Nothing
R/report_mig_interannual.R
In stacomiR: Fish Migration Monitoring
Defines functions
fun_report_mig_interannual
fn_connect_report_mig_interannual
Documented in
fn_connect_report_mig_interannual
fun_report_mig_interannual
#' Class "report_mig_interannual"
#'
#' When daily report are written in the t_reportjournalier_bjo table by the
#' \link{report_mig-class} they can be used by this class to display
#' interannual comparisons of migration.
#' When running its connect method, this class will run the \link{report_mig-class}
#' for each year where data are missing, or
#' where the annual sum in the t_reportjournalier_bjo table differs from the counts
#' generated by the \link{report_annual-class} : rows have been changed in the database.
#' Different charts are produced with different
#' period grouping. See \link{write_database,report_mig-method} for details about how
#' this method inserts data in the t_reportjournalier_bjo table.
#'
#' @include ref_year.R
#' @slot dc An object of class \link{ref_dc-class}, the counting device
#' @slot data A \code{data.frame} data loaded from the daily migration table t_bilanmigrationjournalier_bjo
#' @slot taxa An object of class \link{ref_taxa-class}, there can only be one taxa
#' @slot stage An object of class \link{ref_stage-class}, there can only be one stage
#' @slot start_year An object of class \link{ref_year-class}. ref_year allows to choose year of beginning
#' @slot end_year An object of class \link{ref_year-class}
#' ref_year allows to choose last year of the report
#' @slot calcdata A \code{list} of calculated data, filled in by the calcule method
#'
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_mig_interannual-example.R
#' @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()
)
)
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)]))
})
#' Get table content for table t_bilanmigrationjournalier_bjo in report_mig_interannual
#'
#' Each time a report mig runs, it can write its content in the t_bilanmigrationjournalier_bjo
#' table which stores the results of the report_mig with one value per day
#'
#' @param years A vector of years
#' @param taxa One taxa
#' @param stage One stage
#' @param dc A vector of counting devices
#' @return a data frame with the content of table t_bilanmigrationjournalier_bjo in the database
#' @export
fn_connect_report_mig_interannual <- function(years, taxa, stage, dc) {
requete = new("RequeteDBwhere")
requete@where = paste(
"WHERE bjo_annee IN ",
vector_to_listsql(years),
" AND bjo_tax_code='",
taxa,
"' AND bjo_std_code='",
stage,
"' AND bjo_dis_identifiant in",
vector_to_listsql(dc),
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)
}
#' connect method for report_mig_interannual
#'
#' This method will check if the data in the t_reportjournalier_bjo table has no missing data,
#' if missing the program will load missing data. As a second step,
#' the program will check if the numbers in the table t_reportjournalier_bjo differ from those in the database,
#' and propose to re-run the report_mig (which has a write_database methode to write daily reports) for those years.
#' @note We expect different results between daily reports from the t_reportjournalier_bjo table and the annual sums
#' from report_annual for glass eels as those may have been weighted and not only counted. The t_reportjournalier_bjo table used by report_mig_interannual
#' contains the sum of glass eel numbers converted from weights and those directly counted. The report_annual does not.
#' @param object An object of class \link{report_mig_interannual-class}
#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
#' @param check Checks that data are corresponding between report_annual and report_mig
#' @return report_mig_interannual an instantiated object with values filled with user choice
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @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"))
}
#---------------------------------------------------------------------------------------
#---------------------------------------------------------------------------------------
object@data <- fn_connect_report_mig_interannual(
years =(object@start_year@year_selected):(object@end_year@year_selected),
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
dc = object@dc@dc_selected)
if (nrow(object@data) == 0) {
funout(
gettextf("No data in table t_bilanmigrationjournalier_bjo", domain = "R-StacomiR")
)
check = TRUE
}
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),.groups="drop")
data24 <-
dplyr::filter(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) {
write_database(bM, silent = silent)
}
} # end for loop to write new reports
# reloading everything
object@data <- fn_connect_report_mig_interannual(
years =(object@start_year@year_selected):(object@end_year@year_selected),
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
dc = object@dc@dc_selected)
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, 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]
if (!silent) 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)
} else {
if (! silent)
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 shouldn't be the case, please check administrator."),
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_report_mig_interannual(
years =(object@start_year@year_selected):(object@end_year@year_selected),
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
dc = object@dc@dc_selected)
# 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
#' @param object An object of class \link{report_mig_interannual-class}
#' @param silent Should the operation be returning the number of rows deleted
#' @return nothing, called for its side effect, removing lines from the database
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases supprime.report_mig_interannual
setMethod(
"supprime",
signature = signature("report_mig_interannual"),
definition = function(object, silent =TRUE)
{
# 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
)
res1 <- pool::dbExecute(con@connection, statement = sql)
if (!silent) funout(gettextf("%s rows deleted in %st_bilanmigrationjournalier_bjo", res1, get_schema()))
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
)
res2 <- pool::dbExecute(con@connection, statement = sql)
if (!silent) funout(gettextf("%s rows deleted in %st_bilanmigrationmensuel_bme",res2,get_schema()))
return(invisible(NULL))
}
)
#' loading method for report_mig_interannual class
#' @param object An object of class \link{report_mig_interannual-class}
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_mig_interannual-class} with slots set from values assigned in \code{envir_stacomi} environment
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @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)
}
)
#' command line interface for report_mig_interannual class
#' @param object An object of class \link{report_mig_interannual-class}
#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
#' @param taxa Either a species name in latin or the SANDRE code for species (ie 2038=Anguilla anguilla),
#' it should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
#' @param stage A stage code matching the ref.tr_stadedeveloppement_std table in the stacomi database, see \link{choice_c,ref_stage-method}
#' @param start_year The starting the first year, passed as character or integer
#' @param end_year the finishing year
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_mig_interannual-class} with data selected
#' The choice_c method fills in the data slot for classes \link{ref_dc-class}, \link{ref_taxa-class}, \link{ref_stage-class} and two slots of \link{ref_year-class}
#' @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)
}
)
#' 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
#' 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"
#' @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)
}
)
#' statistics per time period
#'
#'
#' @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
#' @return a data frame with mean, max, and min calculated for each timesplit
#' @export
fun_report_mig_interannual = function(dat,
year = NULL,
timesplit = NULL)
{
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
}
#' Plot method for report_mig_interannual
#'
#' Several of these plots are scaled against the same year,i.e.the comparison is based on
#' year 2000, meaning that day 1 would correspond to the first date of 2000, which is also a
#' 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
#' French values "jour" "semaine" "quinzaine" "mois" are also accepted.
#' @param year_choice The year chosen to calculate statistics which will be plotted against the historical series,
#' should be a character vector of length one e.g. '2012', default NULL, when NULL the latest year is selected.
#' @param alpha, argument passed when plot.type=barchart, pointrange, standard default 1
#' @param silent Stops displaying the messages.
#' \describe{
#' \item{plot.type="line"}{One line per daily report_mig, a reference year is highlighted with year_choice, this graph
#' does not react to argument timesplit}
#' \item{plot.type="standard"}{The year selected in year_choice is displayed against a ribbon of historical values}
#' \item{plot.type="density"}{Creates density plot to compare seasonality, data computed by 15 days period, this graph ignore
#' the timesplit argument}
#' \item{plot.type="step"}{Creates step plots to compare seasonality, the year chosen in year_choice (or the interface if silent =FALSE, and year_choice=NULL, is the
#' latest if silent=TRUE, or it can be selected in the droplist. It is highlighted against the other with a dotted line}
#' \item{plot.type="barchart"}{Comparison of daily migration of one year against periodic migration for the other years available in the chronicle,
#' different periods can be chosen with argument timesplit}
#' \item{plot.type="pointrange"}{Pointrange graphs, different periods can be chosen with argument timesplit}
#' \item{plot.type="seasonal"}{Plot to display summary statistics about the migration period, different periods can be chosen with argument timesplit,
#' this graph ignores argument year_choice}
#' }
#' @return Nothing, called for its side effect of plotting
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_mig_interannual
#' @importFrom rlang sym
#' @export
setMethod(
"plot",
signature(x = "report_mig_interannual", y = "missing"),
definition = function(x,
plot.type = "standard",
timesplit = "month",
year_choice = NULL,
alpha=1,
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
)
if (nrow(report_mig_interannual@data) == 0) {
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"
)
)
} else {
dat <- report_mig_interannual@data
years_available <- as.character(unique(dat$bjo_annee)[order(unique(dat$bjo_annee))])
if (!is.null(year_choice)){
if (is.numeric(year_choice)) year_choice <- as.character(year_choice)
if (length(year_choice)>1) stop("year choice should be a character vector of length one, e.g. '2012'")
if (! year_choice %in% years_available) stop(gettextf("year_choice :%s is not within year range %s", year_choice, paste(years_available, collapse =","), domain="R-stacomiR"))
}
if (silent == FALSE & is.null(year_choice)) {
year_choice <-
as.numeric(
select.list(
choices = years_available,
preselect = as.character(max(dat$bjo_annee)),
gettext("Year choice", domain="R-stacomiR"),
multiple = FALSE
)
)
} else if (silent == FALSE & !is.null(year_choice)) {
year_choice <-
as.numeric(
select.list(
choices = years_available,
preselect = year_choice,
gettext("Year choice", domain="R-stacomiR"),
multiple = FALSE
)
)
} else if (silent == TRUE & is.null(year_choice)) {
year_choice <- max(dat$bjo_annee)
} else {
# do nothing, we will use year choice as passed
}
#-------------------------------------------------------------------------
if (plot.type == "line") {
# this one does not use year choice
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(color="grey",linewidth=1.5, data=subset(dat,dat$year==year_choice)) +
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_line',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
#----------------------------------------------
# does not use timesplit
} else if (plot.type == "standard") {
# dataset for current year
dat0 <-
fun_report_mig_interannual(dat, year = NULL, timesplit = NULL)
dat <-
fun_report_mig_interannual(dat, year = year_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(year_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(year_choice), 1, just =
"center")))
amplitudechoice <- paste(year_choice, '/', amplitude)
tmp <- dat0[as.numeric(as.character(dat0$year)) == year_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 = max(alpha-0.3,0.3)
)
g <-
g + geom_line(
aes(y = value, color = I("orange")),
alpha = max(alpha-0.3,0.3),
data = tmp
)
g <-
g + geom_point(aes(y = value, color = I("orange")),
size = 1.2,
data = tmp)
g <-
g + scale_fill_manual(
name = eval(amplitudechoice),
values = c("#35789C", "orange"),
labels = c(
gettext("Historical amplitude", domain = "R-StacomiR"),
year_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","orange"),
labels = c(stringr::str_c(
gettext("Interannual mean\n", domain = "R-stacomiR"),
amplitude
), year_choice)
) +
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"],
",",
year_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("g_standard", g, envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the graphical object into envir_stacomi environment : write g=get('g_standard',envir_stacomi)",
domain = "R-stacomiR")
)
} # end if plot==standard
#----------------------------------------------
} else if (plot.type == "step") {
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
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(year_choice), ]
g <- g + geom_step(aes(col = year, linewidth = 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_step',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
#----------------------------------------------
} else if (plot.type == "barchart") {
dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit)
dat1 <-
fun_report_mig_interannual(dat, year = year_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 == "month") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d")
} else if (timesplit == "week"){
dat[, timesplit] <- strftime(dat[, timesplit], format = "%W")
} else {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%j")
}
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(dat1$year))),
"-",
max(as.numeric(as.character(dat1$year))),
sep = "")
newdat <- prepare_dat(dat1)
newdat0 <- prepare_dat(dat0)
# 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(year_choice), 1, just = "center")))
selection <-
as.numeric(as.character(dat0$year)) == as.numeric(year_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 == "month") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d")
} else if (timesplit == "week") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W")
} else {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%j")
}
tmp[, timesplit] <- as.factor(tmp[, timesplit])
tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?"
newdat$comp <- NA
# 2 weeks creates some problems (it was with aes_string which has been removed)
# so it is replaced with fortnight maybe consider simplifying ?
if (timesplit=="2 weeks") {
timesplit <- "fortnight"
newdat<- chnames(newdat,"2 weeks", "fortnight")
tmp <- chnames(tmp,"2 weeks", "fortnight")
}
if (timesplit %in% c("week","day")){
tmp[,timesplit] <- as.numeric(as.character(tmp[,timesplit]))
newdat[,timesplit] <- as.numeric(as.character(newdat[,timesplit]))
}
timesplit <- rlang::sym(timesplit)
g <- ggplot(tmp, aes(x = !!timesplit, y = value))
g <- g + geom_crossbar(
data = newdat,
aes(
x = !!timesplit,
y = mean,
ymin = mintab,
ymax = maxtab
),
fill = "grey60",
alpha = alpha,
size = 0.5,
fatten = 3,
col = "grey60"
)
g <-
g + geom_bar(
stat = "identity",
aes(y = value, col = comp),
fill = NA,
width = 0.6,
size=0.1
)
g <-
g + geom_bar(
stat = "identity",
aes(y = value, fill = comp),
alpha = max(alpha-0.3,0.3),
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 = year_choice,
values = cols,
limits = c(
"min",
"max",
"<moy",
">=moy",
"hist_mean",
"hist_range",
"?"
)
)
g <- g + scale_fill_manual(
name = year_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()
if (timesplit=="fortnight") g <- g + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=0))
print(g)
assign("g_barchart", g, envir_stacomi)
if (!silent)
funout(
gettextf(
"Writing the graphical object into envir_stacomi environment : write g=get('g_barchart',envir_stacomi)",
)
)
#-------------------------------------------------------------------------
} 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
dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit)
dat1<-
fun_report_mig_interannual(dat, year = year_choice, timesplit = timesplit)
dat1$year <- as.factor(dat1$year)
dat1 <- dat1[order(dat1$year, dat1[, timesplit]), ]
dat1$keeptimesplit <- dat1[, timesplit]
if (timesplit == "month") {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%m/%d")
} else if (timesplit == "week") {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%W")
} else {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%j")
}
dat1[, timesplit] <- as.factor(dat1[, timesplit])
newdat <- dat1[match(unique(dat1[, timesplit]), dat1[, 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(dat1$year))), "-", max(as.numeric(as.character(dat1$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(year_choice), 1, just =
"center")))
selection <-
as.numeric(as.character(dat0$year)) == as.numeric(year_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 == "month") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d")
} else if (timesplit == "week") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W")
} else {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%j")
}
tmp[, timesplit] <- as.factor(tmp[, timesplit])
tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?"
newdat$comp <- NA
if (timesplit == "2 weeks") {
timesplit <- "fortnight"
newdat<- chnames(newdat,"2 weeks", "fortnight")
tmp <- chnames(tmp,"2 weeks", "fortnight")
dat1 <- chnames(dat1,"2 weeks", "fortnight")
}
timesplit <- rlang::sym(timesplit)
g <- ggplot(tmp, aes(x = !!timesplit, y = value))
g <-
g + geom_dotplot(
aes(x = !!timesplit, y = value),
data = dat1,
stackdir = "center",
binaxis = "y",
position = "dodge",
dotsize = 0.5,
fill = "wheat",
alpha=alpha
) #position = "dodge",dotsize = 0.4,alpha=0.5,binwidth = 1.5
g <-
g + geom_pointrange(
data = newdat,
aes(
x = !!timesplit,
y = mean,
ymin = mintab,
ymax = maxtab
),
alpha = alpha,
size = 0.8
)
g <-
g + geom_pointrange(
aes(
x = !!timesplit,
y = mean,
ymin = mintab,
ymax = maxtab,
color = comp),
alpha = max(alpha-0.4,0.3))
g <- g + scale_y_continuous(name = "effectif")
cols <-
c(
"max" = "blue",
"min" = "red",
">=moy" = "darkgreen",
"<moy" = "darkorange",
"0" = "grey10",
"?" = "darkviolet"
)
g <- g + scale_color_manual(name = year_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()
if (timesplit=="fortnight") g <- g + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=0))
print(g)
assign("g_pointrange", g, envir_stacomi)
if (!silent)
funout(
gettext(
"\"Writing the graphical object into envir_stacomi environment : write g=get(\"g_pointrange\",envir_stacomi)",
domain = "R-stacomiR")
)
#-------------------------------------------------------------------------
} else if (plot.type == "density") {
timesplit = "2 weeks"
dat1 <- fun_report_mig_interannual(dat, year = NULL, timesplit)
dat1$year <- as.factor(dat1$year)
sum_per_year <- tapply(dat1$value, dat1$year, sum)
sum_per_year <-
data.frame(year = names(sum_per_year),
sum_per_year = sum_per_year)
dat1 <- merge(dat1, sum_per_year, by = "year")
dat1$std_value <- dat1$value / dat1$sum_per_year
#dat <- chnames(dat, "2 weeks", "fortnight")
all_15 <- unique(dat1[, "2 weeks"])
# below I'm adding 0 instead of nothing for 15 days without value
for (i in 1:length(unique(dat1$year))) {
#i=5
year <- unique(dat1$year)[i]
this_year_15 <- unique(dat1[dat1$year == year, "2 weeks"])
missing <- all_15[!all_15 %in% this_year_15]
if (length(missing >= 1)) {
missingdat <- data.frame(
"year" = year,
"2 weeks" = missing, # this is what we get from the function
"value" = 0,
"maxtab" = 0,
"mintab" = 0,
"mean" = 0,
"sum_per_year" = 0,
"std_value" = 0
)
colnames(missingdat)[2] <- "2 weeks"
dat1 <- rbind(dat1, missingdat)
}
}
dat1 = dat1[order(dat1$year, dat1[, "2 weeks"]), ]
dat1 <- chnames(dat1, "2 weeks", "fortnight")
g <- ggplot(dat1, aes(x = fortnight, y = std_value))
g <-
g + geom_area(aes(y = std_value, fill = year), position =
"stack")
g <-
g + scale_x_datetime(
name = gettext("fortnight", domain = "R-stacomiR"),
date_breaks = "month",
date_minor_breaks = "2 weeks",
date_labels = "%b",
limits = as.POSIXct(c(
Hmisc::truncPOSIXt(min(dat1[dat1$value != 0, "fortnight"]), "days"),
Hmisc::ceil(max(dat1[dat1$value != "0", "fortnight"]), "days")
))
)
g <-
g + scale_y_continuous(name = gettext("Somme des pourcentages annuels de migration par quinzaine", domain = "R-stacomiR"))
cols <- grDevices::rainbow(length(levels(dat1$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("g_density", 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
)
#timesplit <- rlang::sym(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(x = !!rlang::sym(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"))) +
scale_x_date(
name =Hmisc::capitalize(gettext(timesplit, domain = "R-stacomiR")),
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 {
# end if
stop ("plot.type argument invalid")
}
} # end else
return(invisible(NULL))
}
)
#' summary for report_mig_interannual
#' provides summary statistics for the latest year (if silent=TRUE), or the year selected in the interface,
#' if silent=FALSE. Mean, min and max are historical statistics and they always include the current year from the
#' historical dataset.
#' @param object An object of class \code{\link{report_mig_interannual-class}}
#' @param year_choice The year chosen to calculate statistics which will be displayed beside the historical series,
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters (not used there)
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_mig_interannual
#' @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
#browser()
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)) {
funtable(
tableau = dat0[dat0$DC == DC[i], ],
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) {
year_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 {
year_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=",")))
}
year_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 == year_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 <- year_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)
}
)
Try the stacomiR package in your browser
Any scripts or data that you put into this service are public.
stacomiR documentation built on May 29, 2024, 10:41 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions fun_report_mig_interannual fn_connect_report_mig_interannual
Documented in fn_connect_report_mig_interannual fun_report_mig_interannual
#' Class "report_mig_interannual"
#'
#' When daily report are written in the t_reportjournalier_bjo table by the
#' \link{report_mig-class} they can be used by this class to display
#' interannual comparisons of migration.
#' When running its connect method, this class will run the \link{report_mig-class}
#' for each year where data are missing, or
#' where the annual sum in the t_reportjournalier_bjo table differs from the counts
#' generated by the \link{report_annual-class} : rows have been changed in the database.
#' Different charts are produced with different
#' period grouping. See \link{write_database,report_mig-method} for details about how
#' this method inserts data in the t_reportjournalier_bjo table.
#'
#' @include ref_year.R
#' @slot dc An object of class \link{ref_dc-class}, the counting device
#' @slot data A \code{data.frame} data loaded from the daily migration table t_bilanmigrationjournalier_bjo
#' @slot taxa An object of class \link{ref_taxa-class}, there can only be one taxa
#' @slot stage An object of class \link{ref_stage-class}, there can only be one stage
#' @slot start_year An object of class \link{ref_year-class}. ref_year allows to choose year of beginning
#' @slot end_year An object of class \link{ref_year-class}
#' ref_year allows to choose last year of the report
#' @slot calcdata A \code{list} of calculated data, filled in by the calcule method
#'
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_mig_interannual-example.R
#' @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()
)
)
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)]))
})
#' Get table content for table t_bilanmigrationjournalier_bjo in report_mig_interannual
#'
#' Each time a report mig runs, it can write its content in the t_bilanmigrationjournalier_bjo
#' table which stores the results of the report_mig with one value per day
#'
#' @param years A vector of years
#' @param taxa One taxa
#' @param stage One stage
#' @param dc A vector of counting devices
#' @return a data frame with the content of table t_bilanmigrationjournalier_bjo in the database
#' @export
fn_connect_report_mig_interannual <- function(years, taxa, stage, dc) {
requete = new("RequeteDBwhere")
requete@where = paste(
"WHERE bjo_annee IN ",
vector_to_listsql(years),
" AND bjo_tax_code='",
taxa,
"' AND bjo_std_code='",
stage,
"' AND bjo_dis_identifiant in",
vector_to_listsql(dc),
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)
}
#' connect method for report_mig_interannual
#'
#' This method will check if the data in the t_reportjournalier_bjo table has no missing data,
#' if missing the program will load missing data. As a second step,
#' the program will check if the numbers in the table t_reportjournalier_bjo differ from those in the database,
#' and propose to re-run the report_mig (which has a write_database methode to write daily reports) for those years.
#' @note We expect different results between daily reports from the t_reportjournalier_bjo table and the annual sums
#' from report_annual for glass eels as those may have been weighted and not only counted. The t_reportjournalier_bjo table used by report_mig_interannual
#' contains the sum of glass eel numbers converted from weights and those directly counted. The report_annual does not.
#' @param object An object of class \link{report_mig_interannual-class}
#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
#' @param check Checks that data are corresponding between report_annual and report_mig
#' @return report_mig_interannual an instantiated object with values filled with user choice
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @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"))
}
#---------------------------------------------------------------------------------------
#---------------------------------------------------------------------------------------
object@data <- fn_connect_report_mig_interannual(
years =(object@start_year@year_selected):(object@end_year@year_selected),
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
dc = object@dc@dc_selected)
if (nrow(object@data) == 0) {
funout(
gettextf("No data in table t_bilanmigrationjournalier_bjo", domain = "R-StacomiR")
)
check = TRUE
}
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),.groups="drop")
data24 <-
dplyr::filter(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) {
write_database(bM, silent = silent)
}
} # end for loop to write new reports
# reloading everything
object@data <- fn_connect_report_mig_interannual(
years =(object@start_year@year_selected):(object@end_year@year_selected),
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
dc = object@dc@dc_selected)
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, 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]
if (!silent) 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)
} else {
if (! silent)
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 shouldn't be the case, please check administrator."),
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_report_mig_interannual(
years =(object@start_year@year_selected):(object@end_year@year_selected),
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
dc = object@dc@dc_selected)
# 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
#' @param object An object of class \link{report_mig_interannual-class}
#' @param silent Should the operation be returning the number of rows deleted
#' @return nothing, called for its side effect, removing lines from the database
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases supprime.report_mig_interannual
setMethod(
"supprime",
signature = signature("report_mig_interannual"),
definition = function(object, silent =TRUE)
{
# 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
)
res1 <- pool::dbExecute(con@connection, statement = sql)
if (!silent) funout(gettextf("%s rows deleted in %st_bilanmigrationjournalier_bjo", res1, get_schema()))
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
)
res2 <- pool::dbExecute(con@connection, statement = sql)
if (!silent) funout(gettextf("%s rows deleted in %st_bilanmigrationmensuel_bme",res2,get_schema()))
return(invisible(NULL))
}
)
#' loading method for report_mig_interannual class
#' @param object An object of class \link{report_mig_interannual-class}
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_mig_interannual-class} with slots set from values assigned in \code{envir_stacomi} environment
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @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)
}
)
#' command line interface for report_mig_interannual class
#' @param object An object of class \link{report_mig_interannual-class}
#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
#' @param taxa Either a species name in latin or the SANDRE code for species (ie 2038=Anguilla anguilla),
#' it should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
#' @param stage A stage code matching the ref.tr_stadedeveloppement_std table in the stacomi database, see \link{choice_c,ref_stage-method}
#' @param start_year The starting the first year, passed as character or integer
#' @param end_year the finishing year
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_mig_interannual-class} with data selected
#' The choice_c method fills in the data slot for classes \link{ref_dc-class}, \link{ref_taxa-class}, \link{ref_stage-class} and two slots of \link{ref_year-class}
#' @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)
}
)
#' 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
#' 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"
#' @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)
}
)
#' statistics per time period
#'
#'
#' @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
#' @return a data frame with mean, max, and min calculated for each timesplit
#' @export
fun_report_mig_interannual = function(dat,
year = NULL,
timesplit = NULL)
{
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
}
#' Plot method for report_mig_interannual
#'
#' Several of these plots are scaled against the same year,i.e.the comparison is based on
#' year 2000, meaning that day 1 would correspond to the first date of 2000, which is also a
#' 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
#' French values "jour" "semaine" "quinzaine" "mois" are also accepted.
#' @param year_choice The year chosen to calculate statistics which will be plotted against the historical series,
#' should be a character vector of length one e.g. '2012', default NULL, when NULL the latest year is selected.
#' @param alpha, argument passed when plot.type=barchart, pointrange, standard default 1
#' @param silent Stops displaying the messages.
#' \describe{
#' \item{plot.type="line"}{One line per daily report_mig, a reference year is highlighted with year_choice, this graph
#' does not react to argument timesplit}
#' \item{plot.type="standard"}{The year selected in year_choice is displayed against a ribbon of historical values}
#' \item{plot.type="density"}{Creates density plot to compare seasonality, data computed by 15 days period, this graph ignore
#' the timesplit argument}
#' \item{plot.type="step"}{Creates step plots to compare seasonality, the year chosen in year_choice (or the interface if silent =FALSE, and year_choice=NULL, is the
#' latest if silent=TRUE, or it can be selected in the droplist. It is highlighted against the other with a dotted line}
#' \item{plot.type="barchart"}{Comparison of daily migration of one year against periodic migration for the other years available in the chronicle,
#' different periods can be chosen with argument timesplit}
#' \item{plot.type="pointrange"}{Pointrange graphs, different periods can be chosen with argument timesplit}
#' \item{plot.type="seasonal"}{Plot to display summary statistics about the migration period, different periods can be chosen with argument timesplit,
#' this graph ignores argument year_choice}
#' }
#' @return Nothing, called for its side effect of plotting
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_mig_interannual
#' @importFrom rlang sym
#' @export
setMethod(
"plot",
signature(x = "report_mig_interannual", y = "missing"),
definition = function(x,
plot.type = "standard",
timesplit = "month",
year_choice = NULL,
alpha=1,
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
)
if (nrow(report_mig_interannual@data) == 0) {
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"
)
)
} else {
dat <- report_mig_interannual@data
years_available <- as.character(unique(dat$bjo_annee)[order(unique(dat$bjo_annee))])
if (!is.null(year_choice)){
if (is.numeric(year_choice)) year_choice <- as.character(year_choice)
if (length(year_choice)>1) stop("year choice should be a character vector of length one, e.g. '2012'")
if (! year_choice %in% years_available) stop(gettextf("year_choice :%s is not within year range %s", year_choice, paste(years_available, collapse =","), domain="R-stacomiR"))
}
if (silent == FALSE & is.null(year_choice)) {
year_choice <-
as.numeric(
select.list(
choices = years_available,
preselect = as.character(max(dat$bjo_annee)),
gettext("Year choice", domain="R-stacomiR"),
multiple = FALSE
)
)
} else if (silent == FALSE & !is.null(year_choice)) {
year_choice <-
as.numeric(
select.list(
choices = years_available,
preselect = year_choice,
gettext("Year choice", domain="R-stacomiR"),
multiple = FALSE
)
)
} else if (silent == TRUE & is.null(year_choice)) {
year_choice <- max(dat$bjo_annee)
} else {
# do nothing, we will use year choice as passed
}
#-------------------------------------------------------------------------
if (plot.type == "line") {
# this one does not use year choice
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(color="grey",linewidth=1.5, data=subset(dat,dat$year==year_choice)) +
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_line',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
#----------------------------------------------
# does not use timesplit
} else if (plot.type == "standard") {
# dataset for current year
dat0 <-
fun_report_mig_interannual(dat, year = NULL, timesplit = NULL)
dat <-
fun_report_mig_interannual(dat, year = year_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(year_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(year_choice), 1, just =
"center")))
amplitudechoice <- paste(year_choice, '/', amplitude)
tmp <- dat0[as.numeric(as.character(dat0$year)) == year_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 = max(alpha-0.3,0.3)
)
g <-
g + geom_line(
aes(y = value, color = I("orange")),
alpha = max(alpha-0.3,0.3),
data = tmp
)
g <-
g + geom_point(aes(y = value, color = I("orange")),
size = 1.2,
data = tmp)
g <-
g + scale_fill_manual(
name = eval(amplitudechoice),
values = c("#35789C", "orange"),
labels = c(
gettext("Historical amplitude", domain = "R-StacomiR"),
year_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","orange"),
labels = c(stringr::str_c(
gettext("Interannual mean\n", domain = "R-stacomiR"),
amplitude
), year_choice)
) +
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"],
",",
year_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("g_standard", g, envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the graphical object into envir_stacomi environment : write g=get('g_standard',envir_stacomi)",
domain = "R-stacomiR")
)
} # end if plot==standard
#----------------------------------------------
} else if (plot.type == "step") {
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
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(year_choice), ]
g <- g + geom_step(aes(col = year, linewidth = 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_step',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
#----------------------------------------------
} else if (plot.type == "barchart") {
dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit)
dat1 <-
fun_report_mig_interannual(dat, year = year_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 == "month") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d")
} else if (timesplit == "week"){
dat[, timesplit] <- strftime(dat[, timesplit], format = "%W")
} else {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%j")
}
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(dat1$year))),
"-",
max(as.numeric(as.character(dat1$year))),
sep = "")
newdat <- prepare_dat(dat1)
newdat0 <- prepare_dat(dat0)
# 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(year_choice), 1, just = "center")))
selection <-
as.numeric(as.character(dat0$year)) == as.numeric(year_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 == "month") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d")
} else if (timesplit == "week") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W")
} else {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%j")
}
tmp[, timesplit] <- as.factor(tmp[, timesplit])
tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?"
newdat$comp <- NA
# 2 weeks creates some problems (it was with aes_string which has been removed)
# so it is replaced with fortnight maybe consider simplifying ?
if (timesplit=="2 weeks") {
timesplit <- "fortnight"
newdat<- chnames(newdat,"2 weeks", "fortnight")
tmp <- chnames(tmp,"2 weeks", "fortnight")
}
if (timesplit %in% c("week","day")){
tmp[,timesplit] <- as.numeric(as.character(tmp[,timesplit]))
newdat[,timesplit] <- as.numeric(as.character(newdat[,timesplit]))
}
timesplit <- rlang::sym(timesplit)
g <- ggplot(tmp, aes(x = !!timesplit, y = value))
g <- g + geom_crossbar(
data = newdat,
aes(
x = !!timesplit,
y = mean,
ymin = mintab,
ymax = maxtab
),
fill = "grey60",
alpha = alpha,
size = 0.5,
fatten = 3,
col = "grey60"
)
g <-
g + geom_bar(
stat = "identity",
aes(y = value, col = comp),
fill = NA,
width = 0.6,
size=0.1
)
g <-
g + geom_bar(
stat = "identity",
aes(y = value, fill = comp),
alpha = max(alpha-0.3,0.3),
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 = year_choice,
values = cols,
limits = c(
"min",
"max",
"<moy",
">=moy",
"hist_mean",
"hist_range",
"?"
)
)
g <- g + scale_fill_manual(
name = year_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()
if (timesplit=="fortnight") g <- g + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=0))
print(g)
assign("g_barchart", g, envir_stacomi)
if (!silent)
funout(
gettextf(
"Writing the graphical object into envir_stacomi environment : write g=get('g_barchart',envir_stacomi)",
)
)
#-------------------------------------------------------------------------
} 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
dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit)
dat1<-
fun_report_mig_interannual(dat, year = year_choice, timesplit = timesplit)
dat1$year <- as.factor(dat1$year)
dat1 <- dat1[order(dat1$year, dat1[, timesplit]), ]
dat1$keeptimesplit <- dat1[, timesplit]
if (timesplit == "month") {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%m/%d")
} else if (timesplit == "week") {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%W")
} else {
dat1[, timesplit] <- strftime(dat1[, timesplit], format = "%j")
}
dat1[, timesplit] <- as.factor(dat1[, timesplit])
newdat <- dat1[match(unique(dat1[, timesplit]), dat1[, 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(dat1$year))), "-", max(as.numeric(as.character(dat1$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(year_choice), 1, just =
"center")))
selection <-
as.numeric(as.character(dat0$year)) == as.numeric(year_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 == "month") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m")
} else if (timesplit == "2 weeks") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d")
} else if (timesplit == "week") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W")
} else {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%j")
}
tmp[, timesplit] <- as.factor(tmp[, timesplit])
tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?"
newdat$comp <- NA
if (timesplit == "2 weeks") {
timesplit <- "fortnight"
newdat<- chnames(newdat,"2 weeks", "fortnight")
tmp <- chnames(tmp,"2 weeks", "fortnight")
dat1 <- chnames(dat1,"2 weeks", "fortnight")
}
timesplit <- rlang::sym(timesplit)
g <- ggplot(tmp, aes(x = !!timesplit, y = value))
g <-
g + geom_dotplot(
aes(x = !!timesplit, y = value),
data = dat1,
stackdir = "center",
binaxis = "y",
position = "dodge",
dotsize = 0.5,
fill = "wheat",
alpha=alpha
) #position = "dodge",dotsize = 0.4,alpha=0.5,binwidth = 1.5
g <-
g + geom_pointrange(
data = newdat,
aes(
x = !!timesplit,
y = mean,
ymin = mintab,
ymax = maxtab
),
alpha = alpha,
size = 0.8
)
g <-
g + geom_pointrange(
aes(
x = !!timesplit,
y = mean,
ymin = mintab,
ymax = maxtab,
color = comp),
alpha = max(alpha-0.4,0.3))
g <- g + scale_y_continuous(name = "effectif")
cols <-
c(
"max" = "blue",
"min" = "red",
">=moy" = "darkgreen",
"<moy" = "darkorange",
"0" = "grey10",
"?" = "darkviolet"
)
g <- g + scale_color_manual(name = year_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()
if (timesplit=="fortnight") g <- g + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=0))
print(g)
assign("g_pointrange", g, envir_stacomi)
if (!silent)
funout(
gettext(
"\"Writing the graphical object into envir_stacomi environment : write g=get(\"g_pointrange\",envir_stacomi)",
domain = "R-stacomiR")
)
#-------------------------------------------------------------------------
} else if (plot.type == "density") {
timesplit = "2 weeks"
dat1 <- fun_report_mig_interannual(dat, year = NULL, timesplit)
dat1$year <- as.factor(dat1$year)
sum_per_year <- tapply(dat1$value, dat1$year, sum)
sum_per_year <-
data.frame(year = names(sum_per_year),
sum_per_year = sum_per_year)
dat1 <- merge(dat1, sum_per_year, by = "year")
dat1$std_value <- dat1$value / dat1$sum_per_year
#dat <- chnames(dat, "2 weeks", "fortnight")
all_15 <- unique(dat1[, "2 weeks"])
# below I'm adding 0 instead of nothing for 15 days without value
for (i in 1:length(unique(dat1$year))) {
#i=5
year <- unique(dat1$year)[i]
this_year_15 <- unique(dat1[dat1$year == year, "2 weeks"])
missing <- all_15[!all_15 %in% this_year_15]
if (length(missing >= 1)) {
missingdat <- data.frame(
"year" = year,
"2 weeks" = missing, # this is what we get from the function
"value" = 0,
"maxtab" = 0,
"mintab" = 0,
"mean" = 0,
"sum_per_year" = 0,
"std_value" = 0
)
colnames(missingdat)[2] <- "2 weeks"
dat1 <- rbind(dat1, missingdat)
}
}
dat1 = dat1[order(dat1$year, dat1[, "2 weeks"]), ]
dat1 <- chnames(dat1, "2 weeks", "fortnight")
g <- ggplot(dat1, aes(x = fortnight, y = std_value))
g <-
g + geom_area(aes(y = std_value, fill = year), position =
"stack")
g <-
g + scale_x_datetime(
name = gettext("fortnight", domain = "R-stacomiR"),
date_breaks = "month",
date_minor_breaks = "2 weeks",
date_labels = "%b",
limits = as.POSIXct(c(
Hmisc::truncPOSIXt(min(dat1[dat1$value != 0, "fortnight"]), "days"),
Hmisc::ceil(max(dat1[dat1$value != "0", "fortnight"]), "days")
))
)
g <-
g + scale_y_continuous(name = gettext("Somme des pourcentages annuels de migration par quinzaine", domain = "R-stacomiR"))
cols <- grDevices::rainbow(length(levels(dat1$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("g_density", 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
)
#timesplit <- rlang::sym(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(x = !!rlang::sym(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"))) +
scale_x_date(
name =Hmisc::capitalize(gettext(timesplit, domain = "R-stacomiR")),
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 {
# end if
stop ("plot.type argument invalid")
}
} # end else
return(invisible(NULL))
}
)
#' summary for report_mig_interannual
#' provides summary statistics for the latest year (if silent=TRUE), or the year selected in the interface,
#' if silent=FALSE. Mean, min and max are historical statistics and they always include the current year from the
#' historical dataset.
#' @param object An object of class \code{\link{report_mig_interannual-class}}
#' @param year_choice The year chosen to calculate statistics which will be displayed beside the historical series,
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters (not used there)
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_mig_interannual
#' @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
#browser()
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)) {
funtable(
tableau = dat0[dat0$DC == DC[i], ],
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) {
year_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 {
year_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=",")))
}
year_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 == year_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 <- year_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)
}
)
Try the stacomiR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.