stacomiR coverage - 85.09%

Files
Source

#' Class "report_silver_eel"
#'
#' the report_silver_eel class is used to calculate various statistics about the silver eel run. It comprises calculation
#' of various maturation index such as Durif's stages and Pankhurst eye index. The objective is to provide standardized
#' output to the stations monitoring the silver eel run.
#' @include create_generic.R
#' @include ref_dc.R
#' @include ref_taxa.R
#' @include ref_stage.R
#' @include ref_horodate.R
#' @include ref_par.R
#' @note This class is displayed by interface_report_silver_eel
#' @slot data A data frame with data generated from the database
#' @slot calcdata A list of dc with processed data. Each dc contains a data frame with
#' \itemize{
#' \item (1) qualitative data on body contrast (CONT), presence of punctuation on the lateral line (LINP)
#' \item (2) quantitative data "BL" Body length,"W" weight,"Dv" vertical eye diameter,"Dh" horizontal eye diameter,"FL" pectoral fin length
#' \item (3) calculated durif stages, Pankhurst's index, Fulton's body weight coefficient K_ful
#' \item (4) other columns containing data pertaining to the sample and the control operation:  lot_identifiant,ope_identifiant,
#' ope_dic_identifiant,ope_date_debut,ope_date_fin,dev_code (destination code of fish),
#' dev_libelle (text for destination of fish)
#' }
#' @slot dc Object of class \link{ref_dc-class}: the control devices
#' @slot taxa An object of class \link{ref_taxa-class}: the species
#' @slot stage An object of class \link{ref_stage-class} : the stages of the fish
#' @slot par An object of class \link{ref_par-class}: the parameters used
#' @slot horodatedebut An object of class \link{ref_horodate-class}
#' @slot horodatefin An object of class \link{ref_horodate-class}
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("report_silver_eel", ...)}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_silver_eel-example.R
#' @aliases report_silver_eel
#' @export
setClass(
  Class = "report_silver_eel",
  representation = representation(
    data = "data.frame",
    calcdata = "list",
    dc = "ref_dc",
    taxa = "ref_taxa",
    stage = "ref_stage",
    par = "ref_par",
    horodatedebut = "ref_horodate",
    horodatefin = "ref_horodate"
  ),
  prototype = prototype(
    data = data.frame(),
    calcdata = list(),
    dc = new("ref_dc"),
    taxa = new("ref_taxa"),
    stage = new("ref_stage"),
    par = new("ref_par"),
    horodatedebut = new("ref_horodate"),
    horodatefin = new("ref_horodate")
  )
)
setValidity("report_silver_eel", function(object)
{
  rep1 = object@taxa@taxa_selected[1] == '2038'
  label1 <-
    'report_silver_eel should only be for eel (tax_code=2038)'
  rep2 = all(object@stage@stage_selected %in% c('AGG', 'AGJ'))
  label2 <-
    'Only stages silver (AGG) and yellow (AGJ) should be used in report_silver_eel'
  return(ifelse(rep1 &
                  rep2 , TRUE , c(label1, label2)[!c(rep1, rep2)]))
})
#' connect method for report_silver_eel
#'
#' @param object An object of class \link{report_silver_eel-class}
#' @param silent Boolean if TRUE messages are not displayed
#' @return An object of class \link{report_silver_eel-class} with slot data \code{@data} filled
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases connect.report_silver_eel
setMethod(
  "connect",
  signature = signature("report_silver_eel"),
  definition = function(object, silent = FALSE) {
    requete <- new("RequeteDBwheredate")
    requete@select = paste("SELECT * FROM ",
                           get_schema(),
                           "vue_lot_ope_car",
                           sep = "")
    requete@colonnedebut = "ope_date_debut"
    requete@colonnefin = "ope_date_fin"
    requete@datedebut <- object@horodatedebut@horodate
    requete@datefin <- object@horodatefin@horodate
    requete@order_by = "ORDER BY ope_date_debut"
    requete@and = paste(
      " AND ope_dic_identifiant in ",
      vector_to_listsql(object@dc@dc_selected),
      " AND lot_tax_code in ",
      vector_to_listsql(object@taxa@taxa_selected),
      " AND lot_std_code in ",
      vector_to_listsql(object@stage@stage_selected),
      " AND car_par_code in ",
      vector_to_listsql(object@par@par_selected),
      sep = ""
    )
    requete <- stacomirtools::query(requete)
    object@data <- requete@query
    if (!silent)
      funout(gettext("Data loaded", domain = "R-stacomiR"))
    return(object)
  }
)


#' charge method for report_silver_eel class
#'
#' this method verifies that boxes have been clicked in the user interface and gets the objects pasted in
#' envir_stacomi. It is not necessary to run this method when loading from the command line using the
#' choice_c method
#' @param object An object of class \link{report_silver_eel-class}
#' @param h a handler
#' @return An object of class \link{report_silver_eel-class}  with slots filled from values assigned in \code{envir_stacomi} environment
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of the class
#' @aliases charge.report_silver_eel
#' @keywords internal
setMethod(
  "charge",
  signature = signature("report_silver_eel"),
  definition = function(object, h) {
    if (exists("ref_dc", envir_stacomi)) {
      object@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)) {
      object@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)) {
      object@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("ref_par", envir_stacomi)) {
      object@par <- get("ref_par", envir_stacomi)
    } else {
      funout(
        gettext("You need to choose a parameter, clic on validate\n", domain = "R-stacomiR"),
        arret = TRUE
      )
    }
    if (exists("report_arg_date_debut", envir_stacomi)) {
      object@horodatedebut@horodate <-
        get("report_arg_date_debut", envir_stacomi)
    } else {
      funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
             arret = TRUE)
    }
    if (exists("report_arg_date_fin", envir_stacomi)) {
      object@horodatefin@horodate <-
        get("report_arg_date_fin", envir_stacomi)
    } else {
      funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
             arret = TRUE)
    }
    
    return(object)
    validObject(object)
  }
)


#' command line interface for report_silver_eel class
#' 
#' #' The choice_c method fills in the data slot for classes \link{ref_dc-class}, \link{ref_taxa-class}, \link{ref_stage-class}, \link{ref_par-class} and two slots of \link{ref_horodate-class} and then
#' uses the choice_c methods of these object to select the data.
#' @param object An object of class \link{report_silver_eel-class}
#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
#' @param taxa '2038=Anguilla anguilla',
#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
#' @param stage 'AGG'
#' @param par Parameters chosen for the report are body size (1786), vertical eye diameter (BBBB), horizontal eye diameter (CCCC),
#' body contrast (CONT), presence of punctuation on the lateral line (LINP), length of the pectoral fin (PECT)
#' @param horodatedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param horodatefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_mig-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_silver_eel
setMethod(
  "choice_c",
  signature = signature("report_silver_eel"),
  definition = function(object,
                        dc,
                        taxa = 2038,
                        stage = 'AGG',
                        par = c('1786', 'CCCC', 'BBBB', 'CONT', 'LINP', 'A111', 'PECT'),
                        horodatedebut,
                        horodatefin,
                        silent = FALSE) {
    # code for debug using example
    #r_silver<-b_carlothorodatedebut="2010-01-01";horodatefin="2015-12-31"
    r_silver <- object
    r_silver@dc = charge(r_silver@dc)
    # loads and verifies the dc
    # this will set dc_selected slot
    r_silver@dc <- choice_c(object = r_silver@dc, dc)
    # only taxa present in the report_mig are used
    r_silver@taxa <-
      charge_with_filter(object = r_silver@taxa, r_silver@dc@dc_selected)
    r_silver@taxa <- choice_c(r_silver@taxa, taxa)
    r_silver@stage <-
      charge_with_filter(object = r_silver@stage,
                         r_silver@dc@dc_selected,
                         r_silver@taxa@taxa_selected)
    r_silver@stage <- choice_c(r_silver@stage, stage)
    r_silver@par <-
      charge_with_filter(
        object = r_silver@par,
        r_silver@dc@dc_selected,
        r_silver@taxa@taxa_selected,
        r_silver@stage@stage_selected
      )
    r_silver@par <- choice_c(r_silver@par, par, silent = silent)
    r_silver@horodatedebut <- choice_c(
      object = r_silver@horodatedebut,
      nomassign = "reportArg_date_debut",
      funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
      horodate = horodatedebut,
      silent = silent
    )
    r_silver@horodatefin <- choice_c(
      r_silver@horodatefin,
      nomassign = "reportArg_date_fin",
      funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
      horodate = horodatefin,
      silent = silent
    )
    validObject(r_silver)
    return(r_silver)
  }
)

#' Calculate individual silver eel parameters.
#'
#' This calcule method for report_silver_eel, will transform data from long (one line per size characteristic,
#' size, weight, eye diameter, pectoral fin measurement, lateral line and constrast) to wide format (one
#' line per silver eel). It will also calculate Durif silvering index and Pankhurst and Fulton's K.
#'
#' @param object An object of class \link{report_silver_eel-class}
#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
#' @return An object of class \link{report_silver_eel-class} with slot calcdata filled, as a list
#' for each counting device
#' @aliases calcule.report_silver_eel
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod(
  "calcule",
  signature = signature("report_silver_eel"),
  definition = function(object, silent) {
    r_silver <- object
    if (nrow(r_silver@data) == 0) {
      funout(
        gettext("No data of silver or yellow eel on the selected period", domain =
                  "R-stacomiR"),
        arret = TRUE
      )
    }
    arg = r_silver@data
    lesdc <- r_silver@dc@dc_selected
    parquant <- c("1786", "A111", "BBBB", "CCCC", "PECT")
    parqual <- c("CONT", "LINP")
    for (i in 1:length(lesdc)) {
      dc <- lesdc[i]
      other <-
        dplyr::select(
          arg,
          lot_identifiant,
          ope_dic_identifiant,
          ope_identifiant,
          ope_date_debut,
          ope_date_fin,
          dev_code,
          dev_libelle
        )
      other <- dplyr::filter(other, ope_dic_identifiant == dc)
      other <-
        dplyr::group_by(
          other,
          lot_identifiant,
          ope_identifiant,
          ope_dic_identifiant,
          ope_date_debut,
          ope_date_fin,
          dev_code,
          dev_libelle
        )
      other <- dplyr::summarize(other)
      other <- as.data.frame(other)
      other <-
        fun_date_extraction(other,
                            "ope_date_debut",
                            jour_an = TRUE,
                            jour_mois = FALSE)
      # extracting the dc from the array
      # all parms are there but some are null,i.e.val_libelle is null for quantitative parm and
      # car_valeur_quantitatif is null for for qualitative parms
      matqual <- reshape2::acast(
        arg[arg$ope_dic_identifiant == lesdc[i], ],
        lot_identifiant ~ car_par_code + car_val_identifiant,
        value.var = "val_libelle",
        drop = TRUE
      )
      matquant <- reshape2::acast(
        arg[arg$ope_dic_identifiant == lesdc[i], ],
        lot_identifiant ~ car_par_code + car_val_identifiant,
        value.var = "car_valeur_quantitatif",
        drop = TRUE
      )
      
      # this function will select the parameters one by one
      # test them for pattern against column name
      # and return the column. So a data frame of quantitative or qualitative parm are returned
      fn <- function(X, mat) {
        veccol <- grepl(X, dimnames(mat)[[2]])
        return(mat[, veccol])
      }
      matquant2 <- sapply(X = parquant, FUN = fn, mat = matquant)
      colnames(matquant2) <- c("BL", "W", "Dv", "Dh", "FL")
      
      matqual2 <- sapply(
        X = parqual,
        FUN = fn,
        mat = matqual,
        simplify = FALSE
      )
      # now matquant2 only contain the correct columns
      # matqual has two column for a single qualitative variable, which is wrong
      # we will merge them
      
      # however there is a bug if only one value is present
      # depending on the data structure there might a bug
      # when there is only one dimension (ie on instance of factor where there should be two)
      for (z in 1:length(matqual2)) {
        if (is.null(dim(matqual2[[z]])[2]))
          matqual2[[z]] <- cbind(matqual2[[z]], NA)
      }
      matqual3 <- matrix(NA, nrow = nrow(matqual2[[1]]), ncol = length(parqual))
      # below if the data in  the first column is NA we choose the second
      # which migh also be NA in which case the result becomes a NA
      
      for (j in 1:length(parqual)) {
        theparqual = parqual[j]
        matqual3[, j] <-
          apply(matqual2[[theparqual]], 1, function(X)
            ifelse(is.na(X[1]), X[2], X[1]))
      }
      dd <- as.data.frame(matqual3)
      rownames(dd) <- rownames(matquant2)
      colnames(dd) <- parqual
      dd$stage <- as.vector(fun_stage_durif(matquant2))
      dd <- cbind(dd, as.data.frame(matquant2))
      dd$MD <- rowMeans(dd[, c("Dv", "Dh")], na.rm = TRUE)
      dd$Pankhurst = 100 * (dd$MD / 2) ^ 2 * pi / dd$BL
      #K = 100 Wt /TL3 with Wt in g and TL in cm	(Cone 1989). (Acou, 2009)
      dd$K_ful = 100 * dd$W / (dd$BL / 10) ^ 3
      ddd <- cbind(other, dd)
      r_silver@calcdata[[as.character(dc)]] <- ddd
    }
    assign("r_silver", r_silver, envir_stacomi)
    return(r_silver)
  }
)


#' Plots of various type for report_silver_eel
#'
#' @param x An object of class \link{report_silver_eel-class}
#' @param plot.type Default "1"
#'  \itemize{
#' 		\item{plot.type="1"}{Lattice plot of Durif's stages according to Body Length and Eye Index (average of vertical and horizontal diameters).
#' If several DC are provided then a comparison of data per dc is provided}
#' 		\item{plot.type="2"}{Lattice plot giving a comparison of Durif's stage proportion over time, if several DC are provided an annual comparison
#' is proposed, if only one DC is provided then the migration is split into month.}
#' 		\item{plot.type="3"}{ Series of graphs showing  mean Fulton's coefficient, Pankhurst eye index,	along
#' with a size weight analysis and regression using robust regression (rlm more robust to the presence of outliers)}
#' 			\item{plot.type="4"}{ Lattice cloud plot of Pankurst~ Body Length ~ weight)}
#' }
#' @param silent Stops displaying the messages
#' @return A lattice xy.plot if \code{plot.type =1}, a lattice barchart if \code{plot.type=2}, nothing but plots a series of graphs in 
#' a single plot if \code{plot.type=3}, a lattice cloud object if \code{plot.type=4}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_silver_eel
#' @importFrom stats update
#' @export
setMethod(
  "plot",
  signature(x = "report_silver_eel", y = "missing"),
  definition = function(x,
                        plot.type = c("1","2","3","4"),
                        silent = FALSE) {
    #r_silver<-r_sample_char;require(ggplot2);plot.type="1"
    #browser()
			oldpar <- par(no.readonly = TRUE) 
			on.exit(par(oldpar))  
    r_silver <- x
		plot.type <- as.character(plot.type)# to pass also characters
		plot.type <- match.arg(plot.type)
    if (exists("r_silver", envir_stacomi)) {
      r_silver <- get("r_silver", envir_stacomi)
    } else {
      if (!silent)
        funout(
          gettext("You need to launch computation first, clic on calc\n", domain =
                    "R-stacomiR"),
          arret = TRUE
        )
    }
    dat <- r_silver@calcdata
    # cols are using viridis::inferno(6,alpha=0.9)
    blue_for_males <- grDevices::adjustcolor("#008490", alpha.f = 0.8)
    
    datdc <- data.frame()
    
    
    for (i in 1:length(dat)) {
      datdc <- rbind(datdc, dat[[i]])
    }
    
    
    
    # trellis.par.get()
    datdc$stage <-
      factor(datdc$stage, levels = c("I", "FII", "FIII", "FIV", "FV", "MII"))
    datdc$ope_dic_identifiant <- as.factor(datdc$ope_dic_identifiant)
    datdc$ouv <- NA
    for (i in 1:length(r_silver@dc@dc_selected)) {
      datdc$ouv[datdc$ope_dic_identifiant == r_silver@dc@dc_selected[i]] <-
        r_silver@dc@data[r_silver@dc@data$dc == r_silver@dc@dc_selected[i], "ouv_libelle"]
    }
    
    
    
    
    #################################################
    # plot.type =1 Eye, length category durif stages
    #################################################
    
    if (plot.type == "1") {
      my.settings <- list(
        superpose.symbol = list(
          col = c(
            "Lime green",
            "#420A68E6",
            "#932667E6",
            "#DD513AE6",
            "#FCA50AE6",
            blue_for_males
          ),
          pch = c(3, 4, 8, 15, 16, 17),
          cex = c(1, 1, 1, 1, 1, 1),
          alpha = c(0.9, 0.9, 0.9, 0.9, 0.9, 0.9)
        ),
        superpose.line = list(
          col = c(
            "#FBA338",
            "#420A68E6",
            "#932667E6",
            "#DD513AE6",
            "#FCA50AE6",
            blue_for_males
          )
        ),
        strip.background = list(col = "#932667E6"),
        strip.border = list(col = "black")
      )
      lattice::trellis.par.set(my.settings)
      # show.settings()
      if (length(dat) > 1) {
        form <- as.formula(MD ~ BL | ouv)
      } else {
        form <- as.formula(MD ~ BL)
      }
      
      xy.plot <- lattice::xyplot(
        form,
        data = datdc,
        group = stage,
        type = c("p"),
        par.settings = my.settings,
        xlab = gettext("size (BL mm)", domain = "R-stacomiR"),
        ylab = gettext("Mean eye diameter (MD mm)", domain = "R-stacomiR"),
        par.strip.text = list(col = "white", font = 2),
        auto.key = list(
          title = gettext("Silvering stages (Durif et al. 2009)", domain = "R-stacomiR"),
          cex.title = 1.2,
          space = "top",
          columns = 6,
          between.columns = 1
        )
      )
      # draw lines in lattice
      xy.plot <- update(
        xy.plot,
        panel = function(...) {
          lattice::panel.abline(
            h = c(6.5, 8),
            v = c(300, 450, 500) ,
            lty = "dotted",
            col = "light grey"
          )
          lattice::panel.xyplot(...)
        }
      )
      
      return(xy.plot)
      
    }
    ######################################
    # Migration according to stage, month and year
    # !! throws a warning calling par(new=TRUE) with no plot, no dev.new()
    ######################################
    if (plot.type == "2") {
      datdc1 <- dplyr::select(datdc, ouv, annee, mois, stage)
      datdc1 <- dplyr::group_by(datdc1, ouv, annee, mois, stage)
      datdc1 <- dplyr::summarize(datdc1, N = dplyr::n())
      datdc1 <- as.data.frame(datdc1)
      # show.settings()
      my.settings <- list(
        superpose.polygon = list(
          col = c(
            "Lime green",
            "#420A68E6",
            "#932667E6",
            "#DD513AE6",
            "#FCA50AE6",
            blue_for_males
          ),
          alpha = c(0.9, 0.9, 0.9, 0.9, 0.9, 0.9)
        ),
        superpose.line = list(
          col = c(
            "#FBA338",
            "#420A68E6",
            "#932667E6",
            "#DD513AE6",
            "#FCA50AE6",
            blue_for_males
          )
        ),
        #colfn<-colorRampPalette(c("#1C4587", "#BBC7DB"),space = "Lab")
        #colfn(7)
        strip.background = list(
          col = c(
            "#1B4586",
            "#3E5894",
            "#596DA2",
            "#7282B0",
            "#8A98BE",
            "#A2AFCC",
            "#BAC6DA"
          )
        ),
        strip.border = list(col = "black")
      )
      lattice::trellis.par.set(my.settings)
      
      # show.settings()
      if (length(dat) > 1) {
        form <- as.formula(N ~ annee | ouv)
      } else {
        form <- as.formula(N ~ mois | annee)
      }
      
      bb <- lattice::barchart(
        form,
        data = datdc1,
        group = stage,
        xlab = gettext("Month", domain = "R-stacomiR"),
        ylab = gettext("Number", domain = "R-stacomiR"),
        par.strip.text = list(col = "white", font = 2),
        auto.key = list(
          title = gettext("Number by silvering stage", domain = "R-stacomiR"),
          cex.title = 1.2,
          space = "top",
          columns = 6,
          between.columns = 0.5
        )
      )
      return(bb)
      
    }
    ######################################
    # Series of graphs showing proportion of stage, mean Fulton's coefficient, Pankhurst eye index,
    # body weight, body size, sex ratio.
    ######################################
    if (plot.type == "3") {
      layout(
        matrix(c(1, 2, 3, 4, 4, 5, 6, 6, 7), 3, 3, byrow = TRUE),
        widths = c(3, 3, 1),
        heights = c(3, 1, 3)
      )
      # width 331 sets the last column relative width
      # same for rows
      par(mar = c(3, 4.1, 4.1, 2.1))# ressetting to default
      datdc <- chnames(datdc, "ope_dic_identifiant", "dc")
      lesdc <- unique(datdc$dc)
      datdc$sex <- "F"
      datdc$sex[datdc$BL < 450] <- "M"
      
      #############
      # Fulton
      #############
      moy <- tapply(datdc$K_ful, list(datdc$dc, datdc$sex), mean, na.rm = TRUE)
      sd <-
        tapply(datdc$K_ful, list(datdc$dc, datdc$sex), sd, na.rm = TRUE) # sample standard deviation
      n <- tapply(datdc$K_ful, list(datdc$dc, datdc$sex), length)
      SE = sd / sqrt(n)
      plotTop = max(moy + 3 * SE, na.rm = TRUE)
      
      
      bp <- barplot(
        moy,
        beside = TRUE,
        las = 1,
        ylim = c(0, plotTop),
        cex.names = 0.75,
        main = "Fulton coefficient (+-2SE)",
        ylab = "Fulton K",
        xlab = "",
        border = "black",
        axes = TRUE,
        #legend.text = TRUE,
        #args.legend = list(title = "DC",
        #		x = "topright",
        #		cex = .7)
      )
      graphics::segments(bp, moy - SE * 2, bp,
                         moy + SE * 2, lwd = 2)
      
      graphics::arrows(
        bp,
        moy - SE * 2,
        bp,
        moy + SE * 2,
        lwd = 2,
        angle = 90,
        code = 3,
        length = 0.05
      )
      
      
      #############
      # Pankhurst
      #############
      moy <-
        tapply(datdc$Pankhurst, list(datdc$dc, datdc$sex), mean, na.rm = TRUE)
      sd <-
        tapply(datdc$Pankhurst, list(datdc$dc, datdc$sex), sd, na.rm = TRUE) # sample standard deviation
      n <- tapply(datdc$Pankhurst, list(datdc$dc, datdc$sex), length)
      SE = sd / sqrt(n)
      plotTop = max(moy + 3 * SE, na.rm = TRUE)
      
      
      bp <- barplot(
        moy,
        beside = TRUE,
        las = 1,
        ylim = c(0, plotTop),
        cex.names = 0.75,
        main = "Pankhurst (+-2SE)",
        ylab = "Pankhurst eye index",
        xlab = "",
        border = "black",
        axes = TRUE,
        #legend.text = TRUE,
        #args.legend = list(title = "DC",
        #		x = "topright",
        #		cex = .7)
      )
      segments(bp, moy - SE * 2, bp,
               moy + SE * 2, lwd = 2)
      
      arrows(
        bp,
        moy - SE * 2,
        bp,
        moy + SE * 2,
        lwd = 2,
        angle = 90,
        code = 3,
        length = 0.05
      )
      
      #############
      # empty plot
      #############
      op <- par(mar = c(1, 1, 1, 1))
      plot(
        1,
        type = "n",
        axes = F,
        xlab = "",
        ylab = ""
      )
      legend("center",
             fill = grDevices::grey.colors(nrow(moy)),
             legend = unique(datdc$dc))
      # grey.colors is the default color generation for barplot
      #############
      # size hist
      #############
      par(mar = c(1, 4.1, 1, 1))
      for (i in 1:length(lesdc)) {
        indexdc <- datdc$dc == lesdc[i]
        histxn <-
          graphics::hist(datdc$BL[indexdc],
                         breaks = seq(250, 1100, by = 50),
                         plot = FALSE)$density
        if (i == 1)
          histx <- histxn
        else
          histx <- cbind(histx, histxn)
        
      }
      if (length(lesdc) > 1)
        colnames(histx) <- lesdc
      barplot(
        height = t(histx),
        space = 0,
        beside = FALSE,
        las = 1,
        horiz = FALSE,
        legend.text = FALSE,
        axes = FALSE
      )
      #############
      # empty plot
      #############
      op <- par(mar = c(1, 1, 1, 1))
      plot(
        1,
        type = "n",
        axes = F,
        xlab = "",
        ylab = ""
      )
      
      #############
      # size -weight
      #############
      par(mar = c(5.1, 4.1, 1, 1)) # blur bottom left up right
      plot(
        datdc$BL,
        datdc$W,
        type = "n",
        xlab = gettext("Size (mm)", domain = "R-stacomiR"),
        ylab = gettext("Weight(g)", domain = "R-stacomiR"),
        xlim = c(250, 1000),
        ylim = c(0, 2000)
      )
      abline(v = seq(250, 1000, by = 50),
             col = "lightgray",
             lty = 2)
      abline(h = seq(0, 2000, by = 100),
             col = "lightgray",
             lty = 2)
      # some alpha blending to better see the points :
      lescol <- ggplot2::alpha(grDevices::grey.colors(nrow(moy)), 0.8)
      for (i in 1:length(lesdc)) {
        indexdc <- datdc$dc == lesdc[i]
        points(
          datdc$BL[indexdc],
          datdc$W[indexdc],
          pch = 16,
          col = lescol[i],
          cex = 0.8
        )
        
      }
      ######################"
      # Size - weight model using robust regression
      ######################
      subdatdc <- datdc[, c("BL", "W")]
      subdatdc$BL3 <- (subdatdc$BL / 1000) ^ 3
      # plot(subdatdc$W~subdatdc$BL3)
      
      rlmmodb <- MASS::rlm(W ~ 0 + BL3, data = subdatdc)
      #summary(rlmmodb)
      newdata <-
        data.frame("BL" = seq(250, 1000, by = 50),
                   "BL3" = (seq(250, 1000, by = 50) / 1000) ^ 3)
      pred <-
        predict(
          rlmmodb,
          newdata = newdata,
          se.fit = TRUE,
          type = "response",
          interval = "prediction"
        )
      newdata$predlm <- pred$fit[, 1]
      newdata$predlowIC <- pred$fit[, 2]
      newdata$predhighIC <- pred$fit[, 3]
      
      points(newdata$BL, newdata$predlm, type = "l")
      points(
        newdata$BL,
        newdata$predlowIC,
        type = "l",
        lty = 2,
        col = "grey50"
      )
      points(
        newdata$BL,
        newdata$predhighIC,
        type = "l",
        lty = 2,
        col = "grey50"
      )
      
      text(400, 1500, stringr::str_c("W=", round(coefficients(rlmmodb), 1), " BL^3"))
      
      #############
      # weight hist rotate
      #############
      par(mar = c(5.1, 1, 1, 1))
      for (i in 1:length(lesdc)) {
        indexdc <- datdc$dc == lesdc[i]
        histyn <-
          hist(datdc$W[indexdc],
               plot = FALSE,
               breaks = seq(0, 2500, by = 100))$density
        if (i == 1)
          histy <- histyn
        else
          histy <- cbind(histy, histyn)
        
      }
      if (length(lesdc) > 1)
        colnames(histy) <- lesdc
      barplot(
        height = t(histy),
        space = 0,
        beside = FALSE,
        las = 1,
        horiz = TRUE,
        legend.text = FALSE,
        axes = FALSE
      )
      
    }
    if (plot.type == "4") {
      #creating a shingle with some overlaps
      my.settings <- list(
        superpose.polygon = list(
          col = c(
            "Lime green",
            "#420A68E6",
            "#932667E6",
            "#DD513AE6",
            "#FCA50AE6",
            blue_for_males
          ),
          alpha = c(0.9, 0.9, 0.9, 0.9, 0.9, 0.9)
        ),
        superpose.line = list(
          col = c(
            "#FBA338",
            "#420A68E6",
            "#932667E6",
            "#DD513AE6",
            "#FCA50AE6",
            blue_for_males
          )
        ),
        #colfn<-colorRampPalette(c("#1C4587", "#BBC7DB"),space = "Lab")
        #colfn(7)
        strip.background = list(
          col = c(
            "#1B4586",
            "#3E5894",
            "#596DA2",
            "#7282B0",
            "#8A98BE",
            "#A2AFCC",
            "#BAC6DA"
          )
        ),
        strip.border = list(col = "black")
      )
      lattice::trellis.par.set(my.settings)
      datdc <-
        datdc[complete.cases(datdc[, c("Pankhurst", "W", "BL", "ouv", "stage")]), ]
      ccc <-
        lattice::cloud(
          Pankhurst ~ W * BL | ouv,
          data = datdc,
          group = stage,
          screen = list(x = -90, y = 70),
          distance = .4,
          zoom = .6,
          strip = lattice::strip.custom(par.strip.text = list(col = "white"))
        )
      return(ccc)
    }
    
    
  }
)

#' summary for report_silver_eel
#' @param object An object of class \code{\link{report_silver_eel-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters
#' @return A list per DC with statistic for Durif stages, Pankhurst, MD Eye diameter, BL body length and weight W
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_silver_eel
#' @export
setMethod(
  "summary",
  signature = signature(object = "report_silver_eel"),
  definition = function(object, silent = FALSE, ...) {
    r_silver <- object
    if (exists("r_silver", envir_stacomi)) {
      r_silver <- get("r_silver", envir_stacomi)
    } else {
      if (!silent)
        funout(
          gettext("You need to launch computation first, clic on calc\n", domain =
                    "R-stacomiR"),
          arret = TRUE
        )
    }
    dat <- r_silver@calcdata
    # cols are using viridis::inferno(6,alpha=0.9)
    
    printstat <- function(vec, silent) {
      moy <- mean(vec, na.rm = TRUE)
      sd <- sd(vec, na.rm = TRUE) # sample standard deviation
      n <- length(vec[!is.na(vec)])
      SE = sd / sqrt(n)
      if (!silent)
        print(noquote(
          stringr::str_c(
            "mean=",
            round(moy, 2),
            ",SD=",
            round(sd, 2),
            ",N=",
            n,
            ",SE=",
            round(SE, 2)
          )
        ))
      return(list(
        "mean" = moy,
        "SD" = sd,
        "N" = n,
        "SE" = SE
      ))
    }
    result <- list()
    for (i in 1:length(dat)) {
      datdc <-	dat[[i]]
      ouvrage <-
        r_silver@dc@data[r_silver@dc@data$dc == r_silver@dc@dc_selected[i], "ouv_libelle"]
      dc <- as.character(unique(datdc$ope_dic_identifiant))
      result[[dc]] <- list()
      result[[dc]][["ouvrage"]] <- ouvrage
      if (!silent) {
        print(noquote(stringr::str_c("Statistics for dam : ", ouvrage)))
        print(noquote("========================"))
        print(noquote("Stages Durif"))
        print(table(datdc$stage))
      }
      result[[dc]][["Stages"]] <- table(datdc$stage)
      if (!silent) {
        print(noquote("-----------------------"))
        print(noquote("Pankhurst"))
        print(noquote("-----------------------"))
      }
      result[[dc]][["Pankhurst"]] <-
        printstat(datdc$Pankhurst, silent = silent)
      if (!silent) {
        print(noquote("-----------------------"))
        print(noquote('Eye diameter (mm)'))
        print(noquote("-----------------------"))
      }
      result[[dc]][["MD"]] <- printstat(datdc$MD, silent = silent)
      if (!silent) {
        print(noquote("-----------------------"))
        print(noquote('Length (mm)'))
        print(noquote("-----------------------"))
      }
      result[[dc]][["BL"]] <- printstat(datdc$BL, silent = silent)
      if (!silent) {
        print(noquote("-----------------------"))
        print(noquote('Weight (g)'))
        print(noquote("-----------------------"))
      }
      result[[dc]][["W"]] <- printstat(datdc$W, silent = silent)
    }
    return(result)
  }
)

#' Method to print the command line of the object
#' @param x An object of class report_silver_eel
#' @param ... Additional parameters passed to print
#' @return NULL, prints data in the console
#' @author cedric.briand
#' @aliases print.report_silver_eel
#' @export
setMethod(
  "print",
  signature = signature("report_silver_eel"),
  definition = function(x, ...) {
    sortie1 <- "r_silver=new('report_silver_eel')"
    sortie2 <- stringr::str_c(
      "r_silver=choice_c(r_silver,",
      "dc=c(",
      stringr::str_c(x@dc@dc_selected, collapse = ","),
      "),",
      "taxa=c(",
      stringr::str_c(shQuote(x@taxa@data$tax_nom_latin), collapse = ","),
      "),",
      "stage=c(",
      stringr::str_c(shQuote(x@stage@stage_selected), collapse = ","),
      "),",
      "par=c(",
      stringr::str_c(shQuote(x@par@par_selected), collapse = ","),
      "),",
      "horodatedebut=",
      shQuote(
        strftime(x@horodatedebut@horodate, format = "%d/%m/%Y %H-%M-%S")
      ),
      ",horodatefin=",
      shQuote(
        strftime(x@horodatefin@horodate, format = "%d/%m/%Y %H-%M-%S")
      ),
      ")"
    )
    # removing backslashes
    funout(sortie1)
    funout(stringr::str_c(sortie2, ...))
    return(invisible(NULL))
  }
)


#' funplotreport_silver_eel
#'
#' assigns an object g in envir_stacomi for eventual modification of the plot
#' @param action, action 1,2,3 or 4 corresponding to plot
#' @param ... Additional parameters
#' @return Nothing
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
funplotreport_silver_eel = function(action, ...) {
  r_silver <- get(x = "report_arg", envir = envir_stacomi)
  r_silver <- charge(r_silver)
  r_silver <- connect(r_silver)
  r_silver <- calcule(r_silver)
  #plot.type is determined by button in h$action
  the_plot <- plot(r_silver, plot.type = action)
  print(the_plot)
}



#' Function to calculate the stages from Durif
#'
#' @param data A dataset with columns BL, W, Dv, Dh, FL corresponding to body length (mm),
#' Weight (g), vertical eye diameter (mm), vertical eye diameter (mm), and pectoral fin length (mm)
#' @returns A data.frame with durif stages per individual
#' @author Laurent Beaulaton \email{laurent.beaulaton@onema.fr}
#' @export
fun_stage_durif = function(data) {
  # see section Good Practise in ? data
  data(coef_durif, envir = environment())
  stopifnot(colnames(data) == c("BL", "W", "Dv", "Dh", "FL"))
  data <-
    cbind(1, data[, c(1, 2, 5)], rowMeans(data[, c("Dv", "Dh")], na.rm = TRUE))
  colnames(data) <- c("Constant", "BL", "W", "FL", "MD")
  data <- data[, c(1, 2, 3, 5, 4)]
  indices <- data %*% coef_durif
  return(unlist(apply(indices, 1, function(X)
    ifelse(is.na(X[1]), NA, names(which.max(X))))))
}

#' Creates a list of available schemas in the db
#' 
#' @return A table with of data providers with org_code, the user of each schema, and  org_description the description of the schema
#' @export
fun_schema <- function(){
	req = new("RequeteDB")
	# this query will get characteristics from lot_pere when null
	req@sql = "SELECT * FROM ref.ts_organisme_org too WHERE NOT  org_code IN ('nat','invite') ORDER BY org_code"
	schema_table <- query(req)@query	
	return(schema_table)
}
	



#' Class "report_annual"
#'
#' This class displays annual migration counts, for several counting device, taxa or stages.
#' @include ref_dc.R
#' @include ref_taxa.R
#' @include ref_stage.R
#' @include ref_year.R
#' @slot dc Object of class \code{\link{ref_dc-class}}, the counting device, multiple values allowed
#' @slot data Object of class \code{"data.frame"} data for report lot
#' @slot taxa An object of class \code{\link{ref_taxa-class}}, multiple values allowed
#' @slot stage An object of class \code{\link{ref_stage-class}}, multiple values allowed
#' @slot start_year Object of class \code{\link{ref_year-class}}. ref_year allows to choose year of beginning
#' @slot end_year Object of class \code{\link{ref_year-class}}
#' ref_year allows to choose last year of the report
#' @aliases report_annual
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_annual-example.R
#' @export
setClass(
		Class = "report_annual",
		representation =
				representation(
						dc = "ref_dc",
						taxa = "ref_taxa",
						stage = "ref_stage",
						data = "data.frame",
						start_year = "ref_year",
						end_year = "ref_year"
				),
		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")
		)
)


#' charge method for report_annual class
#'
#' Method used by the graphical interface to load data and check that all choices have
#' been made by the user
#' @param object An object of class \link{report_annual-class}
#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
#' @aliases charge.report_annual
#' @return object An object of class \link{report_annual-class} with data set from values assigned in \code{envir_stacomi} environment
#' @keywords internal
setMethod(
		"charge",
		signature = signature("report_annual"),
		definition = function(object, silent = FALSE) {
			r_ann <- object
			if (exists("ref_dc", envir_stacomi)) {
				r_ann@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)) {
				r_ann@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)) {
				r_ann@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)) {
				r_ann@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)) {
				r_ann@end_year <- get("end_year", envir_stacomi)
			} else {
				funout(gettext("You need to choose the ending year\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			assign("report_annual", r_ann, envir_stacomi)
			funout(
					gettext(
							"The object report_annual is stored in the stacomi environment, type r_ann <-get('report_annual',envir_stacomi)",
							domain = "R-stacomiR"
					)
			)
			return(r_ann)
			
			
		}
)


#' connect method for report_annual class
#' this method performs the sum over the year attention this function does
#' not count subsamples.
#' @param object An object of class \link{report_annual-class}
#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
#' @return An instantiated object with values filled with user choice
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of class \link{report_annual-class} including a dataframe with column effectif, comprising the sum of report_mig counts
#' @importFrom dplyr anti_join arrange bind_rows
#' @aliases connect.report_annual
setMethod(
		"connect",
		signature = signature("report_annual"),
		definition = function(object, silent = FALSE)
		{
			r_ann <- object
			req = new("RequeteDB")
			##############################
			##############################"
			start_year =	r_ann@start_year@year_selected
			end_year = r_ann@end_year@year_selected
			dc = vector_to_listsql(r_ann@dc@dc_selected)
			tax = vector_to_listsql(r_ann@taxa@taxa_selected)
			std = vector_to_listsql(r_ann@stage@stage_selected)
			
			reqdiff = new("RequeteDB")
			
			reqdiff@sql = paste(
					"select *, extract(year  from ope_date_debut) as annee_debut, extract(year  from ope_date_fin) as annee_fin	FROM ",
					get_schema(),
					"t_operation_ope  join ",
					get_schema(),
					"t_lot_lot on lot_ope_identifiant=ope_identifiant
							where ope_dic_identifiant in ",
					dc,
					" and extract(year from ope_date_debut)>=",
					start_year,
					" and	 extract(year from ope_date_debut)<=",
					end_year,
					" and ope_dic_identifiant in ",
					dc,
					" and lot_tax_code in ",
					tax,
					" and lot_std_code in ",
					std,
					" and lot_lot_identifiant is null
							order by ope_dic_identifiant, annee_debut,annee_fin; ",
					sep = ""
			)
			reqdiff@sql <-
					stringr::str_replace_all(reqdiff@sql, "[\r\n\t]" , " ")
			reqdiff <- stacomirtools::query(reqdiff)
			detailed_data <- stacomirtools::getquery(reqdiff)
			# If there are some operations with year of date_debut different to the year of date_fin we need to find these operations
			# and apply on it the overlaps function to separate fish that arrive during the first year from the rest
			#If we don't have operation on two years we apply the simple sum per year
			annee_differentes <-
					detailed_data$annee_debut != detailed_data$annee_fin
			if (any(annee_differentes)) {
				data_to_cut <- detailed_data[annee_differentes, ]
				data_not_to_cut <- detailed_data[!annee_differentes, ]
				# vector of years of cut
				round_years <-
						lubridate::floor_date(data_to_cut$ope_date_debut, "years") + lubridate::years(1)
				end_of_the_year = difftime(round_years, data_to_cut$ope_date_debut, units =
								"days")
				beginning_of_the_year = difftime(data_to_cut$ope_date_fin, round_years, units =
								"day")
				operation_duration = difftime(data_to_cut$ope_date_fin,
						data_to_cut$ope_date_debut,
						units = "day")
				data_beginning_of_the_year <- data_to_cut
				data_beginning_of_the_year$lot_effectif <-
						data_beginning_of_the_year$lot_effectif *
						as.numeric(beginning_of_the_year) / as.numeric(operation_duration)
				data_beginning_of_the_year$ope_date_debut <- round_years
				data_beginning_of_the_year$annee_debut <-
						lubridate::year(round_years)
				data_end_of_the_year <- data_to_cut
				data_end_of_the_year$lot_effectif <-
						data_end_of_the_year$lot_effectif *
						as.numeric(end_of_the_year) / as.numeric(operation_duration)
				data_end_of_the_year$ope_date_fin <- round_years
				final_data <-
						rbind(data_not_to_cut,
								data_beginning_of_the_year,
								data_end_of_the_year)
				
				con <- new("ConnectionDB")
				con <- connect(con)
				on.exit(pool::poolClose(con@connection))
				pool::dbWriteTable(con@connection, 
						name = "final_data", 
						value=final_data, 
						temporary=TRUE)	
				r_ann@data <- pool::dbGetQuery(con@connection,
						" select sum(lot_effectif) as effectif, annee_debut as annee,
								ope_dic_identifiant,
								lot_tax_code,
								lot_std_code
								from
								final_data
								group by annee, ope_dic_identifiant, lot_tax_code, lot_std_code
								order by ope_dic_identifiant, annee, lot_tax_code, lot_std_code; ")					
				
			}
			#If we have dc and years with no difference in the years of start and end for the same operation we calculate the "classical" sum by year
			else {
				req@sql = paste(
						" select sum(lot_effectif) as effectif, annee, ope_dic_identifiant,lot_tax_code, lot_std_code  from
								(select *, extract(year  from ope_date_debut) as annee FROM ",
						get_schema(),
						"t_operation_ope ",
						" join ",
						get_schema(),
						"t_lot_lot on lot_ope_identifiant=ope_identifiant where ope_dic_identifiant in",
						dc,
						" and extract(year from ope_date_debut)>=",
						start_year,
						" and extract(year from ope_date_fin)<=",
						end_year,
						" and ope_dic_identifiant in ",
						dc,
						" and lot_tax_code in ",
						tax,
						" and lot_std_code in ",
						std,
						" and lot_lot_identifiant is null) as tmp",
						" group by annee, ope_dic_identifiant, lot_tax_code, lot_std_code ",
						" order by ope_dic_identifiant, annee, lot_tax_code, lot_std_code; ",
						sep = ""
				)
				req@sql <- stringr::str_replace_all(req@sql, "[\r\n\t]" , "")
				req <- stacomirtools::query(req)
				resdata <- getquery(req)

				all_comb <- expand.grid(
						annee = start_year:end_year,
						ope_dic_identifiant = r_ann@dc@dc_selected,
				    lot_tax_code = r_ann@taxa@taxa_selected,
						lot_std_code =  r_ann@stage@stage_selected
						)
				missing <- dplyr::anti_join(all_comb,resdata[,c("annee", "ope_dic_identifiant", "lot_tax_code", 
										"lot_std_code")])
				if (nrow(missing) > 0){
				missing$effectif = 0
				r_ann@data <- dplyr::bind_rows(resdata,missing)
				} else {
					r_ann@data <-	resdata
				}
				r_ann@data <- dplyr::arrange(r_ann@data,ope_dic_identifiant, lot_tax_code, lot_std_code, annee)		
			}
			return(r_ann)
		}
)

#' command line interface for \link{report_annual-class}
#' 
#' 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}
#' @param object An object of class \link{report_annual-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_annual-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_annual
setMethod(
		"choice_c",
		signature = signature("report_annual"),
		definition = function(object,
				dc,
				taxa,
				stage,
				start_year,
				end_year,
				silent = FALSE) {
			# code for debug using example
			#dc=c(5,6);taxa="Anguilla anguilla";stage=c("AGJ","AGG","CIV");start_year="1996";end_year="2016"
			r_ann <- object
			r_ann@dc = charge(r_ann@dc)
			# loads and verifies the dc
			# this will set dc_selected slot
			r_ann@dc <- choice_c(object = r_ann@dc, dc)
			# only taxa present in the report_mig are used
			r_ann@taxa <-
					charge_with_filter(object = r_ann@taxa, r_ann@dc@dc_selected)
			r_ann@taxa <- choice_c(r_ann@taxa, taxa)
			r_ann@stage <-
					charge_with_filter(object = r_ann@stage,
							r_ann@dc@dc_selected,
							r_ann@taxa@taxa_selected)
			r_ann@stage <- choice_c(r_ann@stage, stage)
			
			r_ann@start_year <- charge(object = r_ann@start_year,
					objectreport = "report_annual")
			r_ann@start_year <- choice_c(
					object = r_ann@start_year,
					nomassign = "start_year",
					annee = start_year,
					silent = silent
			)
			r_ann@end_year@data <- r_ann@start_year@data
			r_ann@end_year <- choice_c(
					object = r_ann@end_year,
					nomassign = "end_year",
					annee = end_year,
					silent = silent
			)
			assign("report_annual", r_ann, envir = envir_stacomi)
			return(r_ann)
		}
)

#' xtable function for \link{report_annual-class}
#' create an xtable objet but also assigns an add.to.column argument in envir_stacomi,
#' for later use by the print.xtable method.
#' @param x, an object of class "report_annual"
#' @param caption, see xtable
#' @param label, see xtable
#' @param align, see xtable, overidden if NULL
#' @param digits default 0
#' @param display see xtable
#' @param auto see xtable
#' @param dc_name A string indicating the names of the DC, in the order of  \code{x@dc@dc_selected}
#' if not provided DC codes are used.
#' @param tax_name A string indicating the names of the taxa, if not provided latin names are used
#' @param std_name A string indicating the stages names, if not provided then std_libelle are used
#' @return A xtable for annual report
#' @aliases xtable.report_annual
#' @export
setMethod(
		"xtable",
		signature = signature("report_annual"),
		definition = function(x,
				caption = NULL,
				label = NULL,
				align = NULL,
				digits = 0,
				display = NULL,
				auto = FALSE,
				dc_name = NULL,
				tax_name = NULL,
				std_name = NULL) {
			r_ann <- x
			dat = r_ann@data
			tax = r_ann@taxa@taxa_selected
			std = r_ann@stage@stage_selected
			dc = r_ann@dc@dc_selected
			# giving names by default if NULL else checking that arguments dc_name, tax_name, std_name
			#have the right length
			if (is.null(dc_name)){
				dc_name = r_ann@dc@data$dc_code[r_ann@dc@data$dc %in% r_ann@dc@dc_selected]
			} 
			if (length(dc) != length(dc_name)) {
				stop (stringr::str_c("dc_name argument should have length ", length(dc)))
			}
			if (is.null(tax_name)){
				tax_name = r_ann@taxa@data$tax_nom_latin[r_ann@taxa@data$tax_code %in% r_ann@taxa@taxa_selected]
			} 
			if (length(tax) != length(tax_name)){
				stop (stringr::str_c("tax_name argument should have length ", length(tax)))
			}
			if (is.null(std_name)){
				std_name = r_ann@stage@data$std_libelle[r_ann@stage@data$std_code %in% r_ann@stage@stage_selected]
			}

			if (length(std) != length(std_name)){
				stop (stringr::str_c("std_name argument should have length ", length(std)))
			}
			
			dat <-
					dat[, c("annee",
									"effectif",
									"ope_dic_identifiant",
									"lot_tax_code",
									"lot_std_code")]
			dat <-
					reshape2::dcast(dat,
							annee ~ ope_dic_identifiant + lot_tax_code + lot_std_code,
							value.var = "effectif")
			coln <- colnames(dat)[2:length(colnames(dat))]
			# names header for DC
			# this function creates title as "multicolumn" arguments, repeated over columns if necessary
			# it will be passed later as add.to.row print.xtable command
			fn_title <- function(les_valeurs, valeur_uk, name_uk, total = TRUE) {
				which_arg <- match(les_valeurs, valeur_uk)
				if (length(les_valeurs) == 1) {
					repetes <- FALSE
				} else {
					repetes <-
							c(les_valeurs[2:length(les_valeurs)] == les_valeurs[1:(length(les_valeurs) -
														1)], FALSE) # FALSE, at the end we want the values aggregated anyway
				}
				rr = 1
				les_valeurs_final <- vector()
				for (i in 1:length(les_valeurs)) {
					# if the same argument is repeated over current value and the next
					if (repetes[i]) {
						rr <- rr + 1
					} else {
						# sortie de la boucle
						les_valeurs_final <-
								c(
										les_valeurs_final,
										stringr::str_c(
												"\\multicolumn{",
												rr,
												"}{c}{",
												xtable::sanitize(name_uk[which_arg[i]]),
												"}"
										)
								)
						rr = 1
					}
				}
				if (total) {
					les_valeurs_final <-
							stringr::str_c(" & ",
									stringr::str_c(les_valeurs_final, collapse = " & "),
									" & Total\\\\\n")
				} else {
					les_valeurs_final <-
							stringr::str_c(" & ",
									stringr::str_c(les_valeurs_final, collapse = " & "),
									" & \\\\\n")
				}
				return(les_valeurs_final)
			}
			les_dc <-
					unlist(lapply(stringr::str_split(coln, "_"), function(X)
										X[1]))
			les_dc <-
					fn_title(
							les_valeurs = les_dc,
							valeur_uk = dc,
							name_uk = dc_name,
							total = FALSE
					)
			
			#header for tax
			les_tax <-
					unlist(lapply(stringr::str_split(coln, "_"), function(X)
										X[2]))
			les_tax <-
					fn_title(
							les_valeurs = les_tax,
							valeur_uk = tax,
							name_uk = tax_name,
							total = FALSE
					)
			# name header for std
			les_std <-
					unlist(lapply(stringr::str_split(coln, "_"), function(X)
										X[3]))
			les_std <-
					fn_title(
							les_valeurs = les_std,
							valeur_uk = std,
							name_uk = std_name,
							total = TRUE
					)
			# remove annee (it is now only rownames)
			rownames(dat) <- dat$annee
			dat <- dat[, -1, FALSE]
			# calculating sum
			if (ncol(dat) > 1)
				dat$sum <- rowSums(dat[, 1:ncol(dat)], na.rm = TRUE)
			
			
			if (is.null(align))
				align <- c("l", rep("r", ncol(dat)))
			if (is.null(display))
				display = c("s", rep("f", ncol(dat)))
			xt <- xtable::xtable(
					dat,
					caption = caption,
					label = label,
					align = align,
					digits = 0,
					display = display,
					# integer,small scientific if it saves place, string..
					auto = auto
			)
			addtorow <- list()
			addtorow$pos <- list()
			addtorow$pos[[1]] <- 0
			addtorow$pos[[2]] <- 0
			addtorow$pos[[3]] <- 0
			addtorow$pos[[4]] <- 0
			addtorow$pos[[5]] <- 0
			addtorow$command <-
					c(les_dc, "\\hline\n", les_tax , "\\hline\n", les_std)
			assign("addtorow", addtorow, envir_stacomi)
			return(xt)
		}
)


#' barplot method for object \link{report_annual-class}
#' @param height An object of class report_annual
#' @param legend.text See barplot help
#' @param ... additional arguments passed to barplot
#' @return No return value, called for side effects
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases barplot.report_annual
#' @seealso \link{report_annual-class} for examples
#' @export
setMethod(
		"barplot",
		signature(height = "report_annual"),
		definition = function(height, legend.text = NULL, ...) {
			r_ann <- height
			# require(ggplot2)
			if (nrow(r_ann@data) > 0) {
				dat = r_ann@data
				lesdic <- unique(dat$ope_dic_identifiant)
				lestax <- unique(dat$lot_tax_code)
				lesstd <- unique(dat$lot_std_code)
				
				# create a matrix of each dc, taxa, stage
				if (length(lestax) == 1 & length(lesstd) & length(lesdic) == 1) {
					dat0 <-
							reshape2::dcast(dat, lot_tax_code ~ annee, value.var = "effectif")
					mat <- as.matrix(dat0[, 2:ncol(dat0)])
					mat[is.na(mat)] <- 0
					barplot(mat, ...)
					
				} else if (length(lestax) == 1 & length(lesstd) == 1) {
					dat0 <-
							reshape2::dcast(dat, ope_dic_identifiant ~ annee, value.var = "effectif")
					mat <- as.matrix(dat0[, 2:ncol(dat0)])
					mat[is.na(mat)] <- 0
					if (is.null(legend.text)) {
						legend.text = dat0$ope_dic_identifiant
						barplot(mat, legend.text = legend.text, ...)
					} else {
						barplot(mat, ...)
					}
					
				} else if (length(lestax) == 1 & length(lesdic) == 1) {
					dat0 <-
							reshape2::dcast(dat, lot_std_code ~ annee, value.var = "effectif")
					mat <- as.matrix(dat0[, 2:ncol(dat0)])
					mat[is.na(mat)] <- 0
					if (is.null(legend.text)) {
						legend.text = dat0$lot_std_code
						barplot(mat, legend.text = legend.text, ...)
					} else {
						barplot(mat, ...)
					}
					
				} else if (length(lesdic) == 1 & length(lesstd) == 1) {
					dat0 <-
							reshape2::dcast(dat, lot_tax_code ~ annee, value.var = "effectif")
					mat <- as.matrix(dat0[, 2:ncol(dat0)])
					mat[is.na(mat)] <- 0
					if (is.null(legend.text)) {
						legend.text <- dat0$lot_tax_code
						barplot(mat, legend.text = legend.text, ...)
					} else {
						barplot(mat, ...)
					}
					
				} else if (length(lestax) == 1) {
					dat0 <-
							reshape2::dcast(dat,
									ope_dic_identifiant + lot_std_code ~ annee,
									value.var = "effectif")
					mat <- as.matrix(dat0[, 3:ncol(dat0)])
					mat[is.na(mat)] <- 0
					if (is.null(legend.text)) {
						legend.text <-
								stringr::str_c(dat0$ope_dic_identifiant, "_", dat0$lot_std_code)
						barplot(mat, legend.text = legend.text, ...)
					} else {
						barplot(mat, ...)
					}
					
				} else if (length(lesstd) == 1) {
					dat0 <-
							reshape2::dcast(dat,
									ope_dic_identifiant + lot_tax_code ~ annee,
									value.var = "effectif")
					mat <- as.matrix(dat0[, 3:ncol(dat0)])
					mat[is.na(mat)] <- 0
					if (is.null(legend.text)) {
						legend.text <-
								stringr::str_c(dat0$ope_dic_identifiant, "_", dat0$lot_tax_code)
						barplot(mat, legend.text = legend.text, ...)
					} else {
						barplot(mat, ...)
					}
				} else if (length(lesdic) == 1) {
					dat0 <-
							reshape2::dcast(dat, lot_std_code + lot_tax_code ~ annee, value.var = "effectif")
					mat <- as.matrix(dat0[, 3:ncol(dat0)])
					mat[is.na(mat)] <- 0
					if (is.null(legend.text)) {
						legend.text <- stringr::str_c(dat0$lot_tax_code, "_", dat0$lot_std_code)
						barplot(mat, legend.text = legend.text, ...)
					} else {
						barplot(mat, ...)
					}
					
				} else {
					dat0 <-
							reshape2::dcast(dat,
									ope_dic_identifiant + lot_tax_code + lot_std_code ~ annee,
									value.var = "effectif")
					mat <- as.matrix(dat0[, 4:ncol(dat0)])
					mat[is.na(mat)] <- 0
					if (is.null(legend.text)) {
						legend.text <- stringr::str_c(dat0$ope_dic_identifiant,
								"_",
								dat0$lot_tax_code,
								"_",
								dat0$lot_std_code)
						barplot(mat, legend.text = legend.text, ...)
					} else {
						barplot(mat, ...)
					}
				}
			}    else     {
				funout(gettext("No data", domain = "R-stacomiR"))
			}
			return(invisible(NULL))
		}
)



#' Plot method for report_annual
#'
#' @param x An object of class \link{report_annual-class}
#' @param plot.type Default point
#' @param silent Stops displaying the messages.
#' \itemize{
#' 		\item{plot.type="point": ggplot+geom_point}'
#' }
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_annual
#' @seealso \link{report_mig_interannual-class} for examples
#' @return No return value, called for side effects
#' @importFrom scales breaks_pretty
#' @export
setMethod(
		"plot",
		signature(x = "report_annual", y = "missing"),
		definition = function(x,
				plot.type = "point",
				silent = FALSE) {
			r_ann <- x
			dat <- r_ann@data
			lesdic <- unique(dat$ope_dic_identifiant)
			lestax <- unique(dat$lot_tax_code)
			lesstd <- unique(dat$lot_std_code)
			if (nrow(r_ann@data) > 0) {
				if (plot.type == "point") {
					colnames(dat) <- c("effectif", "annee", "dc", "taxa", "stage")
					dat$dc <- as.factor(dat$dc)
					dat$taxa <- as.factor(dat$taxa)
					if (length(lestax) == 1 & length(lesstd) & length(lesdic) == 1) {
						# note below the scale is made to avoid 2000.5 2001 ... and too much breaks as well 
						# see #27
						g <- ggplot(dat, aes(x = annee, y = effectif)) + geom_point() +
								geom_line() +
								scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
								theme_bw()
						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 (length(lestax) == 1 & length(lesstd) == 1) {
						g <- ggplot(dat, aes(x = annee, y = effectif)) +
								geom_point(aes(col = dc)) +
								geom_line(aes(col = dc)) +
								scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
								theme_bw()
						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 (length(lestax) == 1 & length(lesdic) == 1) {
						g <- ggplot(dat, aes(x = annee, y = effectif)) + geom_point(aes(col = stage)) +
								geom_line(aes(col = stage)) +
								scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
								theme_bw()
						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 (length(lesdic) == 1 & length(lesstd) == 1) {
						g <- ggplot(dat, aes(x = annee, y = effectif)) + geom_point(aes(col = taxa)) +
								geom_line(aes(col = taxa)) +
								scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
								theme_bw()
						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 (length(lestax) == 1) {
						g <-
								ggplot(dat, aes(x = annee, y = effectif)) + geom_point(aes(col = dc, shape =
														stage)) +
								geom_line(aes(col = dc, linetype = stage)) +
								scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
								theme_bw()
						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 (length(lesstd) == 1) {
						g <-
								ggplot(dat, aes(x = annee, y = effectif)) + geom_point(aes(col = dc, shape =
														taxa)) +
								geom_line(aes(col = dc, shape = taxa)) +
								scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
								theme_bw()
						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 (length(lesdic) == 1) {
						g <-
								ggplot(dat, aes(x = annee, y = effectif)) + geom_point(aes(col = taxa, shape =
														stage)) +
								geom_line(aes(col = taxa, shape = stage)) +
								scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
								theme_bw()
						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 (length(lesdic) < 3) {
							g <-
									ggplot(dat, aes(x = annee, y = effectif)) + geom_point(aes(col = taxa, shape =
															stage)) +
									geom_line(aes(col = taxa, shape = stage)) +
									scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
									facet_wrap( ~ dc) +
									theme_bw()
							print(g)
							assign("g", g, envir_stacomi)
						} else {
							g <- ggplot(dat, aes(x = annee, y = effectif)) + geom_point(aes(col = stage)) +
									geom_line(aes(col = stage)) +
									facet_grid(dc ~ stage) +
									scale_x_continuous(breaks = scales::breaks_pretty(n=pmin(length(unique(dat$annee)),10))) +
									theme_bw()
							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     {
				funout(gettext("No data", domain = "R-stacomiR"))
			}
			return(invisible(NULL))
		}

)




#' Class "report_dc" report du fonctionnement du dispositif de
#' comptage
#'
#' The counting device is not always working. It may me stopped either
#' following a monitoring protocol, or due to malfunction of the device, this
#' class allows to draw graphics allowing an overview of the device operation
#' @slot data A data frame
#' @slot dc An object of class \code{ref_dc-class}
#' @slot horodatedebut An object of class \code{ref_horodate-class}
#' @slot horodatefin An object of class \code{ref_horodate-class}
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("report_dc", ...)}.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @example inst/examples/report_dc-example.R
#' @family report Objects
#' @keywords classes
#' @aliases report_dc
#' @export
setClass(
		Class = "report_dc",
		representation = representation(
				data = "data.frame",
				dc = "ref_dc",
				horodatedebut = "ref_horodate",
				horodatefin = "ref_horodate"
		),
		prototype = prototype(
				data = data.frame(),
				dc = new("ref_dc"),
				horodatedebut = new("ref_horodate"),
				horodatefin = new("ref_horodate")
		)
)




#' connect method for report_dc
#'
#' loads the working periods and type of arrest or disfunction of the DC
#' @param object An object of class \link{report_dc-class}
#' @param silent boolean, default FALSE, if TRUE messages are not displayed
#' @return  An object of class \link{report_dc-class} with slot data filled from the database
#' @aliases connect.report_dc
#' @author cedric.briand
setMethod(
		"connect",
		signature = signature("report_dc"),
		definition = function(object, silent = FALSE) {
			#object<-report_dc
			if (length(object@dc@dc_selected)==0) stop("No selected dc in repor_dc@dc@dc_selected, did you forget to use the method charge ?")
			req <- new("RequeteDBwheredate")
			req@select = sql <- paste(
					"SELECT",
					" per_dis_identifiant,",
					" per_date_debut,",
					" per_date_fin,",
					" per_commentaires,",
					" per_etat_fonctionnement,",
					" per_tar_code,",
					" tar_libelle AS libelle",
					" FROM  ",
					get_schema(),
					"t_periodefonctdispositif_per per",
					" INNER JOIN ref.tr_typearretdisp_tar tar ON tar.tar_code=per.per_tar_code",
					sep = ""
			)
			req@colonnedebut <- "per_date_debut"
			req@colonnefin <- "per_date_fin"
			req@datedebut <- object@horodatedebut@horodate
			req@datefin <- object@horodatefin@horodate
			req@order_by <- "ORDER BY per_date_debut"
			req@and <-
					paste("AND per_dis_identifiant in ",
							vector_to_listsql(object@dc@dc_selected))
			#req@where=#defini dans la methode DBwheredate
			req <-
					stacomirtools::query(req) # appel de la methode connect de l'object DBWHEREDATE
			object@data <- req@query
			if (!silent)
				funout(gettext("Time steps loaded for this counting device\n", domain =
										"R-stacomiR"))
			return(object)
		}
)

#' charge method for report_dc
#'
#' used by the graphical interface to retrieve the objects of referential classes
#' assigned to envir_stacomi
#' @param object An object of class \link{report_dc-class}
#' @param silent boolean, default FALSE, if TRUE messages are not displayed.
#' @aliases charge.report_dc
#' @return object An object of class \link{report_dc-class} with data set from values assigned in \code{envir_stacomi} environment

#' @keywords internal
setMethod(
		"charge",
		signature = signature("report_dc"),
		definition = function(object, silent = FALSE) {
			if (exists("ref_dc", envir_stacomi)) {
				object@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("report_dc_date_debut", envir_stacomi)) {
				object@horodatedebut@horodate <-
						get("report_dc_date_debut", envir_stacomi)
			} else {
				funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			
			if (exists("report_dc_date_fin", envir_stacomi)) {
				object@horodatefin@horodate <- get("report_dc_date_fin", envir_stacomi)
			} else {
				funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			return(object)
		}
)


#' command line interface for report_dc class
#'
#' The choice_c method fills in the data slot for ref_dc, and then
#' uses the choice_c methods of these object to "select" the data.
#' @param object An object of class \link{ref_dc-class}
#' @param dc The dc to set
#' @param horodatedebut A POSIXt or Date or character to fix the date of beginning of the report
#' @param horodatefin A POSIXt or Date or character to fix the last date of the report
#' @param silent Should program be silent or display messages
#' @aliases choice_c.report_dc
#' @return An object of class \link{ref_dc-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
setMethod(
		"choice_c",
		signature = signature("report_dc"),
		definition = function(object,
				dc,
				horodatedebut,
				horodatefin,
				silent = FALSE) {
			# report_dc<-r_dc;dc=5;horodatedebut="2000-01-01";horodatefin="2015-12-31";silent=TRUE
			report_dc <- object
			assign("report_dc", report_dc, envir = envir_stacomi)
			if (!silent)
				funout(
						gettext(
								"Loading of the list for fishways and choice of the time step\n",
								domain = "R-stacomiR"
						)
				)
			report_dc@dc <- charge(report_dc@dc)
			report_dc@dc <- choice_c(report_dc@dc, dc)
			# assigns the parameter (horodatedebut) of the method to the object using choice_c method for ref_dc
			report_dc@horodatedebut <- choice_c(
					object = report_dc@horodatedebut,
					nomassign = "report_dc_date_debut",
					funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatedebut,
					silent = silent
			)
			report_dc@horodatefin <- choice_c(
					report_dc@horodatefin,
					nomassign = "report_dc_date_fin",
					funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatefin,
					silent = silent
			)
			assign("report_dc", report_dc, envir = envir_stacomi)
			return(report_dc)
		}
)

#' Different plots for report_dc
#'
#' \itemize{
#' \item{plot.type=1}{A barplot of the operation time per month}
#' \item{plot.type=2}{Barchat giving the time per type of operation }
#' \item{plot.type=2}{Rectangle plots drawn along a line}
#' \item{plot.type=4}{Plots per day drawn over the period to show the operation of a df, days in x, hours in y}
#' 	}
#'
#' @note The program cuts periods which overlap between two month.
#' The splitting of different periods into month is
#' assigned to the \code{envir_stacomi} environment.
#' @param x An object of class \link{report_dc-class}.
#' @param plot.type 1 to 4, barplot, barchart, rectangle plot and box showing details of daily operation,
#' a plot with adjacent rectangles.
#' @param silent Stops displaying the messages default to FALSE 
#' @param main The title of the graph, if NULL a default title will be plotted
#' with the number of the DF.
#' @param color_type_oper Named vector of color for the graph, must match type operation default to 
#' c("Fonc normal" = "#76BEBE",
#'  "Arr ponctuel" = "#FF6700",
#'  "Arr maint" = "#9E0142",
#'  "Dysfonc" = "#EE1874",
#'  "Non connu" = "#999999").
#' @param color_etat Named vector state value (must match the names "TRUE", "FALSE").
#' @return Nothing but prints the different plots.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_dc
#' @importFrom utils setTxtProgressBar
#' @export
setMethod(
		"plot",
		signature(x = "report_dc", y = "missing"),
		definition =
				function(x,
						plot.type = 1,
						silent = FALSE,
						main = NULL,
						color_type_oper = 	c("Fonc normal" = "#76BEBE",
						                     "Arr ponctuel" = "#FF6700", 
						                     "Arr maint" = "#9E0142",
						                     "Dysfonc" = "#EE1874",
						                     "Non connu" = "#999999"),
						color_etat=c("TRUE"="#0F313A","FALSE"="#CEB99A")) {
			#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			#           PLOT OF TYPE BARCHART (plot.type=1 (true/false) or plot.type=2)
			#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			#report_dc<-r_dc; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="1"
			
			report_dc <- x
			plot.type <- as.character(plot.type)# to pass also characters
			if (!plot.type %in% c("1", "2", "3", "4"))
				stop('plot.type must be 1,2,3 or 4')
			if (nrow(report_dc@data) == 0)
				funout(gettext("No data for this counting device\n", domain = "R-stacomiR"),
						arret = TRUE)
			if (plot.type == "1" | plot.type == "2") {
				t_periodefonctdispositif_per = report_dc@data # on recupere le data.frame
				tempsdebut <- t_periodefonctdispositif_per$per_date_debut
				tempsfin <- t_periodefonctdispositif_per$per_date_fin
				tempsdebut[tempsdebut < report_dc@horodatedebut@horodate] <-
						report_dc@horodatedebut@horodate
				tempsfin[tempsfin > report_dc@horodatefin@horodate] <-
						report_dc@horodatefin@horodate
				t_periodefonctdispositif_per = cbind(t_periodefonctdispositif_per, tempsdebut, tempsfin)
				seqmois = seq(
						from = tempsdebut[1],
						to = tempsfin[nrow(t_periodefonctdispositif_per)],
						by = "month",
						tz = "GMT"
				)
				seqmois = as.POSIXlt(round_date(seqmois, unit = "month"))
				# adding one month at the end to get a complete coverage of the final month
				seqmois <- c(seqmois,
						seqmois[length(seqmois)] %m+% months(1))
				t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per[1, ]
				############################
				# progress bar
				###########################
				
				progress_bar <- utils::txtProgressBar()
				# this function assigns
				z = 0 # compteur tableau t_periodefonctdispositif_per_mois
				for (j in 1:nrow(t_periodefonctdispositif_per)) {
					#cat( j
					setTxtProgressBar(progress_bar,j / nrow(t_periodefonctdispositif_per))
					if (j > 1)
						t_periodefonctdispositif_per_mois = rbind(t_periodefonctdispositif_per_mois,
								t_periodefonctdispositif_per[j, ])
					lemoisnext = seqmois[seqmois > tempsdebut[j]][1] # le premier mois superieur a tempsdebut
					while (tempsfin[j] > lemoisnext) {
						# on est a cheval sur deux periodes
						
						#if (z>0) stop("erreur")
						z = z + 1
						t_periodefonctdispositif_per_mois = rbind(t_periodefonctdispositif_per_mois,
								t_periodefonctdispositif_per[j, ])
						t_periodefonctdispositif_per_mois[j + z, "tempsdebut"] = as.POSIXct(lemoisnext)
						t_periodefonctdispositif_per_mois[j + z - 1, "tempsfin"] = as.POSIXct(lemoisnext)
						lemoisnext = seqmois[match(as.character(lemoisnext), as.character(seqmois)) +
										1] # on decale de 1 mois avant de rerentrer dans la boucle
						#if (is.na(lemoisnext) ) break
					}
					#if (is.na(lemoisnext)) break
				}
				t_periodefonctdispositif_per_mois$sumduree <-
						as.numeric(
								difftime(
										t_periodefonctdispositif_per_mois$tempsfin,
										t_periodefonctdispositif_per_mois$tempsdebut,
										units = "hours"
								)
						)
				t_periodefonctdispositif_per_mois$mois1 = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
						"%b")
				t_periodefonctdispositif_per_mois$mois = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
						"%m")
				t_periodefonctdispositif_per_mois$annee = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
						"%Y")
				cat("All done.\n")
				close(progress_bar)
				if (is.null(main))
					main <-
							gettextf("Operation of the counting device %s",
									report_dc@dc@dc_selected)
				
				# graphic
				#modification of the order
				
				t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per_mois[order(t_periodefonctdispositif_per_mois$per_etat_fonctionnement,
								decreasing = TRUE), ]
				g <- ggplot(t_periodefonctdispositif_per_mois,
								aes(x = mois, y = sumduree, fill = libelle)) +
						facet_grid(annee ~ .) +
						ggtitle(main) +
						ylab(gettext("duration", domain = "R-stacomiR")) +
						xlab(gettext("month", domain = "R-stacomiR")) +
						geom_bar(stat = 'identity') +
						scale_fill_manual(
								gettext("type_oper.", domain = "R-stacomiR"),
								values = color_type_oper
						) +
						theme(
								plot.background = element_rect(fill = "white"),
								panel.background = element_rect(fill = "white"),
								legend.background = element_rect(fill = "white"),
								strip.background = element_rect(colour = "pink", fill = "brown"),
								strip.text = element_text(colour = "white"),
								panel.grid.major = element_blank(),
								panel.grid.minor = element_blank(),
								text = element_text(colour = "navyblue"),
								line = element_line(colour = "black"),
								legend.key = element_rect(fill = "white", colour = "black"),
								axis.text = element_text(colour = "black")
						)
				
				t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per_mois[order(t_periodefonctdispositif_per_mois$per_etat_fonctionnement), ]
				t_periodefonctdispositif_per_mois$per_etat_fonctionnement = as.factor(t_periodefonctdispositif_per_mois$per_etat_fonctionnement)
				g1 <-
						ggplot(t_periodefonctdispositif_per_mois,
								aes(x = mois, y = sumduree)) +
						facet_grid(annee ~ .) +
						ggtitle(main) +
						ylab(gettext("duration", domain = "R-stacomiR")) +
						xlab(gettext("month", domain = "R-stacomiR")) +
						geom_bar(stat = 'identity', aes(fill = per_etat_fonctionnement)) +
						scale_fill_manual(gettext("operation", domain = "R-stacomiR"),
								values = color_etat) +
						theme(
								plot.background = element_rect(fill = "white"),
								panel.background = element_rect(fill = "white"),
								legend.background = element_rect(fill = "white"),
								strip.background = element_rect(colour = "#C07C44", fill = "#A07C68"),
								strip.text = element_text(colour = "#41DADE"),
								panel.grid.major = element_blank(),
								panel.grid.minor = element_blank(),
								text = element_text(colour = "#482E21"),
								line = element_line(colour = "black"),
								legend.key = element_rect(fill = "white", colour = "black"),
								axis.text = element_text(colour = "black")
						)
				
				if (plot.type == "1") {
					print(g)
					assign(x = "g_report_dc_1",
							value = g,
							envir = envir_stacomi)
					if (!silent){
						funout(text =
										gettext(
												"Writing the ggplot into envir_stacomi environment : g_report_dc_1=get('g_report_dc_1',envir_stacomi)\n",
												domain = "R-stacomiR"
										)
						)
					}
				} # end if plot 1
				if (plot.type == "2"){
					print(g1) 
					assign("g_report_dc_2",
							g1,
							envir = envir_stacomi)			
					if (!silent){
						funout(
								gettext(
										"Writing the ggplot into envir_stacomi environment : g_report_dc_2=get('g_report_dc_2',envir_stacomi)\n",
										domain = "R-stacomiR"
								)
						)
					}
				} # end if plot 2
				assign("periodeDC",
						t_periodefonctdispositif_per_mois,
						envir = envir_stacomi)
				if (!silent)
					funout(
							gettext(
									"Writing the table into envir_stacomi environment : write periodeDC=get('periodeDC',envir_stacomi)\n",
									domain = "R-stacomiR"
							)
					)
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
				#           PLOT OF TYPE BOX (plot.type=3)
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			} else if (plot.type == "3") {
				#report_dc<-r_dc; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="3"
				t_periodefonctdispositif_per = report_dc@data
				graphdate <- function(vectordate) {
					vectordate <- as.POSIXct(vectordate)
					attributes(vectordate) <- NULL
					unclass(vectordate)
					return(vectordate)
				}
				time.sequence = seq.POSIXt(
						from = report_dc@horodatedebut@horodate,
						to = report_dc@horodatefin@horodate,
						by = "day"
				)
				debut = graphdate(time.sequence[1])
				fin = graphdate(time.sequence[length(time.sequence)])
				
				
				
				# creation d'un graphique vide
				if (is.null(main))
					main <- ""
				plot(
						graphdate(time.sequence),
						seq(0, 1, length.out = length(time.sequence)),
						xlim = c(debut, fin),
						type = "n",
						xlab = "",
						xaxt = "n",
						yaxt = "n",
						ylab = gettext("Counting device", domain = "R-stacomiR"),
						main = main,
						#bty="n",
						cex = 0.8
				)
				r <- round(range(time.sequence), "day")
				graphics::axis(1,
						at = graphdate(seq(r[1], r[2], by = "month")),
						labels = strftime(as.POSIXlt(seq(r[1], r[2], by = "month")), format = "%d-%b"))
				if (dim(t_periodefonctdispositif_per)[1] == 0) {
					rect(
							xleft = debut,
							ybottom = 0.6,
							xright = fin,
							ytop = 0.9,
							col = "grey",
							border = NA,
							lwd = 1
					)
					rect(
							xleft = debut,
							ybottom = 0.1,
							xright = fin,
							ytop = 0.4,
							col = color_type_oper["Non connu"],
							border = NA,
							lwd = 1
					)
					legend(
							x = "bottom",
							legend = gettext("Func.", "Stop", "Normal func", domain = "R-stacomiR"),
							pch = c(16, 16),
							col = c("grey", color_type_oper["Non connu"]),
							#horiz=TRUE,
							ncol = 3,
							bty = "n"
					)
				} else {
					if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement == 1) > 0) {
						rect(
								xleft = graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														1]),
								ybottom = 0.6,
								xright = graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														1]),
								ytop = 0.9,
								col = color_etat["TRUE"],
								border = NA,
								lwd = 1
						)
					}
					if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement == 0) >
							0)   {
						rect(
								xleft = graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														0]),
								ybottom = 0.6,
								xright = graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														0]),
								ytop = 0.9,
								col = color_etat["FALSE"],
								border = NA,
								lwd = 1
						)
					}
				}
				listeperiode <-
						fun_table_per_dis(
								typeperiode = t_periodefonctdispositif_per$per_tar_code,
								tempsdebut = t_periodefonctdispositif_per$per_date_debut,
								tempsfin = t_periodefonctdispositif_per$per_date_fin,
								libelle = t_periodefonctdispositif_per$libelle,
								color = color_type_oper[t_periodefonctdispositif_per$libelle],
								date = FALSE
						)
				
				for (j in 1:length(listeperiode)) {
					
					
					rect(
							xleft = graphdate(listeperiode[[j]]$debut),
							ybottom = 0.1,
							xright = graphdate(listeperiode[[j]]$fin),
							ytop = 0.4,
							col = listeperiode[[j]]$color,
							border = NA,
							lwd = 1
					)
				}
				legend  (
						x = debut,
						y = 0.6,
						legend = gettext(
								"Normal",
								"Stop",
								domain = "R-stacomiR"
						),
						pch = c(15, 15),
						col = color_etat,
						bty = "n",
						horiz = TRUE,
						text.width = (fin - debut) / 6 ,
						cex = 0.8
				)
				legend  (
						x = debut,
						y = 0.1,
						legend = names(color_type_oper),
						pch = c(15, 15),
						col = color_type_oper,
						bty = "n",
						horiz = TRUE,
						text.width = (fin - debut) / 6,
						cex = 0.8
				)
				graphics::text(
						x = debut,
						y = 0.95,
						label = gettext("Operation of the counting device", domain = "R-stacomiR"),
						font = 4,
						pos = 4
				)
				graphics::text(
						x = debut,
						y = 0.45,
						label = gettext("Shutdowns types for this counting device", domain = "R-stacomiR"),
						font = 4,
						pos = 4
				)
				
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
				#           PLOT OF TYPE BOX (plot.type=4)
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			} else if (plot.type == "4") {
				if (is.null(main))
					main <-
							gettext("Working of the counting device",
									report_dc@dc@dc_selected)
				
				#report_dc<-r_dc; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="4"
				t_periodefonctdispositif_per = report_dc@data
				tpp <-
						split_per_day(
								t_periodefonctdispositif_per,
								horodatedebut = "per_date_debut",
								horodatefin = "per_date_fin"
						)
				
				g <- ggplot(tpp) +
						geom_rect(aes(
										xmin = xmin,
										xmax = xmax,
										ymin = Hdeb,
										ymax = Hfin,
										fill = libelle
								),
								alpha = 0.8) +
						scale_fill_manual(
								"type",
								values = c(
										color_type_oper
								),
								labels = gettext(
										"Normal oper",
										"Operational stop",
										"Stop",
										"Dysfunct",
										"Unknown",
										domain = "R-stacomiR"
								)
						) +
						#scale_colour_manual("type",values=c("1"="#40CA2C","2"="#C8B22D","3"="#AB3B26","4"="#B46BED","5"="#B8B8B8"),
						#		labels = gettext("Normal oper","Operational stop","Stop","Dysfunct","Unknown")+		)
						ggtitle(main) +
						ylab("Heure") + theme(
								plot.background = element_rect(fill = "black"),
								panel.background = element_rect(fill = "black"),
								legend.background = element_rect(fill = "black"),
								panel.grid.major = element_blank(),
								panel.grid.minor = element_blank(),
								text = element_text(colour = "white"),
								line = element_line(colour = "grey50"),
								legend.key = element_rect(fill = "black", colour = "black"),
								axis.text = element_text(colour = "white")
						)
				
				print(g)
				assign("g_report_dc_4",
						g,
						envir = envir_stacomi)			
				if (!silent)
					funout(
							gettext(
									"Writing the ggplot into envir_stacomi environment : g_report_dc_4 <- get('g_report_dc_4',envir_stacomi)\n",
									domain = "R-stacomiR"
							)
					)
				
			}
			return(invisible(NULL))
		}
)





#' Method to print the command line of the object.
#' @param x An object of class report_dc
#' @param ... Additional parameters passed to print
#' @return Nothing, called for its side effect
#' @author cedric.briand
#' @aliases print.report_dc
#' @export
setMethod(
		"print",
		signature = signature("report_dc"),
		definition = function(x, ...) {
			sortie1 <- "report_dc=new('report_dc')\n"
			sortie2 <- stringr::str_c(
					"report_dc=choice_c(report_dc,",
					"dc=",
					x@dc@dc_selected,
					",",
					"horodatedebut=",
					shQuote(as.character(x@horodatedebut@horodate)),
					",",
					"horodatefin=",
					shQuote(as.character(x@horodatefin@horodate)),
					")"
			)
			# removing backslashes
			funout(stringr::str_c(sortie1, sortie2), ...)
			return(invisible(NULL))
		}
)



#' summary for report_dc, write csv and html output, and prints summary statistics
#' @param object An object of class \code{\link{report_dc-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters (not used there)
#' @return Nothing, called for its side effect of writing html, csv files and printing summary
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_dc
#' @export
setMethod(
		"summary",
		signature = signature(object = "report_dc"),
		definition = function(object, silent = FALSE, ...) {
			#report_dc<-r_dc
			report_dc <- object
			t_periodefonctdispositif_per <-
					report_dc@data # on recupere le data.frame
			t_periodefonctdispositif_per$per_date_debut <-
					as.character(t_periodefonctdispositif_per$per_date_debut)
			t_periodefonctdispositif_per$per_date_fin <-
					as.character(t_periodefonctdispositif_per$per_date_fin)
			annee = paste(unique(strftime(
									as.POSIXlt(t_periodefonctdispositif_per$per_date_debut),
									"%Y"
							)), collapse = "+")
			path1 = file.path(
					path.expand(get("datawd", envir = envir_stacomi)),
					paste(
							"t_periodefonctdispositif_per_DC_",
							report_dc@dc@dc_selected,
							"_",
							annee,
							".csv",
							sep = ""
					),
					fsep = "\\"
			)
			res <- tryCatch(
					write.table(
							t_periodefonctdispositif_per,
							file = path1,
							row.names = FALSE,
							col.names = TRUE,
							sep = ";"
					), error = function(e) e,
					finally =
							if (!silent)	funout(gettextf("Writing of %s \n", path1, domain = "R-stacomiR"))
			)
			if (inherits(res, "simpleError")) {
				warnings("The table could not be reported, please modify datawd with options(stacomiR.path='path/to/directory'")
			} else {
				# reports works anyways, write html
				path1html <-
						file.path(
								path.expand(get("datawd", envir = envir_stacomi)),
								paste(
										"t_periodefonctdispositif_per_DC_",
										report_dc@dc@dc_selected,
										"_",
										annee,
										".html",
										sep = ""
								),
								fsep = "\\"
						)
				funout(gettextf(
								"Writing of %s this might take a while, please be patient ...\n",
								path1html
						))
				funhtml(
						t_periodefonctdispositif_per,
						caption = gettextf(
								"t_periodefonctdispositif_per_DC_%s_%s",
								report_dc@dc@dc_selected,
								annee
						),
						top = TRUE,
						outfile = path1html,
						clipboard = FALSE,
						append = FALSE,
						digits = 2
				)
			}
			print(gettextf("summary statistics for CD=%s", report_dc@dc@dc_selected),
					domain = "R-stacomiR")
			print(gettextf("dc_code=%s", report_dc@dc@data[report_dc@dc@data$dc ==
											report_dc@dc@dc_selected, "dc_code"], domain = "R-stacomiR"))
			duree <-
					difftime(
							t_periodefonctdispositif_per$per_date_fin,
							t_periodefonctdispositif_per$per_date_debut,
							units = "day"
					)
			sommes <-
					tapply(duree, t_periodefonctdispositif_per$per_tar_code, sum)
			perc <- round(100 * sommes / as.numeric(sum(duree)))
			sommes <- round(sommes, 2)
			funout(gettext("Duration in days (operation type):", domain = "R-stacomiR"))
			funout(paste(
							gettext(
									"Normal oper",
									"Operational stop",
									"Stop",
									"Dysfunct",
									"Unknown",
									gettext("Func.", "Stop", "Normal func", domain = "R-stacomiR")
							),
							" :",
							sommes,
							"(",
							perc,
							"%)",
							sep = ""
					))
			sommes <-
					tapply(duree,
							t_periodefonctdispositif_per$per_etat_fonctionnement,
							sum)
			perc <- round(100 * sommes / as.numeric(sum(duree)))
			sommes <- round(sommes, 2)
			funout(gettext("Duration in days (operation):", domain = "R-stacomiR"))
			funout(paste(rev(
									gettext("Func.", "Stop", domain = "R-stacomiR")
							),
							" :",
							sommes, "(", perc, "%)", sep = ""))
			return(invisible(NULL))
		}
)

#' Report on fishway operation
#'
#' Fishways (DF) are of various nature, from very simple eel ladders fed by water discharged from the river,
#' to more complex fishways with levels adjusted by the opening of various gates and regulators.
#' The objective of this class is to provide an assessment of the working status of a fishway throughout the year.
#' A number of fishes ascending a fishway has meaning only if we know that the fishway is operational, and that the counting
#' operated on the fishway has remained operational.
#' In the database the operation of the fishway (DF) and counting device (DC) is agregated in one table (t_periodefonctdispositif_per).
#' The column  per_etat_fonctionnement indicates whether the fishway is operational (with a boolean) and the column per_tar_code indicates
#' the status of either the fishway or DC. In the database four types of operation are set,  "1"=normal operation,
#' "2"=Device stopped in normal operation (ie lift ascending, high tide...),
#' "3"="Stopped for maintenance or other problem",
#' "4"="Works but not fully operational,i.e.flow problem, flood, clogged with debris...",
#' "5"="Not known")
#'
#' @include ref_df.R
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("report_df")}.
#' @slot data A data frame
#' @slot df An object of class \code{ref_df-class}
#' @slot horodatedebut An object of class \code{ref_horodate-class}
#' @slot horodatefin An object of class \code{ref_horodate-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_df-example.R
#' @aliases report_df
#' @export
setClass(
		Class = "report_df",
		representation = representation(
				data = "data.frame",
				df = "ref_df",
				horodatedebut = "ref_horodate",
				horodatefin = "ref_horodate"
		),
		prototype = prototype(
				data = data.frame(),
				df = new("ref_df"),
				horodatedebut = new("ref_horodate"),
				horodatefin = new("ref_horodate")
		)
)


#' connect method for report_df
#'
#' @param object An object of class \link{report_df-class}
#' loads the working periods and type of arrest or disfunction of the DF
#' @param silent Boolean, TRUE removes messages.
#' @return  An object of class \code{report_df} with slot data filled from the database
#' @aliases connect.report_df
#' @author cedric.briand
setMethod(
		"connect",
		signature = signature("report_df"),
		definition = function(object, silent = FALSE) {
			#  construit une requete DBwheredate
			req <- new("RequeteDBwheredate")
			req@select = paste(
					"SELECT",
					" per_dis_identifiant,",
					" per_date_debut,",
					" per_date_fin,",
					" per_commentaires,",
					" per_etat_fonctionnement,",
					" per_tar_code,",
					" tar_libelle AS libelle",
					" FROM  ",
					get_schema(),
					"t_periodefonctdispositif_per per",
					" INNER JOIN ref.tr_typearretdisp_tar tar ON tar.tar_code=per.per_tar_code",
					sep = ""
			)
			req@colonnedebut = "per_date_debut"
			req@colonnefin = "per_date_fin"
			req@order_by = "ORDER BY per_date_debut"
			req@datedebut <- object@horodatedebut@horodate
			req@datefin <- object@horodatefin@horodate
			req@and = paste("AND per_dis_identifiant in",
					vector_to_listsql(object@df@df_selected))
			#req@where=#defini dans la methode DBwheredate
			req <-
					stacomirtools::query(req) # appel de la methode connect de l'object DBWHEREDATE
			object@data <- req@query
			if (!silent)
				funout(gettext("Time steps of the fishway loaded\n", domain = "R-stacomiR"))
			return(object)
		}
)


#' charge method for report_df
#'
#'
#' used by the graphical interface to retrieve the objects of referential classes
#' assigned to envir_stacomi
#' @param object An object of class \link{report_df-class}
#' @param silent Keeps program silent
#' @return  An object of class \link{report_df-class}  with data set from values assigned in \code{envir_stacomi} environment
#' @aliases charge.report_df
#' @keywords internal
setMethod(
		"charge",
		signature = signature("report_df"),
		definition = function(object, silent = FALSE) {
			# object<-BfDF
			if (exists("ref_df", envir = envir_stacomi)) {
				object@df <- get("ref_df", envir = envir_stacomi)
			} else {
				funout(
						gettext(
								"You need to choose a crossing device, clic on validate\n",
								domain = "R-stacomiR"
						),
						arret = TRUE
				)
			}
			
			if (exists("report_df_date_debut", envir = envir_stacomi)) {
				object@horodatedebut@horodate <-
						get("report_df_date_debut", envir = envir_stacomi)
			} else {
				funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			
			if (exists("report_df_date_fin", envir = envir_stacomi)) {
				object@horodatefin@horodate <-
						get("report_df_date_fin", envir = envir_stacomi)
			} else {
				funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			assign("report_df", object, envir = envir_stacomi)
			return(object)
		}
)

#' command line interface for report_df class
#'
#' The choice_c method fills in the data slot for ref_df, and then
#' uses the choice_c methods of these object to "select" the data.
#' @param object An object of class \link{ref_df-class}
#' @param df The df to set
#' @param horodatedebut A POSIXt or Date or character to fix the date of beginning of the report
#' @param horodatefin A POSIXt or Date or character to fix the last date of the report
#' @param silent Should program be silent or display messages
#' @return An object of class \link{ref_df-class}  with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_df
setMethod(
		"choice_c",
		signature = signature("report_df"),
		definition = function(object,
				df,
				horodatedebut,
				horodatefin,
				silent = FALSE) {
			# report_df<-r_df;df=2;horodatedebut="2013-01-01";horodatefin="2013-12-31";silent=TRUE
			report_df <- object
			assign("report_df", report_df, envir = envir_stacomi)
			if (!silent)
				funout(
						gettext(
								"Loading of the list for fishways and choice of the time step\n",
								domain = "R-stacomiR"
						)
				)
			report_df@df <- charge(report_df@df)
			report_df@df <- choice_c(report_df@df, df)
			# assigns the parameter (horodatedebut) of the method to the object using choice_c method for ref_dc
			report_df@horodatedebut <- choice_c(
					object = report_df@horodatedebut,
					nomassign = "report_df_date_debut",
					funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatedebut,
					silent = silent
			)
			report_df@horodatefin <- choice_c(
					report_df@horodatefin,
					nomassign = "report_df_date_fin",
					funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatefin,
					silent = silent
			)
			assign("report_df", report_df, envir = envir_stacomi)
			return(report_df)
		}
)

#' Different plots for report_df
#'
#' \itemize{
#'      \item{plot.type=1}{A barplot of the operation time per month}
#' 		\item{plot.type=2}{Barchat giving the time per type of operation }
#' 		\item{plot.type=2}{Rectangle plots drawn along a line}
#'      \item{plot.type=4}{Plots per day drawn over the period to show the operation of a df, days in x, hours in y}
#' 	}
#'
#' @note The program cuts periods which overlap between two month. The splitting of different periods into month is
#' assigned to the \code{envir_stacomi} environment.
#' @param x An object of class \link{report_df-class}.
#' @param plot.type 1 to 4.
#' @param silent Stops displaying the messages.
#' @param main The title of the graph, if NULL a default title will be plotted with the number of the DF.
#' @param color_type_oper Named vector of color for the graph, must match type operation default to c(
#'								"Fonc normal" = "#1B9E77","Arr ponctuel" = "#E6AB02", "Arr maint" = "#9E0142",
#'								"Dysfonc" = "#E41A1C","Non connu" = "#999999").
#' @param color_etat Named vector state value (must match the names "TRUE", "FALSE").
#' @return Nothing but prints the different plots.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_df
#' @export
setMethod(
		"plot",
		signature(x = "report_df", y = "missing"),
		# attention laisser sur une ligne sinon plante au check
		definition = function(x,
				plot.type = 1,
				silent = FALSE,
				main = NULL,
				color_type_oper = 	c("Fonc normal" = "#1B9E77", 
				                     "Arr ponctuel" = "#E6AB02", 
				                     "Arr maint" = "#9E0142",
				                     "Dysfonc" = "#E41A1C",
				                     "Non connu" = "#999999"),
				color_etat = c("TRUE"="chartreuse3","FALSE"="orangered3")) {
			#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			#           PLOT OF TYPE BARCHART (plot.type=1 (true/false) or plot.type=2)
			#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			#report_df<-r_df; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="1"
			report_df <- x
			plot.type <- as.character(plot.type)# to pass also characters
			if (!plot.type %in% c("1", "2", "3", "4"))
				stop('plot.type must be 1,2,3 or 4')
			if (nrow(report_df@data) == 0)
				funout(gettext("No data for this fishway\n", domain = "R-stacomiR"),
						arret = TRUE)
			if (plot.type == "1" | plot.type == "2") {
				t_periodefonctdispositif_per = report_df@data # on recupere le data.frame
				tempsdebut <- t_periodefonctdispositif_per$per_date_debut
				tempsfin <- t_periodefonctdispositif_per$per_date_fin
				tempsdebut[tempsdebut < report_df@horodatedebut@horodate] <-
						report_df@horodatedebut@horodate
				tempsfin[tempsfin > report_df@horodatefin@horodate] <-
						report_df@horodatefin@horodate
				t_periodefonctdispositif_per = cbind(t_periodefonctdispositif_per, tempsdebut, tempsfin)
				seqmois = seq(
						from = tempsdebut[1],
						to = tempsfin[nrow(t_periodefonctdispositif_per)],
						by = "month",
						tz = "GMT"
				)
				seqmois = as.POSIXlt(round_date(seqmois, unit = "month"))
				# adding one month at the end to get a complete coverage of the final month
				seqmois <- c(seqmois,
						seqmois[length(seqmois)] %m+% months(1))
				
				#seqmois<-c(seqmois,seqmois[length(seqmois)]+months(1))
				t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per[1, ]
				############################
				#progress bar
				###########################
				progress_bar <- utils::txtProgressBar()
				z = 0 # compteur tableau t_periodefonctdispositif_per_mois
				for (j in 1:nrow(t_periodefonctdispositif_per)) {
					#cat( j
					setTxtProgressBar(progress_bar,  j / nrow(t_periodefonctdispositif_per))
					if (j > 1)
						t_periodefonctdispositif_per_mois = rbind(t_periodefonctdispositif_per_mois,
								t_periodefonctdispositif_per[j, ])
					lemoisnext = seqmois[seqmois > tempsdebut[j]][1] # le premier mois superieur a tempsdebut
					while (tempsfin[j] > lemoisnext) {
						# on est a cheval sur deux periodes
						
						#if (z>0) stop("erreur")
						z = z + 1
						t_periodefonctdispositif_per_mois = rbind(t_periodefonctdispositif_per_mois,
								t_periodefonctdispositif_per[j, ])
						t_periodefonctdispositif_per_mois[j + z, "tempsdebut"] = as.POSIXct(lemoisnext)
						t_periodefonctdispositif_per_mois[j + z - 1, "tempsfin"] = as.POSIXct(lemoisnext)
						lemoisnext = seqmois[match(as.character(lemoisnext), as.character(seqmois)) +
										1] # on decale de 1 mois avant de rerentrer dans la boucle
						#if (is.na(lemoisnext) ) break
					}
					#if (is.na(lemoisnext)) break
				}
				t_periodefonctdispositif_per_mois$sumduree <-
						as.numeric(
								difftime(
										t_periodefonctdispositif_per_mois$tempsfin,
										t_periodefonctdispositif_per_mois$tempsdebut,
										units = "hours"
								)
						)
				t_periodefonctdispositif_per_mois$mois1 = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
						"%b")
				t_periodefonctdispositif_per_mois$mois = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
						"%m")
				t_periodefonctdispositif_per_mois$annee = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
						"%Y")
				if (is.null(main))
					main <- gettextf("Fishway operation %s", report_df@df@df_selected)
				# graphic
				t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per_mois[order(t_periodefonctdispositif_per_mois$per_tar_code,
								decreasing = TRUE), ]
				
				g <- ggplot(t_periodefonctdispositif_per_mois,
								aes(x = mois, y = sumduree, fill = libelle)) +
						facet_grid(annee ~ .) +
						ylab(gettext("duration", domain = "R-stacomiR")) +
						xlab(gettext("month", domain = "R-stacomiR")) +
						ggtitle(main) +
						geom_bar(stat = 'identity') +
						scale_fill_manual(
								gettext("operation"),
								values = color_type_oper
						)
				
				t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per_mois[order(t_periodefonctdispositif_per_mois$per_etat_fonctionnement), ]
				t_periodefonctdispositif_per_mois$per_etat_fonctionnement = as.factor(t_periodefonctdispositif_per_mois$per_etat_fonctionnement)
				
				g1 <-
						ggplot(t_periodefonctdispositif_per_mois,
								aes(x = mois, y = sumduree)) + facet_grid(annee ~ .) +
						ylab(gettext("duration", domain = "R-stacomiR")) +
						xlab(gettext("month", domain = "R-stacomiR")) +
						ggtitle(main) +
						geom_bar(stat = 'identity', aes(fill = per_etat_fonctionnement)) +
						scale_fill_manual(gettext("operation", domain = "R-stacomiR"),
								values = color_etat)
				
				if (plot.type == "1")
					print(g1)
				if (plot.type == "2")
					print(g)
				assign("periodeDF",
						t_periodefonctdispositif_per_mois,
						envir_stacomi)
				if (!silent)
					funout(
							gettext(
									"Writing the table into envir_stacomi environment : write periodeDF=get('periodeDF',envir_stacomi)\n",
									domain = "R-stacomiR"
							)
					)
				# the progress bar has been assigned in envir_stacomi, we destroy it
				close(progress_bar)
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
				#           PLOT OF TYPE BOX (plot.type=3)
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			} else if (plot.type == "3") {
				#report_df<-r_df; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="3"
				if (!silent)
					funout(gettext("No data for this fishway\n"))
				t_periodefonctdispositif_per = report_df@data
				graphdate <- function(vectordate) {
					vectordate <- as.POSIXct(vectordate)
					attributes(vectordate) <- NULL
					unclass(vectordate)
					return(vectordate)
				}
				time.sequence = seq.POSIXt(
						from = report_df@horodatedebut@horodate,
						to = report_df@horodatefin@horodate,
						by = "day"
				)
				debut = graphdate(time.sequence[1])
				fin = graphdate(time.sequence[length(time.sequence)])

				# creation d'un graphique vide
				if (is.null(main))
					main <- ""
				plot(
						graphdate(time.sequence),
						seq(0, 1, length.out = length(time.sequence)),
						xlim = c(debut, fin),
						type = "n",
						xlab = "",
						xaxt = "n",
						yaxt = "n",
						ylab = gettext("Fishway", domain = "R-stacomiR"),
						main = main,
						#bty="n",
						cex = 0.8
				)
				r <- round(range(time.sequence), "day")
				graphics::axis(1,
						at = graphdate(seq(r[1], r[2], by = "weeks")),
						labels = strftime(as.POSIXlt(seq(r[1], r[2], by = "weeks")), format = "%d-%b"))
				if (dim(t_periodefonctdispositif_per)[1] == 0) {
					rect(
							xleft = debut,
							ybottom = 0.6,
							xright = fin,
							ytop = 0.9,
							col = "grey",
							border = NA,
							lwd = 1
					)
					rect(
							xleft = debut,
							ybottom = 0.1,
							xright = fin,
							ytop = 0.4,
							col = color_type_oper["Non connu"],
							border = NA,
							lwd = 1
					)
					legend(
							x = "bottom",
							legend = gettext("Func", "Stop", "Normal func", domain = "R-stacomiR"),
							pch = c(16, 16),
							col = c("grey", color_type_oper["Non connu"]),
							#horiz=TRUE,
							ncol = 5,
							bty = "n"
					)
				} else {
					if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement == 1) > 0) {
						rect(
								xleft = graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														1]),
								ybottom = 0.6,
								xright = graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														1]),
								ytop = 0.9,
								col = color_etat["TRUE"],
								border = NA,
								lwd = 1
						)
					}
					if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement == 0) >
							0)                           {
						rect(
								xleft = graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														0]),
								ybottom = 0.6,
								xright = graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement ==
														0]),
								ytop = 0.9,
								col = color_etat["FALSE"],
								border = NA,
								lwd = 1
						)
					}
					listeperiode <-
							fun_table_per_dis(
									typeperiode = t_periodefonctdispositif_per$per_tar_code,
									tempsdebut = t_periodefonctdispositif_per$per_date_debut,
									tempsfin = t_periodefonctdispositif_per$per_date_fin,
									libelle = t_periodefonctdispositif_per$libelle,
									color = 	 color_type_oper[t_periodefonctdispositif_per$libelle],
									date = FALSE
							)

					
					for (j in 1:length(listeperiode)) {

						rect(
								xleft = graphdate(listeperiode[[j]]$debut),
								ybottom = 0.1,
								xright = graphdate(listeperiode[[j]]$fin),
								ytop = 0.4,
								col = listeperiode[[j]]$color,
								border = NA,
								lwd = 1
						)
					}
					legend  (
							x = debut,
							y = 0.6,
							legend = gettext("Func.", "Stop", domain = "R-stacomiR"),
							pch = c(15, 15),
							col = color_etat,
							bty = "n",
							horiz = TRUE,
							text.width = (fin - debut) / 6 ,
							cex = 0.8
					)
					legend  (
							x = debut,
							y = 0.1,
							legend = names(color_type_oper),
							pch = c(15, 15),
							col = color_type_oper,
							bty = "n",
							horiz = TRUE,
							text.width = (fin - debut) / 8,
							cex = 0.7
					)
					text(
							x = debut,
							y = 0.95,
							label = gettext("Fishway operation", domain = "R-stacomiR"),
							font = 4,
							pos = 4
					)
					text(
							x = debut,
							y = 0.45,
							label = gettext("Shutdowns types for this fishway", domain = "R-stacomiR"),
							font = 4,
							pos = 4
					)
				}
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
				#           PLOT OF TYPE BOX (plot.type=4)
				#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
			} else if (plot.type == "4") {
				if (is.null(main))
					main <- gettextf("Fishway operation %s", report_df@df@df_selected)
				
				#report_df<-r_df; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="4"
				t_periodefonctdispositif_per = report_df@data
				tpp <-
						split_per_day(
								t_periodefonctdispositif_per,
								horodatedebut = "per_date_debut",
								horodatefin = "per_date_fin"
						)
				
				g <- ggplot(tpp) +
						geom_rect(
								aes(
										xmin = xmin,
										xmax = xmax,
										ymin = Hdeb,
										ymax = Hfin,
										col = libelle,
										fill = libelle
								),
								alpha = 0.5
						) +
						scale_fill_manual(
								"type",
								values = color_type_oper,
								labels = gettext(
										"Normal oper",
										"Operational stop",
										"Stop",
										"Dysfunct",
										"Unknown",
										domain = "R-stacomiR"
								)
						) +
						scale_colour_manual(
								"type",
								values = color_type_oper,
								labels = gettext(
										"Normal oper",
										"Operational stop",
										"Stop",
										"Dysfunct",
										"Unknown",
										domain = "R-stacomiR"
								)
						) +
						ylab("Heure") + theme(
								plot.background = element_rect(fill = "black"),
								panel.background = element_rect(fill = "black"),
								legend.background = element_rect(fill = "black"),
								panel.grid.major = element_blank(),
								panel.grid.minor = element_blank(),
								text = element_text(colour = "white"),
								line = element_line(colour = "grey50"),
								legend.key = element_rect(fill = "black", colour = "black"),
								axis.text = element_text(colour = "white")
						)
				
				print(g)
				
			}
			return(invisible(NULL))
		}
)


#' Internal use, function used in the graphical interface to create a barchart for report_df class
#'
#' @note The program cuts periods which overlap between two month
#' @param ... additional parameters
#' @return Nothing, called for its side effect of plotting data
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
funbarchartDF = function(...) {
	report_df <- get("report_df", envir = envir_stacomi)
	report_df <- charge(report_df)
	report_df <- connect(report_df)
	if (nrow(report_df@data) == 0) {
		funout(gettext("No data for this fishway\n", domain = "R-stacomiR"),
				arret = TRUE)
	}
	plot(report_df, plot.type = 1, silent = FALSE)
	return(invisible(NULL))
}


#' Internal use barchart for report_df class from the graphical interface
#'
#' @note The program cuts periods which overlap between two month
#' @param ... additional parameters
#' @return Nothing, called for its side effect of plotting data
#' @keywords internal
funbarchart1DF = function(...) {
	report_df <- get("report_df", envir = envir_stacomi)
	report_df <- charge(report_df)
	report_df <- connect(report_df)
	if (nrow(report_df@data) == 0) {
		funout(gettext("No data for this fishway\n", domain = "R-stacomiR"),
				arret = TRUE)
	}
	plot(report_df, plot.type = 2, silent = FALSE)
	return(invisible(NULL))
}

#' Internal use, rectangles to describe the DF work for report_df class,
#' 
#' @param ... additional parameters
#' @return Nothing, called for its side effect of plotting data
#' @keywords internal
funboxDF = function(...) {
	report_df <- get("report_df", envir = envir_stacomi)
	report_df <- charge(report_df)
	report_df <- connect(report_df)
	
	if (nrow(report_df@data) == 0) {
		funout(gettext("No data for this fishway\n", domain = "R-stacomiR"),
				arret = TRUE)
	}
	plot(report_df, plot.type = 3, silent = FALSE)
	return(invisible(NULL))
	
}

#' Function to plot calendar like graph, internal use
#' @param ... additional parameters
#' @return Nothing, called for its side effect of plotting data
#' @keywords internal
funchartDF = function(...) {
	report_df <- get("report_df", envir = envir_stacomi)
	report_df <- charge(report_df)
	report_df <- connect(report_df)
	
	if (nrow(report_df@data) == 0) {
		funout(gettext("No data for this fishway\n", domain = "R-stacomiR"),
				arret = TRUE)
	}
	plot(report_df, plot.type = 4, silent = FALSE)
	return(invisible(NULL))
	
}

#' Table output for report_df class
#' @param ... additional parameters
#' @return Nothing, called for its side effect of running summary
#' @keywords internal
funtableDF = function(...) {
	report_df <- get("report_df", envir = envir_stacomi)
	report_df <- charge(report_df)
	report_df <- connect(report_df)
	
	if (nrow(report_df@data) == 0) {
		funout(gettext("No data for this fishway\n", domain = "R-stacomiR"),
				arret = TRUE)
	}
	summary(report_df)
	return(invisible(NULL))
}


#' Method to print the command line of the object
#' @param x An object of class report_df
#' @param ... Additional parameters passed to print
#' @return Nothing, called for its side effect of printing data
#' @author cedric.briand
#' @aliases print.report_df
#' @export
setMethod(
		"print",
		signature = signature("report_df"),
		definition = function(x, ...) {
			sortie1 <- "report_df=new('report_df')\n"
			sortie2 <- stringr::str_c(
					"report_df=choice_c(report_df,",
					"df=",
					x@df@df_selected,
					",",
					"horodatedebut=",
					shQuote(as.character(x@horodatedebut@horodate)),
					",",
					"horodatefin=",
					shQuote(as.character(x@horodatefin@horodate)),
					")"
			)
			# removing backslashes
			funout(stringr::str_c(sortie1, sortie2), ...)
			return(invisible(NULL))
		}
)


#' summary for report_df, write csv and html output, and prints summary statistics
#' @param object An object of class \code{\link{report_df-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters (not used there)
#' @return Nothing, called for its side effect of writing html, csv files and printing summary
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_df
#' @export
setMethod(
		"summary",
		signature = signature(object = "report_df"),
		definition = function(object, silent = FALSE, ...) {
			#report_df<-r_df;
			report_df <- object
			t_periodefonctdispositif_per <- report_df@data # on recupere le data.frame
			t_periodefonctdispositif_per$per_date_debut <- as.character(t_periodefonctdispositif_per$per_date_debut)
			t_periodefonctdispositif_per$per_date_fin <- as.character(t_periodefonctdispositif_per$per_date_fin)
			annee <- paste(unique(strftime(
									as.POSIXlt(t_periodefonctdispositif_per$per_date_debut),
									"%Y"
							)), collapse = "+")
			path1 <- file.path(
					path.expand(get("datawd", envir = envir_stacomi)),
					paste(
							"t_periodefonctdispositif_per_DF_",
							report_df@df@df_selected,
							"_",
							annee,
							".csv",
							sep = ""
					),
					fsep = "\\"
			)
			res <- tryCatch(
					write.table(
							t_periodefonctdispositif_per,
							file = path1,
							row.names = FALSE,
							col.names = TRUE,
							sep = ";"
					), error = function(e) e,
					finally =
							if (!silent)	funout(gettextf("Writing of %s \n", path1, domain = "R-stacomiR"))
			)
			if (inherits(res, "simpleError")) {
				warnings("The table could not be reported, please modify datawd with options(stacomiR.path='path/to/directory'")
			} else {
				
				path1html <- file.path(
						path.expand(get("datawd", envir = envir_stacomi)),
						paste(
								"t_periodefonctdispositif_per_DF_",
								report_df@df@df_selected,
								"_",
								annee,
								".html",
								sep = ""
						),
						fsep = "\\"
				)
				if (!silent)
					funout(gettextf(
									"Writing of %s this might take a while, please be patient ...\n",
									path1html
							))
				funhtml(
						t_periodefonctdispositif_per,
						caption = paste(
								"t_periodefonctdispositif_per_DF_",
								report_df@df@df_selected,
								"_",
								annee,
								sep = ""
						),
						top = TRUE,
						outfile = path1html,
						clipboard = FALSE,
						append = FALSE,
						digits = 2
				)
			}
			t_periodefonctdispositif_per <- report_df@data
			print(gettextf("summary statistics for DF=%s", report_df@df@df_selected))
			print(gettextf("df_code=%s", report_df@df@data[report_df@df@data$df ==
											report_df@df@df_selected, "df_code"]))
			duree <-
					difftime(
							t_periodefonctdispositif_per$per_date_fin,
							t_periodefonctdispositif_per$per_date_debut,
							units = "day"
					)
			sommes <-
					tapply(duree, t_periodefonctdispositif_per$per_tar_code, sum)
			perc <- round(100 * sommes / as.numeric(sum(duree)))
			sommes <- round(sommes, 2)
			funout(gettext("Duration in days (operation type):", domain = "R-stacomiR"))
			funout(paste(
							gettext(
									"Normal oper",
									"Operational stop",
									"Stop",
									"Dysfunct",
									"Unknown",
									domain = "R-stacomiR"
							),
							" :",
							sommes,
							"(",
							perc,
							"%)",
							sep = ""
					))
			sommes <-
					tapply(duree,
							t_periodefonctdispositif_per$per_etat_fonctionnement,
							sum)
			perc <- round(100 * sommes / as.numeric(sum(duree)))
			sommes <- round(sommes, 2)
			funout(gettext("Duration in days (operation):", domain = "R-stacomiR"))
			funout(paste(rev(
									gettext("Func.", "Stop", domain = "R-stacomiR")
							),
							" :",
							sommes, "(", perc, "%)", sep = ""))
			return(invisible(NULL))	
		}
)

#' Migration report along with quantitative and
#' qualitative characteristics
#' 
#' Migration along with qualitative or quantitative characteristics or both
#' (e.g.) weight of eels according to the size class per period of time, weight
#' of fish according to gender, number of fish per age class. This class does not split migration evenly over 
#' time period. So, unlike calculations made in class report_mig and report_mig_mult
#' the whole time span of the migration operation is not considered, only  the date of beginning of 
#' the operation is used to perform calculations. 
#' 
#' @include ref_parquan.R
#' @include ref_parqual.R
#' @include ref_choice.R
#' @include report_sample_char.R
#' @note The main difference between this class and \link{report_sample_char-class} is that this class allows to
#' select (or not) the samples, and that it handles quantitative and qualitative parameters separately.
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('report_mig_char', ...)}.  they are loaded by the interface
#' using interface_report_mig_char function.
#' @slot calcdata A 'list' of calculated data, filled in by the calcule method
#' @slot data A \code{data.frame} inherited from \link{report_sample_char-class}
#' @slot dc An object of class \link{ref_dc-class} inherited from \link{report_sample_char-class}
#' @slot taxa An object of class \link{ref_taxa-class} inherited from \link{report_sample_char-class}
#' @slot stage An object of class \link{ref_stage-class} inherited from \link{report_sample_char-class}
#' @slot horodatedebut An object of class \link{ref_horodate-class} inherited from \link{report_sample_char-class}
#' @slot horodatefin An object of class \link{ref_horodate-class} inherited from \link{report_sample_char-class}
#' @slot par An object of class \link{ref_par-class} inherited from \link{report_sample_char-class}
#' @slot echantillon An object of class \link{ref_choice-class}, vector of choice
#' @slot parquan An object of class \link{ref_parquan-class}, quantitative parameter 
#' @slot parqual An object of class \link{ref_parqual-class}, qualitative parameter
#' @family report Objects
#' @aliases report_mig_char
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @concept report Object 
#' @example inst/examples/report_mig_char-example.R
#' @keywords classes
#' @export
setClass(Class = "report_mig_char", 
		representation = representation(
				echantillon = "ref_choice",
				calcdata = "list", 
				parqual = "ref_parqual", 
				parquan = "ref_parquan"), 
		prototype = list(
				data = list(),
				echantillon = new("ref_choice", listechoice = c("with", "without"),
						selectedvalue = "with"), 
				calcdata = list(),
				parqual = new("ref_parqual"),
				parquan = new("ref_parquan")),
		contains = "report_sample_char")


setValidity("report_mig_char", function(object) {
			retValue = ""
			rep4 <- length(object@taxa) == 1
			if (!rep4)
				retValue = gettext("This report should be for just one taxa")
			rep5 <- length(object@parqual) == 1 | length(object@parquan) == 1
			if (!rep5)
				retValue = gettext("length(object@parqual)==1|length(object@parquan)==1 not TRUE")
			return(ifelse(rep4 & rep5, TRUE, retValue))
		})


#' command line interface for report_mig_char class
#' @param object An object of class \link{report_mig_char-class}
#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
#' @param taxa '2220=Salmo salar', can be a vector with several values
#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
#' @param stage The stages selected, can be a vector with several values
#' @param parquan Quantitative parameter
#' @param parqual Qualitative parameter
#' @param horodatedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param horodatefin The finishing date of the report, for this class this will be used to calculate the number of daily steps
#' @param echantillon 'with' can be 'without', checking without modifies the query
#' in the connect method so that subsamples are not allowed 
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return An object of class \link{report_sea_age-class}
#' The choice_c method fills in the data slot for classes \link{ref_dc-class}, \link{ref_taxa-class}, \link{ref_stage-class}, \link{ref_par-class} and two slots of \link{ref_horodate-class} and then 
#' uses the choice_c methods of these object to select the data.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_mig_char
setMethod("choice_c", signature = signature("report_mig_char"), definition = function(object,
				dc, taxa, stage, parquan = NULL, parqual = NULL, horodatedebut, horodatefin,
				echantillon = c("with","without"), silent = FALSE) {
			echantillon <-  match.arg(echantillon)
			# code for debug using example
			# horodatedebut='2012-01-01';horodatefin='2013-12-31';dc=c(107,108,101);taxa=2220;stage=c('5','11','BEC','BER','IND');parquan=c('1786','1785','C001','A124');parqual='COHO';silent=FALSE
			r_mig_char <- object
			r_mig_char@dc = charge(r_mig_char@dc)
			r_mig_char@dc <- choice_c(object = r_mig_char@dc, dc)
			r_mig_char@taxa <- charge_with_filter(object = r_mig_char@taxa, r_mig_char@dc@dc_selected)
			r_mig_char@taxa <- choice_c(r_mig_char@taxa, taxa)
			r_mig_char@stage <- charge_with_filter(object = r_mig_char@stage, r_mig_char@dc@dc_selected,
					r_mig_char@taxa@taxa_selected)
			r_mig_char@stage <- choice_c(r_mig_char@stage, stage, silent = silent)
			r_mig_char@parquan <- charge_with_filter(object = r_mig_char@parquan, dc_selected = r_mig_char@dc@dc_selected,
					taxa_selected = r_mig_char@taxa@taxa_selected, stage_selected = r_mig_char@stage@stage_selected)
			if (!is.null(parquan))
				r_mig_char@parquan <- choice_c(r_mig_char@parquan, parquan, silent = silent)
			# the method choice_c is written in ref_par, and each time
			assign("ref_parquan", r_mig_char@parquan, envir_stacomi)
			r_mig_char@parqual <- charge_with_filter(object = r_mig_char@parqual, r_mig_char@dc@dc_selected,
					r_mig_char@taxa@taxa_selected, r_mig_char@stage@stage_selected)
			if (!is.null(parqual)) {
				r_mig_char@parqual <- choice_c(r_mig_char@parqual, parqual, silent = silent)
				r_mig_char@parqual <- charge_complement(r_mig_char@parqual)
			}
			assign("ref_parqual", r_mig_char@parqual, envir_stacomi)
			r_mig_char@horodatedebut <- choice_c(object = r_mig_char@horodatedebut, nomassign = "bmC_date_debut",
					funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatedebut, silent = silent)
			r_mig_char@horodatefin <- choice_c(r_mig_char@horodatefin, nomassign = "bmC_date_fin",
					funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatefin, silent = silent)
			r_mig_char@echantillon <- charge(r_mig_char@echantillon, vecteur = c("with","without"), label = "essai",
					selected = as.integer(1))
			r_mig_char@echantillon <- choice_c(r_mig_char@echantillon, selectedvalue = echantillon)
			validObject(r_mig_char)
			return(r_mig_char)
		})

#' charge method for report_mig_char
#' 
#' Used by the graphical interface to collect and test objects in the environment envir_stacomi, 
#' fills also the data slot by the connect method. It is not necessary to run the charge method
#' if the choice is made from the command line using the choice_c method.
#' @param object An object of class \link{report_mig_char-class}
#' @param silent Default FALSE, if TRUE the program should not display messages
#' @return \link{report_mig_char-class}  with slot filled from values assigned in \code{envir_stacomi} environment
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases charge.report_mig_char
#' @keywords internal
setMethod("charge", signature = signature("report_mig_char"), definition = function(object,
				silent = FALSE) {
			r_mig_char <- object
			if (exists("bmC_date_debut", envir_stacomi)) {
				r_mig_char@horodatedebut@horodate <- get("bmC_date_debut", envir_stacomi)
			} else {
				funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			if (exists("bmC_date_fin", envir_stacomi)) {
				r_mig_char@horodatefin@horodate <- get("bmC_date_fin", envir_stacomi)
			} else {
				funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			
			if (exists("ref_dc", envir_stacomi)) {
				r_mig_char@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)) {
				r_mig_char@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)) {
				r_mig_char@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("refchoice", envir_stacomi)) {
				r_mig_char@echantillon <- get("refchoice", envir_stacomi)
			} else {
				r_mig_char@echantillon@listechoice <- gettext("with", domain = "R-stacomiR")
				r_mig_char@echantillon@selected <- as.integer(1)
			}
			
			if (!(exists("ref_parquan", envir_stacomi) | exists("ref_parqual", envir_stacomi))) {
				funout(gettext("You need to choose at least one parameter qualitative or quantitative\n",
								domain = "R-stacomiR"), arret = TRUE)
			}
			
			if (exists("ref_parquan", envir_stacomi)) {
				r_mig_char@parquan <- get("ref_parquan", envir_stacomi)
			}
			if (exists("ref_parqual", envir_stacomi)) {
				r_mig_char@parqual <- get("ref_parqual", envir_stacomi)
			}
			
			stopifnot(validObject(r_mig_char, test = TRUE))
			return(r_mig_char)
		})

#' connect method for report_mig_char
#' 
#' 
#' uses the report_mig_mult method
#' @param object An object of class \link{report_mig_char-class}
#' @param silent Boolean default FALSE, if TRUE information messages not displayed
#' @return An object of class \link{report_mig_char-class}  with list in \code{@data$parquan} and \code{@data$parqual} filled in from the database
#' @aliases connect.report_mig_char
setMethod("connect", signature = signature("report_mig_char"), definition = function(object,
				silent = FALSE) {
			r_mig_char <- object
			if (r_mig_char@echantillon@selectedvalue == "without") {
				echantillons = " AND lot_pere IS NULL"
			} else {
				echantillons = ""
			}
			# data can be selected but not in the database or the inverse
			parquan <- intersect(r_mig_char@parquan@par_selected, r_mig_char@parquan@data$par_code)
			parqual <- intersect(r_mig_char@parqual@par_selected, r_mig_char@parqual@data$par_code)
			if (length(parquan) == 0 & length(parqual) == 0) {
				stop("You need to choose at least one quantitative or qualitative attribute")
			} else {
				if (length(parqual) != 0)
				{
					# caracteristique qualitative
					req = new("RequeteDB")
					# this query will get characteristics from lot_pere when null
					req@sql = paste("SELECT ", " ope_date_debut,", " ope_date_fin,",
							" lot_methode_obtention,", " lot_identifiant ,", " lot_effectif,",
							" car_val_identifiant,", " ope_dic_identifiant,", " lot_tax_code,",
							" lot_std_code,", " car_par_code", " FROM ", get_schema(), "vue_ope_lot_ech_parqual", " WHERE ope_dic_identifiant in ",
							vector_to_listsql(r_mig_char@dc@dc_selected), echantillons,
							" AND lot_tax_code in ", vector_to_listsql(r_mig_char@taxa@taxa_selected),
							" AND lot_std_code in ", vector_to_listsql(r_mig_char@stage@stage_selected),
							" AND car_par_code in ", vector_to_listsql(parqual), " AND (ope_date_debut, ope_date_fin) OVERLAPS (TIMESTAMP '",
							r_mig_char@horodatedebut@horodate, "', TIMESTAMP '", r_mig_char@horodatefin@horodate,
							"')", sep = "")
					r_mig_char@data[["parqual"]] <- query(req)@query
				}  # end if (parqual)
				if (length(parquan) != 0)
				{
					# Caracteristique quantitative
					req = new("RequeteDB")
					# we round the date to be consistent with daily values from the
					req@sql = paste("SELECT ", " ope_date_debut,", " ope_date_fin,",
							" lot_methode_obtention,", " lot_identifiant ,", " lot_effectif,",
							" car_valeur_quantitatif,", " ope_dic_identifiant,", " lot_tax_code,",
							" lot_std_code,", " car_par_code", " FROM ", get_schema(),
							"vue_ope_lot_ech_parquan", " WHERE ope_dic_identifiant in ",
							vector_to_listsql(r_mig_char@dc@dc_selected), echantillons,
							" AND lot_tax_code in ", vector_to_listsql(r_mig_char@taxa@taxa_selected),
							" AND lot_std_code in ", vector_to_listsql(r_mig_char@stage@stage_selected),
							" AND car_par_code in ", vector_to_listsql(parquan), " AND (ope_date_debut, ope_date_fin) OVERLAPS (TIMESTAMP '",
							r_mig_char@horodatedebut@horodate, "', TIMESTAMP '", r_mig_char@horodatefin@horodate,
							"')", sep = "")
					
					r_mig_char@data[["parquan"]] <- query(req)@query
				}  # end if (parquan)
			}  # end else  
			return(r_mig_char)
		})


#' Turns a continuous parameter into discrete values 
#' 
#' The parm name becomes "parm_discrete". New values are created in the `data[["parqual"]]` slot 
#' of the report and the parqual slot is updated
#' 
#' @param object An object of class \link{ref_parquan-class}
#' @param par The code of a quantitative parameter
#' @param silent Default FALSE, if TRUE the program should not display messages
#' @param ... Additional parms to the cut method \link[base]{cut}   
#' @return An object of class \link{ref_parquan-class} with lines removed from \code{r@data[["parquan"]]}
#' and added (after transformation to qualitative values) in \code{r@data[["parqal"]]}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod("setasqualitative", signature = signature("report_mig_char"), definition = function(object,
				par, silent = FALSE, ...) {
			r_mig_char <- object
			# par <-'A124' ========= initial checks ================
			if (!inherits(par , "character"))
				stop("par should be a character")
			if (nrow(r_mig_char@data[["parquan"]]) == 0)
				funout(gettext("No data for quantitative parameter, perhaps you forgot to run the calcule method"))
			if (!par %in% r_mig_char@parquan@par_selected)
				funout(gettextf("The parameter %s is not in the selected parameters", par),
						arret = TRUE)
			if (!par %in% r_mig_char@parquan@data$par_code)
				funout(gettextf("No data for this parameter : %s, nothing to do", par), arret = TRUE)

			# r_mig_char@data[["parqual"]] in report_mig_char -----------------------------	
			
			newtabqual <- r_mig_char@data[["parquan"]]
			lignes_du_par <- newtabqual$car_par_code == par
			newtabqual <- newtabqual[lignes_du_par, ]
			nbnaquan <- sum(is.na(newtabqual$car_valeur_quantitatif))
			newtabqual$car_valeur_quantitatif <- cut(newtabqual$car_valeur_quantitatif, ...)
			nbnaqual <- sum(is.na(newtabqual$car_valeur_quantitatif))

			if (all(is.na(newtabqual$car_valeur_quantitatif))) stop("Only NA produced, please check the bounds")
			if (nbnaqual > nbnaquan) warning(sprintf("You are producing %s NA values, maybe change your limits",nbnaqual - nbnaquan))
			# newtabqual$car_valeur_quantitatif<-cut(newtabqual$car_valeur_quantitatif,breaks=c(0,1.5,2.5,10),label=c('1','2','3'))
			newtabqual <- chnames(newtabqual, "car_valeur_quantitatif", "car_val_identifiant")
			newtabqual$car_par_code <- paste0(newtabqual$car_par_code,"_discrete")
			new_car_code <- newtabqual$car_par_code[1] # e.g "A124_qualitatif"
			new_car_nom <- paste0(r_mig_char@parquan@data[r_mig_char@parquan@data$par_code==par,"par_nom"], " (qual)")

			tabqual <- r_mig_char@data[["parqual"]]
			# remove first lines already processed earlier in valqual with the same parm
			if (!is.null(tabqual)){
				tabqual <- tabqual[!tabqual$car_par_code %in% new_car_code,]			
			}
			r_mig_char@data[["parqual"]] <- rbind(tabqual, newtabqual)
			# Adding the par to parqual
			
			# valqual slot in parqual -----------------------------			
			
			tabvalqual <- r_mig_char@parqual@valqual
			if (!is.null(tabvalqual)){
				tabvalqual <- tabvalqual[!tabvalqual$val_qual_code %in% new_car_code,]
			}
			tabvalqual <- rbind(
					tabvalqual,
					data.frame(val_identifiant = levels(newtabqual$car_val_identifiant),
							val_qal_code = new_car_code,
							val_rang = 1:length(levels(newtabqual$car_val_identifiant)),
							val_libelle = levels(newtabqual$car_val_identifiant))
			)
			r_mig_char@parqual@valqual <- tabvalqual
			
			# data slot in parqual -----------------------------

			tabdata <- r_mig_char@parqual@data 
			if (!is.null(tabdata)){
				tabdata <- tabdata[!tabdata$par_code %in% new_car_code,]
			}
			tabdata <- rbind(tabdata, 
					c("par_code"=new_car_code, "par_nom"=new_car_nom,"par_unite"=NA, "par_nature"=NA,"par_definition"=NA,"qual_valeurs_possibles"=NA)
			)
			colnames(tabdata) <- c("par_code", "par_nom", "par_unite", "par_nature", "par_definition", "qal_valeurs_possibles")
			r_mig_char@parqual@data <-tabdata
			
			# selected parm in parqual -----------------------------

			r_mig_char@parqual@par_selected <- unique(c(r_mig_char@parqual@par_selected, new_car_code))
			
			if (!silent)
				funout(gettextf("%s lines have been converted from quantitative to qualitative parameters",
								nrow(newtabqual)))
			return(r_mig_char)
		})


# TODO create a dataframe with only one line per fish for all parameters
#' Computes data to a standard format for the summary and plot methods.
#' 
#' Merges the content of the list elements 'parqual' and 'parquan' in the data slot, and creates
#' a single dataframe with one line per qualitative and quantitative pair. This methods allow to 
#' cross one quantity (e.g. length) with a qualitative parameter (e.g. sex).
#' 
#' @param object An object of class \link{report_mig_char-class}
#' @param silent Boolean default FALSE, if TRUE information messages not displayed
#' @return An object of class \link{report_mig_char-class} with slot \code{@calcdata} filled
#' @aliases calcule.report_mig_char
setMethod("calcule", signature = signature("report_mig_char"), definition = function(object,
				silent = FALSE) {
			r_mig_char <- object
			qual <- r_mig_char@data[["parqual"]]
			quan <- r_mig_char@data[["parquan"]]
			if (is.null(qual) & is.null(quan))
				stop("cannot perform calcule method, no data in either qualitative or quantitative parameters")
			if (!is.null(qual))
				qual <- chnames(qual, "car_par_code", "car_par_code_qual")
			if (!is.null(quan))
				quan <- chnames(quan, "car_par_code", "car_par_code_quan")
			if (is.null(qual)) {
				quaa <- quan
				quaa$car_par_code_qual = NA
			} else if (is.null(quan)) {
				quaa <- qual
				quaa$car_par_code_quan = NA
			} else {
				quaa <- merge(qual, quan, by = c("ope_dic_identifiant", "lot_identifiant",
								"ope_date_debut", "ope_date_fin", "lot_methode_obtention", "lot_effectif",
								"lot_tax_code", "lot_std_code"), all.x = TRUE, all.y = TRUE)
			}
			quaa = fun_date_extraction(data = quaa, nom_coldt = "ope_date_debut")
			quaa <- quaa[order(quaa$ope_dic_identifiant, quaa$lot_tax_code, quaa$lot_std_code,
							quaa$ope_date_debut), ]
			r_mig_char@calcdata <- quaa
			if (!silent)
				funout(gettext("The calculated data are in slot calcdata"))
			assign("r_mig_char", r_mig_char, envir_stacomi)
			return(r_mig_char)
		})


#' plot method for report_mig_char
#' 
#' 
#' @param x An object of class report_mig_char
#' @param plot.type One of 'qual', 'quant' 'crossed' default to qual
#' @param color_parm A named vector for the colors of either parameters (if plot.type=quant) or levels for
#' parameters (if plot.type=qual).
#' @param silent Boolean default FALSE, if TRUE information messages not displayed
#' @param ... Additional parameters
#' @return Nothing, called for its side effect of plotting data
#' @aliases plot.report_mig_char
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
setMethod("plot", signature = signature(x = "report_mig_char", y = "missing"), 
		definition = function(x,
				color_parm = NULL, plot.type = "qual", silent = FALSE, ...) {
			r_mig_char <- x
			if (nrow(r_mig_char@calcdata) == 0)
				stop("no data in calcdata, have you forgotten to run calculations ?")
			# transformation du tableau de donnees color_parm<-c('age 1'='red','age
			# 2'='blue','age 3'='green') color_parm<-c('C001'='red')
			if (plot.type == "qual")
			{
				parlevels <- r_mig_char@parqual@valqual$val_identifiant
				if (nrow(r_mig_char@parqual@valqual)==0) stop("No data loaded in qualitative parameters")
				cs <- colortable(color = color_parm, vec = parlevels, palette = "Dark2")
				cs <- stacomirtools::chnames(cs, "name", "car_val_identifiant")
				calcdata <- r_mig_char@calcdata
				calcdata <- merge(calcdata, cs)
				g <- ggplot(calcdata) + geom_bar(aes(x = mois, y = lot_effectif, fill = color),
								stat = "identity") + xlab(gettext("Month")) + ylab(gettext("Number")) +
						scale_fill_identity(name = gettext("Classes"), labels = cs[, "car_val_identifiant"],
								breaks = cs[, "color"], guide = "legend") + theme_bw()
				
				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"))
				print(g)
			}  #end plot.type = 'qual'
			if (plot.type == "quant")
			{
				calcdata <- r_mig_char@calcdata
				calcdata$car_par_code_quan[is.na(calcdata$car_par_code_quan)] <- "NA"
				the_parms <- unique(calcdata$car_par_code_quan)
				cs <- colortable(color = color_parm, vec = the_parms, palette = "Dark2")
				cs <- stacomirtools::chnames(cs, "name", "car_par_code_quan")
				calcdata <- merge(calcdata, cs)
				g <- ggplot(calcdata) + geom_point(aes(x = ope_date_debut, y = car_valeur_quantitatif,
										col = color), stat = "identity") + xlab(gettext("Month")) + ylab(gettext("Quantitative parameter")) +
						scale_colour_identity(name = gettext("Param"), labels = cs[, "car_par_code_quan"],
								breaks = cs[, "color"], guide = "legend") + theme_bw()
				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"))
				print(g)
			}  #end plot.type='quant'
			if (plot.type == "crossed")
			{
				parlevels <- r_mig_char@parqual@valqual$val_identifiant
				
				cs <- colortable(color = color_parm, vec = parlevels, palette = "Dark2")
				cs <- stacomirtools::chnames(cs, "name", "car_val_identifiant")
				calcdata <- r_mig_char@calcdata
				#calcdata$car_val_identifiant
				calcdata <- merge(calcdata, cs)
				if (length(unique(calcdata$car_par_code_quan))==1){
					label <- paste(
							r_mig_char@parquan@data[r_mig_char@parquan@par_selected ==r_mig_char@parquan@data$par_code,"par_nom"],
							" (",
							r_mig_char@parquan@data[r_mig_char@parquan@par_selected ==r_mig_char@parquan@data$par_code,"par_unite"],
							")", sep="")
				g <- ggplot(calcdata) + geom_point(aes(x = ope_date_debut, y = car_valeur_quantitatif,
										col = color), stat = "identity") + xlab(gettext("Month")) + ylab(label) +
						scale_colour_identity(name = gettext("Param"), labels = cs[, "car_val_identifiant"],
								breaks = cs[, "color"], guide = "legend") + theme_bw()
			} else {
				g <- ggplot(calcdata) + geom_point(aes(x = ope_date_debut, y = car_valeur_quantitatif,
										col = color), stat = "identity") + xlab(gettext("Month")) + ylab(gettext("Quantitative parameter")) +
						scale_colour_identity(name = gettext("Param"), labels = cs[, "car_val_identifiant"],
								breaks = cs[, "color"], guide = "legend") + 
						facet_wrap(~car_par_code_quan, scales="free_y") +					
						theme_bw() 
			}
				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"))
				print(g)
			}  #end plot.type='xyplot'
			return(invisible(NULL))
		})


#' summary for report_mig_char 
#' @param object An object of class \code{\link{report_mig_char-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters
#' @return A table with the summary
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_mig_char
#' @export
setMethod("summary", signature = signature(object = "report_mig_char"), definition = function(object,
				silent = FALSE, ...) {
			r_mig_char <- object
			bm <- r_mig_char@calcdata
			if (nrow(bm) == 0)
				stop("No data in slot calcdata, did you forget to run the calcule method ?")
			if (length(unique(bm$annee)) == 1) {
				table = round(tapply(bm$lot_effectif, list(bm$mois, bm$car_val_identifiant),
								sum), 1)
				table <- rbind(table, colSums(table, na.rm = TRUE))
				rownames(table)[nrow(table)] <- gettext("Sum")
				table <- as.data.frame(table)
			} else {
				table = round(tapply(bm$lot_effectif, list(bm$annee, bm$mois, bm$car_val_identifiant),
								sum), 1)
				ftable2data.frame <- function(x, ...) {
					y <- format(x, quote = FALSE)
					z <- data.frame(y[-1, ], stringsAsFactors = FALSE)
					names(z) <- y[1, ]
					z
				}
				table <- ftable2data.frame(ftable(table))
			}
			return(table)
		})


#' xtable function for \link{report_mig_char-class}
#' create an xtable objet to be later used by the print.xtable method.
#' @param x, an object of class 'report_mig_char'
#' @param caption, see xtable
#' @param label, see xtable
#' @param align, see xtable, overidden if NULL
#' @param digits, see xtable
#' @param display see xtable
#' @param auto see xtable
#' @param ... Additional parameters
#' @return A xtable
#' @aliases xtable.report_mig_char
#' @export
setMethod("xtable", signature = signature("report_mig_char"), definition = function(x,
				caption = NULL, label = NULL, align = NULL, ...) {
			r_mig_char <- x
			dat = r_mig_char@data
			dc = stringr::str_c(r_mig_char@dc@dc_selected, collapse = " ")
			tax = stringr::str_c(r_mig_char@taxa@taxa_selected, collapse = " ")
			std = stringr::str_c(r_mig_char@stage@stage_selected, collapse = " ")
			
			dat <- summary(r_mig_char, silent = TRUE)
			
			xt <- xtable::xtable(dat, ...)
			if (is.null(align)) {
				align <- c("l", rep("r", ncol(dat)))
				align(xt) <- align
			}
			if (is.null(display)) {
				display = c("s", rep("f", ncol(dat)))
				display(xt) <- display
			}
			if (is.null(caption)) {
				caption = gettextf("Summary for dc %s, taxa %s, stage %s.", dc, tax,
						std)
				caption(xt) <- caption
			}
			return(xt)
		})


#' Trend of wet weight in glass eel
#' 
#' In trapping ladders, glass eel are seldom counted, as they are too tiny to handle and too numerous to count.
#' The usual operation is to weight them, or to use a bucket to measure their volume. These weights or volumes will later
#' need to be converted to numbers. The glass eel weight may follow a seasonal pattern. It's the case for Anguilla anguilla 
#' glass eel in the Bay of Biscay. Weights can be modelled using sine wave curves, or more complex gam models. 
#' This class has a model method to try those models, which can also be used to extact coefficients manually
#' to manually test more complex models.
#' Some plots are provided to display the coefficients stored in the database, and the model results. A parameter provided in 
#' the graphical interface or in the command line (slot liste) takes values '1', '>1', 'tous' which mean respectively use
#' only individual sample of glass eels, or use 'group weights' which can be more close to the real weight of glass eel
#' during counts as glass eel are not completely drained from their water during handling to preserve their mucus. The list choice
#' 'tous' means that both individual and group weights are selected.
#' @include ref_coe.R
#' @note In this class some tools are available to import glass eel measurement from
#' experimental fishing in the estuary. For the charge method dates for the
#' request are from august to august (a glass eel season)
#' @slot data A \code{'data.frame'} data for report lot
#' @slot calcdata  A list containing two processed data frames, data and coe
#' @slot dc Object of class \code{\link{ref_dc-class}}, the counting device
#' @slot start_year Object of class \code{\link{ref_year-class}}. ref_year allows to choose the year of beginning
#' @slot end_year Object of class \code{\link{ref_year-class}}
#' ref_year allows to choose last year of the report
#' @slot coe Object of class \code{\link{ref_coe-class}} class loading coefficient
#' of conversion between quantity (weights or volumes of glass eel) and numbers
#' @slot liste Object of class \code{\link{ref_list-class}} ref_list referential
#' class choose within a list, here the choice is whether subsamples or not. Subsamples
#' in the stacomi database are samples with a non null value for parent sample. Migration
#' counts are never made on subsamples but those can be integrated to calculate mean weights.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_ge_weight-example.R
#' @aliases report_ge_weight
#' @export 
setClass(Class = "report_ge_weight", representation = representation(data = "data.frame",
				calcdata = "list", dc = "ref_dc", start_year = "ref_year", end_year = "ref_year",
				coe = "ref_coe", liste = "ref_list"), prototype = prototype(data = data.frame(),
				calcdata = list(), dc = new("ref_dc"), start_year = new("ref_year"), end_year = new("ref_year"),
				coe = new("ref_coe"), liste = new("ref_list")))

#' connect method for report_Poids_moyen
#' 
#' The connect method adapts queries according to user choices, mean weight
#'  w is calculated as car_valeur_quantitatif/lot_effectif. These coefficients are stored in the database,
#' and the connect method loads them from the table using the \link{ref_coe-class}
#' @param object An object of class \link{report_ge_weight-class}
#' @param silent Should the method be silent
#' @return An object of class \link{report_ge_weight-class}  with slots data and coe filled from the database
#' @note dates for the request are from august to august (a glass eel season)
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases connect.report_ge_weight
setMethod("connect", signature = signature("report_ge_weight"), definition = function(object, silent=TRUE) {
			# object<-r_gew loading mean weights
			requete = new("RequeteDBwheredate")
			requete@datedebut = strptime(paste(object@start_year@year_selected, "-08-01",
							sep = ""), format = "%Y-%m-%d")
			requete@datefin = strptime(paste(object@end_year@year_selected, "-08-01",
							sep = ""), format = "%Y-%m-%d")
			requete@colonnedebut = "ope_date_debut"
			requete@colonnefin = "ope_date_fin"
			requete@select = paste("SELECT lot_identifiant,ope_date_debut,ope_date_fin,lot_effectif,car_valeur_quantitatif as poids,",
					" (car_valeur_quantitatif/lot_effectif) AS w,", " (ope_date_fin-ope_date_debut)/2 AS duree,",
					" ope_date_debut+(ope_date_fin-ope_date_debut)/2 as datemoy,", " date_part('year', ope_date_debut) as annee,",
					" date_part('month',ope_date_debut) as mois", " FROM ", get_schema(), "vue_lot_ope_car_qan", sep = "")
			requete@and = paste(" AND ope_dic_identifiant=", object@dc@dc_selected, " AND std_libelle='civelle'",
					ifelse(object@liste@selectedvalue == "tous", "", paste(" AND  lot_effectif",
									object@liste@selectedvalue)), " AND upper(car_methode_obtention::text) = 'MESURE'::text",
					" AND car_par_code='A111'", sep = "")
			requete <- stacomirtools::query(requete)
			object@data <- requete@query
			# loading conversion coefficients
			object@coe@datedebut = requete@datedebut
			object@coe@datefin = requete@datefin
			object@coe <- charge(object@coe)
			if (!silent){
				funout(gettext("The query to load the coefficients of conversion is finished\n",
								domain = "R-stacomiR"))
				funout(gettextf("%1.0f lines found for the conversion coefficients\n", nrow(object@coe),
								domain = "R-stacomiR"))
			}
			assign(x = "report_ge_weight", value = object, envir = envir_stacomi)
			return(object)
		})


#' command line interface for \link{report_ge_weight-class}
#' @param object An object of class \link{report_ge_weight-class}
#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
#' @param start_year The starting the first year, passed as character or integer
#' @param end_year the finishing year, must be > start_year (minimum one year in august to the next in august)
#' @param selectedvalue A character to select and object in the \link{ref_list-class}
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_ge_weight-class}  with data selected
#' The choice_c method fills in the data slot for classes \link{ref_dc-class} \link{ref_year-class}
#' \link{ref_coe-class} \link{ref_list-class}
#' @aliases choice_c.report_ge_weight
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod("choice_c", signature = signature("report_ge_weight"), definition = function(object,
				dc, start_year, end_year, selectedvalue, silent = FALSE) {
			# code for debug using example
			# dc=c(5,6);start_year='2015';end_year='2016';selectedvalue='>1';silent=FALSE
			if (length(selectedvalue) != 1)
				stop("selectedvalue must be of length one")
			r_gew <- object
			stopifnot(end_year > start_year)
			r_gew@dc = charge(r_gew@dc)
			# loads and verifies the dc this will set dc_selected slot
			r_gew@dc <- choice_c(object = r_gew@dc, dc)
			# only taxa present in the report_mig are use
			r_gew@start_year <- charge(object = r_gew@start_year, objectreport = "report_ge_weight")
			r_gew@start_year <- choice_c(object = r_gew@start_year, nomassign = "start_year",
					annee = start_year, silent = silent)
			r_gew@end_year@data <- r_gew@start_year@data
			r_gew@end_year <- choice_c(object = r_gew@end_year, nomassign = "end_year", annee = end_year,
					silent = silent)
			r_gew@liste = charge(object = r_gew@liste, listechoice = c("=1", ">1", "tous"),
					label = gettext("choice of number in sample (one, several,all)", domain = "R-stacomiR"))  # choix de la categorie d'effectif)
			r_gew@liste <- choice_c(r_gew@liste, selectedvalue = selectedvalue)
			assign("report_ge_weight", r_gew, envir = envir_stacomi)
			return(r_gew)
		})




#' Calcule method for report_ge_weight
#' @param object An object of class \link{report_ge_weight-class}
#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
#' @return An object of class  \link{report_ge_weight-class} with  \code{@calcdata[["data"]]} (essentially a selection of 
#' columns and renaming from \code{@data}) and \code{coe} daily coefficients extracted from the database 
#' \code{@calcdata[["coe"]]} and prepared for graphs
#' @aliases calcule.report_ge_weight
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod("calcule", signature = signature("report_ge_weight"), definition = function(object,
				silent = FALSE) {
			r_gew <- object
			donnees <- r_gew@data
			coeff <- r_gew@coe@data
			coeff$w <- 1/coeff$coe_valeur_coefficient
			coeff$date <- as.POSIXct(coeff$coe_date_debut)
			if (!silent)
				funout(gettext("To obtain the table, type : report_ge_weight=get('report_ge_weight',envir_stacomi)@data\n",
								domain = "R-stacomiR"))
			# changement des noms
			donnees <- stacomirtools::chnames(donnees, c("lot_identifiant", "ope_date_debut",
							"ope_date_fin", "lot_effectif", "poids", "w", "duree", "datemoy"), c("lot",
							"date", "date_fin", "effectif", "poids", "w", "time.sequence", "date"))
			# correction de manques d'effectifs dans la base
			if (sum(is.na(donnees$effectif)) > 0)
				warnings(gettextf("size is missing, lots %s", paste(unique(donnees$lot[is.na(donnees$effectif)]),
										collapse = " "), domain = "R-stacomiR"))
			r_gew@calcdata[["data"]] <- donnees[, c(8, 6, 4, 1)]
			r_gew@calcdata[["coe"]] <- coeff[order(coeff$date), c(10, 9)]
			assign("report_ge_weight", r_gew, envir = envir_stacomi)
			return(r_gew)
		})


#' Plot method for report_ge_weight' 
#' @note the model method provides plots for the fitted models
#' @param x An object of class \link{report_ge_weight-class}
#' @param plot.type Default '1'. '1' plot of mean weight of glass eel against the mean date of operation (halfway between start,
#' and end of operation). The ggplot 'p' can be accessed from envir_stacomi using \code{get('p',envir_stacomi)}. '2' standard plot of current coefficent.
#' '3' same as '1' but with size according to number.
#' @param silent Stops displaying the messages
#' @return Nothing, called for its side effect of plotting data
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_ge_weight
#' @export
setMethod("plot", signature(x = "report_ge_weight", y = "missing"), definition = function(x,
				plot.type = 1, silent = FALSE) {
			# plot.type='1';silent=FALSE r_gew=get('report_ge_weight',envir_stacomi)
			r_gew <- x
			don <- r_gew@calcdata$data
			coe <- r_gew@calcdata$coe
			####################'
			# ggplot
			if (plot.type == 1) {
				p <- ggplot2::qplot(x = date, y = w, data = don)
				print(p)
				assign("p", p, envir = envir_stacomi)
				if (!silent)
					funout(gettext("ggplot object p assigned to envir_stacomi", domain = "R-stacomiR"))
				####################'
				# standard plot
			} else if (plot.type == 2) {
				if (length(r_gew@liste@selectedvalue) == 0)
					stop("Internal error, the value has not been selected before launching plot")
				type_poids = switch(r_gew@liste@selectedvalue, `>1` = gettext("wet weights",
								domain = "R-stacomiR"), `=1` = gettext("dry weights", domain = "R-stacomiR"),
						tous = gettext("wet and dry weights", domain = "R-stacomiR"))
				plot(x = don$date, y = don$w, xlab = gettext("date", domain = "R-stacomiR"),
						ylab = gettext("mean weights", domain = "R-stacomiR"), col = "red", main = gettextf("Seasonal trend of %s, from %s to %s",
								type_poids, r_gew@start_year@year_selected, r_gew@end_year@year_selected,
								domain = "R-stacomiR"), sub = "Trend of wet weights")
				coe <- coe[order(coe$date), ]
				points(coe$date, coe$w, type = "l", col = "black", lty = 2)
				# legend('topright',c('Obs.', 'Coeff base'),
				# col=c('black','cyan'),pch='o',cex = 0.8)
				
				####################'
				# geom_point + size
			} else if (plot.type == 3) {
				p <- ggplot2::qplot(x = date, y = w, data = don)
				print(p + aes(size = effectif))
				assign("p", p, envir = envir_stacomi)
				if (!silent)
					funout(gettext("object p assigned to envir_stacomi", domain = "R-stacomiR"))
			}
			return(invisible(NULL))
		})


#' model method for report_ge_weight' 
#' this method uses samples collected over the season to model the variation in weight of
#' glass eel or yellow eels.
#' @param object An object of class \link{report_ge_weight-class}
#' @param model.type default 'seasonal', 'seasonal1','seasonal2','manual'. 
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return An object of class \link{report_ge_weight-class} with \code{@calcdata[["import_coe"]]} filled.
#' @details 
#' Depending on model.type several models are produced
#' \itemize{
#'\item{model.type='seasonal'.}{ The simplest model uses a seasonal variation, it is
#'     fitted with a sine wave curve allowing a cyclic variation 
#'     w ~ a*cos(2*pi*(d'-T)/365)+b with a period T. The modified day d' used is this model is set
#'     at 1 the 1st of august doy = d' + d0; d0 = 212, doy=julian days}
#'\item{model.type='seasonal1'.}{ A time component is introduced in the model, which allows
#'   for a long term variation along with the seasonal variation. This long term variation is
#'   is fitted with a gam, the time variable is set at zero at the beginning of the first day of observed values.
#'   The seasonal variation is modeled on the same modified julian time as model.type='seasonal'
#'   but here we use a cyclic cubic spline cc, which allows to return at the value of d0=0 at d=365.
#'   This model was considered as the best to model size variations by Diaz & Briand in prep. but using a large set of values
#'   over years.}
#'\item{model.type='seasonal2'.}{The seasonal trend in the previous model is now modelled with a sine
#'   curve similar to the sine curve used in seasonal.  The formula for this is \eqn{sin(\omega vt) + cos(\omega vt)}{sin(omega vt) + cos(omega vt)}, 
#'  where vt is the time index variable \eqn{\omega}{omega} is a constant that describes how the index variable relates to the full period
#'   (here, \eqn{2\pi/365=0.0172}{2pi/365=0.0172}). The model is written as following \eqn{w~cos(0.0172*doy)+sin(0.0172*doy)+s(time).}}
#'\item{model.type='manual'.}{ The dataset don (the raw data), coe (the coefficients already present in the
#'   database, and newcoe the dataset to make the predictions from, are written to the environment envir_stacomi. 
#'   please see example for further description on how to fit your own model, build the table of coefficients,
#'   and write it to the database.}
#' }
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases model.report_ge_weight
setMethod("model", signature(object = "report_ge_weight"), definition = function(object,
				model.type = "seasonal", silent = FALSE) {
			# r_gew=get('report_ge_weight',envir_stacomi);silent=TRUE;require(ggplot2)
			# r_gew <- bilPM
			r_gew <- object
			don <- r_gew@calcdata$data
			coe <- r_gew@calcdata$coe
			seq = seq(as.Date(r_gew@coe@datedebut), as.Date(r_gew@coe@datefin), by = "day")
			origine <- as.POSIXct(trunc(min(don$date), "day"))
			# season starting in november
			fndate <- function(data) {
				if (!"date" %in% colnames(data))
					stop("date should be in colnames(data)")
				if (!inherits(data$date[1], "POSIXct"))
					stop("date should be POSIXct")
				data$year <- lubridate::year(data$date)
				# lubridate::yday(lubridate::dmy(01082008))
				data$yday = lubridate::yday(data$date)
				data$doy = data$yday - 212  # year begins in august to be consistent with the class   
				data$season <- stringr::str_c(lubridate::year(data$date) - 1, "-", lubridate::year(data$date))  # year-1-year
				data$season[data$doy > 0] <- stringr::str_c(lubridate::year(data$date), "-",
						lubridate::year(data$date) + 1)[data$doy > 0]  # for november and december it's year - year+1
				data$yearbis <- data$year  # same as season but with a numeric
				data$yearbis[data$doy > 0] <- data$yearbis[data$doy > 0] + 1  # same as season but a numeric
				data$doy[data$doy < 0] <- data$doy[data$doy < 0] + 365
				data$time = as.numeric(data$date - origine)
				return(data)
			}
			don$date <- as.POSIXct(as.Date(don$date)) # bug the tz in CEST and GMT don't fit well
			# and the range of time between don and newcoe becomes extremely different
			don <- fndate(don)
			newcoe = data.frame(date = seq, mean_weight = NA, number = NA, lot = NA, yday = lubridate::yday(seq))
			newcoe$date = as.POSIXct(newcoe$date)
			newcoe = fndate(newcoe)
			
			if (model.type == "seasonal") {
				result <- data.frame(season = unique(don$season), year = unique(don$yearbis),
						a = NA, T = NA, b = NA)
				for (seas in unique(don$season)) {
					# seas<-unique(don$season)[1]
					if (!silent){
						print(seas)
						print("___________")
					}
					# regression one per season, taking T as adjusted previously
					year = result[result$season == seas, "year"]
					g0 <- nls(formula = w ~ a * cos(2 * pi * (doy - T)/365) + b, data = don[don$season ==
											seas, ], start = list(a = 0.08, T = 73.7, b = 0.29))
					# getting the results into a table result
					result[result$season == seas, c("a", "T", "b")] <- coef(g0)
					if (!silent){
						print(summary(g0))
						print("AIC:")
						print(AIC(g0))
					}
					# what is the size in december ? I'm just using the formula from
					# Guerault and Desaunay
					# result[result$season==seas,'pred_weight']<-coef(g0)['a']*cos(2*pi*(50-T)/365)+coef(g0)['b']
					# dataframe for prediction, I will bind them to get a final
					# dataframe (predatafull) for the graph below
					predatay <- newcoe[newcoe$season == seas, ]
					predatay$pred_weight <- predict(g0, newdata = predatay)
					if (seas == unique(don$season)[1]) {
						predata <- predatay
					} else predata <- rbind(predata, predatay)
				}
				if (!silent) print(result)
				assign("result", result, envir_stacomi)
				if (!silent)
					funout(gettext("Model equations assigned to envir_stacomi (result)",
									domain = "R-stacomiR"))
				
				p <- ggplot(don) + geom_jitter(aes(x = doy, y = w), col = "aquamarine4") +
						facet_wrap(~season) + geom_line(aes(x = doy, y = pred_weight), data = predata) +
						# geom_line(aes(x=doy,y=pred_weight),color='green',size=1,data=predatafull[predatafull$doy==50,])+
						theme_minimal() + theme(panel.border = element_blank(), axis.line = element_line()) +
						xlab(gettext("Day in the season, starting 1st of august", domain = "R-StacomiR"))
				
				print(p)
				assign("p", p, envir = envir_stacomi)
				if (!silent)
					funout(gettext("ggplot object p assigned to envir_stacomi", domain = "R-stacomiR"))
				
				
				# fm <- stats::nls(formula=w ~ a*cos(2*pi*(doy-T)/365)+b
				# ,data=don,start=list(a=0.1,T=73,b=0.3)) pred<-stats::predict(fm,
				# newdata=newcoe) com=gettextf('sinusoidal model,
				# a.cos(2.pi.(jour-T)/365)+b a=%s t=%s
				# b=%s',round(coef(fm),2)[1],round(coef(fm),2)[2],round(coef(fm),2)[3])
				# plot(r_gew,plot.type=2) points(as.POSIXct(newcoe$date),pred,
				# col='magenta') legend('topright',c('Obs.', 'Coeff base','Mod'),
				# col=c('black','cyan','magenta'),pch='o',cex = 0.8)
				# mtext(com,side=3,line=0.5)
				
				result_to_text <- stringr::str_c(sapply(t(result[, c(1, 3, 4, 5)]), as.character),
						collapse = " ")
				
				# setting text for comment (lines inserted into the database)
				com = stringr::str_c("w ~ a*cos(2*pi*(doy-T)/365)+b with a period T.", " The julian time d0 used is this model is set at zero 1st of November doy = d + d0; d0 = 305.",
						" Coefficients for the model (one line per season): season, a, T, b =",
						result_to_text)
				
			} else if (model.type == "seasonal1") {
				
				g1 = mgcv::gam(w ~ s(yday, bs = "cc") + s(time), data = don, knots = list(yday = c(1,
										365)))
				# the knots=list(yday=c(1,365) is necessary for a smooth construction
				# of the model
				summary(g1)
				plot(g1, pages = 1)
				predata <- newcoe
				pred <- predict(g1, newdata = predata, se.fit = TRUE, type="response")
				predata$pred_weight <- pred$fit
				predata$pred_weight_lwr <- pred$fit - 1.96 * pred$se.fit
				predata$pred_weight_upr <- pred$fit + 1.96 * pred$se.fit
				p <- ggplot(don) + geom_jitter(aes(x = date, y = w), col = "aquamarine4") +
						geom_line(aes(x = date, y = pred_weight), data = predata) + geom_ribbon(data = predata,
								aes(x = date, ymin = pred_weight_lwr, ymax = pred_weight_upr), alpha = 0.3,
								fill = "saddlebrown") + scale_x_datetime(date_breaks = "years", date_minor_breaks = "month") +
						theme_minimal() + theme(panel.border = element_blank(), axis.line = element_line()) +
						xlab("Date")
				if (!silent) print(p)
				assign("p", p, envir = envir_stacomi)
				assign("g1", g1, envir = envir_stacomi)
				if (!silent)
					funout(gettext("ggplot object p assigned to envir_stacomi", domain = "R-stacomiR"))
				if (!silent)
					funout(gettext("gam model g1 assigned to envir_stacomi", domain = "R-stacomiR"))
				com = "model seasonal1 = gam(w~s(yday,bs='cc')+s(time), knots = list(yday = c(1, 365)))"
				
			} else if (model.type == "seasonal2") {
				
				## seasonal effects with a continuous sine-cosine wave,.  The
				## formula for this is 'sin(omegavt) + cos(omegavt)',
				## where vt is the time index variable
				## \tomega is a constant that describes how the index
				## variable relates to the full period (here,
				## 2pi/365=0.0172).
				g2 = mgcv::gam(w ~ cos(0.0172 * doy) + sin(0.0172 * doy) + s(time), data = don)
				print(gettext("One model per year, doy starts in august", domain = "R-stacomiR"))
				summary(g2)
				plot(g2, pages = 1)
				predata <- newcoe
				pred <-  predict(g2, newdata = predata, se.fit = TRUE, type="response")
				predata$pred_weight <- pred$fit
				predata$pred_weight_lwr <- pred$fit - 1.96 * pred$se.fit
				predata$pred_weight_upr <- pred$fit + 1.96 * pred$se.fit
				p <- ggplot(don) + geom_jitter(aes(x = date, y = w), col = "aquamarine4") +
						geom_line(aes(x = date, y = pred_weight), data = predata) + geom_ribbon(data = predata,
								aes(x = date, ymin = pred_weight_lwr, ymax = pred_weight_upr), alpha = 0.8,
								fill = "wheat") + 
						scale_x_datetime(date_breaks = "years", date_minor_breaks = "month") +
						theme_minimal() + 
						theme(panel.border = element_blank(), axis.line = element_line()) +
						xlab("Date")
				if (!silent) print(p)
				assign("p", p, envir = envir_stacomi)
				assign("g2", g2, envir = envir_stacomi)
				if (!silent)
					funout(gettext("ggplot object p assigned to envir_stacomi", domain = "R-stacomiR"))
				if (!silent)
					funout(gettext("gam model g2 assigned to envir_stacomi", domain = "R-stacomiR"))
				
				## comparison
				## with Guerault and Desaunay (summary table in latex)
				gamma = as.numeric(sqrt(g2$coefficients["cos(0.0172 * doy)"]^2 + g2$coefficients["sin(0.0172 * doy)"]^2))  #0.386
				# compared with 0.111
				phi = round(as.numeric(atan2(g2$coefficients["sin(0.0172 * doy)"], g2$coefficients["cos(0.0172 * doy)"]) -
										pi/2))  # -0.82
				# time is centered on zero
				s0 = as.numeric(g2$coefficients["(Intercept)"])  #7.04 (compared with 6.981)
				summary_harmonic <- data.frame(source = c("Vilaine 1991-1993, Guerault et Desaunay",
								"This model"), `$\\gamma$` = c(0.0375, gamma), `$s_0$` = c(0.263, s0),
						`$\\phi$` = c(319, 305 - phi))
				# need to repass colnames
				colnames(summary_harmonic) = c("source", "$\\gamma$", "$s_0(cm)$", "$\\phi$")
				xt_summary_harmonic <- xtable(summary_harmonic, caption = gettext("Comparison of the coefficients obtained by \\citet{desaunay_seasonal_1997} and in the present modelling of estuarine samples.",
								domain = "R-stacomiR"), label = gettext("summary_harmonic", domain = "R-stacomiR"),
						digits = c(0, 0, 3, 3, 0))
				tabname <- stringr::str_c(get("datawd", envir = envir_stacomi), "/summary_harmonic.tex")
				o <- print(xt_summary_harmonic, file = tabname, table.placement = "htbp",
						caption.placement = "top", NA.string = "", include.rownames = FALSE,
						tabular.environment = "tabularx", width = "0.6\\textwidth", sanitize.colnames.function = function(x) {
							x
						})
				
				funout(gettextf("summary coefficients written in %s", tabname, domain = "R-stacomiR"))
				com = stringr::str_c("model seasonal2 = gam(w~cos(0.0172*doy)+sin(0.0172*doy)+s(time), knots = list(yday = c(1, 365))),Desaunay's gamma=",
						round(gamma, 3), ", phi=", phi, ", s0=", round(s0, 3))
				
				
			} else if (model.type == "manual") {
				if (!silent)
					funout(gettext("Table for predictions newcoe assigned to envir_stacomi",
									domain = "R-stacomiR"))
				assign("newcoe", newcoe, envir = envir_stacomi)
				if (!silent)
					funout(gettext("Table of data don assigned to envir_stacomi", domain = "R-stacomiR"))
				assign("don", don, envir = envir_stacomi)
				if (!silent)
					funout(gettext("Table of current coefficients coe assigned to envir_stacomi",
									domain = "R-stacomiR"))
				assign("coe", coe, envir = envir_stacomi)
			}
			
			if (model.type != "manual") {
				import_coe = data.frame(coe_tax_code = "2038", coe_std_code = "CIV", coe_qte_code = 1,
						coe_date_debut = Hmisc::roundPOSIXt(predata$date, digits = "days"), coe_date_fin = Hmisc::roundPOSIXt(predata$date,
								digits = "days") + as.difftime(1, units = "days"), coe_valeur_coefficient = 1/predata$pred_weight,
						coe_commentaires = com)
				# will write only if the database is present
				if (get("database_expected", envir_stacomi)) {
					fileout = paste(get("datawd", envir = envir_stacomi), "import_coe", r_gew@start_year@year_selected,
							r_gew@end_year@year_selected, ".csv", sep = "")
					utils::write.table(import_coe, file = fileout, row.names = FALSE, sep = ";")
					if (! silent){ 
						funout(paste(gettextf("data directory :%s", fileout, domain = "R-stacomiR")))
					}
				}
				assign("import_coe", import_coe, envir = envir_stacomi)
				if (! silent){
					funout(gettext("To obtain the table, type : import_coe=get(\"import_coe\",envir_stacomi)",
									domain = "R-stacomiR"))
				}
				r_gew@calcdata[["import_coe"]] <- import_coe
			}
			return(r_gew)
		})




#' Method to write data to the stacomi database for \link{report_ge_weight-class}
#' 
#' Data will be written in tj_coefficientconversion_coe table, if the class retrieves some data
#' from the database, those will be deleted first. 
#' @param object An object of class \link{report_ge_weight-class}
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return Nothing, called for its side effect of writing to the database
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases write_database.report_ge_weight
setMethod("write_database", signature = signature("report_ge_weight"), definition = function(object,
				silent = FALSE) {
			
			r_gew <- object
			if (!"import_coe" %in% names(r_gew@calcdata))
				funout(gettext("Attention, you must fit a model before trying to write the predictions in the database",
								domain = "R-stacomiR"), arret = TRUE)
			# first delete existing data from the database
			supprime(r_gew@coe, tax = 2038, std = "CIV", silent = silent)
			import_coe <- r_gew@calcdata$import_coe
			import_coe$coe_org_code <- get_org()
			import_coe$coe_date_debut <- as.Date(import_coe$coe_date_debut)+1  # to avoid day change with POSIXct and database
			import_coe$coe_date_fin <- as.Date(import_coe$coe_date_fin)+1  
			con <- new("ConnectionDB")
			con <- connect(con)
			on.exit(pool::poolClose(con@connection))
			sql <- "DROP TABLE IF EXISTS import_coe"
			pool::dbExecute(con@connection, statement = sql)
			pool::dbWriteTable(con@connection, 
					name = "import_coe", 
					value=import_coe, 
					temporary=TRUE)	
			sql <- stringr::str_c("INSERT INTO ", get_schema(), "tj_coefficientconversion_coe (",
					"coe_tax_code,coe_std_code,coe_qte_code,coe_date_debut,coe_date_fin,coe_valeur_coefficient,
							coe_commentaires,coe_org_code)",
					" SELECT coe_tax_code,coe_std_code,coe_qte_code,coe_date_debut,coe_date_fin,coe_valeur_coefficient::real,
							coe_commentaires,coe_org_code FROM import_coe;")
			pool::dbExecute(con@connection, statement = sql)
			if (!silent){
				funout(gettext(sprintf("You have written %s rows in the database",nrow(import_coe)),
								domain = "R-stacomiR"))
			}
			return(invisible(NULL))
		})




#' Migration reports for multiple DC / species / stages
#' 
#' Migration counts for several Fish counting devices (DC), several taxa and several stages.
#' This migration count can be built either by the graphical interface or from the command line 
#' (see examples).

#' @note A Migration report comes from a migration monitoring : the fishes are monitored in a section of river, this section is
#' called a control station (station). Most often, there is a dam, one or several fishways (DF) which comprise one or several counting devices (DC).
#' On each counting device, the migration is recorded. It can be either an instant recording (video control) or the use of traps,
#' Operations are monitoring operations during a period. For each operation, several species of fishes can be recorded (samples). In the case of migratory 
#' fishes the stage of development is important as it may indicate generic migrations, to and fro, between the river and the sea.
#' 
#' Hence a Multiple Migration report is built from several one or several counting devices (DC), one or several Taxa (Taxon), one or several stages
#' (stage). The migration can be also recorded not as numbers, but in the case of glass eels, as weight, which will be later transformed to number, 
#' from daily conversion coefficients. The methods in this class test whether the counts are numbers or another type of quantity.
#' This class makes different calculations than report_mig, it does not handle escapement coefficients,
#' it uses quantities other than numbers if necessary (only used for glass eel in the connect method).
#' @slot dc An object of class \code{ref_dc-class}
#' @slot taxa An object of class \code{\link{ref_taxa-class}}
#' @slot stage An object of class \code{\link{ref_stage-class}}
#' @slot timestep An object of class \code{\link{ref_timestep_daily-class}}
#' @slot data A data.frame containing raw data filled by the connect method
#' @slot calcdata A 'list' of calculated daily data, one per dc, filled in by the calcule method
#' @slot coef_conversion A data frame of daily weight to number conversion coefficients, filled in by the connect
#' method if any weight are found in the data slot.
#' @slot time.sequence A POSIXt time sequence
#' @family report Objects
#' @aliases report_mig_mult
#' @keywords classes
#' @example inst/examples/report_mig_mult-example.R
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
setClass(Class = "report_mig_mult", representation = representation(dc = "ref_dc",
				taxa = "ref_taxa", stage = "ref_stage", timestep = "ref_timestep_daily", data = "data.frame",
				calcdata = "list", coef_conversion = "data.frame", time.sequence = "POSIXct"),
		prototype = prototype(dc = new("ref_dc"), taxa = new("ref_taxa"), stage = new("ref_stage"),
				timestep = new("ref_timestep_daily"), data = data.frame(), calcdata = list(),
				coef_conversion = data.frame(), time.sequence = as.POSIXct(Sys.time())))

setValidity("report_mig_mult", function(object) {
			rep1 = length(object@dc) >= 1
			rep2 = length(object@taxa) >= 1
			rep3 = length(object@stage) >= 1
			return(ifelse(rep1 & rep2 & rep3, TRUE, c(1:6)[!c(rep1, rep2, rep3)]))
		})




#' charge method for report_mig_mult
#' 
#' Unique the other report classes where the charge method is only used by the graphical interface 
#' to collect and test objects in the environment envir_stacomi, and see if the right choices have
#' been made in the graphical interface, this method is used to load data on migration control operations
#' fishway operations, and counting devices operations as data from those are displayed in the main plots. 
#' 
#' @param object An object of class \link{report_mig_mult-class}
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return An object of class \link{report_mig_mult-class} with slots filled from values assigned in \code{envir_stacomi} environment
#' @aliases charge.report_mig_mult
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod("charge", signature = signature("report_mig_mult"), definition = function(object,
				silent = FALSE) {
			report_mig_mult <- object
			if (exists("ref_dc", envir_stacomi)) {
				report_mig_mult@dc <- get("ref_dc", envir_stacomi)
				dc <- report_mig_mult@dc@dc_selected
				df <- report_mig_mult@dc@data$df[report_mig_mult@dc@data$dc %in% dc]
			} 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_mult@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_mult@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("timestep", envir_stacomi)) {
				report_mig_mult@timestep <- get("timestep", envir_stacomi)
			} else {
				funout(gettext("Attention, no time step selected, compunting with default value\n",
								domain = "R-stacomiR"), arret = FALSE)
				warning("Attention, no time step selected, compunting with default value\n")
			}
			################################# loading data for other classes associated
			################################# with report_mig_mult
			assign("report_dc_date_debut", get("timestep", envir_stacomi)@dateDebut, envir_stacomi)
			assign("report_dc_date_fin", as.POSIXlt(end_date(get("timestep", envir_stacomi))),
					envir_stacomi)
			assign("report_df_date_debut", get("timestep", envir_stacomi)@dateDebut, envir_stacomi)
			assign("report_df_date_fin", as.POSIXlt(end_date(get("timestep", envir_stacomi))),
					envir_stacomi)
			assign("report_ope_date_debut", get("timestep", envir_stacomi)@dateDebut, envir_stacomi)
			assign("report_ope_date_fin", as.POSIXlt(end_date(get("timestep", envir_stacomi))),
					envir_stacomi)
			
			report_ope <- get("report_ope", envir = envir_stacomi)
			report_ope <- charge(report_ope)
			# charge will search for ref_dc (possible multiple choice),
			# report_ope_date_debut and report_ope_date_fin in envir_stacomi
			report_dc <- get("report_dc", envir = envir_stacomi)
			# charge will search for ref_dc (possible multiple choice),
			# report_dc_date_debut and report_dc_date_fin in envir_stacomi
			report_dc <- charge(report_dc)
			ref_df = new("ref_df")
			ref_df <- charge(ref_df)
			ref_df <- choice_c(ref_df, df)
			assign("ref_df", ref_df, envir = envir_stacomi)
			report_df <- get("report_df", envir = envir_stacomi)
			# charge will search for ref_df (possible multiple choice),
			# report_df_date_debut and report_df_date_fin in envir_stacomi
			report_df <- charge(report_df)
			# the object are assigned to the envir_stacomi for later use by the connect
			# method
			assign("report_df", report_df, envir = envir_stacomi)
			assign("report_dc", report_dc, envir = envir_stacomi)
			assign("report_ope", report_ope, envir = envir_stacomi)
			stopifnot(validObject(report_mig_mult, test = TRUE))
			# connect will load, coefficients, DF, DC, operations
			return(report_mig_mult)
		})


#' command line interface for report_mig_mult class
#' 
#' The choice_c method fills in the data slot for ref_dc, ref_taxa, ref_stage and then 
#' uses the choice_c methods of these object to 'select' the data.
#' @param object An object of class \link{report_mig-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),
#' these 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 datedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param datefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
#' @param silent Should messages be hided default FALSE
#' @return An object of class \link{report_mig_mult-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_mig_mult
setMethod("choice_c", signature = signature("report_mig_mult"), definition = function(object,
				dc, taxa, stage, datedebut, datefin, silent = FALSE) {
			report_mig_mult <- object
			report_df = new("report_df")
			assign("report_df", report_df, envir = envir_stacomi)
			report_dc = new("report_dc")
			assign("report_dc", report_dc, envir = envir_stacomi)
			report_ope = new("report_ope")
			assign("report_ope", report_ope, envir = envir_stacomi)
			report_mig_mult@dc = charge(report_mig_mult@dc)
			# loads and verifies the dc
			report_mig_mult@dc <- choice_c(object = report_mig_mult@dc, dc)
			# only taxa present in the report_mig are used
			report_mig_mult@taxa <- charge_with_filter(object = report_mig_mult@taxa, 
					report_mig_mult@dc@dc_selected)
			report_mig_mult@taxa <- choice_c(report_mig_mult@taxa, taxa)
			report_mig_mult@stage <- charge_with_filter(object = report_mig_mult@stage, 
					dc_selected = report_mig_mult@dc@dc_selected,
					taxa_selected = report_mig_mult@taxa@taxa_selected)
			report_mig_mult@stage <- choice_c(report_mig_mult@stage, stage)
			report_mig_mult@timestep <- choice_c(report_mig_mult@timestep, datedebut, datefin)
			assign("report_mig_mult", report_mig_mult, envir = envir_stacomi)
			if (!silent)
				funout(gettext("Choice made, and object report_mig_mult assigned in envir_stacomi"),
						domain = "R-stacomiR")
			return(report_mig_mult)
		})

#' #' Transforms migration per period to daily migrations, and performs the conversion from weights to number is data
#' are stored as weights (glass eel). This calculation is performed in a loop for all dc. 
#' 
#'  The calculation must be launched once data are filled by the connect method. Currently the negative argument
#' has no effect. 
#'  
#' @param object An object of class \link{report_mig_mult-class}
#' @param negative a boolean indicating if a separate sum must be done for positive and negative values, if true, positive and negative counts return 
#' different rows
#' @param silent Default FALSE, should messages be stopped
#' @note The class does not handle escapement rates, though structurally those are present in the database. If you 
#' want to use those you will have to do the calculation manually from the data in \code{report_mig_mult@data}.
#' @return report_mig_mult with a list in slot calcdata. For each dc one will find a list with the following elements
#' \describe{
#' \item{method}{In the case of instantaneous periods (video counting) the sum of daily values is done by the \link{fun_report_mig_mult} method and the value indicated in method is 'sum'.
#'  If any migration monitoring period is longer than a day, then the migration is split using the \link{fun_report_mig_mult_overlaps} function and the value indicated in the 
#' method is 'overlaps' as the latter method uses the overlap package to split migration period.}
#' \item{data}{the calculated data. If weight are present, the columns display weight or numbers, the total number is 
#' 'Effectif_total' and corresponds to the addition of numbers and numbers converted from weight,
#' the total weight is 'Poids_total'+'poids_depuis_effectifs' and corresponds to weighed glass eel plus glass eel number converted in weights.
#' CALCULE corresponds to calulated number, MESURE to measured numbers, EXPERT to punctual expertise of migration (for instance measured in other path, or known migration
#' of fishes passing the dam but not actually counted, PONCTUEL to fishes counted by visual identification but not by the counting apparatus (in case of technical problem for instance)}
#' \item{contient_poids}{A boolean which indicates, in the case of glass eel, that the function \link{fun_weight_conversion} has been run to convert the weights to numbers using the weight
#' to number coefficients in the database (see link{report_ge_weight}).}
#' \item{negative}{A parameter indicating if negative migration (downstream in the case of upstream migration devices) have been converted to positive numbers,
#' not developed yet}}
#' @aliases calcule.report_mig_mult
setMethod("calcule", signature = signature("report_mig_mult"), definition = function(object,
				negative = FALSE, silent = FALSE) {
			
			# report_mig_mult<-r_mig_mult; negative=FALSE
			if (!silent)
				funout(gettext("Starting migration summary ... be patient\n", domain = "R-stacomiR"))
			report_mig_mult <- object
			debut = report_mig_mult@timestep@dateDebut
			fin = end_date(report_mig_mult@timestep)
			time.sequence <- seq.POSIXt(from = debut, to = fin, by = as.numeric(report_mig_mult@timestep@step_duration))
			report_mig_mult@time.sequence <- time.sequence
			lestableaux <- list()
			for (dic in unique(report_mig_mult@data$ope_dic_identifiant)) {
				datasub <- report_mig_mult@data[report_mig_mult@data$ope_dic_identifiant ==
								dic, ]
				datasub$duree = difftime(datasub$ope_date_fin, datasub$ope_date_debut, units = "days")
				if (any(datasub$duree > (report_mig_mult@timestep@step_duration/86400))) {
					#----------------------
					# reports with overlaps
					#----------------------
					data <- fun_report_mig_mult_overlaps(time.sequence = time.sequence, datasub = datasub,
							negative = negative)
					# to remain compatible with report mig :
					data$taux_d_echappement = -1
					lestableaux[[stringr::str_c("dc_", dic)]][["data"]] <- data
					lestableaux[[stringr::str_c("dc_", dic)]][["method"]] <- "overlaps"
					contient_poids <- "poids" %in% datasub$type_de_quantite
					lestableaux[[stringr::str_c("dc_", dic)]][["contient_poids"]] <- contient_poids
					
					lestableaux[[stringr::str_c("dc_", dic)]][["negative"]] <- negative
					if (contient_poids) {
						coe <- report_mig_mult@coef_conversion[, c("coe_date_debut", "coe_valeur_coefficient")]
						data$coe_date_debut <- as.Date(data$debut_pas)
						data <- merge(data, coe, by = "coe_date_debut")
						data <- data[, -1]  # removing coe_date_debut
						data <- fun_weight_conversion(tableau = data, time.sequence = report_mig_mult@time.sequence,
								silent)
					}
					
					lestableaux[[stringr::str_c("dc_", dic)]][["data"]] <- data
					
				} else {
					#----------------------
					# report simple
					#----------------------
					mydata <- fun_report_mig_mult(time.sequence = time.sequence, datasub = datasub,
							negative = negative)
					mydata$taux_d_echappement = -1
					mydata$coe_valeur_coefficient = NA
					contient_poids <- "poids" %in% datasub$type_de_quantite
					if (contient_poids) {
						# at this tage data for coe_valeur_coefficient are null, we
						# remove the column before merging
						mydata <- mydata[, -match("coe_valeur_coefficient", colnames(mydata))]
						coe <- report_mig_mult@coef_conversion[, c("coe_date_debut", "coe_valeur_coefficient")]
						mydata$coe_date_debut <- as.Date(mydata$debut_pas)
						mydata2 <- merge(mydata, coe, by = "coe_date_debut")
						mydata2 <- mydata2[, -match("coe_date_debut", colnames(mydata2))]  # removing coe_date_debut
						data <- fun_weight_conversion(tableau = mydata2, time.sequence = report_mig_mult@time.sequence,
								silent)
					} else {
						data <- mydata
					}
					lestableaux[[stringr::str_c("dc_", dic)]][["data"]] <- data
					lestableaux[[stringr::str_c("dc_", dic)]][["method"]] <- "sum"
					lestableaux[[stringr::str_c("dc_", dic)]][["contient_poids"]] <- contient_poids
					lestableaux[[stringr::str_c("dc_", dic)]][["negative"]] <- negative
				}
			}  # end for dic
			# TODO developper une methode pour sumneg
			report_mig_mult@calcdata <- lestableaux
			assign("report_mig_mult", report_mig_mult, envir_stacomi)
			if (!silent) {
				funout(gettext("The summary object is stored in environment envir_stacomi, write report_mig_mult=get(\"report_mig_mult\",envir_stacomi) \n",
								domain = "R-stacomiR"))
				funout(gettext("Raw data are stored in report_mig_mult@data, processed data in report_mig_mult@calcdata\\n\n",
								domain = "R-stacomiR"))
			}
			return(report_mig_mult)
		})

#' connect method for report_mig_mult
#' 
#' this method loads data from the database for report_mig but also fills the table of conversion coefficient, if 
#' the taxa is eel. It also calls connect method for \link{report_df-class}, 
#' \link{report_dc-class} and \link{report_ope-class} associated with the report
#' and used by the \link{fungraph} and \link{fungraph_glasseel} functions. As a side effect it assigns
#' objects 	\link{report_dc-class}, \link{report_df-class} and \link{report_ope-class} in environment \code{envir_stacomi}


#' @param object An object of class \link{report_mig_mult-class}
#' @param silent Boolean, if TRUE messages are not displayed
#' @return An object of class \link{report_mig_mult-class} with slot @data filled from the database
#' @aliases connect.report_mig_mult
setMethod("connect", signature = signature("report_mig_mult"), definition = function(object,
				silent = FALSE) {
			# recuperation du report_mig report_mig_mult<-bmM
			
			report_mig_mult <- object
			
			# retrieve the argument of the function and passes it to report_mig_mult
			# easier to debug
			req = new("RequeteDBwheredate")
			req@colonnedebut <- "ope_date_debut"
			req@colonnefin <- "ope_date_fin"
			# we round the date to be consistent with daily values from the
			req@datedebut = report_mig_mult@timestep@dateDebut
			req@datefin = as.POSIXlt(end_date(report_mig_mult@timestep) + as.difftime("23:59:59"))
			if (length(report_mig_mult@dc@dc_selected) == 0)
				stop("DC has length zero, are you connected to the right schema, do you use the right dc number ?")
			dc = vector_to_listsql(report_mig_mult@dc@dc_selected)
			if (length(report_mig_mult@taxa@taxa_selected) == 0)
				stop("Taxa has length zero, are you connected to the right schema, do you use the right taxa ?")
			tax = vector_to_listsql(report_mig_mult@taxa@taxa_selected)
			if (length(report_mig_mult@stage@stage_selected) == 0)
				stop("Stage has length zero, are you connected to the right schema, do you use the right stage ?")
			std = vector_to_listsql(report_mig_mult@stage@stage_selected)
			sch = get_schema()
			req@select = stringr::str_c("SELECT 
							ope_identifiant,
							lot_identifiant,
							ope_date_debut,
							ope_date_fin,
							ope_dic_identifiant,
							lot_tax_code,
							lot_std_code,
							CASE WHEN lot_effectif is not NULL then lot_effectif  
							WHEN lot_effectif is null then lot_quantite 
							end as value,
							case when lot_effectif is not NULL  then 'effectif' 
							when lot_effectif is null and lot_qte_code='1' then 'poids' 
							when lot_effectif is null and lot_qte_code='2' then 'volume' 
							else 'quantite' end as type_de_quantite,
							lot_dev_code, 
							lot_methode_obtention",
					" FROM ", sch, "t_operation_ope", " JOIN ", sch, "t_lot_lot on lot_ope_identifiant=ope_identifiant")
			# removing character marks
			req@select <- stringr::str_replace_all(req@select, "[\r\n\t]", "")
			# the where clause is returned by DBWheredate
			req@and = stringr::str_c(" AND ope_dic_identifiant in", dc, " AND lot_tax_code in ",
					tax, " AND lot_std_code in ", std, " AND lot_lot_identifiant IS NULL")
			req <- stacomirtools::query(req)
			report_mig_mult@data = req@query
			if (!silent)
				cat(stringr::str_c("data collected from the database nrow=", nrow(report_mig_mult@data),
								"\n"))
			# recuperation des coefficients si il y a des civelles dans le report
			if (2038 %in% report_mig_mult@taxa@taxa_selected) {
				req = new("RequeteDBwheredate")
				req@select = paste("select * from", sch, "tj_coefficientconversion_coe")
				req@datedebut = as.POSIXlt(report_mig_mult@timestep@dateDebut)
				req@datefin = as.POSIXlt(end_date(report_mig_mult@timestep))
				req@colonnedebut <- "coe_date_debut"
				req@colonnefin <- "coe_date_fin"
				req@and <- c("and coe_tax_code='2038'", "and coe_std_code='CIV'")
				req@order_by <- "order by coe_date_debut"
				req <- stacomirtools::query(req)
				report_mig_mult@coef_conversion <- req@query
				
			}
			stopifnot(validObject(report_mig_mult, test = TRUE))
			
			#######################''
			# connect method for associated classes
			report_ope <- get("report_ope", envir = envir_stacomi)
			report_dc <- get("report_dc", envir = envir_stacomi)
			report_df <- get("report_df", envir = envir_stacomi)
			report_ope <- connect(report_ope, silent = silent)
			report_dc <- connect(report_dc, silent = silent)
			report_df <- connect(report_df, silent = silent)
			assign("report_df", report_df, envir = envir_stacomi)
			assign("report_dc", report_dc, envir = envir_stacomi)
			assign("report_ope", report_ope, envir = envir_stacomi)
			return(report_mig_mult)
		})


#' Plots of various type for report_mig_mult
#' 
#' \itemize{
#'   \item{plot.type='standard'}{calls \code{\link{fungraph}} and \code{\link{fungraph_glasseel}} functions to plot as many 'report_mig'
#'   as needed, the function will test for the existence of data for one dc, one taxa, and one stage}
#'   \item{plot.type='step'}{creates Cumulated graphs for report_mig_mult.  Data are summed per day for different dc taxa and stages}
#'   \item{plot.type='multiple'}{Method to overlay graphs for report_mig_mult (multiple dc/taxa/stage in the same plot)}
#' }
#' @param x An object of class report_mig_mult
#' @param plot.type One of 'standard','step','multiple'. Defaut to \code{standard} the standard report_mig with dc and operation displayed, can also be \code{step} or 
#' \code{multiple} 
#' @param silent Stops most messages from being displayed
#' @param color Default NULL, argument passed for the plot.type='standard' method. A vector of color in the following order : (1) working, (2) stopped, (3:7) 1...5 types of operation,
#' (8:11) numbers, weight, NULL, NULL (if glass eel), (8:11)  measured, calculated, expert, direct observation for other taxa. If null will be set to brewer.pal(12,'Paired')[c(8,10,4,6,1,2,3,5,7)]
#' @param color_ope Default NULL, argument passed for the plot.type='standard' method. A vector of color for the operations. Default to brewer.pal(4,'Paired')
#' @param ... Additional arguments passed to matplot or plot if plot.type='standard', see ... in \link{fungraph_glasseel} and \link{fungraph}
#' @return Nothing, called for its side effect of plotting
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_mig_mult
#' @export
setMethod("plot", signature(x = "report_mig_mult", y = "missing"), definition = function(x,
				plot.type = "standard", color = NULL, color_ope = NULL, silent = FALSE, ...) {
			# print('entering plot function') report_mig_mult<-r_mig_mult;silent=FALSE
			report_mig_mult <- x
			the_taxa = report_mig_mult@taxa@data[report_mig_mult@taxa@data$tax_code %in% report_mig_mult@taxa@taxa_selected, ]
			the_stages = report_mig_mult@stage@data[report_mig_mult@stage@data$std_code %in% report_mig_mult@stage@stage_selected, ]
			lesdc = as.numeric(report_mig_mult@dc@dc_selected)
			# ==========================type=1=============================
			if (plot.type == "standard") {
				if (!silent)
					print("plot type standard")
				if (!silent)
					funout(gettext("Statistics about migration :\n", domain = "R-stacomiR"))
				# dcnum=1;taxanum=1;stagenum=2 &&&&&&&&&&&&&&&&&&&&&&&&&debut de
				# boucle&&&&&&&&&&&&&&&&&&&&&&&&&&&
				compte <- 0
				for (dcnum in 1:length(lesdc)) {
					for (taxanum in 1:nrow(the_taxa)) {
						for (stagenum in 1:nrow(the_stages)) {
							# dcnum=1;taxnum=1;stagenum=1
							taxa <- the_taxa[taxanum, "tax_nom_latin"]
							stage <- the_stages[stagenum, "std_libelle"]
							dc <- lesdc[dcnum]
							data <- report_mig_mult@calcdata[[stringr::str_c("dc_", dc)]][["data"]]
							data <- data[data$lot_tax_code == the_taxa[taxanum, "tax_code"] &
											data$lot_std_code == the_stages[stagenum, "std_code"], ]
							
							if (!is.null(data)) {
								if (nrow(data) > 0)
								{
									
									if (!silent) {
										funout(paste("dc=", dc, taxa = taxa, stage = stage, "\n"))
										funout("---------------------\n")
									}
									if (any(duplicated(data$No.pas)))
										stop("duplicated values in No.pas")
									data_without_hole <- merge(data.frame(No.pas = as.numeric(strftime(report_mig_mult@time.sequence,
																	format = "%j")) - 1, debut_pas = report_mig_mult@time.sequence),
											data, by = c("No.pas", "debut_pas"), all.x = TRUE)
									data_without_hole$CALCULE[is.na(data_without_hole$CALCULE)] <- 0
									data_without_hole$MESURE[is.na(data_without_hole$MESURE)] <- 0
									data_without_hole$EXPERT[is.na(data_without_hole$EXPERT)] <- 0
									data_without_hole$PONCTUEL[is.na(data_without_hole$PONCTUEL)] <- 0
									compte = compte + 1
									if (report_mig_mult@calcdata[[stringr::str_c("dc_", dc)]][["contient_poids"]] &
											taxa == "Anguilla anguilla" & (stage == "civelle" | stage ==
												"Anguilla jaune")) {
										
										#----------------------------------
										# report migration with weight (glass eel)
										#-----------------------------------------
										if (compte != 1)
											dev.new()
										fungraph_glasseel(report_mig = report_mig_mult, table = data_without_hole,
												time.sequence = report_mig_mult@time.sequence, taxa = taxa,
												stage = stage, dc = dc, color = color, color_ope = color_ope,
												silent, ...)
									} else {
										
										#----------------------------------
										# report migration standard
										#-----------------------------------------
										if (compte != 1)
											dev.new()
										# silent=TRUE
										fungraph(report_mig = report_mig_mult, tableau = data_without_hole,
												time.sequence = report_mig_mult@time.sequence, taxa,
												stage, dc, color = color, color_ope = color_ope, silent,
												...)
									}
								}  # end nrow(data)>0  
								# ecriture du report journalier, ecrit aussi le report
								# mensuel fn_Ecritreport_daily(report_mig_mult)
								
							}
						}
					}
				}
				# &&&&&&&&&&&&&&&&&&&&&&&&&fin de boucle&&&&&&&&&&&&&&&&&&&&&&&&&&&
			}
			# ==========================type=2=============================
			if (plot.type == "step") {

				grdata <- data.frame()
				for (i in 1:length(report_mig_mult@calcdata)) {
					data <- report_mig_mult@calcdata[[i]]$data
					# extracting similar columns (not those calculated)
					data <- data[, c("No.pas", "debut_pas", "fin_pas", "ope_dic_identifiant",
									"lot_tax_code", "lot_std_code", "MESURE", "CALCULE", "EXPERT", "PONCTUEL",
									"Effectif_total")]
					grdata <- rbind(grdata, data)
				}
				names(grdata) <- tolower(names(grdata))
				grdata <- as.data.frame(grdata %>%
								dplyr::group_by(debut_pas, no.pas) %>%
								dplyr::summarize(effectif_total = sum(effectif_total)) %>%
								dplyr::arrange(debut_pas))
				grdata_without_hole <- merge(data.frame(no.pas = as.numeric(strftime(report_mig_mult@time.sequence,
												format = "%j")) - 1, debut_pas = report_mig_mult@time.sequence), grdata,
						by = c("no.pas", "debut_pas"), all.x = TRUE)
				grdata_without_hole <- fun_date_extraction(grdata_without_hole, nom_coldt = "debut_pas",
						annee = FALSE, mois = TRUE, quinzaine = TRUE, semaine = TRUE, jour_an = TRUE,
						jour_mois = FALSE, heure = FALSE)
				grdata_without_hole <- grdata_without_hole[order(grdata_without_hole$no.pas),		]
				grdata_without_hole$effectif_total[is.na(grdata_without_hole$effectif_total)] <- 0
				
				grdata_without_hole$cumsum = cumsum(grdata_without_hole$effectif_total)
				annee = unique(strftime(as.POSIXlt(report_mig_mult@time.sequence), "%Y"))
				dis_commentaire = paste(as.character(report_mig_mult@dc@dc_selected),
						collapse = ",")
				update_geom_defaults("step", aes(size = 3))
				
				p <- ggplot(grdata_without_hole) + geom_step(aes(x = debut_pas, y = cumsum,
										colour = mois)) + ylab(gettext("Cumulative migration", domain = "R-stacomiR")) +
						theme(plot.title = element_text(size = 10, colour = "deepskyblue")) +
						xlab("mois") + scale_colour_manual(values = c(`01` = "#092360", `02` = "#1369A2",
										`03` = "#0099A9", `04` = "#009780", `05` = "#67B784", `06` = "#CBDF7C",
										`07` = "#FFE200", `08` = "#DB9815", `09` = "#E57B25", `10` = "#F0522D",
										`11` = "#912E0F", `12` = "#33004B")) + ggtitle(gettextf("Cumulative count %s, %s, %s, %s",
										dis_commentaire, paste(the_taxa$tax_nom_latin, collapse=", "), paste(the_stages$std_libelle, collapse=","), annee))
				print(p)
				assign("p", p, envir = envir_stacomi)
				assign("grdata", grdata_without_hole, envir_stacomi)
				if (!silent)
					funout(gettext("The plot has been assigned to p in envir_stacomi,write p<-get('p',envir_stacomi) to retrieve the object"))
				if (!silent)
					funout(gettext("The data for the plot have been assigned to envir_stacomi,write grdata<-get('grdata',envir_stacomi) to retrieve the object"))
				
			}
			# ==========================type=3=============================
			if (plot.type == "multiple") {
				grdata <- fun_aggreg_for_plot(report_mig_mult)
				if (length(unique(grdata$taxa)) == 1 & length(unique(grdata$stage)) == 1) {
					p <- ggplot(grdata, aes(x = debut_pas, y = effectif_total), fill = "black") +
							geom_bar(position = "stack", stat = "identity") + facet_grid(DC ~
											., scales = "free_y")
				} else if (length(unique(grdata$taxa)) == 1) {
					p <- ggplot(grdata, aes(x = debut_pas, y = effectif_total, fill = stage)) +
							geom_bar(position = "stack", stat = "identity") + facet_grid(DC ~
											., scales = "free_y") + scale_fill_brewer(palette = "Set2")
				} else if (length(unique(grdata$stage)) == 1) {
					p <- ggplot(grdata, aes(x = debut_pas, y = effectif_total, fill = taxa)) +
							geom_bar(position = "stack", stat = "identity") + facet_grid(DC ~
											., scales = "free_y") + scale_fill_brewer(palette = "Set2")
				} else {
					p <- ggplot(grdata, aes(x = debut_pas, y = effectif_total, fill = stage)) +
							geom_bar(position = "stack", stat = "identity") + facet_grid(DC +
											taxa ~ ., scales = "free_y") + scale_fill_brewer(palette = "Set2")
				}
				
				print(p)
				assign("p", p, envir = envir_stacomi)
				if (!silent)
					funout(gettext("The plot has been assigned to p in envir_stacomi,write p<-get('p',envir_stacomi) to retrieve the object"))
				assign("grdata", grdata, envir_stacomi)
				if (!silent)
					funout(gettext("The data for the plot have been assigned to envir_stacomi,write grdata<-get('grdata',envir_stacomi) to retrieve the object"))
				
			}
			# ==========================end / type=3=============================  
			return(invisible(NULL))
		})


#' summary for report_mig_mult 
#' calls functions funstat and funtable to create migration overviews
#' and generate csv and html output in the user data directory
#' @param object An object of class \code{\link{report_mig_mult-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters (not used there)
#' @return Nothing, runs funstat and funtable method for each DC
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_mig_mult
#' @export
setMethod("summary", signature = signature(object = "report_mig_mult"), definition = function(object,
				silent = FALSE, ...) {
			# report_mig_mult<-r_mig_mult; silent<-FALSE
			report_mig_mult <- object
			the_taxa = report_mig_mult@taxa@data[report_mig_mult@taxa@data$tax_code %in% report_mig_mult@taxa@taxa_selected, ]
			the_stages = report_mig_mult@stage@data[report_mig_mult@stage@data$std_code %in% report_mig_mult@stage@stage_selected, ]
			lesdc = as.numeric(report_mig_mult@dc@dc_selected)
			if (!silent)
				funout(gettext("Statistics about migration :\n", domain = "R-stacomiR"))
			# &&&&&&&&&&&&&&&&&&&&&&&&&debut de boucle&&&&&&&&&&&&&&&&&&&&&&&&&&&
			# dcnum=2;taxanum=1;stagenum=1
			for (dcnum in 1:length(lesdc)) {
				for (taxanum in 1:nrow(the_taxa)) {
					for (stagenum in 1:nrow(the_stages)) {
						
						taxa = the_taxa[taxanum, "tax_nom_latin"]
						stage = the_stages[stagenum, "std_libelle"]
						DC = lesdc[dcnum]
						
						# preparation du jeu de donnees pour la fonction fungraph_civ
						# developpee pour la classe report_mig
						data <- report_mig_mult@calcdata[[stringr::str_c("dc_", DC)]][["data"]]
						data <- data[data$lot_tax_code == the_taxa[taxanum, "tax_code"] &
										data$lot_std_code == the_stages[stagenum, "std_code"], ]
						
						if (!is.null(data)) {
							if (nrow(data) > 0) {
								
								if (any(duplicated(data$No.pas)))
									stop("duplicated values in No.pas")
								data_without_hole <- merge(data.frame(No.pas = as.numeric(strftime(report_mig_mult@time.sequence,
																format = "%j")) - 1, debut_pas = report_mig_mult@time.sequence),
										data, by = c("No.pas", "debut_pas"), all.x = TRUE)
								data_without_hole$CALCULE[is.na(data_without_hole$CALCULE)] <- 0
								data_without_hole$MESURE[is.na(data_without_hole$MESURE)] <- 0
								data_without_hole$EXPERT[is.na(data_without_hole$EXPERT)] <- 0
								data_without_hole$PONCTUEL[is.na(data_without_hole$PONCTUEL)] <- 0
								
								resum = funstat(tableau = data_without_hole, time.sequence = report_mig_mult@time.sequence,
										taxa, stage, DC, silent)
								# pb with posixt and xtable, removing posixt and setting
								# date instead
								data_without_hole$debut_pas <- as.Date(data_without_hole$debut_pas)
								data_without_hole <- data_without_hole[, -match("fin_pas", colnames(data_without_hole))]
								funtable(tableau = data_without_hole, time.sequence = report_mig_mult@time.sequence,
										taxa, stage, DC, resum, silent)
								
							}
						}
					}
				}
			}
			
			
		})



#' Method to print the command line of the object
#' @param x An object of class report_mig_mult
#' @param ... Additional parameters passed to print
#' @return NULL
#' @author cedric.briand
#' @aliases print.report_mig_mult
#' @export
setMethod("print", signature = signature("report_mig_mult"), definition = function(x,
				...) {
			sortie1 <- "report_mig_mult=new('report_mig_mult')\n"
			sortie2 <- stringr::str_c("report_mig_mult=choice_c(report_mig_mult,", "dc=c(",
					stringr::str_c(x@dc@dc_selected, collapse = ","), "),", "taxa=c(", stringr::str_c(shQuote(x@taxa@data$tax_nom_latin),
							collapse = ","), "),", "stage=c(", stringr::str_c(shQuote(x@stage@stage_selected),
							collapse = ","), "),", "datedebut=", shQuote(strftime(x@timestep@dateDebut,
									format = "%d/%m/%Y")), ",datefin=", shQuote(strftime(end_date(x@timestep),
									format = "%d/%m/%Y")), ")")
			# removing backslashes
			funout(stringr::str_c(sortie1, sortie2), ...)
			return(invisible(NULL))
		})

#' Function to calculate daily migration using overlaps functions
#' 
#' Function to calculate daily migration from migration monitoring whose length is more than one day,
#' this calculation relies on the (false) assumption that migration is evenly spread over time. 
#' @param time.sequence the time sequence to be filled in with new data
#' @param datasub the initial dataset
#' @param negative 'boolean', default FALSE, TRUE indicates a separate sum for negative and positive migrations
#' to time.sequence period and summed over the new sequence. A migration operation spanning several days will
#' be converted to 'daily' values assuming that the migration was regular over time. The function
#' returns one row per taxa, stages, counting device. It does not account for the destination of taxa. It returns
#' separate rows for quantities and numbers. Several columns are according to the type of measure (MESURE, CALCULE, PONCTUEL or EXPERT).
#' @return A data.frame with daily migrations
#' @seealso calcule,report_mig_mult-method
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
fun_report_mig_mult_overlaps <- function(time.sequence, datasub, negative = FALSE) {
	# browser()
	mat1 <- as.data.frame(cbind(as.numeric(time.sequence), as.numeric(time.sequence +
									as.difftime(1, units = "days"))))
	mat2 <- as.data.frame(cbind(as.numeric(datasub$ope_date_debut), as.numeric(datasub$ope_date_fin)))
	rownames(mat1) <- as.character(time.sequence)
	rownames(mat2) <- datasub$lot_identifiant
	imat1 <- intervals::Intervals(mat1)
	intervals::closed(imat1) <- c(FALSE, FALSE)
	imat2 <- intervals::Intervals(mat2)
	intervals::closed(imat2) <- c(FALSE, FALSE)
	listei <- intervals::interval_overlap(imat2, imat1)
	listei2 <- listei  # copie de la liste pour l'ecraser
	for (i in 1:length(listei)) {
		vec <- listei[[i]]
		if (length(vec) == 0) {
			# pas de lot
			listei2[[i]] = 0
		} else if (length(vec) == 1) {
			# l'ensemble du lot est inclus dans la journee
			listei2[[i]] = 1
		} else {
			# le premier jour va du debut de l'ope e la fin de la premiere date
			# puis n-2 jour puis le dernier jour de la date de debut e la fin
			# de l'ope
			idlot = names(listei)[i]
			tps = c(difftime(time.sequence[vec[1]] + as.difftime(1, units = "days"),
							datasub[datasub$lot_identifiant == idlot, "ope_date_debut"], units = "days"),
					rep(1, length(vec) - 2), difftime(datasub[datasub$lot_identifiant ==
											idlot, "ope_date_fin"], time.sequence[vec[length(vec)]], units = "days"))
			listei2[[i]] <- as.numeric(tps)/(as.numeric(sum(tps)))  # on ramene a 1
			stopifnot(all.equal(as.numeric(sum(listei2[[i]])), 1))
		}
	}
	
	# specific case of operations across two years In this case we want to
	# split the operation and retain only the part corresponding to the current
	# year beginning of the year initializing variable browser()
	overlapping_samples_between_year <- FALSE
	imat3 <- imat1[1, ]
	listei3 <- intervals::interval_overlap(imat2, imat3)
	# vector of samples (lot) which are overlapping between two years
	lots_across <- names(listei3)[vapply(listei3, function(X) length(X) > 0, NA)]
	if (length(lots_across) > 0) {
		overlapping_samples_between_year <- TRUE
		for (i in 1:length(lots_across)) {
			the_lot <- lots_across[i]
			duration_in_the_year <- as.numeric(difftime(datasub[datasub$lot_identifiant ==
											the_lot, "ope_date_fin"], time.sequence[1], units = "days"))
			duration_of_the_sample <- as.numeric(difftime(datasub[datasub$lot_identifiant ==
											the_lot, "ope_date_fin"], datasub[datasub$lot_identifiant == the_lot,
									"ope_date_debut"], units = "days"))
			listei2[[the_lot]] <- listei2[[the_lot]] * (duration_in_the_year/duration_of_the_sample)
			
		}
	}
	#######################  end of the year
	le <- length(time.sequence)
	mat3 <- as.data.frame(cbind(as.numeric(time.sequence[le] + as.difftime(1, units = "days")),
					as.numeric(time.sequence[le] + as.difftime(2, units = "days"))))
	imat3 <- intervals::Intervals(mat3)
	listei3 <- intervals::interval_overlap(imat2, imat3)
	# vector of samples (lot) which are overlapping between two years
	lots_across <- names(listei3)[vapply(listei3, function(X) length(X) > 0, NA)]
	if (length(lots_across) > 0) {
		overlapping_samples_between_year <- TRUE
		for (i in 1:length(lots_across)) {
			the_lot <- lots_across[i]
			duration_in_the_year <- as.numeric(difftime(time.sequence[length(time.sequence)] +
									lubridate::days(1), datasub[datasub$lot_identifiant == the_lot, "ope_date_debut"],
							units = "days"))
			duration_of_the_sample <- as.numeric(difftime(datasub[datasub$lot_identifiant ==
											the_lot, "ope_date_fin"], datasub[datasub$lot_identifiant == the_lot,
									"ope_date_debut"], units = "days"))
			listei2[[the_lot]] <- listei2[[the_lot]] * (duration_in_the_year/duration_of_the_sample)
			
		}
	}
	
	
	# df ['lot_identifiant','coef','ts.id'] lot_identifiant= identifiant du
	# lot, coef = part du lot dans chaque id_seq (sequence de jours), 'id_seq'
	# numero du jour creating a table with lot_identifiant, sequence, and the
	# coeff to apply
	df <- data.frame(lot_identifiant = rep(names(listei2), sapply(listei2, length)),
			coef = unlist(listei2), ts_id = unlist(listei))
	# dataframe corresponding to the whole time sequence
	df.ts = data.frame(debut_pas = time.sequence, fin_pas = time.sequence + as.difftime(1,
					units = "days"), ts_id = as.numeric(strftime(time.sequence, format = "%j")),
			stringsAsFactors = FALSE)
	dfts <- merge(df.ts, df, by = "ts_id")
	datasub1 <- merge(dfts, datasub, by = "lot_identifiant")
	datasub1$value <- as.numeric(datasub1$value)  # Otherwise rounded to integer
	# If negative negative and positive are treated separately and return one
	# row for each positive or negative value below coef is the part of the
	# operation within the current year
	if (negative) {
		
		the_negative <- datasub1 %>%
				dplyr::select(debut_pas, fin_pas, value, coef, type_de_quantite, ope_dic_identifiant,
						lot_tax_code, lot_std_code, lot_methode_obtention) %>%
				dplyr::filter(value < 0) %>%
				dplyr::group_by(ope_dic_identifiant, lot_tax_code, lot_std_code, lot_methode_obtention,
						debut_pas, fin_pas, type_de_quantite) %>%
				dplyr::summarize(value = sum(value * coef)) %>%
				dplyr::arrange(ope_dic_identifiant, debut_pas, lot_tax_code, lot_std_code,
						type_de_quantite)
		
		the_positive <- datasub1 %>%
				dplyr::select(debut_pas, fin_pas, value, coef, type_de_quantite, ope_dic_identifiant,
						lot_tax_code, lot_std_code, lot_methode_obtention) %>%
				dplyr::filter(value >= 0) %>%
				dplyr::group_by(ope_dic_identifiant, lot_tax_code, lot_std_code, lot_methode_obtention,
						debut_pas, fin_pas, type_de_quantite) %>%
				dplyr::summarize(value = sum(value * coef)) %>%
				dplyr::arrange(ope_dic_identifiant, debut_pas, lot_tax_code, lot_std_code,
						type_de_quantite)
		
		datasub2 <- as.data.frame(rbind(the_negative, the_positive))
		
	} else {
		datasub2 <- as.data.frame(datasub1 %>%
						dplyr::select(debut_pas, fin_pas, value, coef, type_de_quantite, ope_dic_identifiant,
								lot_tax_code, lot_std_code, lot_methode_obtention) %>%
						dplyr::group_by(ope_dic_identifiant, lot_tax_code, lot_std_code, lot_methode_obtention,
								debut_pas, fin_pas, type_de_quantite) %>%
						dplyr::summarize(value = sum(value * coef)) %>%
						dplyr::arrange(ope_dic_identifiant, debut_pas, lot_tax_code, lot_std_code,
								type_de_quantite))
		
	}
	# if some samples overlap between the current year and the year arround the
	# current year, then the calculation will have hampered our numbers of a
	# small amount and the following test is not expected to be TRUE.
	if (!overlapping_samples_between_year)
		# note 2020 I'm getting this strange results that I don't understand
		# round(sum(datasub$value, na.rm = TRUE), 2) and
		# round(sum(datasub2$value, na.rm = TRUE), 2) are not equal: Mean
		# relative difference: 0.000996741 so rounded values by 2 digits are
		# not equal ???? # changed test to 0.1 browser()
		# 2021 same issue when running the vignette but don't see any difference in the browser() ?
		if (!abs(round(sum(datasub$value, na.rm = TRUE), 2) - round(sum(datasub2$value,
								na.rm = TRUE), 2)) < 0.1) warnings(
					paste("the numbers are different between raw numbers",
							round(sum(datasub$value, na.rm = TRUE), 2),
							"and number recalculated per day",
							round(sum(datasub2$value,	na.rm = TRUE),2)))
	datasub3 <- reshape2::dcast(datasub2, debut_pas + fin_pas + ope_dic_identifiant +
					lot_tax_code + lot_std_code + type_de_quantite ~ lot_methode_obtention, value.var = "value")
	if (!"MESURE" %in% colnames(datasub3))
		datasub3$MESURE = 0
	if (!"CALCULE" %in% colnames(datasub3))
		datasub3$CALCULE = 0
	if (!"EXPERT" %in% colnames(datasub3))
		datasub3$EXPERT = 0
	if (!"PONCUTEL" %in% colnames(datasub3))
		datasub3$PONCTUEL = 0
	datasub3$MESURE[is.na(datasub3$MESURE)] <- 0
	datasub3$CALCULE[is.na(datasub3$CALCULE)] <- 0
	datasub3$EXPERT[is.na(datasub3$EXPERT)] <- 0
	datasub3$PONCTUEL[is.na(datasub3$PONCTUEL)] <- 0
	# pour compatibilite
	datasub3 <- cbind(data.frame(No.pas = as.numeric(strftime(datasub3$debut_pas,
									format = "%j")) - 1), datasub3)
	datasub3$Effectif_total = rowSums(datasub3[, c("MESURE", "CALCULE", "EXPERT",
							"PONCTUEL")])
	return(datasub3)
}



#' Calculate daily migration by simple repartition
#' 
#' Function to calculate daily migration from migration monitoring whose length is less than one day,
#'  typically video recording whose period are instant events.
#' @param time.sequence the time sequence to be filled in with new data
#' @param datasub the initial dataset
#' @param negative 'boolean', default FALSE, TRUE indicates a separate sum for negative and positive migrations
#' @return A data.frame with number summed over over the time.sequence. 
#' The function returns the same output than \link{fun_report_mig_mult_overlaps}
#' but is intended to work faster. In the data.frame, the total number is 
#' 'Effectif_total' and corresponds to the addition of numbers and numbers converted from weight,
#' the total weight is 'Poids_total'+'poids_depuis_effectifs' and corresponds to weighed glass eel plus glass eel number converted in weights.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
fun_report_mig_mult <- function(time.sequence, datasub, negative = FALSE) {    
	df.ts = data.frame(debut_pas = time.sequence, fin_pas = time.sequence + as.difftime(1,
					units = "days"), ts_id = strftime(time.sequence, format = "%j"), stringsAsFactors = FALSE)
	datasub$ts_id <- strftime(datasub$ope_date_debut, format = "%j")
	datasub1 <- merge(df.ts, datasub, by = "ts_id")
	if (negative) {
		
		the_negative <- datasub1 %>%
				dplyr::select(debut_pas, fin_pas, value, type_de_quantite, ope_dic_identifiant,
						lot_tax_code, lot_std_code, lot_methode_obtention) %>%
				dplyr::filter(value < 0) %>%
				dplyr::group_by(ope_dic_identifiant, lot_tax_code, lot_std_code, lot_methode_obtention,
						debut_pas, fin_pas, type_de_quantite) %>%
				dplyr::summarize(value = sum(value)) %>%
				dplyr::arrange(ope_dic_identifiant, debut_pas, lot_tax_code, lot_std_code,
						type_de_quantite)
		
		the_positive <- datasub1 %>%
				dplyr::select(debut_pas, fin_pas, value, type_de_quantite, ope_dic_identifiant,
						lot_tax_code, lot_std_code, lot_methode_obtention) %>%
				dplyr::filter(value >= 0) %>%
				dplyr::group_by(ope_dic_identifiant, lot_tax_code, lot_std_code, lot_methode_obtention,
						debut_pas, fin_pas, type_de_quantite) %>%
				dplyr::summarize(value = sum(value)) %>%
				dplyr::arrange(ope_dic_identifiant, debut_pas, lot_tax_code, lot_std_code,
						type_de_quantite)
		
		datasub2 <- as.data.frame(rbind(the_negative, the_positive))
		
	} else {
		datasub2 <- as.data.frame(datasub1 %>%
						dplyr::select(debut_pas, fin_pas, value, type_de_quantite, ope_dic_identifiant,
								lot_tax_code, lot_std_code, lot_methode_obtention) %>%
						dplyr::group_by(ope_dic_identifiant, lot_tax_code, lot_std_code, lot_methode_obtention,
								debut_pas, fin_pas, type_de_quantite) %>%
						dplyr::summarize(value = sum(value)) %>%
						dplyr::arrange(ope_dic_identifiant, debut_pas, lot_tax_code, lot_std_code,
								type_de_quantite))
		
	}
	# note 2020 I'm getting this strange results that I don't understand
	# round(sum(datasub$value, na.rm = TRUE), 2) and
	# round(sum(datasub2$value, na.rm = TRUE), 2) are not equal: Mean
	# relative difference: 0.000996741 so rounded values by 2 digits are
	# not equal ???? # changed test to 0.1 
	# 2021 same issue when running the vignette but don't see any difference in the browser() ?
	# maybe due to different time settings on the machine so it's converted to a warning
	if (!abs(round(sum(datasub$value, na.rm = TRUE), 2) - round(sum(datasub2$value,
							na.rm = TRUE), 2)) < 0.1) warnings(
				paste("the numbers are different between raw numbers",
						round(sum(datasub$value, na.rm = TRUE), 2),
						"and number recalculated per day",
						round(sum(datasub2$value,	na.rm = TRUE),2)))
	datasub3 <- reshape2::dcast(datasub2, debut_pas + fin_pas + ope_dic_identifiant +
					lot_tax_code + lot_std_code + type_de_quantite ~ lot_methode_obtention, value.var = "value")
	if (!"MESURE" %in% colnames(datasub3))
		datasub3$MESURE = 0
	if (!"CALCULE" %in% colnames(datasub3))
		datasub3$CALCULE = 0
	if (!"EXPERT" %in% colnames(datasub3))
		datasub3$EXPERT = 0
	if (!"PONCTUEL" %in% colnames(datasub3))
		datasub3$PONCTUEL = 0
	datasub3$MESURE[is.na(datasub3$MESURE)] <- 0
	datasub3$CALCULE[is.na(datasub3$CALCULE)] <- 0
	datasub3$EXPERT[is.na(datasub3$EXPERT)] <- 0
	datasub3$PONCTUEL[is.na(datasub3$PONCTUEL)] <- 0
	datasub3 <- cbind(data.frame(No.pas = as.numeric(strftime(datasub3$debut_pas,
									format = "%j")) - 1), datasub3)
	datasub3$Effectif_total = rowSums(datasub3[, c("MESURE", "CALCULE", "EXPERT",
							"PONCTUEL")])
	return(datasub3)
}

#' returns a table where weights and number are calculated from number and weights respectively
#' performs a query to collect the conversion coefficients
#' @param tableau Table issued from report_mig
#' @param time.sequence Time sequence from report_mig
#' @param silent If silent=TRUE do not display messages
#' @return tableau, the data frame with weight converted to numbers
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
fun_weight_conversion = function(tableau, time.sequence, silent) {
	if (!silent)
		funout(gettextf("dc=%s Conversion weight / number\n", unique(tableau$ope_dic_identifiant)))
	nr <- nrow(unique(tableau[, c("debut_pas", "lot_tax_code", "lot_std_code")]))
	tableaupoids = subset(tableau, tableau$type_de_quantite == "poids")
	tableaueffectif = subset(tableau, tableau$type_de_quantite == "effectif")
	tableaueffectif = tableaueffectif[, c("No.pas", "lot_tax_code", "lot_std_code",
					"CALCULE", "MESURE", "EXPERT", "PONCTUEL", "Effectif_total")]
	tableaudesdeux = tableau[, c("No.pas", "debut_pas", "fin_pas", "ope_dic_identifiant",
					"lot_tax_code", "lot_std_code", "coe_valeur_coefficient")]
	tableaudesdeux = tableaudesdeux[!duplicated(tableaudesdeux[, c("No.pas", "lot_tax_code",
									"lot_std_code")]), ]
	# Conversion des poids en effectifs
	tableauconvert = tableaupoids[, c("MESURE", "CALCULE", "EXPERT", "PONCTUEL",
					"Effectif_total")]
	tableauconvert = tableauconvert * tableaupoids$coe_valeur_coefficient  # les coeff sont du type 2.54 et non 0.3
	if (sum(tableaupoids$coe_valeur_coefficient) == 0)
		funout(gettext("Careful sum=0, you didn't enter the coefficient of conversion\n",
						domain = "R-stacomiR"))
	# creation d'une tableau (matricepoids) a 5 colonnes comprenant les
	# effectifs convertis
	matricepoids = cbind(tableaupoids[, c("No.pas", "lot_tax_code", "lot_std_code")],
			tableauconvert, tableaupoids[, c("MESURE", "CALCULE", "EXPERT", "PONCTUEL",
							"Effectif_total")])
	dimnames(matricepoids) = list(1:length(tableaupoids[, 1]), c("No.pas", "lot_tax_code",
					"lot_std_code", "MESURE", "CALCULE", "EXPERT", "PONCTUEL", "Effectif_total",
					"poids_MESURE", "poids_CALCULE", "poids_EXPERT", "poids_PONCTUEL", "Poids_total"))
	tableau = merge(tableaudesdeux, tableaueffectif, by = c("No.pas", "lot_tax_code",
					"lot_std_code"), all.x = TRUE, all.y = FALSE)
	tableau = merge(tableau, matricepoids, all.x = TRUE, all.y = FALSE, by = c("No.pas",
					"lot_tax_code", "lot_std_code"), sort = TRUE, suffixes = c(".e", ".p"))
	# je vire les NA
	tableau[is.na(tableau)] = 0
	tableau$MESURE = tableau$MESURE.e + tableau$MESURE.p
	tableau$CALCULE = tableau$CALCULE.e + tableau$CALCULE.p
	tableau$EXPERT = tableau$EXPERT.e + tableau$EXPERT.p
	tableau$PONCTUEL = tableau$PONCTUEL.e + tableau$PONCTUEL.p
	tableau$Effectif_total = tableau$Effectif_total.e + tableau$Effectif_total.p
	tableau[, "poids_depuis_effectifs"] = tableau[, "Effectif_total.e"]/tableau$coe_valeur_coefficient
	stopifnot(nr == nrow(tableau))
	return(tableau)
}

#' Calculates a data.frame where all components within the list calcdata are aggregated
#' and formatted for plot
#' @param object An object of class \link{report_mig_mult-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return A data.frame
#' @export
fun_aggreg_for_plot <- function(object) {
	if (!inherits(object , "report_mig_mult"))
		stop("This function must have for argument an object of class report_mig_mult")
	the_taxa = paste(object@taxa@data[object@data$tax_code %in% object@taxa@taxa_selected,"tax_nom_latin"], collapse = ",")
	the_stages = paste(object@stage@data[object@data$std_code %in% object@stage@stage_selected,"std_libelle"], collapse = ",")
	grdata <- data.frame()
	for (i in 1:length(object@calcdata)) {
		data <- object@calcdata[[i]]$data
		# extracting similar columns (not those calculated)
		data <- data[, c("No.pas", "debut_pas", "fin_pas", "ope_dic_identifiant",
						"lot_tax_code", "lot_std_code", "MESURE", "CALCULE", "EXPERT", "PONCTUEL",
						"Effectif_total")]
		grdata <- rbind(grdata, data)
	}
	names(grdata) <- tolower(names(grdata))
	grdata <- fun_date_extraction(grdata, nom_coldt = "debut_pas", annee = FALSE,
			mois = TRUE, quinzaine = TRUE, semaine = TRUE, jour_an = TRUE, jour_mois = FALSE,
			heure = FALSE)
	annee = unique(strftime(as.POSIXlt(object@time.sequence), "%Y"))
	dis_commentaire = paste(as.character(object@dc@dc_selected), collapse = ",")
	grdata <- stacomirtools::chnames(grdata, c("ope_dic_identifiant", "lot_tax_code",
					"lot_std_code"), c("DC", "taxa", "stage"))
	grdata$DC <- as.factor(grdata$DC)
	grdata$taxa <- as.factor(grdata$taxa)
	return(grdata)
}




# Nom fichier : ref_env (classe) Date de creation : 02/01/2009 15:02:40

#' Class 'ref_env'
#' 
#' Enables to load measure stations and to select one of them
#' 
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_env', ...)}. 
#' @slot dataframe Data concerning the
#' measure station
#' @slot env_selected The selected measure station 
#' @author cedric.briand@eptb-vilaine.fr
#' @keywords classes
setClass(Class = "ref_env", representation = 
				representation(data = "data.frame",
						env_selected="character"),
    prototype = prototype(
				data = data.frame(),
				env_selected=character()))

#' Loading method for ref_env referential object
#' @return An S4 object of class ref_env with data loaded from the database
#' @param object An object of class \link{ref_env-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_env')
#'  charge(object)
#' }
setMethod("charge", signature = signature("ref_env"), definition = function(object) {
    requete = new("RequeteDB")
    requete@sql = paste("SELECT stm_identifiant, stm_libelle, stm_sta_code, stm_par_code, stm_description",
        " FROM ", get_schema(), "tj_stationmesure_stm", " ORDER BY stm_identifiant;",
        sep = "")
    requete@silent = TRUE
    requete <- stacomirtools::query(requete)
    object@data <- requete@query
    return(object)
})



#' Command line interface to select a monitoring  station
#' 
#' the choice_c method is intended to have the same behaviour as choice (which creates a
#' widget in the graphical interface) but from the command line. 
#' @param object an object of class ref_env
#' @param stationMesure a character vector of the monitoring station code (corresponds to stm_libelle in the tj_stationmesure_stm table)
#' @return an object of class \link{ref_env-class} with the monitoring station selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod("choice_c", signature = signature("ref_env"), definition = function(object,
    stationMesure) {
    if (!inherits(stationMesure, "character")) {
        stop("the stationmesure should be of class character")
    }
    if (length(stationMesure) == 0) {
        stop("Select at least one value\n")
    }
    if (any(is.na(stationMesure))) {
        stop("NA values for stationmesure")
    }
    # I can use the stm_libelle as there is a unique constraint in the table
    libellemanquants <- stationMesure[!stationMesure %in% object@data$stm_libelle]
    if (length(libellemanquants) > 0)
        warning(gettextf("stationmesure code not present :\n %s", stringr::str_c(libellemanquants,
            collapse = ", "), domain = "R-stacomiR"))
    object@env_selected <- object@data$stm_libelle[object@data$stm_libelle %in% stationMesure]
    assign("ref_env", object, envir_stacomi)
    return(object)
})

#' class report_env simple output of one or several environmental
#' conditions...
#' 
#' Annual overview of environmental conditions. This class enables to draw some plot, but will mostly used to build
#' joined graphs crossing the information from \link{report_mig_mult-class} and \link{report_mig_env-class}
#' 
#' @include ref_horodate.R 
#' @include ref_env.R
#' @include create_generic.R
#' @include utilities.R
#' @slot horodatedebut \link{ref_horodate-class}
#' @slot horodatefin \link{ref_horodate-class}
#' @slot stationMesure \link{ref_env-class}
#' @slot data \code{data.frame}
#' @author cedric.briand@eptb-vilaine.fr
#' @family report Objects
#' @keywords classes
#' @aliases report_env
#' @keywords classes
#' @example inst/examples/report_env-example.R
#' @export
setClass(Class = "report_env", representation = representation(stationMesure = "ref_env",
    horodatedebut = "ref_horodate", horodatefin = "ref_horodate", data = "data.frame"),
    prototype = prototype(horodatedebut = new("ref_horodate"), horodatefin = new("ref_horodate"),
        stationMesure = new("ref_env"), data = data.frame()))


#' connect method for report_env class
#' @param object An object of class \link{report_env-class}
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return An object of class \link{report_env-class} with slot data filled from the database
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases connect.report_env
setMethod("connect", signature = signature("report_env"), definition = function(object,
    silent = FALSE) {
    # object<-r_env
			if (length(object@stationMesure@env_selected)==0) warning("No measure station selected")
			stm_selected <- object@stationMesure@data[object@stationMesure@data$stm_libelle %in% object@stationMesure@env_selected,"stm_identifiant"]

    requete = new("RequeteDBwheredate")
    requete@datedebut = strptime(object@horodatedebut@horodate, format = "%Y-%m-%d")
    requete@datefin = strptime(object@horodatefin@horodate, format = "%Y-%m-%d")
    requete@colonnedebut = "env_date_debut"
    requete@colonnefin = "env_date_fin"
    requete@select = paste("SELECT", " env_date_debut,", " env_date_fin,", " env_methode_obtention,",
        " val_libelle as env_val_identifiant,", " env_valeur_quantitatif,", " env_stm_identifiant",
        " FROM ", get_schema(), "tj_conditionenvironnementale_env",
        " LEFT JOIN ref.tr_valeurparametrequalitatif_val on env_val_identifiant=val_identifiant",
        sep = "")
    requete@order_by <- "ORDER BY env_stm_identifiant, env_date_debut"
    tmp <- vector_to_listsql(stm_selected)
    requete@and = paste(" AND env_stm_identifiant IN ", tmp)
    requete <- stacomirtools::query(requete)
    object@data <- stacomirtools::killfactor(stacomirtools::getquery(requete))
    if (!silent)
        funout(gettext("Environmental conditions loading query completed\n", domain = "R-stacomiR"))
    return(object)
})
#' command line interface for report_env class
#' 
#' The choice_c method fills in the data slot for \link{ref_env-class} by runnning the charge method of this object.
#' It then runs the choice method on this object. It also applies the choice method for objects of class \link{ref_horodate-class}
#' @param object An object of class \link{report_env-class}
#' @param stationMesure A character, the code of the monitoring station, which records environmental parameters \link{choice_c,ref_env-method}
#' @param datedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param datefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
#' @param silent Boolean default FALSE, if TRUE information messages not displayed.
#' @return An object of class \link{report_env-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_env
setMethod("choice_c", signature = signature("report_env"), definition = function(object,
    stationMesure, datedebut, datefin, silent = FALSE) {
    # code for debug using r_mig example
    # stationmesure=c('temp_gabion','coef_maree');datedebut='2008-01-01';datefin='2008-12-31';silent=FALSE
    r_env <- object
    r_env@stationMesure = charge(r_env@stationMesure)
    # loads and verifies the stationmesure (selects the relevant lines in the
    # table
    r_env@stationMesure <- choice_c(object = r_env@stationMesure, stationMesure)
    r_env@horodatedebut <- choice_c(object = r_env@horodatedebut, nomassign = "report_env_date_debut",
        funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
        horodate = datedebut, silent = silent)
    r_env@horodatefin <- choice_c(r_env@horodatefin, nomassign = "report_env_date_fin",
        funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
        horodate = datefin, silent = silent)
    return(r_env)
})
#' charge method for report_env class
#' @param object An object of class \link{report_env-class}
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases charge.report_env
#' @return An object of class \link{report_env-class} with data set from values assigned in \code{envir_stacomi} environment
#' @keywords internal
setMethod("charge", signature = signature("report_env"), definition = function(object,
    silent) {

    if (exists("ref_env", envir_stacomi)) {
        object@stationMesure <- get("ref_env", envir_stacomi)
    } else {
        funout(gettext("You need to choose a monitoring station, clic on validate\n",
            domain = "R-stacomiR"), arret = TRUE)
    }

    if (exists("report_env_date_debut", envir_stacomi)) {
        object@horodatedebut@horodate <- get("report_env_date_debut", envir_stacomi)
    } else {
        funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
            arret = TRUE)
    }

    if (exists("report_env_date_fin", envir_stacomi)) {
        object@horodatefin@horodate <- get("report_env_date_fin", envir_stacomi)
    } else {
        funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
            arret = TRUE)
    }
    return(object)
})

#' Plot method for report_env
#' @param x An object of class \link{report_env-class}
#' @param silent Stops displaying the messages
#' @return Nothing, called for its side effect of plotting data
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_env
#' @export
setMethod("plot", signature(x = "report_env", y = "missing"), definition = function(x,
    silent = FALSE) {
    # le dataframe contenant le res de la requete
    r_env <- x
    dat <- r_env@data
    if (length(unique(dat$env_stm_identifiant)) != 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(unique(dat$env_stm_identifiant)),
            1, just = "center")))
        lesGraphes = list()
        if (length(unique(dat$env_stm_identifiant)) != nrow(r_env@stationMesure@data)) {
            funout(gettext("Some monitoring stations lack associated values (no environmental data)\n",
                domain = "R-stacomiR"))
        }

        # for all stationmesure selected
        for (i in 1:length(unique(dat$env_stm_identifiant))) {
            # the identifier of the current station
            stmidentifiant <- unique(dat$env_stm_identifiant)[i]

            # the line of report_env@stationMesure currently processed in the
            # loop
            stm <- r_env@stationMesure@data[r_env@stationMesure@data$stm_identifiant ==
                stmidentifiant, ]

            # all measures for the selected station
            nameColonne <- as.character(stm$stm_libelle)
            datstm <- stacomirtools::chnames(dat, "env_valeur_quantitatif", nameColonne)
            datstm <- datstm[datstm$env_stm_identifiant == stmidentifiant, ]

            # creating the plot
            g <- ggplot(datstm, aes_string(x = "env_date_debut", y = nameColonne))
            g <- g + geom_line(aes_string(colour = nameColonne)) + scale_y_continuous(stm$stm_libelle) +
                scale_x_datetime(name = "date")

            # printing plot on screen
            print(g, vp = vplayout(i, 1))
        }
    } else {
        funout(gettext("No environmental conditions values for selected monitoring stations (report_env.R)\n",
            domain = "R-stacomiR"), arret = TRUE)
    }
		return(invisible(NULL))
})

#' Class 'ref_par'
#' 
#' Class enabling to load the list of parameters and select one of them
#' @include create_generic.R
#' @slot data A data.frame
#' @slot par_selected A character vector corresponding to par_code
#' @section Objects from the Class: Objects can be created by calls of the form
#' @author cedric.briand@eptb-vilaine.fr
#' @keywords classes
#' @slot data='data.frame' the list of parameters
#' @family referential objects
setClass(Class = "ref_par", representation = representation(data = "data.frame",
    par_selected = "character"))


setValidity("ref_par", method = function(object) {
    if (length(object@par_selected) != 0) {
        if (nrow(object@data) > 0) {
            concord <- object@par_selected %in% object@data$par_code
            if (any(!concord)) {
                return(paste("No data for par", object@par_selected[!concord]))

            } else {
                return(TRUE)
            }
        } else {
            return("You tried to set a value for par_selected without initializing the data slot")
        }
    } else return(TRUE)

})
#' Loading method for ref_par referential objects
#' @aliases charge.ref_par
#' @param object An object of class \link{ref_par-class}
#' @return An S4 object of class ref_par
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An S4 object of class \link{ref_par-class} 
#' @examples 
#' \dontrun{
#'  object=new('ref_par')
#' charge(object)
#' }
setMethod("charge", signature = signature("ref_par"), definition = function(object) {
    requete = new("RequeteDB")
    requete@sql = paste("SELECT par_code, par_nom, par_unite, par_nature, par_definition  from ref.tg_parametre_par")
    requete <- stacomirtools::query(requete)
    #funout(gettext("Loading parameters query completed\n", domain = "R-stacomiR"))
    object@data <- requete@query
    return(object)
})


#' Loading method for \code{ref_par referential} objects searching only those parameters existing for a DC, a Taxa, and a stage
#' @aliases charge_with_filter.ref_par
#' @param object An object of class \link{ref_par-class}
#' @param dc_selected A counting device selected for the report 
#' @param taxa_selected The taxa selected for the report
#' @param stage_selected The stage selected for the report
#' @return An S4 object of class \link{ref_par-class} 
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_par')
#' charge_with_filter(object,dc_selected=6,taxa_selected=2038,stage_selected=c('AGJ','CIV'))
#' }
setMethod("charge_with_filter", signature = signature("ref_par"), definition = function(object,
    dc_selected, taxa_selected, stage_selected) {
    requete = new("RequeteDBwhere")
    requete@select = paste("SELECT DISTINCT ON (par_code) par_code, par_nom, par_unite, par_nature, par_definition", " FROM ",
				get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
        " JOIN ", get_schema(), "tj_caracteristiquelot_car on car_lot_identifiant=lot_identifiant",
        " JOIN ref.tg_parametre_par on par_code=car_par_code", sep = "")
    requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected))
    requete@and = paste("and lot_tax_code in", vector_to_listsql(taxa_selected),
        " and lot_std_code in ", vector_to_listsql(stage_selected), sep = "")
    requete@order_by = "ORDER BY par_code"
    requete <- stacomirtools::query(requete)
    object@data <- requete@query
    if (nrow(object@data) == 0)
        funout(gettext("No data for selected device, taxa and stage\n", domain = "R-stacomiR"),
            arret = TRUE)
    return(object)
})


#' Command line interface to select a parameter
#' 
#' @aliases choice_c.ref_par
#' @param object an object of class  \link{ref_par-class}
#' @param par A character vector of par
#' @param silent Default FALSE but not used there
#' @return An object of class \link{ref_par-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod("choice_c", signature = signature("ref_par"), definition = function(object,
    par, silent = FALSE) {
    if (inherits(par , "numeric")) {
        par <- as.character(par)
    }
    if (any(is.na(par)))
        stop("NA values par")
    object@par_selected <- par
    if (nrow(object@data) == 0) {
        stop("Internal error : tried to set a value for par_selected without initializing the data slot")
    }
    # validObject(object,test=FALSE) here I don't want to generate an error if
    # parm is not present so I'm not using the validObject which will throw and
    # error
    concord <- object@par_selected %in% object@data$par_code

    if (any(!concord)) {
        warning(paste(gettextf("No data for par %s", object@par_selected[!concord],
            domain = "R-stacomiR")))
    }
		# to work with daughter class
		if (inherits(object, "ref_parquan")) {
			assign("ref_parquan", object, envir = envir_stacomi)
			} else if (inherits(object, "ref_parqual")){
				assign("ref_parqual", object, envir = envir_stacomi)	
			} else {
				assign("ref_par", object, envir = envir_stacomi)
			}				

    return(object)
})




#' Graph function for glass eel migration. Differs from fungraph as it does not
#' draw the ggplot graph for month
#'
#' This graph will also plot numbers and bars according to whether the glass
#' eel have been counted through weight or numbers
#'
#'
#' @param report_mig an object of class \link{report_mig-class} or an
#' object of class \link{report_mig_mult-class}
#' @param table a data frame with the results
#' @param time.sequence a vector POSIXt
#' @param taxa the species
#' @param stage the stage
#' @param dc the counting device, default to null, only necessary for \link{report_mig_mult-class}
#' @param silent Message displayed or not
#' @param color Default NULL, a vector of length 11 of color in the following order, numbers, weight, working, stopped, 1...5 types of operation,
#' the 2 latest colors are not used but kept for consistency with fungraph
#' for the fishway, if null will be set to brewer.pal(12,"Paired")[c(4,6,1,2,3,5,7,8,10,11,12)]
#' @param color_ope Default NULL, a vector of color for the operations. Default to brewer.pal(4,"Paired")
#' @param ... additional parameters passed to plot, main, ylab, cex.main, font.main, type, xlim, ylim, lty, bty, pch
#' it is not possible to change xlim
#' @return No return value, called for side effects
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
fungraph_glasseel = function(report_mig,
		table,
		time.sequence,
		taxa,
		stage,
		dc = null,
		silent,
		color = NULL,
		color_ope = NULL,
		...) {
	oldpar <- par(no.readonly = TRUE) 
	on.exit(par(oldpar))  
	# color=null
	# color calculation
	if (is.null(color)) {
		tp <- RColorBrewer::brewer.pal(12, "Paired")
		mypalette = c(
				"working" = tp[4],
				# green
				"stopped" = tp[6],
				# red
				"Fonc normal" =  tp[1],
				"Arr ponctuel" = tp[2], 
				"Arr maintenance" = tp[3],
				"Dysfonc" = tp[5], 						
				"Non connu" =  tp[7],
				"eff" = tp[8],
				#orange
				"weight" = tp[10],
				#purple
				"unused1" = tp[11],
				"unused1" = tp[12]
		)
	} else {
		if (length(color) != 11)
			stop("The length of color must be 11")
		mypalette = c(
				"working" = color[1],
				"stopped" = color[2],
				"Fonc normal" = color[3],
				"Arr ponctuel" = color[4],
				"Arr maintenance" = color[5],
				"Dysfonc" = color[6],
				"Non connu" = color[7],
				"eff" = color[8],
				"weight" = color[9],
				"unused1" = color[10],
				"unused2" = color[11]
		)
	}
	
	
	if (is.null(color_ope)) {
		if (stacomirtools::is.odd(dc))
			brew = "Paired"
		else
			brew = "Accent"
		color_ope = RColorBrewer::brewer.pal(8, brew)
	}
	
	if (is.null(dc))
		dc = report_mig@dc@dc_selected[1]
	annee = paste(unique(strftime(as.POSIXlt(time.sequence), "%Y")), collapse =
					",")
	mois = months(time.sequence)
	jour = strftime(as.POSIXlt(time.sequence), "%j")
	index = table$No.pas + 1
	eff = table$Effectif_total
	eff.p = table$Effectif_total.p
	debut = unclass(as.Date(time.sequence[min(index)]))[[1]]
	fin = unclass(as.Date(time.sequence[max(index)]))[[1]]
	eff[eff == 0] <- NA #for graph need
	eff.p[eff.p == 0] <- NA
	dis_commentaire =  as.character(report_mig@dc@data$dis_commentaires[report_mig@dc@data$dc %in%
							dc])
	if (!silent)
		funout(gettextf("Glass eels graph %s\n", dis_commentaire))
	###################################
	# Graph annuel couvrant sequence >0
	####################################
	
	vec <- c(rep(1, 15), rep(2, 2), rep(3, 2), 4, rep(5, 6))
	mat <- matrix(vec, length(vec), 1)
	layout(mat)
	#par("bg"=grDevices::gray(0.8))
	graphics::par("mar" = c(3, 4, 3, 2) + 0.1)
	dots <- list(...)
	if (!"main" %in% names(dots))
		main = gettextf("Glass eels graph %s, %s, %s, %s",
				dis_commentaire,
				taxa,
				stage,
				annee,
				domain = "R-stacomiR")
	else
		main = dots[["main"]]
	if (!"ylab" %in% names(dots))
		ylab = gettext("Number of glass eels (x1000)", domain = "R-stacomiR")
	else
		ylab = dots[["ylab"]]
	if (!"cex.main" %in% names(dots))
		cex.main = 1
	else
		cex.main = dots[["cex.main"]]
	if (!"font.main" %in% names(dots))
		font.main = 1
	else
		font.main = dots[["font.main"]]
	if (!"type" %in% names(dots))
		type = "h"
	else
		type = dots[["type"]]
	if (!"xlim" %in% names(dots))
		xlim = c(debut, fin)
	else
		xlim = dots[["xlim"]]
	if (!"ylim" %in% names(dots))
		ylim = c(0, max(eff / 1000, na.rm = TRUE)) * 1.2
	else
		xlim = c(debut, fin)#dots[["xlim"]] # currently this argument is ignored
	if (!"cex" %in% names(dots))
		cex = 1
	else
		cex = dots[["cex"]]
	if (!"lty" %in% names(dots))
		lty = 1
	else
		lty = dots[["lty"]]
	if (!"pch" %in% names(dots))
		pch = 16
	else
		pch = dots[["pch"]]
	if (!"bty" %in% names(dots))
		bty = "l"
	else
		bty = dots[["bty"]]
	plot(
			x = as.Date(time.sequence, "Europe/Paris"),
			y = eff / 1000,
			col = mypalette["eff"],
			type = type,
			xlim = xlim,
			ylim = ylim,
			lty = lty,
			xaxt = "n",
			ylab = ylab,
			#xlab="date",
			cex.main = cex.main,
			font.main = font.main,
			main = main,
			cex = cex,
			pch = pch,
			bty = bty
	)
	#print(plot,position = c(0, .3, 1, .9), more = TRUE)
	r <- as.Date(round(range(time.sequence), "day"))
	axis.Date(1, at = seq(r[1], r[2], by = "weeks"), format = "%d-%b")
	
	points(
			as.Date(time.sequence, "Europe/Paris"),
			eff.p / 1000,
			type = type,
			lty = lty,
			col = mypalette["weight"]
	)
	
	legend(
			x = "topright",
			inset = 0.01,
			legend = gettext("weighted", "counted", domain = "R-stacomiR"),
			pch = c(16, 16),
			col = mypalette[c("weight", "eff")]
	)
	######################################
	# text labels for numbers and weights
	######################################
	text(
			x = debut + (fin - debut) / 8,
			y = max(eff / 1000, na.rm = TRUE) * 1.15,
			labels = paste(round(
							sum(table$poids_depuis_effectifs, na.rm = TRUE) / 1000, 2
					), " kg"),
			col = mypalette["eff"],
			adj = 1,
			cex = cex
	)
	text(
			x = debut + 3 * (fin - debut) / 8 ,
			y = max(eff / 1000, na.rm = TRUE) * 1.15,
			labels = paste("N=", round(
							sum(table$Effectif_total.e, na.rm = TRUE)
					)),
			col = mypalette["eff"],
			adj = 1,
			cex = cex
	)
	text(
			x = debut + (fin - debut) / 8,
			y = max(eff / 1000, na.rm = TRUE) * 1.2,
			labels = paste(round(
							sum(table$Poids_total, na.rm = TRUE) / 1000, 2
					), " kg"),
			col = mypalette["weight"],
			adj = 1,
			cex = cex
	)
	text(
			x = debut + 3 * (fin - debut) / 8,
			y = max(eff / 1000, na.rm = TRUE) * 1.2,
			labels = paste("N=", round(sum(eff.p, na.rm = TRUE))),
			col = mypalette["weight"],
			adj = 1,
			cex = cex
	)
	text(
			x = debut + 3 + (fin - debut) / 8,
			y = max(eff / 1000, na.rm = TRUE) * 1.1,
			labels = paste(round(
							sum(table$Poids_total, table$poids_depuis_effectifs, na.rm = TRUE) / 1000,
							2
					), " kg"),
			col = "black",
			adj = 1,
			cex = cex
	)
	text(
			x = debut + 3 * (fin - debut) / 8,
			y = max(eff / 1000, na.rm = TRUE) * 1.1,
			labels = paste("N=", round(sum(eff, na.rm = TRUE))),
			col = "black",
			adj = 1,
			cex = cex
	)
	segments(
			x0 = debut,
			y0 = max(eff / 1000, na.rm = TRUE) * 1.125,
			x1 = debut + 3 * (fin - debut) / 8,
			y1 = max(eff / 1000, na.rm = TRUE) * 1.125
	)
	
	
	report_ope <- get("report_ope", envir = envir_stacomi)
	t_operation_ope <-
			report_ope@data[report_ope@data$ope_dic_identifiant == dc, ]
	dif = difftime(t_operation_ope$ope_date_fin,
			t_operation_ope$ope_date_debut,
			units = "days")
	
	if (!silent) {
		funout(gettextf(
						"number of operations =%s\n",
						nrow(t_operation_ope),
						domain = "R-stacomiR"
				))
		funout(gettextf("average trapping time = %sdays\n", round(mean(
										as.numeric(dif)
								), 2), domain = "R-stacomiR"))
		funout(gettextf("maximum term = %sdays\n", round(max(
										as.numeric(dif)
								), 2), domain = "R-stacomiR"))
		funout(gettextf("minimum term = %sdays\n", round(min(
										as.numeric(dif)
								), 2), domain = "R-stacomiR"))
	}
	
	df <- report_mig@dc@data$df[report_mig@dc@data$dc == dc]
	report_df <- get("report_df", envir = envir_stacomi)
	report_dc <- get("report_dc", envir = envir_stacomi)
	report_df@data <-
			report_df@data[report_df@data$per_dis_identifiant == df, ]
	report_dc@data <-
			report_dc@data[report_dc@data$per_dis_identifiant == dc, ]
	
	
	graphdate <- function(vectordate) {
		attributes(vectordate) <- NULL
		unclass(vectordate)
	}
	
	
	###################################
	# creation d'un graphique vide (2)
	###################################
	
	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
	plot(
			as.Date(time.sequence),
			seq(0, 3, length.out = length(eff)),
			xlim = xlim,
			type = "n",
			xlab = "",
			xaxt = "n",
			yaxt = "n",
			ylab = gettext("Fishway", domain = "R-stacomiR"),
			bty = "n",
			cex = cex + 0.2
	)
	
	###################################
	# Time for dc operation
	###################################
	
	if (dim(report_df@data)[1] == 0) {
		rect(
				xleft = debut,
				ybottom = 2.1,
				xright = fin,
				ytop = 3,
				col = "grey",
				border = NA,
				lwd = 1
		)
		rect(
				xleft = debut,
				ybottom = 1.1,
				xright = fin,
				ytop = 2,
				col = "grey40",
				border = NA,
				lwd = 1
		)
		legend(
				x = "bottom",
				legend = gettext("Unknown working", "Unknow operation type", domain =
								"R-stacomiR"),
				pch = c(16, 16),
				col = c("grey", "grey40"),
				horiz = TRUE,
				bty = "n"
		)
		
		
	} else {
		# si il sort quelque chose
		if (sum(report_df@data$per_etat_fonctionnement == 1) > 0) {
			rect(
					xleft = graphdate(as.Date(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
													1])),
					ybottom = 2.1,
					xright = graphdate(as.Date(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
													1])),
					ytop = 3,
					col = mypalette["working"],
					border = NA,
					lwd = 1
			)
		}
		if (sum(report_df@data$per_etat_fonctionnement == 0) > 0) {
			rect(
					xleft = graphdate(as.Date(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
													0])),
					ybottom = 2.1,
					xright = graphdate(as.Date(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
													0])),
					ytop = 3,
					col = mypalette["stopped"],
					border = NA,
					lwd = 1
			)
		}
		#creation d'une liste par categorie d'arret contenant vecteurs dates
		listeperiode <-
				fun_table_per_dis(
						typeperiode = report_df@data$per_tar_code,
						tempsdebut = report_df@data$per_date_debut,
						tempsfin = report_df@data$per_date_fin,
						libelle = report_df@data$libelle,
						color= mypalette[report_df@data$libelle]
				)
		nomperiode <- vector()
		color_periodes <- vector()
		for (j in 1:length(listeperiode)) {
			nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
			#ecriture pour chaque type de periode			
			color_periode = listeperiode[[j]]$color
			rect(
					xleft = graphdate(listeperiode[[j]]$debut),
					ybottom = 1.1,
					xright = graphdate(listeperiode[[j]]$fin),
					ytop = 2,
					col = color_periode,
					border = NA,
					lwd = 1
			)
			color_periodes <- c(color_periodes, color_periode)
		}
		# below the colors for operation are from 4 to 3+ntypeoperation
		legend  (
				x = debut,
				y = 1.2,
				legend = gettext("working", "stopped", nomperiode, domain = "R-stacomiR"),
				pch = c(15, 15),
				col = c(mypalette["working"], mypalette["stopped"], color_periodes),
				bty = "n",
				ncol = length(listeperiode) + 2,
				text.width = (fin - debut) / 10
		)
	}
	
	###################################
	# creation d'un graphique vide (3=DC)
	###################################
	
	
	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
	plot(
			as.Date(time.sequence),
			seq(0, 3, length.out = length(eff)),
			xlim = xlim,
			type = "n",
			xlab = "",
			xaxt = "n",
			yaxt = "n",
			ylab = gettext("CD", domain = "R-stacomiR"),
			bty = "n",
			cex = cex + 0.2
	)
	###################################
	# time for DC (counting device) operation
	###################################
	
	
	if (dim(report_dc@data)[1] == 0) {
		rect(
				xleft = debut,
				ybottom = 2.1,
				xright = fin,
				ytop = 3,
				col = "grey",
				border = NA,
				lwd = 1
		)
		
		rect(
				xleft = debut,
				ybottom = 1.1,
				xright = fin,
				ytop = 2,
				col = "grey40",
				border = NA,
				lwd = 1
		)
		legend(
				x = "bottom",
				legend = gettext("Unknown working", "Unknow operation type", domain =
								"R-stacomiR"),
				pch = c(16, 16),
				col = c("grey", "grey40"),
				horiz = TRUE,
				#ncol=5,
				bty = "n"
		)
		
		
	} else {
		if (sum(report_dc@data$per_etat_fonctionnement == 1) > 0) {
			rect(
					xleft = graphdate(as.Date(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
													1])),
					ybottom = 2.1,
					xright = graphdate(as.Date(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
													1])),
					ytop = 3,
					col = mypalette["working"],
					border = NA,
					lwd = 1
			)
		}
		if (sum(report_dc@data$per_etat_fonctionnement == 0) > 0)
		{
			rect(
					xleft = graphdate(as.Date(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
													0])),
					ybottom = 2.1,
					xright = graphdate(as.Date(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
													0])),
					ytop = 3,
					col = mypalette["stopped"],
					border = NA,
					lwd = 1
			)
		}
		listeperiode <-
				fun_table_per_dis(
						typeperiode = report_dc@data$per_tar_code,
						tempsdebut = report_dc@data$per_date_debut,
						tempsfin = report_dc@data$per_date_fin,
						libelle = report_dc@data$libelle,
						color= mypalette[report_df@data$libelle]
				)
		nomperiode <- vector()
		color_periodes <- vector()
		for (j in 1:length(listeperiode)) {
			nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
			color_periode = listeperiode[[j]]$color
			rect(
					xleft = graphdate(listeperiode[[j]]$debut),
					ybottom = 1.1,
					xright = graphdate(listeperiode[[j]]$fin),
					ytop = 2,
					col = color_periode,
					border = NA,
					lwd = 1
			)
			color_periodes <- c(color_periodes, color_periode)
		}
		
		legend  (
				x = debut,
				y = 1.2,
				legend = gettext("working", "stopped", nomperiode, domain = "R-stacomiR"),
				pch = c(15, 15),
				col = c(mypalette["working"], mypalette["stopped"], color_periodes),
				bty = "n",
				ncol = length(listeperiode) + 2,
				text.width = (fin - debut) / 10
		)
	}
	
	###################################
	# creation d'un graphique vide (4=OP)
	###################################
	
	
	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
	plot(
			as.Date(time.sequence),
			seq(0, 1, length.out = length(eff)),
			xlim = xlim,
			type = "n",
			xlab = "",
			xaxt = "n",
			yaxt = "n",
			ylab = gettext("Op", domain = "R-stacomiR"),
			bty = "n",
			cex = cex + 0.2
	)
	###################################
	# operations
	###################################
	rect(
			xleft = graphdate(as.Date(t_operation_ope$ope_date_debut)),
			ybottom = 0,
			xright = graphdate(as.Date(t_operation_ope$ope_date_fin)),
			ytop = 1,
			col = color_ope,
			border = NA,
			lwd = 1
	)
	
	
	###################################
	# Graph mensuel
	####################################
	graphics::par("mar" = c(4, 4, 1, 2) + 0.1)
	petitmois = substr(as.character(mois), 1, 3)
	effmois = tapply(eff, mois, sum, na.rm = TRUE)[c(5, 4, 9, 2, 8, 7, 6, 1, 12, 11, 10, 3)]
	effmois.p = tapply(eff.p, mois, sum, na.rm = TRUE)[c(5, 4, 9, 2, 8, 7, 6, 1, 12, 11, 10, 3)]
	effmois <- data.frame("eff" = effmois)
	effmois.p <- data.frame("eff" = effmois.p)
	tablemens <-
			rbind(
					cbind(
							"eff" = effmois - effmois.p,
							"type" = 2,
							"mois" = 1:12
					),
					cbind(effmois.p, "type" = "1", "mois" = 1:12)
			)
	
	
	superpose.polygon <- lattice::trellis.par.get("superpose.polygon")
	superpose.polygon$col =   mypalette[c("weight", "eff")]
	superpose.polygon$border = rep("transparent", 6)
	lattice::trellis.par.set("superpose.polygon", superpose.polygon)
	fontsize <- lattice::trellis.par.get("fontsize")
	fontsize$text = 10
	lattice::trellis.par.set("fontsize", fontsize)
	par.main.text <- lattice::trellis.par.get("par.main.text")
	par.main.text$cex = cex
	par.main.text$font = 1
	lattice::trellis.par.set("par.main.text", par.main.text)
	
	
	par.ylab.text <- lattice::trellis.par.get("par.ylab.text")
	par.ylab.text$cex = cex - 0.2
	lattice::trellis.par.set("par.ylab.text", par.ylab.text)
	par.xlab.text <- lattice::trellis.par.get("par.xlab.text")
	par.xlab.text$cex = cex - 0.2
	lattice::trellis.par.set("par.xlab.text", par.xlab.text)
	
	
	bar <- lattice::barchart(
			eff / 1000 ~ as.factor(mois),
			groups = as.factor(type),
			xlab = gettext("Month", domain = "R-stacomiR"),
			ylab = gettext("Number (x1000)", domain = "R-stacomiR"),
			#    main=list(label=paste("Donnees mensuelles")),
			data = tablemens,
			allow.multiple = FALSE,
			#			key=lattice::simpleKey(text=c(gettext("weight of monthly number"),gettext("monthly number counted",domain="R-stacomiR")),
			#					rectangles = TRUE,
			#					points=FALSE,
			#					space="right",
			#					cex=0.8),
			strip = FALSE,
			stack = TRUE
	)
	print(bar, position = c(0, 0, 1, .25), newpage = FALSE)
	return(invisible(NULL))
}

#'
#' 
#' Internal function, tests the connection and if it works loads the stacomi interface
#' @note \code{base} is copied by stacomi into envir_stacomi. Same for \code{database_expected}
#' 
#' @param ... Other arguments
#' @return Nothing
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
load_stacomi <- function(...) {
	
	# assigned when passing through stacomi
	database_expected <- get("database_expected", envir_stacomi)  # logical true or false
	
	if (database_expected) {
		sch <- get_schema()
		dbname  <- options("stacomiR.dbname")[[1]]
		host <- options("stacomiR.host")[[1]]
		port <- options("stacomiR.port")[[1]]
		user <- options("stacomiR.user")[[1]]
		password <- options("stacomiR.password")[[1]]
		if (user=="") {
			# this is the default options at start
			# if interactive will try to set the options upon loading
			if (interactive()){
				user <- readline(prompt="Enter user: ")
				options("stacomiR.user"=user)
				password <- readline(prompt="Enter password: ")	
				options("stacomiR.password"=password)
			} else {
				user <- "postgres"
				password <- "postgres"
				warning('no user set by default, reverted to user <- "postgres" and  password <- "postgres", 
                you can change it with options("stacomiR.user"=user) and options("stacomiR.password"=password)')
			}
		}

		
		con = new("ConnectionDB")
		e = expression(con <- connect(con))
		con = tryCatch(eval(e), error = function(e) e)
		if ("Rcpp::exception"%in%class(con)){
			cat(con$message)
			test <- FALSE
		} else {
			test <- TRUE
			pool::poolClose(con@connection)		
		}
		
		
		
		# second test to check that the database is working OK		
		
		if (test) {
			requete = new("RequeteDB")
			requete@sql = paste0("select count(*) from ", sch, "t_lot_lot")
			requete <- stacomirtools::query(requete)
			if (nrow(requete@query) == 0) {
				# the database link is not working or the 
				# schema
				funout(paste(gettext("Problem during the test, connection to the database is established but failed to connect to the right schema argument passed to stacomi",
										domain = "R-stacomiR"), "\n", 
								gettext("dbname", domain = "R-stacomiR")," :", dbname, "\n", 
								gettext("User", domain = "R-stacomiR"),	" :", user, "\n", 
								gettext("Port", domain = "R-stacomiR"),	" :", port, "\n", 
								gettext("Host", domain = "R-stacomiR"),	" :", host, "\n", 								
								gettext("Password", domain = "R-stacomiR"),	" :", password),
						gettext("schema", domain = "R-stacomiR"), " :", sch)
			} 
			
		} else {
			# the test has failed and the user will be prompted to another
			funout(paste(gettext("Problem when testing the DB connection", domain = "R-stacomiR"),
							gettext("dbname", domain = "R-stacomiR")," :", dbname, "\n", 
							gettext("User", domain = "R-stacomiR"),	" :", user, "\n", 
							gettext("Port", domain = "R-stacomiR"),	" :", port, "\n", 
							gettext("Host", domain = "R-stacomiR"),	" :", host, "\n", 								
							gettext("Password", domain = "R-stacomiR"),	" :", password))
		}  # end else test (else == the test didn't pass, we have to change the name and password
	} else {
		# here : database_expected=FALSE we don't want to check the connection
		# at all...
	}
}






#' stacomi Main launcher for program stacomi
#' 
#' When \code{database_expected=FALSE} a connection to the database is not expected. Therefore test are run by calling examples object stored in Rdata.
#' To change the language use Sys.setenv(LANG = 'fr') or Sys.setenv(LANG = 'en')
#' @param database_expected Boolean, if \code{TRUE} pre launch tests will be run to test the connection validity
#' @param datawd The data working directory
#' @param sch The schema in the stacomi database default 'iav.'
#' @return Nothing, called for its side effect of loading
#' @usage stacomi(database_expected=TRUE, datawd = "~", sch = "iav")
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples
#' 
#'  require(stacomiR)
#' #launch stacomi 
#'  \dontrun{ 
#' stacomi(database_expected=TRUE, datawd='~',sch= "iav")
#' }
#' # launch stacomi without connection to the database
#' stacomi(database_expected=FALSE)
#' # launch stacomi with options
#' options(
#'		stacomiR.dbname = "bd_contmig_nat",
#'		stacomiR.host = readline(prompt = "Enter host: "),
#'		stacomiR.port = "5432",
#'		stacomiR.user = readline(prompt = "Enter user: "),
#'		stacomiR.password = readline(prompt = "Enter password: ")
#')
#' @export
stacomi = function(database_expected = TRUE,  datawd = "~", sch = "iav") {	
	assign("database_expected", database_expected, envir = envir_stacomi)
	# values assigned in the envir_stacomi
	assign("datawd", datawd, envir = envir_stacomi)
	assign("sch", paste(sch, ".", sep = ""), envir = envir_stacomi)
	load_stacomi()
	invisible(NULL)
}






#' Working environment for stacomiR created when launching stacomi()
#' 
#' This is where the graphical interface stores its objects
#' try \code{ls(envir=envir_stacomi)}
#' @keywords environment
#' @export
envir_stacomi <- new.env(parent = asNamespace("stacomiR"))
# calcmig<-data.frame()

#' Class "report_mig_env"
#'
#' Enables to compute an annual overview of fish migration and environmental
#' conditions in the same chart. Environmental conditions may trigger migration events, variation in flow
#' or temperatures can  be plotted along migration to check graphically for a possible relation. To enable this,
#' environmental conditions are loaded from an "environmental monitoring station", which records environmental
#' parameters and is attached to a migratory station in the database.
#' This class enables both continuous output (temperature -flow) as well as discrete parameters (qualitative = moon
#' phase, type of operation of a gate, opening of a gate...) which will be displayed on the graph. Values are scaled so that
#' single plot can display migration numbers and environmental parameters. Environmental parameters when stored at a
#' time scale lower that a day are averaged per day, unless they are qualitative parameters, in which case only the first
#' event of the day is displayed on the annual plot.
#'
#' @include report_mig_mult.R
#' @include report_env.R
#' @include create_generic.R
#' @include utilities.R
#' @slot report_mig_mult \link{report_mig_mult-class}
#' @slot report_env \link{report_env-class}
#' @author cedric.briand@eptb-vilaine.fr marion.legrand@logrami.fr
#' @family report Objects
#' @keywords classes
#' @aliases report_mig_env
#' @keywords classes
#' @example inst/examples/report_mig_env-example.R
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @export
setClass(
		Class = "report_mig_env",
		representation =
				representation(report_mig_mult = "report_mig_mult",
						report_env = "report_env"),
		prototype = prototype(
				report_mig_mult = new("report_mig_mult"),
				report_env = new("report_env")
		
		)
)


setValidity("report_mig_env",
		function(object)
		{
			rep1 = validObject(object@report_mig_mult, test = TRUE)
			rep2 = validObject(object@report_env, test = TRUE)
			return(ifelse(rep1 & rep2 , TRUE, c(1:2)[!c(rep1, rep2)]))
		})
#' connect method for report_mig_env class
#' @param object An object of class \link{report_mig_env-class}
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return an object of report_mig_env class
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_mig_env
setMethod(
		"connect",
		signature = signature("report_mig_env"),
		definition = function(object, silent = FALSE) {
			#object<-r_mig_env
			r_mig_env <- object
			r_mig_env@report_mig_mult <-
					connect(r_mig_env@report_mig_mult, silent = silent)
			r_mig_env@report_env <- connect(r_mig_env@report_env, silent = silent)
			return(r_mig_env)
		}
)
#' command line interface for report_env class
#' 
#' @param object An object of class \link{report_env-class}
#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
#' @param taxa '2038=Anguilla anguilla',
#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
#' @param stage 'AGJ=Yellow eel', 'AGG=Silver eel', 'CIV=glass eel'
#' @param stationMesure A character, the code of the monitoring station, which records environmental parameters \link{choice_c,ref_env-method}
#' @param datedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param datefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
#' @param silent Boolean default FALSE, if TRUE information messages not displayed.
#' @aliases choice_c.report_mig_env
#' @return An object of class \link{report_env-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod(
		"choice_c",
		signature = signature("report_mig_env"),
		definition = function(object,
				dc,
				taxa,
				stage,
				stationMesure,
				datedebut,
				datefin,
				silent = FALSE) {
			# code for debug
			# dc=c(5,6,12);	taxa=c("Anguilla anguilla");stage=c("AGJ","AGG","CIV");
			# stationMesure=c("temp_gabion","coef_maree");
			# datedebut="2008-01-01";datefin="2008-12-31";silent=FALSE
			r_mig_env <- object
			r_mig_env@report_mig_mult =
					choice_c(
							r_mig_env@report_mig_mult,
							dc = dc,
							taxa = taxa,
							stage = stage,
							datedebut = datedebut,
							datefin = datefin,
							silent = silent
					)
			r_mig_env@report_env = choice_c(
					r_mig_env@report_env,
					stationMesure = stationMesure,
					datedebut = datedebut,
					datefin = datefin,
					silent = silent
			)
			return(r_mig_env)
		}
)
#' charge method for report_mig_env class
#'
#' #' Unique the other report classes where the charge method is only used by the graphical interface
#' to collect and test objects in the environment envir_stacomi, and see if the right choices have
#' been made in the graphical interface, this methods runs the \link{charge,report_mig_mult-method}
#' and needs to be called from the command line (see examples)
#' @param object An object of class \link{report_mig_env-class}
#' @param silent Should the function remain silent (boolean)
#' @return An object of class \link{report_mig_env-class} with data set from values assigned in \code{envir_stacomi} environment
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases charge.report_mig_env
setMethod(
		"charge",
		signature = signature("report_mig_env"),
		definition = function(object, silent = FALSE) {
			# silent=FALSE
			r_mig_env <- object
			r_mig_env@report_mig_mult <-
					charge(r_mig_env@report_mig_mult, silent = silent)
			# the values for date are not initiated by the interface
			assign(
					"report_env_date_debut",
					get("timestep", envir_stacomi)@"dateDebut",
					envir_stacomi
			)
			assign("report_env_date_fin",
					as.POSIXlt(end_date(get(
											"timestep", envir_stacomi
									))),
					envir_stacomi)
			r_mig_env@report_env <-
					charge(r_mig_env@report_env, silent = silent)
			return(r_mig_env)
		}
)

#' Calculations for migration in the class \link{report_mig_env-class}
#'
#' Runs the calcule method in \link{report_mig_mult-class}
#' @param object An object of class \link{report_mig_env-class}
#' @param silent Boolean default FALSE, if TRUE information messages not displayed
#' @aliases calcule.report_mig_env
#' @return \link{report_mig_env-class} with data in slot r_mig_env@report_mig_mult@calcdata
setMethod(
		"calcule",
		signature = signature("report_mig_env"),
		definition = function(object, silent = FALSE) {
			# silent=FALSE
			r_mig_env <- object
			r_mig_env@report_mig_mult <-
					calcule(r_mig_env@report_mig_mult, silent = silent)
			if (!silent)
				funout(
						gettext(
								"r_mig_env object is stocked into envir_stacomi environment\n",
								domain = "R-stacomiR"
						)
				)
			return(r_mig_env)
		}
)


#' Plot method for report_mig_env
#' @param x An object of class \link{report_mig_env}
#' @param silent Stops displaying the messages.
#' @param color_station A named vector of station color (e.g. c("temp_gabion"="red","coef_maree"="blue","phases_lune"="green")) default null
#' @param color_dc A named vector giving the color for each dc default null (e.g. c("5"="#4D4D4D","6"="#E6E6E6","12"="#AEAEAE"))
#' @return Nothing, called for its side effect of plotting 
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_mig_env
#' @export
setMethod(
		"plot",
		signature(x = "report_mig_env", y = "missing"),
		definition = function(x,
				color_station = NULL,
				color_dc = NULL,
				silent = FALSE) {
			#color_station=NULL;color_dc=NULL
			# color_station<-c("temp_gabion"="red","coef_maree"="blue","phases_lune"="green")
			# color_dc=c("5"="#4D4D4D","6"="#E6E6E6","12"="#AEAEAE")
			r_mig_env <- x
			
			
			grdata <- fun_aggreg_for_plot(r_mig_env@report_mig_mult)
			# we collect the dataset used to build the graph
			
			taxa = as.character(r_mig_env@report_mig_mult@taxa@data[
							r_mig_env@report_mig_mult@taxa@data$tax_code %in% 
									r_mig_env@report_mig_mult@taxa@taxa_selected, "tax_nom_latin"]
			)
			stage = as.character(r_mig_env@report_mig_mult@stage@data[
							r_mig_env@report_mig_mult@stage@data$std_code%in% 
									r_mig_env@report_mig_mult@stage@stage_selected,"std_libelle"]
			)
			dc <- unique(grdata$DC)
			stations <- r_mig_env@report_env@stationMesure@data
			dc_code <- r_mig_env@report_mig_mult@dc@data$dc_code[match(dc, r_mig_env@report_mig_mult@dc@data$dc)]
			# tableau conditions environnementales
			tableauCE <- r_mig_env@report_env@data
			if (nrow(tableauCE) == 0) {
				funout(
						gettext(
								"You don't have any environmental conditions within the time period\n",
								domain = "R-stacomiR"
						),
						arret = TRUE
				)
			}
			
			# we collect libelle and source of data from station
			source <- unlist(lapply(regmatches(stations$stm_description,gregexpr("(?<=:([[:space:]])).*", stations$stm_description, perl =TRUE),invert=NA),
							function(X) X[2]))
			if (any(is.na(source))) {
				missing <- stations[is.na(source),"stm_libelle"]
				missing_and_selected <- missing[missing%in%r_mig_env@report_env@stationMesure@env_selected]
				missing_and_selected <- paste(missing_and_selected, collapse=" , ")
				warning(sprintf("the source of data is not present in column stm_description of table tj_stationmesure_stm for stations: %s. \n Please consider adding it by adding something like source: Banque hydro at the end of the line in table tj_stationmesure_stm column stm_description", 
								missing_and_selected))
				source[is.na(source)] <- "Not defined"
			}

			stations$source <- source 
			tableauCE <- merge(tableauCE,stations, by.x="env_stm_identifiant", by.y="stm_identifiant")
			# (?<= ) lookbehind, get the string : with a space after but not capture it. .* capture anything after
			# currently we've added the source of data within the stm_description string so as not to change the db
	    # regmatches, invert = NA returns a list with first elt matching and second non mathing
	    # we want the full list returned with NA when missing match



			
			# the data can be in the POSIXct format, we need to round them
			tableauCE$date <-
					as.POSIXct(Hmisc::roundPOSIXt(tableauCE$env_date_debut, digits = "days"))
			qualitative <- !is.na(tableauCE$env_val_identifiant)
			tableauCEquan <- tableauCE[!qualitative, ]
			tableauCEqual <- tableauCE[qualitative, ]
			if (nrow(unique(cbind(tableauCE$date, tableauCE$stm_libelle))) !=	nrow(tableauCE)) {
				# do not cut character chain below...
				funout(
						gettextf(
								"Attention, on one station :%s there are several entries for the same day :%s we will calculate average for numeric	and use the first value for qualitative parameter",
								sta,
								paste(unique(tableauCEst$env_date_debut[duplicated(tableauCEst$env_date_debut)]), sep =
												"")
						),
						arret = FALSE
				)
				# for quantitative parameters we group by date and station and use the average to
				# extract one value per day
				tableauCEquan <-
						dplyr::select(tableauCEquan, date, stm_libelle, env_valeur_quantitatif) %>%
						dplyr::group_by(date, stm_libelle) %>%
						dplyr::summarize(valeur = mean(env_valeur_quantitatif)) %>%
						dplyr::ungroup()
				# for qualitative value, when there are several values for the same date
				# we arbitrarily select the first
				tableauCEqual <-
						dplyr::select(tableauCEqual, date, stm_libelle, env_val_identifiant) %>%
						dplyr::group_by(date, stm_libelle) %>%
						dplyr::summarize(valeur = first(env_val_identifiant)) %>%
						dplyr::ungroup()
			} else {
				# we want the same format as above
				tableauCEquan <-
						dplyr::select(tableauCEquan, date, stm_libelle, env_valeur_quantitatif) %>%
						dplyr::rename(valeur = env_valeur_quantitatif)
				tableauCEqual <-
						dplyr::select(tableauCEqual, date, stm_libelle, env_val_identifiant) %>%
						dplyr::rename(valeur = env_val_identifiant)
			}
			variables_quant <- unique(tableauCEquan$stm_libelle)
			variables_qual <- unique(tableauCEqual$stm_libelle)
			grdata <- fun_date_extraction(
					grdata,
					nom_coldt = "debut_pas",
					annee = FALSE,
					mois = TRUE,
					quinzaine = TRUE,
					semaine = TRUE,
					jour_an = TRUE,
					jour_mois = FALSE,
					heure = FALSE
			)
			
			# to rescale everything on the same graph
			maxeff = floor(log10(max(grdata$effectif_total, na.rm = TRUE)))
			
			for (i in 1:length(variables_quant)) {
				diff = maxeff - round(log10(max(tableauCEquan[tableauCEquan$stm_libelle ==
														variables_quant[i], "valeur"], na.rm = TRUE)))
				if (diff != 0 & !is.na(diff)) {
					tableauCEquan[tableauCEquan$stm_libelle == variables_quant[i], "valeur"] = as.numeric(tableauCEquan[tableauCEquan$stm_libelle ==
											variables_quant[i], "valeur"]) * 10 ^ diff
					variables_quant[i] = paste(variables_quant[i], ".10^", diff, sep = "")
				} # end if
			} #end for
			yqualitatif = (10 ^ (maxeff)) / 2
			
			ylegend = gettextf(
					"Number, %s, %s",
					paste(variables_quant, collapse = ", "),
					paste(variables_qual, collapse = ", ")
			)
			
			
			######################
			# treatment of data to group by dc
			# if several taxa or stages are passed, they are aggregated with a warning
			#################################
			if (length(unique(taxa)) > 1)
				warning(gettextf(
								"you have %s taxa in the report, those will be aggregated",
								length(unique(taxa))
						))
			if (length(unique(stage)) > 1)
				warning(gettextf(
								"you have %s stages in the report, those will be aggregated",
								length(unique(stage))
						))
			plotdata <-
					dplyr::select(grdata, debut_pas, DC, effectif_total) %>% dplyr::rename(date =
									debut_pas) %>%
					dplyr::group_by(date, DC) %>% dplyr::summarize(effectif = sum(effectif_total)) %>%
					dplyr::ungroup()
			
			#######################
			# color scheme for station
			#######################
			
			cs <-
					colortable(color = color_station,
							vec = unique(tableauCE$stm_libelle),
							palette = "Accent")
			cs <- stacomirtools::chnames(cs, "name", "stm_libelle")
			#######################
			# color scheme for dc
			#######################
			cdc <-
					colortable(color = color_dc,
							vec = dc,
							color_function = "gray.colors")
			cdc <- stacomirtools::chnames(cdc, "name", "DC")
			#######################
			# merging with colors for manual scales
			######################
			plotdata <- killfactor(merge(plotdata, cdc, by = "DC"))
			tableauCEquan <-
					killfactor(merge(tableauCEquan, cs, by = "stm_libelle"))
			tableauCEqual <-
					killfactor(merge(tableauCEqual, cs, by = "stm_libelle"))
			######################
			#  source of data
			#######################
			source <- paste("source:",paste(unique(tableauCE$source), collapse=", "))
			
			
			g <- ggplot(plotdata) +
					geom_bar(aes(x = date, y = effectif, fill = color),
							position = "stack",
							stat = "identity") +
					ylab(ylegend) +
					geom_line(aes(x = date, y = valeur, colour = color),
							data = tableauCEquan,
							size = 1) +
					geom_point(
							aes(
									x = date,
									shape = valeur,
									colour = color
							),
							y = yqualitatif,
							data = tableauCEqual,
							size = 3
					) +
					scale_fill_identity(name = gettext("DC"),
							labels = dc_code,
							guide = "legend") +
					scale_colour_identity(
							name = gettext("stations"),
							labels = cs[, "stm_libelle"],
							breaks = cs[, "color"],
							guide = "legend"
					) +
					scale_shape(guide = "legend", name = gettext("Qualitative parm")) +
					theme_bw() +
					labs(caption=source)
			print(g)
			assign("g", g, envir_stacomi)
			if (!silent)
				funout(
						gettext(
								"the ggplot object has been assigned to envir_stacomi, type g<-get('g',envir_stacomi)"
						)
				)
			return(invisible(NULL))
		}
)# end function



#' function used for some lattice graphs with dates 
#' @param vectordate date or POSIXt 
#' @return vectordate (without class)
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
graphdate<-function(vectordate){
	vectordate <- as.POSIXct(vectordate)
	attributes(vectordate) <- NULL
	unclass(vectordate)
	return(vectordate)
}







#' function used to remove special non utf8 character which cause the gtk
#' interface to crash
#' 
#' 
#' @param text a text string which might contain no utf8 characters
#' @return text
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
fun_char_spe<-function(text){
	text <- gsub("\u00e9","e",text) 
	text <- gsub("\u00e8","e",text) 
	text <- gsub("\u00ea","e",text) 
	text <- gsub("\u00e0","a",text) 
	return(text)}








#' Transforms a vector into a string called within an sql command e.g.
#' c('A','B','C') => in ('A','B','C')
#' 
#' Transforms a vector into a string called within an sql command e.g. c(A,B,C)
#' => in ('A','B','C')
#' 
#' 
#' @param vect a character vector
#' @return A list of value
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
vector_to_listsql<-function(vect)
{
	if (is.null(vect)) stop("The vector passed to vector_to_listsql should not be null")
	if (any(is.na(vect))) stop("The vector passed to vector_to_listsql should not be NA")
	if (length(vect)==0) stop("The vector passed to vector_to_listsql should not be of lenght zero")
	if (length(vect)==1) 
	{
		listsql=paste("(","'",vect,"'",")",sep="")
	}
	
	if (length(vect)>2)
	{
		listsql=paste("(","'",vect[1],"'",",", sep="")
		for(j in 2:(length(vect)-1)){
			listsql=paste(listsql,"'",vect[j],"'",",",sep="")
		}
		listsql=paste(listsql,"'",vect[length(vect)],"'",")", sep="")
	} 
	else if  (length(vect)==2)
	{
		listsql=paste("(","'",vect[1],"'",",", sep="")
		listsql=paste(listsql,"'",vect[length(vect)],"'",")", sep="") 
	}
	
	return(listsql)
} 



#' Create a dataframe suitable for charts per 24h and day
#' 
#' This functions takes a data frame with a column with starting time and another with ending time
#' If the period extends over midnight, it will be split into new lines, starting and ending at midnight
#' 
#' @param data The dataframe
#' @param horodatedebut The beginning time
#' @param horodatefin The ending time
#' @return A data frame with four new columns, Hmin (hour min), Hmax (hmax), xmin (day) and xmax (next day),
#' and new rows
#' @author cedric.briand
#' @examples
#' datatemp<-structure(list(per_dis_identifiant = c(1L, 1L, 1L), 
#' per_date_debut = structure(c(1420056600, 
#'	1420071000, 1420081200), class = c("POSIXct", "POSIXt"), tzone = ""), 
#'	per_date_fin = structure(c(1420071000, 1420081200, 1421000000
#'	), class = c("POSIXct", "POSIXt"), tzone = ""), per_commentaires = c("fonct calcul", 
#'	"fonct calcul", "fonct calcul"), per_etat_fonctionnement = c(1L, 
#'	0L, 0L), per_tar_code = 1:3, libelle = c("Fonc normal", "Arr ponctuel", 
#'	"Arr maint")), .Names = c("per_dis_identifiant", "per_date_debut", 
#'	"per_date_fin", "per_commentaires", "per_etat_fonctionnement", 
#'	"per_tar_code", "libelle"), row.names = c(NA, 3L), class = "data.frame")
#'  newdf<-split_per_day(data=datatemp,horodatedebut="per_date_debut",
#' horodatefin="per_date_fin")
#' @export
split_per_day<-function(data,horodatedebut,horodatefin){
	if(!horodatedebut%in%colnames(data)) stop("horodatedebut not in column names for data")
	if(!horodatefin%in%colnames(data)) stop("horodatefin not column names for data")	
	data$Hdeb<-as.numeric(strftime(data[,horodatedebut],"%H"))+as.numeric(strftime(data[,horodatedebut],"%M"))/60
	data$Hfin<-as.numeric(strftime(data[,horodatefin],"%H"))+round(as.numeric(strftime(data[,horodatefin],"%M"))/60,2)
	data$xmin<-lubridate::floor_date(data[,horodatedebut],unit="day") # pour les graphiques en rectangle
	data$xmax<-data$xmin+lubridate::days(1)
	# number of times we pass to midnigth
	# round is for when we switch hour
	data$n0<-round(difftime(floor_date(data[,horodatefin],unit="day"),floor_date(data[,horodatedebut],unit="day"),units="days"))
	# rows that will be duplicated
	data$id=sequence(nrow(data))
	data<-data[rep(sequence(nrow(data)),data$n0+1),]
	data$newid<-sequence(nrow(data))
	# within a group where dates overlap between two days
	#the first will and all lines except the last be set 24 for Hfin
	data1<-data%>%filter(n0>0)%>%group_by(id)%>%filter(min_rank(desc(newid)) !=1)%>%mutate("Hfin"=24)
	#replacing rows in data
	data[match(data1$newid,data$newid),]<-data1
	# all except the first will be set 0 to Hdeb
	data2<-data%>%filter(n0>0)%>%group_by(id)%>%filter(min_rank(newid) !=1)%>%mutate("Hdeb"=0)
	#replacing rows in data
	data[match(data2$newid,data$newid),]<-data2
	# now get the sequence of days righly set by adding the number of days to xmin and xmax
	data3<-data%>%filter(n0>0)%>%group_by(id)%>%mutate(xmin=xmin+ as.difftime(rank(newid)-1, units="days"),
			xmax=xmax+as.difftime(rank(newid)-1, units="days"))
	data[match(data3$newid,data$newid),]<-data3
	data<-as.data.frame(data)	
	return(data)
}

#' This function extracts temporal characteristics from a dataframe
#' 
#' 
#' @param data a data frame containing a Date or POSIXt column
#' @param nom_coldt the name of the column containing date or POSIXt entry to
#' be processed
#' @param annee logical do you want a column describing year to be added to the
#' dataframe
#' @param mois logical, add column with month
#' @param quinzaine logical, add column with 15 days
#' @param semaine logical, add column with weeks
#' @param semaine_std logical, add column with standard weeks (using isoweek from lubridate)
#' @param jour_an logical, add column with day of year
#' @param jour_mois logical, add column with day of month
#' @param heure logical, add column with hour
#' @return The dataframe with date column filled
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
fun_date_extraction=function(data, # tableau de donnees e importer
		nom_coldt, # nom de la colonne
		annee=TRUE,
		mois=TRUE,
		quinzaine=FALSE,
		semaine=TRUE,
		semaine_std=FALSE,
		jour_an=FALSE,
		jour_mois=TRUE,
		heure=FALSE                           
){
	if (annee) data$annee <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%Y"))                        
	if (mois) data$mois <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%m"))
	# %b Abbreviated month name in the current locale. (Also matches full name on input.)
	if (quinzaine) {
		data$quinzaine=ceiling(as.numeric(strftime(as.POSIXlt(data[,nom_coldt]),
								format="%W"))/2)
		data$quinzaine <- as.character(data$quinzaine)
		data$quinzaine[as.numeric(data$quinzaine)<10] <- paste("0", data$quinzaine[as.numeric(data$quinzaine)<10],sep="")
		data$quinzaine <- as.factor(data$quinzaine)
	}
	if (semaine) data$semaine <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%W"))
	#%W : Week of the year as decimal number (00e53) using Monday as the first day of week (and typically with the first Monday of the year as day 1 of week 1). The UK convention
	if (jour_an) data$jour_365 <- strftime(as.POSIXlt(data[,nom_coldt]), format="%j")                          
	if (jour_mois) data$jour_mois <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%d"))  
	# %d :  Day of the month as decimal number (01e31).
	if (heure) data$heure <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%H"))  
	#%H     Hours as decimal number (00e23).    
	if (semaine_std) data$semaine_std=lubridate::isoweek(as.POSIXlt(data[,nom_coldt]))
	return(data)
}    


#' Builds a table with colors to merge with a dataframe for later
#' use in ggplot. An initial check will be done
#' on the name of the color vector. A data frame is built. It contains a column color which is a factor.
#' The factor order match the order of the vector (not the alphabetical order of the colors).

#' 
#' @param color Either null (default) or a named vector of colors, the
#' names should correspond to the values of vec 
#' @param  vec The vector to match the color with, if a named vector
#' or color is supplied the names should match
#' @param palette, the name of the RColorBrewer palette, defaults to "Set2", ignored for other
#' color gradient functions and if a named vector of colors is provided
#' @param color_function, the name of the function used to brew the colors, one for 
#' "brewer.pal", "gray.colors", "random", default to "brewer.pal, this argument is ignored if a
#' named vector of color is passed.
#' @return A dataframe with two columns, the vector (name) and the color (color) as a reordered factor
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
colortable <- function(color=NULL, vec, palette="Set2", color_function=c("brewer.pal","gray.colors","random")){
	color_function <- match.arg(color_function, choices = c("brewer.pal","gray.colors","random"))
	if (is.null(color)) {
		if (color_function == "brewer.pal") {
			number_available <- RColorBrewer::brewer.pal.info[rownames(RColorBrewer::brewer.pal.info)==palette,"maxcolors"]
			if (number_available>=length(vec)){
			color <- RColorBrewer::brewer.pal(length(vec),name=palette)[1:length(vec)] # 1:length(vec) as palette return minimum 3 values
			}	 else {
				message(gettextf("Palette %s has only got %s values and you need %s", palette, number_available, length(vec)))
				qual_col_pals <- RColorBrewer::brewer.pal.info[RColorBrewer::brewer.pal.info$category == 'qual',]
				color <- sample(unlist(mapply(RColorBrewer::brewer.pal, qual_col_pals$maxcolors, rownames(qual_col_pals))),length(vec))
			}
		} else if (color_function == "gray.colors"){
			color=grDevices::gray.colors(length(vec))
		} else if (color_function == "random"){
			color <- grDevices::colors()[grep('gr(a|e)y', grDevices::colors(), invert = T)]
			color <- sample(color, size=length(vec))
		}
		names(color)<-vec
	} else if (length(color) != length(vec)){
		funout(gettextf("The color argument should have length %s", length(vec)), arret=TRUE)
	}
	if (!all(names(color)%in%vec)) {
		stop (gettextf("The following name(s) %s do not match vector name: %s",
						names(color)[!names(color)%in%vec],
						paste(vec, collapse=", ")))
	}
	# creating a data frame to pass to merge later (to get the color in the data frame)
	cs <- data.frame(name=names(color), color=color)
	# problem with different order (set by color name) implying different order
	# in the graph (ie by color not by car_val_identifiant
	cs$color <- as.factor(cs$color)
	bonordre <- match(cs$color, levels(cs$color))
	cs$color  <-  factor(cs$color, levels(cs$color)[bonordre])
	return(cs)
}


#' this function displays text and will be used to convey stacomiR message in shiny
#' 
#' 
#' @param text The text to displaying the R 
#' console and later in shiny
#' @param arret Should this cause the program to stop ?
#' @param ... Additional parameters passed to print
#' @return nblignes Assigned in envir_stacomi
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
funout <- function(text,arret=FALSE,...){
	if(arret) stop(text) else print(text,quote=FALSE,...)
}

#' this function gets the schema from envir stacomi and throws warning
#' 
#' @param default passed to rlang::get_env
#' @return The schema in envir_stacomi
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
get_schema <- function(default=NULL){
	if (!exists("envir_stacomi")) stop("envir_stacomi not created did you run stacomi() ?")
	sch <- rlang::env_get(envir_stacomi, "sch", default=default)
	if (is.null(sch)) stop("program failure, sch not in envir_stacomi")
	return(sch)
}

#' this function gets the name of the stucture as it is set in the database
#' 
#' @return The name of the structure (org_code)
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
get_org <- function(){
return(toupper(gsub("\\.", "", get_schema())))
}

#' functions called in DF and DC
#' 
#' 
#' 
#' @param typeperiode ref.tr_typearretdisp_tar(per_tar_code) the code of the
#' period (see table ref.tr_typearretdisp_tar)
#' @param tempsdebut ref.tr_typearretdisp_tar(per_date_debut) starting
#' timestamp of the period
#' @param tempsfin The postgres column ref.tr_typearretdisp_tar(per_date_fin) ending timestamp of
#' the period
#' @param libelle The postgres column ref.tr_typearretdisp_tar(libelle )description of the period
#' type
#' @param color A named vector of color matching libelle.
#' @param date Boolean, should the function return a POSIXt or date value
#' @return  A list
#' @note returns either POSIXt or date if date=TRUE
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
fun_table_per_dis <- function(typeperiode, tempsdebut, tempsfin, libelle, color, date = TRUE) {
    listeg = list()
    for (j in 1:5) {
        if (!date) {
            # pour utilisation ulterieure de la classe Posixct
            if (sum(unique(typeperiode) == j) > 0) {
                choice_periode <- typeperiode == j
                liste <- list(debut = tempsdebut[choice_periode], 
										fin = tempsfin[choice_periode],
                  nom = libelle[choice_periode][1],
									color = color[choice_periode][1])
                listeg[[as.character(j)]] <- liste
            }
            # pour utilisation ulterieure de la classe date
        } else {
            if (sum(unique(typeperiode) == j) > 0) {
                choice_periode <- typeperiode == j
                liste <- list(
										debut = as.Date(tempsdebut[choice_periode]), 
										fin = as.Date(tempsfin[choice_periode]),
                  nom = as.character(libelle[choice_periode][1]),
									color = color[choice_periode][1])
                listeg[[as.character(j)]] <- liste
            }
        }
    }
    return(listeg)
}

#' Validity check for ref_horodate
#'
#' @param object A ref_horodate object
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
validity_ref_horodate = function(object)
{
  rep1 = inherits(object@horodate[2], "POSIXt")
  
  return(ifelse(rep1, TRUE, FALSE))
}


#' Class ref_horodate
#'
#' choice of date with method to show current and previous year
#'
#'
#' @slot horodate a "POSIXt"
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("ref_horodate", \dots{})}.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family referential objects
setClass(
  Class = "ref_horodate",
  representation =
    representation(horodate = "POSIXt"),
  validity = validity_ref_horodate,
  prototype = prototype(horodate = Hmisc::roundPOSIXt(Sys.time(), "years"))
)


#' Choice_c method for ref_horodate
#' @aliases choice_c.ref_horodate
#' @param object An object of class \link{ref_horodate-class}
#' @param nomassign The name assigned in environment envir_stacomi
#' @param funoutlabel, text displayed by the interface
#' @param silent Default FALSE, should messages be displayed
#' @param horodate The horodate to set, formats "\%d/\%m/\%Y \%H:\%M:\%s", "\%d/\%m/\%y \%H:\%M:\%s", "\%Y-\%m-\%d  \%H:\%M:\%s" formats
#' can also be passed with the date set to the minute \%d/\%m/\%Y \%H:\%M or the day  \%d/\%m/\%Y
#' \dots are accepted. The choice_c method assigns and
#' @return An object of class \link{ref_horodate-class} with slot \emph{horodate} set,
#'  and assigns an object of class POSIXt with name nomassign in envir_stacomi
setMethod(
  "choice_c",
  signature = signature("ref_horodate"),
  definition = function(object,
                        nomassign = "horodate",
                        funoutlabel = "nous avons le choix dans la date\n",
                        #decal=0,
                        horodate,
                        silent = FALSE) {
    # horodate="2013-01-01"
    # parse the horohorodate
    if (length(horodate) > 1)
      stop("horodate should be a vector of length 1")
    if (is.null(horodate))
      stop("horodate should not be null")
    if (inherits(horodate, "character")) {
      if (grepl("/", horodate)) {
        .horodate = strptime(horodate, format = "%d/%m/%Y %H:%M:%s")
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d/%m/%y %H:%M:%s")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d/%m/%y %H:%M")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d/%m/%Y %H:%M")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d/%m/%y")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d/%m/%Y")
        }
      } else if (grepl("-", horodate)) {
        .horodate = strptime(horodate, format = "%Y-%m-%d  %H:%M:%s")
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d-%m-%Y  %H:%M:%s")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%Y-%m-%d  %H:%M")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d-%m-%Y  %H:%M")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%Y-%m-%d")
        }
        if (is.na(.horodate)) {
          .horodate = strptime(horodate, format = "%d-%m-%Y")
        }
      } else {
        stop(
          "Formatting problem, the character vector you are trying to pass as horodate could not be parsed. Check example or documentation"
        )
      }
      
    } else if (inherits(horodate, "Date")) {
      .horodate <- as.POSIXlt(horodate)
    } else if (inherits(horodate[2] , "POSIXt")) {
      .horodate = horodate
    }
    if (is.na(.horodate))
      stop(
        "Formatting problem, the character vector you are trying to pass as horodate could not be parsed. Check example or documentation"
      )
    object@horodate = .horodate
    validObject(object)
    assign(nomassign, object@horodate, envir_stacomi)
    if (!silent)
      funout(funoutlabel)
    return(object)
  }
)

#' Class 'ref_stage'
#' 
#' Representation of a fish phase
#' 
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_stage', data='data.frame')}.  \describe{
#' \item{list('data')}{Object of class \code{'data.frame'} ~ The phases
#' available in the database}\item{:}{Object of class \code{'data.frame'} ~ The
#' phases available in the database} }
#' @slot data A data frame containing data loaded from the database by either charge or charge_with_filter methods
#' @slot stage_selected Contains the code \code{'tax_code'} of the stage selected by choice_c() method
#' @author cedric.briand@eptb-vilaine.fr
#' @keywords classes
#' @family referential objects
setClass(Class = "ref_stage", representation = representation(data = "data.frame", stage_selected="character"))

#' Loading method for ref_stage referential objects
#' @param object An object of class \link{ref_stage-class}
#' @return An S4 object of class \link{ref_stage-class} with all stages available in the database
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_stage')
#'  charge(object)
#' }
setMethod("charge", signature = signature("ref_stage"), definition = function(object) {
    req = new("RequeteDB")
    req@sql = "SELECT std_code, std_libelle FROM ref.tr_stadedeveloppement_std ORDER BY std_code ;"
    req <- stacomirtools::query(req) 
    object@data <- req@query
    return(object)
})


#' Loading method for ref_stage referential objects searching only those stages existing for a DC and a Taxon
#' @param object An object of class \link{ref_stage-class}
#' @param dc_selected The selected counting device
#' @param taxa_selected The selected species
#' @return An S4 object of class \link{ref_stage-class} listing all stages available for one DC and one taxon
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  dc_selected=6
#'taxa_selected=2038
#'  object=new('ref_stage')
#'  charge_with_filter(object,dc_selected,taxa_selected)
#' }
setMethod("charge_with_filter", signature = signature("ref_stage"), definition = function(object,
    dc_selected, taxa_selected) {
    requete = new("RequeteDBwhere")
    requete@select = paste("SELECT DISTINCT ON (std_code) std_code, std_libelle",
        " FROM ", get_schema(), "tg_dispositif_dis", " JOIN ",
        get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
        " JOIN ref.tr_stadedeveloppement_std on lot_std_code=std_code", sep = "")
    requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected),
        sep = "")
    requete@and = paste("and lot_tax_code in ", vector_to_listsql(taxa_selected),
        sep = "")
    requete@order_by = "ORDER BY std_code"
    requete <- stacomirtools::query(requete)  # appel de la methode connect de l'object requeteDB
    object@data <- requete@query
    if (nrow(object@data) == 0)
        funout(gettext("No data for this counting device and this taxa\n", domain = "R-stacomiR"),
            arret = TRUE)
    return(object)
})


#' choice_c method for ref_stage
#' 
#' the choice_c method is intended to have the same behaviour as choice (which creates a
#' widget in the graphical interface) but from the command line. The values passed to the choice_c method
#' for stage is the code.  Any numeric value will be discarded
#' @param object An object of class \link{ref_stage-class}
#' @param stage the vector of stages chosen
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An S4 object of class \link{ref_stage-class} with the stage selected in the data slot
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples
#' \dontrun{
#'object=new('ref_stage')
#'object<-charge(object)
#' }
setMethod("choice_c", signature = signature("ref_stage"), definition = function(object,
    stage, silent = FALSE) {
    if (is.null(stage)) {
        funout(gettext("No value for argument stage\n", domain = "R-stacomiR"), arret = TRUE)
    }
    missing_std_libelle <- stage[!stage %in% object@data$std_code]
    if (length(missing_std_libelle) > 0 & !silent)
        funout(gettextf("No data for this counting device and this taxa\n %s", stringr::str_c( missing_std_libelle,
            collapse = ", "), domain = "R-stacomiR"))
    object@stage_selected <- object@data[object@data$std_code %in% stage,"std_code"]
    if (nrow(object@data) == 0) {
        funout(gettext("Stop there is no line in the taxa table (problem with the DB link ?)\n",
            domain = "R-stacomiR"), arret = TRUE)
    }
    assign("ref_stage", object, envir = envir_stacomi)
    return(object)
})

#' Function for report_mig graphs including numbers DF DC operations
#'
#' This graph is for species other than glass eel
#'
#'
#' @param report_mig An object of class \code{\linkS4class{report_mig}}
#' @param tableau A data frame with the with the following columns : No.pas,debut_pas,fin_pas,
#' ope_dic_identifiant,lot_tax_code,lot_std_code,type_de_quantite,MESURE,CALCULE,
#' EXPERT,PONCTUEL,Effectif_total,taux_d_echappement,coe_valeur_coefficient
#' @note this function is intended to be called from the plot method in report_mig_mult and report_mig
#' @param time.sequence A vector POSIXt
#' @param taxa The species
#' @param stage The stage
#' @param dc The DC
#' @param silent Message displayed or not
#' @param color Default NULL, a vector of color in the following order, working, stopped, 1...5 types of operation
#' for the fishway or DC, measured, calculated, expert, direct observation. If null will be set to brewer.pal(12,"Paired")[c(8,10,4,6,1,2,3,5,7)]
#' @param color_ope Default NULL, a vector of color for the operations. Default to brewer.pal(4,"Paired")
#' @param ... additional parameters passed to matplot, main, ylab, ylim, lty, pch, bty, cex.main,
#' it is currenly not a good idea to change xlim (numbers are wrong, the month plot covers all month, and legend placement is wrong
#' @return No return value, called for side effects
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
fungraph = function(report_mig,
                    tableau,
                    time.sequence,
                    taxa,
                    stage,
                    dc = NULL,
                    silent,
                    color = NULL,
                    color_ope = NULL,
                    ...) {
  #mat <- matrix(1:6,3,2)
  #layout(mat)
  #browser()
  #cat("fungraph")
  # color=null
  # color calculation
  
	oldpar <- par(no.readonly = TRUE) 
	on.exit(par(oldpar))  
  if (is.null(color)) {
    tp <- RColorBrewer::brewer.pal(12, "Paired")
    mypalette = c(
      "working" = tp[4],
      "stopped" = tp[6],
			"Fonc normal" =  tp[1],
			"Arr ponctuel" = tp[2], 
			"Arr maintenance" = tp[3],
			"Dysfonc" = tp[5], 						
			"Non connu" =  tp[7],
      "ponctuel" = "indianred",
      "expert" = "chartreuse2",
      "calcule" = "deepskyblue",
      "mesure" = "black"
    )
  } else {
    if (length(color) != 11)
      stop("The length of color must be 11")
    mypalette = c(
      "working" =		color[1],
      "stopped" =		color[2],
			"Fonc normal" = color[3],
			"Arr ponctuel" = color[4],
			"Arr maintenance" = color[5],
			"Dysfonc" = color[6],
			"Non connu" = color[7],
      "mesure" =		color[8],
      "calcule" =		color[9],
      "expert" =		color[10],
      "ponctuel" =		color[11]
    )
  }
  
  if (is.null(color_ope)) {
    if (stacomirtools::is.odd(dc))
      brew = "Paired"
    else
      brew = "Accent"
    color_ope = RColorBrewer::brewer.pal(8, brew)
  }
  
  if (is.null(dc))
    dc = report_mig@dc@dc_selected[1]
  annee = unique(strftime(as.POSIXlt(time.sequence), "%Y"))[1]
  mois = months(time.sequence)
  jour = strftime(as.POSIXlt(time.sequence), "%j")
  jmois = strftime(as.POSIXlt(time.sequence), "%d")
  mois = unique(mois)
  mois = paste("15", substr(as.character(mois), 1, 3))
  index = as.vector(tableau$No.pas[jmois == 15])
  x = 1:nrow(tableau)
  debut = unclass(as.POSIXct((min(time.sequence))))[[1]] # attention arrondit e un jour de moins
  fin = unclass(as.POSIXct(max(time.sequence)))[[1]]
  dis_commentaire =  as.character(report_mig@dc@data$dis_commentaires[report_mig@dc@data$dc %in%
                                                                        dc]) # commentaires sur le DC
  ###################################
  # Definition du layout
  ####################################
  vec <- c(rep(1, 15), rep(2, 2), rep(3, 2), 4, rep(5, 6))
  mat <- matrix(vec, length(vec), 1)
  layout(mat)
  
  #par("bg"=grDevices::gray(0.8))
  graphics::par("mar" = c(3, 4, 3, 2) + 0.1)
  ###################################
  # Graph annuel couvrant sequence >0
  ####################################
  dots <- list(...)
  if (!"main" %in% names(dots))
    main = gettextf("Migration graph %s, %s, %s, %s",
                    dis_commentaire,
                    taxa,
                    stage,
                    annee,
                    domain = "R-stacomiR")
  else
    main = dots[["main"]]
  if (!"ylab" %in% names(dots))
    ylab = gettext("Number", domain = "R-stacomiR")
  else
    ylab = dots[["ylab"]]
  if (!"cex.main" %in% names(dots))
    cex.main = 1
  else
    cex.main = dots[["cex.main"]]
  if (!"font.main" %in% names(dots))
    font.main = 1
  else
    font.main = dots[["font.main"]]
  if (!"type" %in% names(dots))
    type = "h"
  else
    type = dots[["type"]]
  if (!"xlim" %in% names(dots))
    xlim = c(debut, fin)
  else
    xlim = c(debut, fin)#dots[["xlim"]] # currently this argument is ignored
  if (!"ylim" %in% names(dots))
    ylim = NULL
  else
    ylim = dots[["ylim"]]
  if (!"cex" %in% names(dots))
    cex = 1
  else
    cex = dots[["cex"]]
  if (!"lty" %in% names(dots))
    lty = 1
  else
    lty = dots[["lty"]]
  if (!"pch" %in% names(dots))
    pch = 16
  else
    pch = dots[["pch"]]
  if (!"bty" %in% names(dots))
    bty = "l"
  else
    bty = dots[["bty"]]
  matplot(
    time.sequence,
    cbind(
      tableau$MESURE + tableau$CALCULE + tableau$EXPERT + tableau$PONCTUEL,
      tableau$MESURE + tableau$CALCULE + tableau$EXPERT,
      tableau$MESURE + tableau$CALCULE,
      tableau$MESURE
    ),
    col = mypalette[c("ponctuel", "expert", "calcule", "mesure")],
    type = type,
    pch = pch,
    lty = lty,
    xaxt = "n",
    bty = bty,
    ylab = ylab,
    xlab = NULL,
    main = main,
    xlim = c(debut, fin),
    cex.main = cex.main,
    font.main = font.main
  )
  if (report_mig@timestep@step_duration == "86400") {
    # pas de temps journalier
    index = as.vector(x[jmois == 15])
    axis(
      side = 1,
      at = index,
      tick = TRUE,
      labels = mois
    )
    #axis(side=1,at=as.vector(x[jmois==1]),tick=TRUE,labels=FALSE)
    
  } else {
    axis(side = 1)
  }
  mtext(
    text = gettextf("Sum of numbers =%s",
                    round(
                      sum(
                        tableau$MESURE,
                        tableau$CALCULE,
                        tableau$EXPERT,
                        tableau$PONCTUEL,
                        na.rm = TRUE
                      )
                    ), domain = "R-stacomiR"),
    side = 3,
    col = mypalette["expert"],
    cex = 0.8
  )
  
  legend(
    x = 0,
    y = max(
      tableau$MESURE,
      tableau$CALCULE,
      tableau$EXPERT,
      tableau$PONCTUEL,
      na.rm = TRUE
    ),
    legend = gettext("measured", "calculated", "expert", "direct", domain =
                       "R-stacomiR"),
    pch = c(16),
    col = mypalette[c("mesure", "calcule", "expert", "ponctuel")]
  )
  report_ope <- get("report_ope", envir = envir_stacomi)
  t_operation_ope <-
    report_ope@data[report_ope@data$ope_dic_identifiant == dc, ]
  dif = difftime(t_operation_ope$ope_date_fin,
                 t_operation_ope$ope_date_debut,
                 units = "days")
  
  if (!silent) {
    funout(ngettext(
      nrow(t_operation_ope),
      "%d operation \n",
      "%d operations \n",
      domain = "R-stacomiR"
    ))
    funout(gettextf("average trapping time = %s days\n", round(mean(
      as.numeric(dif)
    ), 2), domain = "R-stacomiR"))
    funout(gettextf("maximum term = %s", round(max(
      as.numeric(dif)
    ), 2), domain = "R-stacomiR"))
    funout(gettextf("minimum term = %s", round(min(
      as.numeric(dif)
    ), 2), domain = "R-stacomiR"))
  }
  
  
  df <- report_mig@dc@data$df[report_mig@dc@data$dc == dc]
  report_df <- get("report_df", envir = envir_stacomi)
  report_dc <- get("report_dc", envir = envir_stacomi)
  report_df@data <-
    report_df@data[report_df@data$per_dis_identifiant == df, ]
  report_dc@data <-
    report_dc@data[report_dc@data$per_dis_identifiant == dc, ]
  
  
  
  graphdate <- function(vectordate) {
    attributes(vectordate) <- NULL
    vectordate = unclass(vectordate)
    vectordate[vectordate < debut] <- debut
    vectordate[vectordate > fin] <- fin
    return(vectordate)
  }
  
  
  ###################################
  # creation d'un graphique vide (2)
  ###################################
  graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
  plot(
    as.POSIXct(time.sequence),
    seq(0, 3, length.out = nrow(tableau)),
    xlim = xlim,
    type = "n",
    xlab = "",
    xaxt = "n",
    yaxt = "n",
    ylab = gettext("Fishway", domain = "R-stacomiR"),
    bty = "n",
    cex = cex + 0.2
  )
  
  ###################################
  # time for DF (fishway) operation
  ###################################
  
  if (dim(report_df@data)[1] == 0) {
    rect(
      xleft = debut,
      ybottom = 2.1,
      xright = fin,
      ytop = 3,
      col = "grey",
      border = NA,
      lwd = 1
    )
    rect(
      xleft = debut,
      ybottom = 1.1,
      xright = fin,
      ytop = 2,
      col = "grey40",
      border = NA,
      lwd = 1
    )
    legend(
      x = "bottom",
      legend = gettext("Unknown working", "Unknow operation type", domain =
                         "R-stacomiR"),
      pch = c(16, 16),
      col = c("grey", "grey40"),
      horiz = TRUE,
      bty = "n"
    )
    
    
  } else {
    # si il sort quelque chose
    if (sum(report_df@data$per_etat_fonctionnement == 1) > 0) {
      rect(
        xleft = graphdate(as.POSIXct(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
                                                                     1])),
        ybottom = 2.1,
        xright = graphdate(as.POSIXct(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
                                                                    1])),
        ytop = 3,
        col = mypalette["working"],
        border = NA,
        lwd = 1
      )
    }
    if (sum(report_df@data$per_etat_fonctionnement == 0) > 0) {
      rect(
        xleft = graphdate(as.POSIXct(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
                                                                     0])),
        ybottom = 2.1,
        xright = graphdate(as.POSIXct(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
                                                                    0])),
        ytop = 3,
        col = mypalette["stopped"],
        border = NA,
        lwd = 1
      )
    }
    #creation d'une liste par categorie d'arret contenant vecteurs dates
    listeperiode <-
      fun_table_per_dis(
        typeperiode = report_df@data$per_tar_code,
        tempsdebut = report_df@data$per_date_debut,
        tempsfin = report_df@data$per_date_fin,
        libelle = report_df@data$libelle,
				color= mypalette[report_df@data$libelle],
        date = FALSE
      )
    nomperiode <- vector()
    color_periodes <-
      vector() # a vector of colors, one per period type in listeperiode
    for (j in 1:length(listeperiode)) {
      #recuperation du vecteur de noms (dans l'ordre) e partir de la liste
      nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
      #ecriture pour chaque type de periode
      color_periode = listeperiode[[j]]$color
      rect(
        xleft = graphdate(listeperiode[[j]]$debut),
        ybottom = 1.1,
        xright = graphdate(listeperiode[[j]]$fin),
        ytop = 2,
        col = color_periode,
        border = NA,
        lwd = 1
      )
      color_periodes <- c(color_periodes, color_periode)
    }
    
    legend  (
      x = debut,
      y = 1.2,
      legend = c(gettext("stop", domain = "R-stacomiR"), nomperiode),
      pch = c(15, 15),
      col = c(mypalette["working"], mypalette["stopped"], color_periodes),
      bty = "n",
      ncol = 7,
      text.width = (fin - debut) / 10
    )
  }
  
  ###################################
  # creation d'un graphique vide (3)
  ###################################
  
  graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
  plot(
    as.POSIXct(time.sequence),
    seq(0, 3, length.out = nrow(tableau)),
    xlim = xlim,
    type = "n",
    xlab = "",
    xaxt = "n",
    yaxt = "n",
    ylab = gettext("CD", domain = "R-stacomiR"),
    bty = "n",
    cex = cex + 0.2
  )
  ###################################
  # time for DC (counting device) operation
  ###################################
  
  
  if (dim(report_dc@data)[1] == 0) {
    rect(
      xleft = debut,
      ybottom = 2.1,
      xright = fin,
      ytop = 3,
      col = "grey",
      border = NA,
      lwd = 1
    )
    
    rect(
      xleft = debut,
      ybottom = 1.1,
      xright = fin,
      ytop = 2,
      col = "grey40",
      border = NA,
      lwd = 1
    )
    legend(
      x = "bottom",
      legend = gettext("Unknown working", "Unknow operation type", domain =
                         "R-stacomiR"),
      pch = c(16, 16),
      col = c("grey", "grey40"),
      #horiz=TRUE,
      ncol = 5,
      bty = "n"
    )
    
    
  } else {
    if (sum(report_dc@data$per_etat_fonctionnement == 1) > 0) {
      rect(
        xleft = graphdate(as.POSIXct(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
                                                                     1])),
        ybottom = 2.1,
        xright = graphdate(as.POSIXct(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
                                                                    1])),
        ytop = 3,
        col = mypalette["working"],
        border = NA,
        lwd = 1
      )
    }
    if (sum(report_dc@data$per_etat_fonctionnement == 0) > 0)
    {
      rect(
        xleft = graphdate(as.POSIXct(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
                                                                     0])),
        ybottom = 2.1,
        xright = graphdate(as.POSIXct(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
                                                                    0])),
        ytop = 3,
        col = mypalette["stopped"],
        border = NA,
        lwd = 1
      )
    }
    listeperiode <-
      fun_table_per_dis(
        typeperiode = report_dc@data$per_tar_code,
        tempsdebut = report_dc@data$per_date_debut,
        tempsfin = report_dc@data$per_date_fin,
        libelle = report_dc@data$libelle,
				color= mypalette[report_df@data$libelle],
        date = FALSE
      )
    nomperiode <- vector()
    color_periodes <- vector()
    for (j in 1:length(listeperiode)) {
      nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
      color_periode <- listeperiode[[j]]$color
      rect(
        xleft = graphdate(listeperiode[[j]]$debut),
        ybottom = 1.1,
        xright = graphdate(listeperiode[[j]]$fin),
        ytop = 2,
        col = color_periode,
        border = NA,
        lwd = 1
      )
    }
    
    legend  (
      x = debut,
      y = 1.2,
      legend = gettext("working", "stopped", nomperiode, domain = "R-stacomiR"),
      pch = c(15, 15),
      col = c(mypalette["working"], mypalette["stopped"], color_periodes),
      bty = "n",
      ncol = length(listeperiode) + 2,
      text.width = (fin - debut) / 10
    )
  }
  
  ###################################
  # creation d'un graphique vide (4=op)
  ###################################
  
  
  graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
  plot(
    as.POSIXct(time.sequence),
    seq(0, 1, length.out = nrow(tableau)),
    xlim = xlim,
    type = "n",
    xlab = "",
    xaxt = "n",
    yaxt = "n",
    ylab = gettext("Op", domain = "R-stacomiR"),
    bty = "n",
    cex = cex + 0.2
  )
  ###################################
  # operations
  ###################################
  
  rect(
    xleft = graphdate(as.POSIXct(t_operation_ope$ope_date_debut)),
    ybottom = 0,
    xright = graphdate(as.POSIXct(t_operation_ope$ope_date_fin)),
    ytop = 1,
    col = color_ope,
    border = NA,
    lwd = 1
  )
  
  
  ###################################
  # Graph mensuel
  ####################################
  graphics::par("mar" = c(4, 4, 1, 2) + 0.1)
  tableau$mois = factor(months(tableau$debut_pas, abbreviate = TRUE),
                        levels = unique(months(tableau$debut_pas, abbreviate = TRUE)))
  tableaum <-
    reshape2::melt(
      data = tableau[, c("MESURE", "CALCULE", "EXPERT", "PONCTUEL", "mois")],
      id.vars = c("mois"),
      measure.vars = c("MESURE", "CALCULE", "EXPERT", "PONCTUEL"),
      variable.name = "type",
      value.name = "number"
    )
  levels(tableaum$type) <-
    gettext("measured", "calculated", "expert", "direct", domain = "R-stacomiR")
  superpose.polygon <- lattice::trellis.par.get("plot.polygon")
  superpose.polygon$col =  mypalette[c("mesure", "calcule", "expert", "ponctuel")]
  superpose.polygon$border = rep("transparent", 6)
  lattice::trellis.par.set("superpose.polygon", superpose.polygon)
  fontsize <- lattice::trellis.par.get("fontsize")
  fontsize$text = 10
  lattice::trellis.par.set("fontsize", fontsize)
  par.main.text <- lattice::trellis.par.get("par.main.text")
  par.main.text$cex = 1
  par.main.text$font = 1
  lattice::trellis.par.set("par.main.text", par.main.text)
  # lattice::show.settings()
  
  par.ylab.text <- lattice::trellis.par.get("par.ylab.text")
  par.ylab.text$cex = 0.8
  lattice::trellis.par.set("par.ylab.text", par.ylab.text)
  par.xlab.text <- lattice::trellis.par.get("par.xlab.text")
  par.xlab.text$cex = 0.8
  lattice::trellis.par.set("par.xlab.text", par.xlab.text)
  
  bar <- lattice::barchart(
    number / 1000 ~ mois,
    groups = type,
    xlab = gettext("Month", domain = "R-stacomiR"),
    ylab = gettext("Number (x1000)", domain = "R-stacomiR"),
    data = tableaum,
    allow.multiple = FALSE,
    strip = FALSE,
    stack = TRUE,
    origin = 0
  )
  print(bar, position = c(0, 0, 1, .25), newpage = FALSE)
  
  return(invisible(NULL))
}

#' Class 'ref_taxa'
#' 
#' Loading and selection of fish species. This class is a referential class, and it is 
#' integrated into refreport objects.
#' 
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_taxa', ...)}.   
#' @slot data A \code{'data.frame'} of species available in the database
#' @slot taxa_selected Contains the code \code{'tax_code'} of the taxa selected by choice_c() method
#' @author cedric.briand@eptb-vilaine.fr
#' @family referential objects
setClass(Class = "ref_taxa", representation = representation(data = "data.frame",taxa_selected = "character"))


#' Loading method for ref_taxa referential objects
#' 
#' @return An S4 object of class ref_taxa
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @param object An object of class \link{ref_taxa-class}
#' @return An S4 object of class \link{ref_taxa-class} with all taxa loaded from the database
#' @examples \dontrun{
#'  object=new('ref_taxa')
#'  charge(object)}
setMethod("charge", signature = signature("ref_taxa"), definition = function(object) {
    req = new("RequeteDB")
    req@sql = "SELECT tax_code, tax_nom_latin, tax_nom_commun, tax_ntx_code, tax_tax_code FROM ref.tr_taxon_tax  ORDER BY tax_rang ASC ;"
    req <- stacomirtools::query(req) 
    object@data <- req@query
    return(object)
})

#' Loading method for ref_taxa referential objects searching only taxa existing for a DC
#' @param object An object of class \link{ref_taxa-class}
#' @param dc_selected A counting device selected, only taxa attached to this dc are selected
#' @return An S4 object of class \link{ref_taxa-class} with all taxa present on a DC (counting device)
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples \dontrun{
#'  dc_selected=6
#'  object=new('ref_taxa')
#'  charge_with_filter(object,dc_selected=dc_selected)}
setMethod("charge_with_filter", signature = signature("ref_taxa"), definition = function(object,
    dc_selected) {
    requete = new("RequeteDBwhere")
    requete@select = paste("SELECT DISTINCT ON (tax_rang) tax_code, tax_nom_latin, tax_nom_commun, tax_ntx_code, tax_tax_code",
        " FROM ", get_schema(), "tg_dispositif_dis", " JOIN ",
        get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
        " JOIN ref.tr_taxon_tax on lot_tax_code=tax_code", sep = "")
    requete@where = paste("where dis_identifiant in", vector_to_listsql(dc_selected))
    requete@order_by = "ORDER BY tax_rang ASC"
    requete <- stacomirtools::query(requete)
    object@data <- requete@query
    return(object)
})


#' choice_c method for ref_taxa
#' 
#' the choice_cc method is intended to have the same behaviour as choice (which creates a
#' widget in the graphical interface) but from the command line. The values passed to the choice_c method
#' for taxa can be either numeric (2038 = Anguilla anguilla) or character.  
#' @param object An object from the class ref_taxa
#' @param taxa The vector of taxa, can be either code (numeric) or latin name
#' @return An S4 object of class \link{ref_taxa-class} with data filtered according to the taxa
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples
#' \dontrun{
#' object=new('ref_taxa')
#' object<-charge(object)
#' objectreport=new('report_mig_mult')
#' choice_c(object=object,'Anguilla anguilla')
#' }
setMethod("choice_c", signature = signature("ref_taxa"), definition = function(object,
    taxa) {
    if (is.null(taxa)) {
        funout(gettext("No value for argument taxa\n", domain = "R-stacomiR"), arret = TRUE)
    } else if (inherits(taxa, "character") & suppressWarnings(all(is.na(as.numeric(taxa))))) {
			# taxa is 'Anguilla anguilla'
        libellemanquants <- taxa[!taxa %in% object@data$tax_nom_latin]
        if (length(libellemanquants) > 0)
            warning(gettextf("Taxa not present :\n %s", stringr::str_c(libellemanquants,
                collapse = ", "), domain = "R-stacomiR"))
        object@taxa_selected <- object@data[object@data$tax_nom_latin %in% taxa,"tax_code"]
    } else if (inherits(taxa, "numeric")){
			# taxa is  2038
        codemanquants <- taxa[!as.character(taxa) %in% object@data$tax_code]
        if (length(codemanquants) > 0)
            warning(gettextf("Taxa not present :\n %s", stringr::str_c(codemanquants,
                collapse = ", "), domain = "R-stacomiR"))
        object@taxa_selected <- object@data[object@data$tax_code %in% as.character(taxa),"tax_code"]
    } else if (inherits(taxa, "character") & !suppressWarnings(all(is.na(as.numeric(taxa))))){
			# taxa is "2038"
			codemanquants <- taxa[!taxa %in% object@data$tax_code]
			if (length(codemanquants) > 0)
				warning(gettextf("Taxa not present :\n %s", stringr::str_c(codemanquants,
										collapse = ", "), domain = "R-stacomiR"))
			object@taxa_selected <- object@data[object@data$tax_code %in% taxa, "tax_code"]		
		}
    if (nrow(object@data) == 0) {
        funout(gettext("Stop there is no line in the taxa table (problem with the DB link ?)\n",
            domain = "R-stacomiR"), arret = TRUE)
    }
    assign("ref_taxa", object, envir = envir_stacomi)
    return(object)
})

#' Class "report_sea_age"
#'
#' the report_sea_age class is used to dispatch adult salmons to age class according to
#' their size and to basin dependent limits set by the user. Once checked with graphs and summary
#' statistics, the results are to be written to the database.
#' @include create_generic.R
#' @include ref_textbox.R
#' @include ref_dc.R
#' @include ref_taxa.R
#' @include ref_stage.R
#' @include ref_horodate.R
#' @include ref_par.R
#' @note This class is displayed by interface_report_sea_age
#' @slot data A data frame with data generated from the database
#' @slot calcdata A list of dc with processed data. This lists consists of two elements
#' \itemize{
#' \item (1) data A dataset with age set to be used by the plot and summary methods
#' \item (2) tj_caracteristitiquelot_car A dataset to import into the database
#' }
#' @slot dc Object of class \link{ref_dc-class}: the control devices
#' @slot taxa Object of class \link{ref_taxa-class}: the species
#' @slot stage Object of class \link{ref_stage-class} : the stages of the fish
#' @slot par Object of class \link{ref_par-class}: the parameters used
#' @slot horodatedebut An object of class \code{ref_horodate-class}
#' @slot horodatefin An object of class \code{ref_horodate-class}
#' @slot limit1hm The size limit, in mm between 1 sea winter fishes and 2 sea winter fishes
#' @slot limit2hm The size limit, in mm between 2 sea winter fishes and 3 sea winter fishes
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("report_sea_age", ...)}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_sea_age-example.R
#' @aliases report_sea_age
#' @export
setClass(
		Class = "report_sea_age",
		representation = representation(
				data = "data.frame",
				calcdata = "list",
				dc = "ref_dc",
				taxa = "ref_taxa",
				stage = "ref_stage",
				par = "ref_par",
				horodatedebut = "ref_horodate",
				horodatefin = "ref_horodate",
				limit1hm = "ref_textbox",
				limit2hm = "ref_textbox"
		),
		prototype = prototype(
				data = data.frame(),
				calcdata = list(),
				dc = new("ref_dc"),
				taxa = new("ref_taxa"),
				stage = new("ref_stage"),
				par = new("ref_par"),
				horodatedebut = new("ref_horodate"),
				horodatefin = new("ref_horodate"),
				limit1hm = new("ref_textbox"),
				limit2hm = new("ref_textbox")
		)
)
setValidity("report_sea_age", function(object)
		{
			rep1 = object@taxa@taxa_selected[1] == '2220'
			label1 <-
					'report_sea_age should only be for salmon (tax_code=2220)'
			rep2 = all(object@stage@stage_selected %in% c('5', '11', 'BEC', 'BER', 'IND'))
			label2 <-
					'Only stages 5,11,BEC,BER,IND should be used in report_sea_age'
			return(ifelse(rep1 &
									rep2 , TRUE , c(label1, label2)[!c(rep1, rep2)]))
		})
#' connect method for report_sea_age
#'
#' @param object An object of class \link{report_sea_age-class}
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return An object of class \link{report_sea_age-class} with slot data \code{@data} filled
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases connect.report_sea_age
setMethod(
		"connect",
		signature = signature("report_sea_age"),
		definition = function(object, silent = FALSE) {
			requete <- new("RequeteDBwheredate")
			requete@select = paste("SELECT * FROM ",
					get_schema(),
					"vue_lot_ope_car",
					sep = "")
			requete@colonnedebut = "ope_date_debut"
			requete@colonnefin = "ope_date_fin"
			requete@datedebut <- object@horodatedebut@horodate
			requete@datefin <- object@horodatefin@horodate
			requete@order_by = "ORDER BY ope_date_debut"
			requete@and = paste(
					" AND ope_dic_identifiant in ",
					vector_to_listsql(object@dc@dc_selected),
					" AND lot_tax_code in ",
					vector_to_listsql(object@taxa@taxa_selected),
					" AND lot_std_code in ",
					vector_to_listsql(object@stage@stage_selected),
					" AND car_par_code in ",
					vector_to_listsql(object@par@par_selected),
					sep = ""
			)
			requete <- stacomirtools::query(requete)
			object@data <- requete@query
			if (!silent)
				funout(gettext("Data loaded", domain = "R-stacomiR"))
			return(object)
		}
)


#' Loads data and check that all choices in the graphical interface have been made.
#'
#' It is not necessary to run this method if the choice_c method has been run.
#' This method verifies that boxes have been clicked in the user interface and gets the objects pasted in
#' envir_stacomi
#' @param object An object of class \link{report_sea_age-class}
#' @param h a handler
#' @return An object of class \link{report_sea_age-class} with slots filled with user choice
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of class \link{report_sea_age-class} with slots filled from values assigned in \code{envir_stacomi} environment
#' @aliases charge.report_sea_age
#' @keywords internal
setMethod(
		"charge",
		signature = signature("report_sea_age"),
		definition = function(object, h) {
			if (exists("ref_dc", envir_stacomi)) {
				object@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)) {
				object@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)) {
				object@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("ref_par", envir_stacomi)) {
				object@par <- get("ref_par", envir_stacomi)
			} else {
				funout(
						gettext("You need to choose a parameter, clic on validate\n", domain = "R-stacomiR"),
						arret = TRUE
				)
			}
			# rem pas tres satisfaisant car ce nom est choisi dans l'interface
			if (exists("r_seaa_date_debut", envir_stacomi)) {
				object@horodatedebut@horodate <-
						get("r_seaa_date_debut", envir_stacomi)
			} else {
				funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			# rem id
			if (exists("r_seaa_date_fin", envir_stacomi)) {
				object@horodatefin@horodate <- get("r_seaa_date_fin", envir_stacomi)
			} else {
				funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			if (exists("limit1hm", envir_stacomi)) {
				object@limit1hm <- get("limit1hm", envir_stacomi)
			} else {
				funout(gettext("you need to choose a value for limit1hm", domain = "R-stacomiR"),
						arret = TRUE)
			}
			if (exists("limit2hm", envir_stacomi)) {
				object@limit2hm <- get("limit2hm", envir_stacomi)
			} else {
				funout(gettext("you need to choose a value for limit2hm", domain = "R-stacomiR"),
						arret = TRUE)
			}
			return(object)
			validObject(object)
			assign("r_seaa", object, envir_stacomi)
		}
)


#' command line interface for report_sea_age class
#' 
#' #' The choice_c method fills in the data slot for classes \link{ref_dc-class}, \link{ref_taxa-class}, \link{ref_stage-class}, \link{ref_par-class} and two slots of \link{ref_horodate-class} and then
#' uses the choice_c methods of these object to select the data.
#' @param object An object of class \link{report_sea_age-class}
#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
#' @param taxa '2220=Salmo salar',
#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
#' @param stage '5','11','BEC','BER','IND'
#' @param par Parameters chosen for the report are measured body size (1786), measured fork length (1785),video size (C001) and number of year at sea (A124)
#' @param horodatedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param horodatefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
#' @param limit1hm Size limit of a salmon for an one sea winter fish
#' @param limit2hm Size limit of a salmon for a two sea winter fish
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return An object of class \link{report_sea_age-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_sea_age
setMethod(
		"choice_c",
		signature = signature("report_sea_age"),
		definition = function(object,
				dc,
				taxa = 2220,
				stage = c('5', '11', 'BEC', 'BER', 'IND'),
				par = c('1786', '1785', 'C001', 'A124'),
				horodatedebut,
				horodatefin,
				limit1hm,
				limit2hm,
				silent = FALSE) {
			# code for debug using example
			#horodatedebut="2012-01-01";horodatefin="2013-12-31";dc=c(107,108,101);
			#taxa=2220;	stage=c('5','11','BEC','BER','IND');par=c('1786','1785','C001');silent=FALSE
			if (!(is.numeric(limit1hm) |
						is.integer(limit1hm)))
				funout(gettext("limit1hm should be numeric or integer", domain = "R-stacomiR"),
						arret = TRUE)
			if (!(is.numeric(limit2hm) |
						is.integer(limit2hm)))
				funout(gettext("limit2hm should be numeric or integer", domain = "R-stacomiR"),
						arret = TRUE)
			
			r_seaa <- object
			r_seaa@dc = charge(r_seaa@dc)
			# loads and verifies the dc
			# this will set dc_selected slot
			r_seaa@dc <- choice_c(object = r_seaa@dc, dc)
			# only taxa present in the report_mig are used
			r_seaa@taxa <-
					charge_with_filter(object = r_seaa@taxa, r_seaa@dc@dc_selected)
			r_seaa@taxa <- choice_c(r_seaa@taxa, taxa)
			r_seaa@stage <-
					charge_with_filter(object = r_seaa@stage,
							r_seaa@dc@dc_selected,
							r_seaa@taxa@taxa_selected)
			r_seaa@stage <- choice_c(r_seaa@stage, stage, silent = silent)
			r_seaa@par <-
					charge_with_filter(
							object = r_seaa@par,
							r_seaa@dc@dc_selected,
							r_seaa@taxa@taxa_selected,
							r_seaa@stage@stage_selected
					)
			r_seaa@par <- choice_c(r_seaa@par, par, silent = silent)
			r_seaa@horodatedebut <- choice_c(
					object = r_seaa@horodatedebut,
					nomassign = "r_seaa_date_debut",
					funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatedebut,
					silent = silent
			)
			r_seaa@horodatefin <- choice_c(
					r_seaa@horodatefin,
					nomassign = "r_seaa_date_fin",
					funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
					horodate = horodatefin,
					silent = silent
			)
			r_seaa@limit1hm <-
					choice_c(r_seaa@limit1hm, as.character(limit1hm), "limit1hm")
			r_seaa@limit2hm <-
					choice_c(r_seaa@limit2hm, as.character(limit2hm), "limit2hm")
			validObject(r_seaa)
			return(r_seaa)
		}
)

#' Split data according to the limits
#' set in the limit1hm, and limit2hm arguments of the \link{report_sea_age-class}.
#'
#' If no value are provided in the limit1hm slot, an error is returned, if
#' no value is provided in the limit2hm slot a default upper value for salmon
#' size is taken to ensure all salmon are either of age 1 or 2, but no age 3 are
#' returned
#' @param object An object of class \code{\link{report_sea_age-class}}
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of class \link{report_sea_age-class} with calculated data in slot calcdata
#' @aliases calcule.report_sea_age
setMethod(
		"calcule",
		signature = signature("report_sea_age"),
		definition = function(object, silent) {
			#r_seaa<-r_sample_char
			r_seaa <- object
			if (nrow(r_seaa@data) == 0) {
				funout(
						gettext("you have no line in the database for this period", domain = "R-stacomiR"),
						arret = TRUE
				)
			}
			adm = r_seaa@data # we get the data.frame
			# the age already present in the database don't interest us there
			adm = adm[adm$car_par_code != 'A124', ]
			if (is.na(as.numeric(r_seaa@limit1hm@label)))
				stop("internal error")
			# if no value, a dummy value of 2m
			if (is.na(as.numeric(r_seaa@limit2hm@label)))
				r_seaa@limit2hm@label <- 2000
			lescoupes <-
					c(0,
							as.numeric(r_seaa@limit1hm@label),
							as.numeric(r_seaa@limit2hm@label),
							2001)
			adm$age <-
					cut(
							x = adm$car_valeur_quantitatif,
							breaks = lescoupes,
							labels = FALSE
					)
			r_seaa@calcdata[["data"]] <- adm
			assign("r_seaa", r_seaa, envir_stacomi)
			return(r_seaa)
		}
)


#' Plots of various type for report_sea_age
#'
#' @param x An object of class \link{report_sea_age-class}
#' @param plot.type Default "1"
#'  \itemize{
#' 		\item{plot.type="1"}{density plot by sea age}
#' 		\item{plot.type="2"}{Density plot by sea age and dc}
#' }
#' @param silent Default FALSE, if TRUE the program should no display messages.
#' @return Nothing, called for its side effect of plotting
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_sea_age
#' @export
setMethod(
		"plot",
		signature(x = "report_sea_age", y = "missing"),
		definition = function(x,
				plot.type = "1",
				silent = FALSE) {
			#require(ggplot2);plot.type="1"
			#browser()
			r_seaa <- x
			plot.type <- as.character(plot.type)# to pass also characters
			if (!plot.type %in% c("1", "2"))
				stop('plot.type must be 1,2')
			if (nrow(r_seaa@calcdata[["data"]]) == 0) {
				if (!silent)
					funout(
							gettext("You need to launch computation first, clic on calc\n", domain =
											"R-stacomiR"),
							arret = TRUE
					)
			}
			dat <- r_seaa@calcdata[["data"]]
			# cols are using viridis::inferno(6,alpha=0.9)
			les_coupes = as.numeric(c(r_seaa@limit1hm@label, r_seaa@limit2hm@label))
			
			
			#################################################
			# plot.type =1 density plot
			#################################################
			
			if (plot.type == "1") {
				p <-
						ggplot(dat) + geom_histogram(
								aes(x = car_valeur_quantitatif, fill = factor(age)),
								binwidth = 10,
								alpha = 0.8
						) +
						geom_vline(xintercept = les_coupes,
								lty = 2,
								lwd = 1) +
						annotate(
								"text",
								x = les_coupes,
								y = 0,
								label = les_coupes,
								vjust = 1,
								hjust = -0.2
						) +
						theme_minimal() +
						scale_fill_manual("Age",
								values = c("1" = "#379ec6", "2" = "#173957", "3" = "#b09953")) +
						xlab("Size in mm") +
						ylab("Effectif")
				print(p)
				assign("p", p, envir = envir_stacomi)
				if (!silent){
					funout(
							gettext(
									"The graphical object is written is env_stacomi, type p<-get('p',envir=envir_stacomi)",
									domain = "R-stacomiR"
							)
					)}
				
			}
			######################################
			# Migration according to stage, month and year
			######################################
			# todo see of anotation is possible
			if (plot.type == "2") {
				p <-
						ggplot(dat) + geom_histogram(
								aes(x = car_valeur_quantitatif, fill = factor(age)),
								binwidth = 10,
								alpha = 0.8
						) +
						geom_vline(xintercept = les_coupes,
								lty = 2,
								lwd = 1) +
						theme_minimal() +
						scale_fill_manual("Age",
								values = c("1" = "#379ec6", "2" = "#173957", "3" = "#b09953")) +
						xlab("Size in mm") +
						ylab("Effectif") +
						facet_grid(ope_dic_identifiant ~ .)
				print(p)
				assign("p", p, envir = envir_stacomi)
				if (!silent){
					funout(
							gettext(
									"The graphical object is written is env_stacomi, type p<-get('p',envir=envir_stacomi)",
									domain = "R-stacomiR"
							)
					)
				}
			}
			return(invisible(NULL))
		}
)

#' summary for report_sea_age
#' @param object An object of class \link{report_sea_age-class}
#' @param silent Default FALSE, if TRUE the program should no display messages.
#' @param ... Additional parameters
#' @return The summary
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_sea_age
#' @export
setMethod(
		"summary",
		signature = signature(object = "report_sea_age"),
		definition = function(object, silent = FALSE, ...) {
			r_seaa <- object
			dat <- r_seaa@calcdata[["data"]]
			if (nrow(dat) == 0) {
				if (!silent)
					funout(
							gettext("You need to launch computation first, clic on calc\n", domain =
											"R-stacomiR"),
							arret = TRUE
					)
			}
			ndc = unique(dat$ope_dic_identifiant)
			result <- list()
			for (i in 1:length(ndc)) {
				datdc <-	dat[dat$ope_dic_identifiant == ndc[i], ]
				dc_code <- r_seaa@dc@data$dc_code[r_seaa@dc@data$dc == ndc[i]]
				ouvrage <-
						gsub("[\r\n]", "", r_seaa@dc@data[r_seaa@dc@data$dc == r_seaa@dc@dc_selected[i], "ouv_libelle"])
				dc <- as.character(unique(datdc$ope_dic_identifiant))
				result[[dc]] <- list()
				result[[dc]][["ouvrage"]] <- ouvrage
				print(noquote(
								stringr::str_c("Age Statistics for dam : ", ouvrage, " CD=", dc_code)
						))
				print(noquote("========================"))
				print(table(datdc$age))
				result[[dc]][["age"]] <- table(datdc$age)
				
			}
			if (length(ndc) > 1) {
				print(noquote(stringr::str_c("Age Statistics total")))
				print(noquote("========================"))
				print(table(dat$age))
				
			}
			return(result)
		}
)

#' Command line method to write the characteristic "sea age" (car_par_code='A124')
#' into the tj_caracteristiquelot_car table in the user's scheme
#'
#' The sea age characteristic is calculated from the measured or calculated size of salmon and with a size/age rule
#' defined by the user. 
#' @param object an object of class \link{report_sea_age-class}
#' @param silent : Default FALSE, if TRUE the program should no display messages.
#' @return Nothing, called for its side effect of writing data to the database
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases write_database.report_sea_age
#' @export
setMethod(
		"write_database",
		signature = signature("report_sea_age"),
		definition = function(object, silent = TRUE) {
			# dbname="bd_contmig_nat"
			r_seaa <- object
			calcdata <- r_seaa@calcdata[["data"]]
			data_in_base <- r_seaa@data
			if (nrow(calcdata) == 0) {
				if (!silent)
					funout(
							gettext("You need to launch computation first, clic on calc\n", domain =
											"R-stacomiR"),
							arret = TRUE
					)
			}
			if (!inherits(r_seaa, "report_sea_age"))
				stop("the r_seaa should be of class report_sea_age")
			if (!inherits(silent, "logical"))
				stop("the silent argument should be a logical")
			data_in_base <- data_in_base[data_in_base$car_par_code == 'A124', ]
			if (nrow(data_in_base) > 0) {
				supprime(r_seaa, silent = silent)
			}
			#--------------
			# creating the table to import
			#--------------
			code_parametre_age = 'A124'
			code_methode_obtention = "CALCULE"
			comment = gettextf(
					"Age calculated from the size of fish compared to reference value %s for the limit between 1 sea winter and 2 sea winter fish, and %s for the limit between 2 sea winter fish and 3 sea winter fish",
					r_seaa@limit1hm@label,
					r_seaa@limit2hm@label
			)
			bam = data.frame(
					r_seaa@calcdata$data$lot_identifiant,
					code_parametre_age,
					code_methode_obtention,
					as.integer(NA),
					r_seaa@calcdata$data$age,
					as.integer(NA),
					comment,
					get_org()
			)
			#--------------
			# writing the table in the database
			#--------------
			con <- new("ConnectionDB")
			con <- connect(con)
			on.exit(pool::poolClose(con@connection))
			pool::dbWriteTable(con@connection, 
					name = "bam", 
					value=bam, 
					temporary=TRUE)	
			
			sql <-
					stringr::str_c(
							"INSERT INTO ",
							get_schema(),
							"tj_caracteristiquelot_car 	SELECT * FROM  bam;"
					)
			
			pool::dbExecute(con@connection, statement = sql)
			
			if (!silent) {
				funout(gettextf("Writing  %s age values in the database \n", nrow(bam)))
			}
			return(invisible(NULL))
		}
)

#' Method to print the command line of the object
#' @param x An object of class report_sea_age
#' @param ... Additional parameters passed to print
#' @return NULL
#' @author cedric.briand
#' @aliases print.report_sea_age
#' @export
setMethod(
		"print",
		signature = signature("report_sea_age"),
		definition = function(x, ...) {
			sortie1 <- "r_seaa=new('report_sea_age')"
			sortie2 <- stringr::str_c(
					"r_seaa=choice_c(r_seaa,",
					"dc=c(",
					stringr::str_c(x@dc@dc_selected, collapse = ","),
					"),",
					"taxa=c(",
					stringr::str_c(shQuote(x@taxa@data$tax_nom_latin), collapse = ","),
					"),",
					"stage=c(",
					stringr::str_c(shQuote(x@stage@stage_selected), collapse = ","),
					"),",
					"par=c(",
					stringr::str_c(shQuote(x@par@par_selected), collapse = ","),
					"),",
					"horodatedebut=",
					shQuote(
							strftime(x@horodatedebut@horodate, format = "%d/%m/%Y %H-%M-%S")
					),
					",horodatefin=",
					shQuote(
							strftime(x@horodatefin@horodate, format = "%d/%m/%Y %H-%M-%S")
					),
					")"
			)
			# removing backslashes
			funout(sortie1)
			funout(stringr::str_c(sortie2, ...))
			return(invisible(NULL))
		}
)




#' supprime method for report_mig_interannual class
#' @param object An object of class \link{report_sea_age-class}
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return Nothing, called for its side effect of deleting data in the database
#' @aliases supprime.report_sea_age
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
setMethod(
		"supprime",
		signature = signature("report_sea_age"),
		definition = function(object, silent = FALSE)
		{
			r_seaa <- object
			data_in_base <- r_seaa@data
			data_in_base <- data_in_base[data_in_base$car_par_code == 'A124', ]
			if (nrow(data_in_base) == 0) {
				if (!silent)
					funout(gettext("No data to remove"), arret = TRUE)
			}
			con = new("ConnectionDB")
			con <- connect(con)
			on.exit(pool::poolClose(con@connection))
			sql =  stringr::str_c("DELETE from ", 
					get_schema(),
					"tj_caracteristiquelot_car ",
					"WHERE car_lot_identifiant IN ",
					vector_to_listsql(data_in_base$lot_identifiant),
					" AND car_par_code='A124';"					
			)
			pool::dbExecute(con@connection, statement = sql)			
			return(invisible(NULL))
		}

)

#' Validity check for ref_year
#'
#' validity_year tests for validity within the class
#'
#'
#' @param object An object of class \code{\linkS4class{ref_year}}
#' @return boolean The test for the object refannee
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @keywords internal
validity_year = function(object)
{
	rep1 = inherits(object@data, "data.frame")
	rep2 = inherits(object@year_selected, "numeric")
	
	return(ifelse(rep1 & rep2, TRUE, FALSE))
}
#definition de la classe

#' Year reference class
#'
#' Class used to select one or several years
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("ref_year", data=data.frame(), year_selected=numeric())}.
#' @include create_generic.R
#' @slot data A \code{data.frame} with the list of possible years selected as numerics
#' @slot year_selected A numeric vector
#' @keywords classes
#' @family referential objects
#' @author cedric.briand@eptb-vilaine.fr
setClass(
		Class = "ref_year",
		representation =
				representation(data = "data.frame", year_selected = "numeric"),
		validity = validity_year,
		prototype = prototype(data = data.frame(), year_selected = numeric())
)

#' Loading method for ref_year referential objects
#'
#' Selects year available either in the bjo table if report_object==report_mig_interannual) or in the t_operation_ope table
#' @param object An object of class \link{ref_year-class}
#' @param objectreport The object report, default \code{report_ge_weight} other possible value report_mig_interannual
#' @return object An object of class \link{ref_year-class} with slot data filled with the available years for the corresponding report
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples
#' \dontrun{
#' object=new("ref_year")
#' charge(object)
#'  validObject(annee)
#' showMethods("charge")
#' }
setMethod(
		"charge",
		signature = signature("ref_year"),
		definition = function(object, objectreport = "report_ge_weight") {
			requete = new("RequeteDB")
			if (objectreport == "report_mig_interannual") {
				if (exists("ref_dc", envir_stacomi)) {
					dc <- get("ref_dc", envir_stacomi)
					and1 <- paste(" AND bjo_dis_identifiant in", vector_to_listsql(dc@dc_selected))
				} else {
					and1 <- ""
				}
				if (exists("ref_taxa", envir_stacomi)) {
					taxa <- get("ref_taxa", envir_stacomi)
					and2 <-
							stringr::str_c(" AND bjo_tax_code ='", taxa@taxa_selected, "'")
				} else {
					and2 <- ""
				}
				if (exists("ref_stage", envir_stacomi)) {
					stage <- get("ref_stage", envir_stacomi)
					and3 <-
							stringr::str_c(" AND bjo_std_code ='", stage@stage_selected, "'")
				} else
				{
					and3 = ""
				}
				requete@sql = paste(
						"select  DISTINCT ON (bjo_annee) bjo_annee from ",
						get_schema(),
						"t_bilanmigrationjournalier_bjo where bjo_identifiant>0 ",
						# I want and statements to not have to choose the order
						# the where statement is always verified
						and1,
						and2,
						and3,
						sep = ""
				)
			} else if (objectreport == "report_ge_weight") {
				requete@sql = paste(
						"select  DISTINCT ON (year) year from( select date_part('year', ope_date_debut) as year from ",
						get_schema(),
						"t_operation_ope) as tabletemp",
						sep = ""
				)
			} else if (objectreport == "report_annual" |
					objectreport == "report_species") {
				if (exists("ref_dc", envir_stacomi)) {
					dc <- get("ref_dc", envir_stacomi)
					and1 <-
							paste(" AND ope_dic_identifiant in ",
									vector_to_listsql(dc@dc_selected))
				} else {
					and1 <- ""
				}
				if (exists("ref_taxa", envir_stacomi)) {
					taxa <- get("ref_taxa", envir_stacomi)
					if (!length(taxa@taxa_selected)==0){
						and2 <-
								stringr::str_c(" AND lot_tax_code in ",
										vector_to_listsql(taxa@taxa_selected))
					} else {
						and2 <- ""
					}
				} else {
					and2 <- ""
				}
				if (exists("ref_stage", envir_stacomi)) {
					stage <- get("ref_stage", envir_stacomi)
					if (!length(stage@stage_selected)==0){
						and3 <-
								stringr::str_c(" AND lot_std_code in ",
										vector_to_listsql(stage@stage_selected))
					} else
					{
						and3 = ""
					}
				} else
				{
					and3 = ""
				}
				requete@sql = paste(
						"select  DISTINCT ON (year) year from (select date_part('year', ope_date_debut) as year from ",
						get_schema(),
						"t_operation_ope JOIN ",
						get_schema(),
						"t_lot_lot on lot_ope_identifiant=ope_identifiant",
						" WHERE lot_lot_identifiant is null",
						and1,
						and2,
						and3,
						") as tabletemp",
						sep = ""
				)
			} else {
				funout(gettextf("Not implemented for objectreport = %s", objectreport),
						arret = TRUE)
			}
			requete <-
					stacomirtools::query(requete)  
			object@data <- stacomirtools::getquery(requete)
			return(object)
		}
)


#' choice_c method for ref_year referential from the command line
#'
#' The choice_c method will issue a warning if the year is not present in the database
#' Allows the selection of year and the assignment in environment envir_stacomi
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @param object An object of class \link{ref_year-class}
#' @param annee The year to select, either as a character or as a numeric
#' @param nomassign The name to be assigned in envir_stacomi
#' @param funoutlabel The label that appears in funout
#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
#' @return object An object of class \link{ref_year-class} with year selected
#' @examples
#' \dontrun{
#' object=new("ref_year")
#' object<-charge(object)
#' win=gwindow(title="test ref_year")
#' group=ggroup(container=win,horizontal=FALSE)
#' choice(object,nomassign="ref_year",funoutlabel="essai",titleFrame="essai ref_year",preselect=1)
#' dispose(win)
#' }
setMethod(
		"choice_c",
		signature = signature("ref_year"),
		definition = function(object,
				annee,
				nomassign = "ref_year",
				funoutlabel = gettext("Year selected\n", domain = "R-stacomiR"),
				silent = FALSE) {
			if (length(annee) > 1)
				stop("horodate should be a vector of length 1")
			if (inherits (annee, "character"))
				annee <- as.numeric(annee)
			# the charge method must be performed before
			gettext("no year", domain = "R-stacomiR")
			if (!annee %in% object@data[, 1]) {
				warning(
						stringr::str_c(
								"Attention, year ",
								annee,
								" is not available in the database, available years :",
								ifelse(
										length(object@data$bjo_annee) == 0,
										gettext(" none", domain = "R-stacomiR"),
										stringr::str_c(object@data$bjo_annee, collapse = ",")
								)
						)
				)
			}
			object@year_selected <- annee
			
			assign(nomassign, object, envir_stacomi)
			if (!silent)
				funout(funoutlabel)
			return(object)
		}
)

#' Class 'report_sample_char'
#' 
#' The report_sample_char class is used to load and display sample characteristics, which can be either
#' continuous or discrete variable, for instance, it can be used to analyze size or sex structure during
#' a given period. 
#' 
#' @note This class is displayed by interface_report_sample_char, in the database, the class calls the content
#' of the view vue_lot_ope_car
#' @slot data A data frame
#' @slot dc An object of class \link{ref_dc-class}: the control devices
#' @slot taxa An object of class \link{ref_taxa-class}: the species
#' @slot stage An object of class \link{ref_stage-class} : the stages of the fish
#' @slot par An object of class \link{ref_par-class}: the parameters used
#' @slot horodatedebut An object of class \link{ref_horodate-class}
#' @slot horodatefin An object of class \link{ref_horodate-class}
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('report_sample_char', ...)}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @example inst/examples/report_sample_char-example.R
#' @aliases report_sample_char
#' @export
setClass(Class = "report_sample_char", representation = representation(data = "ANY",
    dc = "ref_dc", taxa = "ref_taxa", stage = "ref_stage", par = "ref_par", horodatedebut = "ref_horodate",
    horodatefin = "ref_horodate"), prototype = prototype(data = data.frame(), dc = new("ref_dc"),
    taxa = new("ref_taxa"), stage = new("ref_stage"), par = new("ref_par"), horodatedebut = new("ref_horodate"),
    horodatefin = new("ref_horodate")))

#' connect method for report_sample_char
#' 
#' @param object An object of class \link{report_sample_char-class}
#' @param silent Boolean if TRUE messages are not displayed
#' @return An object of class \link{report_sample_char-class} with slot data \code{@data} filled
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases connect.report_sample_char
setMethod("connect", signature = signature("report_sample_char"), definition = function(object,
    silent = FALSE) {
    requete <- new("RequeteDBwheredate")
    requete@select = paste("SELECT * FROM ", get_schema(),
        "vue_lot_ope_car", sep = "")
    requete@colonnedebut = "ope_date_debut"
    requete@colonnefin = "ope_date_fin"
    requete@datedebut <- object@horodatedebut@horodate
    requete@datefin <- object@horodatefin@horodate
    requete@order_by = "ORDER BY ope_date_debut"
    requete@and = paste(" AND ope_dic_identifiant in ", vector_to_listsql(object@dc@dc_selected),
        " AND lot_tax_code in ", vector_to_listsql(object@taxa@taxa_selected), " AND lot_std_code in ",
        vector_to_listsql(object@stage@stage_selected), " AND car_par_code in ", vector_to_listsql(object@par@par_selected),
        sep = "")
    requete <- stacomirtools::query(requete)
    object@data <- requete@query
    if (!silent)
        funout(gettext("Sample characteristics have been loaded from the database\n",
            domain = "R-stacomiR"))
    return(object)
})


#' charge method for report_sample_char class
#' 
#' this method verifies that boxes have been clicked in the user interface and gets the objects pasted in 
#' envir_stacomi
#' @param object An object of class \link{report_sample_char-class} 
#' @return An object of class \link{report_sample_char-class} with slots filled with user choice
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of the class \link{report_sample_char-class} with slots filled from values assigned in \code{envir_stacomi} environment
#' @aliases charge.report_sample_char
#' @keywords internal
setMethod("charge", signature = signature("report_sample_char"), definition = function(object) {
    if (exists("ref_dc", envir_stacomi)) {
        object@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)) {
        object@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)) {
        object@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("ref_par", envir_stacomi)) {
        object@par <- get("ref_par", envir_stacomi)
    } else {
        funout(gettext("You need to choose a parameter, clic on validate\n", domain = "R-stacomiR"),
            arret = TRUE)
    }
    # rem pas tres satisfaisant car ce nom est choisi dans l'interface
    if (exists("report_sample_char_date_debut", envir_stacomi)) {
        object@horodatedebut@horodate <- get("report_sample_char_date_debut", envir_stacomi)
    } else {
        funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
            arret = TRUE)
    }
    # rem id
    if (exists("report_sample_char_date_fin", envir_stacomi)) {
        object@horodatefin@horodate <- get("report_sample_char_date_fin", envir_stacomi)
    } else {
        funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
            arret = TRUE)
    }
    assign("report_sample_char", object, envir_stacomi)
    return(object)
})


#' command line interface for report_sample_char class
#' 
#' #' The choice_c method fills in the data slot for classes \link{ref_dc-class}, \link{ref_taxa-class}, \link{ref_stage-class}, \link{ref_par-class} and two slots of \link{ref_horodate-class} and then 
#' uses the choice_c methods of these object to select the data.
#' @param object An object of class \link{report_sample_char-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),
#' these 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 par A parameter matching th ref.tg_parametre_par table in the stacomi database, see \link{choice_c,ref_par-method}
#' @param horodatedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param horodatefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_mig-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_sample_char
setMethod("choice_c", signature = signature("report_sample_char"), definition = function(object,
    dc, taxa, stage, par, horodatedebut, horodatefin, silent = FALSE) {
    # code for debug using example
    # report_sample_char<-r_sample_char;dc=c(5,6);taxa='Anguilla anguilla'
    # stage=c('CIV','AGJ');par=c(1785,1786,1787,'C001');horodatedebut='2010-01-01';horodatefin='2015-12-31'
    report_sample_char <- object
    report_sample_char@dc = charge(report_sample_char@dc)
    # loads and verifies the dc this will set dc_selected slot
    report_sample_char@dc <- choice_c(object = report_sample_char@dc, dc)
    # only taxa present in the report_mig are used
    report_sample_char@taxa <- charge_with_filter(object = report_sample_char@taxa,
        report_sample_char@dc@dc_selected)
    report_sample_char@taxa <- choice_c(report_sample_char@taxa, taxa)
    report_sample_char@stage <- charge_with_filter(object = report_sample_char@stage,
        report_sample_char@dc@dc_selected, report_sample_char@taxa@taxa_selected)
    report_sample_char@stage <- choice_c(report_sample_char@stage, stage)
    report_sample_char@par <- charge_with_filter(object = report_sample_char@par,
        report_sample_char@dc@dc_selected, report_sample_char@taxa@taxa_selected,
        report_sample_char@stage@stage_selected)
    report_sample_char@par <- choice_c(report_sample_char@par, par, silent = silent)
    report_sample_char@horodatedebut <- choice_c(object = report_sample_char@horodatedebut,
        nomassign = "report_sample_char_date_debut", funoutlabel = gettext("Beginning date has been chosen\n",
            domain = "R-stacomiR"), horodate = horodatedebut, silent = silent)
    report_sample_char@horodatefin <- choice_c(report_sample_char@horodatefin, nomassign = "report_sample_char_date_fin",
        funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
        horodate = horodatefin, silent = silent)
    return(report_sample_char)
})

#' Calculation for report_sample_char
#' 
#' In that class, most treatments are done in the query, this method checks that data are available and fills information for year, month, two weeks, week, doy 
#' @param object An object of class \code{\link{report_sample_char-class}} 
#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
#' @return An object of class \code{\link{report_sample_char-class}} with slot \code{@data} filled
#' @aliases calcule.report_sample_char
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod("calcule", signature = signature("report_sample_char"), definition = function(object,
    silent = FALSE) {
    # report_sample_char<-r_sample_char
    report_sample_char <- object
    if (nrow(report_sample_char@data) == 0) {
        funout(gettext("No information for these samples during the selected period\n",
            domain = "R-stacomiR"), arret = TRUE)
    }
    vue_ope_lot = report_sample_char@data  # on recupere le data.frame
    nom_variable = report_sample_char@par@data$par_nom[report_sample_char@par@data$par_code %in%
        report_sample_char@par@par_selected]
    # stopifnot(length(nom_variable)==1)
    vue_ope_lot$ope_dic_identifiant = as.factor(vue_ope_lot$ope_dic_identifiant)
    vue_ope_lot$dev_code = as.factor(vue_ope_lot$dev_code)
    vue_ope_lot$car_val_identifiant = as.factor(vue_ope_lot$car_val_identifiant)
    vue_ope_lot$car_par_code = as.factor(vue_ope_lot$car_par_code)
    vue_ope_lot$ope_identifiant = as.factor(vue_ope_lot$ope_identifiant)
    vue_ope_lot$lot_pere = as.factor(vue_ope_lot$lot_pere)
    vue_ope_lot$val_libelle = as.factor(vue_ope_lot$val_libelle)
    vue_ope_lot$lot_tax_code = as.factor(vue_ope_lot$lot_tax_code)
    vue_ope_lot <- fun_date_extraction(data = vue_ope_lot, nom_coldt = "ope_date_debut",
        annee = TRUE, mois = TRUE, quinzaine = TRUE, semaine = TRUE, jour_an = TRUE,
        jour_mois = FALSE, heure = FALSE)
    #   vue_ope_lot=stacomirtools::chnames(vue_ope_lot,
    #     c('ope_identifiant','lot_identifiant','ope_dic_identifiant','lot_pere',
    #       'ope_date_debut','ope_date_fin','lot_effectif','lot_quantite','lot_tax_code','lot_std_code','tax_nom_latin','std_libelle','dev_code','dev_libelle','par_nom','car_par_code','car_methode_obtention','car_val_identifiant',
    # 'car_valeur_quantitatif','val_libelle',
    # 'annee','mois','quinzaine','semaine','jour_365'),
    #     c('ope','lot','dic','lot_pere',
    #       'date','date_fin','effectif','quantite','lot_tax_code','lot_std_code','tax','std','dev_code','dev','par','car_par_code','meth','val','val_quant','val_libelle',
    # 'annee','mois','quinzaine','semaine','jour'))
    # vue_ope_lot=vue_ope_lot[,c('ope','lot','dic','lot_pere','date','effectif','quantite','tax','std','dev','par','meth','val','val_quant','val_libelle',
    # 'annee','mois','quinzaine','semaine','jour')]
    report_sample_char@data <- vue_ope_lot
    assign("report_sample_char", report_sample_char, envir_stacomi)  #assign('report_sample_char',vue_ope_lot,envir_stacomi)
    if (!silent)
        funout(gettext("To obtain the table, type : report_sample_char=get('report_sample_char',envir_stacomi)\n",
            domain = "R-stacomiR"))
    return(report_sample_char)
})


#' Plots of various type for reportcarlot
#' @param x An object of class report_sample_char
#' @param plot.type One of '1','violin plot'. Defaut to \code{1} , can also be \code{2} boxplot or 
#' \code{3} points. 
#' @param silent Stops displaying the messages
#' @return Nothing, called for its side effect, plotting
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_sample_char
#' @export
setMethod("plot", signature(x = "report_sample_char", y = "missing"), definition = function(x,
    plot.type = "1", silent = FALSE) {
    # report_sample_char<-r_sample_char;require(ggplot2);plot.type='1'
    # browser()
    report_sample_char <- x
    plot.type <- as.character(plot.type)  # to pass also characters
    if (!plot.type %in% c("1", "2", "3"))
        stop("plot.type must be 1,2,3")
    if (exists("report_sample_char", envir_stacomi)) {
        report_sample_char <- get("report_sample_char", envir_stacomi)
    } else {
        if (!silent)
            funout(gettext("You need to launch computation first, clic on calc\n",
                domain = "R-stacomiR"), arret = TRUE)
    }
    name_param <- report_sample_char
    if (plot.type == 1) {
        g <- ggplot(report_sample_char@data, aes(x = car_valeur_quantitatif))
        g <- g + stat_density(aes(ymax = ..density.., ymin = -..density..), fill = "grey50",
            colour = "grey10", geom = "ribbon", position = "identity") + facet_grid(. ~
            annee) + coord_flip()
        print(g)
        assign("g", g, envir_stacomi)
        if (!silent)
            funout(gettext("To obtain the graphical object, type :  g<-get(\"g\",envir_stacomi)\n",
                domain = "R-stacomiR"))
    } else if (plot.type == 2) {
        g <- ggplot(report_sample_char@data)
        g <- g + geom_boxplot(aes(x = mois, y = car_valeur_quantitatif, fill = std_libelle)) +
            facet_grid(annee ~ .)
        print(g)
        assign("g", g, envir_stacomi)
        if (!silent)
            funout(gettext("To obtain the graphical object, type :  g<-get(\"g\",envir_stacomi)\n",
                domain = "R-stacomiR"))

    } else if (plot.type == 3) {
        g <- ggplot(report_sample_char@data)
        g <- g + geom_point(aes(x = ope_date_debut, y = car_valeur_quantitatif))
        print(g)
        assign("g", g, envir_stacomi)
        if (!silent)
            funout(gettext("To obtain the graphical object, type :  g<-get(\"g\",envir_stacomi)\n",
                domain = "R-stacomiR"))
    }
    return(invisible(NULL))
})

#' summary for report_sample_char 
#' 
#' @param object An object of class \code{\link{report_sample_char-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters
#' @return Nothing, called for its side effect of printing a summary
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_sample_char
#' @export
setMethod("summary", signature = signature(object = "report_sample_char"), definition = function(object,
    silent = FALSE, ...) {
    Hmisc::describe(object@data)
		return(invisible(NULL))
})

#' Method to print the command line of the object
#' @param x An object of class report_sample_char
#' @param ... Additional parameters passed to print
#' @return NULL
#' @author cedric.briand
#' @aliases print.report_sample_char
#' @export
setMethod("print", signature = signature("report_sample_char"), definition = function(x,
    ...) {
    sortie1 <- "report_sample_char=new('report_sample_char')"
    sortie2 <- stringr::str_c("report_sample_char <- choice_c(report_sample_char,",
        "dc=c(", stringr::str_c(x@dc@dc_selected, collapse = ","), "),", "taxa=c(",
        stringr::str_c(shQuote(x@taxa@data$tax_nom_latin), collapse = ","), "),",
        "stage=c(", stringr::str_c(shQuote(x@stage@stage_selected), collapse = ","),
        "),", "par=c(", stringr::str_c(shQuote(x@par@par_selected), collapse = ","),
        "),", "horodatedebut=", shQuote(strftime(x@horodatedebut@horodate, format = "%d/%m/%Y %H-%M-%S")),
        ",horodatefin=", shQuote(strftime(x@horodatefin@horodate, format = "%d/%m/%Y %H-%M-%S")),
        ")")
    # removing backslashes
    funout(sortie1)
    funout(stringr::str_c(sortie2, ...))
    return(invisible(NULL))
})


#' Counts of number per taxa/stages
#' 
#' This class is used to make the assessment of all species, and their number. It is intended
#' as a simple way to check what fishes are present (taxa + development stage). It was altered to include ref_taxa,
#' to allow excluding some of the most numerous taxa from reports. The taxa is reported unless 
#' a taxa has several stages, in which case the different stages for the taxa will be reported
#' Using the split arguments
#' the calc method of the class will count numbers, subsamples are not accounted for in the Overview.
#' The split argument currently takes values year or month. The class is intended to be used over long periods
#' e.g years. The plot method writes either an histogram or a pie chart of number per
#' year/week/month.
#' @slot dc an object of class \link{ref_dc-class} 
#' @slot taxa Object of class \link{ref_taxa-class}: the species
#' @slot start_year Object of class \code{\link{ref_year-class}}
#' @slot end_year Object of class \code{\link{ref_year-class}}
#' @slot data \code{data.frame}
#' @slot calcdata \code{data.frame} with data processed by the calc method
#' @slot split Object of class \code{\link{ref_list-class}} ref_list referential class choose within a list
#' @include ref_taxa.R
#' @include ref_dc.R
#' @include ref_list.R
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @aliases report_species 
#' @example inst/examples/report_species-example.R
#' @keywords classes
#' @export
setClass(Class = "report_species", representation = representation(dc = "ref_dc", taxa = "ref_taxa",
				start_year = "ref_year", end_year = "ref_year", data = "data.frame", calcdata = "data.frame",
				split = "ref_list"), prototype = prototype(dc = new("ref_dc"), taxa = new("ref_taxa"), start_year = new("ref_year"),
				end_year = new("ref_year"), data = data.frame(), calcdata = data.frame(), split = new("ref_list")))


#' connect method for report_species
#' @param object An object of class report_species
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_species-class} with data slot filled with slot data \code{@data} filled
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases connect.report_species
setMethod("connect", signature = signature("report_species"), definition = function(object,
				silent = FALSE) {
			bilesp <- object
			requete = new("RequeteDB")
			start_year = bilesp@start_year@year_selected
			end_year = bilesp@end_year@year_selected
			requete@sql = paste("SELECT lot_identifiant, ope_date_debut, ope_date_fin,",
					" lot_effectif, lot_tax_code, lot_std_code, tax_nom_latin, std_libelle,",
					" date_part('year', ope_date_debut) as annee,", " date_part('month',ope_date_debut) as mois,",
					" date_part('week',ope_date_debut) as semaine", " FROM ", 
					get_schema(), 
					"t_operation_ope", " INNER JOIN ", 
					get_schema(),
					"t_lot_lot ON ope_identifiant=lot_ope_identifiant", " INNER JOIN ref.tr_taxon_tax on tax_code=lot_tax_code",
					" INNER JOIN ref.tr_stadedeveloppement_std on std_code=lot_std_code", " WHERE extract(year from ope_date_debut)>=",
					start_year, " AND extract(year from ope_date_debut)<=", end_year, " AND ope_dic_identifiant in",
					vector_to_listsql(bilesp@dc@dc_selected), "AND lot_tax_code in", vector_to_listsql(bilesp@taxa@taxa_selected),
					" AND lot_lot_identifiant IS NULL",
					" AND lot_effectif IS NOT NULL", sep = "")
			requete <- stacomirtools::query(requete)
			if (requete@status != "success")
				funout(gettext("Query failed for for report species \n", domain = "R-stacomiR"),
						arret = TRUE)
			bilesp@data <- requete@query
			if (!silent)
				funout(gettext("data loaded from the database for report_species"))
			assign("bilesp", bilesp, envir = envir_stacomi)
			return(bilesp)
		})


#' command line interface for \link{report_species-class}
#' 
#' @param object An object of class \link{report_species-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 'all' (default) or 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 start_year The starting the first year, passed as character or integer
#' @param end_year the finishing year
#' @param split one of c('none','week','month','year')
#' @param silent Boolean, if TRUE, information messages are not displayed
#' @return An object of class \link{report_species-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_species
setMethod("choice_c", signature = signature("report_species"), 
		definition = function(object,
				dc, 
				taxa="all",
				split = "none",
				start_year, 
				end_year, 
				silent = FALSE) {
			# code for debug using example
			# dc=c(5,6);taxa = c(start_year='1996';end_year='2016';split='none';silent=TRUE
			bilesp <- object
			bilesp@dc = charge(bilesp@dc)
			# loads and verifies the dc this will set dc_selected slot
			bilesp@dc <- choice_c(object = bilesp@dc, dc)
			
			bilesp@taxa <-
					charge_with_filter(object = bilesp@taxa, bilesp@dc@dc_selected)
			
			if (any(taxa=="all")) {
				# taxa selected correspond to all loaded taxa for the dc
				bilesp@taxa@taxa_selected <- bilesp@taxa@data$tax_code
				# Here we are not using the standard choice_c which assigns in envir_stacomi...
				assign("ref_taxa", bilesp@taxa, envir=envir_stacomi)
			} else {
				bilesp@taxa <- choice_c(bilesp@taxa, taxa)
			}
			bilesp@split = charge(object = bilesp@split, listechoice = c("none", "week",
							"month", "year"), label = gettext("choice of number in sample (one, several,all)",
							domain = "R-stacomiR"))  # choix de la categorie d'effectif)
			bilesp@split <- choice_c(bilesp@split, selectedvalue = split)
			# by default choice_c returns reflist but usefull to mimic gr.interface
			assign("refliste", bilesp@split, envir_stacomi)
			bilesp@start_year <- charge(object = bilesp@start_year, objectreport = "report_species")
			bilesp@start_year <- choice_c(object = bilesp@start_year, nomassign = "start_year",
					annee = start_year, silent = silent)
			bilesp@end_year@data <- bilesp@start_year@data
			bilesp@end_year <- choice_c(object = bilesp@end_year, nomassign = "end_year",
					annee = end_year, silent = silent)
			assign("bilesp", bilesp, envir = envir_stacomi)
			return(bilesp)
		})


#' charge method for report_species
#' 
#' Verifies the content of objects when the graphical interface is used, it is not necessary
#' to call the charge method if the choice_c method has been used
#' @param object An object of class \link{report_species-class}
#' @param silent Stops displaying the messages. 
#' @return report_species with slots filled by user choice
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of class \link{report_species-class} with slots filled from values assigned in \code{envir_stacomi} environment
#' @aliases charge.report_species
#' @keywords internal
setMethod("charge", signature = signature("report_species"), definition = function(object,
				silent = FALSE) {
			if (!silent)
				funout(gettext("Checking objects and launching query\n", domain = "R-stacomiR"))
			bilesp <- object
			if (exists("ref_dc", envir_stacomi)) {
				bilesp@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)) {
				bilesp@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("start_year", envir_stacomi)) {
				bilesp@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)) {
				bilesp@end_year <- get("end_year", envir_stacomi)
			} else {
				funout(gettext("You need to choose the ending year\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			
			if (exists("refliste", envir_stacomi)) {
				bilesp@split <- get("refliste", envir_stacomi)
			} else {
				funout(gettext("You need to choose a size class\n", domain = "R-stacomiR"),
						arret = TRUE)
			}
			assign("bilesp", bilesp, envir_stacomi)
			if (!silent)
				funout(gettext("A report_species object was stored into envir_stacomi environment : write bilesp=get('bilesp',envir_stacomi)",
								domain = "R-stacomiR"))
			return(bilesp)
		})



#' calcule method for report_species
#' 
#' The number will be split according to the split argument passed to the class, e.g.
#' per year or month or week. Data from different DC will be grouped. Counts are given per taxa,
#' unless there are several stages, in which case the counts correspond to taxa + stage.
#' @param object An object of class \link{report_species-class}
#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
#' @return An object of class \link{report_species-class} with calcdata slot filled.
#' @aliases calcule.report_species
setMethod("calcule", signature = signature("report_species"), definition = function(object,
				silent = FALSE) {
			bilesp <- object
			DC = as.numeric(bilesp@dc@dc_selected)
			# update of refliste which does not need calcul button pushed
			tableEspeces = bilesp@data
			if (nrow(tableEspeces) == 0)
				funout(gettext("No fish in the database for this period\n", domain = "R-stacomiR"),
						arret = TRUE)
			tableEspeces$taxa_stage = paste(tableEspeces$tax_nom_latin, tableEspeces$std_libelle,
					sep = "_")
			# only keeping taxa stage for species with several stages
			nbstage = tapply(tableEspeces$tax_nom_latin, tableEspeces$taxa_stage, function(X) (length(unique(X))))
			# we currently have taxa+stage, below this is replaces with taxa unless
			# there are more than one stage per species
			if (length(nbstage[nbstage > 1]) > 0) {
				les_multiples = names(nbstage[nbstage > 1])
				tableEspeces[!tableEspeces$taxa_stage %in% les_multiples, "taxa_stage"] <- tableEspeces$tax_nom_latin[!tableEspeces$taxa_stage %in%
								les_multiples]
			} else tableEspeces$taxa_stage <- tableEspeces$tax_nom_latin
			if (min(tableEspeces$lot_effectif) < 0) {
				if (!silent)
					funout(gettext("Some negative counts are transformed into positive ones\n",
									domain = "R-stacomiR"))
				tableEspeces$lot_effectif = abs(tableEspeces$lot_effectif)
			}
			sumEspeces = switch(bilesp@split@selectedvalue, year = as.data.frame(xtabs(lot_effectif ~
											taxa_stage + annee, data = tableEspeces)), month = as.data.frame(xtabs(lot_effectif ~
											taxa_stage + mois, data = tableEspeces)), week = as.data.frame(xtabs(lot_effectif ~
											taxa_stage + semaine, data = tableEspeces)), none = as.data.frame(xtabs(lot_effectif ~
											taxa_stage, data = tableEspeces)))
			colnames(sumEspeces)[colnames(sumEspeces) == "Freq"] <- "Effectif"  # pas forcement le m nb de colonnes
			if (bilesp@split@selectedvalue != "none") {
				colnames(sumEspeces)[2] <- bilesp@split@selectedvalue
			}
			bilesp@calcdata <- sumEspeces
			assign("bilesp", bilesp, envir_stacomi)
			return(bilesp)
		})

#' Plot method for report_species
#' 
#' @param x An object of class \link{report_species-class}
#' @param plot.type Default pie
#' #' \itemize{
#'   \item{plot.type='pie': A pie}' 
#'   \item{plot.type='barchart' : A barchart}
#' }
#' @param color Default NULL, a vector of colors of length corresponding to the number of taxa-stage
#' different values, use unique(bilesp@calcdata$taxa_stage) to get that number. The color applies to both
#' pie and barchart plots
#' @param silent Stops displaying the messages
#' @return Nothing, called for producing plots
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.reportreport_species
#' @export
setMethod("plot", signature(x = "report_species", y = "missing"), definition = function(x,
				plot.type = "pie", color = NULL, silent = FALSE) {
			bilesp <- x
			if (nrow(bilesp@calcdata) == 0)
				stop("No data in the calcdata slot, did you forget to run calculations ?")
			nb = length(unique(bilesp@calcdata$taxa_stage))
			g <- ggplot(bilesp@calcdata)
			g <- g + geom_col(aes(x = "", y = Effectif, fill = taxa_stage)) + ggtitle(paste("report Especes, DC",
									str_c(bilesp@dc@dc_selected, collapse = "+"), bilesp@start_year@year_selected,
									"=>", bilesp@end_year@year_selected)) + xlab("") + ylab(gettext("Number",
									domain = "R-stacomiR"))
			# theme(axis.line.x=element_line('none'))+theme(axis.title.x=
			# element_text('none'))
			if (bilesp@split@selectedvalue != "none") {
				facet <- switch(bilesp@split@selectedvalue, year = as.formula(~year), month = as.formula(~month),
						week = as.formula(~week))
				g <- g + facet_wrap(facet, scales = "fixed")
			}
			if (is.null(color)) {
				if (nb <= 8) {
					g <- g + scale_fill_brewer(palette = "Accent", name = gettext("Taxa-stage",
									domain = "R-stacomiR"))
				} else if (nb <= 12) {
					p <- g + scale_fill_brewer(palette = "Set3", name = gettext("Taxa-stage",
									domain = "R-stacomiR"))
				} else {
					g <- g + scale_fill_manual(values = grDevices::rainbow(nb), name = gettext("Taxa-stage",
									domain = "R-stacomiR"))
				}
			} else {
				# color is not null
				if (length(color) != nb)
					stop(gettextf("The vector of color should be of length %s", domain = "R-stacomiR",
									nb))
				g <- g + scale_fill_manual(values = color, gettext("Taxa-stage", domain = "R-stacomiR"))
			}
			if (plot.type == "barplot") {
				print(g)
				assign("g", g, envir = envir_stacomi)
			} else if (plot.type == "pie") {
				g <- g + coord_polar(theta = "y", start = pi) + xlab("") + ylab("")
				print(g)
				assign("g", g, envir = envir_stacomi)
			} else {
				funout(gettext("plot.type should be one of barplot or pie", domain = "R-stacomiR"),
						arret = TRUE)
			}
			if (!silent)
				funout(gettext("the object g has been assigned to envir_stacomi", domain = "R-stacomiR"))
			
			return(invisible(NULL))
		})



#' summary for report_species 
#' 
#'  generate csv and html output in the user data directory
#' @param object An object of class \code{\link{report_species-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @return nothing, but writes summary in \code{get("datawd", envir = envir_stacomi)}, and prints output
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_species
#' @export
setMethod("summary", signature = signature(object = "report_species"), definition = function(object,
				silent = FALSE) {
			bilesp <- object
			if (nrow(bilesp@calcdata) == 0)
				stop("No data in the calcdata slot, did you forget to run calculations ?")
			loc <- str_c(str_c(bilesp@dc@dc_selected, collapse = "+"), bilesp@start_year@year_selected,
					bilesp@end_year@year_selected, sep = "_")
			
			path = file.path(normalizePath(path.expand(get("datawd", envir = envir_stacomi))),
					paste("tableEspece", loc, ".csv", sep = ""), fsep = "\\")
			res <- tryCatch(
					write.table(bilesp@calcdata, path, row.names = TRUE, col.names = TRUE, sep = ";",
							append = FALSE),
					error = function(e) e,
					finally =
							if (!silent) 		{
								funout(gettextf("writing of %s \n", path))
								funout(gettextf("attention, negative numbers were transformed into positive numbers"))
							})
			if (inherits(res, "simpleError")) {
				warnings("The table could not be reported, please change the working directory datawd with options(stacomiR.path='path/to/directory'")
			}
			
		})


#' Class 'ref_parqual'
#' 
#' Class enabling to load the list of qualitative parameters and to select one
#' of them. It inherits from 'ref_par', uses its 'choice' method
#' @author cedric.briand@eptb-vilaine.fr
#' @slot valqual='data.frame' the list of qualitative parameters
#' @include ref_par.R
#' @family referential objects
setClass(Class = "ref_parqual", representation = representation(valqual = "data.frame"),
    contains = "ref_par")

#' Loading method for Reparqual referential objects
#' @param object An object of class \link{ref_parqual-class}
#' @return An S4 object of class ref_parqual
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_parqual')
#'  charge(object)
#' }
setMethod("charge", signature = signature("ref_parqual"), definition = function(object) {
    requete = new("RequeteDB")
    requete@sql = "select par_code, par_nom, par_unite, par_nature, par_definition, qal_valeurs_possibles from ref.tg_parametre_par
     INNER JOIN ref.tr_parametrequalitatif_qal ON tr_parametrequalitatif_qal.qal_par_code::text = tg_parametre_par.par_code::text"
    requete <- stacomirtools::query(requete)
    # funout(gettext('The query to load parameters is done
    # \n',domain='R-stacomiR'))
    object@data <- requete@query
    return(object)
})

#' Loading method for Reparqual referential objects searching only those parameters existing for a DC, a Taxon, and a stage
#' @param object An object of class \link{ref_parqual-class}
#' @param dc_selected The dc set in the report object
#' @param taxa_selected The taxa set in the report object
#' @param stage_selected The stage set in the report object
#' @return An S4 object of class \link{ref_parqual-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  dc_selected=6
#'  taxa_selected=2038
#'  stage_selected='AGJ'
#'  object=new('ref_parqual')
#'  charge_with_filter(object,dc_selected,taxa_selected,stage_selected)
#' }
setMethod("charge_with_filter", signature = signature("ref_parqual"), definition = function(object,
    dc_selected, taxa_selected, stage_selected) {
    requete = new("RequeteDBwhere")
    requete@select = paste("SELECT DISTINCT ON (par_code) par_code, par_nom, par_unite, par_nature, par_definition, qal_valeurs_possibles", " FROM ",
        get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
        " JOIN ", get_schema(), "tj_caracteristiquelot_car on car_lot_identifiant=lot_identifiant",
        " JOIN ref.tg_parametre_par on par_code=car_par_code", " JOIN ref.tr_parametrequalitatif_qal ON tr_parametrequalitatif_qal.qal_par_code::text = tg_parametre_par.par_code::text",
        sep = "")
    requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected))
    requete@and = paste("and lot_tax_code in ", vector_to_listsql(taxa_selected),
        " and lot_std_code in ", vector_to_listsql(stage_selected), sep = "")
    requete@order_by = "ORDER BY par_code"
    requete <- stacomirtools::query(requete)
    object@data <- requete@query
    return(object)
})

#'  Loads an additional dataset
#' this method is loaded to obtain the possible values of a qualitative parameter. Here data only contains one line
#' @param object An object of class \link{ref_parqual-class}
#' @return An S4 object of class \link{ref_parqual-class} with the valqual slot filled
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  dc_selected=6
#'taxa_selected=2038
#'  stage_selected='AGJ'
#'  object=new('ref_parqual')
#'  object<-charge(object)
#'  charge_complement(object)
#' }  
setMethod("charge_complement", signature = signature("ref_parqual"), definition = function(object) {
    requete = new("RequeteDB")
    requete@sql = paste("select * from ref.tr_valeurparametrequalitatif_val", " WHERE val_qal_code in ",
        vector_to_listsql(object@par_selected), " ORDER BY val_rang", sep = "")
    requete <- stacomirtools::query(requete)
    # funout(gettext('The query to load parameters is done
    # \n',domain='R-stacomiR'))
    object@valqual <- requete@query
    return(object)
})



#' function to print and save statistics in .csv and .html formats for report_mig and report_mig_mult class
#' @param tableau A table with the following columns : No.pas,debut_pas,fin_pas,              
#' ope_dic_identifiant,lot_tax_code,lot_std_code,type_de_quantite,MESURE,CALCULE,               
#' EXPERT,PONCTUEL,Effectif_total,taux_d_echappement,coe_valeur_coefficient
#' @note this function is intended to be called from within the summary method 
#' @param time.sequence Passed from report_mig or report_mig_mult
#' @param taxa  Taxa
#' @param stage The Stage
#' @param DC  The counting device
#' @param resum A summary table generated by funstat
#' @param silent If TRUE, all messages turned off (except warnings and errors) 
#' @return No return value, called for side effects
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
funtable = function(tableau, time.sequence, taxa, stage, DC, resum, silent) {
	annee = paste(unique(strftime(as.POSIXlt(time.sequence), "%Y")), collapse = ",")
	tableau$debut_pas <- as.character(tableau$debut_pas)
	path1 = file.path(path.expand(get("datawd", envir = envir_stacomi)), paste(DC,
					"_", taxa, "_", stage, "_", annee, ".csv", sep = ""), fsep = "/")
	path1html = file.path(path.expand(get("datawd", envir = envir_stacomi)), paste(DC,
					"_", taxa, "_", stage, "_", annee, ".html", sep = ""), fsep = "/")
	res <- tryCatch(
			write.table(tableau, file = path1, row.names = FALSE, col.names = TRUE, sep = ";")
			, error = function(e) e,
			finally =
					if (!silent) funout(gettext("Writing of %s \n", path1, domain = "R-stacomiR"))
	
	)
	
	

	res <- tryCatch(
			suppressWarnings(funhtml(data = tableau, caption = paste(DC, "_", taxa, "_",
									stage, "_", annee, ".csv", sep = ""), top = TRUE, outfile = path1html, clipboard = FALSE,
							append = FALSE, digits = 2)),
			error = function(e) e,
			finally =
					if (!silent) funout(gettextf("writing of %s\n", path1html))
	
	)	
	if (!is.null(resum)) {
		path2 = file.path(path.expand(get("datawd", envir = envir_stacomi)), paste("res",
						DC, "_", taxa, "_", stage, "_", annee, ".csv", sep = ""), fsep = "/")
		resum1 <- resum
		resum$id = rownames(resum)
		path2html = file.path(path.expand(get("datawd", envir = envir_stacomi)),
				paste("res", annee, ".html", sep = ""), fsep = "/")
		res <- tryCatch({
					write.table(resum1, path2, row.names = FALSE, col.names = TRUE, sep = ";")
					suppressWarnings(funhtml(data = resum, caption = paste("Sommes mensuelles",
											annee), top = TRUE, outfile = path2html, clipboard = FALSE, append = TRUE,
									digits = 2))
				}, error = function(e) e,
				finally ={
					if (!silent)	funout(gettextf("writing of %s\n", path2))
					if (!silent)	funout(gettextf("writing of %s\n", path2html))
				})
		if (inherits(res, "simpleError")) {
			warnings("The table could not be reported, please change the working directory datawd with options(stacomiR.path='path/to/directory'")
		}
	}
	return(invisible(NULL))
}



#' ref_textbox referencial class 
#' 
#' allows to a put a value within a glabel
#' @author cedric.briand@eptb-vilaine.fr
#' @slot title='character' the title of the box giving the possible choices
#' @slot labels the logical parameters choice
#' @slot checked a vector
setClass(Class = "ref_textbox", representation = representation(title = "character",
    label = "character"))

#' Loading method for ref_textbox referential objects
#' @param object An object of class \link{ref_textbox-class}
#' @param title A title for the frame
#' @param label A label for the TextBox
#' @return An S4 object of class \link{ref_textbox-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_textbox')
#' charge(object,title='un titre',label='20')
#' }
setMethod("charge", signature = signature("ref_textbox"), definition = function(object,
    title, label) {
    object@title = title
    object@label = label
    return(object)
})


#' Choice_c method for ref_textbox referential objects
#'
#' @param object An object of class \link{ref_textbox-class}
#' @param value The value to set
#' @param nomassign  The name with which the object will be assigned in envir_stacomi
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An S4 object of class \link{ref_textbox-class} label selected
setMethod("choice_c", signature = signature("ref_textbox"), definition = function(object,
    value, nomassign = "ref_textbox") {
    object@label <- value
    assign(nomassign, object, envir_stacomi)
    return(object)
})

#' Migration report for one DC, one species and one stage
#'
#' This class performs a migration summary. A migration monitoring operation can correspond to a single
#' horodate (in the case of some video monitoring operation) or comprise a period which does not necessarily
#' span a full day. The daily migration is calculated by splitting the operation between days, and the migration is either
#' grouped or split according to the lenth of the different time spans.
#' @include ref_taxa.R
#' @include ref_stage.R
#' @include ref_timestep_daily.R
#' @include report_df.R
#' @include report_dc.R
#' @include report_ope.R
#' @slot dc Object of class \link{ref_dc-class}: the control device
#' @slot taxa Object of class \link{ref_taxa-class}: the species
#' @slot stage Object of class \link{ref_stage-class} : the stage of the fish
#' @slot timestep Object of class \link{ref_timestep_daily-class} : the time step
#' constrained to daily value and 365 days
#' @slot data Object of class \code{data.frame} with data filled in from the connect method
#' @slot calcdata A "list" of calculated daily data, one per dc, filled in by the calcule method
#' @slot coef_conversion A data.frame of daily weight to number conversion coefficients, filled in by the connect
#' method if any weight are found in the data slot.
#' @slot time.sequence Object of class \code{POSIXct} : a time sequence of days generated by the calcule method
#' @note In practise, the report_mig class uses methods (calcule, connect...) from the more elaborate \link{report_mig_mult-class}
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @family report Objects
#' @keywords classes
#' @aliases report_mig
#' @example inst/examples/report_mig-example.R
#' @export
setClass(
		Class = "report_mig",
		representation =
				representation(
						dc = "ref_dc",
						taxa = "ref_taxa",
						stage = "ref_stage",
						timestep = "ref_timestep_daily",
						data = "data.frame",
						calcdata = "list",
						coef_conversion = "data.frame",
						time.sequence = "POSIXct"
				),
		prototype = prototype(
				dc = new("ref_dc"),
				taxa = new("ref_taxa"),
				stage = new("ref_stage"),
				timestep = new("ref_timestep_daily"),
				data = data.frame(),
				calcdata = list(),
				coef_conversion = data.frame(),
				time.sequence = as.POSIXct(Sys.time())
		)
)
# report_mig= new("report_mig")

setValidity("report_mig", function(object)
		{
			rep1 = length(object@dc) == 1
			rep2 = length(object@taxa) == 1
			rep3 = length(object@stage) == 1
			rep3 = length(object@timestep) == 1
			rep4 = (object@timestep@nb_step == 365 |
						object@timestep@nb_step == 366) # constraint 365 to 366 days
			rep5 = as.numeric(strftime(object@timestep@dateDebut, '%d')) == 1 # contrainte : depart = 1er janvier
			rep6 = as.numeric(strftime(object@timestep@dateDebut, '%m')) == 1
			return(ifelse(rep1 &
									rep2 &
									rep3 &
									rep4 &
									rep5 &
									rep6 , TRUE , c(1:6)[!c(rep1, rep2, rep3, rep4, rep5, rep6)]))
		})

#deprecated0.6
##' handler for calculations report_mig
##'
##'  internal use
##' @param h handler
##' @param ... additional parameters
##' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
##' @keywords internal
#h_report_migcalc=function(h,...){
#  if (exists("report_mig",envir_stacomi)) {
#	report_mig<-get("report_mig",envir_stacomi)
#  } else {
#	funout(gettext("You need to launch computation first, clic on calc\n",domain="R-stacomiR"),arret=TRUE)
#  }
#  report_mig<-charge(report_mig)
#  report_mig<-connect(report_mig)
#  report_mig<-calcule(report_mig)
#}

#' connect method for report_mig
#'
#'
#' uses the report_mig_mult method
#' @param object An object of class \link{report_mig-class}
#' @param silent Boolean default FALSE, if TRUE information messages not displayed
#' @return report_mig with slot \code{@data} filled from the database
#' @aliases connect.report_mig
setMethod(
		"connect",
		signature = signature("report_mig"),
		definition = function(object, silent = FALSE) {
			report_mig <- object
			report_mig_mult <- as(report_mig, "report_mig_mult")
			report_mig_mult <- connect(report_mig_mult, silent = silent)
			report_mig@data <- report_mig_mult@data
			report_mig@coef_conversion <- report_mig_mult@coef_conversion
			return(report_mig)
		}
)
#' command line interface for report_mig class
#' 
#' The choice_c method fills in the data slot for ref_dc, ref_taxa, ref_stage, and refref_timestep_daily and then
#' uses the choice_c methods of these object to select the data.
#' @param object An object of class \link{report_mig-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),
#' these 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 datedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
#' @param datefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
#' @return An object of class \link{report_mig-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases choice_c.report_mig
setMethod(
		"choice_c",
		signature = signature("report_mig"),
		definition = function(object, dc, taxa, stage, datedebut, datefin) {
			# code for debug using r_mig example
			#report_mig<-r_mig;dc=5;taxa="Liza ramada";stage="IND";datedebut="2015-01-01";datefin="2015-12-31"
			report_mig <- object
			report_mig@dc = charge(report_mig@dc)
			# loads and verifies the dc
			# this will set dc_selected slot
			report_mig@dc <- choice_c(object = report_mig@dc, dc)
			# only taxa present in the report_mig are used
			report_mig@taxa <-
					charge_with_filter(object = report_mig@taxa, report_mig@dc@dc_selected)
			report_mig@taxa <- choice_c(report_mig@taxa, taxa)
			report_mig@stage <-
					charge_with_filter(object = report_mig@stage,
							report_mig@dc@dc_selected,
							report_mig@taxa@taxa_selected)
			report_mig@stage <- choice_c(report_mig@stage, stage)
			report_mig@timestep <-
					choice_c(report_mig@timestep, datedebut, datefin)
			return(report_mig)
		}
)

#' Loads additional data on migration control operations, df (fishway) dc (counting device).
#'
#' this method creates additional classes in envir_stacomi for later use in plot (operations,
#' DF operation, DC operation). So unlike in most report classes where the charge method is only
#' used by the graphical interface, it is necessary to run charge for report_mig.
#' @param object An object of class \code{\link{report_mig-class}}
#' @param silent Should the program be returning messages
#' @return An object of class \link{report_mig-class} with slots filled from values assigned in \code{envir_stacomi} environment
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases charge.report_mig
setMethod(
		"charge",
		signature = signature("report_mig"),
		definition = function(object, silent = FALSE) {
			report_mig <- object
			#report_mig<-r_mig
			#pour l'instant ne lancer que si les fenetre sont fermees
			# funout(gettext("launching updateplot \n",domain="R-stacomiR"))
			if (exists("ref_dc", envir_stacomi)) {
				report_mig@dc <- get("ref_dc", envir_stacomi)
				dc <- report_mig@dc@dc_selected
				df <- report_mig@dc@data$df[report_mig@dc@data$dc %in% dc]
			} 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@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@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("timestep", envir_stacomi)) {
				report_mig@timestep <- get("timestep", envir_stacomi)
			} else {
				funout(
						gettext(
								"Attention, no time step selected, compunting with default value\n",
								domain = "R-stacomiR"
						),
						arret = FALSE
				)
				warning(
						gettext(
								"Attention, no time step selected, compunting with default value\n",
								domain = "R-stacomiR"
						)
				)
			}
			
			#################################
			# loading data for other classes associated with report_mig_mult
			#################################
			report_df = new("report_df")
			report_dc = new("report_dc")
			report_ope = new("report_ope")
			assign(
					"report_dc_date_debut",
					get("timestep", envir_stacomi)@"dateDebut",
					envir_stacomi
			)
			assign("report_dc_date_fin", as.POSIXlt(end_date(get(
											"timestep", envir_stacomi
									))), envir_stacomi)
			assign(
					"report_df_date_debut",
					get("timestep", envir_stacomi)@"dateDebut",
					envir_stacomi
			)
			assign("report_df_date_fin", as.POSIXlt(end_date(get(
											"timestep", envir_stacomi
									))), envir_stacomi)
			assign(
					"report_ope_date_debut",
					get("timestep", envir_stacomi)@"dateDebut",
					envir_stacomi
			)
			assign("report_ope_date_fin",
					as.POSIXlt(end_date(get(
											"timestep", envir_stacomi
									))),
					envir_stacomi)
			
			report_ope <- charge(report_ope)
			# charge will search for ref_dc (possible multiple choice), report_ope_date_debut
			# and report_ope_date_fin in envir_stacomi
			# charge will search for ref_dc (possible multiple choice), report_dc_date_debut
			# and report_dc_date_fin in envir_stacomi
			report_dc <- charge(report_dc)
			ref_df = new("ref_df")
			ref_df <- charge(ref_df)
			ref_df <- choice_c(ref_df, df)
			
			assign("ref_df", ref_df, envir = envir_stacomi)
			
			# charge will search for ref_df (possible multiple choice), report_df_date_debut
			# and report_df_date_fin in envir_stacomi
			report_df <- charge(report_df)
			# the object are assigned to the envir_stacomi for later use by the connect method
			assign("report_df", report_df, envir = envir_stacomi)
			assign("report_dc", report_dc, envir = envir_stacomi)
			assign("report_ope", report_ope, envir = envir_stacomi)
			return(report_mig)
		}
)


#' Transforms migration per period to daily migrations, and performs the conversion from weights to number is data
#' are stored as weights (glass eel).
#'
#'  The calculation must be launched once data are filled by the connect method. Currently the negative argument
#' has no effect.
#' @param object An object of class \code{\link{report_mig-class}}
#' @param negative a boolean indicating if a separate sum must be done for positive and negative values, if true, positive and negative counts return
#' different rows
#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
#' @note The class report_mig does not handle escapement rates nor
#' 'devenir' i.e. the destination of the fishes.
#' @return report_mig with calcdata slot filled. It is a list with one element per counting device containing
#' \describe{
#' \item{method}{In the case of instantaneous periods (video counting) the sum of daily values is done by the \link{fun_report_mig_mult} method and the value indicated in method is "sum".
#'  If any migration monitoring period is longer than a day, then the migration is split using the \link{fun_report_mig_mult_overlaps} function and the value indicated in the
#' method is "overlaps" as the latter method uses the overlap package to split migration period.}
#' \item{data}{the calculated data.}
#' \item{contient_poids}{A boolean which indicates, in the case of glass eel, that the function \link{fun_weight_conversion} has been run to convert the weights to numbers using the weight
#' to number coefficients in the database (see link{report_ge_weight}).}
#' \item{negative}{A parameter indicating if negative migration (downstream in the case of upstream migration devices) have been converted to positive numbers,
#' not developed yet}}
#' @aliases calcule.report_mig
setMethod(
		"calcule",
		signature = signature("report_mig"),
		definition = function(object,
				negative = FALSE,
				silent = FALSE) {
			#report_mig<-r_mig
			#report_mig<-bM_Arzal_civ
			#negative=FALSE;silent=FALSE
			if (!silent) {
				funout(gettext("Starting migration summary ... be patient\n", domain = "R-stacomiR"))
			}
			report_mig <- object
			
			if (nrow(report_mig@data) > 0) {
				#				report_mig@data$time.sequence=difftime(report_mig@data$ope_date_fin,
				#						report_mig@data$ope_date_debut,
				#						units="days")
				debut = report_mig@timestep@dateDebut
				fin = end_date(report_mig@timestep)
				time.sequence <- seq.POSIXt(
						from = debut,
						to = fin,
						by = as.numeric(report_mig@timestep@step_duration)
				)
				report_mig@time.sequence <- time.sequence
				lestableaux <- list()
				datasub <- report_mig@data
				dic <- unique(report_mig@data$ope_dic_identifiant)
				stopifnot(length(dic) == 1)
				datasub$duree = difftime(datasub$ope_date_fin, datasub$ope_date_debut, units =
								"days")
				if (any(datasub$duree > (report_mig@timestep@step_duration / 86400))) {
					#----------------------
					# reports with overlaps
					#----------------------
					data <-
							fun_report_mig_mult_overlaps(
									time.sequence = time.sequence,
									datasub = datasub,
									negative = negative
							)
					# to remain compatible with report_mig
					data$taux_d_echappement = -1
					lestableaux[[stringr::str_c("dc_", dic)]][["data"]] <- data
					lestableaux[[stringr::str_c("dc_", dic)]][["method"]] <-
							"overlaps"
					contient_poids <- "poids" %in% datasub$type_de_quantite
					lestableaux[[stringr::str_c("dc_", dic)]][["contient_poids"]] <-
							contient_poids
					lestableaux[[stringr::str_c("dc_", dic)]][["negative"]] <-
							negative
					if (contient_poids) {
						coe <-
								report_mig@coef_conversion[, c("coe_date_debut", "coe_valeur_coefficient")]
						data$coe_date_debut <- as.Date(data$debut_pas)
						data <- merge(data, coe, by = "coe_date_debut")
						data <- data[, -1] # removing coe_date_debut
						data <-
								fun_weight_conversion(tableau = data,
										time.sequence = report_mig@time.sequence,
										silent)
					}
					
					lestableaux[[stringr::str_c("dc_", dic)]][["data"]] <- data
					
				} else {
					#----------------------
					#report simple
					#----------------------
					data <-
							fun_report_mig_mult(
									time.sequence = time.sequence,
									datasub = datasub,
									negative = negative
							)
					data$taux_d_echappement = -1
					contient_poids <- "poids" %in% datasub$type_de_quantite
					if (contient_poids) {
						coe <-
								report_mig@coef_conversion[, c("coe_date_debut", "coe_valeur_coefficient")]
						data$coe_date_debut <- as.Date(data$debut_pas)
						data <- merge(data, coe, by = "coe_date_debut")
						data <- data[, -1] # removing coe_date_debut
						data <-
								fun_weight_conversion(tableau = data,
										time.sequence = report_mig@time.sequence,
										silent)
					} else {
						data$coe_valeur_coefficient = NA
					}
					lestableaux[[stringr::str_c("dc_", dic)]][["data"]] <- data
					lestableaux[[stringr::str_c("dc_", dic)]][["method"]] <- "sum"
					lestableaux[[stringr::str_c("dc_", dic)]][["contient_poids"]] <-
							contient_poids
					lestableaux[[stringr::str_c("dc_", dic)]][["negative"]] <-
							negative
				}
				# TODO developper une methode pour sumneg
				report_mig@calcdata <- lestableaux
				assign("report_mig", report_mig, envir_stacomi)
				if (!silent) {
					funout(
							gettext(
									"Summary object is stocked into envir_stacomi environment : write report_mig=get('report_mig',envir_stacomi) \n",
									domain = "R-stacomiR"
							)
					)
					funout(
							gettext(
									"To access calculated data, type report_mig@calcdata\n",
									domain = "R-stacomiR"
							)
					)
				}
				
				
				
			} else {
				# no fish...
				funout(
						gettext(
								"There are no values for the taxa, stage and selected period\n",
								domain = "R-stacomiR"
						)
				)
			}
			return(report_mig)
		}
)


#deprecated0.6
##' handler to print the command line
##' @param h a handler
##' @param ... Additional parameters
##' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
##' @keywords internal
#houtreport_mig=function(h=null,...) {
#  if (exists("ref_stage",envir_stacomi)) 	{
#	report_mig<-get("report_mig",envir_stacomi)
#	print(report_mig)
#  }
#  else
#  {
#	funout(gettext("Please select DC, taxa, and stages for a complete command\n",domain="R-stacomiR"),arret=TRUE)
#  }
#}

#' Method to print the command line of the object
#' @param x An object of class report_mig
#' @param ... Additional parameters passed to print
#' @return NULL
#' @author cedric.briand
#' @aliases print.report_mig
#' @export
setMethod(
		"print",
		signature = signature("report_mig"),
		definition = function(x, ...) {
			sortie1 <- "report_mig=new('report_mig');"
			sortie2 <- stringr::str_c(
					"report_mig=choice_c(report_mig,",
					"dc=c(",
					stringr::str_c(x@dc@dc_selected, collapse = ","),
					"),",
					"taxa=c(",
					stringr::str_c(shQuote(x@taxa@data$tax_nom_latin), collapse = ","),
					"),",
					"stage=c(",
					stringr::str_c(shQuote(x@stage@stage_selected), collapse = ","),
					"),",
					"datedebut=",
					shQuote(strftime(x@timestep@dateDebut, format = "%d/%m/%Y")),
					",datefin=",
					shQuote(strftime(end_date(x@timestep), format = "%d/%m/%Y")),
					")"
			)
			# removing backslashes
			funout(stringr::str_c(sortie1, sortie2), ...)
			return(invisible(NULL))
		}
)




#' Plots of various type for report_mig.
#'
#' \itemize{
#' 		\item{plot.type="standard"}{calls \code{\link{fungraph}} and \code{\link{fungraph_glasseel}} functions to plot as many "report_mig"
#' 			as needed, the function will test for the existence of data for one dc, one taxa, and one stage}
#' 		\item{plot.type="step"}{creates Cumulated graphs for report_mig_mult.  Data are summed per day for different dc taxa and stages}
#' 		\item{plot.type="multiple"}{Method to overlay graphs for report_mig_mult (multiple dc/taxa/stage in the same plot)}
#' }
#' @param x An object of class report_mig
#' @param y From the formals but missing
#' @param plot.type One of "standard","step". Defaut to \code{standard} the standard report_mig with dc and operation displayed, can also be \code{step} or
#' \code{multiple}
#' @param silent Stops displaying the messages.
#' @param color Default NULL, argument passed for the plot.type="standard" method. A vector of color in the following order : (1) working, (2) stopped, (3:7) 1...5 types of operation,
#' (8:11) numbers, weight, NULL, NULL (if glass eel), (8:11)  measured, calculated, expert, direct observation for other taxa. If null will be set to brewer.pal(12,"Paired")[c(8,10,4,6,1,2,3,5,7)]
#' @param color_ope Default NULL, argument passed for the plot.type="standard" method. A vector of color for the operations. Default to brewer.pal(4,"Paired")
#' @param ... Additional arguments passed to matplot or plot if plot.type="standard", see ... in \link{fungraph_glasseel} and \link{fungraph}
#' @return Nothing, called for its side effect
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_mig
#' @export
setMethod(
		"plot",
		signature(x = "report_mig", y = "ANY"),
		definition = function(x,
				y,
				plot.type = "standard",
				color = NULL,
				color_ope = NULL,
				silent = FALSE,
				...) {
			#report_mig<-r_mig
			report_mig <- x
			################################################################
			#                 standard plot
			################################################################
			if (plot.type == "standard") {
				if (!silent)
					print("plot type standard")
				if (!silent)
					funout(gettext("Statistics about migration :\n", domain = "R-stacomiR"))
				taxa = report_mig@taxa@data[1, "tax_nom_latin"]
				stage = report_mig@stage@data[1, "std_libelle"]
				dc = as.numeric(report_mig@dc@dc_selected)[1]
				data <- report_mig@calcdata[[stringr::str_c("dc_", dc)]][["data"]]
				if (!is.null(data)) {
					if (nrow(data) > 0) {
						if (!silent) {
							funout(paste(
											"dc=",
											dc,
											"taxa" = taxa,
											"stage" = stage,
											"\n"
									))
							funout("---------------------\n")
						}
						if (any(duplicated(data$No.pas)))
							stop("duplicated values in No.pas")
						data_without_hole <- merge(
								data.frame(
										No.pas = as.numeric(strftime(
														report_mig@time.sequence, format = "%j"
												)) - 1,
										debut_pas = report_mig@time.sequence
								),
								data,
								by = c("No.pas", "debut_pas"),
								all.x = TRUE
						)
						data_without_hole$CALCULE[is.na(data_without_hole$CALCULE)] <- 0
						data_without_hole$MESURE[is.na(data_without_hole$MESURE)] <- 0
						data_without_hole$EXPERT[is.na(data_without_hole$EXPERT)] <- 0
						data_without_hole$PONCTUEL[is.na(data_without_hole$PONCTUEL)] <- 0
						if (report_mig@calcdata[[stringr::str_c("dc_", dc)]][["contient_poids"]] &
								taxa == "Anguilla anguilla" &
								(stage == "civelle" | stage == "Anguille jaune")) {
							#----------------------------------
							# report migration with weights (glass eel)
							#-----------------------------------------
							
							fungraph_glasseel(
									report_mig = report_mig,
									table = data_without_hole,
									time.sequence = report_mig@time.sequence,
									taxa = taxa,
									stage = stage,
									dc = dc,
									silent,
									color = color,
									color_ope = color_ope,
									...
							)
						}	else {
							#----------------------------------
							# report migration standard
							#-----------------------------------------
							#silent=TRUE
							fungraph(
									report_mig = report_mig,
									tableau = data_without_hole,
									time.sequence = report_mig@time.sequence,
									taxa,
									stage,
									dc,
									color = color,
									color_ope = color_ope,
									silent,
									...
							)
						}
					} # end nrow(data)>0
				} # end is.null(data)
				
				################################################################
				#                 step plot
				################################################################
				# FIXME problem with negative numbers
			} else if (plot.type == "step") {
				taxa  <-  as.character(report_mig@taxa@data$tax_nom_latin)
				stage  <-  as.character(report_mig@stage@data$std_libelle)
				dc  <-  as.numeric(report_mig@dc@dc_selected)
				if (report_mig@timestep@step_duration == 86400 &
						report_mig@timestep@step_duration == 86400) {
					grdata <- report_mig@calcdata[[stringr::str_c("dc_", dc)]][["data"]]
					grdata <- fun_date_extraction(
							grdata,
							nom_coldt = "debut_pas",
							annee = FALSE,
							mois = TRUE,
							quinzaine = TRUE,
							semaine = TRUE,
							jour_an = TRUE,
							jour_mois = FALSE,
							heure = FALSE
					)
					grdata$Cumsum <- cumsum(grdata$Effectif_total)
					# pour sauvegarder sous excel
					annee <-
							unique(strftime(as.POSIXlt(report_mig@time.sequence), "%Y"))[1]
					dis_commentaire <-
							as.character(report_mig@dc@data$dis_commentaires[report_mig@dc@data$dc %in%
													report_mig@dc@dc_selected])
					update_geom_defaults("line", aes(size = 2))
					
					p <- ggplot(grdata) +
							geom_line(aes(
											x = debut_pas,
											y = Cumsum,
											colour = mois
									)) +
							ylab(gettext("Cumulative migration", domain = "R-stacomiR")) +
							ggtitle(gettextf(
											"Cumulative count %s, %s, %s, %s",
											dis_commentaire,
											taxa,
											stage,
											annee
									)) +
							theme(plot.title = element_text(size = 10, colour = "navy")) +
							scale_colour_manual(
									values = c(
											"01" = "#092360",
											"02" = "#1369A2",
											"03" = "#0099A9",
											"04" = "#009780",
											"05" = "#67B784",
											"06" = "#CBDF7C",
											"07" = "#FFE200",
											"08" = "#DB9815",
											"09" = "#E57B25",
											"10" = "#F0522D",
											"11" = "#912E0F",
											"12" = "#33004B"
									)
							)
					print(p)
				} else {
					funout(
							gettext(
									"Warning, this function applies for annual summaries\n",
									domain = "R-stacomiR"
							)
					)
				}
			} else {
				stop("unrecognised plot.type argument, plot.type should either be standard or step")
			}
			return(invisible(NULL))
		}


)


#' summary for report_mig
#' calls functions funstat and funtable to create migration overviews
#' and generate csv and html output in the user data directory
#' @param object An object of class \code{\link{report_mig-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters (not used there)
#' @return Nothing, calls the \link{summary.report_mig_mult} method
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_mig
#' @export
setMethod(
		"summary",
		signature = signature(object = "report_mig"),
		definition = function(object, silent = FALSE, ...) {
			report_mig_mult <- as(object, "report_mig_mult")
			summary(report_mig_mult, silent = silent)
			return(invisible(NULL))
		}

)





#' Command line method to write the daily and monthly counts to the t_bilanmigrationjournalier_bjo table
#'
#' Daily values are needed to compare migrations from year to year, by the class \link{report_mig_interannual-class}. They are added by
#' by this function.
#' @param object an object of class \linkS4class{report_mig}
#' @param silent : TRUE to avoid messages
#' @param check_for_bjo : do you want to check if data are already present in the bjo table, and delete them,
#' this param was added otherwise connect method when called from report_mig_interannual runs in loops
#' @note the user is asked whether or not he wants to overwrite data only when silent is FALSE, if no
#' data are present in the database, the import is done anyway. 
#' @return Nothing, just writes data into the database
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples
#' \dontrun{
#' stacomi(database_expected=FALSE)
#' data("r_mig")
#' r_mig<-calcule(r_mig)
#' write_database(report_mig=r_mig,silent=FALSE)
#' }
#' @aliases write_database.report_mig
#' @export
setMethod(
		"write_database",
		signature = signature("report_mig"),
		definition = function(object,
				silent = TRUE,
				check_for_bjo = TRUE) {
			# object=bM			
			report_mig <- object
			if (!inherits(report_mig, "report_mig"))
				stop("the report_mig should be of class report_mig")
			if (!inherits(silent, "logical"))
				stop("the silent argument should be a logical")
			dc = as.numeric(report_mig@dc@dc_selected)[1]
			data = report_mig@calcdata[[stringr::str_c("dc_", dc)]][["data"]]
			# keep one line if there is one species in one day with as much up as down...
			if (nrow(data) > 1)
				data = data[data$Effectif_total != 0, ]
			jour_dans_lannee_non_nuls = data$debut_pas
			col_a_retirer = match(c("No.pas", "type_de_quantite", "debut_pas", "fin_pas"),
					colnames(data))
			col_a_retirer = col_a_retirer[!is.na(col_a_retirer)] # as in the case of glass eel and weight
			# the columns are not the same
			data = data[, -col_a_retirer]
			
			# below again the taux_d_echappement not there if glass eel and weights
			if (is.null(data$taux_d_echappement))
				data$taux_d_echappement <- NA
			data$taux_d_echappement[data$taux_d_echappement == -1] <- NA
			if (!is.null(data$coe_valeur_coefficient)) {
				data$coe_valeur_coefficient[data$"coe_valeur_coefficient" == 1] <- NA
			} else {
				data$coe_valeur_coefficient <- NA
			}
			cannotbenull = match(c("taux_d_echappement", "coe_valeur_coefficient"),
					colnames(data))
			
			if (nrow(data) > 1)
				data[, -cannotbenull][data[, -cannotbenull] == 0] <- NA
			annee <-
					as.numeric(unique(strftime(
											as.POSIXlt(report_mig@time.sequence), "%Y"
									))[1])
			
			if ("Poids_total" %in% colnames(data)) {
				aat_reportmigrationjournalier_bjo = cbind(
						report_mig@dc@dc_selected,
						report_mig@taxa@taxa_selected,
						report_mig@stage@stage_selected,
						annee,
						# une valeur
						rep(jour_dans_lannee_non_nuls, ncol(data[, c(
														"MESURE",
														"CALCULE",
														"EXPERT",
														"PONCTUEL",
														"Effectif_total",
														"Effectif_total.p",
														"Effectif_total.e",
														"poids_depuis_effectifs",
														"Poids_total",
														"taux_d_echappement",
														"coe_valeur_coefficient"
												)])),
						utils::stack(data[, c(
												"MESURE",
												"CALCULE",
												"EXPERT",
												"PONCTUEL",
												"Effectif_total",
												"Effectif_total.p",
												"Effectif_total.e",
												"poids_depuis_effectifs",
												"Poids_total",
												"taux_d_echappement",
												"coe_valeur_coefficient"
										)]),
						Sys.time(),
						get_org())
			} else {
				aat_reportmigrationjournalier_bjo = cbind(
						report_mig@dc@dc_selected,
						report_mig@taxa@taxa_selected,
						report_mig@stage@stage_selected,
						annee,
						# une valeur
						rep(jour_dans_lannee_non_nuls, ncol(data[, c(
														"MESURE",
														"CALCULE",
														"EXPERT",
														"PONCTUEL",
														"Effectif_total",
														"taux_d_echappement",
														"coe_valeur_coefficient"
												)])),
						utils::stack(data[, c(
												"MESURE",
												"CALCULE",
												"EXPERT",
												"PONCTUEL",
												"Effectif_total",
												"taux_d_echappement",
												"coe_valeur_coefficient"
										)]),
						Sys.time(),
						get_org()
				)
			}
			aat_reportmigrationjournalier_bjo = stacomirtools::killfactor(aat_reportmigrationjournalier_bjo[!is.na(aat_reportmigrationjournalier_bjo$values), ])
			colnames(aat_reportmigrationjournalier_bjo) <-
					c(
							"bjo_dis_identifiant",
							"bjo_tax_code",
							"bjo_std_code",
							"bjo_annee",
							"bjo_jour",
							"bjo_valeur",
							"bjo_labelquantite",
							"bjo_horodateexport",
							"bjo_org_code"
					)
			
			
			#####
			# Ci dessous conversion de la classe vers migration Interannuelle pour utiliser
			# les methodes de cette classe
			bil = as(report_mig, "report_mig_interannual")
			# the argument check_for_bjo ensures that we don't re-run the connect method
			# in loop when the write_database is called from within the report_mig_interannual connect method
			# check = FALSE tells the method not to check for missing data (we don't want that check when the
			# write database is called from the report_mig class
			# so far bil@data has no data
			
			if (check_for_bjo)			bil = connect(bil, silent = silent, check = FALSE)	# now should have data in the data slot		
			
			confirm = function() {
				supprime(bil)
				con <- new("ConnectionDB")
				con <- connect(con)
				on.exit(pool::poolClose(con@connection))
				pool::dbWriteTable(con@connection, 
						name = "aat_reportmigrationjournalier_bjo", 
						value=aat_reportmigrationjournalier_bjo, 
						temporary=TRUE)	
				sql <-
						stringr::str_c(
								"INSERT INTO ",
								get_schema(),
								"t_bilanmigrationjournalier_bjo (",
								"bjo_dis_identifiant,bjo_tax_code,bjo_std_code,bjo_annee,bjo_jour,bjo_valeur,bjo_labelquantite,bjo_horodateexport,bjo_org_code)",
								" SELECT * FROM  aat_reportmigrationjournalier_bjo;"
						)
				# con already created above
				
				#CHECKME : i removed the capture output is it OK
				# utils::capture.output(pool::dbExecute(con@connection, statement = sql))		
				pool::dbExecute(con@connection, statement = sql)	
				
				if (!silent) {
					funout(gettextf("Writing daily summary in the database %s \n", annee))
				}
				
				# ecriture egalement du report mensuel
				taxa <- report_mig@taxa@data[report_mig@taxa@data$tax_code %in% report_mig@taxa@taxa_selected,"tax_nom_latin"]
				stage <- report_mig@stage@data[report_mig@stage@data$std_code %in% report_mig@stage@stage_selected,"std_libelle"]
				DC <- as.numeric(report_mig@dc@dc_selected)
				tableau <- report_mig@calcdata[[stringr::str_c("dc_", DC)]][["data"]]
				resum = funstat(
						tableau = tableau,
						time.sequence = tableau$debut_pas,
						taxa,
						stage,
						DC,
						silent = silent
				)
				fun_write_monthly(report_mig, resum, silent = silent)
			}#end function hconfirm
			
			# below we write if !silent and "yes", if silent and if no data in the db
			# we don't write write !only don't write if not silent and "no" 
			# 
			
			if (nrow(bil@data) > 0) # this means also check_for_bjo
			{
				if (!silent) {
					choice <- menu(
							c("yes", "no"),
							graphics = TRUE,
							title = gettextf(
									"Summary exists :%s Overwrite ?",
									unique(bil@data$bjo_horodateexport)
							)
					)
					if (choice=="yes"){
						confirm()
					}
				} else { # silent write anyways
					confirm()
				}				
			} else { # no data in bjo so we write anyways
				confirm()
			}	
			return(invisible(NULL))
			
		}
)

#' Class 'ref_list'
#' 
#' Enables to load a 'ref_list' object from a list given by a 'report' object
#' @param liste choice='character' A vector of character to choose within a droplist
#' @param label='character' the title of the box
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_list', listechoice, label)}.  \describe{
#' \item{list('listechoice')}{Object of class \code{'character'}}\item{:}{Object
#' of class \code{'character'}} \item{list('label')}{Object of class
#' \code{'character'}}\item{:}{Object of class \code{'character'}} }
#' @author cedric.briand@eptb-vilaine.fr
#' @keywords internal
#' @family referential objects
setClass(Class = "ref_list", representation = representation(listechoice = "character",
    selectedvalue = "character", label = "character"))


#' Loading method for ref_list referential objects
#' @aliases charge.ref_list
#' @return An S4 object of class \link{ref_list-class} 
#' @param object An object of class \link{ref_list-class}
#' @param listechoice A character vector setting the possible values in which the user can select
#' @param label A label for refliste
#' @return An S4 object of class \link{ref_list-class} 
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_list')
#' charge(object)
#' }
setMethod("charge", signature = signature("ref_list"), definition = function(object,
    listechoice, label) {
    object@listechoice = listechoice
    object@label = label
    return(object)
})


#' Choice_c method for ref_list referential objects
#' @aliases choice_c.ref_list
#' @param object An object of class \link{ref_list-class}
#' @param selectedvalue the value selected in the combo
#' @return An S4 object of class \link{ref_list-class} 
#' @note the choice method assigns an object of class refList named ref_list in the environment envir_stacomi
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples  
#' \dontrun{
#' object=new('ref_list')
#' object<-charge(object,vecteur=c('1','2'),label='please choose')
#' object<-choice_c(object)
#' }
setMethod("choice_c", signature = signature("ref_list"), definition = function(object,
    selectedvalue) {
    if (length(selectedvalue) > 1)
        stop("valeurchoisie should be a vector of length 1")
    if (inherits(selectedvalue, "numeric"))
        selectedvalue <- as.character(selectedvalue)
    # the charge method must be performed before

    if (!selectedvalue %in% object@listechoice) {
        stop(stringr::str_c("The selected valeur,", selectedvalue, " not in the list of possible values :",
            stringr::str_c(object@listechoice, collapse = ",")))
    } else {
        object@selectedvalue <- selectedvalue
    }
    return(object)
})

#' Function to calculate statistics per month
#' @param tableau A table with the following columns : No.pas,debut_pas,fin_pas,              
#' ope_dic_identifiant,lot_tax_code,lot_std_code,type_de_quantite,MESURE,CALCULE,               
#' EXPERT,PONCTUEL,Effectif_total,taux_d_echappement,coe_valeur_coefficient
#' @note this function is intended to be called from within the summary method 
#' @param time.sequence Passed from report_mig or report_mig_mult
#' @param taxa  Taxa
#' @param stage The Stage
#' @param DC  The counting device
#' @param silent Message displayed or not
#' @return No return value, called for side effects
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
funstat = function(tableau, time.sequence, taxa, stage, DC, silent) {
    if (!silent)
        funout(gettext("Calculation of the monthly balance sheet\n", domain = "R-stacomiR"))
    mois = strftime(as.POSIXlt(time.sequence), "%m")
    moislab = unique(mois)
    annee = paste(unique(strftime(as.POSIXlt(time.sequence), "%Y")), collapse = ",")
    somme = tapply(tableau$Effectif_total, mois, sum, na.rm = TRUE)  # sums
    moyennes_journalieres = tapply(tableau$Effectif_total, mois, mean, na.rm = TRUE)  # means
    # ecarts_types=tapply(tableau$Effectif_total, mois, sd, na.rm=TRUE) # std.
    # deviations nombre=as.integer(tapply(tableau$Effectif_total, mois,
    # function(x) sum(!is.na(x)))) # counts
    resum = rbind(somme, moyennes_journalieres)  #,moyennes_journalieres,ecarts_types,nombre)
		if (taxa == "Anguilla anguilla" & stage == "civelle") {
        poids_depuis_effectif = tapply(tableau$poids_depuis_effectif, mois, sum,
            na.rm = TRUE)
        poids_mesure = tapply(tableau$Poids_total, mois, sum, na.rm = TRUE)
        Poids_total = poids_depuis_effectif + poids_mesure
        resum = rbind(somme, moyennes_journalieres, poids_depuis_effectif, poids_mesure,
            Poids_total)
    }
    resum = resum[, moislab, drop = FALSE]
    resum = as.data.frame(resum)
    resum["somme", "year"] = round(sum(tableau$Effectif_total, na.rm = TRUE), 2)
    resum["moyennes_journalieres", "year"] = mean(tableau$Effectif_total, na.rm = TRUE)
    # resum['moyennes_journalieres','year']=round(mean(tableau$Effectif_total,
    # na.rm=TRUE),2)
    # resum['ecarts_types','report']=round(sd(tableau$Effectif_total,
    # na.rm=TRUE),2)
    if (taxa == "Anguilla anguilla" & stage == "civelle") {
        resum["poids_depuis_effectif", "year"] = round(sum(tableau$poids_depuis_effectif,
            na.rm = TRUE), 2)
        resum["poids_mesure", "year"] = round(sum(tableau$Poids_total, na.rm = TRUE),
            2)
        resum["Poids_total", "year"] = round(sum(Poids_total, na.rm = TRUE), 2)
    }
    resum = cbind(label = paste("DC", DC, taxa, stage, annee, sep = "_"), resum)
    # funout(paste(DC,taxa,stage,annee,'\n'))
    # funout(paste('DC','code_taxa','code_stage','annee','\n'))
    if (!silent) {
        funout(gettext("Calculation of the monthly balance sheet\n", domain = "R-stacomiR"))
        print(resum["somme", ])
    }
    return(resum)
}

UNE_SECONDE     = as.difftime(c("0:0:1"))

UNE_MINUTE      = 60 * UNE_SECONDE

DIX_MINUTES     = 10 * UNE_MINUTE

QUINZE_MINUTES  = 15 * UNE_MINUTE

TRENTE_MINUTES  = 30 * UNE_MINUTE

UNE_HEURE       = 60 * UNE_MINUTE

DOUZE_HEURES    = 12 * UNE_HEURE

UN_JOUR         = 24 * UNE_HEURE

UNE_SEMAINE     = 7 * UN_JOUR

DEUX_SEMAINES   = 2 * UNE_SEMAINE

UN_MOIS         = 30 * UN_JOUR

TROIS_MOIS      = 91 * UN_JOUR

SIX_MOIS        = 182 * UN_JOUR

UN_AN           = 365 * UN_JOUR


Valeurref_timestep = c(
  UNE_SECONDE,
  UNE_MINUTE,
  DIX_MINUTES,
  QUINZE_MINUTES,
  TRENTE_MINUTES,
  UNE_HEURE,
  DOUZE_HEURES,
  UN_JOUR,
  UNE_SEMAINE,
  DEUX_SEMAINES,
  UN_MOIS,
  TROIS_MOIS,
  SIX_MOIS,
  UN_AN
)
Labelref_timestep = c(
  "1 sec",
  "1 min",
  "10 min" ,
  "15 min" ,
  "30 min",
  "1 h"   ,
  "12 h"  ,
  "1 jour"   ,
  "1 sem" ,
  "2 sem"  ,
  "1 mois" ,
  "3 mois" ,
  "6 mois" ,
  "1 an"
)
Lesref_timestep = data.frame("Valeurref_timestep" = Valeurref_timestep)
Lesref_timestep[, "Labelref_timestep"] = Labelref_timestep
rownames(Lesref_timestep) =
  c(
    "UNE_SECONDE",
    "UNE_MINUTE",
    "DIX_MINUTES",
    "QUINZE_MINUTES",
    "TRENTE_MINUTES",
    "UNE_HEURE",
    "DOUZE_HEURES",
    "UN_JOUR",
    "UNE_SEMAINE",
    "DEUX_SEMAINES",
    "UN_MOIS",
    "TROIS_MOIS",
    "SIX_MOIS",
    "UN_AN"
  )
rm(
  UNE_SECONDE,
  UNE_MINUTE,
  DIX_MINUTES,
  QUINZE_MINUTES,
  TRENTE_MINUTES,
  UNE_HEURE,
  DOUZE_HEURES,
  UN_JOUR,
  UNE_SEMAINE,
  DEUX_SEMAINES,
  UN_MOIS,
  TROIS_MOIS,
  SIX_MOIS,
  UN_AN,
  Labelref_timestep
)


validity_ref_timestep = function(object)
{
  retValue = NULL
  rep1 = inherits(object@dateDebut[1], "POSIXlt")
  if (!rep1)
    retValue = "object@dateDebut is not of class POSIXlt"
  rep2 = length(object@step_duration) == 1
  if (!rep2)
    retValue = paste(retValue, "length(object@step_duration) !=1")
  rep3 = length(object@nb_step) == 1
  if (!rep3)
    retValue = paste(retValue, "length(object@nb_step) !=1")
  rep4 = length(object@nocurrent_step) == 1
  if (!rep4)
    retValue = paste(retValue, "length(object@nocurrent_step) !=1")
  return(ifelse(rep1 & rep2 & rep3 & rep4, TRUE, retValue))
}

#' Class "ref_timestep"
#'
#' Describes a time step
#'
#'
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("ref_timestep",
#' dateDebut="POSIXt",step_duration=numeric(),nb_step=numeric(),nocurrent_step=integer())}.
#' \describe{
#' \item{list("dateDebut")}{Object of class \code{"POSIXt"} Starting
#' date }
#' \item{:}{Object of class \code{"POSIXt"} Starting date }
#' \item{list("step_duration")}{Object of class \code{"numeric"} Step length
#' }\item{:}{Object of class \code{"numeric"} Step length }
#' \item{list("nb_step")}{Object of class \code{"numeric"} Number of steps
#' }\item{:}{Object of class \code{"numeric"} Number of steps }
#' \item{list("nocurrent_step")}{Object of class \code{"integer"} Number of the
#' current step }\item{:}{Object of class \code{"integer"} Number of the
#' current step } }
#' @author cedric.briand@eptb-vilaine.fr
#' @seealso \code{\linkS4class{ref_timestep_daily}}
#' @concept report Object
setClass(
  Class = "ref_timestep",
  representation =
    representation(
      dateDebut = "POSIXlt",
      step_duration = "numeric",
      nb_step = "numeric",
      nocurrent_step = "integer"
    ),
  validity = validity_ref_timestep,
  prototype = prototype(
    dateDebut = as.POSIXlt(Hmisc::truncPOSIXt(Sys.time(), "year")),
    step_duration = as.numeric(86400),
    nb_step = as.numeric(1),
    nocurrent_step = as.integer(0)
  )
)
# timestep= new("ref_timestep")


validity_ref_timestepChar = function(object)
{
  rep1 = inherits(object@dateDebut[1],"POSIXlt")
  rep2 = length(object@step_duration) == 1
  rep3 = length(object@nb_step) == 1
  rep4 = length(object@nocurrent_step) == 1
  rep5 = object@step_duration %in% Lesref_timestep[, "Labelref_timestep"]
  return(ifelse(rep1 &
                  rep2 &
                  rep3 & rep4 & rep5, TRUE, c(1:5)[!c(rep1, rep2, rep3, rep4, rep5)]))
}
#' Class "ref_timestepChar"
#'
#' Character to represent a ref_timestep
#'
#'
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("ref_timestepChar", \dots{})}
#' @author cedric.briand@eptb-vilaine.fr
#' @seealso \code{\linkS4class{ref_timestep}}
#' @keywords classes
#' @examples
#'
#' showClass("ref_timestepChar")
#'
setClass(
  Class = "ref_timestepChar",
  representation =
    representation(
      dateDebut = "POSIXlt",
      step_duration = "character",
      nb_step = "numeric",
      nocurrent_step = "integer"
    ),
  validity = validity_ref_timestepChar,
  prototype = prototype(
    dateDebut = as.POSIXlt(
      strptime("2008-01-01 00:00:00", format = "%Y-%m-%d %H:%M:%S"),
      tz = "GMT"
    ),
    step_duration = as.character("1 jour"),
    nb_step = as.numeric(1),
    nocurrent_step = as.integer(0)
  )
)

setAs("ref_timestepChar", "ref_timestep",   # from to
      function(from, to) {
        index = Lesref_timestep[, "Labelref_timestep"] %in% from@step_duration
        newstep_duration = Lesref_timestep[index, "Valeurref_timestep"]
        new(
          "ref_timestep",
          dateDebut = from@dateDebut,
          step_duration = newstep_duration,
          nb_step = from@nb_step,
          nocurrent_step = from@nocurrent_step
        )
      })
# timestep=as(timestepChar,"ref_timestep")


#' Gets the final horodate for an object of class \link{ref_timestep-class}
#' @param object An object of class \link{ref_timestep-class}
#' @return end_date, The final date corresponding to nb_step*time duration + initial date
#' @keywords internal
setMethod(
  "end_date",
  signature = signature("ref_timestep"),
  definition = function(object) {
    end_date = object@dateDebut + object@step_duration * (object@nb_step)
    # pour les pb de changement d'heure
    
    return(end_date)
  }
)




#' Gets the year or a vector of years corresponding to the timestep ("ref_timestep") object
#' @param object An object of class \link{ref_timestep-class}
#' @return A numeric with year or vector of years corresponding to the timestep
#' @keywords internal
setMethod(
  "get_year",
  signature = signature("ref_timestep"),
  definition = function(object) {
    dateFin = end_date(object)
    dateDebut = object@dateDebut
    seq = seq.POSIXt(from = dateDebut, to = dateFin, by = "day")
    seq = seq[-length(seq)]
    annees = unique(strftime(seq, "%Y"))
    return (as.numeric(annees))
  }
)


#' Class 'ref_df'
#' 
#' Representation of a fishway, contains description data of all fishways from
#' the database along with the selected fishways (df) (integer)
#' Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_df', df_selected=integer(), ouvrage=integer(),
#' data=data.frame())}.  
#' @param df_selected Object of class \code{'integer'} The identifier of the fishway
#' @param ouvrage Object of class \code{'integer'} The attached dam
#' @param data Object of class \code{'data.frame'} Data concerning the fishway
#' @author cedric.briand@eptb-vilaine.fr
#' @family referential objects
setClass(Class = "ref_df", representation = representation(df_selected = "integer",
				ouvrage = "integer", data = "data.frame"))

setValidity("ref_df", method = function(object) {
			if (length(object@df_selected) != 0) {
				if (nrow(object@data) > 0) {
					concord <- object@df_selected %in% object@data$df
					if (any(!concord)) {
						return(paste("No data for DF", object@df_selected[!concord]))
						
					} else {
						return(TRUE)
					}
				} else {
					return("You tried to set a value for df_selected without initializing the data slot")
				}
			} else return(TRUE)
			
		})
#' Loading method for DF referential objects
#' @param object An object of class \link{ref_df-class}
#' @return An object of class ref_df with df loaded
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_df')
#' charge(object)
#' }
setMethod("charge", signature = signature("ref_df"), definition = function(object) {
			requete = new("RequeteDB")
			requete@sql = paste("select dis_identifiant as DF,", " dis_date_creation,", " dis_date_suppression,",
					" dis_commentaires,", " dif_ouv_identifiant,", " ouv_libelle,", " dif_code as DF_code,",
					" dif_localisation,", " dif_orientation,", " tdf_libelle as type_DF", " from ",
					get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositiffranchissement_dif ON dif_dis_identifiant=dis_identifiant",
					" JOIN ", get_schema(), "tj_dfesttype_dft ON dif_dis_identifiant=dft_df_identifiant",
					" JOIN ", get_schema(), "t_ouvrage_ouv on dif_ouv_identifiant=ouv_identifiant",
					" JOIN ref.tr_typedf_tdf ON tdf_code=dft_tdf_code", " ORDER BY dis_identifiant;",
					sep = "")
			requete <- stacomirtools::query(requete)
			object@data <- requete@query
			return(object)
		})


#' Command line interface to choose a fishway
#' 
#' the choice_c method is intended to have the same behaviour as choice (which creates a
#' widget in the graphical interface) but from the command line.  The parameters for dF are transformed to integer as the ref_df only 
#' takes integer in the df slots. 
#' DF are third in hierarchy in the stacomi database Station>ouvrage>DF>DC>operation. This class is only used in the
#' report_df class.
#' @param object an object of class \link{ref_df-class}
#' @param df a character vector of df chosen
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of class ref_df with df selected
#' @examples
#' \dontrun{
#' win=gwindow()
#' group=ggroup(container=win,horizontal=FALSE)
#' object=new('ref_df')
#' object<-charge(object)
#' objectreport=new('report_mig_mult')
#' choice_c(object=object,objectreport=objectreport,dc=1)
#' }
setMethod("choice_c", signature = signature("ref_df"), definition = function(object,
				df) {
			# object<-ref_df
			if (inherits(df, "numeric")) {
				df <- as.integer(df)
			} else if (inherits(df, "character")) {
				
				suppressWarnings(expr = {df <- as.integer(as.numeric(df))})

			}
			if (any(is.na(df)))
				stop("NA values df")
			object@df_selected <- df
			object@ouvrage = object@data$dif_ouv_identifiant[object@data$df %in% object@df_selected]
			validObject(object)
			# the method validObject verifies that the df is in the data slot of
			# ref_df  
			
			assign("ref_df", object, envir = envir_stacomi)
			return(object)
		})

#' Report on operations
#'
#' Operations are monitoring operations generated between two dates. In the case of video monitoring
#' or similar, they can be instantaneous
#'
#' @include ref_dc.R
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("report_ope")}.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @concept report Object
#' @keywords classes
#' @aliases report_ope
#' @export
setClass(
  Class = "report_ope",
  representation = representation(
    data = "data.frame",
    dc = "ref_dc",
    horodatedebut = "ref_horodate",
    horodatefin = "ref_horodate"
  ),
  prototype = prototype(
    data = data.frame(),
    dc = new("ref_dc"),
    horodatedebut = new("ref_horodate"),
    horodatefin = new("ref_horodate")
    
  )
)

#' connect method for report_ope
#'
#' @param object An object of class \link{report_ope-class}
#' load data from the operation table, one dataset per DC
#' @param silent Boolean, TRUE removes messages.
#' @return  An object of class \link{report_ope-class} with slot data \code{@data} filled
#' @aliases connect.report_ope
#' @author cedric.briand
setMethod(
  "connect",
  signature = signature("report_ope"),
  definition = function(object, silent = FALSE) {
    # object<-report_ope
    req <- new("RequeteDBwheredate")
    lesdc <- object@dc@dc_selected
    req@colonnedebut = "ope_date_debut"
    req@colonnefin = "ope_date_debut"
    req@order_by = "ORDER BY ope_dic_identifiant, ope_date_debut"
    req@datedebut <- object@horodatedebut@horodate
    #below to be consistet with BIlanMigrationMult
    req@datefin <-
      as.POSIXlt(object@horodatefin@horodate + as.difftime("23:59:59"))
    req@select <-
      paste("SELECT * FROM  ",
            get_schema(),
            "t_operation_ope ")
    req@and = paste("AND ope_dic_identifiant in",
                    stringr::str_c("(", stringr::str_c(lesdc, collapse = ","), ")"))
    req <-
      stacomirtools::query(req)
    object@data <- req@query
    if (!silent)
      funout(gettext("Loading data for operations", domain = "R-stacomiR"))
    return(object)
  }
)


#' charge method for report_ope
#'
#'
#' used by the graphical interface to retrieve referential classes
#' assigned to envir_stacomi
#' @param object An object of class \link{report_ope-class}
#' @param silent Keeps program silent
#' @return  An object of class \link{report_ope-class}  with slots filled from values assigned in \code{envir_stacomi} environment
#' @aliases charge.report_ope
#' @author cedric.briand
#' @keywords internal
setMethod(
  "charge",
  signature = signature("report_ope"),
  definition = function(object, silent = FALSE) {
    # object<-report_ope
    if (exists("ref_dc", envir = envir_stacomi)) {
      object@dc <- get("ref_dc", envir = envir_stacomi)
    } else {
      funout(
        gettext(
          "You need to choose a counting device, clic on validate\n",
          domain = "R-stacomiR"
        ),
        arret = TRUE
      )
    }
    
    if (exists("report_ope_date_debut", envir = envir_stacomi)) {
      object@horodatedebut@horodate <-
        get("report_ope_date_debut", envir = envir_stacomi)
    } else {
      funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
             arret = TRUE)
    }
    
    if (exists("report_ope_date_fin", envir = envir_stacomi)) {
      object@horodatefin@horodate <-
        get("report_ope_date_fin", envir = envir_stacomi)
    } else {
      funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
             arret = TRUE)
    }
    assign("report_ope", object, envir = envir_stacomi)
    return(object)
  }
)

#' Generic method for manual choice using the command line
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @keywords internal
#' @export
setGeneric("choice_c", def = function(object, ...) standardGeneric("choice_c"))
#' Generic method to load referentials
#' @param object Object
#' @param ... Additional parm
#' @author cedric.briand
#' @export
setGeneric("charge", def = function(object, ...) standardGeneric("charge"))
#' Generic method to load referentials, with filters from the parent object in the database
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @keywords internal
#' @export
setGeneric("charge_with_filter", def = function(object, ...) standardGeneric("charge_with_filter"))
# setGeneric('connect',def=function(object,...) standardGeneric('connect')) #
# package stacomirtools setGeneric('plot',def=function(x,y,...)
# standardGeneric('plot'))
#' Generic for prediction
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @export
setGeneric("model", def = function(object, ...) standardGeneric("model"))
#' Generic method to load additional data
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @export
setGeneric("charge_complement", def = function(object, ...) standardGeneric("charge_complement"))
#' Generic method for calculations
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @export
setGeneric("calcule", def = function(object, ...) standardGeneric("calcule"))
#' Generic method to delete entires from the database
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @seealso \link{calcule.report_ge_weight}, \link{calcule.report_mig_char}, \link{calcule.report_mig_env},
#' \link{calcule.report_mig_interannual},\link{calcule.report_mig_mult},\link{calcule.report_mig_mult},
#' \link{calcule.report_sample_char},  \link{calcule.report_sea_age},  \link{calcule.report_silver_eel},
#'  \link{calcule.report_species}
#' @export
setGeneric("supprime", def = function(object, ...) standardGeneric("supprime"))
#' Generic method write_database
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @export
setGeneric("write_database", def = function(object, ...) standardGeneric("write_database"))
#' Generic method getvalue
#' @param object Object
#' @param ... Additional parms
#' @author cedric.briand
#' @export
setGeneric("getvalue", def = function(object, ...) standardGeneric("getvalue"))
#' Generic method to transform quantitative par into a qualitative one
#' @param object Object
#' @param ... Additional parms 
#' @author cedric.briand
#' @export
setGeneric("setasqualitative", def = function(object, ...) standardGeneric("setasqualitative"))
#' Generic method for getting the final date
#' @param object An object
#' @param ... Additional parameters passed to the method
#' @keywords internal
setGeneric(
		"end_date",
		def = function(object, ...)
			standardGeneric("end_date")
)


#' Generic method to get the years
#' @param object An object
#' @param ... Additional parameters passed to the method
#' @keywords internal
setGeneric(
		"get_year",
		def = function(object, ...)
			standardGeneric("get_year")
)

#' Environment where most objects from the package are stored and then loaded
#' by the charge method
#' 
#' envir_stacomi \code{envir_stacomi <- new.env(parent = baseenv())} is the
#' environment where most object created by the interface are stored
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
"envir_stacomi"

#' Class 'ref_timestep_daily'
#' 
#' Representation of a ref_timestep object with a step length equal to one day.
#' It receives an inheritance from ref_timestep
#' 
#' validity_ref_timestep_daily
#' @include ref_timestep.R
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_timestep_daily',
#' dateDebut='POSIXt',step_duration=numeric(),nb_step=numeric(),nocurrent_step=integer())}.
#' \describe{ \item{list('dateDebut')}{Object of class \code{'POSIXt'} Starting
#' date }\item{:}{Object of class \code{'POSIXt'} Starting date }
#' \item{list('step_duration')}{Object of class \code{'numeric'} Step length
#' }\item{:}{Object of class \code{'numeric'} Step length }
#' \item{list('nb_step')}{Object of class \code{'numeric'} Number of steps
#' }\item{:}{Object of class \code{'numeric'} Number of steps }
#' \item{list('nocurrent_step')}{Object of class \code{'integer'} Number of the
#' current step }\item{:}{Object of class \code{'integer'} Number of the
#' current step } }
#' @author cedric.briand@eptb-vilaine.fr
#' @seealso \code{\linkS4class{ref_timestep}}
#' @keywords classes
setClass(Class = "ref_timestep_daily", contains = "ref_timestep", prototype = (step_duration = 86400))



setValidity(Class = "ref_timestep_daily", function(object) {
    retValue <- NULL
    rep1 = validity_ref_timestep(object)
    if (!is.logical(rep1))
        retValue <- rep1
    rep2 = (object@step_duration == 86400)
    if (!rep2)
        retValue = paste(retValue, gettext("Time step duration should be daily",
            domain = "R-stacomiR"))
    rep3 = length(get_year(object)) == 1
    if (!rep3)
        retValue = paste(retValue, gettext("Time step can't include more than one year",
            domain = "R-stacomiR"))
    return(ifelse(rep1 & rep2 & rep3, TRUE, retValue))
})
# pour test #object=new('ref_timestep_daily')



#' choice_c method for class ref_timestep_daily
#' 
#' the choice_c method is intended to have the same behaviour as choice (which creates a
#' widget in the graphical interface) but from the command line.  
#' @param object An object of class \link{ref_timestep_daily-class}
#' @param datedebut A character (format \code{'15/01/1996'} or \code{'1996-01-15'} or \code{'15-01-1996'}), or POSIXct object
#' @param datefin A character 
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples
#' \dontrun{
#'  object=new('ref_dc')
#'  object<-charge(object)
#'  choice_c(object=object,datedebut='2012-01-01',datefin='2013-01-01')
#' }
#' @return An S4 object of class \link{ref_timestep_daily-class} with date selected
setMethod("choice_c", signature = signature("ref_timestep_daily"), definition = function(object,
    datedebut, datefin) {
    if (inherits(datedebut, "character")) {
        if (grepl("/", datedebut)) {
            datedebut = strptime(datedebut, format = "%d/%m/%Y")
            if (is.na(datedebut)) {
                datedebut = strptime(datedebut, format = "%d/%m/%y")
            }
        } else if (grepl("-", datedebut)) {
            datedebut = strptime(datedebut, format = "%Y-%m-%d")
            if (is.na(datedebut)) {
                datedebut = strptime(datedebut, format = "%d-%m-%Y")
            }
        }
        if (is.na(datedebut)) {
            stop("datedebut not parsed to datetime try format like '01/01/2017'")
        }
    }

    # the datedebut can have a POSIXct format
    if (inherits(datefin, "character")) {
        if (grepl("/", datefin)) {
            datefin = strptime(datefin, format = "%d/%m/%Y")
            if (is.na(datefin)) {
                datefin = strptime(datefin, format = "%d/%m/%y")
            }
        } else if (grepl("-", datefin)) {
            datefin = strptime(datefin, format = "%Y-%m-%d")
            if (is.na(datefin)) {
                datefin = strptime(datefin, format = "%d-%m-%Y")
            }
        }
        if (is.na(datefin)) {
            stop("datefin not parsed to datetime try format like '01/01/2017'")
        }
    }
    object@dateDebut <- as.POSIXlt(datedebut)
    object@nb_step = as.numeric(difftime(datefin, datedebut, units = "days"))  # to fit with end_date(object)
    validObject(object)
    assign("timestep", object, envir_stacomi)
    return(object)
})

#' Class 'ref_dc'
#'
#' Description of a control device.
#'
#' @include create_generic.R
#' @slot dc_selected Object of class \code{'integer'}, The selected device
#' @slot ouvrage Object of class \code{'integer'}, the attached dam
#' @slot station Object of class \code{'character'}, the attached migration monitoring station, this is necessary to join the
#' table of escapements calculated at the station level.
#' @slot data Object of class \code{'data.frame'} data pertaining to the control device
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_dc', dc_selected=integer(), ouvrage=integer(),
#' data=data.frame())}.
#' @author cedric.briand@eptb-vilaine.fr
#' @keywords classes
#' @family referential objects
setClass(
    Class = "ref_dc",
    representation = representation(
        dc_selected = "integer",
        ouvrage = "integer",
        station = "character",
        data = "data.frame"
    ),
    prototype = prototype(
        dc_selected = integer(),
        ouvrage = integer(),
        station = character(),
        data = data.frame()
    )
)



setValidity(
    "ref_dc",
    method = function(object) {
        if (length(object@dc_selected) != 0) {
            if (nrow(object@data) > 0) {
                concord <- object@dc_selected %in% object@data$dc
                if (any(!concord)) {
                    return(paste("No data for DC", object@dc_selected[!concord]))
                    
                } else {
                    return(TRUE)
                }
            } else {
                return(
                    "You tried to set a value for dc_selected without initializing the data slot"
                )
            }
        } else
            return(TRUE)
        
    }
)


#' Method to load the counting devices of the control station
#' @param object An object of class \link{ref_dc-class}
#' @return an object of class ref_dc with data loaded
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
setMethod(
    "charge",
    signature = signature("ref_dc"),
    definition = function(object) {
        requete = new("RequeteDB")
        requete@sql = paste(
            "select dis_identifiant as DC,",
            " dis_date_creation,",
            " dis_date_suppression,",
            " dif_dis_identifiant as DF,",
            " dis_commentaires,",
            " dif_ouv_identifiant,",
            " ouv_libelle,",
            " dif_code as DF_code,",
            " dic_code as DC_code,",
            " dif_localisation,",
            " dif_orientation,",
            " tdf_libelle as type_DF,",
            " tdc_libelle as type_DC,",
            "sta_code",
            " FROM ",
            get_schema(),
            "tg_dispositif_dis",
            " JOIN ",
            get_schema(),
            "t_dispositifcomptage_dic ON dic_dis_identifiant =dis_identifiant",
            " JOIN ",
            get_schema(),
            "t_dispositiffranchissement_dif ON dif_dis_identifiant=dic_dif_identifiant",
            " JOIN ",
            get_schema(),
            "tj_dfesttype_dft ON dif_dis_identifiant=dft_df_identifiant",
            " JOIN ",
            get_schema(),
            "t_ouvrage_ouv on dif_ouv_identifiant=ouv_identifiant",
            " JOIN ",
            get_schema(),
            "t_station_sta on ouv_sta_code=sta_code",
            " JOIN ref.tr_typedf_tdf ON tdf_code=dft_tdf_code",
            " JOIN ref.tr_typedc_tdc ON dic_tdc_code=tdc_code",
            " WHERE  dft_rang=1",
            " ORDER BY dis_identifiant;",
            sep = ""
        )
        requete <- stacomirtools::query(requete)
        # funout(gettext('The query to load counting devices is done
        # \n',domain='R-stacomiR'))
        object@data <- requete@query
        return(object)
    }
)



#' Command line interface to select a counting device
#'
#' the choice_c method is intended to have the same behaviour as choice (which creates a
#' widget in the graphical interface) but from the command line.  The parameters for dc are transformed to integer as the ref_dc only
#' takes integer in the dc slots. The method also loads the stations and ouvrages (dams) associated with the counting device (dc).
#' The values passed to the choice_c method are then checked with the setValidty method.
#' Finally, if an objectreport is passed as a parameter, the method will do a charge_with_filter to select only the taxa present in the counting devices
#' @param object an object of class ref_dc
#' @param dc a character vector of dc chosen
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @return An object of class ref_dc with dc selected
#' @examples
#' \dontrun{
#' win=gwindow()
#' group=ggroup(container=win,horizontal=FALSE)
#' object=new('ref_dc')
#' object<-charge(object)
#' objectreport=new('report_mig_mult')
#' choice_c(object=object,objectreport=objectreport,dc=1)
#' }
setMethod(
    "choice_c",
    signature = signature("ref_dc"),
    definition = function(object,
                          dc) {
        if (inherits(dc, "numeric")) {
            dc <- as.integer(dc)
        } else if (inherits(dc, "character")) {
            dc = as.integer(as.numeric(dc))
        }
        if (any(is.na(dc)))
            stop("NA values dc")
        
        
        object@dc_selected <- dc
        validObject(object)
        # the method validObject verifies that the dc is in the data slot of
        # ref_dc  
        
        object@station <-
            as.character(object@data$sta_code[object@data$dc %in% object@dc_selected])
        object@ouvrage <-
            object@data$dif_ouv_identifiant[object@data$dc %in% object@dc_selected]
        assign("ref_dc", object, envir = envir_stacomi)
        return(object)
    }
)

# Name : ref_coe(classe)

#' Class 'ref_coe'
#' 
#' Enables to load conversion coefficients quantity-number. This class only exists to load
#' the data with its method charge. It is not used directly as component of the graphical interface,
#' as the year is already loaded in the different report objects
#' 
#' 
#' @note Class loading coefficient of conversion between quantity (weights or
#' volumes of glass eel) and numbers between a starting and finishing date
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_coe')}.
#' @slot data A \code{data.frame}
#' @slot datedebut A 'POSIXlt'
#' @slot datefin A 'POSIXlt'
#' @author cedric.briand@eptb-vilaine.fr
#' @family referential objects
#' @keywords classes
setClass(Class = "ref_coe", representation = representation(data = "data.frame",
				datedebut = "POSIXlt", datefin = "POSIXlt"), prototype = prototype(data = data.frame()))

#' loads the coefficients for the period defined in class
#' 
#' 
#' The slots datedebut and datefin have to be filled before using charge
#' @param object An object of class \link{ref_coe-class}
#' @return An object of class \link{ref_coe-class} 
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#' object<- new('ref_coe')
#' object@datedebut<-strptime('01/01/1996',format='%d/%m/%Y')
#' object@datefin<-strptime('01/01/1997',format='%d/%m/%Y')
#' charge(object) 
#' }
setMethod("charge", signature = signature("ref_coe"), definition = function(object) {
			requete = new("RequeteDBwheredate")
			requete@datedebut = object@datedebut
			requete@datefin = object@datefin
			requete@colonnedebut = "coe_date_debut"
			requete@colonnefin = "coe_date_fin"
			requete@datefin = as.POSIXlt(object@datefin)
			requete@select = stringr::str_c("select * from ", get_schema(), "tj_coefficientconversion_coe")
			requete@and = " and  coe_tax_code='2038' and coe_std_code='CIV' and coe_qte_code='1'"
			requete <- query(requete)
			object@data <- requete@query
			return(object)
		})


#' supprime method for 'ref_coe' class
#' @param object An object of class \link{ref_coe-class}
#' @param tax '2038=Anguilla anguilla'
#' @param std 'CIV=civelle'
#' @param silent Default FALSE, if TRUE the program should no display messages
#' @return Nothing, called for side effect
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
setMethod("supprime", signature = signature("ref_coe"), definition = function(object,
				tax, std, silent = FALSE) {
			# object<-r_gew@coe;tax=2038;std='CIV' getting the data to import
			
			# here I assume that dc_selected will be unique (no report with several
			# dc)
			req = new("RequeteDB")
			req@sql <- stringr::str_c(
					"WITH deleted AS (", 
					"DELETE FROM ", get_schema(), "tj_coefficientconversion_coe ",
					"WHERE coe_date_debut >= '",object@datedebut,"'",
					" AND coe_date_fin  <= '", object@datefin, "'",
					" AND  coe_tax_code='", tax, "' and coe_std_code='", std,
					"' and coe_qte_code='1'",
					" RETURNING *)",
					" SELECT * FROM deleted"
			)
			del <- stacomirtools::getquery(query(req))
			nr <- nrow(del)
			if (!silent)
				funout(gettextf("%s rows deleted from table tj_coefficientconversion_coe",
								nr, domain = "R-stacomiR"))
			return(invisible(NULL))
		})


#' Class 'ref_parquan'
#' 
#' Class enabling to load the list of quantitative parameters and to select one
#' of them. It inherits from 'ref_par', uses its 'choice' method
#' @author cedric.briand@eptb-vilaine.fr
#' @keywords classes
#' @family referential objects
#' @include ref_par.R
setClass(Class = "ref_parquan", contains = "ref_par")

#' Loading method for Reparquan referential objects
#' @param object An object of class \link{ref_parquan-class}
#' @return An S4 object of class \link{ref_parquan-class} with data loaded
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  object=new('ref_parquan')
#'  charge(object)
#' }
setMethod("charge", signature = signature("ref_parquan"), definition = function(object) {
    requete = new("RequeteDB")
    requete@sql = "SELECT par_code, par_nom, par_unite, par_nature, par_definition FROM ref.tg_parametre_par 
	  INNER JOIN ref.tr_parametrequantitatif_qan ON qan_par_code=par_code"
    requete <- stacomirtools::query(requete)
    # funout(gettext('The query to load parameters is done
    # \n',domain='R-stacomiR'))
    object@data <- requete@query
    return(object)
})


#' Loading method for Reparquan referential objects searching only those parameters existing for a DC (counting device), a Taxon, and a stage
#' @param object An object of class \link{ref_parquan-class}
#' @param dc_selected The dc set in the report object
#' @param taxa_selected The taxa set in the report object
#' @param stage_selected The stage set in the report object
#' @return An S4 object of class \link{ref_parquan-class} with data loaded showing available parameters for one DC
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#'  dc_selected=6
#'taxa_selected=2038
#'  stage_selected='AGJ'
#'  object=new('ref_parquan')
#'  charge_with_filter(object,dc_selected,taxa_selected,stage_selected)
#' }  
setMethod("charge_with_filter", signature = signature("ref_parquan"), definition = function(object,
    dc_selected, taxa_selected, stage_selected) {
    requete = new("RequeteDBwhere")
    requete@select = paste("SELECT DISTINCT ON (par_code) par_code, par_nom, par_unite, par_nature, par_definition", " FROM ",
        get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
        " JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
        " JOIN ", get_schema(), "tj_caracteristiquelot_car on car_lot_identifiant=lot_identifiant",
        " JOIN ref.tg_parametre_par on par_code=car_par_code", " JOIN ref.tr_parametrequantitatif_qan ON qan_par_code=par_code",
        sep = "")
    requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected))
    requete@and = paste("and lot_tax_code in ", vector_to_listsql(taxa_selected),
        " and lot_std_code in ", vector_to_listsql(stage_selected), "", sep = "")
    requete@order_by = "ORDER BY par_code"
    requete <- stacomirtools::query(requete)
    object@data <- requete@query
    return(object)
})



setAs("report_mig", "report_mig_interannual", function(from) {
    start_year = new("ref_year")
    end_year = new("ref_year")
    start_year@year_selected = min(get_year(from@timestep))
    end_year@year_selected = max(get_year(from@timestep))
    report_mig_interannual = new("report_mig_interannual")
    report_mig_interannual@dc = from@dc
    report_mig_interannual@taxa = from@taxa
    report_mig_interannual@stage = from@stage
    report_mig_interannual@start_year = start_year
    report_mig_interannual@end_year = end_year
    return(report_mig_interannual)
})


setAs("report_mig_interannual", "report_mig_mult", function(from) {
    report_mig_mult = new("report_mig_mult")
    report_mig_mult@dc = from@dc
    report_mig_mult@taxa = from@taxa
    report_mig_mult@stage = from@stage
    report_mig_mult@timestep@dateDebut = strptime(stringr::str_c(from@start_year@year_selected,
        "-01-01"), format = "%Y-%m-%d")
    report_mig_mult@timestep@nb_step = 364
    return(report_mig_mult)
})


setAs("report_mig", "report_mig_mult", function(from) {
    bMM = new("report_mig_mult")
    bMM@dc = from@dc
    bMM@taxa = from@taxa
    bMM@stage = from@stage
    bMM@timestep = from@timestep
    bMM@coef_conversion = from@coef_conversion
    bMM@data = from@data
    bMM@time.sequence = from@time.sequence
    bMM@calcdata = from@calcdata
    return(bMM)
})

setAs("report_mig_interannual", "report_annual", function(from) {
    r_ann = new("report_annual")
    r_ann@dc = from@dc
    r_ann@taxa = from@taxa
    r_ann@stage = from@stage
    r_ann@start_year = from@start_year
    r_ann@end_year = from@end_year
    return(r_ann)
})

#' This writes monthly data in t_reportmensuel_mens table
#' 
#' @note This function is launched by fun_write_daily, the resum 
#' dataset is created by the \link{funstat} function
#' 
#' 
#' @param report_mig an object of class \code{\linkS4class{report_mig}}
#' @param resum data frame with summary per month
#' @param silent Suppresses messages
#' @return No return value, called for side effects
#' @export
fun_write_monthly<-function(report_mig,resum,silent){
	t_reportmigrationmensuel_bme <- stacomirtools::killfactor(
			cbind(report_mig@dc@dc_selected,
					report_mig@taxa@taxa_selected,
					report_mig@stage@stage_selected,
					as.integer(unique(strftime(as.POSIXlt(report_mig@time.sequence),"%Y"))), # une valeur bme_annee			
					rep(rownames(resum),(ncol(resum)-2)), # nb of month except columns report and label # bme_labelquantite
					stack(resum, select=c(2:(ncol(resum)-1))),# stack re-ordonne les tab de donnees !  
					as.POSIXct(format(Sys.time(), "%Y-%m-%d %H:%M:%S")),
					get_org()
			)
	)
	colnames(t_reportmigrationmensuel_bme) <-
			c("bme_dis_identifiant","bme_tax_code","bme_std_code","bme_annee","bme_labelquantite","bme_valeur",
					"bme_mois","bme_horodateexport","bme_org_code")
	t_reportmigrationmensuel_bme$bme_mois<- as.integer(t_reportmigrationmensuel_bme$bme_mois)
	# ecriture dans la base...
	con <- new("ConnectionDB")
	con <- connect(con)
	on.exit(pool::poolClose(con@connection))
	pool::dbWriteTable(con@connection, 
			name = "temp_t_reportmigrationmensuel_bme", 
			value=t_reportmigrationmensuel_bme, 
			temporary=TRUE,
			overwrite=TRUE)	
	
	sql=paste(
			"INSERT INTO ",
			get_schema(),
			"t_bilanmigrationmensuel_bme (",			
			"bme_dis_identifiant,bme_tax_code,bme_std_code,bme_annee,bme_labelquantite,bme_valeur,
					bme_mois,bme_horodateexport,bme_org_code)",
			" SELECT * FROM temp_t_reportmigrationmensuel_bme")
	
	nline <- pool::dbExecute(con@connection, statement = sql)
	
	if (!silent) funout(gettextf("Writing monthly summary (n=%s) in the database\n", nline, domain="R-stacomiR"))
	return(invisible(NULL))
} # end function


#' Class 'ref_choice'
#' 
#' ref_choice referential class allows to choose within several values with
#' radiobuttons interface
#' 
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new('ref_choice', listechoice=character() ,label=character()
#' ,selected=integer())}.
#' @slot listechoice A character vector giving possible choices
#' @slot label A character, title of the box giving the possible choices
#' @slot selected An \code{Integer}  the initial selected value (as an index), first=1 used in gradio
#' @author cedric.briand@eptb-vilaine.fr
#' @family referential objects
setClass(Class = "ref_choice", representation = representation(listechoice = "ANY",
    label = "character", selected = "integer", selectedvalue = "ANY"), prototype = list(selectedvalue = vector()))

#' Loading method for Refchoice referential objects
#' 
#' @family referential objects
#' @return An S4 object of class \link{ref_choice-class} 
#' @param object An object of class ref_choice
#' @param vecteur A vector of name, see example code.
#' @param label Labels for the choices
#' @param selected An integer indicating which object is selected at launch
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples 
#' \dontrun{
#' object=new('ref_choice')
#' charge(object,vecteur=c('oui','non'),label='essai',selected=as.integer(1))
#' }
setMethod("charge", signature = signature("ref_choice"), definition = function(object,
    vecteur, label, selected) {
    object@listechoice = vecteur
    object@label = label
    object@selected = selected
    object
    return(object)
})


#' Choice_c method for ref_choice referential objects
#' @param object An object of class \link{ref_choice-class}
#' @param selectedvalue the value selected in the combo
#' @return An S4 object of class \link{ref_choice-class} 
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @examples  
#' \dontrun{
#' object=new('ref_list')
#' object<-charge(object,vecteur=c('1','2'),label='please choose')
#' object<-choice_c(object)
#' }
setMethod("choice_c", signature = signature("ref_choice"), definition = function(object,
    selectedvalue) {

    if (length(selectedvalue) > 1)
        stop("valeurchoisie should be a vector of length 1")
    if (inherits(selectedvalue,"numeric"))
        selectedvalue <- as.character(selectedvalue)
    # the charge method must be performed before

    if (!selectedvalue %in% object@listechoice) {
        stop(stringr::str_c("The selected valeur,", selectedvalue, " not in the list of possible values :",
            stringr::str_c(object@listechoice, collapse = ",")))
    } else {
        object@selectedvalue <- selectedvalue
    }
    return(object)


})


1		#' Creates a list of available schemas in the db
2		#'
3		#' @return A table with of data providers with org_code, the user of each schema, and org_description the description of the schema
4		#' @export
5		fun_schema <- function(){
6	!	req = new("RequeteDB")
7		# this query will get characteristics from lot_pere when null
8	!	req@sql = "SELECT * FROM ref.ts_organisme_org too WHERE NOT org_code IN ('nat','invite') ORDER BY org_code"
9	!	schema_table <- query(req)@query
10	!	return(schema_table)
11		}
12
13
14

1		# Nom fichier : ref_env (classe) Date de creation : 02/01/2009 15:02:40
2
3		#' Class 'ref_env'
4		#'
5		#' Enables to load measure stations and to select one of them
6		#'
7		#' @section Objects from the Class: Objects can be created by calls of the form
8		#' \code{new('ref_env', ...)}.
9		#' @slot dataframe Data concerning the
10		#' measure station
11		#' @slot env_selected The selected measure station
12		#' @author cedric.briand@eptb-vilaine.fr
13		#' @keywords classes
14		setClass(Class = "ref_env", representation =
15		representation(data = "data.frame",
16		env_selected="character"),
17		prototype = prototype(
18		data = data.frame(),
19		env_selected=character()))
20
21		#' Loading method for ref_env referential object
22		#' @return An S4 object of class ref_env with data loaded from the database
23		#' @param object An object of class \link{ref_env-class}
24		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
25		#' @examples
26		#' \dontrun{
27		#' object=new('ref_env')
28		#' charge(object)
29		#' }
30		setMethod("charge", signature = signature("ref_env"), definition = function(object) {
31	5x	requete = new("RequeteDB")
32	5x	requete@sql = paste("SELECT stm_identifiant, stm_libelle, stm_sta_code, stm_par_code, stm_description",
33	5x	" FROM ", get_schema(), "tj_stationmesure_stm", " ORDER BY stm_identifiant;",
34	5x	sep = "")
35	5x	requete@silent = TRUE
36	5x	requete <- stacomirtools::query(requete)
37	5x	object@data <- requete@query
38	5x	return(object)
39		})
40
41
42
43		#' Command line interface to select a monitoring station
44		#'
45		#' the choice_c method is intended to have the same behaviour as choice (which creates a
46		#' widget in the graphical interface) but from the command line.
47		#' @param object an object of class ref_env
48		#' @param stationMesure a character vector of the monitoring station code (corresponds to stm_libelle in the tj_stationmesure_stm table)
49		#' @return an object of class \link{ref_env-class} with the monitoring station selected
50		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
51		setMethod("choice_c", signature = signature("ref_env"), definition = function(object,
52		stationMesure) {
53	5x	if (!inherits(stationMesure, "character")) {
54	!	stop("the stationmesure should be of class character")
55		}
56	5x	if (length(stationMesure) == 0) {
57	!	stop("Select at least one value\n")
58		}
59	5x	if (any(is.na(stationMesure))) {
60	!	stop("NA values for stationmesure")
61		}
62		# I can use the stm_libelle as there is a unique constraint in the table
63	5x	libellemanquants <- stationMesure[!stationMesure %in% object@data$stm_libelle]
64	5x	if (length(libellemanquants) > 0)
65	!	warning(gettextf("stationmesure code not present :\n %s", stringr::str_c(libellemanquants,
66	!	collapse = ", "), domain = "R-stacomiR"))
67	5x	object@env_selected <- object@data$stm_libelle[object@data$stm_libelle %in% stationMesure]
68	5x	assign("ref_env", object, envir_stacomi)
69	5x	return(object)
70		})

1		#' class report_env simple output of one or several environmental
2		#' conditions...
3		#'
4		#' Annual overview of environmental conditions. This class enables to draw some plot, but will mostly used to build
5		#' joined graphs crossing the information from \link{report_mig_mult-class} and \link{report_mig_env-class}
6		#'
7		#' @include ref_horodate.R
8		#' @include ref_env.R
9		#' @include create_generic.R
10		#' @include utilities.R
11		#' @slot horodatedebut \link{ref_horodate-class}
12		#' @slot horodatefin \link{ref_horodate-class}
13		#' @slot stationMesure \link{ref_env-class}
14		#' @slot data \code{data.frame}
15		#' @author cedric.briand@eptb-vilaine.fr
16		#' @family report Objects
17		#' @keywords classes
18		#' @aliases report_env
19		#' @keywords classes
20		#' @example inst/examples/report_env-example.R
21		#' @export
22		setClass(Class = "report_env", representation = representation(stationMesure = "ref_env",
23		horodatedebut = "ref_horodate", horodatefin = "ref_horodate", data = "data.frame"),
24		prototype = prototype(horodatedebut = new("ref_horodate"), horodatefin = new("ref_horodate"),
25		stationMesure = new("ref_env"), data = data.frame()))
26
27
28		#' connect method for report_env class
29		#' @param object An object of class \link{report_env-class}
30		#' @param silent Default FALSE, if TRUE the program should no display messages
31		#' @return An object of class \link{report_env-class} with slot data filled from the database
32		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
33		#' @aliases connect.report_env
34		setMethod("connect", signature = signature("report_env"), definition = function(object,
35		silent = FALSE) {
36		# object<-r_env
37	4x	if (length(object@stationMesure@env_selected)==0) warning("No measure station selected")
38	4x	stm_selected <- object@stationMesure@data[object@stationMesure@data$stm_libelle %in% object@stationMesure@env_selected,"stm_identifiant"]
39
40	4x	requete = new("RequeteDBwheredate")
41	4x	requete@datedebut = strptime(object@horodatedebut@horodate, format = "%Y-%m-%d")
42	4x	requete@datefin = strptime(object@horodatefin@horodate, format = "%Y-%m-%d")
43	4x	requete@colonnedebut = "env_date_debut"
44	4x	requete@colonnefin = "env_date_fin"
45	4x	requete@select = paste("SELECT", " env_date_debut,", " env_date_fin,", " env_methode_obtention,",
46	4x	" val_libelle as env_val_identifiant,", " env_valeur_quantitatif,", " env_stm_identifiant",
47	4x	" FROM ", get_schema(), "tj_conditionenvironnementale_env",
48	4x	" LEFT JOIN ref.tr_valeurparametrequalitatif_val on env_val_identifiant=val_identifiant",
49	4x	sep = "")
50	4x	requete@order_by <- "ORDER BY env_stm_identifiant, env_date_debut"
51	4x	tmp <- vector_to_listsql(stm_selected)
52	4x	requete@and = paste(" AND env_stm_identifiant IN ", tmp)
53	4x	requete <- stacomirtools::query(requete)
54	4x	object@data <- stacomirtools::killfactor(stacomirtools::getquery(requete))
55	4x	if (!silent)
56	!	funout(gettext("Environmental conditions loading query completed\n", domain = "R-stacomiR"))
57	4x	return(object)
58		})
59		#' command line interface for report_env class
60		#'
61		#' The choice_c method fills in the data slot for \link{ref_env-class} by runnning the charge method of this object.
62		#' It then runs the choice method on this object. It also applies the choice method for objects of class \link{ref_horodate-class}
63		#' @param object An object of class \link{report_env-class}
64		#' @param stationMesure A character, the code of the monitoring station, which records environmental parameters \link{choice_c,ref_env-method}
65		#' @param datedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
66		#' @param datefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
67		#' @param silent Boolean default FALSE, if TRUE information messages not displayed.
68		#' @return An object of class \link{report_env-class} with data selected
69		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
70		#' @aliases choice_c.report_env
71		setMethod("choice_c", signature = signature("report_env"), definition = function(object,
72		stationMesure, datedebut, datefin, silent = FALSE) {
73		# code for debug using r_mig example
74		# stationmesure=c('temp_gabion','coef_maree');datedebut='2008-01-01';datefin='2008-12-31';silent=FALSE
75	4x	r_env <- object
76	4x	r_env@stationMesure = charge(r_env@stationMesure)
77		# loads and verifies the stationmesure (selects the relevant lines in the
78		# table
79	4x	r_env@stationMesure <- choice_c(object = r_env@stationMesure, stationMesure)
80	4x	r_env@horodatedebut <- choice_c(object = r_env@horodatedebut, nomassign = "report_env_date_debut",
81	4x	funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
82	4x	horodate = datedebut, silent = silent)
83	4x	r_env@horodatefin <- choice_c(r_env@horodatefin, nomassign = "report_env_date_fin",
84	4x	funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
85	4x	horodate = datefin, silent = silent)
86	4x	return(r_env)
87		})
88		#' charge method for report_env class
89		#' @param object An object of class \link{report_env-class}
90		#' @param silent Default FALSE, if TRUE the program should no display messages
91		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
92		#' @aliases charge.report_env
93		#' @return An object of class \link{report_env-class} with data set from values assigned in \code{envir_stacomi} environment
94		#' @keywords internal
95		setMethod("charge", signature = signature("report_env"), definition = function(object,
96		silent) {
97
98	2x	if (exists("ref_env", envir_stacomi)) {
99	2x	object@stationMesure <- get("ref_env", envir_stacomi)
100		} else {
101	!	funout(gettext("You need to choose a monitoring station, clic on validate\n",
102	!	domain = "R-stacomiR"), arret = TRUE)
103		}
104
105	2x	if (exists("report_env_date_debut", envir_stacomi)) {
106	2x	object@horodatedebut@horodate <- get("report_env_date_debut", envir_stacomi)
107		} else {
108	!	funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
109	!	arret = TRUE)
110		}
111
112	2x	if (exists("report_env_date_fin", envir_stacomi)) {
113	2x	object@horodatefin@horodate <- get("report_env_date_fin", envir_stacomi)
114		} else {
115	!	funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
116	!	arret = TRUE)
117		}
118	2x	return(object)
119		})
120
121		#' Plot method for report_env
122		#' @param x An object of class \link{report_env-class}
123		#' @param silent Stops displaying the messages
124		#' @return Nothing, called for its side effect of plotting data
125		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
126		#' @aliases plot.report_env
127		#' @export
128		setMethod("plot", signature(x = "report_env", y = "missing"), definition = function(x,
129		silent = FALSE) {
130		# le dataframe contenant le res de la requete
131	2x	r_env <- x
132	2x	dat <- r_env@data
133	2x	if (length(unique(dat$env_stm_identifiant)) != 0) {
134		# le layout pour l'affichage des graphiques
135	2x	vplayout <- function(x, y) {
136	4x	grid::viewport(layout.pos.row = x, layout.pos.col = y)
137		}
138	2x	grid::grid.newpage()
139	2x	grid::pushViewport(grid::viewport(layout = grid::grid.layout(length(unique(dat$env_stm_identifiant)),
140	2x	1, just = "center")))
141	2x	lesGraphes = list()
142	2x	if (length(unique(dat$env_stm_identifiant)) != nrow(r_env@stationMesure@data)) {
143	2x	funout(gettext("Some monitoring stations lack associated values (no environmental data)\n",
144	2x	domain = "R-stacomiR"))
145		}
146
147		# for all stationmesure selected
148	2x	for (i in 1:length(unique(dat$env_stm_identifiant))) {
149		# the identifier of the current station
150	4x	stmidentifiant <- unique(dat$env_stm_identifiant)[i]
151
152		# the line of report_env@stationMesure currently processed in the
153		# loop
154	4x	stm <- r_env@stationMesure@data[r_env@stationMesure@data$stm_identifiant ==
155	4x	stmidentifiant, ]
156
157		# all measures for the selected station
158	4x	nameColonne <- as.character(stm$stm_libelle)
159	4x	datstm <- stacomirtools::chnames(dat, "env_valeur_quantitatif", nameColonne)
160	4x	datstm <- datstm[datstm$env_stm_identifiant == stmidentifiant, ]
161
162		# creating the plot
163	4x	g <- ggplot(datstm, aes_string(x = "env_date_debut", y = nameColonne))
164	4x	g <- g + geom_line(aes_string(colour = nameColonne)) + scale_y_continuous(stm$stm_libelle) +
165	4x	scale_x_datetime(name = "date")
166
167		# printing plot on screen
168	4x	print(g, vp = vplayout(i, 1))
169		}
170		} else {
171	!	funout(gettext("No environmental conditions values for selected monitoring stations (report_env.R)\n",
172	!	domain = "R-stacomiR"), arret = TRUE)
173		}
174	2x	return(invisible(NULL))
175		})

1		#' Class 'ref_par'
2		#'
3		#' Class enabling to load the list of parameters and select one of them
4		#' @include create_generic.R
5		#' @slot data A data.frame
6		#' @slot par_selected A character vector corresponding to par_code
7		#' @section Objects from the Class: Objects can be created by calls of the form
8		#' @author cedric.briand@eptb-vilaine.fr
9		#' @keywords classes
10		#' @slot data='data.frame' the list of parameters
11		#' @family referential objects
12		setClass(Class = "ref_par", representation = representation(data = "data.frame",
13		par_selected = "character"))
14
15
16		setValidity("ref_par", method = function(object) {
17		if (length(object@par_selected) != 0) {
18		if (nrow(object@data) > 0) {
19		concord <- object@par_selected %in% object@data$par_code
20		if (any(!concord)) {
21		return(paste("No data for par", object@par_selected[!concord]))
22
23		} else {
24		return(TRUE)
25		}
26		} else {
27		return("You tried to set a value for par_selected without initializing the data slot")
28		}
29		} else return(TRUE)
30
31		})
32		#' Loading method for ref_par referential objects
33		#' @aliases charge.ref_par
34		#' @param object An object of class \link{ref_par-class}
35		#' @return An S4 object of class ref_par
36		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
37		#' @return An S4 object of class \link{ref_par-class}
38		#' @examples
39		#' \dontrun{
40		#' object=new('ref_par')
41		#' charge(object)
42		#' }
43		setMethod("charge", signature = signature("ref_par"), definition = function(object) {
44	1x	requete = new("RequeteDB")
45	1x	requete@sql = paste("SELECT par_code, par_nom, par_unite, par_nature, par_definition from ref.tg_parametre_par")
46	1x	requete <- stacomirtools::query(requete)
47		#funout(gettext("Loading parameters query completed\n", domain = "R-stacomiR"))
48	1x	object@data <- requete@query
49	1x	return(object)
50		})
51
52
53		#' Loading method for \code{ref_par referential} objects searching only those parameters existing for a DC, a Taxa, and a stage
54		#' @aliases charge_with_filter.ref_par
55		#' @param object An object of class \link{ref_par-class}
56		#' @param dc_selected A counting device selected for the report
57		#' @param taxa_selected The taxa selected for the report
58		#' @param stage_selected The stage selected for the report
59		#' @return An S4 object of class \link{ref_par-class}
60		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
61		#' @examples
62		#' \dontrun{
63		#' object=new('ref_par')
64		#' charge_with_filter(object,dc_selected=6,taxa_selected=2038,stage_selected=c('AGJ','CIV'))
65		#' }
66		setMethod("charge_with_filter", signature = signature("ref_par"), definition = function(object,
67		dc_selected, taxa_selected, stage_selected) {
68	10x	requete = new("RequeteDBwhere")
69	10x	requete@select = paste("SELECT DISTINCT ON (par_code) par_code, par_nom, par_unite, par_nature, par_definition", " FROM ",
70	10x	get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
71	10x	" JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
72	10x	" JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
73	10x	" JOIN ", get_schema(), "tj_caracteristiquelot_car on car_lot_identifiant=lot_identifiant",
74	10x	" JOIN ref.tg_parametre_par on par_code=car_par_code", sep = "")
75	10x	requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected))
76	10x	requete@and = paste("and lot_tax_code in", vector_to_listsql(taxa_selected),
77	10x	" and lot_std_code in ", vector_to_listsql(stage_selected), sep = "")
78	10x	requete@order_by = "ORDER BY par_code"
79	10x	requete <- stacomirtools::query(requete)
80	10x	object@data <- requete@query
81	10x	if (nrow(object@data) == 0)
82	!	funout(gettext("No data for selected device, taxa and stage\n", domain = "R-stacomiR"),
83	!	arret = TRUE)
84	10x	return(object)
85		})
86
87
88		#' Command line interface to select a parameter
89		#'
90		#' @aliases choice_c.ref_par
91		#' @param object an object of class \link{ref_par-class}
92		#' @param par A character vector of par
93		#' @param silent Default FALSE but not used there
94		#' @return An object of class \link{ref_par-class}
95		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
96		setMethod("choice_c", signature = signature("ref_par"), definition = function(object,
97		par, silent = FALSE) {
98	19x	if (inherits(par , "numeric")) {
99	!	par <- as.character(par)
100		}
101	19x	if (any(is.na(par)))
102	!	stop("NA values par")
103	19x	object@par_selected <- par
104	19x	if (nrow(object@data) == 0) {
105	!	stop("Internal error : tried to set a value for par_selected without initializing the data slot")
106		}
107		# validObject(object,test=FALSE) here I don't want to generate an error if
108		# parm is not present so I'm not using the validObject which will throw and
109		# error
110	19x	concord <- object@par_selected %in% object@data$par_code
111
112	19x	if (any(!concord)) {
113	8x	warning(paste(gettextf("No data for par %s", object@par_selected[!concord],
114	8x	domain = "R-stacomiR")))
115		}
116		# to work with daughter class
117	19x	if (inherits(object, "ref_parquan")) {
118	8x	assign("ref_parquan", object, envir = envir_stacomi)
119	19x	} else if (inherits(object, "ref_parqual")){
120	1x	assign("ref_parqual", object, envir = envir_stacomi)
121		} else {
122	10x	assign("ref_par", object, envir = envir_stacomi)
123		}
124
125	19x	return(object)
126		})
127
128
129

1		#' Graph function for glass eel migration. Differs from fungraph as it does not
2		#' draw the ggplot graph for month
3		#'
4		#' This graph will also plot numbers and bars according to whether the glass
5		#' eel have been counted through weight or numbers
6		#'
7		#'
8		#' @param report_mig an object of class \link{report_mig-class} or an
9		#' object of class \link{report_mig_mult-class}
10		#' @param table a data frame with the results
11		#' @param time.sequence a vector POSIXt
12		#' @param taxa the species
13		#' @param stage the stage
14		#' @param dc the counting device, default to null, only necessary for \link{report_mig_mult-class}
15		#' @param silent Message displayed or not
16		#' @param color Default NULL, a vector of length 11 of color in the following order, numbers, weight, working, stopped, 1...5 types of operation,
17		#' the 2 latest colors are not used but kept for consistency with fungraph
18		#' for the fishway, if null will be set to brewer.pal(12,"Paired")[c(4,6,1,2,3,5,7,8,10,11,12)]
19		#' @param color_ope Default NULL, a vector of color for the operations. Default to brewer.pal(4,"Paired")
20		#' @param ... additional parameters passed to plot, main, ylab, cex.main, font.main, type, xlim, ylim, lty, bty, pch
21		#' it is not possible to change xlim
22		#' @return No return value, called for side effects
23		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
24		fungraph_glasseel = function(report_mig,
25		table,
26		time.sequence,
27		taxa,
28		stage,
29		dc = null,
30		silent,
31		color = NULL,
32		color_ope = NULL,
33		...) {
34	2x	oldpar <- par(no.readonly = TRUE)
35	2x	on.exit(par(oldpar))
36		# color=null
37		# color calculation
38	2x	if (is.null(color)) {
39	2x	tp <- RColorBrewer::brewer.pal(12, "Paired")
40	2x	mypalette = c(
41	2x	"working" = tp[4],
42		# green
43	2x	"stopped" = tp[6],
44		# red
45	2x	"Fonc normal" = tp[1],
46	2x	"Arr ponctuel" = tp[2],
47	2x	"Arr maintenance" = tp[3],
48	2x	"Dysfonc" = tp[5],
49	2x	"Non connu" = tp[7],
50	2x	"eff" = tp[8],
51		#orange
52	2x	"weight" = tp[10],
53		#purple
54	2x	"unused1" = tp[11],
55	2x	"unused1" = tp[12]
56		)
57		} else {
58	!	if (length(color) != 11)
59	!	stop("The length of color must be 11")
60	!	mypalette = c(
61	!	"working" = color[1],
62	!	"stopped" = color[2],
63	!	"Fonc normal" = color[3],
64	!	"Arr ponctuel" = color[4],
65	!	"Arr maintenance" = color[5],
66	!	"Dysfonc" = color[6],
67	!	"Non connu" = color[7],
68	!	"eff" = color[8],
69	!	"weight" = color[9],
70	!	"unused1" = color[10],
71	!	"unused2" = color[11]
72		)
73		}
74
75
76	2x	if (is.null(color_ope)) {
77	2x	if (stacomirtools::is.odd(dc))
78	2x	brew = "Paired"
79		else
80	2x	brew = "Accent"
81	2x	color_ope = RColorBrewer::brewer.pal(8, brew)
82		}
83
84	2x	if (is.null(dc))
85	2x	dc = report_mig@dc@dc_selected[1]
86	2x	annee = paste(unique(strftime(as.POSIXlt(time.sequence), "%Y")), collapse =
87		",")
88	2x	mois = months(time.sequence)
89	2x	jour = strftime(as.POSIXlt(time.sequence), "%j")
90	2x	index = table$No.pas + 1
91	2x	eff = table$Effectif_total
92	2x	eff.p = table$Effectif_total.p
93	2x	debut = unclass(as.Date(time.sequence[min(index)]))[[1]]
94	2x	fin = unclass(as.Date(time.sequence[max(index)]))[[1]]
95	2x	eff[eff == 0] <- NA #for graph need
96	2x	eff.p[eff.p == 0] <- NA
97	2x	dis_commentaire = as.character(report_mig@dc@data$dis_commentaires[report_mig@dc@data$dc %in%
98	2x	dc])
99	2x	if (!silent)
100	2x	funout(gettextf("Glass eels graph %s\n", dis_commentaire))
101		###################################
102		# Graph annuel couvrant sequence >0
103		####################################
104
105	2x	vec <- c(rep(1, 15), rep(2, 2), rep(3, 2), 4, rep(5, 6))
106	2x	mat <- matrix(vec, length(vec), 1)
107	2x	layout(mat)
108		#par("bg"=grDevices::gray(0.8))
109	2x	graphics::par("mar" = c(3, 4, 3, 2) + 0.1)
110	2x	dots <- list(...)
111	2x	if (!"main" %in% names(dots))
112	2x	main = gettextf("Glass eels graph %s, %s, %s, %s",
113	2x	dis_commentaire,
114	2x	taxa,
115	2x	stage,
116	2x	annee,
117	2x	domain = "R-stacomiR")
118		else
119	2x	main = dots[["main"]]
120	2x	if (!"ylab" %in% names(dots))
121	2x	ylab = gettext("Number of glass eels (x1000)", domain = "R-stacomiR")
122		else
123	2x	ylab = dots[["ylab"]]
124	2x	if (!"cex.main" %in% names(dots))
125	2x	cex.main = 1
126		else
127	2x	cex.main = dots[["cex.main"]]
128	2x	if (!"font.main" %in% names(dots))
129	2x	font.main = 1
130		else
131	2x	font.main = dots[["font.main"]]
132	2x	if (!"type" %in% names(dots))
133	2x	type = "h"
134		else
135	2x	type = dots[["type"]]
136	2x	if (!"xlim" %in% names(dots))
137	2x	xlim = c(debut, fin)
138		else
139	2x	xlim = dots[["xlim"]]
140	2x	if (!"ylim" %in% names(dots))
141	2x	ylim = c(0, max(eff / 1000, na.rm = TRUE)) * 1.2
142		else
143	2x	xlim = c(debut, fin)#dots[["xlim"]] # currently this argument is ignored
144	2x	if (!"cex" %in% names(dots))
145	2x	cex = 1
146		else
147	2x	cex = dots[["cex"]]
148	2x	if (!"lty" %in% names(dots))
149	2x	lty = 1
150		else
151	2x	lty = dots[["lty"]]
152	2x	if (!"pch" %in% names(dots))
153	2x	pch = 16
154		else
155	2x	pch = dots[["pch"]]
156	2x	if (!"bty" %in% names(dots))
157	2x	bty = "l"
158		else
159	2x	bty = dots[["bty"]]
160	2x	plot(
161	2x	x = as.Date(time.sequence, "Europe/Paris"),
162	2x	y = eff / 1000,
163	2x	col = mypalette["eff"],
164	2x	type = type,
165	2x	xlim = xlim,
166	2x	ylim = ylim,
167	2x	lty = lty,
168	2x	xaxt = "n",
169	2x	ylab = ylab,
170		#xlab="date",
171	2x	cex.main = cex.main,
172	2x	font.main = font.main,
173	2x	main = main,
174	2x	cex = cex,
175	2x	pch = pch,
176	2x	bty = bty
177		)
178		#print(plot,position = c(0, .3, 1, .9), more = TRUE)
179	2x	r <- as.Date(round(range(time.sequence), "day"))
180	2x	axis.Date(1, at = seq(r[1], r[2], by = "weeks"), format = "%d-%b")
181
182	2x	points(
183	2x	as.Date(time.sequence, "Europe/Paris"),
184	2x	eff.p / 1000,
185	2x	type = type,
186	2x	lty = lty,
187	2x	col = mypalette["weight"]
188		)
189
190	2x	legend(
191	2x	x = "topright",
192	2x	inset = 0.01,
193	2x	legend = gettext("weighted", "counted", domain = "R-stacomiR"),
194	2x	pch = c(16, 16),
195	2x	col = mypalette[c("weight", "eff")]
196		)
197		######################################
198		# text labels for numbers and weights
199		######################################
200	2x	text(
201	2x	x = debut + (fin - debut) / 8,
202	2x	y = max(eff / 1000, na.rm = TRUE) * 1.15,
203	2x	labels = paste(round(
204	2x	sum(table$poids_depuis_effectifs, na.rm = TRUE) / 1000, 2
205	2x	), " kg"),
206	2x	col = mypalette["eff"],
207	2x	adj = 1,
208	2x	cex = cex
209		)
210	2x	text(
211	2x	x = debut + 3 * (fin - debut) / 8 ,
212	2x	y = max(eff / 1000, na.rm = TRUE) * 1.15,
213	2x	labels = paste("N=", round(
214	2x	sum(table$Effectif_total.e, na.rm = TRUE)
215		)),
216	2x	col = mypalette["eff"],
217	2x	adj = 1,
218	2x	cex = cex
219		)
220	2x	text(
221	2x	x = debut + (fin - debut) / 8,
222	2x	y = max(eff / 1000, na.rm = TRUE) * 1.2,
223	2x	labels = paste(round(
224	2x	sum(table$Poids_total, na.rm = TRUE) / 1000, 2
225	2x	), " kg"),
226	2x	col = mypalette["weight"],
227	2x	adj = 1,
228	2x	cex = cex
229		)
230	2x	text(
231	2x	x = debut + 3 * (fin - debut) / 8,
232	2x	y = max(eff / 1000, na.rm = TRUE) * 1.2,
233	2x	labels = paste("N=", round(sum(eff.p, na.rm = TRUE))),
234	2x	col = mypalette["weight"],
235	2x	adj = 1,
236	2x	cex = cex
237		)
238	2x	text(
239	2x	x = debut + 3 + (fin - debut) / 8,
240	2x	y = max(eff / 1000, na.rm = TRUE) * 1.1,
241	2x	labels = paste(round(
242	2x	sum(table$Poids_total, table$poids_depuis_effectifs, na.rm = TRUE) / 1000,
243	2x	2
244	2x	), " kg"),
245	2x	col = "black",
246	2x	adj = 1,
247	2x	cex = cex
248		)
249	2x	text(
250	2x	x = debut + 3 * (fin - debut) / 8,
251	2x	y = max(eff / 1000, na.rm = TRUE) * 1.1,
252	2x	labels = paste("N=", round(sum(eff, na.rm = TRUE))),
253	2x	col = "black",
254	2x	adj = 1,
255	2x	cex = cex
256		)
257	2x	segments(
258	2x	x0 = debut,
259	2x	y0 = max(eff / 1000, na.rm = TRUE) * 1.125,
260	2x	x1 = debut + 3 * (fin - debut) / 8,
261	2x	y1 = max(eff / 1000, na.rm = TRUE) * 1.125
262		)
263
264
265	2x	report_ope <- get("report_ope", envir = envir_stacomi)
266	2x	t_operation_ope <-
267	2x	report_ope@data[report_ope@data$ope_dic_identifiant == dc, ]
268	2x	dif = difftime(t_operation_ope$ope_date_fin,
269	2x	t_operation_ope$ope_date_debut,
270	2x	units = "days")
271
272	2x	if (!silent) {
273	!	funout(gettextf(
274	!	"number of operations =%s\n",
275	!	nrow(t_operation_ope),
276	!	domain = "R-stacomiR"
277		))
278	!	funout(gettextf("average trapping time = %sdays\n", round(mean(
279	!	as.numeric(dif)
280	!	), 2), domain = "R-stacomiR"))
281	!	funout(gettextf("maximum term = %sdays\n", round(max(
282	!	as.numeric(dif)
283	!	), 2), domain = "R-stacomiR"))
284	!	funout(gettextf("minimum term = %sdays\n", round(min(
285	!	as.numeric(dif)
286	!	), 2), domain = "R-stacomiR"))
287		}
288
289	2x	df <- report_mig@dc@data$df[report_mig@dc@data$dc == dc]
290	2x	report_df <- get("report_df", envir = envir_stacomi)
291	2x	report_dc <- get("report_dc", envir = envir_stacomi)
292	2x	report_df@data <-
293	2x	report_df@data[report_df@data$per_dis_identifiant == df, ]
294	2x	report_dc@data <-
295	2x	report_dc@data[report_dc@data$per_dis_identifiant == dc, ]
296
297
298	2x	graphdate <- function(vectordate) {
299	40x	attributes(vectordate) <- NULL
300	40x	unclass(vectordate)
301		}
302
303
304		###################################
305		# creation d'un graphique vide (2)
306		###################################
307
308	2x	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
309	2x	plot(
310	2x	as.Date(time.sequence),
311	2x	seq(0, 3, length.out = length(eff)),
312	2x	xlim = xlim,
313	2x	type = "n",
314	2x	xlab = "",
315	2x	xaxt = "n",
316	2x	yaxt = "n",
317	2x	ylab = gettext("Fishway", domain = "R-stacomiR"),
318	2x	bty = "n",
319	2x	cex = cex + 0.2
320		)
321
322		###################################
323		# Time for dc operation
324		###################################
325
326	2x	if (dim(report_df@data)[1] == 0) {
327	!	rect(
328	!	xleft = debut,
329	!	ybottom = 2.1,
330	!	xright = fin,
331	!	ytop = 3,
332	!	col = "grey",
333	!	border = NA,
334	!	lwd = 1
335		)
336	!	rect(
337	!	xleft = debut,
338	!	ybottom = 1.1,
339	!	xright = fin,
340	!	ytop = 2,
341	!	col = "grey40",
342	!	border = NA,
343	!	lwd = 1
344		)
345	!	legend(
346	!	x = "bottom",
347	!	legend = gettext("Unknown working", "Unknow operation type", domain =
348	!	"R-stacomiR"),
349	!	pch = c(16, 16),
350	!	col = c("grey", "grey40"),
351	!	horiz = TRUE,
352	!	bty = "n"
353		)
354
355
356		} else {
357		# si il sort quelque chose
358	2x	if (sum(report_df@data$per_etat_fonctionnement == 1) > 0) {
359	2x	rect(
360	2x	xleft = graphdate(as.Date(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
361	2x	1])),
362	2x	ybottom = 2.1,
363	2x	xright = graphdate(as.Date(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
364	2x	1])),
365	2x	ytop = 3,
366	2x	col = mypalette["working"],
367	2x	border = NA,
368	2x	lwd = 1
369		)
370		}
371	2x	if (sum(report_df@data$per_etat_fonctionnement == 0) > 0) {
372	2x	rect(
373	2x	xleft = graphdate(as.Date(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
374	2x	0])),
375	2x	ybottom = 2.1,
376	2x	xright = graphdate(as.Date(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
377	2x	0])),
378	2x	ytop = 3,
379	2x	col = mypalette["stopped"],
380	2x	border = NA,
381	2x	lwd = 1
382		)
383		}
384		#creation d'une liste par categorie d'arret contenant vecteurs dates
385	2x	listeperiode <-
386	2x	fun_table_per_dis(
387	2x	typeperiode = report_df@data$per_tar_code,
388	2x	tempsdebut = report_df@data$per_date_debut,
389	2x	tempsfin = report_df@data$per_date_fin,
390	2x	libelle = report_df@data$libelle,
391	2x	color= mypalette[report_df@data$libelle]
392		)
393	2x	nomperiode <- vector()
394	2x	color_periodes <- vector()
395	2x	for (j in 1:length(listeperiode)) {
396	5x	nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
397		#ecriture pour chaque type de periode
398	5x	color_periode = listeperiode[[j]]$color
399	5x	rect(
400	5x	xleft = graphdate(listeperiode[[j]]$debut),
401	5x	ybottom = 1.1,
402	5x	xright = graphdate(listeperiode[[j]]$fin),
403	5x	ytop = 2,
404	5x	col = color_periode,
405	5x	border = NA,
406	5x	lwd = 1
407		)
408	5x	color_periodes <- c(color_periodes, color_periode)
409		}
410		# below the colors for operation are from 4 to 3+ntypeoperation
411	2x	legend (
412	2x	x = debut,
413	2x	y = 1.2,
414	2x	legend = gettext("working", "stopped", nomperiode, domain = "R-stacomiR"),
415	2x	pch = c(15, 15),
416	2x	col = c(mypalette["working"], mypalette["stopped"], color_periodes),
417	2x	bty = "n",
418	2x	ncol = length(listeperiode) + 2,
419	2x	text.width = (fin - debut) / 10
420		)
421		}
422
423		###################################
424		# creation d'un graphique vide (3=DC)
425		###################################
426
427
428	2x	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
429	2x	plot(
430	2x	as.Date(time.sequence),
431	2x	seq(0, 3, length.out = length(eff)),
432	2x	xlim = xlim,
433	2x	type = "n",
434	2x	xlab = "",
435	2x	xaxt = "n",
436	2x	yaxt = "n",
437	2x	ylab = gettext("CD", domain = "R-stacomiR"),
438	2x	bty = "n",
439	2x	cex = cex + 0.2
440		)
441		###################################
442		# time for DC (counting device) operation
443		###################################
444
445
446	2x	if (dim(report_dc@data)[1] == 0) {
447	!	rect(
448	!	xleft = debut,
449	!	ybottom = 2.1,
450	!	xright = fin,
451	!	ytop = 3,
452	!	col = "grey",
453	!	border = NA,
454	!	lwd = 1
455		)
456
457	!	rect(
458	!	xleft = debut,
459	!	ybottom = 1.1,
460	!	xright = fin,
461	!	ytop = 2,
462	!	col = "grey40",
463	!	border = NA,
464	!	lwd = 1
465		)
466	!	legend(
467	!	x = "bottom",
468	!	legend = gettext("Unknown working", "Unknow operation type", domain =
469	!	"R-stacomiR"),
470	!	pch = c(16, 16),
471	!	col = c("grey", "grey40"),
472	!	horiz = TRUE,
473		#ncol=5,
474	!	bty = "n"
475		)
476
477
478		} else {
479	2x	if (sum(report_dc@data$per_etat_fonctionnement == 1) > 0) {
480	2x	rect(
481	2x	xleft = graphdate(as.Date(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
482	2x	1])),
483	2x	ybottom = 2.1,
484	2x	xright = graphdate(as.Date(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
485	2x	1])),
486	2x	ytop = 3,
487	2x	col = mypalette["working"],
488	2x	border = NA,
489	2x	lwd = 1
490		)
491		}
492	2x	if (sum(report_dc@data$per_etat_fonctionnement == 0) > 0)
493		{
494	2x	rect(
495	2x	xleft = graphdate(as.Date(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
496	2x	0])),
497	2x	ybottom = 2.1,
498	2x	xright = graphdate(as.Date(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
499	2x	0])),
500	2x	ytop = 3,
501	2x	col = mypalette["stopped"],
502	2x	border = NA,
503	2x	lwd = 1
504		)
505		}
506	2x	listeperiode <-
507	2x	fun_table_per_dis(
508	2x	typeperiode = report_dc@data$per_tar_code,
509	2x	tempsdebut = report_dc@data$per_date_debut,
510	2x	tempsfin = report_dc@data$per_date_fin,
511	2x	libelle = report_dc@data$libelle,
512	2x	color= mypalette[report_df@data$libelle]
513		)
514	2x	nomperiode <- vector()
515	2x	color_periodes <- vector()
516	2x	for (j in 1:length(listeperiode)) {
517	5x	nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
518	5x	color_periode = listeperiode[[j]]$color
519	5x	rect(
520	5x	xleft = graphdate(listeperiode[[j]]$debut),
521	5x	ybottom = 1.1,
522	5x	xright = graphdate(listeperiode[[j]]$fin),
523	5x	ytop = 2,
524	5x	col = color_periode,
525	5x	border = NA,
526	5x	lwd = 1
527		)
528	5x	color_periodes <- c(color_periodes, color_periode)
529		}
530
531	2x	legend (
532	2x	x = debut,
533	2x	y = 1.2,
534	2x	legend = gettext("working", "stopped", nomperiode, domain = "R-stacomiR"),
535	2x	pch = c(15, 15),
536	2x	col = c(mypalette["working"], mypalette["stopped"], color_periodes),
537	2x	bty = "n",
538	2x	ncol = length(listeperiode) + 2,
539	2x	text.width = (fin - debut) / 10
540		)
541		}
542
543		###################################
544		# creation d'un graphique vide (4=OP)
545		###################################
546
547
548	2x	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
549	2x	plot(
550	2x	as.Date(time.sequence),
551	2x	seq(0, 1, length.out = length(eff)),
552	2x	xlim = xlim,
553	2x	type = "n",
554	2x	xlab = "",
555	2x	xaxt = "n",
556	2x	yaxt = "n",
557	2x	ylab = gettext("Op", domain = "R-stacomiR"),
558	2x	bty = "n",
559	2x	cex = cex + 0.2
560		)
561		###################################
562		# operations
563		###################################
564	2x	rect(
565	2x	xleft = graphdate(as.Date(t_operation_ope$ope_date_debut)),
566	2x	ybottom = 0,
567	2x	xright = graphdate(as.Date(t_operation_ope$ope_date_fin)),
568	2x	ytop = 1,
569	2x	col = color_ope,
570	2x	border = NA,
571	2x	lwd = 1
572		)
573
574
575		###################################
576		# Graph mensuel
577		####################################
578	2x	graphics::par("mar" = c(4, 4, 1, 2) + 0.1)
579	2x	petitmois = substr(as.character(mois), 1, 3)
580	2x	effmois = tapply(eff, mois, sum, na.rm = TRUE)[c(5, 4, 9, 2, 8, 7, 6, 1, 12, 11, 10, 3)]
581	2x	effmois.p = tapply(eff.p, mois, sum, na.rm = TRUE)[c(5, 4, 9, 2, 8, 7, 6, 1, 12, 11, 10, 3)]
582	2x	effmois <- data.frame("eff" = effmois)
583	2x	effmois.p <- data.frame("eff" = effmois.p)
584	2x	tablemens <-
585	2x	rbind(
586	2x	cbind(
587	2x	"eff" = effmois - effmois.p,
588	2x	"type" = 2,
589	2x	"mois" = 1:12
590		),
591	2x	cbind(effmois.p, "type" = "1", "mois" = 1:12)
592		)
593
594
595	2x	superpose.polygon <- lattice::trellis.par.get("superpose.polygon")
596	2x	superpose.polygon$col = mypalette[c("weight", "eff")]
597	2x	superpose.polygon$border = rep("transparent", 6)
598	2x	lattice::trellis.par.set("superpose.polygon", superpose.polygon)
599	2x	fontsize <- lattice::trellis.par.get("fontsize")
600	2x	fontsize$text = 10
601	2x	lattice::trellis.par.set("fontsize", fontsize)
602	2x	par.main.text <- lattice::trellis.par.get("par.main.text")
603	2x	par.main.text$cex = cex
604	2x	par.main.text$font = 1
605	2x	lattice::trellis.par.set("par.main.text", par.main.text)
606
607
608	2x	par.ylab.text <- lattice::trellis.par.get("par.ylab.text")
609	2x	par.ylab.text$cex = cex - 0.2
610	2x	lattice::trellis.par.set("par.ylab.text", par.ylab.text)
611	2x	par.xlab.text <- lattice::trellis.par.get("par.xlab.text")
612	2x	par.xlab.text$cex = cex - 0.2
613	2x	lattice::trellis.par.set("par.xlab.text", par.xlab.text)
614
615
616	2x	bar <- lattice::barchart(
617	2x	eff / 1000 ~ as.factor(mois),
618	2x	groups = as.factor(type),
619	2x	xlab = gettext("Month", domain = "R-stacomiR"),
620	2x	ylab = gettext("Number (x1000)", domain = "R-stacomiR"),
621		# main=list(label=paste("Donnees mensuelles")),
622	2x	data = tablemens,
623	2x	allow.multiple = FALSE,
624		# key=lattice::simpleKey(text=c(gettext("weight of monthly number"),gettext("monthly number counted",domain="R-stacomiR")),
625		# rectangles = TRUE,
626		# points=FALSE,
627		# space="right",
628		# cex=0.8),
629	2x	strip = FALSE,
630	2x	stack = TRUE
631		)
632	2x	print(bar, position = c(0, 0, 1, .25), newpage = FALSE)
633	2x	return(invisible(NULL))
634		}

1		#'
2		#'
3		#' Internal function, tests the connection and if it works loads the stacomi interface
4		#' @note \code{base} is copied by stacomi into envir_stacomi. Same for \code{database_expected}
5		#'
6		#' @param ... Other arguments
7		#' @return Nothing
8		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
9		#' @keywords internal
10		load_stacomi <- function(...) {
11
12		# assigned when passing through stacomi
13	110x	database_expected <- get("database_expected", envir_stacomi) # logical true or false
14
15	110x	if (database_expected) {
16	80x	sch <- get_schema()
17	80x	dbname <- options("stacomiR.dbname")[[1]]
18	80x	host <- options("stacomiR.host")[[1]]
19	80x	port <- options("stacomiR.port")[[1]]
20	80x	user <- options("stacomiR.user")[[1]]
21	80x	password <- options("stacomiR.password")[[1]]
22	80x	if (user=="") {
23		# this is the default options at start
24		# if interactive will try to set the options upon loading
25	!	if (interactive()){
26	!	user <- readline(prompt="Enter user: ")
27	!	options("stacomiR.user"=user)
28	!	password <- readline(prompt="Enter password: ")
29	!	options("stacomiR.password"=password)
30		} else {
31	!	user <- "postgres"
32	!	password <- "postgres"
33	!	warning('no user set by default, reverted to user <- "postgres" and password <- "postgres",
34	!	you can change it with options("stacomiR.user"=user) and options("stacomiR.password"=password)')
35		}
36		}
37
38
39	80x	con = new("ConnectionDB")
40	80x	e = expression(con <- connect(con))
41	80x	con = tryCatch(eval(e), error = function(e) e)
42	80x	if ("Rcpp::exception"%in%class(con)){
43	!	cat(con$message)
44	!	test <- FALSE
45		} else {
46	80x	test <- TRUE
47	80x	pool::poolClose(con@connection)
48		}
49
50
51
52		# second test to check that the database is working OK
53
54	80x	if (test) {
55	80x	requete = new("RequeteDB")
56	80x	requete@sql = paste0("select count(*) from ", sch, "t_lot_lot")
57	80x	requete <- stacomirtools::query(requete)
58	80x	if (nrow(requete@query) == 0) {
59		# the database link is not working or the
60		# schema
61	!	funout(paste(gettext("Problem during the test, connection to the database is established but failed to connect to the right schema argument passed to stacomi",
62	!	domain = "R-stacomiR"), "\n",
63	!	gettext("dbname", domain = "R-stacomiR")," :", dbname, "\n",
64	!	gettext("User", domain = "R-stacomiR"), " :", user, "\n",
65	!	gettext("Port", domain = "R-stacomiR"), " :", port, "\n",
66	!	gettext("Host", domain = "R-stacomiR"), " :", host, "\n",
67	!	gettext("Password", domain = "R-stacomiR"), " :", password),
68	!	gettext("schema", domain = "R-stacomiR"), " :", sch)
69		}
70
71		} else {
72		# the test has failed and the user will be prompted to another
73	!	funout(paste(gettext("Problem when testing the DB connection", domain = "R-stacomiR"),
74	!	gettext("dbname", domain = "R-stacomiR")," :", dbname, "\n",
75	!	gettext("User", domain = "R-stacomiR"), " :", user, "\n",
76	!	gettext("Port", domain = "R-stacomiR"), " :", port, "\n",
77	!	gettext("Host", domain = "R-stacomiR"), " :", host, "\n",
78	!	gettext("Password", domain = "R-stacomiR"), " :", password))
79	80x	} # end else test (else == the test didn't pass, we have to change the name and password
80		} else {
81		# here : database_expected=FALSE we don't want to check the connection
82		# at all...
83		}
84		}
85
86
87
88
89
90
91		#' stacomi Main launcher for program stacomi
92		#'
93		#' When \code{database_expected=FALSE} a connection to the database is not expected. Therefore test are run by calling examples object stored in Rdata.
94		#' To change the language use Sys.setenv(LANG = 'fr') or Sys.setenv(LANG = 'en')
95		#' @param database_expected Boolean, if \code{TRUE} pre launch tests will be run to test the connection validity
96		#' @param datawd The data working directory
97		#' @param sch The schema in the stacomi database default 'iav.'
98		#' @return Nothing, called for its side effect of loading
99		#' @usage stacomi(database_expected=TRUE, datawd = "~", sch = "iav")
100		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
101		#' @examples
102		#'
103		#' require(stacomiR)
104		#' #launch stacomi
105		#' \dontrun{
106		#' stacomi(database_expected=TRUE, datawd='~',sch= "iav")
107		#' }
108		#' # launch stacomi without connection to the database
109		#' stacomi(database_expected=FALSE)
110		#' # launch stacomi with options
111		#' options(
112		#' stacomiR.dbname = "bd_contmig_nat",
113		#' stacomiR.host = readline(prompt = "Enter host: "),
114		#' stacomiR.port = "5432",
115		#' stacomiR.user = readline(prompt = "Enter user: "),
116		#' stacomiR.password = readline(prompt = "Enter password: ")
117		#')
118		#' @export
119		stacomi = function(database_expected = TRUE, datawd = "~", sch = "iav") {
120	110x	assign("database_expected", database_expected, envir = envir_stacomi)
121		# values assigned in the envir_stacomi
122	110x	assign("datawd", datawd, envir = envir_stacomi)
123	110x	assign("sch", paste(sch, ".", sep = ""), envir = envir_stacomi)
124	110x	load_stacomi()
125	110x	invisible(NULL)
126		}
127
128
129
130
131
132
133		#' Working environment for stacomiR created when launching stacomi()
134		#'
135		#' This is where the graphical interface stores its objects
136		#' try \code{ls(envir=envir_stacomi)}
137		#' @keywords environment
138		#' @export
139		envir_stacomi <- new.env(parent = asNamespace("stacomiR"))
140		# calcmig<-data.frame()

1		#' Class "report_mig_env"
2		#'
3		#' Enables to compute an annual overview of fish migration and environmental
4		#' conditions in the same chart. Environmental conditions may trigger migration events, variation in flow
5		#' or temperatures can be plotted along migration to check graphically for a possible relation. To enable this,
6		#' environmental conditions are loaded from an "environmental monitoring station", which records environmental
7		#' parameters and is attached to a migratory station in the database.
8		#' This class enables both continuous output (temperature -flow) as well as discrete parameters (qualitative = moon
9		#' phase, type of operation of a gate, opening of a gate...) which will be displayed on the graph. Values are scaled so that
10		#' single plot can display migration numbers and environmental parameters. Environmental parameters when stored at a
11		#' time scale lower that a day are averaged per day, unless they are qualitative parameters, in which case only the first
12		#' event of the day is displayed on the annual plot.
13		#'
14		#' @include report_mig_mult.R
15		#' @include report_env.R
16		#' @include create_generic.R
17		#' @include utilities.R
18		#' @slot report_mig_mult \link{report_mig_mult-class}
19		#' @slot report_env \link{report_env-class}
20		#' @author cedric.briand@eptb-vilaine.fr marion.legrand@logrami.fr
21		#' @family report Objects
22		#' @keywords classes
23		#' @aliases report_mig_env
24		#' @keywords classes
25		#' @example inst/examples/report_mig_env-example.R
26		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
27		#' @family report Objects
28		#' @keywords classes
29		#' @export
30		setClass(
31		Class = "report_mig_env",
32		representation =
33		representation(report_mig_mult = "report_mig_mult",
34		report_env = "report_env"),
35		prototype = prototype(
36		report_mig_mult = new("report_mig_mult"),
37		report_env = new("report_env")
38
39		)
40		)
41
42
43		setValidity("report_mig_env",
44		function(object)
45		{
46		rep1 = validObject(object@report_mig_mult, test = TRUE)
47		rep2 = validObject(object@report_env, test = TRUE)
48		return(ifelse(rep1 & rep2 , TRUE, c(1:2)[!c(rep1, rep2)]))
49		})
50		#' connect method for report_mig_env class
51		#' @param object An object of class \link{report_mig_env-class}
52		#' @param silent Default FALSE, if TRUE the program should no display messages
53		#' @return an object of report_mig_env class
54		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
55		#' @aliases summary.report_mig_env
56		setMethod(
57		"connect",
58		signature = signature("report_mig_env"),
59		definition = function(object, silent = FALSE) {
60		#object<-r_mig_env
61	2x	r_mig_env <- object
62	2x	r_mig_env@report_mig_mult <-
63	2x	connect(r_mig_env@report_mig_mult, silent = silent)
64	2x	r_mig_env@report_env <- connect(r_mig_env@report_env, silent = silent)
65	2x	return(r_mig_env)
66		}
67		)
68		#' command line interface for report_env class
69		#'
70		#' @param object An object of class \link{report_env-class}
71		#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
72		#' @param taxa '2038=Anguilla anguilla',
73		#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
74		#' @param stage 'AGJ=Yellow eel', 'AGG=Silver eel', 'CIV=glass eel'
75		#' @param stationMesure A character, the code of the monitoring station, which records environmental parameters \link{choice_c,ref_env-method}
76		#' @param datedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
77		#' @param datefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
78		#' @param silent Boolean default FALSE, if TRUE information messages not displayed.
79		#' @aliases choice_c.report_mig_env
80		#' @return An object of class \link{report_env-class} with data selected
81		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
82		setMethod(
83		"choice_c",
84		signature = signature("report_mig_env"),
85		definition = function(object,
86		dc,
87		taxa,
88		stage,
89		stationMesure,
90		datedebut,
91		datefin,
92		silent = FALSE) {
93		# code for debug
94		# dc=c(5,6,12); taxa=c("Anguilla anguilla");stage=c("AGJ","AGG","CIV");
95		# stationMesure=c("temp_gabion","coef_maree");
96		# datedebut="2008-01-01";datefin="2008-12-31";silent=FALSE
97	2x	r_mig_env <- object
98	2x	r_mig_env@report_mig_mult =
99	2x	choice_c(
100	2x	r_mig_env@report_mig_mult,
101	2x	dc = dc,
102	2x	taxa = taxa,
103	2x	stage = stage,
104	2x	datedebut = datedebut,
105	2x	datefin = datefin,
106	2x	silent = silent
107		)
108	2x	r_mig_env@report_env = choice_c(
109	2x	r_mig_env@report_env,
110	2x	stationMesure = stationMesure,
111	2x	datedebut = datedebut,
112	2x	datefin = datefin,
113	2x	silent = silent
114		)
115	2x	return(r_mig_env)
116		}
117		)
118		#' charge method for report_mig_env class
119		#'
120		#' #' Unique the other report classes where the charge method is only used by the graphical interface
121		#' to collect and test objects in the environment envir_stacomi, and see if the right choices have
122		#' been made in the graphical interface, this methods runs the \link{charge,report_mig_mult-method}
123		#' and needs to be called from the command line (see examples)
124		#' @param object An object of class \link{report_mig_env-class}
125		#' @param silent Should the function remain silent (boolean)
126		#' @return An object of class \link{report_mig_env-class} with data set from values assigned in \code{envir_stacomi} environment
127		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
128		#' @aliases charge.report_mig_env
129		setMethod(
130		"charge",
131		signature = signature("report_mig_env"),
132		definition = function(object, silent = FALSE) {
133		# silent=FALSE
134	2x	r_mig_env <- object
135	2x	r_mig_env@report_mig_mult <-
136	2x	charge(r_mig_env@report_mig_mult, silent = silent)
137		# the values for date are not initiated by the interface
138	2x	assign(
139	2x	"report_env_date_debut",
140	2x	get("timestep", envir_stacomi)@"dateDebut",
141	2x	envir_stacomi
142		)
143	2x	assign("report_env_date_fin",
144	2x	as.POSIXlt(end_date(get(
145	2x	"timestep", envir_stacomi
146		))),
147	2x	envir_stacomi)
148	2x	r_mig_env@report_env <-
149	2x	charge(r_mig_env@report_env, silent = silent)
150	2x	return(r_mig_env)
151		}
152		)
153
154		#' Calculations for migration in the class \link{report_mig_env-class}
155		#'
156		#' Runs the calcule method in \link{report_mig_mult-class}
157		#' @param object An object of class \link{report_mig_env-class}
158		#' @param silent Boolean default FALSE, if TRUE information messages not displayed
159		#' @aliases calcule.report_mig_env
160		#' @return \link{report_mig_env-class} with data in slot r_mig_env@report_mig_mult@calcdata
161		setMethod(
162		"calcule",
163		signature = signature("report_mig_env"),
164		definition = function(object, silent = FALSE) {
165		# silent=FALSE
166	1x	r_mig_env <- object
167	1x	r_mig_env@report_mig_mult <-
168	1x	calcule(r_mig_env@report_mig_mult, silent = silent)
169	1x	if (!silent)
170	1x	funout(
171	1x	gettext(
172	1x	"r_mig_env object is stocked into envir_stacomi environment\n",
173	1x	domain = "R-stacomiR"
174		)
175		)
176	1x	return(r_mig_env)
177		}
178		)
179
180
181		#' Plot method for report_mig_env
182		#' @param x An object of class \link{report_mig_env}
183		#' @param silent Stops displaying the messages.
184		#' @param color_station A named vector of station color (e.g. c("temp_gabion"="red","coef_maree"="blue","phases_lune"="green")) default null
185		#' @param color_dc A named vector giving the color for each dc default null (e.g. c("5"="#4D4D4D","6"="#E6E6E6","12"="#AEAEAE"))
186		#' @return Nothing, called for its side effect of plotting
187		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
188		#' @aliases plot.report_mig_env
189		#' @export
190		setMethod(
191		"plot",
192		signature(x = "report_mig_env", y = "missing"),
193		definition = function(x,
194		color_station = NULL,
195		color_dc = NULL,
196		silent = FALSE) {
197		#color_station=NULL;color_dc=NULL
198		# color_station<-c("temp_gabion"="red","coef_maree"="blue","phases_lune"="green")
199		# color_dc=c("5"="#4D4D4D","6"="#E6E6E6","12"="#AEAEAE")
200	3x	r_mig_env <- x
201
202
203	3x	grdata <- fun_aggreg_for_plot(r_mig_env@report_mig_mult)
204		# we collect the dataset used to build the graph
205
206	3x	taxa = as.character(r_mig_env@report_mig_mult@taxa@data[
207	3x	r_mig_env@report_mig_mult@taxa@data$tax_code %in%
208	3x	r_mig_env@report_mig_mult@taxa@taxa_selected, "tax_nom_latin"]
209		)
210	3x	stage = as.character(r_mig_env@report_mig_mult@stage@data[
211	3x	r_mig_env@report_mig_mult@stage@data$std_code%in%
212	3x	r_mig_env@report_mig_mult@stage@stage_selected,"std_libelle"]
213		)
214	3x	dc <- unique(grdata$DC)
215	3x	stations <- r_mig_env@report_env@stationMesure@data
216	3x	dc_code <- r_mig_env@report_mig_mult@dc@data$dc_code[match(dc, r_mig_env@report_mig_mult@dc@data$dc)]
217		# tableau conditions environnementales
218	3x	tableauCE <- r_mig_env@report_env@data
219	3x	if (nrow(tableauCE) == 0) {
220	!	funout(
221	!	gettext(
222	!	"You don't have any environmental conditions within the time period\n",
223	!	domain = "R-stacomiR"
224		),
225	!	arret = TRUE
226		)
227		}
228
229		# we collect libelle and source of data from station
230	3x	source <- unlist(lapply(regmatches(stations$stm_description,gregexpr("(?<=:([[:space:]])).*", stations$stm_description, perl =TRUE),invert=NA),
231	3x	function(X) X[2]))
232	3x	if (any(is.na(source))) {
233	2x	missing <- stations[is.na(source),"stm_libelle"]
234	2x	missing_and_selected <- missing[missing%in%r_mig_env@report_env@stationMesure@env_selected]
235	2x	missing_and_selected <- paste(missing_and_selected, collapse=" , ")
236	2x	warning(sprintf("the source of data is not present in column stm_description of table tj_stationmesure_stm for stations: %s. \n Please consider adding it by adding something like source: Banque hydro at the end of the line in table tj_stationmesure_stm column stm_description",
237	2x	missing_and_selected))
238	2x	source[is.na(source)] <- "Not defined"
239		}
240
241	3x	stations$source <- source
242	3x	tableauCE <- merge(tableauCE,stations, by.x="env_stm_identifiant", by.y="stm_identifiant")
243		# (?<= ) lookbehind, get the string : with a space after but not capture it. .* capture anything after
244		# currently we've added the source of data within the stm_description string so as not to change the db
245		# regmatches, invert = NA returns a list with first elt matching and second non mathing
246		# we want the full list returned with NA when missing match
247
248
249
250
251		# the data can be in the POSIXct format, we need to round them
252	3x	tableauCE$date <-
253	3x	as.POSIXct(Hmisc::roundPOSIXt(tableauCE$env_date_debut, digits = "days"))
254	3x	qualitative <- !is.na(tableauCE$env_val_identifiant)
255	3x	tableauCEquan <- tableauCE[!qualitative, ]
256	3x	tableauCEqual <- tableauCE[qualitative, ]
257	3x	if (nrow(unique(cbind(tableauCE$date, tableauCE$stm_libelle))) != nrow(tableauCE)) {
258		# do not cut character chain below...
259	!	funout(
260	!	gettextf(
261	!	"Attention, on one station :%s there are several entries for the same day :%s we will calculate average for numeric and use the first value for qualitative parameter",
262	!	sta,
263	!	paste(unique(tableauCEst$env_date_debut[duplicated(tableauCEst$env_date_debut)]), sep =
264		"")
265		),
266	!	arret = FALSE
267		)
268		# for quantitative parameters we group by date and station and use the average to
269		# extract one value per day
270	!	tableauCEquan <-
271	!	dplyr::select(tableauCEquan, date, stm_libelle, env_valeur_quantitatif) %>%
272	!	dplyr::group_by(date, stm_libelle) %>%
273	!	dplyr::summarize(valeur = mean(env_valeur_quantitatif)) %>%
274	!	dplyr::ungroup()
275		# for qualitative value, when there are several values for the same date
276		# we arbitrarily select the first
277	!	tableauCEqual <-
278	!	dplyr::select(tableauCEqual, date, stm_libelle, env_val_identifiant) %>%
279	!	dplyr::group_by(date, stm_libelle) %>%
280	!	dplyr::summarize(valeur = first(env_val_identifiant)) %>%
281	!	dplyr::ungroup()
282		} else {
283		# we want the same format as above
284	3x	tableauCEquan <-
285	3x	dplyr::select(tableauCEquan, date, stm_libelle, env_valeur_quantitatif) %>%
286	3x	dplyr::rename(valeur = env_valeur_quantitatif)
287	3x	tableauCEqual <-
288	3x	dplyr::select(tableauCEqual, date, stm_libelle, env_val_identifiant) %>%
289	3x	dplyr::rename(valeur = env_val_identifiant)
290		}
291	3x	variables_quant <- unique(tableauCEquan$stm_libelle)
292	3x	variables_qual <- unique(tableauCEqual$stm_libelle)
293	3x	grdata <- fun_date_extraction(
294	3x	grdata,
295	3x	nom_coldt = "debut_pas",
296	3x	annee = FALSE,
297	3x	mois = TRUE,
298	3x	quinzaine = TRUE,
299	3x	semaine = TRUE,
300	3x	jour_an = TRUE,
301	3x	jour_mois = FALSE,
302	3x	heure = FALSE
303		)
304
305		# to rescale everything on the same graph
306	3x	maxeff = floor(log10(max(grdata$effectif_total, na.rm = TRUE)))
307
308	3x	for (i in 1:length(variables_quant)) {
309	6x	diff = maxeff - round(log10(max(tableauCEquan[tableauCEquan$stm_libelle ==
310	6x	variables_quant[i], "valeur"], na.rm = TRUE)))
311	6x	if (diff != 0 & !is.na(diff)) {
312	6x	tableauCEquan[tableauCEquan$stm_libelle == variables_quant[i], "valeur"] = as.numeric(tableauCEquan[tableauCEquan$stm_libelle ==
313	6x	variables_quant[i], "valeur"]) * 10 ^ diff
314	6x	variables_quant[i] = paste(variables_quant[i], ".10^", diff, sep = "")
315	6x	} # end if
316	3x	} #end for
317	3x	yqualitatif = (10 ^ (maxeff)) / 2
318
319	3x	ylegend = gettextf(
320	3x	"Number, %s, %s",
321	3x	paste(variables_quant, collapse = ", "),
322	3x	paste(variables_qual, collapse = ", ")
323		)
324
325
326		######################
327		# treatment of data to group by dc
328		# if several taxa or stages are passed, they are aggregated with a warning
329		#################################
330	3x	if (length(unique(taxa)) > 1)
331	3x	warning(gettextf(
332	3x	"you have %s taxa in the report, those will be aggregated",
333	3x	length(unique(taxa))
334		))
335	3x	if (length(unique(stage)) > 1)
336	3x	warning(gettextf(
337	3x	"you have %s stages in the report, those will be aggregated",
338	3x	length(unique(stage))
339		))
340	3x	plotdata <-
341	3x	dplyr::select(grdata, debut_pas, DC, effectif_total) %>% dplyr::rename(date =
342	3x	debut_pas) %>%
343	3x	dplyr::group_by(date, DC) %>% dplyr::summarize(effectif = sum(effectif_total)) %>%
344	3x	dplyr::ungroup()
345
346		#######################
347		# color scheme for station
348		#######################
349
350	3x	cs <-
351	3x	colortable(color = color_station,
352	3x	vec = unique(tableauCE$stm_libelle),
353	3x	palette = "Accent")
354	3x	cs <- stacomirtools::chnames(cs, "name", "stm_libelle")
355		#######################
356		# color scheme for dc
357		#######################
358	3x	cdc <-
359	3x	colortable(color = color_dc,
360	3x	vec = dc,
361	3x	color_function = "gray.colors")
362	3x	cdc <- stacomirtools::chnames(cdc, "name", "DC")
363		#######################
364		# merging with colors for manual scales
365		######################
366	3x	plotdata <- killfactor(merge(plotdata, cdc, by = "DC"))
367	3x	tableauCEquan <-
368	3x	killfactor(merge(tableauCEquan, cs, by = "stm_libelle"))
369	3x	tableauCEqual <-
370	3x	killfactor(merge(tableauCEqual, cs, by = "stm_libelle"))
371		######################
372		# source of data
373		#######################
374	3x	source <- paste("source:",paste(unique(tableauCE$source), collapse=", "))
375
376
377	3x	g <- ggplot(plotdata) +
378	3x	geom_bar(aes(x = date, y = effectif, fill = color),
379	3x	position = "stack",
380	3x	stat = "identity") +
381	3x	ylab(ylegend) +
382	3x	geom_line(aes(x = date, y = valeur, colour = color),
383	3x	data = tableauCEquan,
384	3x	size = 1) +
385	3x	geom_point(
386	3x	aes(
387	3x	x = date,
388	3x	shape = valeur,
389	3x	colour = color
390		),
391	3x	y = yqualitatif,
392	3x	data = tableauCEqual,
393	3x	size = 3
394		) +
395	3x	scale_fill_identity(name = gettext("DC"),
396	3x	labels = dc_code,
397	3x	guide = "legend") +
398	3x	scale_colour_identity(
399	3x	name = gettext("stations"),
400	3x	labels = cs[, "stm_libelle"],
401	3x	breaks = cs[, "color"],
402	3x	guide = "legend"
403		) +
404	3x	scale_shape(guide = "legend", name = gettext("Qualitative parm")) +
405	3x	theme_bw() +
406	3x	labs(caption=source)
407	3x	print(g)
408	3x	assign("g", g, envir_stacomi)
409	3x	if (!silent)
410	3x	funout(
411	3x	gettext(
412	3x	"the ggplot object has been assigned to envir_stacomi, type g<-get('g',envir_stacomi)"
413		)
414		)
415	3x	return(invisible(NULL))
416		}
417		)# end function

1
2
3		#' function used for some lattice graphs with dates
4		#' @param vectordate date or POSIXt
5		#' @return vectordate (without class)
6		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
7		graphdate<-function(vectordate){
8	!	vectordate <- as.POSIXct(vectordate)
9	!	attributes(vectordate) <- NULL
10	!	unclass(vectordate)
11	!	return(vectordate)
12		}
13
14
15
16
17
18
19
20		#' function used to remove special non utf8 character which cause the gtk
21		#' interface to crash
22		#'
23		#'
24		#' @param text a text string which might contain no utf8 characters
25		#' @return text
26		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
27		fun_char_spe<-function(text){
28	!	text <- gsub("\u00e9","e",text)
29	!	text <- gsub("\u00e8","e",text)
30	!	text <- gsub("\u00ea","e",text)
31	!	text <- gsub("\u00e0","a",text)
32	!	return(text)}
33
34
35
36
37
38
39
40
41		#' Transforms a vector into a string called within an sql command e.g.
42		#' c('A','B','C') => in ('A','B','C')
43		#'
44		#' Transforms a vector into a string called within an sql command e.g. c(A,B,C)
45		#' => in ('A','B','C')
46		#'
47		#'
48		#' @param vect a character vector
49		#' @return A list of value
50		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
51		#' @export
52		vector_to_listsql<-function(vect)
53		{
54	531x	if (is.null(vect)) stop("The vector passed to vector_to_listsql should not be null")
55	531x	if (any(is.na(vect))) stop("The vector passed to vector_to_listsql should not be NA")
56	531x	if (length(vect)==0) stop("The vector passed to vector_to_listsql should not be of lenght zero")
57	530x	if (length(vect)==1)
58		{
59	301x	listsql=paste("(","'",vect,"'",")",sep="")
60		}
61
62	530x	if (length(vect)>2)
63		{
64	130x	listsql=paste("(","'",vect[1],"'",",", sep="")
65	130x	for(j in 2:(length(vect)-1)){
66	2273x	listsql=paste(listsql,"'",vect[j],"'",",",sep="")
67		}
68	130x	listsql=paste(listsql,"'",vect[length(vect)],"'",")", sep="")
69		}
70	530x	else if (length(vect)==2)
71		{
72	99x	listsql=paste("(","'",vect[1],"'",",", sep="")
73	99x	listsql=paste(listsql,"'",vect[length(vect)],"'",")", sep="")
74		}
75
76	530x	return(listsql)
77		}
78
79
80
81		#' Create a dataframe suitable for charts per 24h and day
82		#'
83		#' This functions takes a data frame with a column with starting time and another with ending time
84		#' If the period extends over midnight, it will be split into new lines, starting and ending at midnight
85		#'
86		#' @param data The dataframe
87		#' @param horodatedebut The beginning time
88		#' @param horodatefin The ending time
89		#' @return A data frame with four new columns, Hmin (hour min), Hmax (hmax), xmin (day) and xmax (next day),
90		#' and new rows
91		#' @author cedric.briand
92		#' @examples
93		#' datatemp<-structure(list(per_dis_identifiant = c(1L, 1L, 1L),
94		#' per_date_debut = structure(c(1420056600,
95		#' 1420071000, 1420081200), class = c("POSIXct", "POSIXt"), tzone = ""),
96		#' per_date_fin = structure(c(1420071000, 1420081200, 1421000000
97		#' ), class = c("POSIXct", "POSIXt"), tzone = ""), per_commentaires = c("fonct calcul",
98		#' "fonct calcul", "fonct calcul"), per_etat_fonctionnement = c(1L,
99		#' 0L, 0L), per_tar_code = 1:3, libelle = c("Fonc normal", "Arr ponctuel",
100		#' "Arr maint")), .Names = c("per_dis_identifiant", "per_date_debut",
101		#' "per_date_fin", "per_commentaires", "per_etat_fonctionnement",
102		#' "per_tar_code", "libelle"), row.names = c(NA, 3L), class = "data.frame")
103		#' newdf<-split_per_day(data=datatemp,horodatedebut="per_date_debut",
104		#' horodatefin="per_date_fin")
105		#' @export
106		split_per_day<-function(data,horodatedebut,horodatefin){
107	5x	if(!horodatedebut%in%colnames(data)) stop("horodatedebut not in column names for data")
108	5x	if(!horodatefin%in%colnames(data)) stop("horodatefin not column names for data")
109	5x	data$Hdeb<-as.numeric(strftime(data[,horodatedebut],"%H"))+as.numeric(strftime(data[,horodatedebut],"%M"))/60
110	5x	data$Hfin<-as.numeric(strftime(data[,horodatefin],"%H"))+round(as.numeric(strftime(data[,horodatefin],"%M"))/60,2)
111	5x	data$xmin<-lubridate::floor_date(data[,horodatedebut],unit="day") # pour les graphiques en rectangle
112	5x	data$xmax<-data$xmin+lubridate::days(1)
113		# number of times we pass to midnigth
114		# round is for when we switch hour
115	5x	data$n0<-round(difftime(floor_date(data[,horodatefin],unit="day"),floor_date(data[,horodatedebut],unit="day"),units="days"))
116		# rows that will be duplicated
117	5x	data$id=sequence(nrow(data))
118	5x	data<-data[rep(sequence(nrow(data)),data$n0+1),]
119	5x	data$newid<-sequence(nrow(data))
120		# within a group where dates overlap between two days
121		#the first will and all lines except the last be set 24 for Hfin
122	5x	data1<-data%>%filter(n0>0)%>%group_by(id)%>%filter(min_rank(desc(newid)) !=1)%>%mutate("Hfin"=24)
123		#replacing rows in data
124	5x	data[match(data1$newid,data$newid),]<-data1
125		# all except the first will be set 0 to Hdeb
126	5x	data2<-data%>%filter(n0>0)%>%group_by(id)%>%filter(min_rank(newid) !=1)%>%mutate("Hdeb"=0)
127		#replacing rows in data
128	5x	data[match(data2$newid,data$newid),]<-data2
129		# now get the sequence of days righly set by adding the number of days to xmin and xmax
130	5x	data3<-data%>%filter(n0>0)%>%group_by(id)%>%mutate(xmin=xmin+ as.difftime(rank(newid)-1, units="days"),
131	5x	xmax=xmax+as.difftime(rank(newid)-1, units="days"))
132	5x	data[match(data3$newid,data$newid),]<-data3
133	5x	data<-as.data.frame(data)
134	5x	return(data)
135		}
136
137		#' This function extracts temporal characteristics from a dataframe
138		#'
139		#'
140		#' @param data a data frame containing a Date or POSIXt column
141		#' @param nom_coldt the name of the column containing date or POSIXt entry to
142		#' be processed
143		#' @param annee logical do you want a column describing year to be added to the
144		#' dataframe
145		#' @param mois logical, add column with month
146		#' @param quinzaine logical, add column with 15 days
147		#' @param semaine logical, add column with weeks
148		#' @param semaine_std logical, add column with standard weeks (using isoweek from lubridate)
149		#' @param jour_an logical, add column with day of year
150		#' @param jour_mois logical, add column with day of month
151		#' @param heure logical, add column with hour
152		#' @return The dataframe with date column filled
153		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
154		#' @export
155		fun_date_extraction=function(data, # tableau de donnees e importer
156		nom_coldt, # nom de la colonne
157		annee=TRUE,
158		mois=TRUE,
159		quinzaine=FALSE,
160		semaine=TRUE,
161		semaine_std=FALSE,
162		jour_an=FALSE,
163		jour_mois=TRUE,
164		heure=FALSE
165		){
166	44x	if (annee) data$annee <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%Y"))
167	44x	if (mois) data$mois <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%m"))
168		# %b Abbreviated month name in the current locale. (Also matches full name on input.)
169	44x	if (quinzaine) {
170	29x	data$quinzaine=ceiling(as.numeric(strftime(as.POSIXlt(data[,nom_coldt]),
171	29x	format="%W"))/2)
172	29x	data$quinzaine <- as.character(data$quinzaine)
173	29x	data$quinzaine[as.numeric(data$quinzaine)<10] <- paste("0", data$quinzaine[as.numeric(data$quinzaine)<10],sep="")
174	29x	data$quinzaine <- as.factor(data$quinzaine)
175		}
176	44x	if (semaine) data$semaine <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%W"))
177		#%W : Week of the year as decimal number (00e53) using Monday as the first day of week (and typically with the first Monday of the year as day 1 of week 1). The UK convention
178	44x	if (jour_an) data$jour_365 <- strftime(as.POSIXlt(data[,nom_coldt]), format="%j")
179	44x	if (jour_mois) data$jour_mois <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%d"))
180		# %d : Day of the month as decimal number (01e31).
181	44x	if (heure) data$heure <- as.factor(strftime(as.POSIXlt(data[,nom_coldt]), format="%H"))
182		#%H Hours as decimal number (00e23).
183	44x	if (semaine_std) data$semaine_std=lubridate::isoweek(as.POSIXlt(data[,nom_coldt]))
184	44x	return(data)
185		}
186
187
188		#' Builds a table with colors to merge with a dataframe for later
189		#' use in ggplot. An initial check will be done
190		#' on the name of the color vector. A data frame is built. It contains a column color which is a factor.
191		#' The factor order match the order of the vector (not the alphabetical order of the colors).
192
193		#'
194		#' @param color Either null (default) or a named vector of colors, the
195		#' names should correspond to the values of vec
196		#' @param vec The vector to match the color with, if a named vector
197		#' or color is supplied the names should match
198		#' @param palette, the name of the RColorBrewer palette, defaults to "Set2", ignored for other
199		#' color gradient functions and if a named vector of colors is provided
200		#' @param color_function, the name of the function used to brew the colors, one for
201		#' "brewer.pal", "gray.colors", "random", default to "brewer.pal, this argument is ignored if a
202		#' named vector of color is passed.
203		#' @return A dataframe with two columns, the vector (name) and the color (color) as a reordered factor
204		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
205		#' @export
206		colortable <- function(color=NULL, vec, palette="Set2", color_function=c("brewer.pal","gray.colors","random")){
207	19x	color_function <- match.arg(color_function, choices = c("brewer.pal","gray.colors","random"))
208	19x	if (is.null(color)) {
209	11x	if (color_function == "brewer.pal") {
210	10x	number_available <- RColorBrewer::brewer.pal.info[rownames(RColorBrewer::brewer.pal.info)==palette,"maxcolors"]
211	10x	if (number_available>=length(vec)){
212	10x	color <- RColorBrewer::brewer.pal(length(vec),name=palette)[1:length(vec)] # 1:length(vec) as palette return minimum 3 values
213		} else {
214	!	message(gettextf("Palette %s has only got %s values and you need %s", palette, number_available, length(vec)))
215	!	qual_col_pals <- RColorBrewer::brewer.pal.info[RColorBrewer::brewer.pal.info$category == 'qual',]
216	!	color <- sample(unlist(mapply(RColorBrewer::brewer.pal, qual_col_pals$maxcolors, rownames(qual_col_pals))),length(vec))
217		}
218	11x	} else if (color_function == "gray.colors"){
219	1x	color=grDevices::gray.colors(length(vec))
220	11x	} else if (color_function == "random"){
221	!	color <- grDevices::colors()[grep('gr(a\|e)y', grDevices::colors(), invert = T)]
222	!	color <- sample(color, size=length(vec))
223		}
224	10x	names(color)<-vec
225	19x	} else if (length(color) != length(vec)){
226	1x	funout(gettextf("The color argument should have length %s", length(vec)), arret=TRUE)
227		}
228	17x	if (!all(names(color)%in%vec)) {
229	!	stop (gettextf("The following name(s) %s do not match vector name: %s",
230	!	names(color)[!names(color)%in%vec],
231	!	paste(vec, collapse=", ")))
232		}
233		# creating a data frame to pass to merge later (to get the color in the data frame)
234	17x	cs <- data.frame(name=names(color), color=color)
235		# problem with different order (set by color name) implying different order
236		# in the graph (ie by color not by car_val_identifiant
237	17x	cs$color <- as.factor(cs$color)
238	17x	bonordre <- match(cs$color, levels(cs$color))
239	17x	cs$color <- factor(cs$color, levels(cs$color)[bonordre])
240	17x	return(cs)
241		}
242
243
244		#' this function displays text and will be used to convey stacomiR message in shiny
245		#'
246		#'
247		#' @param text The text to displaying the R
248		#' console and later in shiny
249		#' @param arret Should this cause the program to stop ?
250		#' @param ... Additional parameters passed to print
251		#' @return nblignes Assigned in envir_stacomi
252		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
253		#' @keywords internal
254		funout <- function(text,arret=FALSE,...){
255	101x	if(arret) stop(text) else print(text,quote=FALSE,...)
256		}
257
258		#' this function gets the schema from envir stacomi and throws warning
259		#'
260		#' @param default passed to rlang::get_env
261		#' @return The schema in envir_stacomi
262		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
263		#' @keywords internal
264		get_schema <- function(default=NULL){
265	1448x	if (!exists("envir_stacomi")) stop("envir_stacomi not created did you run stacomi() ?")
266	1448x	sch <- rlang::env_get(envir_stacomi, "sch", default=default)
267	1448x	if (is.null(sch)) stop("program failure, sch not in envir_stacomi")
268	1448x	return(sch)
269		}
270
271		#' this function gets the name of the stucture as it is set in the database
272		#'
273		#' @return The name of the structure (org_code)
274		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
275		#' @keywords internal
276		get_org <- function(){
277	13x	return(toupper(gsub("\\.", "", get_schema())))
278		}

1		#' functions called in DF and DC
2		#'
3		#'
4		#'
5		#' @param typeperiode ref.tr_typearretdisp_tar(per_tar_code) the code of the
6		#' period (see table ref.tr_typearretdisp_tar)
7		#' @param tempsdebut ref.tr_typearretdisp_tar(per_date_debut) starting
8		#' timestamp of the period
9		#' @param tempsfin The postgres column ref.tr_typearretdisp_tar(per_date_fin) ending timestamp of
10		#' the period
11		#' @param libelle The postgres column ref.tr_typearretdisp_tar(libelle )description of the period
12		#' type
13		#' @param color A named vector of color matching libelle.
14		#' @param date Boolean, should the function return a POSIXt or date value
15		#' @return A list
16		#' @note returns either POSIXt or date if date=TRUE
17		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
18		fun_table_per_dis <- function(typeperiode, tempsdebut, tempsfin, libelle, color, date = TRUE) {
19	16x	listeg = list()
20	16x	for (j in 1:5) {
21	80x	if (!date) {
22		# pour utilisation ulterieure de la classe Posixct
23	60x	if (sum(unique(typeperiode) == j) > 0) {
24	38x	choice_periode <- typeperiode == j
25	38x	liste <- list(debut = tempsdebut[choice_periode],
26	38x	fin = tempsfin[choice_periode],
27	38x	nom = libelle[choice_periode][1],
28	38x	color = color[choice_periode][1])
29	38x	listeg[[as.character(j)]] <- liste
30		}
31		# pour utilisation ulterieure de la classe date
32		} else {
33	20x	if (sum(unique(typeperiode) == j) > 0) {
34	10x	choice_periode <- typeperiode == j
35	10x	liste <- list(
36	10x	debut = as.Date(tempsdebut[choice_periode]),
37	10x	fin = as.Date(tempsfin[choice_periode]),
38	10x	nom = as.character(libelle[choice_periode][1]),
39	10x	color = color[choice_periode][1])
40	10x	listeg[[as.character(j)]] <- liste
41		}
42		}
43		}
44	16x	return(listeg)
45		}

1		#' Validity check for ref_horodate
2		#'
3		#' @param object A ref_horodate object
4		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
5		#' @keywords internal
6		validity_ref_horodate = function(object)
7		{
8	!	rep1 = inherits(object@horodate[2], "POSIXt")
9
10	!	return(ifelse(rep1, TRUE, FALSE))
11		}
12
13
14		#' Class ref_horodate
15		#'
16		#' choice of date with method to show current and previous year
17		#'
18		#'
19		#' @slot horodate a "POSIXt"
20		#' @section Objects from the Class: Objects can be created by calls of the form
21		#' \code{new("ref_horodate", \dots{})}.
22		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
23		#' @family referential objects
24		setClass(
25		Class = "ref_horodate",
26		representation =
27		representation(horodate = "POSIXt"),
28		validity = validity_ref_horodate,
29		prototype = prototype(horodate = Hmisc::roundPOSIXt(Sys.time(), "years"))
30		)
31
32
33		#' Choice_c method for ref_horodate
34		#' @aliases choice_c.ref_horodate
35		#' @param object An object of class \link{ref_horodate-class}
36		#' @param nomassign The name assigned in environment envir_stacomi
37		#' @param funoutlabel, text displayed by the interface
38		#' @param silent Default FALSE, should messages be displayed
39		#' @param horodate The horodate to set, formats "\%d/\%m/\%Y \%H:\%M:\%s", "\%d/\%m/\%y \%H:\%M:\%s", "\%Y-\%m-\%d \%H:\%M:\%s" formats
40		#' can also be passed with the date set to the minute \%d/\%m/\%Y \%H:\%M or the day \%d/\%m/\%Y
41		#' \dots are accepted. The choice_c method assigns and
42		#' @return An object of class \link{ref_horodate-class} with slot \emph{horodate} set,
43		#' and assigns an object of class POSIXt with name nomassign in envir_stacomi
44		setMethod(
45		"choice_c",
46		signature = signature("ref_horodate"),
47		definition = function(object,
48		nomassign = "horodate",
49		funoutlabel = "nous avons le choix dans la date\n",
50		#decal=0,
51		horodate,
52		silent = FALSE) {
53		# horodate="2013-01-01"
54		# parse the horohorodate
55	57x	if (length(horodate) > 1)
56	!	stop("horodate should be a vector of length 1")
57	57x	if (is.null(horodate))
58	!	stop("horodate should not be null")
59	57x	if (inherits(horodate, "character")) {
60	57x	if (grepl("/", horodate)) {
61	3x	.horodate = strptime(horodate, format = "%d/%m/%Y %H:%M:%s")
62	3x	if (is.na(.horodate)) {
63	2x	.horodate = strptime(horodate, format = "%d/%m/%y %H:%M:%s")
64		}
65	3x	if (is.na(.horodate)) {
66	2x	.horodate = strptime(horodate, format = "%d/%m/%y %H:%M")
67		}
68	3x	if (is.na(.horodate)) {
69	2x	.horodate = strptime(horodate, format = "%d/%m/%Y %H:%M")
70		}
71	3x	if (is.na(.horodate)) {
72	1x	.horodate = strptime(horodate, format = "%d/%m/%y")
73		}
74	3x	if (is.na(.horodate)) {
75	1x	.horodate = strptime(horodate, format = "%d/%m/%Y")
76		}
77	54x	} else if (grepl("-", horodate)) {
78	51x	.horodate = strptime(horodate, format = "%Y-%m-%d %H:%M:%s")
79	51x	if (is.na(.horodate)) {
80	51x	.horodate = strptime(horodate, format = "%d-%m-%Y %H:%M:%s")
81		}
82	51x	if (is.na(.horodate)) {
83	51x	.horodate = strptime(horodate, format = "%Y-%m-%d %H:%M")
84		}
85	51x	if (is.na(.horodate)) {
86	50x	.horodate = strptime(horodate, format = "%d-%m-%Y %H:%M")
87		}
88	51x	if (is.na(.horodate)) {
89	49x	.horodate = strptime(horodate, format = "%Y-%m-%d")
90		}
91	51x	if (is.na(.horodate)) {
92	!	.horodate = strptime(horodate, format = "%d-%m-%Y")
93		}
94		} else {
95	3x	stop(
96	3x	"Formatting problem, the character vector you are trying to pass as horodate could not be parsed. Check example or documentation"
97		)
98		}
99
100	!	} else if (inherits(horodate, "Date")) {
101	!	.horodate <- as.POSIXlt(horodate)
102	!	} else if (inherits(horodate[2] , "POSIXt")) {
103	!	.horodate = horodate
104		}
105	54x	if (is.na(.horodate))
106	1x	stop(
107	1x	"Formatting problem, the character vector you are trying to pass as horodate could not be parsed. Check example or documentation"
108		)
109	53x	object@horodate = .horodate
110	53x	validObject(object)
111	53x	assign(nomassign, object@horodate, envir_stacomi)
112	53x	if (!silent)
113	5x	funout(funoutlabel)
114	53x	return(object)
115		}
116		)

1		#' Class 'ref_stage'
2		#'
3		#' Representation of a fish phase
4		#'
5		#' @section Objects from the Class: Objects can be created by calls of the form
6		#' \code{new('ref_stage', data='data.frame')}. \describe{
7		#' \item{list('data')}{Object of class \code{'data.frame'} ~ The phases
8		#' available in the database}\item{:}{Object of class \code{'data.frame'} ~ The
9		#' phases available in the database} }
10		#' @slot data A data frame containing data loaded from the database by either charge or charge_with_filter methods
11		#' @slot stage_selected Contains the code \code{'tax_code'} of the stage selected by choice_c() method
12		#' @author cedric.briand@eptb-vilaine.fr
13		#' @keywords classes
14		#' @family referential objects
15		setClass(Class = "ref_stage", representation = representation(data = "data.frame", stage_selected="character"))
16
17		#' Loading method for ref_stage referential objects
18		#' @param object An object of class \link{ref_stage-class}
19		#' @return An S4 object of class \link{ref_stage-class} with all stages available in the database
20		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
21		#' @examples
22		#' \dontrun{
23		#' object=new('ref_stage')
24		#' charge(object)
25		#' }
26		setMethod("charge", signature = signature("ref_stage"), definition = function(object) {
27	2x	req = new("RequeteDB")
28	2x	req@sql = "SELECT std_code, std_libelle FROM ref.tr_stadedeveloppement_std ORDER BY std_code ;"
29	2x	req <- stacomirtools::query(req)
30	2x	object@data <- req@query
31	2x	return(object)
32		})
33
34
35		#' Loading method for ref_stage referential objects searching only those stages existing for a DC and a Taxon
36		#' @param object An object of class \link{ref_stage-class}
37		#' @param dc_selected The selected counting device
38		#' @param taxa_selected The selected species
39		#' @return An S4 object of class \link{ref_stage-class} listing all stages available for one DC and one taxon
40		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
41		#' @examples
42		#' \dontrun{
43		#' dc_selected=6
44		#'taxa_selected=2038
45		#' object=new('ref_stage')
46		#' charge_with_filter(object,dc_selected,taxa_selected)
47		#' }
48		setMethod("charge_with_filter", signature = signature("ref_stage"), definition = function(object,
49		dc_selected, taxa_selected) {
50	54x	requete = new("RequeteDBwhere")
51	54x	requete@select = paste("SELECT DISTINCT ON (std_code) std_code, std_libelle",
52	54x	" FROM ", get_schema(), "tg_dispositif_dis", " JOIN ",
53	54x	get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
54	54x	" JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
55	54x	" JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
56	54x	" JOIN ref.tr_stadedeveloppement_std on lot_std_code=std_code", sep = "")
57	54x	requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected),
58	54x	sep = "")
59	54x	requete@and = paste("and lot_tax_code in ", vector_to_listsql(taxa_selected),
60	54x	sep = "")
61	54x	requete@order_by = "ORDER BY std_code"
62	54x	requete <- stacomirtools::query(requete) # appel de la methode connect de l'object requeteDB
63	54x	object@data <- requete@query
64	54x	if (nrow(object@data) == 0)
65	!	funout(gettext("No data for this counting device and this taxa\n", domain = "R-stacomiR"),
66	!	arret = TRUE)
67	54x	return(object)
68		})
69
70
71		#' choice_c method for ref_stage
72		#'
73		#' the choice_c method is intended to have the same behaviour as choice (which creates a
74		#' widget in the graphical interface) but from the command line. The values passed to the choice_c method
75		#' for stage is the code. Any numeric value will be discarded
76		#' @param object An object of class \link{ref_stage-class}
77		#' @param stage the vector of stages chosen
78		#' @param silent Boolean, if TRUE, information messages are not displayed
79		#' @return An S4 object of class \link{ref_stage-class} with the stage selected in the data slot
80		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
81		#' @examples
82		#' \dontrun{
83		#'object=new('ref_stage')
84		#'object<-charge(object)
85		#' }
86		setMethod("choice_c", signature = signature("ref_stage"), definition = function(object,
87		stage, silent = FALSE) {
88	55x	if (is.null(stage)) {
89	!	funout(gettext("No value for argument stage\n", domain = "R-stacomiR"), arret = TRUE)
90		}
91	55x	missing_std_libelle <- stage[!stage %in% object@data$std_code]
92	55x	if (length(missing_std_libelle) > 0 & !silent)
93	!	funout(gettextf("No data for this counting device and this taxa\n %s", stringr::str_c( missing_std_libelle,
94	!	collapse = ", "), domain = "R-stacomiR"))
95	55x	object@stage_selected <- object@data[object@data$std_code %in% stage,"std_code"]
96	55x	if (nrow(object@data) == 0) {
97	!	funout(gettext("Stop there is no line in the taxa table (problem with the DB link ?)\n",
98	!	domain = "R-stacomiR"), arret = TRUE)
99		}
100	55x	assign("ref_stage", object, envir = envir_stacomi)
101	55x	return(object)
102		})

1		#' Function for report_mig graphs including numbers DF DC operations
2		#'
3		#' This graph is for species other than glass eel
4		#'
5		#'
6		#' @param report_mig An object of class \code{\linkS4class{report_mig}}
7		#' @param tableau A data frame with the with the following columns : No.pas,debut_pas,fin_pas,
8		#' ope_dic_identifiant,lot_tax_code,lot_std_code,type_de_quantite,MESURE,CALCULE,
9		#' EXPERT,PONCTUEL,Effectif_total,taux_d_echappement,coe_valeur_coefficient
10		#' @note this function is intended to be called from the plot method in report_mig_mult and report_mig
11		#' @param time.sequence A vector POSIXt
12		#' @param taxa The species
13		#' @param stage The stage
14		#' @param dc The DC
15		#' @param silent Message displayed or not
16		#' @param color Default NULL, a vector of color in the following order, working, stopped, 1...5 types of operation
17		#' for the fishway or DC, measured, calculated, expert, direct observation. If null will be set to brewer.pal(12,"Paired")[c(8,10,4,6,1,2,3,5,7)]
18		#' @param color_ope Default NULL, a vector of color for the operations. Default to brewer.pal(4,"Paired")
19		#' @param ... additional parameters passed to matplot, main, ylab, ylim, lty, pch, bty, cex.main,
20		#' it is currenly not a good idea to change xlim (numbers are wrong, the month plot covers all month, and legend placement is wrong
21		#' @return No return value, called for side effects
22		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
23		fungraph = function(report_mig,
24		tableau,
25		time.sequence,
26		taxa,
27		stage,
28		dc = NULL,
29		silent,
30		color = NULL,
31		color_ope = NULL,
32		...) {
33		#mat <- matrix(1:6,3,2)
34		#layout(mat)
35		#browser()
36		#cat("fungraph")
37		# color=null
38		# color calculation
39
40	5x	oldpar <- par(no.readonly = TRUE)
41	5x	on.exit(par(oldpar))
42	5x	if (is.null(color)) {
43	5x	tp <- RColorBrewer::brewer.pal(12, "Paired")
44	5x	mypalette = c(
45	5x	"working" = tp[4],
46	5x	"stopped" = tp[6],
47	5x	"Fonc normal" = tp[1],
48	5x	"Arr ponctuel" = tp[2],
49	5x	"Arr maintenance" = tp[3],
50	5x	"Dysfonc" = tp[5],
51	5x	"Non connu" = tp[7],
52	5x	"ponctuel" = "indianred",
53	5x	"expert" = "chartreuse2",
54	5x	"calcule" = "deepskyblue",
55	5x	"mesure" = "black"
56		)
57		} else {
58	!	if (length(color) != 11)
59	!	stop("The length of color must be 11")
60	!	mypalette = c(
61	!	"working" = color[1],
62	!	"stopped" = color[2],
63	!	"Fonc normal" = color[3],
64	!	"Arr ponctuel" = color[4],
65	!	"Arr maintenance" = color[5],
66	!	"Dysfonc" = color[6],
67	!	"Non connu" = color[7],
68	!	"mesure" = color[8],
69	!	"calcule" = color[9],
70	!	"expert" = color[10],
71	!	"ponctuel" = color[11]
72		)
73		}
74
75	5x	if (is.null(color_ope)) {
76	5x	if (stacomirtools::is.odd(dc))
77	1x	brew = "Paired"
78		else
79	4x	brew = "Accent"
80	5x	color_ope = RColorBrewer::brewer.pal(8, brew)
81		}
82
83	5x	if (is.null(dc))
84	!	dc = report_mig@dc@dc_selected[1]
85	5x	annee = unique(strftime(as.POSIXlt(time.sequence), "%Y"))[1]
86	5x	mois = months(time.sequence)
87	5x	jour = strftime(as.POSIXlt(time.sequence), "%j")
88	5x	jmois = strftime(as.POSIXlt(time.sequence), "%d")
89	5x	mois = unique(mois)
90	5x	mois = paste("15", substr(as.character(mois), 1, 3))
91	5x	index = as.vector(tableau$No.pas[jmois == 15])
92	5x	x = 1:nrow(tableau)
93	5x	debut = unclass(as.POSIXct((min(time.sequence))))[[1]] # attention arrondit e un jour de moins
94	5x	fin = unclass(as.POSIXct(max(time.sequence)))[[1]]
95	5x	dis_commentaire = as.character(report_mig@dc@data$dis_commentaires[report_mig@dc@data$dc %in%
96	5x	dc]) # commentaires sur le DC
97		###################################
98		# Definition du layout
99		####################################
100	5x	vec <- c(rep(1, 15), rep(2, 2), rep(3, 2), 4, rep(5, 6))
101	5x	mat <- matrix(vec, length(vec), 1)
102	5x	layout(mat)
103
104		#par("bg"=grDevices::gray(0.8))
105	5x	graphics::par("mar" = c(3, 4, 3, 2) + 0.1)
106		###################################
107		# Graph annuel couvrant sequence >0
108		####################################
109	5x	dots <- list(...)
110	5x	if (!"main" %in% names(dots))
111	5x	main = gettextf("Migration graph %s, %s, %s, %s",
112	5x	dis_commentaire,
113	5x	taxa,
114	5x	stage,
115	5x	annee,
116	5x	domain = "R-stacomiR")
117		else
118	!	main = dots[["main"]]
119	5x	if (!"ylab" %in% names(dots))
120	5x	ylab = gettext("Number", domain = "R-stacomiR")
121		else
122	!	ylab = dots[["ylab"]]
123	5x	if (!"cex.main" %in% names(dots))
124	5x	cex.main = 1
125		else
126	!	cex.main = dots[["cex.main"]]
127	5x	if (!"font.main" %in% names(dots))
128	5x	font.main = 1
129		else
130	!	font.main = dots[["font.main"]]
131	5x	if (!"type" %in% names(dots))
132	5x	type = "h"
133		else
134	!	type = dots[["type"]]
135	5x	if (!"xlim" %in% names(dots))
136	5x	xlim = c(debut, fin)
137		else
138	!	xlim = c(debut, fin)#dots[["xlim"]] # currently this argument is ignored
139	5x	if (!"ylim" %in% names(dots))
140	5x	ylim = NULL
141		else
142	!	ylim = dots[["ylim"]]
143	5x	if (!"cex" %in% names(dots))
144	5x	cex = 1
145		else
146	!	cex = dots[["cex"]]
147	5x	if (!"lty" %in% names(dots))
148	5x	lty = 1
149		else
150	!	lty = dots[["lty"]]
151	5x	if (!"pch" %in% names(dots))
152	5x	pch = 16
153		else
154	!	pch = dots[["pch"]]
155	5x	if (!"bty" %in% names(dots))
156	4x	bty = "l"
157		else
158	1x	bty = dots[["bty"]]
159	5x	matplot(
160	5x	time.sequence,
161	5x	cbind(
162	5x	tableau$MESURE + tableau$CALCULE + tableau$EXPERT + tableau$PONCTUEL,
163	5x	tableau$MESURE + tableau$CALCULE + tableau$EXPERT,
164	5x	tableau$MESURE + tableau$CALCULE,
165	5x	tableau$MESURE
166		),
167	5x	col = mypalette[c("ponctuel", "expert", "calcule", "mesure")],
168	5x	type = type,
169	5x	pch = pch,
170	5x	lty = lty,
171	5x	xaxt = "n",
172	5x	bty = bty,
173	5x	ylab = ylab,
174	5x	xlab = NULL,
175	5x	main = main,
176	5x	xlim = c(debut, fin),
177	5x	cex.main = cex.main,
178	5x	font.main = font.main
179		)
180	5x	if (report_mig@timestep@step_duration == "86400") {
181		# pas de temps journalier
182	5x	index = as.vector(x[jmois == 15])
183	5x	axis(
184	5x	side = 1,
185	5x	at = index,
186	5x	tick = TRUE,
187	5x	labels = mois
188		)
189		#axis(side=1,at=as.vector(x[jmois==1]),tick=TRUE,labels=FALSE)
190
191		} else {
192	!	axis(side = 1)
193		}
194	5x	mtext(
195	5x	text = gettextf("Sum of numbers =%s",
196	5x	round(
197	5x	sum(
198	5x	tableau$MESURE,
199	5x	tableau$CALCULE,
200	5x	tableau$EXPERT,
201	5x	tableau$PONCTUEL,
202	5x	na.rm = TRUE
203		)
204	5x	), domain = "R-stacomiR"),
205	5x	side = 3,
206	5x	col = mypalette["expert"],
207	5x	cex = 0.8
208		)
209
210	5x	legend(
211	5x	x = 0,
212	5x	y = max(
213	5x	tableau$MESURE,
214	5x	tableau$CALCULE,
215	5x	tableau$EXPERT,
216	5x	tableau$PONCTUEL,
217	5x	na.rm = TRUE
218		),
219	5x	legend = gettext("measured", "calculated", "expert", "direct", domain =
220	5x	"R-stacomiR"),
221	5x	pch = c(16),
222	5x	col = mypalette[c("mesure", "calcule", "expert", "ponctuel")]
223		)
224	5x	report_ope <- get("report_ope", envir = envir_stacomi)
225	5x	t_operation_ope <-
226	5x	report_ope@data[report_ope@data$ope_dic_identifiant == dc, ]
227	5x	dif = difftime(t_operation_ope$ope_date_fin,
228	5x	t_operation_ope$ope_date_debut,
229	5x	units = "days")
230
231	5x	if (!silent) {
232	1x	funout(ngettext(
233	1x	nrow(t_operation_ope),
234	1x	"%d operation \n",
235	1x	"%d operations \n",
236	1x	domain = "R-stacomiR"
237		))
238	1x	funout(gettextf("average trapping time = %s days\n", round(mean(
239	1x	as.numeric(dif)
240	1x	), 2), domain = "R-stacomiR"))
241	1x	funout(gettextf("maximum term = %s", round(max(
242	1x	as.numeric(dif)
243	1x	), 2), domain = "R-stacomiR"))
244	1x	funout(gettextf("minimum term = %s", round(min(
245	1x	as.numeric(dif)
246	1x	), 2), domain = "R-stacomiR"))
247		}
248
249
250	5x	df <- report_mig@dc@data$df[report_mig@dc@data$dc == dc]
251	5x	report_df <- get("report_df", envir = envir_stacomi)
252	5x	report_dc <- get("report_dc", envir = envir_stacomi)
253	5x	report_df@data <-
254	5x	report_df@data[report_df@data$per_dis_identifiant == df, ]
255	5x	report_dc@data <-
256	5x	report_dc@data[report_dc@data$per_dis_identifiant == dc, ]
257
258
259
260	5x	graphdate <- function(vectordate) {
261	96x	attributes(vectordate) <- NULL
262	96x	vectordate = unclass(vectordate)
263	96x	vectordate[vectordate < debut] <- debut
264	96x	vectordate[vectordate > fin] <- fin
265	96x	return(vectordate)
266		}
267
268
269		###################################
270		# creation d'un graphique vide (2)
271		###################################
272	5x	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
273	5x	plot(
274	5x	as.POSIXct(time.sequence),
275	5x	seq(0, 3, length.out = nrow(tableau)),
276	5x	xlim = xlim,
277	5x	type = "n",
278	5x	xlab = "",
279	5x	xaxt = "n",
280	5x	yaxt = "n",
281	5x	ylab = gettext("Fishway", domain = "R-stacomiR"),
282	5x	bty = "n",
283	5x	cex = cex + 0.2
284		)
285
286		###################################
287		# time for DF (fishway) operation
288		###################################
289
290	5x	if (dim(report_df@data)[1] == 0) {
291	1x	rect(
292	1x	xleft = debut,
293	1x	ybottom = 2.1,
294	1x	xright = fin,
295	1x	ytop = 3,
296	1x	col = "grey",
297	1x	border = NA,
298	1x	lwd = 1
299		)
300	1x	rect(
301	1x	xleft = debut,
302	1x	ybottom = 1.1,
303	1x	xright = fin,
304	1x	ytop = 2,
305	1x	col = "grey40",
306	1x	border = NA,
307	1x	lwd = 1
308		)
309	1x	legend(
310	1x	x = "bottom",
311	1x	legend = gettext("Unknown working", "Unknow operation type", domain =
312	1x	"R-stacomiR"),
313	1x	pch = c(16, 16),
314	1x	col = c("grey", "grey40"),
315	1x	horiz = TRUE,
316	1x	bty = "n"
317		)
318
319
320		} else {
321		# si il sort quelque chose
322	4x	if (sum(report_df@data$per_etat_fonctionnement == 1) > 0) {
323	4x	rect(
324	4x	xleft = graphdate(as.POSIXct(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
325	4x	1])),
326	4x	ybottom = 2.1,
327	4x	xright = graphdate(as.POSIXct(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
328	4x	1])),
329	4x	ytop = 3,
330	4x	col = mypalette["working"],
331	4x	border = NA,
332	4x	lwd = 1
333		)
334		}
335	4x	if (sum(report_df@data$per_etat_fonctionnement == 0) > 0) {
336	4x	rect(
337	4x	xleft = graphdate(as.POSIXct(report_df@data$per_date_debut[report_df@data$per_etat_fonctionnement ==
338	4x	0])),
339	4x	ybottom = 2.1,
340	4x	xright = graphdate(as.POSIXct(report_df@data$per_date_fin[report_df@data$per_etat_fonctionnement ==
341	4x	0])),
342	4x	ytop = 3,
343	4x	col = mypalette["stopped"],
344	4x	border = NA,
345	4x	lwd = 1
346		)
347		}
348		#creation d'une liste par categorie d'arret contenant vecteurs dates
349	4x	listeperiode <-
350	4x	fun_table_per_dis(
351	4x	typeperiode = report_df@data$per_tar_code,
352	4x	tempsdebut = report_df@data$per_date_debut,
353	4x	tempsfin = report_df@data$per_date_fin,
354	4x	libelle = report_df@data$libelle,
355	4x	color= mypalette[report_df@data$libelle],
356	4x	date = FALSE
357		)
358	4x	nomperiode <- vector()
359	4x	color_periodes <-
360	4x	vector() # a vector of colors, one per period type in listeperiode
361	4x	for (j in 1:length(listeperiode)) {
362		#recuperation du vecteur de noms (dans l'ordre) e partir de la liste
363	11x	nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
364		#ecriture pour chaque type de periode
365	11x	color_periode = listeperiode[[j]]$color
366	11x	rect(
367	11x	xleft = graphdate(listeperiode[[j]]$debut),
368	11x	ybottom = 1.1,
369	11x	xright = graphdate(listeperiode[[j]]$fin),
370	11x	ytop = 2,
371	11x	col = color_periode,
372	11x	border = NA,
373	11x	lwd = 1
374		)
375	11x	color_periodes <- c(color_periodes, color_periode)
376		}
377
378	4x	legend (
379	4x	x = debut,
380	4x	y = 1.2,
381	4x	legend = c(gettext("stop", domain = "R-stacomiR"), nomperiode),
382	4x	pch = c(15, 15),
383	4x	col = c(mypalette["working"], mypalette["stopped"], color_periodes),
384	4x	bty = "n",
385	4x	ncol = 7,
386	4x	text.width = (fin - debut) / 10
387		)
388		}
389
390		###################################
391		# creation d'un graphique vide (3)
392		###################################
393
394	5x	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
395	5x	plot(
396	5x	as.POSIXct(time.sequence),
397	5x	seq(0, 3, length.out = nrow(tableau)),
398	5x	xlim = xlim,
399	5x	type = "n",
400	5x	xlab = "",
401	5x	xaxt = "n",
402	5x	yaxt = "n",
403	5x	ylab = gettext("CD", domain = "R-stacomiR"),
404	5x	bty = "n",
405	5x	cex = cex + 0.2
406		)
407		###################################
408		# time for DC (counting device) operation
409		###################################
410
411
412	5x	if (dim(report_dc@data)[1] == 0) {
413	!	rect(
414	!	xleft = debut,
415	!	ybottom = 2.1,
416	!	xright = fin,
417	!	ytop = 3,
418	!	col = "grey",
419	!	border = NA,
420	!	lwd = 1
421		)
422
423	!	rect(
424	!	xleft = debut,
425	!	ybottom = 1.1,
426	!	xright = fin,
427	!	ytop = 2,
428	!	col = "grey40",
429	!	border = NA,
430	!	lwd = 1
431		)
432	!	legend(
433	!	x = "bottom",
434	!	legend = gettext("Unknown working", "Unknow operation type", domain =
435	!	"R-stacomiR"),
436	!	pch = c(16, 16),
437	!	col = c("grey", "grey40"),
438		#horiz=TRUE,
439	!	ncol = 5,
440	!	bty = "n"
441		)
442
443
444		} else {
445	5x	if (sum(report_dc@data$per_etat_fonctionnement == 1) > 0) {
446	5x	rect(
447	5x	xleft = graphdate(as.POSIXct(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
448	5x	1])),
449	5x	ybottom = 2.1,
450	5x	xright = graphdate(as.POSIXct(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
451	5x	1])),
452	5x	ytop = 3,
453	5x	col = mypalette["working"],
454	5x	border = NA,
455	5x	lwd = 1
456		)
457		}
458	5x	if (sum(report_dc@data$per_etat_fonctionnement == 0) > 0)
459		{
460	5x	rect(
461	5x	xleft = graphdate(as.POSIXct(report_dc@data$per_date_debut[report_dc@data$per_etat_fonctionnement ==
462	5x	0])),
463	5x	ybottom = 2.1,
464	5x	xright = graphdate(as.POSIXct(report_dc@data$per_date_fin[report_dc@data$per_etat_fonctionnement ==
465	5x	0])),
466	5x	ytop = 3,
467	5x	col = mypalette["stopped"],
468	5x	border = NA,
469	5x	lwd = 1
470		)
471		}
472	5x	listeperiode <-
473	5x	fun_table_per_dis(
474	5x	typeperiode = report_dc@data$per_tar_code,
475	5x	tempsdebut = report_dc@data$per_date_debut,
476	5x	tempsfin = report_dc@data$per_date_fin,
477	5x	libelle = report_dc@data$libelle,
478	5x	color= mypalette[report_df@data$libelle],
479	5x	date = FALSE
480		)
481	5x	nomperiode <- vector()
482	5x	color_periodes <- vector()
483	5x	for (j in 1:length(listeperiode)) {
484	14x	nomperiode[j] <- substr(listeperiode[[j]]$nom, 1, 17)
485	14x	color_periode <- listeperiode[[j]]$color
486	14x	rect(
487	14x	xleft = graphdate(listeperiode[[j]]$debut),
488	14x	ybottom = 1.1,
489	14x	xright = graphdate(listeperiode[[j]]$fin),
490	14x	ytop = 2,
491	14x	col = color_periode,
492	14x	border = NA,
493	14x	lwd = 1
494		)
495		}
496
497	5x	legend (
498	5x	x = debut,
499	5x	y = 1.2,
500	5x	legend = gettext("working", "stopped", nomperiode, domain = "R-stacomiR"),
501	5x	pch = c(15, 15),
502	5x	col = c(mypalette["working"], mypalette["stopped"], color_periodes),
503	5x	bty = "n",
504	5x	ncol = length(listeperiode) + 2,
505	5x	text.width = (fin - debut) / 10
506		)
507		}
508
509		###################################
510		# creation d'un graphique vide (4=op)
511		###################################
512
513
514	5x	graphics::par("mar" = c(0, 4, 0, 2) + 0.1)
515	5x	plot(
516	5x	as.POSIXct(time.sequence),
517	5x	seq(0, 1, length.out = nrow(tableau)),
518	5x	xlim = xlim,
519	5x	type = "n",
520	5x	xlab = "",
521	5x	xaxt = "n",
522	5x	yaxt = "n",
523	5x	ylab = gettext("Op", domain = "R-stacomiR"),
524	5x	bty = "n",
525	5x	cex = cex + 0.2
526		)
527		###################################
528		# operations
529		###################################
530
531	5x	rect(
532	5x	xleft = graphdate(as.POSIXct(t_operation_ope$ope_date_debut)),
533	5x	ybottom = 0,
534	5x	xright = graphdate(as.POSIXct(t_operation_ope$ope_date_fin)),
535	5x	ytop = 1,
536	5x	col = color_ope,
537	5x	border = NA,
538	5x	lwd = 1
539		)
540
541
542		###################################
543		# Graph mensuel
544		####################################
545	5x	graphics::par("mar" = c(4, 4, 1, 2) + 0.1)
546	5x	tableau$mois = factor(months(tableau$debut_pas, abbreviate = TRUE),
547	5x	levels = unique(months(tableau$debut_pas, abbreviate = TRUE)))
548	5x	tableaum <-
549	5x	reshape2::melt(
550	5x	data = tableau[, c("MESURE", "CALCULE", "EXPERT", "PONCTUEL", "mois")],
551	5x	id.vars = c("mois"),
552	5x	measure.vars = c("MESURE", "CALCULE", "EXPERT", "PONCTUEL"),
553	5x	variable.name = "type",
554	5x	value.name = "number"
555		)
556	5x	levels(tableaum$type) <-
557	5x	gettext("measured", "calculated", "expert", "direct", domain = "R-stacomiR")
558	5x	superpose.polygon <- lattice::trellis.par.get("plot.polygon")
559	5x	superpose.polygon$col = mypalette[c("mesure", "calcule", "expert", "ponctuel")]
560	5x	superpose.polygon$border = rep("transparent", 6)
561	5x	lattice::trellis.par.set("superpose.polygon", superpose.polygon)
562	5x	fontsize <- lattice::trellis.par.get("fontsize")
563	5x	fontsize$text = 10
564	5x	lattice::trellis.par.set("fontsize", fontsize)
565	5x	par.main.text <- lattice::trellis.par.get("par.main.text")
566	5x	par.main.text$cex = 1
567	5x	par.main.text$font = 1
568	5x	lattice::trellis.par.set("par.main.text", par.main.text)
569		# lattice::show.settings()
570
571	5x	par.ylab.text <- lattice::trellis.par.get("par.ylab.text")
572	5x	par.ylab.text$cex = 0.8
573	5x	lattice::trellis.par.set("par.ylab.text", par.ylab.text)
574	5x	par.xlab.text <- lattice::trellis.par.get("par.xlab.text")
575	5x	par.xlab.text$cex = 0.8
576	5x	lattice::trellis.par.set("par.xlab.text", par.xlab.text)
577
578	5x	bar <- lattice::barchart(
579	5x	number / 1000 ~ mois,
580	5x	groups = type,
581	5x	xlab = gettext("Month", domain = "R-stacomiR"),
582	5x	ylab = gettext("Number (x1000)", domain = "R-stacomiR"),
583	5x	data = tableaum,
584	5x	allow.multiple = FALSE,
585	5x	strip = FALSE,
586	5x	stack = TRUE,
587	5x	origin = 0
588		)
589	5x	print(bar, position = c(0, 0, 1, .25), newpage = FALSE)
590
591	5x	return(invisible(NULL))
592		}

1		#' Class 'ref_taxa'
2		#'
3		#' Loading and selection of fish species. This class is a referential class, and it is
4		#' integrated into refreport objects.
5		#'
6		#' @section Objects from the Class: Objects can be created by calls of the form
7		#' \code{new('ref_taxa', ...)}.
8		#' @slot data A \code{'data.frame'} of species available in the database
9		#' @slot taxa_selected Contains the code \code{'tax_code'} of the taxa selected by choice_c() method
10		#' @author cedric.briand@eptb-vilaine.fr
11		#' @family referential objects
12		setClass(Class = "ref_taxa", representation = representation(data = "data.frame",taxa_selected = "character"))
13
14
15		#' Loading method for ref_taxa referential objects
16		#'
17		#' @return An S4 object of class ref_taxa
18		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
19		#' @param object An object of class \link{ref_taxa-class}
20		#' @return An S4 object of class \link{ref_taxa-class} with all taxa loaded from the database
21		#' @examples \dontrun{
22		#' object=new('ref_taxa')
23		#' charge(object)}
24		setMethod("charge", signature = signature("ref_taxa"), definition = function(object) {
25	2x	req = new("RequeteDB")
26	2x	req@sql = "SELECT tax_code, tax_nom_latin, tax_nom_commun, tax_ntx_code, tax_tax_code FROM ref.tr_taxon_tax ORDER BY tax_rang ASC ;"
27	2x	req <- stacomirtools::query(req)
28	2x	object@data <- req@query
29	2x	return(object)
30		})
31
32		#' Loading method for ref_taxa referential objects searching only taxa existing for a DC
33		#' @param object An object of class \link{ref_taxa-class}
34		#' @param dc_selected A counting device selected, only taxa attached to this dc are selected
35		#' @return An S4 object of class \link{ref_taxa-class} with all taxa present on a DC (counting device)
36		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
37		#' @examples \dontrun{
38		#' dc_selected=6
39		#' object=new('ref_taxa')
40		#' charge_with_filter(object,dc_selected=dc_selected)}
41		setMethod("charge_with_filter", signature = signature("ref_taxa"), definition = function(object,
42		dc_selected) {
43	61x	requete = new("RequeteDBwhere")
44	61x	requete@select = paste("SELECT DISTINCT ON (tax_rang) tax_code, tax_nom_latin, tax_nom_commun, tax_ntx_code, tax_tax_code",
45	61x	" FROM ", get_schema(), "tg_dispositif_dis", " JOIN ",
46	61x	get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
47	61x	" JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
48	61x	" JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
49	61x	" JOIN ref.tr_taxon_tax on lot_tax_code=tax_code", sep = "")
50	61x	requete@where = paste("where dis_identifiant in", vector_to_listsql(dc_selected))
51	61x	requete@order_by = "ORDER BY tax_rang ASC"
52	61x	requete <- stacomirtools::query(requete)
53	61x	object@data <- requete@query
54	61x	return(object)
55		})
56
57
58		#' choice_c method for ref_taxa
59		#'
60		#' the choice_cc method is intended to have the same behaviour as choice (which creates a
61		#' widget in the graphical interface) but from the command line. The values passed to the choice_c method
62		#' for taxa can be either numeric (2038 = Anguilla anguilla) or character.
63		#' @param object An object from the class ref_taxa
64		#' @param taxa The vector of taxa, can be either code (numeric) or latin name
65		#' @return An S4 object of class \link{ref_taxa-class} with data filtered according to the taxa
66		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
67		#' @examples
68		#' \dontrun{
69		#' object=new('ref_taxa')
70		#' object<-charge(object)
71		#' objectreport=new('report_mig_mult')
72		#' choice_c(object=object,'Anguilla anguilla')
73		#' }
74		setMethod("choice_c", signature = signature("ref_taxa"), definition = function(object,
75		taxa) {
76	58x	if (is.null(taxa)) {
77	!	funout(gettext("No value for argument taxa\n", domain = "R-stacomiR"), arret = TRUE)
78	58x	} else if (inherits(taxa, "character") & suppressWarnings(all(is.na(as.numeric(taxa))))) {
79		# taxa is 'Anguilla anguilla'
80	36x	libellemanquants <- taxa[!taxa %in% object@data$tax_nom_latin]
81	36x	if (length(libellemanquants) > 0)
82	1x	warning(gettextf("Taxa not present :\n %s", stringr::str_c(libellemanquants,
83	1x	collapse = ", "), domain = "R-stacomiR"))
84	36x	object@taxa_selected <- object@data[object@data$tax_nom_latin %in% taxa,"tax_code"]
85	58x	} else if (inherits(taxa, "numeric")){
86		# taxa is 2038
87	13x	codemanquants <- taxa[!as.character(taxa) %in% object@data$tax_code]
88	13x	if (length(codemanquants) > 0)
89	1x	warning(gettextf("Taxa not present :\n %s", stringr::str_c(codemanquants,
90	1x	collapse = ", "), domain = "R-stacomiR"))
91	13x	object@taxa_selected <- object@data[object@data$tax_code %in% as.character(taxa),"tax_code"]
92	58x	} else if (inherits(taxa, "character") & !suppressWarnings(all(is.na(as.numeric(taxa))))){
93		# taxa is "2038"
94	9x	codemanquants <- taxa[!taxa %in% object@data$tax_code]
95	9x	if (length(codemanquants) > 0)
96	9x	warning(gettextf("Taxa not present :\n %s", stringr::str_c(codemanquants,
97	9x	collapse = ", "), domain = "R-stacomiR"))
98	9x	object@taxa_selected <- object@data[object@data$tax_code %in% taxa, "tax_code"]
99		}
100	58x	if (nrow(object@data) == 0) {
101	!	funout(gettext("Stop there is no line in the taxa table (problem with the DB link ?)\n",
102	!	domain = "R-stacomiR"), arret = TRUE)
103		}
104	58x	assign("ref_taxa", object, envir = envir_stacomi)
105	58x	return(object)
106		})

1		#' Validity check for ref_year
2		#'
3		#' validity_year tests for validity within the class
4		#'
5		#'
6		#' @param object An object of class \code{\linkS4class{ref_year}}
7		#' @return boolean The test for the object refannee
8		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
9		#' @keywords internal
10		validity_year = function(object)
11		{
12	!	rep1 = inherits(object@data, "data.frame")
13	!	rep2 = inherits(object@year_selected, "numeric")
14
15	!	return(ifelse(rep1 & rep2, TRUE, FALSE))
16		}
17		#definition de la classe
18
19		#' Year reference class
20		#'
21		#' Class used to select one or several years
22		#' @section Objects from the Class: Objects can be created by calls of the form
23		#' \code{new("ref_year", data=data.frame(), year_selected=numeric())}.
24		#' @include create_generic.R
25		#' @slot data A \code{data.frame} with the list of possible years selected as numerics
26		#' @slot year_selected A numeric vector
27		#' @keywords classes
28		#' @family referential objects
29		#' @author cedric.briand@eptb-vilaine.fr
30		setClass(
31		Class = "ref_year",
32		representation =
33		representation(data = "data.frame", year_selected = "numeric"),
34		validity = validity_year,
35		prototype = prototype(data = data.frame(), year_selected = numeric())
36		)
37
38		#' Loading method for ref_year referential objects
39		#'
40		#' Selects year available either in the bjo table if report_object==report_mig_interannual) or in the t_operation_ope table
41		#' @param object An object of class \link{ref_year-class}
42		#' @param objectreport The object report, default \code{report_ge_weight} other possible value report_mig_interannual
43		#' @return object An object of class \link{ref_year-class} with slot data filled with the available years for the corresponding report
44		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
45		#' @examples
46		#' \dontrun{
47		#' object=new("ref_year")
48		#' charge(object)
49		#' validObject(annee)
50		#' showMethods("charge")
51		#' }
52		setMethod(
53		"charge",
54		signature = signature("ref_year"),
55		definition = function(object, objectreport = "report_ge_weight") {
56	25x	requete = new("RequeteDB")
57	25x	if (objectreport == "report_mig_interannual") {
58	10x	if (exists("ref_dc", envir_stacomi)) {
59	10x	dc <- get("ref_dc", envir_stacomi)
60	10x	and1 <- paste(" AND bjo_dis_identifiant in", vector_to_listsql(dc@dc_selected))
61		} else {
62	!	and1 <- ""
63		}
64	10x	if (exists("ref_taxa", envir_stacomi)) {
65	10x	taxa <- get("ref_taxa", envir_stacomi)
66	10x	and2 <-
67	10x	stringr::str_c(" AND bjo_tax_code ='", taxa@taxa_selected, "'")
68		} else {
69	!	and2 <- ""
70		}
71	10x	if (exists("ref_stage", envir_stacomi)) {
72	10x	stage <- get("ref_stage", envir_stacomi)
73	10x	and3 <-
74	10x	stringr::str_c(" AND bjo_std_code ='", stage@stage_selected, "'")
75		} else
76		{
77	!	and3 = ""
78		}
79	10x	requete@sql = paste(
80	10x	"select DISTINCT ON (bjo_annee) bjo_annee from ",
81	10x	get_schema(),
82	10x	"t_bilanmigrationjournalier_bjo where bjo_identifiant>0 ",
83		# I want and statements to not have to choose the order
84		# the where statement is always verified
85	10x	and1,
86	10x	and2,
87	10x	and3,
88	10x	sep = ""
89		)
90	25x	} else if (objectreport == "report_ge_weight") {
91	4x	requete@sql = paste(
92	4x	"select DISTINCT ON (year) year from( select date_part('year', ope_date_debut) as year from ",
93	4x	get_schema(),
94	4x	"t_operation_ope) as tabletemp",
95	4x	sep = ""
96		)
97	25x	} else if (objectreport == "report_annual" \|
98	25x	objectreport == "report_species") {
99	11x	if (exists("ref_dc", envir_stacomi)) {
100	11x	dc <- get("ref_dc", envir_stacomi)
101	11x	and1 <-
102	11x	paste(" AND ope_dic_identifiant in ",
103	11x	vector_to_listsql(dc@dc_selected))
104		} else {
105	!	and1 <- ""
106		}
107	11x	if (exists("ref_taxa", envir_stacomi)) {
108	11x	taxa <- get("ref_taxa", envir_stacomi)
109	11x	if (!length(taxa@taxa_selected)==0){
110	11x	and2 <-
111	11x	stringr::str_c(" AND lot_tax_code in ",
112	11x	vector_to_listsql(taxa@taxa_selected))
113		} else {
114	!	and2 <- ""
115		}
116		} else {
117	!	and2 <- ""
118		}
119	11x	if (exists("ref_stage", envir_stacomi)) {
120	4x	stage <- get("ref_stage", envir_stacomi)
121	4x	if (!length(stage@stage_selected)==0){
122	4x	and3 <-
123	4x	stringr::str_c(" AND lot_std_code in ",
124	4x	vector_to_listsql(stage@stage_selected))
125		} else
126		{
127	!	and3 = ""
128		}
129		} else
130		{
131	7x	and3 = ""
132		}
133	11x	requete@sql = paste(
134	11x	"select DISTINCT ON (year) year from (select date_part('year', ope_date_debut) as year from ",
135	11x	get_schema(),
136	11x	"t_operation_ope JOIN ",
137	11x	get_schema(),
138	11x	"t_lot_lot on lot_ope_identifiant=ope_identifiant",
139	11x	" WHERE lot_lot_identifiant is null",
140	11x	and1,
141	11x	and2,
142	11x	and3,
143	11x	") as tabletemp",
144	11x	sep = ""
145		)
146		} else {
147	!	funout(gettextf("Not implemented for objectreport = %s", objectreport),
148	!	arret = TRUE)
149		}
150	25x	requete <-
151	25x	stacomirtools::query(requete)
152	25x	object@data <- stacomirtools::getquery(requete)
153	25x	return(object)
154		}
155		)
156
157
158		#' choice_c method for ref_year referential from the command line
159		#'
160		#' The choice_c method will issue a warning if the year is not present in the database
161		#' Allows the selection of year and the assignment in environment envir_stacomi
162		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
163		#' @param object An object of class \link{ref_year-class}
164		#' @param annee The year to select, either as a character or as a numeric
165		#' @param nomassign The name to be assigned in envir_stacomi
166		#' @param funoutlabel The label that appears in funout
167		#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
168		#' @return object An object of class \link{ref_year-class} with year selected
169		#' @examples
170		#' \dontrun{
171		#' object=new("ref_year")
172		#' object<-charge(object)
173		#' win=gwindow(title="test ref_year")
174		#' group=ggroup(container=win,horizontal=FALSE)
175		#' choice(object,nomassign="ref_year",funoutlabel="essai",titleFrame="essai ref_year",preselect=1)
176		#' dispose(win)
177		#' }
178		setMethod(
179		"choice_c",
180		signature = signature("ref_year"),
181		definition = function(object,
182		annee,
183		nomassign = "ref_year",
184		funoutlabel = gettext("Year selected\n", domain = "R-stacomiR"),
185		silent = FALSE) {
186	49x	if (length(annee) > 1)
187	49x	stop("horodate should be a vector of length 1")
188	49x	if (inherits (annee, "character"))
189	49x	annee <- as.numeric(annee)
190		# the charge method must be performed before
191	49x	gettext("no year", domain = "R-stacomiR")
192	49x	if (!annee %in% object@data[, 1]) {
193	!	warning(
194	!	stringr::str_c(
195	!	"Attention, year ",
196	!	annee,
197	!	" is not available in the database, available years :",
198	!	ifelse(
199	!	length(object@data$bjo_annee) == 0,
200	!	gettext(" none", domain = "R-stacomiR"),
201	!	stringr::str_c(object@data$bjo_annee, collapse = ",")
202		)
203		)
204		)
205		}
206	48x	object@year_selected <- annee
207
208	48x	assign(nomassign, object, envir_stacomi)
209	48x	if (!silent)
210	48x	funout(funoutlabel)
211	48x	return(object)
212		}
213		)

1		#' Class 'report_sample_char'
2		#'
3		#' The report_sample_char class is used to load and display sample characteristics, which can be either
4		#' continuous or discrete variable, for instance, it can be used to analyze size or sex structure during
5		#' a given period.
6		#'
7		#' @note This class is displayed by interface_report_sample_char, in the database, the class calls the content
8		#' of the view vue_lot_ope_car
9		#' @slot data A data frame
10		#' @slot dc An object of class \link{ref_dc-class}: the control devices
11		#' @slot taxa An object of class \link{ref_taxa-class}: the species
12		#' @slot stage An object of class \link{ref_stage-class} : the stages of the fish
13		#' @slot par An object of class \link{ref_par-class}: the parameters used
14		#' @slot horodatedebut An object of class \link{ref_horodate-class}
15		#' @slot horodatefin An object of class \link{ref_horodate-class}
16		#' @section Objects from the Class: Objects can be created by calls of the form
17		#' \code{new('report_sample_char', ...)}
18		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
19		#' @family report Objects
20		#' @keywords classes
21		#' @example inst/examples/report_sample_char-example.R
22		#' @aliases report_sample_char
23		#' @export
24		setClass(Class = "report_sample_char", representation = representation(data = "ANY",
25		dc = "ref_dc", taxa = "ref_taxa", stage = "ref_stage", par = "ref_par", horodatedebut = "ref_horodate",
26		horodatefin = "ref_horodate"), prototype = prototype(data = data.frame(), dc = new("ref_dc"),
27		taxa = new("ref_taxa"), stage = new("ref_stage"), par = new("ref_par"), horodatedebut = new("ref_horodate"),
28		horodatefin = new("ref_horodate")))
29
30		#' connect method for report_sample_char
31		#'
32		#' @param object An object of class \link{report_sample_char-class}
33		#' @param silent Boolean if TRUE messages are not displayed
34		#' @return An object of class \link{report_sample_char-class} with slot data \code{@data} filled
35		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
36		#' @aliases connect.report_sample_char
37		setMethod("connect", signature = signature("report_sample_char"), definition = function(object,
38		silent = FALSE) {
39	3x	requete <- new("RequeteDBwheredate")
40	3x	requete@select = paste("SELECT * FROM ", get_schema(),
41	3x	"vue_lot_ope_car", sep = "")
42	3x	requete@colonnedebut = "ope_date_debut"
43	3x	requete@colonnefin = "ope_date_fin"
44	3x	requete@datedebut <- object@horodatedebut@horodate
45	3x	requete@datefin <- object@horodatefin@horodate
46	3x	requete@order_by = "ORDER BY ope_date_debut"
47	3x	requete@and = paste(" AND ope_dic_identifiant in ", vector_to_listsql(object@dc@dc_selected),
48	3x	" AND lot_tax_code in ", vector_to_listsql(object@taxa@taxa_selected), " AND lot_std_code in ",
49	3x	vector_to_listsql(object@stage@stage_selected), " AND car_par_code in ", vector_to_listsql(object@par@par_selected),
50	3x	sep = "")
51	3x	requete <- stacomirtools::query(requete)
52	3x	object@data <- requete@query
53	3x	if (!silent)
54	!	funout(gettext("Sample characteristics have been loaded from the database\n",
55	!	domain = "R-stacomiR"))
56	3x	return(object)
57		})
58
59
60		#' charge method for report_sample_char class
61		#'
62		#' this method verifies that boxes have been clicked in the user interface and gets the objects pasted in
63		#' envir_stacomi
64		#' @param object An object of class \link{report_sample_char-class}
65		#' @return An object of class \link{report_sample_char-class} with slots filled with user choice
66		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
67		#' @return An object of the class \link{report_sample_char-class} with slots filled from values assigned in \code{envir_stacomi} environment
68		#' @aliases charge.report_sample_char
69		#' @keywords internal
70		setMethod("charge", signature = signature("report_sample_char"), definition = function(object) {
71	2x	if (exists("ref_dc", envir_stacomi)) {
72	2x	object@dc <- get("ref_dc", envir_stacomi)
73		} else {
74	!	funout(gettext("You need to choose a counting device, clic on validate\n",
75	!	domain = "R-stacomiR"), arret = TRUE)
76		}
77	2x	if (exists("ref_taxa", envir_stacomi)) {
78	2x	object@taxa <- get("ref_taxa", envir_stacomi)
79		} else {
80	!	funout(gettext("You need to choose a taxa, clic on validate\n", domain = "R-stacomiR"),
81	!	arret = TRUE)
82		}
83	2x	if (exists("ref_stage", envir_stacomi)) {
84	2x	object@stage <- get("ref_stage", envir_stacomi)
85		} else {
86	!	funout(gettext("You need to choose a stage, clic on validate\n", domain = "R-stacomiR"),
87	!	arret = TRUE)
88		}
89	2x	if (exists("ref_par", envir_stacomi)) {
90	2x	object@par <- get("ref_par", envir_stacomi)
91		} else {
92	!	funout(gettext("You need to choose a parameter, clic on validate\n", domain = "R-stacomiR"),
93	!	arret = TRUE)
94		}
95		# rem pas tres satisfaisant car ce nom est choisi dans l'interface
96	2x	if (exists("report_sample_char_date_debut", envir_stacomi)) {
97	2x	object@horodatedebut@horodate <- get("report_sample_char_date_debut", envir_stacomi)
98		} else {
99	!	funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
100	!	arret = TRUE)
101		}
102		# rem id
103	2x	if (exists("report_sample_char_date_fin", envir_stacomi)) {
104	2x	object@horodatefin@horodate <- get("report_sample_char_date_fin", envir_stacomi)
105		} else {
106	!	funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
107	!	arret = TRUE)
108		}
109	2x	assign("report_sample_char", object, envir_stacomi)
110	2x	return(object)
111		})
112
113
114		#' command line interface for report_sample_char class
115		#'
116		#' #' The choice_c method fills in the data slot for classes \link{ref_dc-class}, \link{ref_taxa-class}, \link{ref_stage-class}, \link{ref_par-class} and two slots of \link{ref_horodate-class} and then
117		#' uses the choice_c methods of these object to select the data.
118		#' @param object An object of class \link{report_sample_char-class}
119		#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
120		#' @param taxa Either a species name in latin or the SANDRE code for species (ie 2038=Anguilla anguilla),
121		#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
122		#' @param stage A stage code matching the ref.tr_stadedeveloppement_std table in the stacomi database, see \link{choice_c,ref_stage-method}
123		#' @param par A parameter matching th ref.tg_parametre_par table in the stacomi database, see \link{choice_c,ref_par-method}
124		#' @param horodatedebut The starting date as a character, formats like \code{\%Y-\%m-\%d} or \code{\%d-\%m-\%Y} can be used as input
125		#' @param horodatefin The finishing date of the report, for this class this will be used to calculate the number of daily steps.
126		#' @param silent Boolean, if TRUE, information messages are not displayed
127		#' @return An object of class \link{report_mig-class} with data selected
128		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
129		#' @aliases choice_c.report_sample_char
130		setMethod("choice_c", signature = signature("report_sample_char"), definition = function(object,
131		dc, taxa, stage, par, horodatedebut, horodatefin, silent = FALSE) {
132		# code for debug using example
133		# report_sample_char<-r_sample_char;dc=c(5,6);taxa='Anguilla anguilla'
134		# stage=c('CIV','AGJ');par=c(1785,1786,1787,'C001');horodatedebut='2010-01-01';horodatefin='2015-12-31'
135	4x	report_sample_char <- object
136	4x	report_sample_char@dc = charge(report_sample_char@dc)
137		# loads and verifies the dc this will set dc_selected slot
138	4x	report_sample_char@dc <- choice_c(object = report_sample_char@dc, dc)
139		# only taxa present in the report_mig are used
140	4x	report_sample_char@taxa <- charge_with_filter(object = report_sample_char@taxa,
141	4x	report_sample_char@dc@dc_selected)
142	4x	report_sample_char@taxa <- choice_c(report_sample_char@taxa, taxa)
143	4x	report_sample_char@stage <- charge_with_filter(object = report_sample_char@stage,
144	4x	report_sample_char@dc@dc_selected, report_sample_char@taxa@taxa_selected)
145	4x	report_sample_char@stage <- choice_c(report_sample_char@stage, stage)
146	4x	report_sample_char@par <- charge_with_filter(object = report_sample_char@par,
147	4x	report_sample_char@dc@dc_selected, report_sample_char@taxa@taxa_selected,
148	4x	report_sample_char@stage@stage_selected)
149	4x	report_sample_char@par <- choice_c(report_sample_char@par, par, silent = silent)
150	4x	report_sample_char@horodatedebut <- choice_c(object = report_sample_char@horodatedebut,
151	4x	nomassign = "report_sample_char_date_debut", funoutlabel = gettext("Beginning date has been chosen\n",
152	4x	domain = "R-stacomiR"), horodate = horodatedebut, silent = silent)
153	4x	report_sample_char@horodatefin <- choice_c(report_sample_char@horodatefin, nomassign = "report_sample_char_date_fin",
154	4x	funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
155	4x	horodate = horodatefin, silent = silent)
156	4x	return(report_sample_char)
157		})
158
159		#' Calculation for report_sample_char
160		#'
161		#' In that class, most treatments are done in the query, this method checks that data are available and fills information for year, month, two weeks, week, doy
162		#' @param object An object of class \code{\link{report_sample_char-class}}
163		#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
164		#' @return An object of class \code{\link{report_sample_char-class}} with slot \code{@data} filled
165		#' @aliases calcule.report_sample_char
166		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
167		setMethod("calcule", signature = signature("report_sample_char"), definition = function(object,
168		silent = FALSE) {
169		# report_sample_char<-r_sample_char
170	3x	report_sample_char <- object
171	3x	if (nrow(report_sample_char@data) == 0) {
172	!	funout(gettext("No information for these samples during the selected period\n",
173	!	domain = "R-stacomiR"), arret = TRUE)
174		}
175	3x	vue_ope_lot = report_sample_char@data # on recupere le data.frame
176	3x	nom_variable = report_sample_char@par@data$par_nom[report_sample_char@par@data$par_code %in%
177	3x	report_sample_char@par@par_selected]
178		# stopifnot(length(nom_variable)==1)
179	3x	vue_ope_lot$ope_dic_identifiant = as.factor(vue_ope_lot$ope_dic_identifiant)
180	3x	vue_ope_lot$dev_code = as.factor(vue_ope_lot$dev_code)
181	3x	vue_ope_lot$car_val_identifiant = as.factor(vue_ope_lot$car_val_identifiant)
182	3x	vue_ope_lot$car_par_code = as.factor(vue_ope_lot$car_par_code)
183	3x	vue_ope_lot$ope_identifiant = as.factor(vue_ope_lot$ope_identifiant)
184	3x	vue_ope_lot$lot_pere = as.factor(vue_ope_lot$lot_pere)
185	3x	vue_ope_lot$val_libelle = as.factor(vue_ope_lot$val_libelle)
186	3x	vue_ope_lot$lot_tax_code = as.factor(vue_ope_lot$lot_tax_code)
187	3x	vue_ope_lot <- fun_date_extraction(data = vue_ope_lot, nom_coldt = "ope_date_debut",
188	3x	annee = TRUE, mois = TRUE, quinzaine = TRUE, semaine = TRUE, jour_an = TRUE,
189	3x	jour_mois = FALSE, heure = FALSE)
190		# vue_ope_lot=stacomirtools::chnames(vue_ope_lot,
191		# c('ope_identifiant','lot_identifiant','ope_dic_identifiant','lot_pere',
192		# 'ope_date_debut','ope_date_fin','lot_effectif','lot_quantite','lot_tax_code','lot_std_code','tax_nom_latin','std_libelle','dev_code','dev_libelle','par_nom','car_par_code','car_methode_obtention','car_val_identifiant',
193		# 'car_valeur_quantitatif','val_libelle',
194		# 'annee','mois','quinzaine','semaine','jour_365'),
195		# c('ope','lot','dic','lot_pere',
196		# 'date','date_fin','effectif','quantite','lot_tax_code','lot_std_code','tax','std','dev_code','dev','par','car_par_code','meth','val','val_quant','val_libelle',
197		# 'annee','mois','quinzaine','semaine','jour'))
198		# vue_ope_lot=vue_ope_lot[,c('ope','lot','dic','lot_pere','date','effectif','quantite','tax','std','dev','par','meth','val','val_quant','val_libelle',
199		# 'annee','mois','quinzaine','semaine','jour')]
200	3x	report_sample_char@data <- vue_ope_lot
201	3x	assign("report_sample_char", report_sample_char, envir_stacomi) #assign('report_sample_char',vue_ope_lot,envir_stacomi)
202	3x	if (!silent)
203	!	funout(gettext("To obtain the table, type : report_sample_char=get('report_sample_char',envir_stacomi)\n",
204	!	domain = "R-stacomiR"))
205	3x	return(report_sample_char)
206		})
207
208
209		#' Plots of various type for reportcarlot
210		#' @param x An object of class report_sample_char
211		#' @param plot.type One of '1','violin plot'. Defaut to \code{1} , can also be \code{2} boxplot or
212		#' \code{3} points.
213		#' @param silent Stops displaying the messages
214		#' @return Nothing, called for its side effect, plotting
215		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
216		#' @aliases plot.report_sample_char
217		#' @export
218		setMethod("plot", signature(x = "report_sample_char", y = "missing"), definition = function(x,
219		plot.type = "1", silent = FALSE) {
220		# report_sample_char<-r_sample_char;require(ggplot2);plot.type='1'
221		# browser()
222	6x	report_sample_char <- x
223	6x	plot.type <- as.character(plot.type) # to pass also characters
224	6x	if (!plot.type %in% c("1", "2", "3"))
225	!	stop("plot.type must be 1,2,3")
226	6x	if (exists("report_sample_char", envir_stacomi)) {
227	3x	report_sample_char <- get("report_sample_char", envir_stacomi)
228		} else {
229	3x	if (!silent)
230	!	funout(gettext("You need to launch computation first, clic on calc\n",
231	!	domain = "R-stacomiR"), arret = TRUE)
232		}
233	6x	name_param <- report_sample_char
234	6x	if (plot.type == 1) {
235	2x	g <- ggplot(report_sample_char@data, aes(x = car_valeur_quantitatif))
236	2x	g <- g + stat_density(aes(ymax = ..density.., ymin = -..density..), fill = "grey50",
237	2x	colour = "grey10", geom = "ribbon", position = "identity") + facet_grid(. ~
238	2x	annee) + coord_flip()
239	2x	print(g)
240	2x	assign("g", g, envir_stacomi)
241	2x	if (!silent)
242	!	funout(gettext("To obtain the graphical object, type : g<-get(\"g\",envir_stacomi)\n",
243	!	domain = "R-stacomiR"))
244	4x	} else if (plot.type == 2) {
245	2x	g <- ggplot(report_sample_char@data)
246	2x	g <- g + geom_boxplot(aes(x = mois, y = car_valeur_quantitatif, fill = std_libelle)) +
247	2x	facet_grid(annee ~ .)
248	2x	print(g)
249	2x	assign("g", g, envir_stacomi)
250	2x	if (!silent)
251	!	funout(gettext("To obtain the graphical object, type : g<-get(\"g\",envir_stacomi)\n",
252	!	domain = "R-stacomiR"))
253
254	2x	} else if (plot.type == 3) {
255	2x	g <- ggplot(report_sample_char@data)
256	2x	g <- g + geom_point(aes(x = ope_date_debut, y = car_valeur_quantitatif))
257	2x	print(g)
258	2x	assign("g", g, envir_stacomi)
259	2x	if (!silent)
260	!	funout(gettext("To obtain the graphical object, type : g<-get(\"g\",envir_stacomi)\n",
261	!	domain = "R-stacomiR"))
262		}
263	6x	return(invisible(NULL))
264		})
265
266		#' summary for report_sample_char
267		#'
268		#' @param object An object of class \code{\link{report_sample_char-class}}
269		#' @param silent Should the program stay silent or display messages, default FALSE
270		#' @param ... Additional parameters
271		#' @return Nothing, called for its side effect of printing a summary
272		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
273		#' @aliases summary.report_sample_char
274		#' @export
275		setMethod("summary", signature = signature(object = "report_sample_char"), definition = function(object,
276		silent = FALSE, ...) {
277	!	Hmisc::describe(object@data)
278	!	return(invisible(NULL))
279		})
280
281		#' Method to print the command line of the object
282		#' @param x An object of class report_sample_char
283		#' @param ... Additional parameters passed to print
284		#' @return NULL
285		#' @author cedric.briand
286		#' @aliases print.report_sample_char
287		#' @export
288		setMethod("print", signature = signature("report_sample_char"), definition = function(x,
289		...) {
290	1x	sortie1 <- "report_sample_char=new('report_sample_char')"
291	1x	sortie2 <- stringr::str_c("report_sample_char <- choice_c(report_sample_char,",
292	1x	"dc=c(", stringr::str_c(x@dc@dc_selected, collapse = ","), "),", "taxa=c(",
293	1x	stringr::str_c(shQuote(x@taxa@data$tax_nom_latin), collapse = ","), "),",
294	1x	"stage=c(", stringr::str_c(shQuote(x@stage@stage_selected), collapse = ","),
295	1x	"),", "par=c(", stringr::str_c(shQuote(x@par@par_selected), collapse = ","),
296	1x	"),", "horodatedebut=", shQuote(strftime(x@horodatedebut@horodate, format = "%d/%m/%Y %H-%M-%S")),
297	1x	",horodatefin=", shQuote(strftime(x@horodatefin@horodate, format = "%d/%m/%Y %H-%M-%S")),
298		")")
299		# removing backslashes
300	1x	funout(sortie1)
301	1x	funout(stringr::str_c(sortie2, ...))
302	1x	return(invisible(NULL))
303		})
304

1		#' Counts of number per taxa/stages
2		#'
3		#' This class is used to make the assessment of all species, and their number. It is intended
4		#' as a simple way to check what fishes are present (taxa + development stage). It was altered to include ref_taxa,
5		#' to allow excluding some of the most numerous taxa from reports. The taxa is reported unless
6		#' a taxa has several stages, in which case the different stages for the taxa will be reported
7		#' Using the split arguments
8		#' the calc method of the class will count numbers, subsamples are not accounted for in the Overview.
9		#' The split argument currently takes values year or month. The class is intended to be used over long periods
10		#' e.g years. The plot method writes either an histogram or a pie chart of number per
11		#' year/week/month.
12		#' @slot dc an object of class \link{ref_dc-class}
13		#' @slot taxa Object of class \link{ref_taxa-class}: the species
14		#' @slot start_year Object of class \code{\link{ref_year-class}}
15		#' @slot end_year Object of class \code{\link{ref_year-class}}
16		#' @slot data \code{data.frame}
17		#' @slot calcdata \code{data.frame} with data processed by the calc method
18		#' @slot split Object of class \code{\link{ref_list-class}} ref_list referential class choose within a list
19		#' @include ref_taxa.R
20		#' @include ref_dc.R
21		#' @include ref_list.R
22		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
23		#' @family report Objects
24		#' @aliases report_species
25		#' @example inst/examples/report_species-example.R
26		#' @keywords classes
27		#' @export
28		setClass(Class = "report_species", representation = representation(dc = "ref_dc", taxa = "ref_taxa",
29		start_year = "ref_year", end_year = "ref_year", data = "data.frame", calcdata = "data.frame",
30		split = "ref_list"), prototype = prototype(dc = new("ref_dc"), taxa = new("ref_taxa"), start_year = new("ref_year"),
31		end_year = new("ref_year"), data = data.frame(), calcdata = data.frame(), split = new("ref_list")))
32
33
34		#' connect method for report_species
35		#' @param object An object of class report_species
36		#' @param silent Boolean, if TRUE, information messages are not displayed
37		#' @return An object of class \link{report_species-class} with data slot filled with slot data \code{@data} filled
38		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
39		#' @aliases connect.report_species
40		setMethod("connect", signature = signature("report_species"), definition = function(object,
41		silent = FALSE) {
42	7x	bilesp <- object
43	7x	requete = new("RequeteDB")
44	7x	start_year = bilesp@start_year@year_selected
45	7x	end_year = bilesp@end_year@year_selected
46	7x	requete@sql = paste("SELECT lot_identifiant, ope_date_debut, ope_date_fin,",
47	7x	" lot_effectif, lot_tax_code, lot_std_code, tax_nom_latin, std_libelle,",
48	7x	" date_part('year', ope_date_debut) as annee,", " date_part('month',ope_date_debut) as mois,",
49	7x	" date_part('week',ope_date_debut) as semaine", " FROM ",
50	7x	get_schema(),
51	7x	"t_operation_ope", " INNER JOIN ",
52	7x	get_schema(),
53	7x	"t_lot_lot ON ope_identifiant=lot_ope_identifiant", " INNER JOIN ref.tr_taxon_tax on tax_code=lot_tax_code",
54	7x	" INNER JOIN ref.tr_stadedeveloppement_std on std_code=lot_std_code", " WHERE extract(year from ope_date_debut)>=",
55	7x	start_year, " AND extract(year from ope_date_debut)<=", end_year, " AND ope_dic_identifiant in",
56	7x	vector_to_listsql(bilesp@dc@dc_selected), "AND lot_tax_code in", vector_to_listsql(bilesp@taxa@taxa_selected),
57	7x	" AND lot_lot_identifiant IS NULL",
58	7x	" AND lot_effectif IS NOT NULL", sep = "")
59	7x	requete <- stacomirtools::query(requete)
60	7x	if (requete@status != "success")
61	7x	funout(gettext("Query failed for for report species \n", domain = "R-stacomiR"),
62	7x	arret = TRUE)
63	7x	bilesp@data <- requete@query
64	7x	if (!silent)
65	7x	funout(gettext("data loaded from the database for report_species"))
66	7x	assign("bilesp", bilesp, envir = envir_stacomi)
67	7x	return(bilesp)
68		})
69
70
71		#' command line interface for \link{report_species-class}
72		#'
73		#' @param object An object of class \link{report_species-class}
74		#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,ref_dc-method}
75		#' @param taxa Either 'all' (default) or a species name in latin or the SANDRE code for species (ie 2038=Anguilla anguilla),
76		#' it should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,ref_taxa-method}
77		#' @param start_year The starting the first year, passed as character or integer
78		#' @param end_year the finishing year
79		#' @param split one of c('none','week','month','year')
80		#' @param silent Boolean, if TRUE, information messages are not displayed
81		#' @return An object of class \link{report_species-class} with data selected
82		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
83		#' @aliases choice_c.report_species
84		setMethod("choice_c", signature = signature("report_species"),
85		definition = function(object,
86		dc,
87		taxa="all",
88		split = "none",
89		start_year,
90		end_year,
91		silent = FALSE) {
92		# code for debug using example
93		# dc=c(5,6);taxa = c(start_year='1996';end_year='2016';split='none';silent=TRUE
94	7x	bilesp <- object
95	7x	bilesp@dc = charge(bilesp@dc)
96		# loads and verifies the dc this will set dc_selected slot
97	7x	bilesp@dc <- choice_c(object = bilesp@dc, dc)
98
99	7x	bilesp@taxa <-
100	7x	charge_with_filter(object = bilesp@taxa, bilesp@dc@dc_selected)
101
102	7x	if (any(taxa=="all")) {
103		# taxa selected correspond to all loaded taxa for the dc
104	6x	bilesp@taxa@taxa_selected <- bilesp@taxa@data$tax_code
105		# Here we are not using the standard choice_c which assigns in envir_stacomi...
106	6x	assign("ref_taxa", bilesp@taxa, envir=envir_stacomi)
107		} else {
108	1x	bilesp@taxa <- choice_c(bilesp@taxa, taxa)
109		}
110	7x	bilesp@split = charge(object = bilesp@split, listechoice = c("none", "week",
111	7x	"month", "year"), label = gettext("choice of number in sample (one, several,all)",
112	7x	domain = "R-stacomiR")) # choix de la categorie d'effectif)
113	7x	bilesp@split <- choice_c(bilesp@split, selectedvalue = split)
114		# by default choice_c returns reflist but usefull to mimic gr.interface
115	7x	assign("refliste", bilesp@split, envir_stacomi)
116	7x	bilesp@start_year <- charge(object = bilesp@start_year, objectreport = "report_species")
117	7x	bilesp@start_year <- choice_c(object = bilesp@start_year, nomassign = "start_year",
118	7x	annee = start_year, silent = silent)
119	7x	bilesp@end_year@data <- bilesp@start_year@data
120	7x	bilesp@end_year <- choice_c(object = bilesp@end_year, nomassign = "end_year",
121	7x	annee = end_year, silent = silent)
122	7x	assign("bilesp", bilesp, envir = envir_stacomi)
123	7x	return(bilesp)
124		})
125
126
127		#' charge method for report_species
128		#'
129		#' Verifies the content of objects when the graphical interface is used, it is not necessary
130		#' to call the charge method if the choice_c method has been used
131		#' @param object An object of class \link{report_species-class}
132		#' @param silent Stops displaying the messages.
133		#' @return report_species with slots filled by user choice
134		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
135		#' @return An object of class \link{report_species-class} with slots filled from values assigned in \code{envir_stacomi} environment
136		#' @aliases charge.report_species
137		#' @keywords internal
138		setMethod("charge", signature = signature("report_species"), definition = function(object,
139		silent = FALSE) {
140	6x	if (!silent)
141	6x	funout(gettext("Checking objects and launching query\n", domain = "R-stacomiR"))
142	6x	bilesp <- object
143	6x	if (exists("ref_dc", envir_stacomi)) {
144	6x	bilesp@dc <- get("ref_dc", envir_stacomi)
145		} else {
146	!	funout(gettext("You need to choose a counting device, clic on validate\n",
147	!	domain = "R-stacomiR"), arret = TRUE)
148		}
149	6x	if (exists("ref_taxa", envir_stacomi)) {
150	6x	bilesp@taxa <- get("ref_taxa", envir_stacomi)
151		} else {
152	!	funout(
153	!	gettext("You need to choose a taxa, clic on validate\n", domain = "R-stacomiR"),
154	!	arret = TRUE
155		)
156		}
157	6x	if (exists("start_year", envir_stacomi)) {
158	6x	bilesp@start_year <- get("start_year", envir_stacomi)
159		} else {
160	!	funout(gettext("You need to choose the starting year\n", domain = "R-stacomiR"),
161	!	arret = TRUE)
162		}
163	6x	if (exists("end_year", envir_stacomi)) {
164	6x	bilesp@end_year <- get("end_year", envir_stacomi)
165		} else {
166	!	funout(gettext("You need to choose the ending year\n", domain = "R-stacomiR"),
167	!	arret = TRUE)
168		}
169
170	6x	if (exists("refliste", envir_stacomi)) {
171	6x	bilesp@split <- get("refliste", envir_stacomi)
172		} else {
173	!	funout(gettext("You need to choose a size class\n", domain = "R-stacomiR"),
174	!	arret = TRUE)
175		}
176	6x	assign("bilesp", bilesp, envir_stacomi)
177	6x	if (!silent)
178	6x	funout(gettext("A report_species object was stored into envir_stacomi environment : write bilesp=get('bilesp',envir_stacomi)",
179	6x	domain = "R-stacomiR"))
180	6x	return(bilesp)
181		})
182
183
184
185		#' calcule method for report_species
186		#'
187		#' The number will be split according to the split argument passed to the class, e.g.
188		#' per year or month or week. Data from different DC will be grouped. Counts are given per taxa,
189		#' unless there are several stages, in which case the counts correspond to taxa + stage.
190		#' @param object An object of class \link{report_species-class}
191		#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
192		#' @return An object of class \link{report_species-class} with calcdata slot filled.
193		#' @aliases calcule.report_species
194		setMethod("calcule", signature = signature("report_species"), definition = function(object,
195		silent = FALSE) {
196	5x	bilesp <- object
197	5x	DC = as.numeric(bilesp@dc@dc_selected)
198		# update of refliste which does not need calcul button pushed
199	5x	tableEspeces = bilesp@data
200	5x	if (nrow(tableEspeces) == 0)
201	5x	funout(gettext("No fish in the database for this period\n", domain = "R-stacomiR"),
202	5x	arret = TRUE)
203	5x	tableEspeces$taxa_stage = paste(tableEspeces$tax_nom_latin, tableEspeces$std_libelle,
204	5x	sep = "_")
205		# only keeping taxa stage for species with several stages
206	5x	nbstage = tapply(tableEspeces$tax_nom_latin, tableEspeces$taxa_stage, function(X) (length(unique(X))))
207		# we currently have taxa+stage, below this is replaces with taxa unless
208		# there are more than one stage per species
209	5x	if (length(nbstage[nbstage > 1]) > 0) {
210	!	les_multiples = names(nbstage[nbstage > 1])
211	!	tableEspeces[!tableEspeces$taxa_stage %in% les_multiples, "taxa_stage"] <- tableEspeces$tax_nom_latin[!tableEspeces$taxa_stage %in%
212	!	les_multiples]
213	5x	} else tableEspeces$taxa_stage <- tableEspeces$tax_nom_latin
214	5x	if (min(tableEspeces$lot_effectif) < 0) {
215	5x	if (!silent)
216	5x	funout(gettext("Some negative counts are transformed into positive ones\n",
217	5x	domain = "R-stacomiR"))
218	5x	tableEspeces$lot_effectif = abs(tableEspeces$lot_effectif)
219		}
220	5x	sumEspeces = switch(bilesp@split@selectedvalue, year = as.data.frame(xtabs(lot_effectif ~
221	5x	taxa_stage + annee, data = tableEspeces)), month = as.data.frame(xtabs(lot_effectif ~
222	5x	taxa_stage + mois, data = tableEspeces)), week = as.data.frame(xtabs(lot_effectif ~
223	5x	taxa_stage + semaine, data = tableEspeces)), none = as.data.frame(xtabs(lot_effectif ~
224	5x	taxa_stage, data = tableEspeces)))
225	5x	colnames(sumEspeces)[colnames(sumEspeces) == "Freq"] <- "Effectif" # pas forcement le m nb de colonnes
226	5x	if (bilesp@split@selectedvalue != "none") {
227	5x	colnames(sumEspeces)[2] <- bilesp@split@selectedvalue
228		}
229	5x	bilesp@calcdata <- sumEspeces
230	5x	assign("bilesp", bilesp, envir_stacomi)
231	5x	return(bilesp)
232		})
233
234		#' Plot method for report_species
235		#'
236		#' @param x An object of class \link{report_species-class}
237		#' @param plot.type Default pie
238		#' #' \itemize{
239		#' \item{plot.type='pie': A pie}'
240		#' \item{plot.type='barchart' : A barchart}
241		#' }
242		#' @param color Default NULL, a vector of colors of length corresponding to the number of taxa-stage
243		#' different values, use unique(bilesp@calcdata$taxa_stage) to get that number. The color applies to both
244		#' pie and barchart plots
245		#' @param silent Stops displaying the messages
246		#' @return Nothing, called for producing plots
247		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
248		#' @aliases plot.reportreport_species
249		#' @export
250		setMethod("plot", signature(x = "report_species", y = "missing"), definition = function(x,
251		plot.type = "pie", color = NULL, silent = FALSE) {
252	3x	bilesp <- x
253	3x	if (nrow(bilesp@calcdata) == 0)
254	3x	stop("No data in the calcdata slot, did you forget to run calculations ?")
255	3x	nb = length(unique(bilesp@calcdata$taxa_stage))
256	3x	g <- ggplot(bilesp@calcdata)
257	3x	g <- g + geom_col(aes(x = "", y = Effectif, fill = taxa_stage)) + ggtitle(paste("report Especes, DC",
258	3x	str_c(bilesp@dc@dc_selected, collapse = "+"), bilesp@start_year@year_selected,
259	3x	"=>", bilesp@end_year@year_selected)) + xlab("") + ylab(gettext("Number",
260	3x	domain = "R-stacomiR"))
261		# theme(axis.line.x=element_line('none'))+theme(axis.title.x=
262		# element_text('none'))
263	3x	if (bilesp@split@selectedvalue != "none") {
264	3x	facet <- switch(bilesp@split@selectedvalue, year = as.formula(~year), month = as.formula(~month),
265	3x	week = as.formula(~week))
266	3x	g <- g + facet_wrap(facet, scales = "fixed")
267		}
268	3x	if (is.null(color)) {
269	2x	if (nb <= 8) {
270	!	g <- g + scale_fill_brewer(palette = "Accent", name = gettext("Taxa-stage",
271	!	domain = "R-stacomiR"))
272	2x	} else if (nb <= 12) {
273	!	p <- g + scale_fill_brewer(palette = "Set3", name = gettext("Taxa-stage",
274	!	domain = "R-stacomiR"))
275		} else {
276	2x	g <- g + scale_fill_manual(values = grDevices::rainbow(nb), name = gettext("Taxa-stage",
277	2x	domain = "R-stacomiR"))
278		}
279		} else {
280		# color is not null
281	1x	if (length(color) != nb)
282	1x	stop(gettextf("The vector of color should be of length %s", domain = "R-stacomiR",
283	1x	nb))
284	1x	g <- g + scale_fill_manual(values = color, gettext("Taxa-stage", domain = "R-stacomiR"))
285		}
286	3x	if (plot.type == "barplot") {
287	2x	print(g)
288	2x	assign("g", g, envir = envir_stacomi)
289	3x	} else if (plot.type == "pie") {
290	1x	g <- g + coord_polar(theta = "y", start = pi) + xlab("") + ylab("")
291	1x	print(g)
292	1x	assign("g", g, envir = envir_stacomi)
293		} else {
294	!	funout(gettext("plot.type should be one of barplot or pie", domain = "R-stacomiR"),
295	!	arret = TRUE)
296		}
297	3x	if (!silent)
298	3x	funout(gettext("the object g has been assigned to envir_stacomi", domain = "R-stacomiR"))
299
300	3x	return(invisible(NULL))
301		})
302
303
304
305		#' summary for report_species
306		#'
307		#' generate csv and html output in the user data directory
308		#' @param object An object of class \code{\link{report_species-class}}
309		#' @param silent Should the program stay silent or display messages, default FALSE
310		#' @return nothing, but writes summary in \code{get("datawd", envir = envir_stacomi)}, and prints output
311		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
312		#' @aliases summary.report_species
313		#' @export
314		setMethod("summary", signature = signature(object = "report_species"), definition = function(object,
315		silent = FALSE) {
316	1x	bilesp <- object
317	1x	if (nrow(bilesp@calcdata) == 0)
318	1x	stop("No data in the calcdata slot, did you forget to run calculations ?")
319	1x	loc <- str_c(str_c(bilesp@dc@dc_selected, collapse = "+"), bilesp@start_year@year_selected,
320	1x	bilesp@end_year@year_selected, sep = "_")
321
322	1x	path = file.path(normalizePath(path.expand(get("datawd", envir = envir_stacomi))),
323	1x	paste("tableEspece", loc, ".csv", sep = ""), fsep = "\\")
324	1x	res <- tryCatch(
325	1x	write.table(bilesp@calcdata, path, row.names = TRUE, col.names = TRUE, sep = ";",
326	1x	append = FALSE),
327	1x	error = function(e) e,
328	1x	finally =
329	1x	if (!silent) {
330	1x	funout(gettextf("writing of %s \n", path))
331	1x	funout(gettextf("attention, negative numbers were transformed into positive numbers"))
332		})
333	1x	if (inherits(res, "simpleError")) {
334	!	warnings("The table could not be reported, please change the working directory datawd with options(stacomiR.path='path/to/directory'")
335		}
336
337		})
338

1		#' Class 'ref_parqual'
2		#'
3		#' Class enabling to load the list of qualitative parameters and to select one
4		#' of them. It inherits from 'ref_par', uses its 'choice' method
5		#' @author cedric.briand@eptb-vilaine.fr
6		#' @slot valqual='data.frame' the list of qualitative parameters
7		#' @include ref_par.R
8		#' @family referential objects
9		setClass(Class = "ref_parqual", representation = representation(valqual = "data.frame"),
10		contains = "ref_par")
11
12		#' Loading method for Reparqual referential objects
13		#' @param object An object of class \link{ref_parqual-class}
14		#' @return An S4 object of class ref_parqual
15		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
16		#' @examples
17		#' \dontrun{
18		#' object=new('ref_parqual')
19		#' charge(object)
20		#' }
21		setMethod("charge", signature = signature("ref_parqual"), definition = function(object) {
22	1x	requete = new("RequeteDB")
23	1x	requete@sql = "select par_code, par_nom, par_unite, par_nature, par_definition, qal_valeurs_possibles from ref.tg_parametre_par
24	1x	INNER JOIN ref.tr_parametrequalitatif_qal ON tr_parametrequalitatif_qal.qal_par_code::text = tg_parametre_par.par_code::text"
25	1x	requete <- stacomirtools::query(requete)
26		# funout(gettext('The query to load parameters is done
27		# \n',domain='R-stacomiR'))
28	1x	object@data <- requete@query
29	1x	return(object)
30		})
31
32		#' Loading method for Reparqual referential objects searching only those parameters existing for a DC, a Taxon, and a stage
33		#' @param object An object of class \link{ref_parqual-class}
34		#' @param dc_selected The dc set in the report object
35		#' @param taxa_selected The taxa set in the report object
36		#' @param stage_selected The stage set in the report object
37		#' @return An S4 object of class \link{ref_parqual-class}
38		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
39		#' @examples
40		#' \dontrun{
41		#' dc_selected=6
42		#' taxa_selected=2038
43		#' stage_selected='AGJ'
44		#' object=new('ref_parqual')
45		#' charge_with_filter(object,dc_selected,taxa_selected,stage_selected)
46		#' }
47		setMethod("charge_with_filter", signature = signature("ref_parqual"), definition = function(object,
48		dc_selected, taxa_selected, stage_selected) {
49	8x	requete = new("RequeteDBwhere")
50	8x	requete@select = paste("SELECT DISTINCT ON (par_code) par_code, par_nom, par_unite, par_nature, par_definition, qal_valeurs_possibles", " FROM ",
51	8x	get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
52	8x	" JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
53	8x	" JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
54	8x	" JOIN ", get_schema(), "tj_caracteristiquelot_car on car_lot_identifiant=lot_identifiant",
55	8x	" JOIN ref.tg_parametre_par on par_code=car_par_code", " JOIN ref.tr_parametrequalitatif_qal ON tr_parametrequalitatif_qal.qal_par_code::text = tg_parametre_par.par_code::text",
56	8x	sep = "")
57	8x	requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected))
58	8x	requete@and = paste("and lot_tax_code in ", vector_to_listsql(taxa_selected),
59	8x	" and lot_std_code in ", vector_to_listsql(stage_selected), sep = "")
60	8x	requete@order_by = "ORDER BY par_code"
61	8x	requete <- stacomirtools::query(requete)
62	8x	object@data <- requete@query
63	8x	return(object)
64		})
65
66		#' Loads an additional dataset
67		#' this method is loaded to obtain the possible values of a qualitative parameter. Here data only contains one line
68		#' @param object An object of class \link{ref_parqual-class}
69		#' @return An S4 object of class \link{ref_parqual-class} with the valqual slot filled
70		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
71		#' @examples
72		#' \dontrun{
73		#' dc_selected=6
74		#'taxa_selected=2038
75		#' stage_selected='AGJ'
76		#' object=new('ref_parqual')
77		#' object<-charge(object)
78		#' charge_complement(object)
79		#' }
80		setMethod("charge_complement", signature = signature("ref_parqual"), definition = function(object) {
81	2x	requete = new("RequeteDB")
82	2x	requete@sql = paste("select * from ref.tr_valeurparametrequalitatif_val", " WHERE val_qal_code in ",
83	2x	vector_to_listsql(object@par_selected), " ORDER BY val_rang", sep = "")
84	1x	requete <- stacomirtools::query(requete)
85		# funout(gettext('The query to load parameters is done
86		# \n',domain='R-stacomiR'))
87	1x	object@valqual <- requete@query
88	1x	return(object)
89		})
90
91

1		#' function to print and save statistics in .csv and .html formats for report_mig and report_mig_mult class
2		#' @param tableau A table with the following columns : No.pas,debut_pas,fin_pas,
3		#' ope_dic_identifiant,lot_tax_code,lot_std_code,type_de_quantite,MESURE,CALCULE,
4		#' EXPERT,PONCTUEL,Effectif_total,taux_d_echappement,coe_valeur_coefficient
5		#' @note this function is intended to be called from within the summary method
6		#' @param time.sequence Passed from report_mig or report_mig_mult
7		#' @param taxa Taxa
8		#' @param stage The Stage
9		#' @param DC The counting device
10		#' @param resum A summary table generated by funstat
11		#' @param silent If TRUE, all messages turned off (except warnings and errors)
12		#' @return No return value, called for side effects
13		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
14		funtable = function(tableau, time.sequence, taxa, stage, DC, resum, silent) {
15	8x	annee = paste(unique(strftime(as.POSIXlt(time.sequence), "%Y")), collapse = ",")
16	8x	tableau$debut_pas <- as.character(tableau$debut_pas)
17	8x	path1 = file.path(path.expand(get("datawd", envir = envir_stacomi)), paste(DC,
18	8x	"_", taxa, "_", stage, "_", annee, ".csv", sep = ""), fsep = "/")
19	8x	path1html = file.path(path.expand(get("datawd", envir = envir_stacomi)), paste(DC,
20	8x	"_", taxa, "_", stage, "_", annee, ".html", sep = ""), fsep = "/")
21	8x	res <- tryCatch(
22	8x	write.table(tableau, file = path1, row.names = FALSE, col.names = TRUE, sep = ";")
23	8x	, error = function(e) e,
24	8x	finally =
25	8x	if (!silent) funout(gettext("Writing of %s \n", path1, domain = "R-stacomiR"))
26
27		)
28
29
30
31	8x	res <- tryCatch(
32	8x	suppressWarnings(funhtml(data = tableau, caption = paste(DC, "_", taxa, "_",
33	8x	stage, "_", annee, ".csv", sep = ""), top = TRUE, outfile = path1html, clipboard = FALSE,
34	8x	append = FALSE, digits = 2)),
35	8x	error = function(e) e,
36	8x	finally =
37	8x	if (!silent) funout(gettextf("writing of %s\n", path1html))
38
39		)
40	8x	if (!is.null(resum)) {
41	6x	path2 = file.path(path.expand(get("datawd", envir = envir_stacomi)), paste("res",
42	6x	DC, "_", taxa, "_", stage, "_", annee, ".csv", sep = ""), fsep = "/")
43	6x	resum1 <- resum
44	6x	resum$id = rownames(resum)
45	6x	path2html = file.path(path.expand(get("datawd", envir = envir_stacomi)),
46	6x	paste("res", annee, ".html", sep = ""), fsep = "/")
47	6x	res <- tryCatch({
48	6x	write.table(resum1, path2, row.names = FALSE, col.names = TRUE, sep = ";")
49	6x	suppressWarnings(funhtml(data = resum, caption = paste("Sommes mensuelles",
50	6x	annee), top = TRUE, outfile = path2html, clipboard = FALSE, append = TRUE,
51	6x	digits = 2))
52	6x	}, error = function(e) e,
53	6x	finally ={
54	6x	if (!silent) funout(gettextf("writing of %s\n", path2))
55	6x	if (!silent) funout(gettextf("writing of %s\n", path2html))
56		})
57	6x	if (inherits(res, "simpleError")) {
58	!	warnings("The table could not be reported, please change the working directory datawd with options(stacomiR.path='path/to/directory'")
59		}
60		}
61	8x	return(invisible(NULL))
62		}
63
64

1		#' ref_textbox referencial class
2		#'
3		#' allows to a put a value within a glabel
4		#' @author cedric.briand@eptb-vilaine.fr
5		#' @slot title='character' the title of the box giving the possible choices
6		#' @slot labels the logical parameters choice
7		#' @slot checked a vector
8		setClass(Class = "ref_textbox", representation = representation(title = "character",
9		label = "character"))
10
11		#' Loading method for ref_textbox referential objects
12		#' @param object An object of class \link{ref_textbox-class}
13		#' @param title A title for the frame
14		#' @param label A label for the TextBox
15		#' @return An S4 object of class \link{ref_textbox-class}
16		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
17		#' @examples
18		#' \dontrun{
19		#' object=new('ref_textbox')
20		#' charge(object,title='un titre',label='20')
21		#' }
22		setMethod("charge", signature = signature("ref_textbox"), definition = function(object,
23		title, label) {
24	!	object@title = title
25	!	object@label = label
26	!	return(object)
27		})
28
29
30		#' Choice_c method for ref_textbox referential objects
31		#'
32		#' @param object An object of class \link{ref_textbox-class}
33		#' @param value The value to set
34		#' @param nomassign The name with which the object will be assigned in envir_stacomi
35		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
36		#' @return An S4 object of class \link{ref_textbox-class} label selected
37		setMethod("choice_c", signature = signature("ref_textbox"), definition = function(object,
38		value, nomassign = "ref_textbox") {
39	8x	object@label <- value
40	8x	assign(nomassign, object, envir_stacomi)
41	8x	return(object)
42		})

1		#' Class 'ref_list'
2		#'
3		#' Enables to load a 'ref_list' object from a list given by a 'report' object
4		#' @param liste choice='character' A vector of character to choose within a droplist
5		#' @param label='character' the title of the box
6		#' @section Objects from the Class: Objects can be created by calls of the form
7		#' \code{new('ref_list', listechoice, label)}. \describe{
8		#' \item{list('listechoice')}{Object of class \code{'character'}}\item{:}{Object
9		#' of class \code{'character'}} \item{list('label')}{Object of class
10		#' \code{'character'}}\item{:}{Object of class \code{'character'}} }
11		#' @author cedric.briand@eptb-vilaine.fr
12		#' @keywords internal
13		#' @family referential objects
14		setClass(Class = "ref_list", representation = representation(listechoice = "character",
15		selectedvalue = "character", label = "character"))
16
17
18		#' Loading method for ref_list referential objects
19		#' @aliases charge.ref_list
20		#' @return An S4 object of class \link{ref_list-class}
21		#' @param object An object of class \link{ref_list-class}
22		#' @param listechoice A character vector setting the possible values in which the user can select
23		#' @param label A label for refliste
24		#' @return An S4 object of class \link{ref_list-class}
25		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
26		#' @examples
27		#' \dontrun{
28		#' object=new('ref_list')
29		#' charge(object)
30		#' }
31		setMethod("charge", signature = signature("ref_list"), definition = function(object,
32		listechoice, label) {
33	11x	object@listechoice = listechoice
34	11x	object@label = label
35	11x	return(object)
36		})
37
38
39		#' Choice_c method for ref_list referential objects
40		#' @aliases choice_c.ref_list
41		#' @param object An object of class \link{ref_list-class}
42		#' @param selectedvalue the value selected in the combo
43		#' @return An S4 object of class \link{ref_list-class}
44		#' @note the choice method assigns an object of class refList named ref_list in the environment envir_stacomi
45		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
46		#' @examples
47		#' \dontrun{
48		#' object=new('ref_list')
49		#' object<-charge(object,vecteur=c('1','2'),label='please choose')
50		#' object<-choice_c(object)
51		#' }
52		setMethod("choice_c", signature = signature("ref_list"), definition = function(object,
53		selectedvalue) {
54	11x	if (length(selectedvalue) > 1)
55	!	stop("valeurchoisie should be a vector of length 1")
56	11x	if (inherits(selectedvalue, "numeric"))
57	!	selectedvalue <- as.character(selectedvalue)
58		# the charge method must be performed before
59
60	11x	if (!selectedvalue %in% object@listechoice) {
61	!	stop(stringr::str_c("The selected valeur,", selectedvalue, " not in the list of possible values :",
62	!	stringr::str_c(object@listechoice, collapse = ",")))
63		} else {
64	11x	object@selectedvalue <- selectedvalue
65		}
66	11x	return(object)
67		})

1		#' Function to calculate statistics per month
2		#' @param tableau A table with the following columns : No.pas,debut_pas,fin_pas,
3		#' ope_dic_identifiant,lot_tax_code,lot_std_code,type_de_quantite,MESURE,CALCULE,
4		#' EXPERT,PONCTUEL,Effectif_total,taux_d_echappement,coe_valeur_coefficient
5		#' @note this function is intended to be called from within the summary method
6		#' @param time.sequence Passed from report_mig or report_mig_mult
7		#' @param taxa Taxa
8		#' @param stage The Stage
9		#' @param DC The counting device
10		#' @param silent Message displayed or not
11		#' @return No return value, called for side effects
12		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
13		#' @export
14		funstat = function(tableau, time.sequence, taxa, stage, DC, silent) {
15	11x	if (!silent)
16	4x	funout(gettext("Calculation of the monthly balance sheet\n", domain = "R-stacomiR"))
17	11x	mois = strftime(as.POSIXlt(time.sequence), "%m")
18	11x	moislab = unique(mois)
19	11x	annee = paste(unique(strftime(as.POSIXlt(time.sequence), "%Y")), collapse = ",")
20	11x	somme = tapply(tableau$Effectif_total, mois, sum, na.rm = TRUE) # sums
21	11x	moyennes_journalieres = tapply(tableau$Effectif_total, mois, mean, na.rm = TRUE) # means
22		# ecarts_types=tapply(tableau$Effectif_total, mois, sd, na.rm=TRUE) # std.
23		# deviations nombre=as.integer(tapply(tableau$Effectif_total, mois,
24		# function(x) sum(!is.na(x)))) # counts
25	11x	resum = rbind(somme, moyennes_journalieres) #,moyennes_journalieres,ecarts_types,nombre)
26	11x	if (taxa == "Anguilla anguilla" & stage == "civelle") {
27	2x	poids_depuis_effectif = tapply(tableau$poids_depuis_effectif, mois, sum,
28	2x	na.rm = TRUE)
29	2x	poids_mesure = tapply(tableau$Poids_total, mois, sum, na.rm = TRUE)
30	2x	Poids_total = poids_depuis_effectif + poids_mesure
31	2x	resum = rbind(somme, moyennes_journalieres, poids_depuis_effectif, poids_mesure,
32	2x	Poids_total)
33		}
34	11x	resum = resum[, moislab, drop = FALSE]
35	11x	resum = as.data.frame(resum)
36	11x	resum["somme", "year"] = round(sum(tableau$Effectif_total, na.rm = TRUE), 2)
37	11x	resum["moyennes_journalieres", "year"] = mean(tableau$Effectif_total, na.rm = TRUE)
38		# resum['moyennes_journalieres','year']=round(mean(tableau$Effectif_total,
39		# na.rm=TRUE),2)
40		# resum['ecarts_types','report']=round(sd(tableau$Effectif_total,
41		# na.rm=TRUE),2)
42	11x	if (taxa == "Anguilla anguilla" & stage == "civelle") {
43	2x	resum["poids_depuis_effectif", "year"] = round(sum(tableau$poids_depuis_effectif,
44	2x	na.rm = TRUE), 2)
45	2x	resum["poids_mesure", "year"] = round(sum(tableau$Poids_total, na.rm = TRUE),
46	2x	2)
47	2x	resum["Poids_total", "year"] = round(sum(Poids_total, na.rm = TRUE), 2)
48		}
49	11x	resum = cbind(label = paste("DC", DC, taxa, stage, annee, sep = "_"), resum)
50		# funout(paste(DC,taxa,stage,annee,'\n'))
51		# funout(paste('DC','code_taxa','code_stage','annee','\n'))
52	11x	if (!silent) {
53	4x	funout(gettext("Calculation of the monthly balance sheet\n", domain = "R-stacomiR"))
54	4x	print(resum["somme", ])
55		}
56	11x	return(resum)
57		}

1		UNE_SECONDE = as.difftime(c("0:0:1"))
2
3		UNE_MINUTE = 60 * UNE_SECONDE
4
5		DIX_MINUTES = 10 * UNE_MINUTE
6
7		QUINZE_MINUTES = 15 * UNE_MINUTE
8
9		TRENTE_MINUTES = 30 * UNE_MINUTE
10
11		UNE_HEURE = 60 * UNE_MINUTE
12
13		DOUZE_HEURES = 12 * UNE_HEURE
14
15		UN_JOUR = 24 * UNE_HEURE
16
17		UNE_SEMAINE = 7 * UN_JOUR
18
19		DEUX_SEMAINES = 2 * UNE_SEMAINE
20
21		UN_MOIS = 30 * UN_JOUR
22
23		TROIS_MOIS = 91 * UN_JOUR
24
25		SIX_MOIS = 182 * UN_JOUR
26
27		UN_AN = 365 * UN_JOUR
28
29
30		Valeurref_timestep = c(
31		UNE_SECONDE,
32		UNE_MINUTE,
33		DIX_MINUTES,
34		QUINZE_MINUTES,
35		TRENTE_MINUTES,
36		UNE_HEURE,
37		DOUZE_HEURES,
38		UN_JOUR,
39		UNE_SEMAINE,
40		DEUX_SEMAINES,
41		UN_MOIS,
42		TROIS_MOIS,
43		SIX_MOIS,
44		UN_AN
45		)
46		Labelref_timestep = c(
47		"1 sec",
48		"1 min",
49		"10 min" ,
50		"15 min" ,
51		"30 min",
52		"1 h" ,
53		"12 h" ,
54		"1 jour" ,
55		"1 sem" ,
56		"2 sem" ,
57		"1 mois" ,
58		"3 mois" ,
59		"6 mois" ,
60		"1 an"
61		)
62		Lesref_timestep = data.frame("Valeurref_timestep" = Valeurref_timestep)
63		Lesref_timestep[, "Labelref_timestep"] = Labelref_timestep
64		rownames(Lesref_timestep) =
65		c(
66		"UNE_SECONDE",
67		"UNE_MINUTE",
68		"DIX_MINUTES",
69		"QUINZE_MINUTES",
70		"TRENTE_MINUTES",
71		"UNE_HEURE",
72		"DOUZE_HEURES",
73		"UN_JOUR",
74		"UNE_SEMAINE",
75		"DEUX_SEMAINES",
76		"UN_MOIS",
77		"TROIS_MOIS",
78		"SIX_MOIS",
79		"UN_AN"
80		)
81		rm(
82		UNE_SECONDE,
83		UNE_MINUTE,
84		DIX_MINUTES,
85		QUINZE_MINUTES,
86		TRENTE_MINUTES,
87		UNE_HEURE,
88		DOUZE_HEURES,
89		UN_JOUR,
90		UNE_SEMAINE,
91		DEUX_SEMAINES,
92		UN_MOIS,
93		TROIS_MOIS,
94		SIX_MOIS,
95		UN_AN,
96		Labelref_timestep
97		)
98
99
100		validity_ref_timestep = function(object)
101		{
102	24x	retValue = NULL
103	24x	rep1 = inherits(object@dateDebut[1], "POSIXlt")
104	24x	if (!rep1)
105	!	retValue = "object@dateDebut is not of class POSIXlt"
106	24x	rep2 = length(object@step_duration) == 1
107	24x	if (!rep2)
108	!	retValue = paste(retValue, "length(object@step_duration) !=1")
109	24x	rep3 = length(object@nb_step) == 1
110	24x	if (!rep3)
111	!	retValue = paste(retValue, "length(object@nb_step) !=1")
112	24x	rep4 = length(object@nocurrent_step) == 1
113	24x	if (!rep4)
114	!	retValue = paste(retValue, "length(object@nocurrent_step) !=1")
115	24x	return(ifelse(rep1 & rep2 & rep3 & rep4, TRUE, retValue))
116		}
117
118		#' Class "ref_timestep"
119		#'
120		#' Describes a time step
121		#'
122		#'
123		#' @section Objects from the Class: Objects can be created by calls of the form
124		#' \code{new("ref_timestep",
125		#' dateDebut="POSIXt",step_duration=numeric(),nb_step=numeric(),nocurrent_step=integer())}.
126		#' \describe{
127		#' \item{list("dateDebut")}{Object of class \code{"POSIXt"} Starting
128		#' date }
129		#' \item{:}{Object of class \code{"POSIXt"} Starting date }
130		#' \item{list("step_duration")}{Object of class \code{"numeric"} Step length
131		#' }\item{:}{Object of class \code{"numeric"} Step length }
132		#' \item{list("nb_step")}{Object of class \code{"numeric"} Number of steps
133		#' }\item{:}{Object of class \code{"numeric"} Number of steps }
134		#' \item{list("nocurrent_step")}{Object of class \code{"integer"} Number of the
135		#' current step }\item{:}{Object of class \code{"integer"} Number of the
136		#' current step } }
137		#' @author cedric.briand@eptb-vilaine.fr
138		#' @seealso \code{\linkS4class{ref_timestep_daily}}
139		#' @concept report Object
140		setClass(
141		Class = "ref_timestep",
142		representation =
143		representation(
144		dateDebut = "POSIXlt",
145		step_duration = "numeric",
146		nb_step = "numeric",
147		nocurrent_step = "integer"
148		),
149		validity = validity_ref_timestep,
150		prototype = prototype(
151		dateDebut = as.POSIXlt(Hmisc::truncPOSIXt(Sys.time(), "year")),
152		step_duration = as.numeric(86400),
153		nb_step = as.numeric(1),
154		nocurrent_step = as.integer(0)
155		)
156		)
157		# timestep= new("ref_timestep")
158
159
160		validity_ref_timestepChar = function(object)
161		{
162	!	rep1 = inherits(object@dateDebut[1],"POSIXlt")
163	!	rep2 = length(object@step_duration) == 1
164	!	rep3 = length(object@nb_step) == 1
165	!	rep4 = length(object@nocurrent_step) == 1
166	!	rep5 = object@step_duration %in% Lesref_timestep[, "Labelref_timestep"]
167	!	return(ifelse(rep1 &
168	!	rep2 &
169	!	rep3 & rep4 & rep5, TRUE, c(1:5)[!c(rep1, rep2, rep3, rep4, rep5)]))
170		}
171		#' Class "ref_timestepChar"
172		#'
173		#' Character to represent a ref_timestep
174		#'
175		#'
176		#' @section Objects from the Class: Objects can be created by calls of the form
177		#' \code{new("ref_timestepChar", \dots{})}
178		#' @author cedric.briand@eptb-vilaine.fr
179		#' @seealso \code{\linkS4class{ref_timestep}}
180		#' @keywords classes
181		#' @examples
182		#'
183		#' showClass("ref_timestepChar")
184		#'
185		setClass(
186		Class = "ref_timestepChar",
187		representation =
188		representation(
189		dateDebut = "POSIXlt",
190		step_duration = "character",
191		nb_step = "numeric",
192		nocurrent_step = "integer"
193		),
194		validity = validity_ref_timestepChar,
195		prototype = prototype(
196		dateDebut = as.POSIXlt(
197		strptime("2008-01-01 00:00:00", format = "%Y-%m-%d %H:%M:%S"),
198		tz = "GMT"
199		),
200		step_duration = as.character("1 jour"),
201		nb_step = as.numeric(1),
202		nocurrent_step = as.integer(0)
203		)
204		)
205
206		setAs("ref_timestepChar", "ref_timestep", # from to
207		function(from, to) {
208	!	index = Lesref_timestep[, "Labelref_timestep"] %in% from@step_duration
209	!	newstep_duration = Lesref_timestep[index, "Valeurref_timestep"]
210	!	new(
211	!	"ref_timestep",
212	!	dateDebut = from@dateDebut,
213	!	step_duration = newstep_duration,
214	!	nb_step = from@nb_step,
215	!	nocurrent_step = from@nocurrent_step
216		)
217		})
218		# timestep=as(timestepChar,"ref_timestep")
219
220
221		#' Gets the final horodate for an object of class \link{ref_timestep-class}
222		#' @param object An object of class \link{ref_timestep-class}
223		#' @return end_date, The final date corresponding to nb_step*time duration + initial date
224		#' @keywords internal
225		setMethod(
226		"end_date",
227		signature = signature("ref_timestep"),
228		definition = function(object) {
229	155x	end_date = object@dateDebut + object@step_duration * (object@nb_step)
230		# pour les pb de changement d'heure
231
232	155x	return(end_date)
233		}
234		)
235
236
237
238
239		#' Gets the year or a vector of years corresponding to the timestep ("ref_timestep") object
240		#' @param object An object of class \link{ref_timestep-class}
241		#' @return A numeric with year or vector of years corresponding to the timestep
242		#' @keywords internal
243		setMethod(
244		"get_year",
245		signature = signature("ref_timestep"),
246		definition = function(object) {
247	36x	dateFin = end_date(object)
248	36x	dateDebut = object@dateDebut
249	36x	seq = seq.POSIXt(from = dateDebut, to = dateFin, by = "day")
250	36x	seq = seq[-length(seq)]
251	36x	annees = unique(strftime(seq, "%Y"))
252	36x	return (as.numeric(annees))
253		}
254		)
255

1		#' Class 'ref_df'
2		#'
3		#' Representation of a fishway, contains description data of all fishways from
4		#' the database along with the selected fishways (df) (integer)
5		#' Objects from the Class: Objects can be created by calls of the form
6		#' \code{new('ref_df', df_selected=integer(), ouvrage=integer(),
7		#' data=data.frame())}.
8		#' @param df_selected Object of class \code{'integer'} The identifier of the fishway
9		#' @param ouvrage Object of class \code{'integer'} The attached dam
10		#' @param data Object of class \code{'data.frame'} Data concerning the fishway
11		#' @author cedric.briand@eptb-vilaine.fr
12		#' @family referential objects
13		setClass(Class = "ref_df", representation = representation(df_selected = "integer",
14		ouvrage = "integer", data = "data.frame"))
15
16		setValidity("ref_df", method = function(object) {
17		if (length(object@df_selected) != 0) {
18		if (nrow(object@data) > 0) {
19		concord <- object@df_selected %in% object@data$df
20		if (any(!concord)) {
21		return(paste("No data for DF", object@df_selected[!concord]))
22
23		} else {
24		return(TRUE)
25		}
26		} else {
27		return("You tried to set a value for df_selected without initializing the data slot")
28		}
29		} else return(TRUE)
30
31		})
32		#' Loading method for DF referential objects
33		#' @param object An object of class \link{ref_df-class}
34		#' @return An object of class ref_df with df loaded
35		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
36		#' @examples
37		#' \dontrun{
38		#' object=new('ref_df')
39		#' charge(object)
40		#' }
41		setMethod("charge", signature = signature("ref_df"), definition = function(object) {
42	25x	requete = new("RequeteDB")
43	25x	requete@sql = paste("select dis_identifiant as DF,", " dis_date_creation,", " dis_date_suppression,",
44	25x	" dis_commentaires,", " dif_ouv_identifiant,", " ouv_libelle,", " dif_code as DF_code,",
45	25x	" dif_localisation,", " dif_orientation,", " tdf_libelle as type_DF", " from ",
46	25x	get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositiffranchissement_dif ON dif_dis_identifiant=dis_identifiant",
47	25x	" JOIN ", get_schema(), "tj_dfesttype_dft ON dif_dis_identifiant=dft_df_identifiant",
48	25x	" JOIN ", get_schema(), "t_ouvrage_ouv on dif_ouv_identifiant=ouv_identifiant",
49	25x	" JOIN ref.tr_typedf_tdf ON tdf_code=dft_tdf_code", " ORDER BY dis_identifiant;",
50	25x	sep = "")
51	25x	requete <- stacomirtools::query(requete)
52	25x	object@data <- requete@query
53	25x	return(object)
54		})
55
56
57		#' Command line interface to choose a fishway
58		#'
59		#' the choice_c method is intended to have the same behaviour as choice (which creates a
60		#' widget in the graphical interface) but from the command line. The parameters for dF are transformed to integer as the ref_df only
61		#' takes integer in the df slots.
62		#' DF are third in hierarchy in the stacomi database Station>ouvrage>DF>DC>operation. This class is only used in the
63		#' report_df class.
64		#' @param object an object of class \link{ref_df-class}
65		#' @param df a character vector of df chosen
66		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
67		#' @return An object of class ref_df with df selected
68		#' @examples
69		#' \dontrun{
70		#' win=gwindow()
71		#' group=ggroup(container=win,horizontal=FALSE)
72		#' object=new('ref_df')
73		#' object<-charge(object)
74		#' objectreport=new('report_mig_mult')
75		#' choice_c(object=object,objectreport=objectreport,dc=1)
76		#' }
77		setMethod("choice_c", signature = signature("ref_df"), definition = function(object,
78		df) {
79		# object<-ref_df
80	27x	if (inherits(df, "numeric")) {
81	4x	df <- as.integer(df)
82	27x	} else if (inherits(df, "character")) {
83
84	2x	suppressWarnings(expr = {df <- as.integer(as.numeric(df))})
85
86		}
87	27x	if (any(is.na(df)))
88	27x	stop("NA values df")
89	26x	object@df_selected <- df
90	26x	object@ouvrage = object@data$dif_ouv_identifiant[object@data$df %in% object@df_selected]
91	26x	validObject(object)
92		# the method validObject verifies that the df is in the data slot of
93		# ref_df
94
95	26x	assign("ref_df", object, envir = envir_stacomi)
96	26x	return(object)
97		})

1		#' Report on operations
2		#'
3		#' Operations are monitoring operations generated between two dates. In the case of video monitoring
4		#' or similar, they can be instantaneous
5		#'
6		#' @include ref_dc.R
7		#' @section Objects from the Class: Objects can be created by calls of the form
8		#' \code{new("report_ope")}.
9		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
10		#' @concept report Object
11		#' @keywords classes
12		#' @aliases report_ope
13		#' @export
14		setClass(
15		Class = "report_ope",
16		representation = representation(
17		data = "data.frame",
18		dc = "ref_dc",
19		horodatedebut = "ref_horodate",
20		horodatefin = "ref_horodate"
21		),
22		prototype = prototype(
23		data = data.frame(),
24		dc = new("ref_dc"),
25		horodatedebut = new("ref_horodate"),
26		horodatefin = new("ref_horodate")
27
28		)
29		)
30
31		#' connect method for report_ope
32		#'
33		#' @param object An object of class \link{report_ope-class}
34		#' load data from the operation table, one dataset per DC
35		#' @param silent Boolean, TRUE removes messages.
36		#' @return An object of class \link{report_ope-class} with slot data \code{@data} filled
37		#' @aliases connect.report_ope
38		#' @author cedric.briand
39		setMethod(
40		"connect",
41		signature = signature("report_ope"),
42		definition = function(object, silent = FALSE) {
43		# object<-report_ope
44	20x	req <- new("RequeteDBwheredate")
45	20x	lesdc <- object@dc@dc_selected
46	20x	req@colonnedebut = "ope_date_debut"
47	20x	req@colonnefin = "ope_date_debut"
48	20x	req@order_by = "ORDER BY ope_dic_identifiant, ope_date_debut"
49	20x	req@datedebut <- object@horodatedebut@horodate
50		#below to be consistet with BIlanMigrationMult
51	20x	req@datefin <-
52	20x	as.POSIXlt(object@horodatefin@horodate + as.difftime("23:59:59"))
53	20x	req@select <-
54	20x	paste("SELECT * FROM ",
55	20x	get_schema(),
56	20x	"t_operation_ope ")
57	20x	req@and = paste("AND ope_dic_identifiant in",
58	20x	stringr::str_c("(", stringr::str_c(lesdc, collapse = ","), ")"))
59	20x	req <-
60	20x	stacomirtools::query(req)
61	20x	object@data <- req@query
62	20x	if (!silent)
63	!	funout(gettext("Loading data for operations", domain = "R-stacomiR"))
64	20x	return(object)
65		}
66		)
67
68
69		#' charge method for report_ope
70		#'
71		#'
72		#' used by the graphical interface to retrieve referential classes
73		#' assigned to envir_stacomi
74		#' @param object An object of class \link{report_ope-class}
75		#' @param silent Keeps program silent
76		#' @return An object of class \link{report_ope-class} with slots filled from values assigned in \code{envir_stacomi} environment
77		#' @aliases charge.report_ope
78		#' @author cedric.briand
79		#' @keywords internal
80		setMethod(
81		"charge",
82		signature = signature("report_ope"),
83		definition = function(object, silent = FALSE) {
84		# object<-report_ope
85	21x	if (exists("ref_dc", envir = envir_stacomi)) {
86	21x	object@dc <- get("ref_dc", envir = envir_stacomi)
87		} else {
88	!	funout(
89	!	gettext(
90	!	"You need to choose a counting device, clic on validate\n",
91	!	domain = "R-stacomiR"
92		),
93	!	arret = TRUE
94		)
95		}
96
97	21x	if (exists("report_ope_date_debut", envir = envir_stacomi)) {
98	21x	object@horodatedebut@horodate <-
99	21x	get("report_ope_date_debut", envir = envir_stacomi)
100		} else {
101	!	funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
102	!	arret = TRUE)
103		}
104
105	21x	if (exists("report_ope_date_fin", envir = envir_stacomi)) {
106	21x	object@horodatefin@horodate <-
107	21x	get("report_ope_date_fin", envir = envir_stacomi)
108		} else {
109	!	funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
110	!	arret = TRUE)
111		}
112	21x	assign("report_ope", object, envir = envir_stacomi)
113	21x	return(object)
114		}
115		)

1		#' Generic method for manual choice using the command line
2		#' @param object Object
3		#' @param ... Additional parms
4		#' @author cedric.briand
5		#' @keywords internal
6		#' @export
7	469x	setGeneric("choice_c", def = function(object, ...) standardGeneric("choice_c"))
8		#' Generic method to load referentials
9		#' @param object Object
10		#' @param ... Additional parm
11		#' @author cedric.briand
12		#' @export
13	256x	setGeneric("charge", def = function(object, ...) standardGeneric("charge"))
14		#' Generic method to load referentials, with filters from the parent object in the database
15		#' @param object Object
16		#' @param ... Additional parms
17		#' @author cedric.briand
18		#' @keywords internal
19		#' @export
20	141x	setGeneric("charge_with_filter", def = function(object, ...) standardGeneric("charge_with_filter"))
21		# setGeneric('connect',def=function(object,...) standardGeneric('connect')) #
22		# package stacomirtools setGeneric('plot',def=function(x,y,...)
23		# standardGeneric('plot'))
24		#' Generic for prediction
25		#' @param object Object
26		#' @param ... Additional parms
27		#' @author cedric.briand
28		#' @export
29	3x	setGeneric("model", def = function(object, ...) standardGeneric("model"))
30		#' Generic method to load additional data
31		#' @param object Object
32		#' @param ... Additional parms
33		#' @author cedric.briand
34		#' @export
35	2x	setGeneric("charge_complement", def = function(object, ...) standardGeneric("charge_complement"))
36		#' Generic method for calculations
37		#' @param object Object
38		#' @param ... Additional parms
39		#' @author cedric.briand
40		#' @export
41	54x	setGeneric("calcule", def = function(object, ...) standardGeneric("calcule"))
42		#' Generic method to delete entires from the database
43		#' @param object Object
44		#' @param ... Additional parms
45		#' @author cedric.briand
46		#' @seealso \link{calcule.report_ge_weight}, \link{calcule.report_mig_char}, \link{calcule.report_mig_env},
47		#' \link{calcule.report_mig_interannual},\link{calcule.report_mig_mult},\link{calcule.report_mig_mult},
48		#' \link{calcule.report_sample_char}, \link{calcule.report_sea_age}, \link{calcule.report_silver_eel},
49		#' \link{calcule.report_species}
50		#' @export
51	9x	setGeneric("supprime", def = function(object, ...) standardGeneric("supprime"))
52		#' Generic method write_database
53		#' @param object Object
54		#' @param ... Additional parms
55		#' @author cedric.briand
56		#' @export
57	7x	setGeneric("write_database", def = function(object, ...) standardGeneric("write_database"))
58		#' Generic method getvalue
59		#' @param object Object
60		#' @param ... Additional parms
61		#' @author cedric.briand
62		#' @export
63	!	setGeneric("getvalue", def = function(object, ...) standardGeneric("getvalue"))
64		#' Generic method to transform quantitative par into a qualitative one
65		#' @param object Object
66		#' @param ... Additional parms
67		#' @author cedric.briand
68		#' @export
69	8x	setGeneric("setasqualitative", def = function(object, ...) standardGeneric("setasqualitative"))
70		#' Generic method for getting the final date
71		#' @param object An object
72		#' @param ... Additional parameters passed to the method
73		#' @keywords internal
74		setGeneric(
75		"end_date",
76	155x	def = function(object, ...)
77	155x	standardGeneric("end_date")
78		)
79
80
81		#' Generic method to get the years
82		#' @param object An object
83		#' @param ... Additional parameters passed to the method
84		#' @keywords internal
85		setGeneric(
86		"get_year",
87	36x	def = function(object, ...)
88	36x	standardGeneric("get_year")
89		)
90
91		#' Environment where most objects from the package are stored and then loaded
92		#' by the charge method
93		#'
94		#' envir_stacomi \code{envir_stacomi <- new.env(parent = baseenv())} is the
95		#' environment where most object created by the interface are stored
96		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
97		"envir_stacomi"

1		#' Class 'ref_timestep_daily'
2		#'
3		#' Representation of a ref_timestep object with a step length equal to one day.
4		#' It receives an inheritance from ref_timestep
5		#'
6		#' validity_ref_timestep_daily
7		#' @include ref_timestep.R
8		#' @section Objects from the Class: Objects can be created by calls of the form
9		#' \code{new('ref_timestep_daily',
10		#' dateDebut='POSIXt',step_duration=numeric(),nb_step=numeric(),nocurrent_step=integer())}.
11		#' \describe{ \item{list('dateDebut')}{Object of class \code{'POSIXt'} Starting
12		#' date }\item{:}{Object of class \code{'POSIXt'} Starting date }
13		#' \item{list('step_duration')}{Object of class \code{'numeric'} Step length
14		#' }\item{:}{Object of class \code{'numeric'} Step length }
15		#' \item{list('nb_step')}{Object of class \code{'numeric'} Number of steps
16		#' }\item{:}{Object of class \code{'numeric'} Number of steps }
17		#' \item{list('nocurrent_step')}{Object of class \code{'integer'} Number of the
18		#' current step }\item{:}{Object of class \code{'integer'} Number of the
19		#' current step } }
20		#' @author cedric.briand@eptb-vilaine.fr
21		#' @seealso \code{\linkS4class{ref_timestep}}
22		#' @keywords classes
23		setClass(Class = "ref_timestep_daily", contains = "ref_timestep", prototype = (step_duration = 86400))
24
25
26
27		setValidity(Class = "ref_timestep_daily", function(object) {
28		retValue <- NULL
29		rep1 = validity_ref_timestep(object)
30		if (!is.logical(rep1))
31		retValue <- rep1
32		rep2 = (object@step_duration == 86400)
33		if (!rep2)
34		retValue = paste(retValue, gettext("Time step duration should be daily",
35		domain = "R-stacomiR"))
36		rep3 = length(get_year(object)) == 1
37		if (!rep3)
38		retValue = paste(retValue, gettext("Time step can't include more than one year",
39		domain = "R-stacomiR"))
40		return(ifelse(rep1 & rep2 & rep3, TRUE, retValue))
41		})
42		# pour test #object=new('ref_timestep_daily')
43
44
45
46		#' choice_c method for class ref_timestep_daily
47		#'
48		#' the choice_c method is intended to have the same behaviour as choice (which creates a
49		#' widget in the graphical interface) but from the command line.
50		#' @param object An object of class \link{ref_timestep_daily-class}
51		#' @param datedebut A character (format \code{'15/01/1996'} or \code{'1996-01-15'} or \code{'15-01-1996'}), or POSIXct object
52		#' @param datefin A character
53		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
54		#' @examples
55		#' \dontrun{
56		#' object=new('ref_dc')
57		#' object<-charge(object)
58		#' choice_c(object=object,datedebut='2012-01-01',datefin='2013-01-01')
59		#' }
60		#' @return An S4 object of class \link{ref_timestep_daily-class} with date selected
61		setMethod("choice_c", signature = signature("ref_timestep_daily"), definition = function(object,
62		datedebut, datefin) {
63	24x	if (inherits(datedebut, "character")) {
64	24x	if (grepl("/", datedebut)) {
65	!	datedebut = strptime(datedebut, format = "%d/%m/%Y")
66	!	if (is.na(datedebut)) {
67	!	datedebut = strptime(datedebut, format = "%d/%m/%y")
68		}
69	24x	} else if (grepl("-", datedebut)) {
70	24x	datedebut = strptime(datedebut, format = "%Y-%m-%d")
71	24x	if (is.na(datedebut)) {
72	!	datedebut = strptime(datedebut, format = "%d-%m-%Y")
73		}
74		}
75	24x	if (is.na(datedebut)) {
76	!	stop("datedebut not parsed to datetime try format like '01/01/2017'")
77		}
78		}
79
80		# the datedebut can have a POSIXct format
81	24x	if (inherits(datefin, "character")) {
82	24x	if (grepl("/", datefin)) {
83	7x	datefin = strptime(datefin, format = "%d/%m/%Y")
84	7x	if (is.na(datefin)) {
85	!	datefin = strptime(datefin, format = "%d/%m/%y")
86		}
87	17x	} else if (grepl("-", datefin)) {
88	17x	datefin = strptime(datefin, format = "%Y-%m-%d")
89	17x	if (is.na(datefin)) {
90	!	datefin = strptime(datefin, format = "%d-%m-%Y")
91		}
92		}
93	24x	if (is.na(datefin)) {
94	!	stop("datefin not parsed to datetime try format like '01/01/2017'")
95		}
96		}
97	24x	object@dateDebut <- as.POSIXlt(datedebut)
98	24x	object@nb_step = as.numeric(difftime(datefin, datedebut, units = "days")) # to fit with end_date(object)
99	24x	validObject(object)
100	24x	assign("timestep", object, envir_stacomi)
101	24x	return(object)
102		})

1		#' Class 'ref_dc'
2		#'
3		#' Description of a control device.
4		#'
5		#' @include create_generic.R
6		#' @slot dc_selected Object of class \code{'integer'}, The selected device
7		#' @slot ouvrage Object of class \code{'integer'}, the attached dam
8		#' @slot station Object of class \code{'character'}, the attached migration monitoring station, this is necessary to join the
9		#' table of escapements calculated at the station level.
10		#' @slot data Object of class \code{'data.frame'} data pertaining to the control device
11		#' @section Objects from the Class: Objects can be created by calls of the form
12		#' \code{new('ref_dc', dc_selected=integer(), ouvrage=integer(),
13		#' data=data.frame())}.
14		#' @author cedric.briand@eptb-vilaine.fr
15		#' @keywords classes
16		#' @family referential objects
17		setClass(
18		Class = "ref_dc",
19		representation = representation(
20		dc_selected = "integer",
21		ouvrage = "integer",
22		station = "character",
23		data = "data.frame"
24		),
25		prototype = prototype(
26		dc_selected = integer(),
27		ouvrage = integer(),
28		station = character(),
29		data = data.frame()
30		)
31		)
32
33
34
35		setValidity(
36		"ref_dc",
37		method = function(object) {
38		if (length(object@dc_selected) != 0) {
39		if (nrow(object@data) > 0) {
40		concord <- object@dc_selected %in% object@data$dc
41		if (any(!concord)) {
42		return(paste("No data for DC", object@dc_selected[!concord]))
43
44		} else {
45		return(TRUE)
46		}
47		} else {
48		return(
49		"You tried to set a value for dc_selected without initializing the data slot"
50		)
51		}
52		} else
53		return(TRUE)
54
55		}
56		)
57
58
59		#' Method to load the counting devices of the control station
60		#' @param object An object of class \link{ref_dc-class}
61		#' @return an object of class ref_dc with data loaded
62		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
63		setMethod(
64		"charge",
65		signature = signature("ref_dc"),
66		definition = function(object) {
67	70x	requete = new("RequeteDB")
68	70x	requete@sql = paste(
69	70x	"select dis_identifiant as DC,",
70	70x	" dis_date_creation,",
71	70x	" dis_date_suppression,",
72	70x	" dif_dis_identifiant as DF,",
73	70x	" dis_commentaires,",
74	70x	" dif_ouv_identifiant,",
75	70x	" ouv_libelle,",
76	70x	" dif_code as DF_code,",
77	70x	" dic_code as DC_code,",
78	70x	" dif_localisation,",
79	70x	" dif_orientation,",
80	70x	" tdf_libelle as type_DF,",
81	70x	" tdc_libelle as type_DC,",
82	70x	"sta_code",
83	70x	" FROM ",
84	70x	get_schema(),
85	70x	"tg_dispositif_dis",
86	70x	" JOIN ",
87	70x	get_schema(),
88	70x	"t_dispositifcomptage_dic ON dic_dis_identifiant =dis_identifiant",
89	70x	" JOIN ",
90	70x	get_schema(),
91	70x	"t_dispositiffranchissement_dif ON dif_dis_identifiant=dic_dif_identifiant",
92	70x	" JOIN ",
93	70x	get_schema(),
94	70x	"tj_dfesttype_dft ON dif_dis_identifiant=dft_df_identifiant",
95	70x	" JOIN ",
96	70x	get_schema(),
97	70x	"t_ouvrage_ouv on dif_ouv_identifiant=ouv_identifiant",
98	70x	" JOIN ",
99	70x	get_schema(),
100	70x	"t_station_sta on ouv_sta_code=sta_code",
101	70x	" JOIN ref.tr_typedf_tdf ON tdf_code=dft_tdf_code",
102	70x	" JOIN ref.tr_typedc_tdc ON dic_tdc_code=tdc_code",
103	70x	" WHERE dft_rang=1",
104	70x	" ORDER BY dis_identifiant;",
105	70x	sep = ""
106		)
107	70x	requete <- stacomirtools::query(requete)
108		# funout(gettext('The query to load counting devices is done
109		# \n',domain='R-stacomiR'))
110	70x	object@data <- requete@query
111	70x	return(object)
112		}
113		)
114
115
116
117		#' Command line interface to select a counting device
118		#'
119		#' the choice_c method is intended to have the same behaviour as choice (which creates a
120		#' widget in the graphical interface) but from the command line. The parameters for dc are transformed to integer as the ref_dc only
121		#' takes integer in the dc slots. The method also loads the stations and ouvrages (dams) associated with the counting device (dc).
122		#' The values passed to the choice_c method are then checked with the setValidty method.
123		#' Finally, if an objectreport is passed as a parameter, the method will do a charge_with_filter to select only the taxa present in the counting devices
124		#' @param object an object of class ref_dc
125		#' @param dc a character vector of dc chosen
126		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
127		#' @return An object of class ref_dc with dc selected
128		#' @examples
129		#' \dontrun{
130		#' win=gwindow()
131		#' group=ggroup(container=win,horizontal=FALSE)
132		#' object=new('ref_dc')
133		#' object<-charge(object)
134		#' objectreport=new('report_mig_mult')
135		#' choice_c(object=object,objectreport=objectreport,dc=1)
136		#' }
137		setMethod(
138		"choice_c",
139		signature = signature("ref_dc"),
140		definition = function(object,
141		dc) {
142	70x	if (inherits(dc, "numeric")) {
143	64x	dc <- as.integer(dc)
144	6x	} else if (inherits(dc, "character")) {
145	!	dc = as.integer(as.numeric(dc))
146		}
147	70x	if (any(is.na(dc)))
148	!	stop("NA values dc")
149
150
151	70x	object@dc_selected <- dc
152	70x	validObject(object)
153		# the method validObject verifies that the dc is in the data slot of
154		# ref_dc
155
156	69x	object@station <-
157	69x	as.character(object@data$sta_code[object@data$dc %in% object@dc_selected])
158	69x	object@ouvrage <-
159	69x	object@data$dif_ouv_identifiant[object@data$dc %in% object@dc_selected]
160	69x	assign("ref_dc", object, envir = envir_stacomi)
161	69x	return(object)
162		}
163		)

1		# Name : ref_coe(classe)
2
3		#' Class 'ref_coe'
4		#'
5		#' Enables to load conversion coefficients quantity-number. This class only exists to load
6		#' the data with its method charge. It is not used directly as component of the graphical interface,
7		#' as the year is already loaded in the different report objects
8		#'
9		#'
10		#' @note Class loading coefficient of conversion between quantity (weights or
11		#' volumes of glass eel) and numbers between a starting and finishing date
12		#' @section Objects from the Class: Objects can be created by calls of the form
13		#' \code{new('ref_coe')}.
14		#' @slot data A \code{data.frame}
15		#' @slot datedebut A 'POSIXlt'
16		#' @slot datefin A 'POSIXlt'
17		#' @author cedric.briand@eptb-vilaine.fr
18		#' @family referential objects
19		#' @keywords classes
20		setClass(Class = "ref_coe", representation = representation(data = "data.frame",
21		datedebut = "POSIXlt", datefin = "POSIXlt"), prototype = prototype(data = data.frame()))
22
23		#' loads the coefficients for the period defined in class
24		#'
25		#'
26		#' The slots datedebut and datefin have to be filled before using charge
27		#' @param object An object of class \link{ref_coe-class}
28		#' @return An object of class \link{ref_coe-class}
29		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
30		#' @examples
31		#' \dontrun{
32		#' object<- new('ref_coe')
33		#' object@datedebut<-strptime('01/01/1996',format='%d/%m/%Y')
34		#' object@datefin<-strptime('01/01/1997',format='%d/%m/%Y')
35		#' charge(object)
36		#' }
37		setMethod("charge", signature = signature("ref_coe"), definition = function(object) {
38	4x	requete = new("RequeteDBwheredate")
39	4x	requete@datedebut = object@datedebut
40	4x	requete@datefin = object@datefin
41	4x	requete@colonnedebut = "coe_date_debut"
42	4x	requete@colonnefin = "coe_date_fin"
43	4x	requete@datefin = as.POSIXlt(object@datefin)
44	4x	requete@select = stringr::str_c("select * from ", get_schema(), "tj_coefficientconversion_coe")
45	4x	requete@and = " and coe_tax_code='2038' and coe_std_code='CIV' and coe_qte_code='1'"
46	4x	requete <- query(requete)
47	4x	object@data <- requete@query
48	4x	return(object)
49		})
50
51
52		#' supprime method for 'ref_coe' class
53		#' @param object An object of class \link{ref_coe-class}
54		#' @param tax '2038=Anguilla anguilla'
55		#' @param std 'CIV=civelle'
56		#' @param silent Default FALSE, if TRUE the program should no display messages
57		#' @return Nothing, called for side effect
58		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
59		#' @export
60		setMethod("supprime", signature = signature("ref_coe"), definition = function(object,
61		tax, std, silent = FALSE) {
62		# object<-r_gew@coe;tax=2038;std='CIV' getting the data to import
63
64		# here I assume that dc_selected will be unique (no report with several
65		# dc)
66	1x	req = new("RequeteDB")
67	1x	req@sql <- stringr::str_c(
68	1x	"WITH deleted AS (",
69	1x	"DELETE FROM ", get_schema(), "tj_coefficientconversion_coe ",
70	1x	"WHERE coe_date_debut >= '",object@datedebut,"'",
71	1x	" AND coe_date_fin <= '", object@datefin, "'",
72	1x	" AND coe_tax_code='", tax, "' and coe_std_code='", std,
73	1x	"' and coe_qte_code='1'",
74	1x	" RETURNING *)",
75	1x	" SELECT * FROM deleted"
76		)
77	1x	del <- stacomirtools::getquery(query(req))
78	1x	nr <- nrow(del)
79	1x	if (!silent)
80	1x	funout(gettextf("%s rows deleted from table tj_coefficientconversion_coe",
81	1x	nr, domain = "R-stacomiR"))
82	1x	return(invisible(NULL))
83		})
84

1		#' Class 'ref_parquan'
2		#'
3		#' Class enabling to load the list of quantitative parameters and to select one
4		#' of them. It inherits from 'ref_par', uses its 'choice' method
5		#' @author cedric.briand@eptb-vilaine.fr
6		#' @keywords classes
7		#' @family referential objects
8		#' @include ref_par.R
9		setClass(Class = "ref_parquan", contains = "ref_par")
10
11		#' Loading method for Reparquan referential objects
12		#' @param object An object of class \link{ref_parquan-class}
13		#' @return An S4 object of class \link{ref_parquan-class} with data loaded
14		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
15		#' @examples
16		#' \dontrun{
17		#' object=new('ref_parquan')
18		#' charge(object)
19		#' }
20		setMethod("charge", signature = signature("ref_parquan"), definition = function(object) {
21	1x	requete = new("RequeteDB")
22	1x	requete@sql = "SELECT par_code, par_nom, par_unite, par_nature, par_definition FROM ref.tg_parametre_par
23	1x	INNER JOIN ref.tr_parametrequantitatif_qan ON qan_par_code=par_code"
24	1x	requete <- stacomirtools::query(requete)
25		# funout(gettext('The query to load parameters is done
26		# \n',domain='R-stacomiR'))
27	1x	object@data <- requete@query
28	1x	return(object)
29		})
30
31
32		#' Loading method for Reparquan referential objects searching only those parameters existing for a DC (counting device), a Taxon, and a stage
33		#' @param object An object of class \link{ref_parquan-class}
34		#' @param dc_selected The dc set in the report object
35		#' @param taxa_selected The taxa set in the report object
36		#' @param stage_selected The stage set in the report object
37		#' @return An S4 object of class \link{ref_parquan-class} with data loaded showing available parameters for one DC
38		#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
39		#' @examples
40		#' \dontrun{
41		#' dc_selected=6
42		#'taxa_selected=2038
43		#' stage_selected='AGJ'
44		#' object=new('ref_parquan')
45		#' charge_with_filter(object,dc_selected,taxa_selected,stage_selected)
46		#' }
47		setMethod("charge_with_filter", signature = signature("ref_parquan"), definition = function(object,
48		dc_selected, taxa_selected, stage_selected) {
49	8x	requete = new("RequeteDBwhere")
50	8x	requete@select = paste("SELECT DISTINCT ON (par_code) par_code, par_nom, par_unite, par_nature, par_definition", " FROM ",
51	8x	get_schema(), "tg_dispositif_dis", " JOIN ", get_schema(), "t_dispositifcomptage_dic on dis_identifiant=dic_dis_identifiant",
52	8x	" JOIN ", get_schema(), "t_operation_ope on ope_dic_identifiant=dic_dis_identifiant",
53	8x	" JOIN ", get_schema(), "t_lot_lot on lot_ope_identifiant=ope_identifiant",
54	8x	" JOIN ", get_schema(), "tj_caracteristiquelot_car on car_lot_identifiant=lot_identifiant",
55	8x	" JOIN ref.tg_parametre_par on par_code=car_par_code", " JOIN ref.tr_parametrequantitatif_qan ON qan_par_code=par_code",
56	8x	sep = "")
57	8x	requete@where = paste("where dis_identifiant in ", vector_to_listsql(dc_selected))
58	8x	requete@and = paste("and lot_tax_code in ", vector_to_listsql(taxa_selected),
59	8x	" and lot_std_code in ", vector_to_listsql(stage_selected), "", sep = "")
60	8x	requete@order_by = "ORDER BY par_code"
61	8x	requete <- stacomirtools::query(requete)
62	8x	object@data <- requete@query
63	8x	return(object)
64		})
65
66

1		setAs("report_mig", "report_mig_interannual", function(from) {
2	6x	start_year = new("ref_year")
3	6x	end_year = new("ref_year")
4	6x	start_year@year_selected = min(get_year(from@timestep))
5	6x	end_year@year_selected = max(get_year(from@timestep))
6	6x	report_mig_interannual = new("report_mig_interannual")
7	6x	report_mig_interannual@dc = from@dc
8	6x	report_mig_interannual@taxa = from@taxa
9	6x	report_mig_interannual@stage = from@stage
10	6x	report_mig_interannual@start_year = start_year
11	6x	report_mig_interannual@end_year = end_year
12	6x	return(report_mig_interannual)
13		})
14
15
16		setAs("report_mig_interannual", "report_mig_mult", function(from) {
17	!	report_mig_mult = new("report_mig_mult")
18	!	report_mig_mult@dc = from@dc
19	!	report_mig_mult@taxa = from@taxa
20	!	report_mig_mult@stage = from@stage
21	!	report_mig_mult@timestep@dateDebut = strptime(stringr::str_c(from@start_year@year_selected,
22	!	"-01-01"), format = "%Y-%m-%d")
23	!	report_mig_mult@timestep@nb_step = 364
24	!	return(report_mig_mult)
25		})
26
27
28		setAs("report_mig", "report_mig_mult", function(from) {
29	14x	bMM = new("report_mig_mult")
30	14x	bMM@dc = from@dc
31	14x	bMM@taxa = from@taxa
32	14x	bMM@stage = from@stage
33	14x	bMM@timestep = from@timestep
34	14x	bMM@coef_conversion = from@coef_conversion
35	14x	bMM@data = from@data
36	14x	bMM@time.sequence = from@time.sequence
37	14x	bMM@calcdata = from@calcdata
38	14x	return(bMM)
39		})
40
41		setAs("report_mig_interannual", "report_annual", function(from) {
42	10x	r_ann = new("report_annual")
43	10x	r_ann@dc = from@dc
44	10x	r_ann@taxa = from@taxa
45	10x	r_ann@stage = from@stage
46	10x	r_ann@start_year = from@start_year
47	10x	r_ann@end_year = from@end_year
48	10x	return(r_ann)
49		})