Nothing
#' 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}
#' @slot stage An object of class \link{ref_stage-class}
#' @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)]))
})
#' 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"))
}
#---------------------------------------------------------------------------------------
fn_connect <- function() {
les_annees = (object@start_year@year_selected):(object@end_year@year_selected)
tax = object@taxa@taxa_selected
std = object@stage@stage_selected
dic = object@dc@dc_selected
requete = new("RequeteDBwhere")
requete@where = paste(
"WHERE bjo_annee IN ",
vector_to_listsql(les_annees),
" AND bjo_tax_code='",
tax,
"' AND bjo_std_code='",
std,
"' AND bjo_dis_identifiant in",
vector_to_listsql(dic),
sep = ""
)
requete@select = paste(
"SELECT * FROM ",
get_schema(),
"t_bilanmigrationjournalier_bjo",
sep = ""
)
requete@order_by = " ORDER BY bjo_jour "
requete <- stacomirtools::query(requete)
t_bilanmigrationjournalier_bjo <- requete@query
if (nrow(t_bilanmigrationjournalier_bjo)>0) {
t_bilanmigrationjournalier_bjo <- stacomirtools::killfactor(t_bilanmigrationjournalier_bjo)
}
return(t_bilanmigrationjournalier_bjo)
}
#---------------------------------------------------------------------------------------
object@data <- fn_connect()
if (nrow(object@data) == 0) {
funout(
gettextf("No data in table t_bilanmigrationjournalier_bjo", domain = "R-StacomiR")
)
check = TRUE
}
#browser()
if (check) {
#----------------------------------------------------------------------
# Loading a report Annuel to compare numbers
#----------------------------------------------------------------------
report_annual <- as(object, "report_annual")
report_annual <- connect(report_annual)
#----------------------------------------------------------------------
# MAIN LOOP, there can be several dic
#----------------------------------------------------------------------
dic <- object@dc@dc_selected
for (i in 1:length(dic)) {
#i=1
############################################
# function creating a table to compare actual counts with those stored in
# in the t_reportjournalier_bjo table
###########################################
#==========================================
fn_check <- function() {
data1 <-
report_annual@data[report_annual@data$ope_dic_identifiant == dic[i], c("effectif", "annee")]
# data from report_migInterannuel
data2 <- object@data[object@data$bjo_dis_identifiant == dic[i], ]
data21 <-
dplyr::select(data2, bjo_annee, bjo_valeur, bjo_labelquantite)
data22 <- dplyr::group_by(data21, bjo_annee, bjo_labelquantite)
if (nrow(data22) == 0)
data22$bjo_valeur <- as.numeric(data22$bjo_valeur)
data23 <- dplyr::summarize(data22, total = sum(bjo_valeur))
data24 <-
dplyr::filter(dplyr::ungroup(data23),
bjo_labelquantite == "Effectif_total")
data24 <- dplyr::select(data24, bjo_annee, total)
data24 <-
dplyr::rename(data24, annee = bjo_annee, effectif_bjo = total)
data124 <- merge(data1,
data24,
all.x = TRUE,
all.y = TRUE,
by = "annee")
return(data124)
}
#==========================================
# table with 3 columns : annee; effectif; effectif_bjo
compared_numbers <- fn_check()
# as we have changed the report_annual to split data between years
# some unwanted data might step in outside the year range
# we correct for that
compared_numbers <- compared_numbers[compared_numbers$annee >= object@start_year@year_selected &
compared_numbers$annee <= object@end_year@year_selected, ]
#-------------------------------------------------------------------------------------
# First test, if missing data, the program will propose to load the data by running report_mig
#-------------------------------------------------------------------------------------
# when data are missing, NA appear in the effectif_bjo column
if (any(is.na(compared_numbers$effectif_bjo))) {
index_missing_years <- which(is.na(compared_numbers$effectif_bjo))
missing_years <- compared_numbers$annee[index_missing_years]
if (!silent &
length(dic) > 1)
funout(gettextf("DC with missing values : %s ", dic[i], domain = "R-StacomiR"))
if (!silent)
funout(gettextf(
"Years with no value : %s ",
stringr::str_c(missing_years, collapse = "; "),
domain = "R-StacomiR"
))
if (!silent)
funout(
gettextf(
"Some years are missing in the t_reportjournalier_bjo table, loading them now !",
domain = "R-StacomiR"
)
)
for (y in 1:length(missing_years)) {
Y <- missing_years[y]
bM = new("report_mig")
if (!silent)
funout(gettextf("Running report_mig for year %s", Y, domain = "R-StacomiR"))
bM = choice_c(
bM,
dc = dic[i],
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
datedebut = stringr::str_c(Y, "-01-01"),
datefin = stringr::str_c(Y, "-12-31")
)
bM <- charge(bM, silent = silent)
bM <- connect(bM, silent = silent)
bM <- calcule(bM, silent = silent)
if (nrow(bM@data) > 0) {
# below the argument check_for_bjo is necessary
# as the write database method from report_mig
# uses the connect method from report_mig_interannual and the
# program runs in endless loops...
write_database(bM, silent = silent, check_for_bjo = FALSE)
}
} # end for loop to write new reports
# reloading everything
object@data <- fn_connect()
compared_numbers <- fn_check()
} # end if any...
#-------------------------------------------------------------------------------------
# Second test, for existing report with different numbers, again the data will be witten again
# if the previous test failed, and user confirmed that there was a problem
# the object@data and compared_numbers are reloaded (see above)
# this test will only be run if the stage is not glass eel, for glass eels it does not make sense
# as some of the "effectif_total" in the bjo table correspond to weights not counts.
#-------------------------------------------------------------------------------------
if (object@taxa@taxa_selected == 2038 &
object@stage@stage_selected == "CIV") {
if (!silent)
funout(
gettext(
"For glass eel it is not possible to check that data are up to date",
domain = "R-StacomiR"
)
)
} else if (!all(round(compared_numbers$effectif) == round(compared_numbers$effectif_bjo))) {
index_different_years <-
which(round(compared_numbers$effectif) != round(compared_numbers$effectif_bjo))
differing_years <- compared_numbers$annee[index_different_years]
if (!silent)
funout(
gettextf(
"Years with values differing between t_reportjournalier_bjo and report_annual : %s ",
stringr::str_c(differing_years, collapse = "; "),
domain = "R-StacomiR"
)
)
#==================================
reload_years_with_error = function() {
bM = new("report_mig")
for (Y in differing_years) {
# Y=differing_years[1]
funout(gettextf("Running report_mig to correct data for year %s", Y))
bM = choice_c(
bM,
dc = dic[i],
taxa = object@taxa@taxa_selected,
stage = object@stage@stage_selected,
datedebut = stringr::str_c(Y, "-01-01"),
datefin = stringr::str_c(Y, "-12-31")
)
bM <- charge(bM, silent = silent)
bM <- connect(bM, silent = silent)
bM <- calcule(bM, silent = silent)
# report annual may have different numbers from report mig
# so I'm adding an additional check there
bma_num <- compared_numbers[compared_numbers$annee==Y,"effectif"]
bjo_num <- compared_numbers[compared_numbers$annee==Y,"effectif_bjo"]
bjo_num_new <- sum(bM@calcdata[[stringr::str_c("dc_", dic[i])]][["data"]][,"Effectif_total"])
if (nrow(bM@data) > 0) {
if (!round(bjo_num_new) == round(bjo_num)){
# check for bjo will ensure that previous report are deleted
write_database(bM,
silent = silent,
check_for_bjo = TRUE)
} else {
funout(
gettextf(
paste("There is a difference between report_annual Na= %s and report_mig ",
"Nj= %s but the sums are the same between report_mig and the database (t_bilanmigrationjournalier_bjo).",
"This difference is due to migration report overlapping between two years and the program. No writing in the db."),
round(bma_num), round(bjo_num),
domain = "R-StacomiR"
)
)
} # end else numbers are equal => do nothing
} # end test nrow
} # end for loop to write new reports
# the data are loaded again
object@data <- fn_connect()
# I need to assign the result one step up (in the environment of the connect function)
assign("object", object, envir = parent.frame(n = 1))
} # end reload year with errors
#==================================
if (!silent) {
choice2 <-
menu(
c("yes", "no"),
graphics = TRUE,
title = gettextf("Data changed, rerun ?", domain = "R-StacomiR")
)
if (choice2 == 1)
reload_years_with_error()
} else {
reload_years_with_error()
}
} # secondary check
} # end for
} # end check
#-------------------------------------------------------------------------------------
# Final check for data
# index of data already present in the database
#-------------------------------------------------------------------------------------
les_annees = object@start_year@year_selected:object@end_year@year_selected
index = unique(object@data$bjo_annee) %in% les_annees
# s'il manque des donnees pour certaines annees selectionnnees"
if (!silent) {
if (length(les_annees[!index]) > 0)
{
funout(paste(
gettext(
"Attention, there is no migration summary for these year\n",
domain = "R-stacomiR"
),
paste(les_annees[!index], collapse = ","),
gettext(
", this taxa and this stage (report_mig_interannual.r)\n",
domain = "R-stacomiR"
)
))
} # end if
# si toutes les annees sont presentes
if (length(les_annees[index]) > 0) {
funout(paste(
gettext("Interannual migrations query completed", domain = "R-stacomiR"),
paste(les_annees[index], collapse = ","),
"\n"
))
}
}
return(object)
}
)
#' supprime method for report_mig_interannual class, deletes values in table t_bilanmigrationjournalier_bjo
#' @param object An object of class \link{report_mig_interannual-class}
#' @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)
{
# recuperation des annees taxa et stage concernes
les_annees = (object@start_year@year_selected):(object@end_year@year_selected)
tax = object@taxa@taxa_selected
std = object@stage@stage_selected
dic = object@dc@dc_selected
con = new("ConnectionDB")
con <- connect(con)
on.exit(pool::poolClose(con@connection))
sql = stringr::str_c(
"DELETE from ",
get_schema(),
"t_bilanmigrationjournalier_bjo ",
" WHERE bjo_annee IN (",
paste(les_annees, collapse = ","),
") AND bjo_tax_code='",
tax,
"' AND bjo_std_code='",
std,
"' AND bjo_dis_identifiant=",
dic
)
pool::dbExecute(con@connection, statement = sql)
sql = stringr::str_c(
"DELETE from ",
get_schema(),
"t_bilanmigrationmensuel_bme ",
" WHERE bme_annee IN (",
paste(les_annees, collapse = ","),
") AND bme_tax_code='",
tax,
"' AND bme_std_code='",
std,
"' AND bme_dis_identifiant=",
dic
)
pool::dbExecute(con@connection, statement = sql)
return(invisible(NULL))
}
)
#' 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
#'
#' function called for report_mig_mult objects renames columns
#' replaces nulls, and calculates reports with time period larger than day
#'
#' @param dat a data frame with columns ("bjo_annee","bjo_jour","bjo_labelquantite","bjo_valeur")
#' @param annee The year to exclude from the historical series (it will be plotted against the historical series)
#' @param timesplit "week" "2 week" "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,
annee = 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("annee", "jour", "labelquantite", "valeur")
)
dat <- dat[, c("annee", "jour", "valeur")]
if (!is.null(annee)) {
dat <- dat[dat$annee != annee, ]
}
dat$jour <- trunc.POSIXt(dat$jour, digits = 'days')
dat$jour <- as.Date(strptime(strftime(dat$jour, '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 = getvalue(new("ref_period"), timesplit)
)
seq_timesplit <- as.Date(trunc(seq_timesplit, digits = 'days'))
dat[, timesplit] <- dat$jour #
for (j in 1:(length(seq_timesplit) - 1)) {
dat[dat$jour >= seq_timesplit[j] &
dat$jour < seq_timesplit[j + 1], timesplit] <-
seq_timesplit[j]
}
dat[dat$jour >= seq_timesplit[length(seq_timesplit)], timesplit] <-
seq_timesplit[length(seq_timesplit)]
dat[, "interv"] <- paste(dat[, "annee"], dat[, timesplit])
res <- tapply(dat$valeur, dat[, "interv"], sum, na.rm = TRUE)
datc <-
data.frame(
"annee" = substr(names(res), 1, 4),
timesplit = substr(names(res), 5, 15),
"valeur" = as.numeric(res)
)
colnames(datc)[2] <- timesplit
dat <- datc
rm(datc)
} else {
# if null default value is day
timesplit <- "jour"
jour2000 <- 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$annee)) {
# days without report are added with a zero
jour2000restant <-
jour2000[!jour2000 %in% dat[dat$annee == j, "jour"]]
dat0 <- data.frame("jour" = jour2000restant,
"annee" = j,
"valeur" = NA)
dat <- rbind(dat, dat0)
} # end for
}
maxdat <-
suppressWarnings(tapply(dat$valeur, as.character(dat[, timesplit]), max, na.rm =
TRUE))
mindat <-
suppressWarnings(tapply(dat$valeur, as.character(dat[, timesplit]), min, na.rm =
TRUE))
meandat <-
suppressWarnings(tapply(dat$valeur, as.character(dat[, timesplit]), mean, na.rm =
TRUE))
datsummary <-
data.frame("maxtab" = maxdat,
"mintab" = mindat,
"moyenne" = 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$annee, 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 mois (month) other possible values are semaine (week), quinzaine (2 weeks),
#' English values within parenthesis are also accepted.
#' @param silent Stops displaying the messages.
#' \itemize{
#' \item{plot.type="line": one line per daily report_mig}
#' \item{plot.type="standard": the current year is displayed against a ribbon of historical values"}
#' \item{plot.type="density": creates density plot to compare seasonality, data computed by 15 days period}
#' \item{plot.type="step" : creates step plots to compare seasonality, the year chosen in the interface 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}
#' }
#' @return Nothing, called for its side effect of plotting
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_mig_interannual
#' @export
setMethod(
"plot",
signature(x = "report_mig_interannual", y = "missing"),
definition = function(x,
plot.type = "standard",
timesplit = "mois",
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,
"day" = "jour",
"week" = "semaine",
"month" = "mois",
"2 weeks" = "quinzaine",
timesplit
)
# plot.type="line";require(ggplot2)
if (nrow(report_mig_interannual@data) > 0) {
if (plot.type == "line") {
dat <- report_mig_interannual@data
dat <- dat[dat$bjo_labelquantite == "Effectif_total", ]
dat <- stacomirtools::chnames(
dat,
c(
"bjo_annee",
"bjo_jour",
"bjo_labelquantite",
"bjo_valeur"
),
c("annee", "jour", "labelquantite", "valeur")
)
# we need to choose a date, every year brought back to 2000
dat$jour <- as.POSIXct(strptime(strftime(dat$jour,
'2000-%m-%d %H:%M:%S'),
format = '%Y-%m-%d %H:%M:%S'), tz = "GMT")
dat$annee <- as.factor(dat$annee)
dat <- stacomirtools::killfactor(dat)
titre = paste(
gettext("Migration "),
paste(min(dat$annee), max(dat$annee), 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 = jour, y = valeur))
g <-
g + geom_line(aes(color = annee)) + labs(title = paste(titre, "\n", soustitre)) +
scale_x_datetime(name = "date", date_breaks = "1 month",
date_labels = "%b") +
theme_bw()
print(g)
assign("g", g, envir = envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
#----------------------------------------------
} else if (plot.type == "standard") {
dat = report_mig_interannual@data
if (silent == FALSE) {
the_choice <-
as.numeric(
select.list(
choices = as.character(unique(dat$bjo_annee)[order(unique(dat$bjo_annee))]),
preselect = as.character(max(dat$bjo_annee)),
"choice annee",
multiple = FALSE
)
)
} else {
the_choice <- max(dat$bjo_annee)
}
# dataset for current year
dat0 <-
fun_report_mig_interannual(dat, annee = NULL, timesplit = NULL)
dat <-
fun_report_mig_interannual(dat, annee = the_choice, timesplit = NULL)
dat <-
dat[dat$moyenne != 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$jour)), as.character(dat$jour)), ]
newdat <-
newdat[order(newdat$jour), ] # 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$annee))), "-", max(as.numeric(as.character(dat$annee))), sep =
"")
if (length(the_choice) > 0) {
vplayout <-
function(x, y) {
grid::viewport(layout.pos.row = x,
layout.pos.col = y)
}
grid::grid.newpage()
grid::pushViewport(grid::viewport(layout = grid::grid.layout(length(the_choice), 1, just =
"center")))
amplitudechoice <- paste(the_choice, '/', amplitude)
tmp <- dat0[as.numeric(as.character(dat0$annee)) == the_choice, ]
tmp$annee <- as.character(tmp$annee)
g <- ggplot(newdat, aes(x = jour))
g <-
g + geom_ribbon(
aes(
ymin = mintab,
ymax = maxtab,
fill = "amplitude"
),
color = "grey20",
alpha = 0.5
)
g <-
g + geom_bar(
aes(y = valeur, fill = I("orange")),
position = "dodge",
stat = "identity",
color = "grey20",
alpha = 0.8,
data = tmp
)
g <-
g + scale_fill_manual(
name = eval(amplitudechoice),
values = c("#35789C", "orange"),
labels = c(
gettext("Historical amplitude", domain = "R-StacomiR"),
the_choice
)
)
#g <- g+geom_point(aes(y=valeur,col=annee),data=tmp,pch=16,size=1)
# moyenne interannuelle
g <- g + geom_line(aes(y = moyenne, col = I("#002743")), data = newdat)
g <-
g + geom_point(aes(y = moyenne, col = I("#002743")),
size = 1.2,
data = newdat)
g <-
g + scale_colour_manual(
name = eval(amplitudechoice),
values = c("#002743"),
labels = c(stringr::str_c(
gettext("Interannual mean\n", domain = "R-stacomiR"),
amplitude
))
) +
guides(fill = guide_legend(reverse = TRUE))
g <-
g + labs(
title = paste(
paste(report_mig_interannual@dc@dc_selected,collapse="+"),
report_mig_interannual@taxa@data[
report_mig_interannual@taxa@data$tax_code %in%
report_mig_interannual@taxa@taxa_selected,
"tax_nom_latin"],
",",
report_mig_interannual@stage@data[
report_mig_interannual@stage@data$std_code %in%
report_mig_interannual@stage@stage_selected,
"std_libelle"],
",",
paste(newdat$annee),
"/",
amplitude
)
)
g <-
g + scale_x_datetime(
name = "date",
date_breaks = "months",
date_minor_breaks = "weeks",
date_labels = "%d-%m"
)
g <- g + theme_bw() + theme(legend.key = element_blank())
print(g, vp = vplayout(1, 1))
assign(paste("g", 1, sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettextf(
"Writing the graphical object into envir_stacomi environment : write g=get(\"gi\",envir_stacomi) with i=%s",
paste(1:length(the_choice), collapse = ",")
)
)
} # end if plot==standard
#----------------------------------------------
} else if (plot.type == "step") {
dat <- report_mig_interannual@data
dat <- fun_report_mig_interannual(dat)
# runs the default with daily migration
#dat=dat[order(dat$annee,dat$jour),]
dat$valeur[is.na(dat$valeur)] <-0
# otherwise if only one line it may crash
if (silent == FALSE) {
the_choice <- select.list(
choices = as.character(unique(dat$annee)),
preselect = as.character(max(dat$annee)),
multiple = FALSE,
title = gettext("Choose year", domain = "R-StacomirR")
)
} else {
the_choice <- max(as.numeric(as.character(dat$annee)))
}
amplitude <- paste(min(as.numeric(as.character(dat$annee))),
"-", max(as.numeric(as.character(dat$annee))), sep = "")
#################
# calculation of cumsums
###################
for (an in unique(dat$annee)) {
# an=as.character(unique(dat$annee)) ;an<-an[1]
dat[dat$annee == an, "cumsum"] <-
cumsum(dat[dat$annee == an, "valeur"])
dat[dat$annee == an, "total_annuel"] <-
max(dat[dat$annee == an, "cumsum"])
}
dat$cumsum <- dat$cumsum / dat$total_annuel
dat$jour <- as.Date(dat$jour)
dat$annee <- as.factor(dat$annee)
#################
# plot
###################
g <- ggplot(dat, aes(x = jour, y = cumsum))
tmp <-
dat[as.numeric(as.character(dat$annee)) == as.numeric(the_choice), ]
g <- g + geom_step(aes(col = annee, size = total_annuel))
g <- g + geom_step(data = tmp,
col = "black",
lty = 2)
g <-
g + labs(
title = gettextf(
"%s, %s, %s cum %s",
paste(report_mig_interannual@dc@dc_selected, collapse="+"),
report_mig_interannual@taxa@data[
report_mig_interannual@taxa@data$tax_code %in%
report_mig_interannual@taxa@taxa_selected,
"tax_nom_latin"],
report_mig_interannual@stage@data[
report_mig_interannual@stage@data$std_code %in%
report_mig_interannual@stage@stage_selected,
"std_libelle"],
amplitude
)
)
g <-
g + scale_y_continuous(name = gettext("Annual migration percentage", domain =
"R-stacomiR"))
g <-
g + scale_x_date(
name = gettext("date", domain = "R-stacomiR"),
date_breaks = "months",
date_minor_breaks = "weeks",
date_labels = "%b",
limits = range(dat[dat$valeur > 0 &
dat$cumsum != 1, "jour"])
)# date
g <-
g + scale_colour_hue(
name = gettext("year", domain = "R-stacomiR"),
l = 70,
c = 150
)# annee
print(g)
assign("g", g, envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
#----------------------------------------------
} else if (plot.type == "barchart") {
dat = report_mig_interannual@data
if (silent == FALSE) {
the_choice = select.list(
choices = as.character(unique(dat$bjo_annee)),
preselect = as.character(max(dat$bjo_annee)),
multiple = FALSE,
title = gettext("Choose year", domain = "R-StacomiR")
)
} else {
the_choice = max(as.numeric(as.character(dat$bjo_annee)))
}
dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit)
dat <-
fun_report_mig_interannual(dat, annee = the_choice, timesplit = timesplit)
prepare_dat <- function(dat) {
dat <- dat[order(dat$annee, dat[, timesplit]), ]
dat$annee <- as.factor(dat$annee)
dat$keeptimesplit <- dat[, timesplit]
if (timesplit == "mois") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m")
} else if (timesplit == "quinzaine") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d")
} else {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%W")
}
dat[, timesplit] <- as.factor(dat[, timesplit])
# we only keep one per week
newdat <- dat[match(unique(dat[, timesplit]), dat[, timesplit]), ]
newdat <-
newdat[order(newdat[, "keeptimesplit"]), ] # pour avoir les range sur l'ensemble des valeurs dispo et pas seult l'annee en cours
# here change 12/2012 the geom_crossbar now needs a factor, label change according to timesplit
newdat[, timesplit] <- as.factor(newdat[, timesplit])
levels(newdat[, timesplit]) <-
newdat[, timesplit] # to have the factor in the right order from january to dec
return(newdat)
}
amplitude <- paste(min(as.numeric(as.character(dat$annee))),
"-",
max(as.numeric(as.character(dat$annee))),
sep = "")
newdat <- prepare_dat(dat)
newdat0 <- prepare_dat(dat0)
if (length(the_choice) > 0) {
# le layout pour l'affichage des graphiques
vplayout <-
function(x, y) {
grid::viewport(layout.pos.row = x,
layout.pos.col = y)
}
grid::grid.newpage()
grid::pushViewport(grid::viewport(layout =
grid::grid.layout(length(the_choice), 1, just = "center")))
selection <-
as.numeric(as.character(dat0$annee)) == as.numeric(the_choice)
tmp <- dat0[selection, ]
tmp[tmp$valeur >= tmp$moyenne, "comp"] <- ">=moy"
tmp[tmp$valeur < tmp$moyenne, "comp"] <- "<moy"
suppressWarnings({
tmp[tmp$valeur == tmp$maxtab, "comp"] <- "max"
tmp[tmp$valeur == tmp$mintab, "comp"] <- "min"
})
tmp[tmp$moyenne == 0, "comp"] <- "0"
tmp$annee <- as.factor(as.numeric(as.character(tmp$annee)))
if (timesplit == "mois") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m")
} else if (timesplit == "quinzaine") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d")
} else {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W")
}
tmp[, timesplit] <- as.factor(tmp[, timesplit])
tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?"
newdat$comp <- NA
g <- ggplot(tmp, aes_string(x = timesplit, y = "valeur"))
g <- g + geom_crossbar(
data = newdat,
aes_string(
x = timesplit,
y = "moyenne",
ymin = "mintab",
ymax = "maxtab"
),
fill = "grey60",
alpha = 0.5,
size = 0.5,
fatten = 3,
col = "grey60"
)
g <-
g + geom_bar(
stat = "identity",
aes_string(y = "valeur", col = "comp"),
fill = NA,
width = 0.6
)
g <-
g + geom_bar(
stat = "identity",
aes_string(y = "valeur", fill = "comp"),
alpha = 0.5,
width = 0.6
)
#g <- g+scale_x_date(name=paste("mois"),breaks="month",minor_breaks=getvalue(new("ref_period"),label=date_format("%b"),timesplit))
#lim=as.POSIXct(c(Hmisc::truncPOSIXt((min(tmp[tmp$com!="0",timesplit])),"month")-delai,
# Hmisc::ceil((max(tmp[tmp$com!="0",timesplit])),"month")+delai))
# pb the limit truncs the value
g <- g + ylab("effectif")
cols <- c(
"max" = "#000080",
"min" = "#BF0000",
">=moy" = "darkgreen",
"<moy" = "darkorange",
"hist_mean" = "black",
"hist_range" = "grey",
"?" = "darkviolet"
)
fills <- c(
"max" = "blue",
"min" = "red",
">=moy" = "green",
"<moy" = "orange",
"hist_mean" = "black",
"hist_range" = "grey",
"?" = "violet"
)
g <- g + scale_colour_manual(
name = the_choice,
values = cols,
limits = c(
"min",
"max",
"<moy",
">=moy",
"hist_mean",
"hist_range",
"?"
)
)
g <- g + scale_fill_manual(
name = the_choice,
values = fills,
limits = c(
"min",
"max",
"<moy",
">=moy",
"hist_mean",
"hist_range",
"?"
)
)
g <-
g + labs(
title = paste( report_mig_interannual@taxa@data[
report_mig_interannual@taxa@data$tax_code %in%
report_mig_interannual@taxa@taxa_selected,
"tax_nom_latin"],
",",
report_mig_interannual@stage@data[
report_mig_interannual@stage@data$std_code %in%
report_mig_interannual@stage@stage_selected,
"std_libelle"],
", bilan par",
timesplit,
unique(as.character(tmp$annee)),
"/",
amplitude
)
)
g <- g + theme_minimal()
print(g, vp = vplayout(1, 1))
assign(paste("g", 1, sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettextf(
"\"Writing the graphical object into envir_stacomi environment : write g=get(\"gi\",envir_stacomi) with i=%s",
paste(1:length(the_choice), collapse = ",")
)
)
} # end if
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
} else if (plot.type == "pointrange") {
# below before several plots could be made, it's no longer the case
# as I remove the chosen year from the observation (reference) set
dat = report_mig_interannual@data
if (silent == FALSE) {
the_choice <-
select.list(
choices = as.character(unique(dat$bjo_annee)),
preselect = as.character(max(dat$bjo_annee)),
"choice annee",
multiple = FALSE
)
} else {
the_choice <- max(dat$bjo_annee)
}
dat0 <- fun_report_mig_interannual(dat, timesplit = timesplit)
dat <-
fun_report_mig_interannual(dat, annee = the_choice, timesplit = timesplit)
dat$annee <- as.factor(dat$annee)
dat <- dat[order(dat$annee, dat[, timesplit]), ]
dat$keeptimesplit <- dat[, timesplit]
if (timesplit == "mois") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m")
} else if (timesplit == "quinzaine") {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%m/%d")
} else {
dat[, timesplit] <- strftime(dat[, timesplit], format = "%W")
}
dat[, timesplit] <- as.factor(dat[, timesplit])
# dat=dat[dat$moyenne!=0,] # pour des raisons graphiques on ne garde pas les effectifs nuls generes par fun_report_mig_interannual
newdat <- dat[match(unique(dat[, timesplit]), dat[, timesplit]), ]
newdat <-
newdat[order(newdat[, "keeptimesplit"]), ] # il peut y avoir des annees pour le calcul de range qui s'ajoutent
# et viennent d'autres annees, il faut donc reordonner.
amplitude <-
paste(min(as.numeric(as.character(dat$annee))), "-", max(as.numeric(as.character(dat$annee))), sep =
"")
if (length(the_choice) > 0) {
# le layout pour l'affichage des graphiques
vplayout <-
function(x, y) {
grid::viewport(layout.pos.row = x,
layout.pos.col = y)
}
grid::grid.newpage()
grid::pushViewport(grid::viewport(layout = grid::grid.layout(length(the_choice), 1, just =
"center")))
selection <-
as.numeric(as.character(dat0$annee)) == as.numeric(the_choice)
tmp <- dat0[selection, ]
tmp[tmp$valeur >= tmp$moyenne, "comp"] <- ">=moy"
tmp[tmp$valeur < tmp$moyenne, "comp"] <- "<moy"
suppressWarnings({
tmp[tmp$valeur == tmp$maxtab, "comp"] <- "max"
tmp[tmp$valeur == tmp$mintab, "comp"] <- "min"
})
tmp[tmp$moyenne == 0, "comp"] <- "0"
tmp$annee = as.factor(as.numeric(as.character(tmp$annee)))
if (timesplit == "mois") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m")
} else if (timesplit == "quinzaine") {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%m/%d")
} else {
tmp[, timesplit] <- strftime(tmp[, timesplit], format = "%W")
}
tmp[, timesplit] <- as.factor(tmp[, timesplit])
tmp[!tmp[, timesplit] %in% newdat[, timesplit], "comp"] <- "?"
newdat$comp <- NA
g <- ggplot(tmp, aes_string(x = timesplit, y = "valeur"))
g <-
g + geom_dotplot(
aes_string(x = timesplit, y = "valeur"),
data = dat,
stackdir = "center",
binaxis = "y",
position = "dodge",
dotsize = 0.5,
fill = "wheat"
) #position = "dodge",dotsize = 0.4,alpha=0.5,binwidth = 1.5
g <-
g + geom_pointrange(
data = newdat,
aes_string(
x = timesplit,
y = "moyenne",
ymin = "mintab",
ymax = "maxtab"
),
alpha = 1,
size = 0.8
)
g <-
g + geom_bar(stat = "identity",
aes_string(y = "valeur", fill = "comp"),
alpha = 0.6)
g <- g + scale_y_continuous(name = "effectif")
cols <-
c(
"max" = "blue",
"min" = "red",
">=moy" = "darkgreen",
"<moy" = "darkorange",
"0" = "grey10",
"?" = "darkviolet"
)
g <- g + scale_fill_manual(name = the_choice, values = cols)
g <-
g + labs(
title = paste(
report_mig_interannual@taxa@data[
report_mig_interannual@taxa@data$tax_code %in%
report_mig_interannual@taxa@taxa_selected,
"tax_nom_latin"],
",",
report_mig_interannual@stage@data[
report_mig_interannual@stage@data$std_code %in%
report_mig_interannual@stage@stage_selected,
"std_libelle"],
", report par",
timesplit,
unique(as.character(tmp$annee)),
"/",
amplitude
)
)
g <- g + theme_minimal()
print(g, vp = vplayout(1, 1))
assign(paste("g", 1, sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettextf(
"\"Writing the graphical object into envir_stacomi environment : write g=get(\"gi\",envir_stacomi) with i=%s",
paste(1:length(the_choice), collapse = ",")
)
)
} # end if
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
} else if (plot.type == "density") {
if (nrow(report_mig_interannual@data) > 0)
{
timesplit = "quinzaine"
dat <- report_mig_interannual@data
dat <- fun_report_mig_interannual(dat, annee = NULL, timesplit)
dat$annee <- as.factor(dat$annee)
sum_per_year <- tapply(dat$valeur, dat$annee, sum)
sum_per_year <-
data.frame(annee = names(sum_per_year),
sum_per_year = sum_per_year)
dat <- merge(dat, sum_per_year, by = "annee")
dat$std_valeur <- dat$valeur / dat$sum_per_year
all_15 <- unique(dat[, timesplit])
# below I'm adding 0 instead of nothing for 15 days without value
for (i in 1:length(unique(dat$annee))) {
#i=5
annee <- unique(dat$annee)[i]
this_year_15 <- unique(dat[dat$annee == annee, timesplit])
missing <- all_15[!all_15 %in% this_year_15]
if (length(missing >= 1)) {
missingdat <- data.frame(
"annee" = annee,
"quinzaine" = missing,
"valeur" = 0,
"maxtab" = 0,
"mintab" = 0,
"moyenne" = 0,
"sum_per_year" = 0,
"std_valeur" = 0
)
dat <- rbind(dat, missingdat)
}
}
dat = dat[order(dat$annee, dat[, timesplit]), ]
g <- ggplot(dat, aes_string(x = timesplit, y = "std_valeur"))
g <-
g + geom_area(aes_string(y = "std_valeur", fill = "annee"), position =
"stack")
g <-
g + scale_x_datetime(
name = paste("mois"),
date_breaks = "month",
date_minor_breaks = getvalue(new("ref_period"), timesplit),
date_labels = "%b",
limits = as.POSIXct(c(
Hmisc::truncPOSIXt((min(dat[dat$valeur != 0, timesplit])), "month"),
Hmisc::ceil((max(dat[dat$valeur != "0", timesplit])), "month")
))
)
g <-
g + scale_y_continuous(name = "Somme des pourcentages annuels de migration par quinzaine")
cols <- grDevices::rainbow(length(levels(dat$annee)))
g <- g + scale_fill_manual(name = "annee", 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"],
", saisonnalite de la migration"
)
)
g <- g + theme_minimal()
print(g)
assign(paste("g", sep = ""), g, envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
} else {
if (!silent)
funout(
gettext(
"Warning : you have to complete a migration summary for at least one of the selected year before launching a inter-annual summary",
domain = "R-stacomiR"
)
)
}
#####################################################################
} else if (plot.type == "seasonal") {
if (!silent)
funout("Seasonal graph to show the phenology of migration")
#report_mig_interannual<-r_mig_interannual_vichy;silent=FALSE;timesplit="mois";require(ggplot2)
report_mig_interannual <-
calcule(report_mig_interannual, timesplit = timesplit)
#if (!silent& nrow(report_mig_interannual@calcdata)==0) stop("You should run calculation before plotting seasonal data")
dat3 <- report_mig_interannual@calcdata
datadic <- report_mig_interannual@data
datadic <-
fun_date_extraction(
datadic,
nom_coldt = "bjo_jour",
jour_an = TRUE,
quinzaine = TRUE
)
datadic <- chnames(datadic, "jour_365", "jour")
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_,
"jour" = {
as.Date(paste(year, "-", dat[, col[i]], sep = ""), "%Y-%j")
},
"semaine" = {
as.Date(paste(year, "-", dat[, col[i]], "-", 6, sep = ""), "%Y-%U-%w")
},
"mois" = {
as.Date(paste(year, "-", dat[, col[i]], "-", 1, sep = ""), "%Y-%m-%d")
},
stop(
stringr::str_c(
"Internal error, timesplit ",
timesplit_,
" not working for seasonal plot"
)
)
)
}
return(dat)
}
datadic <- fn_getbacktodate(dat = datadic,
col = timesplit,
timesplit_ = timesplit)
dat3 <- fn_getbacktodate(
dat = dat3,
col = c("Q0", "Q5", "Q50", "Q95", "Q100", "d90"),
timesplit_ = timesplit
)
datadic1 <-
dplyr::select(datadic,
{{timesplit}},
bjo_annee,
bjo_valeur,
bjo_labelquantite)
datadic1 <-
dplyr::group_by(datadic1, bjo_annee, dplyr::across(dplyr::all_of(timesplit)), bjo_labelquantite)
datadic1 <- dplyr::summarize(datadic1, bjo_valeur = sum(bjo_valeur))
datadic1 <-
dplyr::ungroup(datadic1) %>% dplyr::filter(bjo_labelquantite == "Effectif_total")
g <- ggplot(data = datadic1) +
geom_rect(
aes(
xmin = Q0,
xmax = Q100,
ymin = year - 0.5,
ymax = year + 0.5
),
fill = "grey90",
data = dat3
) +
geom_tile(
aes_string(x = timesplit, y = "bjo_annee", fill = "bjo_valeur"),
color = ifelse(timesplit == "jour", "transparent", "grey80")
) +
scale_fill_distiller(palette = "Spectral", name = "Effectif") +
geom_path(
aes(x = Q50, y = year),
col = "black",
lty = 2,
data = dat3
) +
geom_point(
aes(x = Q50, y = year),
col = "black",
size = 2,
data = dat3
) +
geom_errorbarh(
aes(
y = year,
xmin = Q5,
xmax = Q95
),
height = 0,
data = dat3,
col = "black"
) +
ylab(Hmisc::capitalize(gettext("year", domain = "R-stacomiR"))) +
xlab(Hmisc::capitalize({{timesplit}})) +
scale_x_date(
name = timesplit,
date_breaks = "month",
date_minor_breaks = getvalue(new("ref_period"), {{timesplit}}),
date_labels = "%b"
) +
theme_bw()
print(g)
assign("g", g, envir = envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the graphical object into envir_stacomi environment : write g=get('g',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
}
else {
# end if
stop ("plot.type argument invalid")
}
} else {
if (!silent)
funout(
gettext(
"Attention : you have to complete a migration summary for at least one of the selected year before launching a inter-annual summary",
domain = "R-stacomiR"
)
)
}
return(invisible(NULL))
}
)
#' 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 with the selected year excluded 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
dat = object@data
dat <- dat[dat$bjo_labelquantite == "Effectif_total", ]
dat <-
stacomirtools::chnames(
dat,
c(
"bjo_dis_identifiant",
"bjo_tax_code",
"bjo_std_code",
"bjo_annee",
"bjo_jour",
"bjo_labelquantite",
"bjo_valeur",
"bjo_horodateexport"
),
c(
"DC",
"Taxon",
"Stade",
"Annee",
"Jour",
"Label_quantite",
"Nombre",
"Date d'export du report"
)
)
dat$Annee <- as.factor(dat$Annee)
dat <- dat[, -1]
tmp <- dat$Jour
DC <- object@dc@dc_selected
dat <- chnames(dat, "Jour", "debut_pas")
# debut_pas must be column name in tableau
listDC <- list()
for (i in 1:length(DC)) {
# this table will write an html table of data
funtable(
tableau = dat[dat$bjo_dis_identifiant == DC, ],
time.sequence = tmp,
taxa = object@taxa@data[object@taxa@data$tax_code %in% object@taxa@taxa_selected, "tax_nom_latin"],
stage = object@stage@data[object@stage@data$std_code %in% object@stage@stage_selected, "std_libelle"],
DC[i],
resum = NULL,
silent = silent
)
# Summary statistics
dat = object@data
if (is.null(year_choice)){
if (silent == FALSE) {
the_choice <- as.numeric(
select.list(
choices = as.character(unique(dat$bjo_annee)[order(unique(dat$bjo_annee))]),
preselect = as.character(max(dat$bjo_annee)),
"choice annee",
multiple = FALSE
)
)
} else {
the_choice <- max((dat$bjo_annee))
}
} else {
if (!year_choice%in%unique(dat$bjo_annee)) {
stop(paste("The chosen year",year_choice,"should be in available years : ",
paste(as.character(unique(dat$bjo_annee)[order(unique(dat$bjo_annee))]), collapse=",")))
}
the_choice <- as.numeric(year_choice)
}
# we use the function that split data per time stamp to generate the full sequence of monthly data
dat <-
fun_report_mig_interannual(dat[dat$bjo_dis_identifiant == DC[i], ], timesplit =
"mois")
# then we extract only current year for summary
colnames(dat)[colnames(dat) == "maxtab"] <- "max"
colnames(dat)[colnames(dat) == "mintab"] <- "min"
dat <- dat[dat$annee == the_choice, ]
dat$mois <- strftime(dat$mois, "%b")
dat$moyenne <- round(dat$moyenne)
dat <- dat[, c("annee", "mois", "min", "moyenne", "max", "valeur")]
colnames(dat) <- c("annee", "mois", "min", "mean", "max", "valeur")
listDC[[as.character(DC[i])]] <- dat
}# end for
return(listDC)
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.