diff --git a/R/report_mig_interannual.R b/R/report_mig_interannual.R index a1a25fa9fdc6a30e4ee46174cf3d9d5ea1685c81..0221aa5c70f6707691474dc9befa67a513365612 100644 --- a/R/report_mig_interannual.R +++ b/R/report_mig_interannual.R @@ -28,45 +28,45 @@ #' @aliases report_mig_interannual #' @export setClass( - Class = "report_mig_interannual", - representation = - representation( - dc = "ref_dc", - taxa = "ref_taxa", - stage = "ref_stage", - data = "data.frame", - start_year = "ref_year", - end_year = "ref_year", - calcdata = "list" - ), - prototype = prototype( - dc = new("ref_dc"), - taxa = new("ref_taxa"), - stage = new("ref_stage"), - data = data.frame(), - start_year = new("ref_year"), - end_year = new("ref_year"), - calcdata = list() - ) + Class = "report_mig_interannual", + representation = + representation( + dc = "ref_dc", + taxa = "ref_taxa", + stage = "ref_stage", + data = "data.frame", + start_year = "ref_year", + end_year = "ref_year", + calcdata = "list" + ), + prototype = prototype( + dc = new("ref_dc"), + taxa = new("ref_taxa"), + stage = new("ref_stage"), + data = data.frame(), + start_year = new("ref_year"), + end_year = new("ref_year"), + calcdata = list() + ) ) setValidity("report_mig_interannual", function(object) - { - # if more than one taxa, the connect method will fail when trying to run the write_database for missing data - # also plots have not been developed accordingly - rep1 = ifelse( - length(object@taxa@taxa_selected) == 1, - TRUE, - gettext("report_mig_interannual can only take one taxa", domain = "R-stacomiR") - ) - # same for stage - rep2 = ifelse( - length(object@stage@stage_selected) == 1, - TRUE, - gettext("report_mig_interannual can only take one stage", domain = "R-stacomiR") - ) - # multiple DC are allowed - return(ifelse(rep1 & rep2 , TRUE , c(1:2)[!c(rep1, rep2)])) - }) + { + # if more than one taxa, the connect method will fail when trying to run the write_database for missing data + # also plots have not been developed accordingly + rep1 = ifelse( + length(object@taxa@taxa_selected) == 1, + TRUE, + gettext("report_mig_interannual can only take one taxa", domain = "R-stacomiR") + ) + # same for stage + rep2 = ifelse( + length(object@stage@stage_selected) == 1, + TRUE, + gettext("report_mig_interannual can only take one stage", domain = "R-stacomiR") + ) + # multiple DC are allowed + return(ifelse(rep1 & rep2 , TRUE , c(1:2)[!c(rep1, rep2)])) + }) #' connect method for report_mig_interannual @@ -86,318 +86,318 @@ setValidity("report_mig_interannual", function(object) #' @aliases connect.report_mig_interannual #' @importFrom utils menu setMethod( - "connect", - signature = signature("report_mig_interannual"), - definition = function(object, - silent = FALSE, - check = TRUE) - { - # object<-r_mig_interannual - # object<-bmi_cha - # object<-bmi_des - # object<-r_mig_interannual_vichy - # require(dplyr); require(ggplot2) - #--------------------------------------------------------------------------------------- - # this function will be run several times if missing data or mismatching data are found - # later in the script (hence the encapsulation) - - # if not silent display information about the connection - if (!silent) { - host <- options("stacomiR.host") - funout(gettextf("host:%s", host, domain = "R-StacomiR")) - port <- options("stacomiR.port") - funout(gettextf("port:%s", port, domain = "R-StacomiR")) - # getting the database name - dbname <- options("stacomiR.dbname") - funout(gettextf("dbname:%s", dbname, domain = "R-StacomiR")) - } - - #--------------------------------------------------------------------------------------- - - - fn_connect <- function() { - les_annees = (object@start_year@year_selected):(object@end_year@year_selected) - tax = object@taxa@taxa_selected - std = object@stage@stage_selected - dic = object@dc@dc_selected - requete = new("RequeteDBwhere") - requete@where = paste( - "WHERE bjo_annee IN ", - vector_to_listsql(les_annees), - " AND bjo_tax_code='", - tax, - "' AND bjo_std_code='", - std, - "' AND bjo_dis_identifiant in", - vector_to_listsql(dic), - sep = "" - ) - requete@select = paste( - "SELECT * FROM ", - get_schema(), - "t_bilanmigrationjournalier_bjo", - sep = "" - ) - requete@order_by = " ORDER BY bjo_jour " - requete <- stacomirtools::query(requete) - t_bilanmigrationjournalier_bjo <- requete@query - if (nrow(t_bilanmigrationjournalier_bjo)>0) { - t_bilanmigrationjournalier_bjo <- stacomirtools::killfactor(t_bilanmigrationjournalier_bjo) - } - return(t_bilanmigrationjournalier_bjo) - } - - #--------------------------------------------------------------------------------------- - - object@data <- fn_connect() - if (nrow(object@data) == 0) { - funout( - gettextf("No data in table t_bilanmigrationjournalier_bjo", domain = "R-StacomiR") - ) - check = TRUE - } - #browser() - if (check) { - #---------------------------------------------------------------------- - # Loading a report Annuel to compare numbers - #---------------------------------------------------------------------- - report_annual <- as(object, "report_annual") - report_annual <- connect(report_annual) - #---------------------------------------------------------------------- - # MAIN LOOP, there can be several dic - #---------------------------------------------------------------------- - dic <- object@dc@dc_selected - for (i in 1:length(dic)) { - #i=1 - ############################################ - # function creating a table to compare actual counts with those stored in - # in the t_reportjournalier_bjo table - ########################################### - #========================================== - - fn_check <- function() { - data1 <- - report_annual@data[report_annual@data$ope_dic_identifiant == dic[i], c("effectif", "annee")] - # data from report_migInterannuel - data2 <- object@data[object@data$bjo_dis_identifiant == dic[i], ] - data21 <- - dplyr::select(data2, bjo_annee, bjo_valeur, bjo_labelquantite) - - data22 <- dplyr::group_by(data21, bjo_annee, bjo_labelquantite) - if (nrow(data22) == 0) - data22$bjo_valeur <- as.numeric(data22$bjo_valeur) - data23 <- dplyr::summarize(data22, total = sum(bjo_valeur)) - data24 <- - dplyr::filter(dplyr::ungroup(data23), - bjo_labelquantite == "Effectif_total") - data24 <- dplyr::select(data24, bjo_annee, total) - data24 <- - dplyr::rename(data24, annee = bjo_annee, effectif_bjo = total) - data124 <- merge(data1, - data24, - all.x = TRUE, - all.y = TRUE, - by = "annee") - return(data124) - } - #========================================== - # table with 3 columns : annee; effectif; effectif_bjo - compared_numbers <- fn_check() - # as we have changed the report_annual to split data between years - # some unwanted data might step in outside the year range - # we correct for that - compared_numbers <- compared_numbers[compared_numbers$annee >= object@start_year@year_selected & - compared_numbers$annee <= object@end_year@year_selected, ] - - #------------------------------------------------------------------------------------- - # First test, if missing data, the program will propose to load the data by running report_mig - #------------------------------------------------------------------------------------- - # when data are missing, NA appear in the effectif_bjo column - if (any(is.na(compared_numbers$effectif_bjo))) { - index_missing_years <- which(is.na(compared_numbers$effectif_bjo)) - missing_years <- compared_numbers$annee[index_missing_years] - if (!silent & - length(dic) > 1) - funout(gettextf("DC with missing values : %s ", dic[i], domain = "R-StacomiR")) - if (!silent) - funout(gettextf( - "Years with no value : %s ", - stringr::str_c(missing_years, collapse = "; "), - domain = "R-StacomiR" - )) - if (!silent) - funout( - gettextf( - "Some years are missing in the t_reportjournalier_bjo table, loading them now !", - domain = "R-StacomiR" - ) - ) - - - for (y in 1:length(missing_years)) { - Y <- missing_years[y] - bM = new("report_mig") - if (!silent) - funout(gettextf("Running report_mig for year %s", Y, domain = "R-StacomiR")) - bM = choice_c( - bM, - dc = dic[i], - taxa = object@taxa@taxa_selected, - stage = object@stage@stage_selected, - datedebut = stringr::str_c(Y, "-01-01"), - datefin = stringr::str_c(Y, "-12-31") - ) - bM <- charge(bM, silent = silent) - bM <- connect(bM, silent = silent) - bM <- calcule(bM, silent = silent) - if (nrow(bM@data) > 0) { - # below the argument check_for_bjo is necessary - # as the write database method from report_mig - # uses the connect method from report_mig_interannual and the - # program runs in endless loops... - write_database(bM, silent = silent, check_for_bjo = FALSE) - } - } # end for loop to write new reports - # reloading everything - object@data <- fn_connect() - compared_numbers <- fn_check() - - } # end if any... - - # The method for report annual has been changed and now reports NA when taxa are missing - # we have to remove them otherwise the comparison does not work : - # (!all(round(compared_numbers$effectif) == round(compared_numbers$effectif_bjo))) - compared_numbers$effectif_bjo[is.na(compared_numbers$effectif_bjo)] <- 0 - - #------------------------------------------------------------------------------------- - # Second test, for existing report with different numbers, again the data will be witten again - # if the previous test failed, and user confirmed that there was a problem - # the object@data and compared_numbers are reloaded (see above) - # this test will only be run if the stage is not glass eel, for glass eels it does not make sense - # as some of the "effectif_total" in the bjo table correspond to weights not counts. - #------------------------------------------------------------------------------------- - - if (object@taxa@taxa_selected == 2038 & - object@stage@stage_selected == "CIV") { - if (!silent) - funout( - gettext( - "For glass eel it is not possible to check that data are up to date", - domain = "R-StacomiR" - ) - ) - - } else if (!all(round(compared_numbers$effectif) == round(compared_numbers$effectif_bjo))) { - index_different_years <- - which(round(compared_numbers$effectif) != round(compared_numbers$effectif_bjo)) - differing_years <- compared_numbers$annee[index_different_years] - if (!silent) - funout( - gettextf( - "Years with values differing between t_reportjournalier_bjo and report_annual : %s ", - stringr::str_c(differing_years, collapse = "; "), - domain = "R-StacomiR" - ) - ) - #================================== - reload_years_with_error = function() { - bM = new("report_mig") - for (Y in differing_years) { - # Y=differing_years[1] - funout(gettextf("Running report_mig to correct data for year %s", Y, domain="R-stacomiR")) - bM = choice_c( - bM, - dc = dic[i], - taxa = object@taxa@taxa_selected, - stage = object@stage@stage_selected, - datedebut = stringr::str_c(Y, "-01-01"), - datefin = stringr::str_c(Y, "-12-31") - ) - bM <- charge(bM, silent = silent) - bM <- connect(bM, silent = silent) - bM <- calcule(bM, silent = silent) - # report annual may have different numbers from report mig - # so I'm adding an additional check there - bma_num <- compared_numbers[compared_numbers$annee==Y,"effectif"] - bjo_num <- compared_numbers[compared_numbers$annee==Y,"effectif_bjo"] - bjo_num_new <- sum(bM@calcdata[[stringr::str_c("dc_", dic[i])]][["data"]][,"Effectif_total"]) - if (nrow(bM@data) > 0) { - if (!round(bjo_num_new) == round(bjo_num)){ - # check for bjo will ensure that previous report are deleted - write_database(bM, - silent = silent, - check_for_bjo = TRUE) - } else { - funout( - gettextf( - paste("There is a difference between report_annual Na= %s and report_mig ", - "Nj= %s but the sums are the same between report_mig and the database (t_bilanmigrationjournalier_bjo).", - "This difference is due to migration report overlapping between two years and the program. No writing in the db."), - round(bma_num), round(bjo_num), - domain = "R-StacomiR" - ) - ) - } # end else numbers are equal => do nothing - } # end test nrow - } # end for loop to write new reports - # the data are loaded again - object@data <- fn_connect() - # I need to assign the result one step up (in the environment of the connect function) - assign("object", object, envir = parent.frame(n = 1)) - - } # end reload year with errors - #================================== - - if (!silent) { - choice2 <- - menu( - c("yes", "no"), - graphics = TRUE, - title = gettextf("Data changed, rerun ?", domain = "R-StacomiR") - ) - if (choice2 == 1) - reload_years_with_error() - - } else { - reload_years_with_error() - } - } # secondary check - } # end for - } # end check - #------------------------------------------------------------------------------------- - # Final check for data - # index of data already present in the database - #------------------------------------------------------------------------------------- - les_annees = object@start_year@year_selected:object@end_year@year_selected - index = unique(object@data$bjo_annee) %in% les_annees - # s'il manque des donnees pour certaines annees selectionnnees" - if (!silent) { - if (length(les_annees[!index]) > 0) - { - funout(paste( - gettext( - "Attention, there is no migration summary for these year\n", - domain = "R-stacomiR" - ), - paste(les_annees[!index], collapse = ","), - gettext( - ", this taxa and this stage (report_mig_interannual.r)\n", - domain = "R-stacomiR" - ) - )) - } # end if - - # si toutes les annees sont presentes - if (length(les_annees[index]) > 0) { - funout(paste( - gettext("Interannual migrations query completed", domain = "R-stacomiR"), - paste(les_annees[index], collapse = ","), - "\n" - )) - } - } - return(object) - } + "connect", + signature = signature("report_mig_interannual"), + definition = function(object, + silent = FALSE, + check = TRUE) + { + # object<-r_mig_interannual + # object<-bmi_cha + # object<-bmi_des + # object<-r_mig_interannual_vichy + # require(dplyr); require(ggplot2) + #--------------------------------------------------------------------------------------- + # this function will be run several times if missing data or mismatching data are found + # later in the script (hence the encapsulation) + + # if not silent display information about the connection + if (!silent) { + host <- options("stacomiR.host") + funout(gettextf("host:%s", host, domain = "R-StacomiR")) + port <- options("stacomiR.port") + funout(gettextf("port:%s", port, domain = "R-StacomiR")) + # getting the database name + dbname <- options("stacomiR.dbname") + funout(gettextf("dbname:%s", dbname, domain = "R-StacomiR")) + } + + #--------------------------------------------------------------------------------------- + + + fn_connect <- function() { + les_annees = (object@start_year@year_selected):(object@end_year@year_selected) + tax = object@taxa@taxa_selected + std = object@stage@stage_selected + dic = object@dc@dc_selected + requete = new("RequeteDBwhere") + requete@where = paste( + "WHERE bjo_annee IN ", + vector_to_listsql(les_annees), + " AND bjo_tax_code='", + tax, + "' AND bjo_std_code='", + std, + "' AND bjo_dis_identifiant in", + vector_to_listsql(dic), + sep = "" + ) + requete@select = paste( + "SELECT * FROM ", + get_schema(), + "t_bilanmigrationjournalier_bjo", + sep = "" + ) + requete@order_by = " ORDER BY bjo_jour " + requete <- stacomirtools::query(requete) + t_bilanmigrationjournalier_bjo <- requete@query + if (nrow(t_bilanmigrationjournalier_bjo)>0) { + t_bilanmigrationjournalier_bjo <- stacomirtools::killfactor(t_bilanmigrationjournalier_bjo) + } + return(t_bilanmigrationjournalier_bjo) + } + + #--------------------------------------------------------------------------------------- + + object@data <- fn_connect() + if (nrow(object@data) == 0) { + funout( + gettextf("No data in table t_bilanmigrationjournalier_bjo", domain = "R-StacomiR") + ) + check = TRUE + } + #browser() + if (check) { + #---------------------------------------------------------------------- + # Loading a report Annuel to compare numbers + #---------------------------------------------------------------------- + report_annual <- as(object, "report_annual") + report_annual <- connect(report_annual) + #---------------------------------------------------------------------- + # MAIN LOOP, there can be several dic + #---------------------------------------------------------------------- + dic <- object@dc@dc_selected + for (i in 1:length(dic)) { + #i=1 + ############################################ + # function creating a table to compare actual counts with those stored in + # in the t_reportjournalier_bjo table + ########################################### + #========================================== + + fn_check <- function() { + data1 <- + report_annual@data[report_annual@data$ope_dic_identifiant == dic[i], c("effectif", "annee")] + # data from report_migInterannuel + data2 <- object@data[object@data$bjo_dis_identifiant == dic[i], ] + data21 <- + dplyr::select(data2, bjo_annee, bjo_valeur, bjo_labelquantite) + + data22 <- dplyr::group_by(data21, bjo_annee, bjo_labelquantite) + if (nrow(data22) == 0) + data22$bjo_valeur <- as.numeric(data22$bjo_valeur) + data23 <- dplyr::summarize(data22, total = sum(bjo_valeur)) + data24 <- + dplyr::filter(dplyr::ungroup(data23), + bjo_labelquantite == "Effectif_total") + data24 <- dplyr::select(data24, bjo_annee, total) + data24 <- + dplyr::rename(data24, annee = bjo_annee, effectif_bjo = total) + data124 <- merge(data1, + data24, + all.x = TRUE, + all.y = TRUE, + by = "annee") + return(data124) + } + #========================================== + # table with 3 columns : annee; effectif; effectif_bjo + compared_numbers <- fn_check() + # as we have changed the report_annual to split data between years + # some unwanted data might step in outside the year range + # we correct for that + compared_numbers <- compared_numbers[compared_numbers$annee >= object@start_year@year_selected & + compared_numbers$annee <= object@end_year@year_selected, ] + + #------------------------------------------------------------------------------------- + # First test, if missing data, the program will propose to load the data by running report_mig + #------------------------------------------------------------------------------------- + # when data are missing, NA appear in the effectif_bjo column + if (any(is.na(compared_numbers$effectif_bjo))) { + index_missing_years <- which(is.na(compared_numbers$effectif_bjo)) + missing_years <- compared_numbers$annee[index_missing_years] + if (!silent & + length(dic) > 1) + funout(gettextf("DC with missing values : %s ", dic[i], domain = "R-StacomiR")) + if (!silent) + funout(gettextf( + "Years with no value : %s ", + stringr::str_c(missing_years, collapse = "; "), + domain = "R-StacomiR" + )) + if (!silent) + funout( + gettextf( + "Some years are missing in the t_reportjournalier_bjo table, loading them now !", + domain = "R-StacomiR" + ) + ) + + + for (y in 1:length(missing_years)) { + Y <- missing_years[y] + bM = new("report_mig") + if (!silent) + funout(gettextf("Running report_mig for year %s", Y, domain = "R-StacomiR")) + bM = choice_c( + bM, + dc = dic[i], + taxa = object@taxa@taxa_selected, + stage = object@stage@stage_selected, + datedebut = stringr::str_c(Y, "-01-01"), + datefin = stringr::str_c(Y, "-12-31") + ) + bM <- charge(bM, silent = silent) + bM <- connect(bM, silent = silent) + bM <- calcule(bM, silent = silent) + if (nrow(bM@data) > 0) { + # below the argument check_for_bjo is necessary + # as the write database method from report_mig + # uses the connect method from report_mig_interannual and the + # program runs in endless loops... + write_database(bM, silent = silent, check_for_bjo = FALSE) + } + } # end for loop to write new reports + # reloading everything + object@data <- fn_connect() + compared_numbers <- fn_check() + + } # end if any... + + # The method for report annual has been changed and now reports NA when taxa are missing + # we have to remove them otherwise the comparison does not work : + # (!all(round(compared_numbers$effectif) == round(compared_numbers$effectif_bjo))) + compared_numbers$effectif_bjo[is.na(compared_numbers$effectif_bjo)] <- 0 + + #------------------------------------------------------------------------------------- + # Second test, for existing report with different numbers, again the data will be witten again + # if the previous test failed, and user confirmed that there was a problem + # the object@data and compared_numbers are reloaded (see above) + # this test will only be run if the stage is not glass eel, for glass eels it does not make sense + # as some of the "effectif_total" in the bjo table correspond to weights not counts. + #------------------------------------------------------------------------------------- + + if (object@taxa@taxa_selected == 2038 & + object@stage@stage_selected == "CIV") { + if (!silent) + funout( + gettext( + "For glass eel it is not possible to check that data are up to date", + domain = "R-StacomiR" + ) + ) + + } else if (!all(round(compared_numbers$effectif) == round(compared_numbers$effectif_bjo))) { + index_different_years <- + which(round(compared_numbers$effectif) != round(compared_numbers$effectif_bjo)) + differing_years <- compared_numbers$annee[index_different_years] + if (!silent) + funout( + gettextf( + "Years with values differing between t_reportjournalier_bjo and report_annual : %s ", + stringr::str_c(differing_years, collapse = "; "), + domain = "R-StacomiR" + ) + ) + #================================== + reload_years_with_error = function() { + bM = new("report_mig") + for (Y in differing_years) { + # Y=differing_years[1] + funout(gettextf("Running report_mig to correct data for year %s", Y, domain="R-stacomiR")) + bM = choice_c( + bM, + dc = dic[i], + taxa = object@taxa@taxa_selected, + stage = object@stage@stage_selected, + datedebut = stringr::str_c(Y, "-01-01"), + datefin = stringr::str_c(Y, "-12-31") + ) + bM <- charge(bM, silent = silent) + bM <- connect(bM, silent = silent) + bM <- calcule(bM, silent = silent) + # report annual may have different numbers from report mig + # so I'm adding an additional check there + bma_num <- compared_numbers[compared_numbers$annee==Y,"effectif"] + bjo_num <- compared_numbers[compared_numbers$annee==Y,"effectif_bjo"] + bjo_num_new <- sum(bM@calcdata[[stringr::str_c("dc_", dic[i])]][["data"]][,"Effectif_total"]) + if (nrow(bM@data) > 0) { + if (!round(bjo_num_new) == round(bjo_num)){ + # check for bjo will ensure that previous report are deleted + write_database(bM, + silent = silent, + check_for_bjo = TRUE) + } else { + funout( + gettextf( + paste("There is a difference between report_annual Na= %s and report_mig ", + "Nj= %s but the sums are the same between report_mig and the database (t_bilanmigrationjournalier_bjo).", + "This difference is due to migration report overlapping between two years and the program. No writing in the db."), + round(bma_num), round(bjo_num), + domain = "R-StacomiR" + ) + ) + } # end else numbers are equal => do nothing + } # end test nrow + } # end for loop to write new reports + # the data are loaded again + object@data <- fn_connect() + # I need to assign the result one step up (in the environment of the connect function) + assign("object", object, envir = parent.frame(n = 1)) + + } # end reload year with errors + #================================== + + if (!silent) { + choice2 <- + menu( + c("yes", "no"), + graphics = TRUE, + title = gettextf("Data changed, rerun ?", domain = "R-StacomiR") + ) + if (choice2 == 1) + reload_years_with_error() + + } else { + reload_years_with_error() + } + } # secondary check + } # end for + } # end check + #------------------------------------------------------------------------------------- + # Final check for data + # index of data already present in the database + #------------------------------------------------------------------------------------- + les_annees = object@start_year@year_selected:object@end_year@year_selected + index = unique(object@data$bjo_annee) %in% les_annees + # s'il manque des donnees pour certaines annees selectionnnees" + if (!silent) { + if (length(les_annees[!index]) > 0) + { + funout(paste( + gettext( + "Attention, there is no migration summary for these year\n", + domain = "R-stacomiR" + ), + paste(les_annees[!index], collapse = ","), + gettext( + ", this taxa and this stage (report_mig_interannual.r)\n", + domain = "R-stacomiR" + ) + )) + } # end if + + # si toutes les annees sont presentes + if (length(les_annees[index]) > 0) { + funout(paste( + gettext("Interannual migrations query completed", domain = "R-stacomiR"), + paste(les_annees[index], collapse = ","), + "\n" + )) + } + } + return(object) + } ) #' supprime method for report_mig_interannual class, deletes values in table t_bilanmigrationjournalier_bjo @@ -406,49 +406,49 @@ setMethod( #' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr} #' @aliases supprime.report_mig_interannual setMethod( - "supprime", - signature = signature("report_mig_interannual"), - definition = function(object) - { - # recuperation des annees taxa et stage concernes - les_annees = (object@start_year@year_selected):(object@end_year@year_selected) - tax = object@taxa@taxa_selected - std = object@stage@stage_selected - dic = object@dc@dc_selected - con = new("ConnectionDB") - con <- connect(con) - on.exit(pool::poolClose(con@connection)) - sql = stringr::str_c( - "DELETE from ", - get_schema(), - "t_bilanmigrationjournalier_bjo ", - " WHERE bjo_annee IN (", - paste(les_annees, collapse = ","), - ") AND bjo_tax_code='", - tax, - "' AND bjo_std_code='", - std, - "' AND bjo_dis_identifiant=", - dic - ) - pool::dbExecute(con@connection, statement = sql) - - sql = stringr::str_c( - "DELETE from ", - get_schema(), - "t_bilanmigrationmensuel_bme ", - " WHERE bme_annee IN (", - paste(les_annees, collapse = ","), - ") AND bme_tax_code='", - tax, - "' AND bme_std_code='", - std, - "' AND bme_dis_identifiant=", - dic - ) - pool::dbExecute(con@connection, statement = sql) - return(invisible(NULL)) - } + "supprime", + signature = signature("report_mig_interannual"), + definition = function(object) + { + # recuperation des annees taxa et stage concernes + les_annees = (object@start_year@year_selected):(object@end_year@year_selected) + tax = object@taxa@taxa_selected + std = object@stage@stage_selected + dic = object@dc@dc_selected + con = new("ConnectionDB") + con <- connect(con) + on.exit(pool::poolClose(con@connection)) + sql = stringr::str_c( + "DELETE from ", + get_schema(), + "t_bilanmigrationjournalier_bjo ", + " WHERE bjo_annee IN (", + paste(les_annees, collapse = ","), + ") AND bjo_tax_code='", + tax, + "' AND bjo_std_code='", + std, + "' AND bjo_dis_identifiant=", + dic + ) + pool::dbExecute(con@connection, statement = sql) + + sql = stringr::str_c( + "DELETE from ", + get_schema(), + "t_bilanmigrationmensuel_bme ", + " WHERE bme_annee IN (", + paste(les_annees, collapse = ","), + ") AND bme_tax_code='", + tax, + "' AND bme_std_code='", + std, + "' AND bme_dis_identifiant=", + dic + ) + pool::dbExecute(con@connection, statement = sql) + return(invisible(NULL)) + } ) @@ -460,66 +460,66 @@ setMethod( #' @aliases charge.report_mig_interannual #' @keywords internal setMethod( - "charge", - signature = signature("report_mig_interannual"), - definition = function(object, silent = FALSE) - { - report_mig_interannual <- object - if (exists("ref_dc", envir_stacomi)) { - report_mig_interannual@dc <- get("ref_dc", envir_stacomi) - } else { - funout( - gettext( - "You need to choose a counting device, clic on validate\n", - domain = "R-stacomiR" - ), - arret = TRUE - ) - } - if (exists("ref_taxa", envir_stacomi)) { - report_mig_interannual@taxa <- get("ref_taxa", envir_stacomi) - } else { - funout( - gettext("You need to choose a taxa, clic on validate\n", domain = "R-stacomiR"), - arret = TRUE - ) - } - if (exists("ref_stage", envir_stacomi)) { - report_mig_interannual@stage <- get("ref_stage", envir_stacomi) - } else - { - funout( - gettext("You need to choose a stage, clic on validate\n", domain = "R-stacomiR"), - arret = TRUE - ) - } - if (exists("start_year", envir_stacomi)) { - report_mig_interannual@start_year <- get("start_year", envir_stacomi) - } else { - funout(gettext("You need to choose the starting year\n", domain = "R-stacomiR"), - arret = TRUE) - } - if (exists("end_year", envir_stacomi)) { - report_mig_interannual@end_year <- get("end_year", envir_stacomi) - } else { - funout(gettext("You need to choose the ending year\n", domain = "R-stacomiR"), - arret = TRUE) - } - # this will test that only one taxa and one stage have been loaded (multiple dc are allowed) - validObject(report_mig_interannual) - assign("report_mig_interannual", - report_mig_interannual, - envir_stacomi) - if (!silent) - funout( - gettext( - "Writing report_mig_interannual in the environment envir_stacomi : write r_mig_interannual=get('report_mig_interannual',envir_stacomi) ", - domain = "R-stacomiR" - ) - ) - - return(report_mig_interannual) - } + "charge", + signature = signature("report_mig_interannual"), + definition = function(object, silent = FALSE) + { + report_mig_interannual <- object + if (exists("ref_dc", envir_stacomi)) { + report_mig_interannual@dc <- get("ref_dc", envir_stacomi) + } else { + funout( + gettext( + "You need to choose a counting device, clic on validate\n", + domain = "R-stacomiR" + ), + arret = TRUE + ) + } + if (exists("ref_taxa", envir_stacomi)) { + report_mig_interannual@taxa <- get("ref_taxa", envir_stacomi) + } else { + funout( + gettext("You need to choose a taxa, clic on validate\n", domain = "R-stacomiR"), + arret = TRUE + ) + } + if (exists("ref_stage", envir_stacomi)) { + report_mig_interannual@stage <- get("ref_stage", envir_stacomi) + } else + { + funout( + gettext("You need to choose a stage, clic on validate\n", domain = "R-stacomiR"), + arret = TRUE + ) + } + if (exists("start_year", envir_stacomi)) { + report_mig_interannual@start_year <- get("start_year", envir_stacomi) + } else { + funout(gettext("You need to choose the starting year\n", domain = "R-stacomiR"), + arret = TRUE) + } + if (exists("end_year", envir_stacomi)) { + report_mig_interannual@end_year <- get("end_year", envir_stacomi) + } else { + funout(gettext("You need to choose the ending year\n", domain = "R-stacomiR"), + arret = TRUE) + } + # this will test that only one taxa and one stage have been loaded (multiple dc are allowed) + validObject(report_mig_interannual) + assign("report_mig_interannual", + report_mig_interannual, + envir_stacomi) + if (!silent) + funout( + gettext( + "Writing report_mig_interannual in the environment envir_stacomi : write r_mig_interannual=get('report_mig_interannual',envir_stacomi) ", + domain = "R-stacomiR" + ) + ) + + return(report_mig_interannual) + } ) #' command line interface for report_mig_interannual class @@ -536,216 +536,216 @@ setMethod( #' @aliases choice_c.report_mig_interannual #' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr} setMethod( - "choice_c", - signature = signature("report_mig_interannual"), - definition = function(object, - dc, - taxa, - stage, - start_year, - end_year, - silent = FALSE) { - # code for debug using example - #report_mig_interannual<-r_mig_interannual;dc=c(16);taxa="Anguilla anguilla";stage=c("AGJ");start_year="1984";end_year="2016" - report_mig_interannual <- object - report_mig_interannual@dc = charge(report_mig_interannual@dc) - # loads and verifies the dc - # this will set dc_selected slot - report_mig_interannual@dc <- - choice_c(object = report_mig_interannual@dc, dc) - # only taxa present in the report_mig are used - report_mig_interannual@taxa <- - charge_with_filter(object = report_mig_interannual@taxa, report_mig_interannual@dc@dc_selected) - report_mig_interannual@taxa <- - choice_c(report_mig_interannual@taxa, taxa) - report_mig_interannual@stage <- - charge_with_filter( - object = report_mig_interannual@stage, - report_mig_interannual@dc@dc_selected, - report_mig_interannual@taxa@taxa_selected - ) - report_mig_interannual@stage <- - choice_c(report_mig_interannual@stage, stage) - # depending on report_object the method will load data and issue a warning if data are not present - # this is the first step, the second verification will be done in method connect - - report_mig_interannual@start_year <- - charge(object = report_mig_interannual@start_year, - objectreport = "report_mig_interannual") - report_mig_interannual@start_year <- - choice_c( - object = report_mig_interannual@start_year, - nomassign = "start_year", - annee = start_year, - silent = silent - ) - report_mig_interannual@end_year@data <- - report_mig_interannual@start_year@data - report_mig_interannual@end_year <- - choice_c( - object = report_mig_interannual@end_year, - nomassign = "end_year", - annee = end_year, - silent = silent - ) - assign("report_mig_interannual", report_mig_interannual, envir = envir_stacomi) - return(report_mig_interannual) - } + "choice_c", + signature = signature("report_mig_interannual"), + definition = function(object, + dc, + taxa, + stage, + start_year, + end_year, + silent = FALSE) { + # code for debug using example + #report_mig_interannual<-r_mig_interannual;dc=c(16);taxa="Anguilla anguilla";stage=c("AGJ");start_year="1984";end_year="2016" + report_mig_interannual <- object + report_mig_interannual@dc = charge(report_mig_interannual@dc) + # loads and verifies the dc + # this will set dc_selected slot + report_mig_interannual@dc <- + choice_c(object = report_mig_interannual@dc, dc) + # only taxa present in the report_mig are used + report_mig_interannual@taxa <- + charge_with_filter(object = report_mig_interannual@taxa, report_mig_interannual@dc@dc_selected) + report_mig_interannual@taxa <- + choice_c(report_mig_interannual@taxa, taxa) + report_mig_interannual@stage <- + charge_with_filter( + object = report_mig_interannual@stage, + report_mig_interannual@dc@dc_selected, + report_mig_interannual@taxa@taxa_selected + ) + report_mig_interannual@stage <- + choice_c(report_mig_interannual@stage, stage) + # depending on report_object the method will load data and issue a warning if data are not present + # this is the first step, the second verification will be done in method connect + + report_mig_interannual@start_year <- + charge(object = report_mig_interannual@start_year, + objectreport = "report_mig_interannual") + report_mig_interannual@start_year <- + choice_c( + object = report_mig_interannual@start_year, + nomassign = "start_year", + annee = start_year, + silent = silent + ) + report_mig_interannual@end_year@data <- + report_mig_interannual@start_year@data + report_mig_interannual@end_year <- + choice_c( + object = report_mig_interannual@end_year, + nomassign = "end_year", + annee = end_year, + silent = silent + ) + assign("report_mig_interannual", report_mig_interannual, envir = envir_stacomi) + return(report_mig_interannual) + } ) #' calcule method for report_mig_interannual #' #' Performs the calculation of seasonal coefficients for the plot(plot.type="seasonal") method. The numbers -#' are split according to the period chosen, one of "day","week","month","2 weeks", French labels are also +#' are split according to the period chosen, one of "day","week","fortnight","month", French labels are also #' accepted as arguments. Once this is done, the seasonality of the migration is displayed using the day when the #' first fish was seen, then the days (or period) corresponding to 5, 50 , 95, and 100 percent of the migration. #' The duration of 90% of the migraton between Q5 and Q95 is also of interest. #' #' @param object An object of class \link{report_mig_interannual-class} #' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors -#' @param timesplit One of "day","week","month","2 weeks", "jour","semaine","quinzaine","mois" +#' @param timesplit One of "day","week","month","fortnight", "jour","semaine","quinzaine","mois" #' @note The class report_mig_interannual does not handle escapement rates nor #' 'devenir' i.e. the destination of the fishes. #' @return An object of class \link{report_mig_interannual-class} with calcdata slot filled. #' @aliases calcule.report_mig_interannual #' @author Marion Legrand setMethod( - "calcule", - signature = signature("report_mig_interannual"), - definition = function(object, - silent = FALSE, - timesplit = "mois") { - report_mig_interannual <- object - #report_mig_interannual<-r_mig_interannual - #report_mig_interannual<-r_mig_interannual_vichy;silent=FALSE;timesplit="mois" - #require(dplyr) - if (!timesplit %in% c("jour", - "day", - "month", - "mois", - "week", - "semaine", - "quinzaine", - "2 weeks")) - stop ( - stringr::str_c( - "timesplit should be one of :", - "jour ", - "day ", - "month ", - "mois ", - "week ", - "semaine ", - "month ", - "mois ", - "quinzaine ", - "2 weeks " - ) - ) - # back to French labels for consistency with fun_report_mig_interannual code - timesplit <- - switch( - timesplit, - "day" = "jour_365", - "jour" = "jour_365", - "week" = "semaine", - "month" = "mois", - "2 weeks" = "quinzaine", - timesplit - ) - # there should be just one station, this will be tested - station <- report_mig_interannual@dc@station - taxa <- report_mig_interannual@taxa@taxa_selected - stage <- report_mig_interannual@stage@stage_selected - if (length(unique(report_mig_interannual@dc@station)) != 1) - stop( - "You have more than one station in the report, the dc from the report should belong to the same station" - ) - if (nrow(report_mig_interannual@data) == 0) - stop( - "No rows in report_mig_interannual@data, nothing to run calculations on, you should run a report_mig_mult on this dc first" - ) - - datadic <- report_mig_interannual@data[report_mig_interannual@data$bjo_labelquantite == - "Effectif_total", ] - datadic <- - fun_date_extraction( - datadic, - nom_coldt = "bjo_jour", - jour_an = TRUE, - quinzaine = TRUE - ) - datadic <- killfactor(datadic) - # here this code avoids the following problem :Error: (list) object cannot be coerced to type 'double' - # data is subsetted for columns not containing bjo, and apply is run on each of the column - datadic[, colnames(datadic)[!grepl("bjo_", colnames(datadic))]] <- - apply( - X = datadic[, colnames(datadic)[!grepl("bjo_", colnames(datadic))]], - MARGIN = 2, - FUN = function(X) - as.numeric(X) - ) - fnquant <- - function(data, - timesplit = "jour_365", - probs = c(0, .05, .5, .95, 1)) { - # if there is just a single line, crashes, so reports exactly the same for all values - if (nrow(data) == 1) { - res <- c( - "0%" = data[, timesplit], - "5%" = data[, timesplit], - "50%" = data[, timesplit], - "95%" = data[, timesplit], - "100%" = data[, timesplit] - ) - } else { - res <- Hmisc::wtd.quantile( - x = data[, timesplit], - weights = abs(data$bjo_valeur), - probs = probs - ) - return(res) - } - } - #fnquant(datadic[datadic$bjo_annee==2012,],"mois") - # for some reasons this code does not work : Error in x + weights : non-numeric argument to binary operator - # dat<-dplyr::select_(datadic,"bjo_annee","bjo_dis_identifiant","bjo_tax_code","bjo_std_code","bjo_valeur",timesplit)%>% - # dplyr::group_by_("bjo_annee","bjo_tax_code","bjo_std_code") - # dat2<-dat%>% do(res=fnquant(data=.,timesplit=timesplit,probs=c(0, .05, .5, .95, 1))) - # dat3<-dat2%>%summarize(bjo_annee,bjo_tax_code,bjo_std_code,Q0=res[[1]],Q5=res[[2]], - # Q50=res[[3]],Q95=res[[4]],Q100=res[[5]]) - # this simple code will do : - dat <- list() - for (i in unique(datadic$bjo_annee)) { - dat[[i]] <- - fnquant(data = datadic[datadic$bjo_annee == i, ], timesplit = timesplit) - } - dat <- as.data.frame(matrix(unlist(dat), ncol = 5, byrow = TRUE)) - colnames(dat) <- c("Q0", "Q5", "Q50", "Q95", "Q100") - dat$d90 <- dat$Q95 - dat$Q5 - dat$year = unique(datadic$bjo_annee) - dat$taxa = taxa - dat$stage = stage - dat$station = unique(station) - dat$timesplit = timesplit - dat <- - dat[, c( - "year", - "station", - "taxa", - "stage", - "Q0", - "Q5", - "Q50", - "Q95", - "Q100", - "d90", - "timesplit" - )] - report_mig_interannual@calcdata <- dat - return(report_mig_interannual) - } + "calcule", + signature = signature("report_mig_interannual"), + definition = function(object, + silent = FALSE, + timesplit = "mois") { + report_mig_interannual <- object + #report_mig_interannual<-r_mig_interannual + #report_mig_interannual<-r_mig_interannual_vichy;silent=FALSE;timesplit="mois" + #require(dplyr) + if (!timesplit %in% c("jour", + "day", + "month", + "mois", + "week", + "semaine", + "quinzaine", + "fortnight")) + stop ( + stringr::str_c( + "timesplit should be one of :", + "jour ", + "day ", + "month ", + "mois ", + "week ", + "semaine ", + "month ", + "mois ", + "quinzaine ", + "fortnight " + ) + ) + # back to French labels for consistency with fun_report_mig_interannual code + timesplit <- + switch( + timesplit, + "day" = "jour_365", + "jour" = "jour_365", + "week" = "semaine", + "month" = "mois", + "fortnight" = "quinzaine", + timesplit + ) + # there should be just one station, this will be tested + station <- report_mig_interannual@dc@station + taxa <- report_mig_interannual@taxa@taxa_selected + stage <- report_mig_interannual@stage@stage_selected + if (length(unique(report_mig_interannual@dc@station)) != 1) + stop( + "You have more than one station in the report, the dc from the report should belong to the same station" + ) + if (nrow(report_mig_interannual@data) == 0) + stop( + "No rows in report_mig_interannual@data, nothing to run calculations on, you should run a report_mig_mult on this dc first" + ) + + datadic <- report_mig_interannual@data[report_mig_interannual@data$bjo_labelquantite == + "Effectif_total", ] + datadic <- + fun_date_extraction( + datadic, + nom_coldt = "bjo_jour", + jour_an = TRUE, + quinzaine = TRUE + ) + datadic <- killfactor(datadic) + # here this code avoids the following problem :Error: (list) object cannot be coerced to type 'double' + # data is subsetted for columns not containing bjo, and apply is run on each of the column + datadic[, colnames(datadic)[!grepl("bjo_", colnames(datadic))]] <- + apply( + X = datadic[, colnames(datadic)[!grepl("bjo_", colnames(datadic))]], + MARGIN = 2, + FUN = function(X) + as.numeric(X) + ) + fnquant <- + function(data, + timesplit = "jour_365", + probs = c(0, .05, .5, .95, 1)) { + # if there is just a single line, crashes, so reports exactly the same for all values + if (nrow(data) == 1) { + res <- c( + "0%" = data[, timesplit], + "5%" = data[, timesplit], + "50%" = data[, timesplit], + "95%" = data[, timesplit], + "100%" = data[, timesplit] + ) + } else { + res <- Hmisc::wtd.quantile( + x = data[, timesplit], + weights = abs(data$bjo_valeur), + probs = probs + ) + return(res) + } + } + #fnquant(datadic[datadic$bjo_annee==2012,],"mois") + # for some reasons this code does not work : Error in x + weights : non-numeric argument to binary operator + # dat<-dplyr::select_(datadic,"bjo_annee","bjo_dis_identifiant","bjo_tax_code","bjo_std_code","bjo_valeur",timesplit)%>% + # dplyr::group_by_("bjo_annee","bjo_tax_code","bjo_std_code") + # dat2<-dat%>% do(res=fnquant(data=.,timesplit=timesplit,probs=c(0, .05, .5, .95, 1))) + # dat3<-dat2%>%summarize(bjo_annee,bjo_tax_code,bjo_std_code,Q0=res[[1]],Q5=res[[2]], + # Q50=res[[3]],Q95=res[[4]],Q100=res[[5]]) + # this simple code will do : + dat <- list() + for (i in unique(datadic$bjo_annee)) { + dat[[i]] <- + fnquant(data = datadic[datadic$bjo_annee == i, ], timesplit = timesplit) + } + dat <- as.data.frame(matrix(unlist(dat), ncol = 5, byrow = TRUE)) + colnames(dat) <- c("Q0", "Q5", "Q50", "Q95", "Q100") + dat$d90 <- dat$Q95 - dat$Q5 + dat$year = unique(datadic$bjo_annee) + dat$taxa = taxa + dat$stage = stage + dat$station = unique(station) + dat$timesplit = timesplit + dat <- + dat[, c( + "year", + "station", + "taxa", + "stage", + "Q0", + "Q5", + "Q50", + "Q95", + "Q100", + "d90", + "timesplit" + )] + report_mig_interannual@calcdata <- dat + return(report_mig_interannual) + } ) #' statistics per time period @@ -755,115 +755,119 @@ setMethod( #' #' @param dat a data frame with columns ("bjo_annee","bjo_jour","bjo_labelquantite","bjo_valeur") #' @param year The year to exclude from the historical series (it will be plotted against the historical series) -#' @param timesplit "week" "2 weeks" "month" as provided to seq.POSIXt, default NULL +#' @param timesplit "day", "week" "fortnight" "month" as provided to seq.POSIXt, default "day" #' @return a data frame with mean, max, and min calculated for each timesplit #' @export fun_report_mig_interannual = function(dat, - year = NULL, - timesplit = NULL) + year = NULL, + timesplit = "day") { - if (nrow(dat) > 0) - { - dat <- dat[dat$bjo_labelquantite == "Effectif_total", ] - dat <- - stacomirtools::chnames( - dat, - c( - "bjo_annee", - "bjo_jour", - "bjo_labelquantite", - "bjo_valeur" - ), - c("year", "day", "labelquantity", "value") - ) - dat <- dat[, c("year", "day", "value")] - if (!is.null(year)) { - dat <- dat[dat$year != year, ] - } - dat$day <- trunc.POSIXt(dat$day, digits = 'days') - dat$day <- as.Date(strptime(strftime(dat$day, '2000-%m-%d'), '%Y-%m-%d')) - - - if (!is.null(timesplit)) { - seq_timesplit <- seq.POSIXt( - from = strptime("2000-01-01", format = '%Y-%m-%d'), - to = strptime("2000-12-31", format = '%Y-%m-%d'), - by = timesplit - ) - seq_timesplit <- as.Date(trunc(seq_timesplit, digits = 'days')) - dat[, timesplit] <- dat$day - for (j in 1:(length(seq_timesplit) - 1)) { - dat[dat$day >= seq_timesplit[j] & - dat$day < seq_timesplit[j + 1], timesplit] <- - seq_timesplit[j] - } - dat[dat$day >= seq_timesplit[length(seq_timesplit)], timesplit] <- - seq_timesplit[length(seq_timesplit)] - dat[, "interv"] <- paste(dat[, "year"], dat[, timesplit]) - res <- tapply(dat$value, dat[, "interv"], sum, na.rm = TRUE) - datc <- - data.frame( - "year" = substr(names(res), 1, 4), - timesplit = substr(names(res), 5, 15), - "value" = as.numeric(res) - ) - colnames(datc)[2] <- timesplit - dat <- datc - rm(datc) - } else { - # if null default value is day - timesplit <- "day" - day2000 <- as.Date(seq.POSIXt( - from = strptime("2000-01-01", format = '%Y-%m-%d'), - to = strptime("2000-12-31", format = '%Y-%m-%d'), - by = "day" - )) - for (j in unique(dat$year)) { - # days without report are added with a zero - day2000remaining <- - day2000[!day2000 %in% dat[dat$year == j, "day"]] - dat0 <- data.frame("day" = day2000remaining, - "year" = j, - "value" = NA) - dat <- rbind(dat, dat0) - } # end for - } - - maxdat <- - suppressWarnings(tapply(dat$value, as.character(dat[, timesplit]), max, na.rm = - TRUE)) - mindat <- - suppressWarnings(tapply(dat$value, as.character(dat[, timesplit]), min, na.rm = - TRUE)) - meandat <- - suppressWarnings(tapply(dat$value, as.character(dat[, timesplit]), mean, na.rm = - TRUE)) - datsummary <- - data.frame("maxtab" = maxdat, - "mintab" = mindat, - "mean" = meandat) - datsummary <- - datsummary[!is.infinite(datsummary$maxtab), ]# the minimum and max of empty set are -Inf and Inf respectively - datsummary[, timesplit] <- names(maxdat)[!is.infinite(maxdat)] - dat[, timesplit] <- as.character(dat[, timesplit]) - dat <- merge(dat, datsummary, by = timesplit) - dat[, timesplit] <- - as.POSIXct(strptime(dat[, timesplit], format = '%Y-%m-%d')) # le format Posixct est necessaire pour les ggplot - rm(maxdat, mindat, meandat) - dat <- dat[order(dat$year, dat[, timesplit]), ] - # this return the first occurence for each day, - # for any day , min, max and mean are OK - return(dat) - - } else { - funout( - gettext( - "Attention : you have to complete a migration summary for at least one of the selected year before launching a inter-annual summary", - domain = "R-stacomiR" - ), - arret = TRUE - ) - }# end else + if (nrow(dat) > 0) + { + dat <- dat[dat$bjo_labelquantite == "Effectif_total", ] + dat <- + stacomirtools::chnames( + dat, + c( + "bjo_annee", + "bjo_jour", + "bjo_labelquantite", + "bjo_valeur" + ), + c("year", "day", "labelquantity", "value") + ) + dat <- dat[, c("year", "day", "value")] + if (!is.null(year)) { + dat <- dat[dat$year != year, ] + } + # everything is truncated to "day" from year 2000 + dat$day <- trunc.POSIXt(dat$day, digits = 'days') + dat$day <- as.Date(strptime(strftime(dat$day, '2000-%m-%d'), '%Y-%m-%d')) + + + if ((timesplit !="day")) { + seq_timesplit <- seq.POSIXt( + from = strptime("2000-01-01", format = '%Y-%m-%d'), + to = strptime("2000-12-31", format = '%Y-%m-%d'), + by = ifelse(timesplit=="fortnight","2 weeks",timesplit) + ) + seq_timesplit <- as.Date(trunc(seq_timesplit, digits = 'days')) + dat[, timesplit] <- dat$day + # replace values within timesplit by timesplit + for (j in 1:(length(seq_timesplit) - 1)) { + dat[dat$day >= seq_timesplit[j] & + dat$day < seq_timesplit[j + 1], timesplit] <- + seq_timesplit[j] + } + # for the last + dat[dat$day >= seq_timesplit[length(seq_timesplit)], timesplit] <- + seq_timesplit[length(seq_timesplit)] + # interv corresponds to the name year + timesplit + dat[, "interv"] <- paste(dat[, "year"], dat[, timesplit]) + res <- tapply(dat$value, dat[, "interv"], sum, na.rm = TRUE) + datc <- + data.frame( + "year" = substr(names(res), 1, 4), + timesplit = substr(names(res), 5, 15), + "value" = as.numeric(res) + ) + colnames(datc)[2] <- timesplit + dat <- datc + rm(datc) + } else { + # value is day + timesplit <- "day" + day2000 <- as.Date(seq.POSIXt( + from = strptime("2000-01-01", format = '%Y-%m-%d'), + to = strptime("2000-12-31", format = '%Y-%m-%d'), + by = "day" + )) + for (j in unique(dat$year)) { + # days without report are added with a zero + day2000remaining <- + day2000[!day2000 %in% dat[dat$year == j, "day"]] + dat0 <- data.frame("day" = day2000remaining, + "year" = j, + "value" = NA) + dat <- rbind(dat, dat0) + } # end for + } + + maxdat <- + suppressWarnings(tapply(dat$value, as.character(dat[, timesplit]), max, na.rm = + TRUE)) + mindat <- + suppressWarnings(tapply(dat$value, as.character(dat[, timesplit]), min, na.rm = + TRUE)) + meandat <- + suppressWarnings(tapply(dat$value, as.character(dat[, timesplit]), mean, na.rm = + TRUE)) + datsummary <- + data.frame("maxtab" = maxdat, + "mintab" = mindat, + "mean" = meandat) + datsummary <- + datsummary[!is.infinite(datsummary$maxtab), ]# the minimum and max of empty set are -Inf and Inf respectively + datsummary[, timesplit] <- names(maxdat)[!is.infinite(maxdat)] + dat[, timesplit] <- as.character(dat[, timesplit]) + dat <- merge(dat, datsummary, by = timesplit) + dat[, timesplit] <- + as.POSIXct(strptime(dat[, timesplit], format = '%Y-%m-%d')) # le format Posixct est necessaire pour les ggplot + rm(maxdat, mindat, meandat) + dat <- dat[order(dat$year, dat[, timesplit]), ] + # this return the first occurence for each day, + # for any day , min, max and mean are OK + return(dat) + + } else { + funout( + gettext( + "Attention : you have to complete a migration summary for at least one of the selected year before launching a inter-annual summary", + domain = "R-stacomiR" + ), + arret = TRUE + ) + }# end else } #' Plot method for report_mig_interannual @@ -873,8 +877,9 @@ fun_report_mig_interannual = function(dat, #' saturday, the last day of the week. #' @param x An object of class \link{report_mig_interannual-class} #' @param plot.type Default standard -#' @param timesplit Used for plot.type barchart or dotplot, Default month other possible values are day, week, 2 weeks, month +#' @param timesplit Used for plot.type barchart or dotplot, Default month other possible values are day, week, fortnight, month #' French values "jour" "semaine" "quinzaine" "mois" are also accepted. +#' @param selected_year The year to compare the interannual bilan with, valid for step, barchart, pointrange, line, standard. #' @param silent Stops displaying the messages. #' \itemize{ #' \item{plot.type="line": one line per daily report_mig} @@ -892,897 +897,826 @@ fun_report_mig_interannual = function(dat, #' @aliases plot.report_mig_interannual #' @export setMethod( - "plot", - signature(x = "report_mig_interannual", y = "missing"), - definition = function(x, - plot.type = "standard", - timesplit = "month", - silent = FALSE) { - #report_mig_interannual<-r_mig_interannual - report_mig_interannual <- x - if (!timesplit %in% c( - "jour", - "day", - "month", - "mois", - "week", - "semaine", - "month", - "mois", - "quinzaine", - "2 weeks" - )) - stop ( - stringr::str_c( - "timesplit should be one of :", - "jour ", - "day ", - "month ", - "mois ", - "week ", - "semaine ", - "month ", - "mois ", - "quinzaine ", - "2 weeks " - ) - ) - # back to French labels for consistency with fun_report_mig_interannual code - timesplit <- - switch( - timesplit, - "jour" = "day", - "semaine" = "week", - "mois" = "month", - "quinzaine"= "2 weeks", - timesplit - ) - - # plot.type="line";require(ggplot2) - - if (nrow(report_mig_interannual@data) > 0) { - - if (plot.type == "line") { - dat <- report_mig_interannual@data - dat <- dat[dat$bjo_labelquantite == "Effectif_total", ] - dat <- stacomirtools::chnames( - dat, - c( - "bjo_annee", - "bjo_jour", - "bjo_labelquantite", - "bjo_valeur" - ), - c("year", "day", "labelquantity", "value") - ) - # we need to choose a date, every year brought back to 2000 - dat$day <- as.POSIXct(strptime(strftime(dat$day, - '2000-%m-%d %H:%M:%S'), - format = '%Y-%m-%d %H:%M:%S'), tz = "GMT") - dat$year <- as.factor(dat$year) - dat <- stacomirtools::killfactor(dat) - titre = paste( - gettext("Migration ", domain="R-stacomiR"), - paste(min(dat$year), max(dat$year), collapse = "-"), - ", ", - paste(report_mig_interannual@dc@data$dis_commentaires[report_mig_interannual@dc@data$dc %in% - report_mig_interannual@dc@dc_selected], collapse="+"), - sep="" - ) - soustitre = paste( - report_mig_interannual@taxa@data[ - report_mig_interannual@taxa@data$tax_code %in% - report_mig_interannual@taxa@taxa_selected, - "tax_nom_latin"], - ", ", - report_mig_interannual@stage@data[ - report_mig_interannual@stage@data$std_code %in% - report_mig_interannual@stage@stage_selected, - "std_libelle"], - ", ", - sep = "" - ) - g <- ggplot(dat, aes(x = day, y = value)) - g <- - g + geom_line(aes(color = year)) + labs(title = paste(titre, "\n", soustitre)) + - scale_x_datetime(name = "date", date_breaks = "1 month", - date_labels = "%b") + - theme_bw() - print(g) - assign("g", g, envir = envir_stacomi) - if (!silent) - funout( - gettext( - "Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n", - domain = "R-stacomiR" - ) - ) - #---------------------------------------------- - } else if (plot.type == "standard") { - dat <- report_mig_interannual@data - if (silent == FALSE) { - the_choice <- - as.numeric( - select.list( - choices = as.character(unique(dat$bjo_annee)[order(unique(dat$bjo_annee))]), - preselect = as.character(max(dat$bjo_annee)), - gettext("Year choice", domain="R-stacomiR"), - multiple = FALSE - ) - ) - } else { - the_choice <- max(dat$bjo_annee) - } - # dataset for current year - dat0 <- - fun_report_mig_interannual(dat, year = NULL, timesplit = NULL) - dat <- - fun_report_mig_interannual(dat, year = the_choice, timesplit = NULL) - dat <- - dat[dat$mean != 0, ] # pour des raisons graphiques on ne garde pas les effectifs nuls generes par fun_report_mig_interannual - newdat <- - dat[match(unique(as.character(dat$day)), as.character(dat$day)), ] - newdat <- - newdat[order(newdat$day), ] # pour avoir les range sur l'ensemble des valeurs dispo et pas seult l'annee en cours - amplitude = paste(min(as.numeric(as.character(dat$year))), "-", max(as.numeric(as.character(dat$year))), sep = - "") - if (length(the_choice) > 0) { - vplayout <- - function(x, y) { - grid::viewport(layout.pos.row = x, - layout.pos.col = y) - } - grid::grid.newpage() - grid::pushViewport(grid::viewport(layout = grid::grid.layout(length(the_choice), 1, just = - "center"))) - amplitudechoice <- paste(the_choice, '/', amplitude) - tmp <- dat0[as.numeric(as.character(dat0$year)) == the_choice, ] - tmp$year <- as.character(tmp$year) - g <- ggplot(newdat, aes(x = day)) - g <- - g + geom_ribbon( - aes( - ymin = mintab, - ymax = maxtab, - fill = "amplitude" - ), - color = "grey20", - alpha = 0.5 - ) - g <- - g + geom_bar( - aes(y = value, fill = I("orange")), - position = "dodge", - stat = "identity", - color = "grey20", - alpha = 0.8, - data = tmp - ) - g <- - g + scale_fill_manual( - name = eval(amplitudechoice), - values = c("#35789C", "orange"), - labels = c( - gettext("Historical amplitude", domain = "R-StacomiR"), - the_choice - ) - ) - #g <- g+geom_point(aes(y=value,col=year),data=tmp,pch=16,size=1) - # moyenne interannuelle - - g <- g + geom_line(aes(y = mean, col = I("#002743")), data = newdat) - g <- - g + geom_point(aes(y = mean, col = I("#002743")), - size = 1.2, - data = newdat) - g <- - g + scale_colour_manual( - name = eval(amplitudechoice), - values = c("#002743"), - labels = c(stringr::str_c( - gettext("Interannual mean\n", domain = "R-stacomiR"), - amplitude - )) - ) + - guides(fill = guide_legend(reverse = TRUE)) - g <- - g + labs( - title = paste( - paste(report_mig_interannual@dc@dc_selected,collapse="+"), - report_mig_interannual@taxa@data[ - report_mig_interannual@taxa@data$tax_code %in% - report_mig_interannual@taxa@taxa_selected, - "tax_nom_latin"], - ",", - report_mig_interannual@stage@data[ - report_mig_interannual@stage@data$std_code %in% - report_mig_interannual@stage@stage_selected, - "std_libelle"], - ",", - the_choice, - "/", - amplitude - ) - ) - g <- - g + scale_x_datetime( - name = "date", - date_breaks = "months", - date_minor_breaks = "weeks", - date_labels = "%d-%m" - ) - g <- g + theme_bw() + theme(legend.key = element_blank()) - print(g, vp = vplayout(1, 1)) - assign(paste("g", 1, sep = ""), g, envir_stacomi) - if (!silent) - funout( - gettextf( - "Writing the graphical object into envir_stacomi environment : write g=get(\"gi\",envir_stacomi) with i=%s", - paste(1:length(the_choice), collapse = ",") - ) - ) - - - } # end if plot==standard - #---------------------------------------------- - } else if (plot.type == "step") { - dat <- report_mig_interannual@data - dat <- fun_report_mig_interannual(dat) - # runs the default with daily migration - #dat=dat[order(dat$year,dat$day),] - dat$value[is.na(dat$value)] <-0 - # otherwise if only one line it may crash - if (silent == FALSE) { - the_choice <- select.list( - choices = as.character(unique(dat$year)), - preselect = as.character(max(dat$year)), - multiple = FALSE, - title = gettext("Choose year", domain = "R-StacomirR") - ) - } else { - the_choice <- max(as.numeric(as.character(dat$year))) - } - amplitude <- paste(min(as.numeric(as.character(dat$year))), - "-", max(as.numeric(as.character(dat$year))), sep = "") - ################# - # calculation of cumsums - ################### - - for (an in unique(dat$year)) { - # an=as.character(unique(dat$year)) ;an<-an[1] - dat[dat$year == an, "cumsum"] <- - cumsum(dat[dat$year == an, "value"]) - dat[dat$year == an, "total_annuel"] <- - max(dat[dat$year == an, "cumsum"]) - } - dat$cumsum <- dat$cumsum / dat$total_annuel - dat$day <- as.Date(dat$day) - dat$year <- as.factor(dat$year) - - ################# - # plot - ################### - - g <- ggplot(dat, aes(x = day, y = cumsum)) - tmp <- - dat[as.numeric(as.character(dat$year)) == as.numeric(the_choice), ] - g <- g + geom_step(aes(col = year, size = total_annuel)) - g <- g + geom_step(data = tmp, - col = "black", - lty = 2) - g <- - g + labs( - title = gettextf( - "%s, %s, %s cum %s", - paste(report_mig_interannual@dc@dc_selected, collapse="+"), - report_mig_interannual@taxa@data[ - report_mig_interannual@taxa@data$tax_code %in% - report_mig_interannual@taxa@taxa_selected, - "tax_nom_latin"], - report_mig_interannual@stage@data[ - report_mig_interannual@stage@data$std_code %in% - report_mig_interannual@stage@stage_selected, - "std_libelle"], - amplitude - ) - ) - g <- - g + scale_y_continuous(name = gettext("Annual migration percentage", domain = - "R-stacomiR")) - g <- - g + scale_x_date( - name = gettext("date", domain = "R-stacomiR"), - date_breaks = "months", - date_minor_breaks = "weeks", - date_labels = "%b", - limits = range(dat[dat$value > 0 & - dat$cumsum != 1, "day"]) - )# date - g <- - g + scale_colour_hue( - name = gettext("year", domain = "R-stacomiR"), - l = 70, - c = 150 - )# year - print(g) - assign("g", g, envir_stacomi) - if (!silent) - funout( - gettext( - "Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n", - domain = "R-stacomiR" - ) - ) - #---------------------------------------------- - } else if (plot.type == "barchart") { - dat = report_mig_interannual@data - if (silent == FALSE) { - the_choice = select.list( - choices = as.character(unique(dat$bjo_annee)), - preselect = as.character(max(dat$bjo_annee)), - multiple = FALSE, - title = gettext("Choose year", domain = "R-StacomiR") - ) - } else { - the_choice = max(as.numeric(as.character(dat$bjo_annee))) - } - dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit) - dat <- - fun_report_mig_interannual(dat, year = the_choice, timesplit = timesplit) - prepare_dat <- function(dat) { - dat <- dat[order(dat$year, dat[, timesplit]), ] - dat$year <- as.factor(dat$year) - dat$keeptimesplit <- dat[, timesplit] - if (timesplit == "mois") { - dat[, timesplit] <- strftime(dat[, timesplit], format = "%m") - } else if (timesplit == "quinzaine") { - dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d") - } else { - dat[, timesplit] <- strftime(dat[, timesplit], format = "%W") - } - dat[, timesplit] <- as.factor(dat[, timesplit]) - # we only keep one per week - newdat <- dat[match(unique(dat[, timesplit]), dat[, timesplit]), ] - newdat <- - newdat[order(newdat[, "keeptimesplit"]), ] # pour avoir les range sur l'ensemble des valeurs dispo et pas seult l'annee en cours - # here change 12/2012 the geom_crossbar now needs a factor, label change according to timesplit - newdat[, timesplit] <- as.factor(newdat[, timesplit]) - levels(newdat[, timesplit]) <- - newdat[, timesplit] # to have the factor in the right order from january to dec - return(newdat) - } - amplitude <- paste(min(as.numeric(as.character(dat$year))), - "-", - max(as.numeric(as.character(dat$year))), - sep = "") - - newdat <- prepare_dat(dat) - newdat0 <- prepare_dat(dat0) - if (length(the_choice) > 0) { - # le layout pour l'affichage des graphiques - vplayout <- - function(x, y) { - grid::viewport(layout.pos.row = x, - layout.pos.col = y) - } - grid::grid.newpage() - grid::pushViewport(grid::viewport(layout = - grid::grid.layout(length(the_choice), 1, just = "center"))) - selection <- - as.numeric(as.character(dat0$year)) == as.numeric(the_choice) - tmp <- dat0[selection, ] - tmp[tmp$value >= tmp$mean, "comp"] <- ">=moy" - tmp[tmp$value < tmp$mean, "comp"] <- "<moy" - suppressWarnings({ - tmp[tmp$value == tmp$maxtab, "comp"] <- "max" - tmp[tmp$value == tmp$mintab, "comp"] <- "min" - }) - tmp[tmp$mean == 0, "comp"] <- "0" - - tmp$year <- as.factor(as.numeric(as.character(tmp$year))) - if (timesplit == "mois") { - tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m") - } else if (timesplit == "quinzaine") { - tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d") - } else { - tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W") - } - tmp[, timesplit] <- as.factor(tmp[, timesplit]) - tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?" - newdat$comp <- NA - - g <- ggplot(tmp, aes_string(x = timesplit, y = "value")) - g <- g + geom_crossbar( - data = newdat, - aes_string( - x = timesplit, - y = "mean", - ymin = "mintab", - ymax = "maxtab" - ), - fill = "grey60", - alpha = 0.5, - size = 0.5, - fatten = 3, - col = "grey60" - ) - g <- - g + geom_bar( - stat = "identity", - aes_string(y = "value", col = "comp"), - fill = NA, - width = 0.6 - ) - g <- - g + geom_bar( - stat = "identity", - aes_string(y = "value", fill = "comp"), - alpha = 0.5, - width = 0.6 - ) - #g <- g+scale_x_date(name=paste("mois"),breaks="month",minor_breaks=getvalue(new("ref_period"),label=date_format("%b"),timesplit)) - #lim=as.POSIXct(c(Hmisc::truncPOSIXt((min(tmp[tmp$com!="0",timesplit])),"month")-delai, - # Hmisc::ceil((max(tmp[tmp$com!="0",timesplit])),"month")+delai)) - # pb the limit truncs the value - g <- g + ylab("effectif") - cols <- c( - "max" = "#000080", - "min" = "#BF0000", - ">=moy" = "darkgreen", - "<moy" = "darkorange", - "hist_mean" = "black", - "hist_range" = "grey", - "?" = "darkviolet" - ) - fills <- c( - "max" = "blue", - "min" = "red", - ">=moy" = "green", - "<moy" = "orange", - "hist_mean" = "black", - "hist_range" = "grey", - "?" = "violet" - ) - - g <- g + scale_colour_manual( - name = the_choice, - values = cols, - limits = c( - "min", - "max", - "<moy", - ">=moy", - "hist_mean", - "hist_range", - "?" - ) - ) - g <- g + scale_fill_manual( - name = the_choice, - values = fills, - limits = c( - "min", - "max", - "<moy", - ">=moy", - "hist_mean", - "hist_range", - "?" - ) - ) - - g <- - g + labs( - title = paste( report_mig_interannual@taxa@data[ - report_mig_interannual@taxa@data$tax_code %in% - report_mig_interannual@taxa@taxa_selected, - "tax_nom_latin"], - ",", - report_mig_interannual@stage@data[ - report_mig_interannual@stage@data$std_code %in% - report_mig_interannual@stage@stage_selected, - "std_libelle"], - ", bilan par", - timesplit, - unique(as.character(tmp$year)), - "/", - amplitude - ) - ) - g <- g + theme_minimal() - print(g, vp = vplayout(1, 1)) - assign(paste("g", 1, sep = ""), g, envir_stacomi) - if (!silent) - funout( - gettextf( - "\"Writing the graphical object into envir_stacomi environment : write g=get(\"gi\",envir_stacomi) with i=%s", - paste(1:length(the_choice), collapse = ",") - ) - ) - - } # end if - - #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - } else if (plot.type == "pointrange") { - # below before several plots could be made, it's no longer the case - # as I remove the chosen year from the observation (reference) set - dat = report_mig_interannual@data - - if (silent == FALSE) { - the_choice <- - select.list( - choices = as.character(unique(dat$bjo_annee)), - preselect = as.character(max(dat$bjo_annee)), - gettext("Year choice", domain = "R-stacomiR"), - multiple = FALSE - ) - } else { - the_choice <- max(dat$bjo_annee) - } - dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit) - dat <- - fun_report_mig_interannual(dat, year = the_choice, timesplit = timesplit) - dat$year <- as.factor(dat$year) - dat <- dat[order(dat$year, dat[, timesplit]), ] - dat$keeptimesplit <- dat[, timesplit] - if (timesplit == "mois") { - dat[, timesplit] <- strftime(dat[, timesplit], format = "%m") - } else if (timesplit == "quinzaine") { - dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d") - } else { - dat[, timesplit] <- strftime(dat[, timesplit], format = "%W") - } - dat[, timesplit] <- as.factor(dat[, timesplit]) - - newdat <- dat[match(unique(dat[, timesplit]), dat[, timesplit]), ] - newdat <- - newdat[order(newdat[, "keeptimesplit"]), ] # il peut y avoir des annees pour le calcul de range qui s'ajoutent - # et viennent d'autres annees, il faut donc reordonner. - - - amplitude <- - paste(min(as.numeric(as.character(dat$year))), "-", max(as.numeric(as.character(dat$year))), sep = - "") - - - if (length(the_choice) > 0) { - # le layout pour l'affichage des graphiques - vplayout <- - function(x, y) { - grid::viewport(layout.pos.row = x, - layout.pos.col = y) - } - grid::grid.newpage() - grid::pushViewport(grid::viewport(layout = grid::grid.layout(length(the_choice), 1, just = - "center"))) - - selection <- - as.numeric(as.character(dat0$year)) == as.numeric(the_choice) - tmp <- dat0[selection, ] - tmp[tmp$value >= tmp$mean, "comp"] <- ">=moy" - tmp[tmp$value < tmp$mean, "comp"] <- "<moy" - suppressWarnings({ - tmp[tmp$value == tmp$maxtab, "comp"] <- "max" - tmp[tmp$value == tmp$mintab, "comp"] <- "min" - }) - tmp[tmp$mean == 0, "comp"] <- "0" - tmp$year = as.factor(as.numeric(as.character(tmp$year))) - if (timesplit == "mois") { - tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m") - } else if (timesplit == "quinzaine") { - tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d") - } else { - tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W") - } - tmp[, timesplit] <- as.factor(tmp[, timesplit]) - tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?" - newdat$comp <- NA - g <- ggplot(tmp, aes_string(x = timesplit, y = "value")) - g <- - g + geom_dotplot( - aes_string(x = timesplit, y = "value"), - data = dat, - stackdir = "center", - binaxis = "y", - position = "dodge", - dotsize = 0.5, - fill = "wheat" - ) #position = "dodge",dotsize = 0.4,alpha=0.5,binwidth = 1.5 - g <- - g + geom_pointrange( - data = newdat, - aes_string( - x = timesplit, - y = "mean", - ymin = "mintab", - ymax = "maxtab" - ), - alpha = 1, - size = 0.8 - ) - g <- - g + geom_bar(stat = "identity", - aes_string(y = "value", fill = "comp"), - alpha = 0.6) - g <- g + scale_y_continuous(name = "effectif") - cols <- - c( - "max" = "blue", - "min" = "red", - ">=moy" = "darkgreen", - "<moy" = "darkorange", - "0" = "grey10", - "?" = "darkviolet" - ) - g <- g + scale_fill_manual(name = the_choice, values = cols) - g <- - g + labs( - title = paste( - report_mig_interannual@taxa@data[ - report_mig_interannual@taxa@data$tax_code %in% - report_mig_interannual@taxa@taxa_selected, - "tax_nom_latin"], - ",", - report_mig_interannual@stage@data[ - report_mig_interannual@stage@data$std_code %in% - report_mig_interannual@stage@stage_selected, - "std_libelle"], - ", report par", - timesplit, - unique(as.character(tmp$year)), - "/", - amplitude - ) - ) - g <- g + theme_minimal() - print(g, vp = vplayout(1, 1)) - assign(paste("g", 1, sep = ""), g, envir_stacomi) - if (!silent) - funout( - gettextf( - "\"Writing the graphical object into envir_stacomi environment : write g=get(\"gi\",envir_stacomi) with i=%s", - paste(1:length(the_choice), collapse = ",") - ) - ) - - } # end if - #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - } else if (plot.type == "density") { - if (nrow(report_mig_interannual@data) > 0) - { - timesplit = "2 weeks" - dat <- report_mig_interannual@data - dat <- fun_report_mig_interannual(dat, year = NULL, timesplit) - dat$year <- as.factor(dat$year) - sum_per_year <- tapply(dat$value, dat$year, sum) - sum_per_year <- - data.frame(year = names(sum_per_year), - sum_per_year = sum_per_year) - dat <- merge(dat, sum_per_year, by = "year") - dat$std_value <- dat$value / dat$sum_per_year - dat <- chnames(dat, "2 weeks", "fortnight") - all_15 <- unique(dat[, "fortnight"]) - # below I'm adding 0 instead of nothing for 15 days without value - for (i in 1:length(unique(dat$year))) { - #i=5 - year <- unique(dat$year)[i] - this_year_15 <- unique(dat[dat$year == year, "fortnight"]) - missing <- all_15[!all_15 %in% this_year_15] - if (length(missing >= 1)) { - missingdat <- data.frame( - "year" = year, - "fortnight" = missing, # this is what we get from the function - "value" = 0, - "maxtab" = 0, - "mintab" = 0, - "mean" = 0, - "sum_per_year" = 0, - "std_value" = 0 - ) - dat <- rbind(dat, missingdat) - } - } - dat = dat[order(dat$year, dat[, "fortnight"]), ] - g <- ggplot(dat, aes_string(x = "fortnight", y = "std_value")) - g <- - g + geom_area(aes_string(y = "std_value", fill = "year"), position = - "stack") - g <- - g + scale_x_datetime( - name = gettext("month", domain = "R-stacomiR"), - date_breaks = "month", - date_minor_breaks = timesplit, - date_labels = "%b", - limits = as.POSIXct(c( - Hmisc::truncPOSIXt((min(dat[dat$valeur != 0, timesplit])), "month"), - Hmisc::ceil((max(dat[dat$valeur != "0", timesplit])), "month") - )) - ) - g <- - g + scale_y_continuous(name = gettext("Somme des pourcentages annuels de migration par quinzaine", domain = "R-stacomiR")) - cols <- grDevices::rainbow(length(levels(dat$year))) - g <- g + scale_fill_manual(name = "year", values = cols) - g <- - g + labs( - title = paste( - paste(report_mig_interannual@dc@dc_selected,collapse=" + "), - report_mig_interannual@taxa@data[ - report_mig_interannual@taxa@data$tax_code %in% - report_mig_interannual@taxa@taxa_selected, - "tax_nom_latin"], - ",", - report_mig_interannual@stage@data[ - report_mig_interannual@stage@data$std_code %in% - report_mig_interannual@stage@stage_selected, - "std_libelle"], - ", ", - gettext("migration seasonality", domain = "R-stacomiR") - ) - ) - g <- g + theme_minimal() - print(g) - assign(paste("g", sep = ""), g, envir_stacomi) - if (!silent) - funout( - gettext( - "Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n", - domain = "R-stacomiR" - ) - ) - - } else { - if (!silent) - funout( - gettext( - "Warning : you have to complete a migration summary for at least one of the selected year before launching a inter-annual summary", - domain = "R-stacomiR" - ) - ) - } - ##################################################################### - } else if (plot.type == "seasonal") { - if (!silent) - funout("Seasonal graph to show the phenology of migration") - #report_mig_interannual<-r_mig_interannual_vichy;silent=FALSE;timesplit="mois";require(ggplot2) - report_mig_interannual <- - calcule(report_mig_interannual, timesplit = timesplit) - #if (!silent& nrow(report_mig_interannual@calcdata)==0) stop("You should run calculation before plotting seasonal data") - dat3 <- report_mig_interannual@calcdata - datadic <- report_mig_interannual@data - datadic <- - fun_date_extraction( - datadic, - nom_coldt = "bjo_jour", - jour_an = TRUE, - quinzaine = TRUE - ) - datadic <- chnames(datadic, c("jour_365","mois","quinzaine","semaine"), c("day","month","fortnight","week")) - datadic <- killfactor(datadic) - #datadic[,timesplit]<-as.numeric(datadic[,timesplit]) - # to get nicer graphs we don't use a "numeric but transform our data into dates - # this function takes a vector of column as argument (col), a timesplit argument - # and a year. So far it does not handle quinzaine so will issue an error if quinzaine is selected - dat3[, c("Q0", "Q5", "Q50", "Q95", "Q100", "d90")] <- - round(dat3[, c("Q0", "Q5", "Q50", "Q95", "Q100", "d90")]) - fn_getbacktodate <- function(dat, col, timesplit_, year = 2000) { - for (i in 1:length(col)) { - dat[, col[i]] <- switch( - timesplit_, - "day" = { - as.Date(paste(year, "-", dat[, col[i]], sep = ""), "%Y-%j") - }, - "week" = { - as.Date(paste(year, "-", dat[, col[i]], "-", 6, sep = ""), "%Y-%U-%w") - }, - "month" = { - as.Date(paste(year, "-", dat[, col[i]], "-", 1, sep = ""), "%Y-%m-%d") - }, - stop( - stringr::str_c( - "Internal error, timesplit ", - timesplit_, - " not working for seasonal plot" - ) - ) - ) - } - return(dat) - } - datadic <- fn_getbacktodate(dat = datadic, - col = timesplit, - timesplit_ = timesplit) - dat3 <- fn_getbacktodate( - dat = dat3, - col = c("Q0", "Q5", "Q50", "Q95", "Q100", "d90"), - timesplit_ = timesplit - ) - - datadic1 <- - dplyr::select(datadic, - {{timesplit}}, - bjo_annee, - bjo_valeur, - bjo_labelquantite) - datadic1 <- - dplyr::group_by(datadic1, bjo_annee, dplyr::across(dplyr::all_of(timesplit)), bjo_labelquantite) - datadic1 <- dplyr::summarize(datadic1, bjo_valeur = sum(bjo_valeur)) - datadic1 <- - dplyr::ungroup(datadic1) %>% dplyr::filter(bjo_labelquantite == "Effectif_total") - g <- ggplot(data = datadic1) + - geom_rect( - aes( - xmin = Q0, - xmax = Q100, - ymin = year - 0.5, - ymax = year + 0.5 - ), - fill = "grey90", - data = dat3 - ) + - geom_tile( - aes_string(x = timesplit, y = "bjo_annee", fill = "bjo_valeur"), - color = ifelse(timesplit == "day", "transparent", "grey80") - ) + - scale_fill_distiller(palette = "Spectral", name = "Effectif") + - geom_path( - aes(x = Q50, y = year), - col = "black", - lty = 2, - data = dat3 - ) + - geom_point( - aes(x = Q50, y = year), - col = "black", - size = 2, - data = dat3 - ) + - geom_errorbarh( - aes( - y = year, - xmin = Q5, - xmax = Q95 - ), - height = 0, - data = dat3, - col = "black" - ) + - ylab(Hmisc::capitalize(gettext("year", domain = "R-stacomiR"))) + - xlab(Hmisc::capitalize({{timesplit}})) + - scale_x_date( - name = timesplit, - date_breaks = "month", - date_minor_breaks = {{timesplit}}, - date_labels = "%b" - ) + - theme_bw() - print(g) - assign("g", g, envir = envir_stacomi) - if (!silent) - funout( - gettext( - "Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n", - domain = "R-stacomiR" - ) - ) - - } - - else { - # end if - stop ("plot.type argument invalid") - } - - } else { - if (!silent) - funout( - gettext( - "Attention : you have to complete a migration summary for at least one of the selected year before launching a inter-annual summary", - domain = "R-stacomiR" - ) - ) - } - return(invisible(NULL)) - } + "plot", + signature(x = "report_mig_interannual", y = "missing"), + definition = function(x, + plot.type = "standard", + timesplit = "month", + selected_year = NULL, + silent = FALSE) { + #report_mig_interannual<-r_mig_interannual + report_mig_interannual <- x + if (!timesplit %in% c( + "jour", + "day", + "month", + "mois", + "week", + "semaine", + "month", + "mois", + "quinzaine", + "fortnight" + )) + stop ( + stringr::str_c( + "timesplit should be one of :", + "jour ", + "day ", + "month ", + "mois ", + "week ", + "semaine ", + "month ", + "mois ", + "quinzaine ", + "fortnight " + ) + ) + # back to French labels for consistency with fun_report_mig_interannual code + timesplit <- + switch( + timesplit, + "jour" = "day", + "semaine" = "week", + "mois" = "month", + "quinzaine"= "fortnight", + timesplit + ) + + # plot.type="line";require(ggplot2) + + if (nrow(report_mig_interannual@data) > 0) { + # this is used in standard, step, barchart, pointrange, but not density seasonal + if (is.null(selected_year)){ + if (silent == FALSE) { + the_reference_year <- + as.numeric( + select.list( + choices = as.character(unique(report_mig_interannual@data$bjo_annee)[order(unique(report_mig_interannual@data$bjo_annee))]), + preselect = as.character(max(report_mig_interannual@data$bjo_annee)), + gettext("Year choice", domain="R-stacomiR"), + multiple = FALSE + ) + ) + } else { + the_reference_year <- max(report_mig_interannual@data$bjo_annee) + } + } else { + if (! selected_year %in% report_mig_interannual@data$bjo_annee) stop("Year not in range, check selected_year argument") + the_reference_year <- selected_year + } + + if (plot.type == "line") { + dat <- report_mig_interannual@data + dat <- dat[dat$bjo_labelquantite == "Effectif_total", ] + dat <- stacomirtools::chnames( + dat, + c( + "bjo_annee", + "bjo_jour", + "bjo_labelquantite", + "bjo_valeur" + ), + c("year", "day", "labelquantity", "value") + ) + # we need to choose a date, every year brought back to 2000 + dat$day <- as.POSIXct(strptime(strftime(dat$day, + '2000-%m-%d %H:%M:%S'), + format = '%Y-%m-%d %H:%M:%S'), tz = "GMT") + dat$year <- as.factor(dat$year) + dat <- stacomirtools::killfactor(dat) + titre = paste( + gettext("Migration ", domain="R-stacomiR"), + paste(min(dat$year), max(dat$year), collapse = "-"), + ", ", + paste(report_mig_interannual@dc@data$dis_commentaires[report_mig_interannual@dc@data$dc %in% + report_mig_interannual@dc@dc_selected], collapse="+"), + sep="" + ) + soustitre = paste( + report_mig_interannual@taxa@data[ + report_mig_interannual@taxa@data$tax_code %in% + report_mig_interannual@taxa@taxa_selected, + "tax_nom_latin"], + ", ", + report_mig_interannual@stage@data[ + report_mig_interannual@stage@data$std_code %in% + report_mig_interannual@stage@stage_selected, + "std_libelle"], + ", ", + sep = "" + ) + g <- ggplot(dat, aes(x = day, y = value)) + g <- + g + geom_line(data=subset(dat, dat$year==the_reference_year), aes(color = year), size=1.5, alpha=0.5) + + geom_line(aes(color = year)) + labs(title = paste(titre, "\n", soustitre)) + + scale_x_datetime(name = "date", date_breaks = "1 month", + date_labels = "%b") + + theme_bw() + print(g) + assign("g_line", g, envir = envir_stacomi) + if (!silent) + funout( + gettext( + "Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n", + domain = "R-stacomiR" + ) + ) + #---------------------------------------------- + } else if (plot.type == "standard") { + dat <- report_mig_interannual@data + + # dataset for current year + dat0 <- + fun_report_mig_interannual(dat, year = NULL, timesplit = "day") + dat <- + fun_report_mig_interannual(dat, year = the_reference_year, timesplit = "day") + dat <- + dat[dat$mean != 0, ] # pour des raisons graphiques on ne garde pas les effectifs nuls generes par fun_report_mig_interannual + newdat <- + dat[match(unique(as.character(dat$day)), as.character(dat$day)), ] + newdat <- + newdat[order(newdat$day), ] # pour avoir les range sur l'ensemble des valeurs dispo et pas seult l'annee en cours + amplitude = paste(min(as.numeric(as.character(dat$year))), "-", max(as.numeric(as.character(dat$year))), sep = + "") + vplayout <- + function(x, y) { + grid::viewport(layout.pos.row = x, + layout.pos.col = y) + } + grid::grid.newpage() + grid::pushViewport(grid::viewport(layout = grid::grid.layout(length(the_reference_year), 1, just = + "center"))) + amplitudechoice <- paste(the_reference_year, '/', amplitude) + tmp <- dat0[as.numeric(as.character(dat0$year)) == the_reference_year, ] + tmp$year <- as.character(tmp$year) + g <- ggplot(newdat, aes(x = day)) + g <- + g + geom_ribbon( + aes( + ymin = mintab, + ymax = maxtab, + fill = "amplitude" + ), + color = "grey20", + alpha = 0.5 + ) + g <- + g + geom_bar( + aes(y = value, fill = I("orange")), + position = "dodge", + stat = "identity", + color = "grey20", + alpha = 0.8, + data = tmp + ) + g <- + g + scale_fill_manual( + name = eval(amplitudechoice), + values = c("#35789C", "orange"), + labels = c( + gettext("Historical amplitude", domain = "R-StacomiR"), + the_reference_year + ) + ) + #g <- g+geom_point(aes(y=value,col=year),data=tmp,pch=16,size=1) + # moyenne interannuelle + + g <- g + geom_line(aes(y = mean, col = I("#002743")), data = newdat) + g <- + g + geom_point(aes(y = mean, col = I("#002743")), + size = 1.2, + data = newdat) + g <- + g + scale_colour_manual( + name = eval(amplitudechoice), + values = c("#002743"), + labels = c(stringr::str_c( + gettext("Interannual mean\n", domain = "R-stacomiR"), + amplitude + )) + ) + + guides(fill = guide_legend(reverse = TRUE)) + g <- + g + labs( + title = paste( + paste(report_mig_interannual@dc@dc_selected,collapse="+"), + report_mig_interannual@taxa@data[ + report_mig_interannual@taxa@data$tax_code %in% + report_mig_interannual@taxa@taxa_selected, + "tax_nom_latin"], + ",", + report_mig_interannual@stage@data[ + report_mig_interannual@stage@data$std_code %in% + report_mig_interannual@stage@stage_selected, + "std_libelle"], + ",", + the_reference_year, + "/", + amplitude + ) + ) + g <- + g + scale_x_datetime( + name = "date", + date_breaks = "months", + date_minor_breaks = "weeks", + date_labels = "%d-%m" + ) + g <- g + theme_bw() + theme(legend.key = element_blank()) + print(g, vp = vplayout(1, 1)) + assign("g_standard", g, envir_stacomi) + if (!silent) + funout( + gettextf( + "Writing the graphical object into envir_stacomi environment : write g=get(\"g_standard\",envir_stacomi)" + ) + ) + + + #-----step ------------------------------------ + } else if (plot.type == "step") { + + dat <- report_mig_interannual@data + dat <- fun_report_mig_interannual(dat, timesplit="day") + # runs the default with daily migration + #dat=dat[order(dat$year,dat$day),] + dat$value[is.na(dat$value)] <-0 + # otherwise if only one line it may crash + + amplitude <- paste(min(as.numeric(as.character(dat$year))), + "-", max(as.numeric(as.character(dat$year))), sep = "") + + # calculation of cumsums --------------------------- + + + for (an in unique(dat$year)) { + # an=as.character(unique(dat$year)) ;an<-an[1] + dat[dat$year == an, "cumsum"] <- + cumsum(dat[dat$year == an, "value"]) + dat[dat$year == an, "total_annuel"] <- + max(dat[dat$year == an, "cumsum"]) + } + dat$cumsum <- dat$cumsum / dat$total_annuel + dat$day <- as.Date(dat$day) + dat$year <- as.factor(dat$year) + + # step plot part ------------- + + g <- ggplot(dat, aes(x = day, y = cumsum)) + tmp <- + dat[as.numeric(as.character(dat$year)) == as.numeric(the_reference_year), ] + g <- g + geom_step(aes(col = year, size = total_annuel)) + g <- g + geom_step(data = tmp, + col = "black", + lty = 2) + g <- + g + labs( + title = gettextf( + "%s, %s, %s cum %s", + paste(report_mig_interannual@dc@dc_selected, collapse="+"), + report_mig_interannual@taxa@data[ + report_mig_interannual@taxa@data$tax_code %in% + report_mig_interannual@taxa@taxa_selected, + "tax_nom_latin"], + report_mig_interannual@stage@data[ + report_mig_interannual@stage@data$std_code %in% + report_mig_interannual@stage@stage_selected, + "std_libelle"], + amplitude + ) + ) + g <- + g + scale_y_continuous(name = gettext("Annual migration percentage", domain = + "R-stacomiR")) + g <- + g + scale_x_date( + name = gettext("date", domain = "R-stacomiR"), + date_breaks = "months", + date_minor_breaks = "weeks", + date_labels = "%b", + limits = range(dat[dat$value > 0 & + dat$cumsum != 1, "day"]) + )# date + g <- + g + scale_colour_hue( + name = gettext("year", domain = "R-stacomiR"), + l = 70, + c = 150 + ) + print(g) + assign("g_step", g, envir_stacomi) + if (!silent) + funout( + gettext( + "Writing the graphical object into envir_stacomi environment : write g=get('g_step',envir_stacomi)\n", + domain = "R-stacomiR" + ) + ) + #---------------------------------------------- + } else if (plot.type == "barchart" | plot.type == "pointrange") { + dat = report_mig_interannual@data + dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit) + dat <- fun_report_mig_interannual(dat, year = the_reference_year, timesplit = timesplit) # we exclude the_reference_year from the dataset + prepare_dat <- function(dat) { + dat <- dat[order(dat$year, dat[, timesplit]), ] + #dat$year <- as.factor(dat$year) + dat$keeptimesplit <- dat[, timesplit] + + + if (timesplit == "month") { + dat[, timesplit] <- strftime(dat[, timesplit], format = "%m") + } else if (timesplit == "fortnight") { + dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d") + } else if (timesplit == "week"){ + dat[, timesplit] <- strftime(dat[, timesplit], format = "%W") + } else if (timesplit == "day"){ + dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d") + } + dat[, timesplit] <- as.factor(dat[, timesplit]) + # we only keep one per timesplit + newdat <- dat[match(unique(dat[, timesplit]), dat[, timesplit]), ] + newdat <- newdat[order(newdat[, "keeptimesplit"]), ] # pour avoir les range sur l'ensemble des valeurs dispo et pas seult l'annee en cours + # here change 12/2012 the geom_crossbar now needs a factor, label change according to timesplit + newdat[, timesplit] <- as.factor(newdat[, timesplit]) + levels(newdat[, timesplit]) <- newdat[, timesplit] # to have the factor in the right order from january to dec + return(newdat) + } + amplitude <- paste(min(as.numeric(as.character(dat$year))), + "-", + max(as.numeric(as.character(dat$year))), + sep = "") + # newdat only keeps one unique value among dat0 + newdat <- prepare_dat(dat) + newdat0 <- prepare_dat(dat0) + + + selection <- + as.numeric(as.character(dat0$year)) == as.numeric(the_reference_year) + # we extract selected year from the full dataset + tmp <- dat0[selection, ] + if (timesplit == "month") { + tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m") + } else if (timesplit == "fortnight") { + tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d") + } else if (timesplit == "week"){ + tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W") + } else if (timesplit == "day"){ + tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d") + } + tmp[, timesplit] <- as.factor(tmp[, timesplit]) + tmp[tmp$value >= tmp$mean & !is.na(tmp$value), "comp"] <- ">=moy" + tmp[tmp$value < tmp$mean & !is.na(tmp$value), "comp"] <- "<moy" + suppressWarnings({ + tmp[tmp$value == tmp$maxtab & !is.na(tmp$value), "comp"] <- "max" + tmp[tmp$value == tmp$mintab & !is.na(tmp$value), "comp"] <- "min" + }) + tmp[tmp$mean == 0, "comp"] <- "0" + tmp[is.na(tmp$value), "comp"] <- "no data" + tmp$year <- as.factor(as.numeric(as.character(tmp$year))) + + tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?" + + # dat is used in pointrange + if (timesplit == "month") { + dat[, timesplit] <- strftime(dat[, timesplit], format = "%m") + } else if (timesplit == "fortnight") { + dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d") + } else if (timesplit == "week"){ + dat[, timesplit] <- strftime(dat[, timesplit], format = "%W") + } else if (timesplit == "day"){ + dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d") + } + + newdat$comp <- NA + + # le layout pour l'affichage des graphiques + vplayout <- + function(x, y) { + grid::viewport(layout.pos.row = x, + layout.pos.col = y) + } + grid::grid.newpage() + grid::pushViewport(grid::viewport(layout = + grid::grid.layout(length(the_reference_year), 1, just = "center"))) + + + #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + #--barchartggplot------------------------------------------------------------------ + if (plot.type == "barchart") { + g <- ggplot(tmp, aes_string(x = timesplit, y = "value")) + g <- g + geom_crossbar( + data = newdat, + aes_string( + x = timesplit, + y = "mean", + ymin = "mintab", + ymax = "maxtab" + ), + fill = "grey60", + alpha = 0.5, + size = 0.5, + fatten = 3, + col = "grey60" + ) + g <- + g + geom_bar( + stat = "identity", + aes_string(y = "value", col = "comp"), + fill = NA, + width = 0.6 + ) + g <- + g + geom_bar( + stat = "identity", + aes_string(y = "value", fill = "comp"), + alpha = 0.5, + width = 0.6 + ) + #g <- g+scale_x_date(name=paste("mois"),breaks="month",minor_breaks=getvalue(new("ref_period"),label=date_format("%b"),timesplit)) + #lim=as.POSIXct(c(Hmisc::truncPOSIXt((min(tmp[tmp$com!="0",timesplit])),"month")-delai, + # Hmisc::ceil((max(tmp[tmp$com!="0",timesplit])),"month")+delai)) + # pb the limit truncs the value + g <- g + ylab("effectif") + cols <- c( + "max" = "#000080", + "min" = "#BF0000", + ">=moy" = "darkgreen", + "<moy" = "darkorange", + "hist_mean" = "black", + "hist_range" = "grey", + "?" = "darkviolet" + ) + fills <- c( + "max" = "blue", + "min" = "red", + ">=moy" = "green", + "<moy" = "orange", + "hist_mean" = "black", + "hist_range" = "grey", + "?" = "violet" + ) + + g <- g + scale_colour_manual( + name = the_reference_year, + values = cols, + limits = c( + "min", + "max", + "<moy", + ">=moy", + "hist_mean", + "hist_range", + "?" + ) + ) + g <- g + scale_fill_manual( + name = the_reference_year, + values = fills, + limits = c( + "min", + "max", + "<moy", + ">=moy", + "hist_mean", + "hist_range", + "?" + ) + ) + + g <- + g + labs( + title = paste( report_mig_interannual@taxa@data[ + report_mig_interannual@taxa@data$tax_code %in% + report_mig_interannual@taxa@taxa_selected, + "tax_nom_latin"], + ",", + report_mig_interannual@stage@data[ + report_mig_interannual@stage@data$std_code %in% + report_mig_interannual@stage@stage_selected, + "std_libelle"], + ", bilan par", + timesplit, + unique(as.character(tmp$year)), + "/", + amplitude + ) + ) + g <- g + theme_minimal() + + + print(g, vp = vplayout(1, 1)) + assign(paste("g_barchart", 1, sep = ""), g, envir_stacomi) + if (!silent) + funout( + gettextf( + "\"Writing the graphical object into envir_stacomi environment : write g=get(\"g_barchart\",envir_stacomi)") + ) + + #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + #-point range ggplot ------------------------------------------------------------------ + } else if (plot.type == "pointrange") { + + + + g <- ggplot(tmp, aes_string(x = timesplit, y = "value")) + g <- + g + geom_pointrange( + data = newdat, + aes_string( + x = timesplit, + y = "mean", + ymin = "mintab", + ymax = "maxtab" + ), + alpha = 1, + size = 0.8 + ) + g <- + g + geom_bar(stat = "identity", + aes_string(y = "value", fill = "comp"), + alpha = 0.6) + g <- + g + geom_dotplot( + aes_string(x = timesplit, y = "value"), + data = dat, + stackdir = "center", + binaxis = "y", + position = "dodge", + dotsize = 0.5, + fill = "wheat" + ) #position = "dodge",dotsize = 0.4,alpha=0.5,binwidth = 1.5 + + + + + g <- g + scale_y_continuous(name = "effectif") + cols <- + c( + "max" = "blue", + "min" = "red", + ">=moy" = "darkgreen", + "<moy" = "darkorange", + "0" = "grey10", + "?" = "darkviolet" + ) + g <- g + scale_fill_manual(name = the_reference_year, values = cols) + g <- + g + labs( + title = paste( + report_mig_interannual@taxa@data[ + report_mig_interannual@taxa@data$tax_code %in% + report_mig_interannual@taxa@taxa_selected, + "tax_nom_latin"], + ",", + report_mig_interannual@stage@data[ + report_mig_interannual@stage@data$std_code %in% + report_mig_interannual@stage@stage_selected, + "std_libelle"], + ", report par", + timesplit, + unique(as.character(tmp$year)), + "/", + amplitude + ) + ) + g <- g + theme_minimal() + print(g, vp = vplayout(1, 1)) + assign(paste("g_pointrange", 1, sep = ""), g, envir_stacomi) + if (!silent) + funout( + gettextf( + "Writing the graphical object into envir_stacomi environment : write g=get(\"g_pointrange\",envir_stacomi)") + ) + } # end ifelse barchart or pointrange + + + #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + } else if (plot.type == "density") { + + + timesplit <- "fortnight" + dat <- report_mig_interannual@data + dat <- fun_report_mig_interannual(dat, year = NULL, timesplit) + dat$year <- as.factor(dat$year) + sum_per_year <- tapply(dat$value, dat$year, sum) + sum_per_year <- + data.frame(year = names(sum_per_year), + sum_per_year = sum_per_year) + dat <- merge(dat, sum_per_year, by = "year") + dat$std_value <- dat$value / dat$sum_per_year + all_15 <- unique(dat[, "fortnight"]) + # below I'm adding 0 instead of nothing for 15 days without value + for (i in 1:length(unique(dat$year))) { + #i=5 + year <- unique(dat$year)[i] + this_year_15 <- unique(dat[dat$year == year, "fortnight"]) + missing <- all_15[!all_15 %in% this_year_15] + if (length(missing >= 1)) { + missingdat <- data.frame( + "year" = year, + "fortnight" = missing, # this is what we get from the function + "value" = 0, + "maxtab" = 0, + "mintab" = 0, + "mean" = 0, + "sum_per_year" = 0, + "std_value" = 0 + ) + dat <- rbind(dat, missingdat) + } + } + dat <- dat[order(dat$year, dat[, "fortnight"]), ] + g <- ggplot(dat, aes_string(x = "fortnight", y = "std_value")) + g <- + g + geom_area(aes_string(y = "std_value", fill = "year"), position = + "stack") + g <- + g + scale_x_datetime( + name = gettext("month", domain = "R-stacomiR"), + date_breaks = "month", + date_minor_breaks = "2 weeks", + date_labels = "%b"#, +# limits = as.POSIXct(c( +# Hmisc::truncPOSIXt((min(dat[dat$valeur != 0, timesplit])), "month"), +# Hmisc::ceil((max(dat[dat$valeur != "0", timesplit])), "month") +# ) +# ) + ) + g <- + g + scale_y_continuous(name = gettext("Somme des pourcentages annuels de migration par quinzaine", domain = "R-stacomiR")) + cols <- grDevices::rainbow(length(levels(dat$year))) + g <- g + scale_fill_manual(name = "year", values = cols) + g <- + g + labs( + title = paste( + paste(report_mig_interannual@dc@dc_selected,collapse=" + "), + report_mig_interannual@taxa@data[ + report_mig_interannual@taxa@data$tax_code %in% + report_mig_interannual@taxa@taxa_selected, + "tax_nom_latin"], + ",", + report_mig_interannual@stage@data[ + report_mig_interannual@stage@data$std_code %in% + report_mig_interannual@stage@stage_selected, + "std_libelle"], + ", ", + gettext("migration seasonality", domain = "R-stacomiR") + ) + ) + g <- g + theme_minimal() + print(g) + assign(paste("g_density", sep = ""), g, envir_stacomi) + if (!silent) + funout( + gettext( + "Writing the graphical object into envir_stacomi environment : write g=get('g_density',envir_stacomi)\n", + domain = "R-stacomiR" + ) + ) + + ##################################################################### + } else if (plot.type == "seasonal") { + if (!silent) funout("Seasonal graph to show the phenology of migration") + #report_mig_interannual<-r_mig_interannual_vichy;silent=FALSE;timesplit="mois";require(ggplot2) + report_mig_interannual <- + calcule(report_mig_interannual, timesplit = timesplit) + #if (!silent& nrow(report_mig_interannual@calcdata)==0) stop("You should run calculation before plotting seasonal data") + dat3 <- report_mig_interannual@calcdata + datadic <- report_mig_interannual@data + datadic <- + fun_date_extraction( + datadic, + nom_coldt = "bjo_jour", + jour_an = TRUE, + quinzaine = TRUE + ) + datadic <- chnames(datadic, c("jour_365","mois","quinzaine","semaine"), c("day","month","fortnight","week")) + datadic <- killfactor(datadic) + #datadic[,timesplit]<-as.numeric(datadic[,timesplit]) + # to get nicer graphs we don't use a "numeric but transform our data into dates + # this function takes a vector of column as argument (col), a timesplit argument + # and a year. So far it does not handle quinzaine so will issue an error if quinzaine is selected + dat3[, c("Q0", "Q5", "Q50", "Q95", "Q100", "d90")] <- + round(dat3[, c("Q0", "Q5", "Q50", "Q95", "Q100", "d90")]) + fn_getbacktodate <- function(dat, col, timesplit_, year = 2000) { + for (i in 1:length(col)) { + dat[, col[i]] <- switch( + timesplit_, + "day" = { + as.Date(paste(year, "-", dat[, col[i]], sep = ""), "%Y-%j") + }, + "week" = { + as.Date(paste(year, "-", dat[, col[i]], "-", 6, sep = ""), "%Y-%U-%w") + }, + "month" = { + as.Date(paste(year, "-", dat[, col[i]], "-", 1, sep = ""), "%Y-%m-%d") + }, + stop( + stringr::str_c( + "Internal error, timesplit ", + timesplit_, + " not working for seasonal plot" + ) + ) + ) + } + return(dat) + } + datadic <- fn_getbacktodate(dat = datadic, + col = timesplit, + timesplit_ = timesplit) + dat3 <- fn_getbacktodate( + dat = dat3, + col = c("Q0", "Q5", "Q50", "Q95", "Q100", "d90"), + timesplit_ = timesplit + ) + + datadic1 <- + dplyr::select(datadic, + {{timesplit}}, + bjo_annee, + bjo_valeur, + bjo_labelquantite) + datadic1 <- + dplyr::group_by(datadic1, bjo_annee, dplyr::across(dplyr::all_of(timesplit)), bjo_labelquantite) + datadic1 <- dplyr::summarize(datadic1, bjo_valeur = sum(bjo_valeur)) + datadic1 <- + dplyr::ungroup(datadic1) %>% dplyr::filter(bjo_labelquantite == "Effectif_total") + g <- ggplot(data = datadic1) + + geom_rect( + aes( + xmin = Q0, + xmax = Q100, + ymin = year - 0.5, + ymax = year + 0.5 + ), + fill = "grey90", + data = dat3 + ) + + geom_tile( + aes_string(x = timesplit, y = "bjo_annee", fill = "bjo_valeur"), + color = ifelse(timesplit == "day", "transparent", "grey80") + ) + + scale_fill_distiller(palette = "Spectral", name = "Effectif") + + geom_path( + aes(x = Q50, y = year), + col = "black", + lty = 2, + data = dat3 + ) + + geom_point( + aes(x = Q50, y = year), + col = "black", + size = 2, + data = dat3 + ) + + geom_errorbarh( + aes( + y = year, + xmin = Q5, + xmax = Q95 + ), + height = 0, + data = dat3, + col = "black" + ) + + ylab(Hmisc::capitalize(gettext("year", domain = "R-stacomiR"))) + + xlab(Hmisc::capitalize({{timesplit}})) + + scale_x_date( + name = timesplit, + date_breaks = "month", + date_minor_breaks = {{timesplit}}, + date_labels = "%b" + ) + + theme_bw() + print(g) + assign("g_seasonal", g, envir = envir_stacomi) + if (!silent) + funout( + gettext( + "Writing the graphical object into envir_stacomi environment : write g=get('g_seasonal',envir_stacomi)\n", + domain = "R-stacomiR" + ) + ) + + } else { + stop ("plot.type argument invalid") + } + + + } else { + if (!silent) + funout( + gettext( + "Attention : you have to complete a migration summary for at least one of the selected year before launching a inter-annual summary", + domain = "R-stacomiR" + ) + ) + } + return(invisible(NULL)) + } ) @@ -1800,108 +1734,108 @@ setMethod( #' @return A list, one element per DC #' @export setMethod( - "summary", - signature = signature(object = "report_mig_interannual"), - definition = function(object, year_choice=NULL, silent = FALSE, ...) { - # table generated with funtable - # TODO traitement des poids - # object<-r_mig_interannual; object <- rmi - dat0 <- object@data - dat0 <- dat0[dat0$bjo_labelquantite == "Effectif_total", ] - dat0 <- - stacomirtools::chnames( - dat0, - c( - "bjo_dis_identifiant", - "bjo_tax_code", - "bjo_std_code", - "bjo_annee", - "bjo_jour", - "bjo_labelquantite", - "bjo_valeur", - "bjo_horodateexport" - ), - c( - "DC", - "taxa", - "stage", - "year", - "day", - "label_quantity", - "number", - "date of report export" - ) - ) - dat0$year <- as.factor(dat0$year) - dat0 <- dat0[, -1] - tmp <- dat0$day - DC <- object@dc@dc_selected - dat0 <- chnames(dat0, "day", "debut_pas") - # debut_pas must be column name in tableau - listDC <- list() - for (i in 1:length(DC)) { - # this table will write an html table of data - funtable( - tableau = dat0[dat0$bjo_dis_identifiant == DC, ], - time.sequence = tmp, - taxa = object@taxa@data[object@taxa@data$tax_code %in% object@taxa@taxa_selected, "tax_nom_latin"], - stage = object@stage@data[object@stage@data$std_code %in% object@stage@stage_selected, "std_libelle"], - DC[i], - resum = NULL, - silent = silent - ) - # Summary statistics - dat1 = object@data - if (is.null(year_choice)){ - if (silent == FALSE) { - the_choice <- as.numeric( - select.list( - choices = as.character(unique(dat1$bjo_annee)[order(unique(dat1$bjo_annee))]), - preselect = as.character(max(dat1$bjo_annee)), - gettext("Year choice", domain = "R-stacomiR"), - multiple = FALSE - ) - ) - } else { - the_choice <- max((dat1$bjo_annee)) - } - } else { - if (!year_choice %in% unique(dat1$bjo_annee)) { - stop(paste("The chosen year",year_choice,"should be in available years : ", - paste(as.character(unique(dat1$bjo_annee)[order(unique(dat1$bjo_annee))]), collapse=","))) - } - the_choice <- as.numeric(year_choice) - } - # we use the function that split data per time stamp to generate the full sequence of monthly data - dat2 <- - fun_report_mig_interannual(dat1[dat1$bjo_dis_identifiant == DC[i], ], timesplit = - "month") - # then we extract only current year for summary - colnames(dat2)[colnames(dat2) == "maxtab"] <- "max" - colnames(dat2)[colnames(dat2) == "mintab"] <- "min" - dat2$nummonth <- as.numeric(strftime(dat2$month, "%m")) # to order later on - dat2$month <- strftime(dat2$month, "%b") - dat2$mean <- round(dat2$mean) - dat3 <- dat2[dat2$year == the_choice, ] - # dat3 only shows the month that have data for one year, here we collect the others - missing_month <- unique(dat2$month)[!unique(dat2$month) %in% unique(dat3$month)] - dat_other_month <- dat2[dat2$month %in% missing_month, ] # data for missing month but many years - if (nrow(dat_other_month)>0){ - dat_other_month$value <- NA # we will no value for the choice - dat_other_month$year <- the_choice # setting actual year - dat_other_month <- dat_other_month [!duplicated(dat_other_month$month),] # keep only one month - } - dat4 <- rbind(dat3, dat_other_month) - dat4 <- dat4[order(dat4$nummonth), c("year", "month", "min", "mean", "max", "value")] - colnames(dat4) <- c( - gettext("year", domain = "R-stacomiR"), - gettext("month", domain = "R-stacomiR"), - "min", - gettext("mean", domain = "R-stacomiR"), - "max", - gettext("value", domain = "R-stacomiR")) - listDC[[as.character(DC[i])]] <- dat4 - }# end for - return(listDC) - } + "summary", + signature = signature(object = "report_mig_interannual"), + definition = function(object, year_choice=NULL, silent = FALSE, ...) { + # table generated with funtable + # TODO traitement des poids + # object<-r_mig_interannual; object <- rmi + dat0 <- object@data + dat0 <- dat0[dat0$bjo_labelquantite == "Effectif_total", ] + dat0 <- + stacomirtools::chnames( + dat0, + c( + "bjo_dis_identifiant", + "bjo_tax_code", + "bjo_std_code", + "bjo_annee", + "bjo_jour", + "bjo_labelquantite", + "bjo_valeur", + "bjo_horodateexport" + ), + c( + "DC", + "taxa", + "stage", + "year", + "day", + "label_quantity", + "number", + "date of report export" + ) + ) + dat0$year <- as.factor(dat0$year) + dat0 <- dat0[, -1] + tmp <- dat0$day + DC <- object@dc@dc_selected + dat0 <- chnames(dat0, "day", "debut_pas") + # debut_pas must be column name in tableau + listDC <- list() + for (i in 1:length(DC)) { + # this table will write an html table of data + funtable( + tableau = dat0[dat0$bjo_dis_identifiant == DC, ], + time.sequence = tmp, + taxa = object@taxa@data[object@taxa@data$tax_code %in% object@taxa@taxa_selected, "tax_nom_latin"], + stage = object@stage@data[object@stage@data$std_code %in% object@stage@stage_selected, "std_libelle"], + DC[i], + resum = NULL, + silent = silent + ) + # Summary statistics + dat1 = object@data + if (is.null(year_choice)){ + if (silent == FALSE) { + the_reference_year <- as.numeric( + select.list( + choices = as.character(unique(dat1$bjo_annee)[order(unique(dat1$bjo_annee))]), + preselect = as.character(max(dat1$bjo_annee)), + gettext("Year choice", domain = "R-stacomiR"), + multiple = FALSE + ) + ) + } else { + the_reference_year <- max((dat1$bjo_annee)) + } + } else { + if (!year_choice %in% unique(dat1$bjo_annee)) { + stop(paste("The chosen year",year_choice,"should be in available years : ", + paste(as.character(unique(dat1$bjo_annee)[order(unique(dat1$bjo_annee))]), collapse=","))) + } + the_reference_year <- as.numeric(year_choice) + } + # we use the function that split data per time stamp to generate the full sequence of monthly data + dat2 <- + fun_report_mig_interannual(dat1[dat1$bjo_dis_identifiant == DC[i], ], timesplit = + "month") + # then we extract only current year for summary + colnames(dat2)[colnames(dat2) == "maxtab"] <- "max" + colnames(dat2)[colnames(dat2) == "mintab"] <- "min" + dat2$nummonth <- as.numeric(strftime(dat2$month, "%m")) # to order later on + dat2$month <- strftime(dat2$month, "%b") + dat2$mean <- round(dat2$mean) + dat3 <- dat2[dat2$year == the_reference_year, ] + # dat3 only shows the month that have data for one year, here we collect the others + missing_month <- unique(dat2$month)[!unique(dat2$month) %in% unique(dat3$month)] + dat_other_month <- dat2[dat2$month %in% missing_month, ] # data for missing month but many years + if (nrow(dat_other_month)>0){ + dat_other_month$value <- NA # we will no value for the choice + dat_other_month$year <- the_reference_year # setting actual year + dat_other_month <- dat_other_month [!duplicated(dat_other_month$month),] # keep only one month + } + dat4 <- rbind(dat3, dat_other_month) + dat4 <- dat4[order(dat4$nummonth), c("year", "month", "min", "mean", "max", "value")] + colnames(dat4) <- c( + gettext("year", domain = "R-stacomiR"), + gettext("month", domain = "R-stacomiR"), + "min", + gettext("mean", domain = "R-stacomiR"), + "max", + gettext("value", domain = "R-stacomiR")) + listDC[[as.character(DC[i])]] <- dat4 + }# end for + return(listDC) + } ) diff --git a/inst/examples/report_mig_interannual-example.R b/inst/examples/report_mig_interannual-example.R index d04f80d845fa68b86e1fb66128344b0a69402871..f14b1145ea05f65be1589502ebd035def5a47544 100644 --- a/inst/examples/report_mig_interannual-example.R +++ b/inst/examples/report_mig_interannual-example.R @@ -1,11 +1,10 @@ require(stacomiR) # launching stacomi without selecting the scheme or interface -stacomi( - database_expected=FALSE, sch='pmp') +stacomi( database_expected=FALSE, sch='pmp') # If you have connection to the database with the pmp scheme # prompt for user and password but you can set appropriate options for host, port and dbname \dontrun{ - stacomi(database_expected=TRUE, sch="pmp") + stacomi(database_expected=TRUE, sch="test") if (interactive()){ if (!exists("user")){ user <- readline(prompt="Enter user: ") @@ -13,23 +12,19 @@ stacomi( } } options( - stacomiR.dbname = "bd_contmig_nat", + stacomiR.dbname = "bd_contmig_nat_test", stacomiR.host ="localhost", stacomiR.port = "5432", stacomiR.user = user, stacomiR.user = password ) - - # (longest historical dataset available - # in France for eel ...) this suppose you have access to the pmp schema... - # a glimpse of the dataset is still available in the r_mig_interannual dataset # loaded in the package... r_mig_interannual <- new("report_mig_interannual") r_mig_interannual <- choice_c(r_mig_interannual, - dc=c(16), + dc=c(6), taxa=c("Anguilla anguilla"), - stage=c("PANG"), - start_year="1990", + stage=c("AGJ"), + start_year="2000", end_year="2015", silent=TRUE) r_mig_interannual <- charge(r_mig_interannual) @@ -37,14 +32,15 @@ stacomi( r_mig_interannual <- calcule(r_mig_interannual, silent=TRUE) } #############otherwise use this ###################### -# load the dataset generated by previous lines +# load the dataset generated for Parc du Marais poitevin +# From 1990 to 2015 data("r_mig_interannual") ####################################################### # the first plot is of little interest, it allows to see what data # are available... simple lines # For irregular operations like those reported at the enfrenaux eel ladder.... -plot(r_mig_interannual,plot.type="line",silent=TRUE) +plot(r_mig_interannual,plot.type="line", selected_year="2015", silent=TRUE) # a plot to show the seasonality, this graph may be misleading if the # migration is not monitored all year round. Note the y unit is not very informative @@ -61,7 +57,7 @@ plot(r_mig_interannual,plot.type="density",silent=TRUE) ############################################# # the standard plot is showing daily values ########################################### - plot(r_mig_interannual,plot.type="standard",silent=TRUE) + plot(r_mig_interannual,plot.type="standard", selected_year="2015", silent=TRUE) # Manual edition of the graph produced if (requireNamespace("ggplot2", quietly = TRUE)){ g1<-get("g1",envir=envir_stacomi) @@ -109,10 +105,10 @@ plot(r_mig_interannual,plot.type="density",silent=TRUE) # with the silent=TRUE argument, it's always the latest year that is selected, # otherwise the user is prompted with a choice, to select the year he wants # to compare will all others... - plot(r_mig_interannual,plot.type="barchart",timesplit="quinzaine",silent=TRUE) + plot(r_mig_interannual,plot.type="barchart",timesplit="quinzaine", selected_year = 2015, silent=TRUE) # Comparison with historical values. Each year and 2 weeks values # is a point on the graph... - plot(r_mig_interannual,plot.type="pointrange",timesplit="mois",silent=TRUE) + plot(r_mig_interannual,plot.type="pointrange",timesplit="mois", selected_year = 2015, silent=TRUE) ############################################### # Step plot # different years shown in the graph diff --git a/tests/testthat/test-02-report_mig.R b/tests/testthat/test-02-report_mig.R index 9137f3609b506175d904385f57f5d47724192b33..d4d591b28597bec0eed2d7000c13815670605756 100644 --- a/tests/testthat/test-02-report_mig.R +++ b/tests/testthat/test-02-report_mig.R @@ -97,7 +97,6 @@ test_that("Summary method works", #env_set_test_stacomi() stacomi(database_expected = FALSE, sch ="test") # overriding user schema - r_mig = new("report_mig") r_mig = choice_c( r_mig, dc = 5, diff --git a/tests/testthat/test-06-report_mig_interannual.R b/tests/testthat/test-06-report_mig_interannual.R index 853ec1f101ff726c3d070182d5b474aa059cc9ae..88eb77f820048dd34630ea156e45f5e6b2f8822e 100644 --- a/tests/testthat/test-06-report_mig_interannual.R +++ b/tests/testthat/test-06-report_mig_interannual.R @@ -214,11 +214,12 @@ test_that("Test bmi plots", { expect_output(plot(report_mig_interannual, plot.type = "step", silent = FALSE)) report_mig_interannual <- connect(report_mig_interannual, silent = TRUE) report_mig_interannual <- calcule(report_mig_interannual, silent = TRUE) - expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "step", silent = TRUE)),NA) - expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "line", silent = TRUE)),NA) - expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "standard", silent = TRUE)),NA) + expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "step", selected_year = 2015, silent = TRUE)),NA) + expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "line", selected_year = 2015,silent = TRUE)),NA) + expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "standard", silent = TRUE)),NA) expect_error(plot(report_mig_interannual, plot.type = "barchart", silent = TRUE),NA) expect_error(suppressMessages(plot(report_mig_interannual, plot.type = "pointrange", silent = TRUE)),NA) + expect_error(suppressMessages(plot(report_mig_interannual, plot.type = "pointrange", selected_year = 2015,timesplit="week", silent = TRUE)),NA) expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "density", silent = TRUE),NA)) expect_error(plot(report_mig_interannual, plot.type = "seasonal", silent = TRUE),NA) expect_error(suppressWarnings(plot(report_mig_interannual, plot.type = "seasonal", timesplit="semaine", silent = TRUE)),NA) @@ -253,7 +254,12 @@ test_that("Test bmi for several dc", { expect_error(suppressWarnings(plot(r_mig_interannual, plot.type = "line", silent = TRUE)),NA) expect_error(suppressWarnings(plot(r_mig_interannual, plot.type = "standard", silent = TRUE)),NA) expect_error(plot(r_mig_interannual, plot.type = "barchart", timesplit="day",silent = TRUE),NA) - expect_error(suppressMessages(plot(r_mig_interannual, plot.type = "pointrange", silent = TRUE)),NA) + expect_error(plot(r_mig_interannual, plot.type = "barchart", timesplit="week",silent = TRUE),NA) + expect_error(plot(r_mig_interannual, plot.type = "barchart", timesplit="jour",silent = TRUE),NA) + expect_error(plot(r_mig_interannual, plot.type = "barchart", timesplit="semaine",silent = TRUE),NA) + expect_error(plot(r_mig_interannual, plot.type = "barchart", timesplit="quinzaine",silent = TRUE),NA) + expect_error(plot(r_mig_interannual, plot.type = "barchart", timesplit="mois",silent = TRUE),NA) + expect_error(suppressMessages(plot(r_mig_interannual, plot.type = "pointrange", silent = TRUE)),NA) expect_error(suppressWarnings(plot(r_mig_interannual, plot.type = "density", silent = TRUE),NA)) expect_error(plot(r_mig_interannual, plot.type = "seasonal", silent = TRUE),NA) expect_error(suppressWarnings(plot(r_mig_interannual, plot.type = "seasonal", timesplit="semaine", silent = TRUE)),NA)