R/report_mig_interannual.R

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.