From abf52be4aaca423ea9af054855d0dcaab39b7a2d Mon Sep 17 00:00:00 2001
From: cedricbriandgithub <cedric.briand@eptb-vilaine.fr>
Date: Fri, 21 Oct 2022 12:06:13 +0200
Subject: [PATCH 1/2] dev: Change names for plot to assign to envir_stacomi
---
R/report_mig_interannual.R | 14 +++++++-------
tests/testthat/test-02-report_mig.R | 1 -
2 files changed, 7 insertions(+), 8 deletions(-)
diff --git a/R/report_mig_interannual.R b/R/report_mig_interannual.R
index a1a25fa..eb0a83c 100644
--- a/R/report_mig_interannual.R
+++ b/R/report_mig_interannual.R
@@ -989,7 +989,7 @@ setMethod(
date_labels = "%b") +
theme_bw()
print(g)
- assign("g", g, envir = envir_stacomi)
+ assign("g_line", g, envir = envir_stacomi)
if (!silent)
funout(
gettext(
@@ -1113,7 +1113,7 @@ setMethod(
)
g <- g + theme_bw() + theme(legend.key = element_blank())
print(g, vp = vplayout(1, 1))
- assign(paste("g", 1, sep = ""), g, envir_stacomi)
+ assign(paste("g_standard", 1, sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettextf(
@@ -1205,7 +1205,7 @@ setMethod(
c = 150
)# year
print(g)
- assign("g", g, envir_stacomi)
+ assign("g_step", g, envir_stacomi)
if (!silent)
funout(
gettext(
@@ -1391,7 +1391,7 @@ setMethod(
)
g <- g + theme_minimal()
print(g, vp = vplayout(1, 1))
- assign(paste("g", 1, sep = ""), g, envir_stacomi)
+ assign(paste("g_barchart", 1, sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettextf(
@@ -1536,7 +1536,7 @@ setMethod(
)
g <- g + theme_minimal()
print(g, vp = vplayout(1, 1))
- assign(paste("g", 1, sep = ""), g, envir_stacomi)
+ assign(paste("g_pointrange", 1, sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettextf(
@@ -1621,7 +1621,7 @@ setMethod(
)
g <- g + theme_minimal()
print(g)
- assign(paste("g", sep = ""), g, envir_stacomi)
+ assign(paste("g_density", sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettext(
@@ -1756,7 +1756,7 @@ setMethod(
) +
theme_bw()
print(g)
- assign("g", g, envir = envir_stacomi)
+ assign("g_seasonal", g, envir = envir_stacomi)
if (!silent)
funout(
gettext(
diff --git a/tests/testthat/test-02-report_mig.R b/tests/testthat/test-02-report_mig.R
index 9137f36..d4d591b 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,
--
GitLab
From be0c1dd9cc614d4a51fc9209469dc90ebdc4bc60 Mon Sep 17 00:00:00 2001
From: cedricbriandgithub <cedric.briand@eptb-vilaine.fr>
Date: Sun, 23 Oct 2022 20:56:00 +0200
Subject: [PATCH 2/2] mostly fixed, test running but see list in #45 and #46
---
R/report_mig_interannual.R | 3424 ++++++++---------
.../examples/report_mig_interannual-example.R | 28 +-
.../testthat/test-06-report_mig_interannual.R | 14 +-
3 files changed, 1701 insertions(+), 1765 deletions(-)
diff --git a/R/report_mig_interannual.R b/R/report_mig_interannual.R
index eb0a83c..0221aa5 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_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
- 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_standard", 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_step", 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_barchart", 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_pointrange", 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_density", 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_seasonal", 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 d04f80d..f14b114 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-06-report_mig_interannual.R b/tests/testthat/test-06-report_mig_interannual.R
index 853ec1f..88eb77f 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)
--
GitLab