[Stacomir-commits] r232 - in pkg/stacomir: . R data inst/config inst/examples man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Nov 1 13:35:03 CET 2016
Author: briand
Date: 2016-11-01 13:35:03 +0100 (Tue, 01 Nov 2016)
New Revision: 232
Added:
pkg/stacomir/R/interface_BilanAnnuels.r
pkg/stacomir/data/bilA.rda
pkg/stacomir/data/bilAM.rda
pkg/stacomir/inst/examples/bilanAnnuels_example.R
pkg/stacomir/man/BilanAnnuels-class.Rd
pkg/stacomir/man/barplot-BilanAnnuels-method.Rd
pkg/stacomir/man/bilA.Rd
pkg/stacomir/man/bilAM.Rd
pkg/stacomir/man/charge-BilanAnnuels-method.Rd
pkg/stacomir/man/choice_c-BilanAnnuels-method.Rd
pkg/stacomir/man/connect-BilanAnnuels-method.Rd
pkg/stacomir/man/hbarplotBilanAnnuels.Rd
pkg/stacomir/man/hbilA.Rd
pkg/stacomir/man/hplotBilanAnnuels.Rd
pkg/stacomir/man/hxtableBilanAnnuels.Rd
pkg/stacomir/man/interface_BilanAnnuels.Rd
pkg/stacomir/man/plot-BilanAnnuels-missing-method.Rd
pkg/stacomir/man/xtable-BilanAnnuels-method.Rd
Removed:
pkg/stacomir/R/funBilanMigrationAnnuel.r
pkg/stacomir/R/funSousListeBilanMigration.r
pkg/stacomir/man/funBilanMigrationAnnuel.Rd
pkg/stacomir/man/funSousListeBilanMigration.Rd
Modified:
pkg/stacomir/DESCRIPTION
pkg/stacomir/NAMESPACE
pkg/stacomir/R/BilanAnnuels.r
pkg/stacomir/R/BilanMigrationInterAnnuelle.r
pkg/stacomir/R/RefAnnee.r
pkg/stacomir/R/RefDC.r
pkg/stacomir/R/create_generic.r
pkg/stacomir/R/data.r
pkg/stacomir/R/stacomi.r
pkg/stacomir/inst/config/generate_data.R
pkg/stacomir/inst/config/stacomi_manual_launch.r
pkg/stacomir/inst/examples/bilanMigrationInterannuelle_example.R
pkg/stacomir/man/BilanEspeces-class.Rd
pkg/stacomir/man/BilanFonctionnementDC-class.Rd
pkg/stacomir/man/BilanFonctionnementDF-class.Rd
pkg/stacomir/man/BilanMigration-class.Rd
pkg/stacomir/man/BilanMigrationConditionEnv-class.Rd
pkg/stacomir/man/BilanMigrationInterAnnuelle-class.Rd
pkg/stacomir/man/BilanMigrationMult-class.Rd
pkg/stacomir/man/Bilan_carlot-class.Rd
pkg/stacomir/man/Bilan_poids_moyen-class.Rd
pkg/stacomir/man/Bilan_stades_pigm-class.Rd
pkg/stacomir/man/Bilan_taille-class.Rd
Log:
FunBilanAnnuels completed
Modified: pkg/stacomir/DESCRIPTION
===================================================================
--- pkg/stacomir/DESCRIPTION 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/DESCRIPTION 2016-11-01 12:35:03 UTC (rev 232)
@@ -10,25 +10,25 @@
available in French English and Spanish.
License: GPL (>= 2)
Collate:
+ 'create_generic.r'
+ 'RefAnnee.r'
+ 'RefStades.r'
+ 'RefTaxon.r'
+ 'RefDC.r'
'BilanAnnuels.r'
'utilitaires.r'
- 'create_generic.r'
'RefStationMesure.r'
'RefHorodate.r'
'BilanConditionEnv.r'
'RefListe.r'
- 'RefDC.r'
'BilanEspeces.r'
'BilanFonctionnementDC.r'
'RefDF.r'
'BilanFonctionnementDF.r'
'PasdeTemps.r'
'PasDeTempsJournalier.r'
- 'RefStades.r'
- 'RefTaxon.r'
'BilanMigration.r'
'BilanMigrationConditionEnv.r'
- 'RefAnnee.r'
'BilanMigrationInterAnnuelle.r'
'BilanMigrationMult.r'
'RefChoix.r'
@@ -50,8 +50,6 @@
'fn_EcritBilanJournalier.r'
'fn_EcritBilanMensuel.r'
'fn_table_per_dis.r'
- 'funBilanMigrationAnnuel.r'
- 'funSousListeBilanMigration.r'
'funSousListeBilanMigrationPar.r'
'fungraph.r'
'fungraph_civelle.r'
@@ -60,6 +58,7 @@
'funstatJournalier.r'
'funtable.r'
'funtraitement_poids.r'
+ 'interface_BilanAnnuels.r'
'interface_BilanConditionEnv.r'
'interface_BilanFonctionnementDC.r'
'interface_BilanFonctionnementDF.r'
@@ -100,7 +99,8 @@
Hmisc,
RGtk2,
lubridate,
- dplyr
+ dplyr,
+ xtable
Suggests:
testthat,
viridis
Modified: pkg/stacomir/NAMESPACE
===================================================================
--- pkg/stacomir/NAMESPACE 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/NAMESPACE 2016-11-01 12:35:03 UTC (rev 232)
@@ -3,7 +3,6 @@
export(chargecsv)
export(fn_EcritBilanJournalier)
export(fn_EcritBilanMensuel)
-export(funBilanMigrationAnnuel)
export(fun_bilanMigrationMult)
export(fun_bilanMigrationMult_Overlaps)
export(fun_char_spe)
@@ -26,6 +25,7 @@
export(split_per_day)
export(stacomi)
export(vector_to_listsql)
+exportClasses(BilanAnnuels)
exportClasses(BilanConditionEnv)
exportClasses(BilanEspeces)
exportClasses(BilanFonctionnementDC)
@@ -40,6 +40,7 @@
exportClasses(Bilan_stades_pigm)
exportClasses(Bilan_taille)
exportMethods(DateFin)
+exportMethods(barplot)
exportMethods(calcule)
exportMethods(charge)
exportMethods(charge_avec_filtre)
@@ -50,6 +51,7 @@
exportMethods(print)
exportMethods(summary)
exportMethods(supprime)
+exportMethods(xtable)
import(RColorBrewer)
import(RGtk2)
import(RODBC)
@@ -62,6 +64,7 @@
import(sqldf)
import(stacomirtools)
import(stringr)
+import(xtable)
importFrom(grDevices,dev.new)
importFrom(grDevices,gray)
importFrom(grDevices,rainbow)
Modified: pkg/stacomir/R/BilanAnnuels.r
===================================================================
--- pkg/stacomir/R/BilanAnnuels.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/BilanAnnuels.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -1,2 +1,539 @@
-# see funBilanMigrationInterannuel pour modif
+#' Class "BilanAnnuels"
+#' @include RefDC.r
+#' @include RefTaxon.r
+#' @include RefStades.r
+#' @include RefAnnee.r
+#' @slot dc Object of class \code{\link{RefDC-class}}, the counting device, multiple values allowed
+#' @slot data Object of class \code{"data.frame"} data for bilan lot
+#' @slot taxons An object of class \code{\link{RefTaxon-class}}, multiple values allowed
+#' @slot stades An object of class \code{\link{RefStades-class}}, multiple values allowed
+#' @slot anneedebut Object of class \code{\link{RefAnnee-class}}. RefAnnee allows to choose year of beginning
+#' @slot anneefin Object of class \code{\link{RefAnnee-class}}
+#' RefAnnee allows to choose last year of the Bilan
+#'
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @family Bilan Objects
+#' @keywords classes
+#' @example inst/examples/bilanAnnuels_example.R
+#' @export
+setClass(Class="BilanAnnuels",representation=
+ representation(
+ dc="RefDC",
+ taxons="RefTaxon",
+ stades="RefStades",
+ data="data.frame",
+ anneedebut="RefAnnee",
+ anneefin="RefAnnee"
+ ),
+ prototype=prototype(dc=new("RefDC"),
+ taxons=new("RefTaxon"),
+ stades=new("RefStades"),
+ data=data.frame(),
+ anneedebut=new("RefAnnee"),
+ anneefin=new("RefAnnee")
+ )
+)
+#' charge method for BilanAnnuels class
+#' @param object An object of class \link{BilanAnnuels-class}
+#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
+setMethod("charge",signature=signature("BilanAnnuels"),
+ definition=function(object,silent=FALSE){
+ bilA<-object
+ if (exists("refDC",envir_stacomi)) {
+ bilA at dc<-get("refDC",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.1,arret=TRUE)
+ }
+ if (exists("refTaxon",envir_stacomi)) {
+ bilA at taxons<-get("refTaxon",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.2,arret=TRUE)
+ }
+ if (exists("refStades",envir_stacomi)){
+ bilA at stades<-get("refStades",envir_stacomi)
+ } else
+ {
+ funout(get("msg",envir_stacomi)$ref.3,arret=TRUE)
+ }
+ if (exists("anneedebut",envir_stacomi)) {
+ bilA at anneedebut<-get("anneedebut",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.10,arret=TRUE)
+ }
+ if (exists("anneefin",envir_stacomi)) {
+ bilA at anneefin<-get("anneefin",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.11,arret=TRUE)
+ }
+ assign("bilanAnnuels",bilA,envir_stacomi)
+ funout(get("msg",envir_stacomi)$BilanAnnuels.1)
+ return(bilA)
+
+
+ })
+
+
+#' connect method for BilanAnnuels class
+#' this method performs the sum over the year attention this function does
+#' not count subsamples.
+#' @param object An object of class \link{BilanAnnuels-class}
+#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
+#' @return An instantianted object with values filled with user choice
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @return A dataframe with column effectif, comprising the sum of bilanMigration counts
+#' @export
+setMethod("connect",signature=signature("BilanAnnuels"),
+ definition=function(object,silent=FALSE)
+ {
+ bilA<-object
+ req=new("RequeteODBC")
+ req at baseODBC<-get("baseODBC", envir=envir_stacomi)
+ ##############################
+ ##############################"
+ anneedebut= bilA at anneedebut@annee_selectionnee
+ anneefin=bilA at anneefin@annee_selectionnee
+ dc = vector_to_listsql(bilA at dc@dc_selectionne)
+ tax=vector_to_listsql(bilA at taxons@data$tax_code)
+ std=vector_to_listsql(bilA at stades@data$std_code)
+ req at 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("sch",envir=envir_stacomi),"t_operation_ope ",
+ " join ",get("sch",envir=envir_stacomi),"t_lot_lot on lot_ope_identifiant=ope_identifiant where ope_dic_identifiant in",dc,
+ " and extract(year from ope_date_debut)>=", anneedebut,
+ " and extract(year from ope_date_fin)<=", anneefin,
+ " 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 at sql<-stringr::str_replace_all(req at sql,"[\r\n\t]" , "")
+ req<-stacomirtools::connect(req)
+ bilA at data=req at query
+ return(bilA)
+ })
+
+#' command line interface for \link{BilanAnnuels-class}
+#' @param object An object of class \link{BilanAnnuels-class}
+#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,RefDC-method}
+#' @param taxons 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,RefTaxon-method}
+#' @param stades A stage code matching the ref.tr_stadedeveloppement_std table in the stacomi database, see \link{choice_c,RefStades-method}
+#' @param anneedebut The starting the first year, passed as charcter or integer
+#' @param anneefin the finishing year
+#' @param silent Boolean, if TRUE, information messages are not displayed
+#' @return An object of class \link{BilanMigrationInterAnnuelle-class}
+#' The choice_c method fills in the data slot for classes \link{RefDC-class}, \link{RefTaxon-class}, \link{RefStades-class} and two slots of \link{RefAnnee-class}
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+setMethod("choice_c",signature=signature("BilanAnnuels"),definition=function(object,
+ dc,
+ taxons,
+ stades,
+ anneedebut,
+ anneefin,
+ silent=FALSE){
+ # code for debug using example
+ #dc=c(5,6);taxons="Anguilla anguilla";stades=c("AGJ","AGG","CIV");anneedebut="1996";anneefin="2016"
+ bilA<-object
+ bilA at dc=charge(bilA at dc)
+ # loads and verifies the dc
+ # this will set dc_selectionne slot
+ bilA at dc<-choice_c(object=bilA at dc,dc)
+ # only taxa present in the bilanMigration are used
+ bilA at taxons<-charge_avec_filtre(object=bilA at taxons,bilA at dc@dc_selectionne)
+ bilA at taxons<-choice_c(bilA at taxons,taxons)
+ bilA at stades<-charge_avec_filtre(object=bilA at stades,bilA at dc@dc_selectionne,bilA at taxons@data$tax_code)
+ bilA at stades<-choice_c(bilA at stades,stades)
+
+ bilA at anneedebut<-charge(object=bilA at anneedebut,
+ objectBilan="BilanAnnuels")
+ bilA at anneedebut<-choice_c(object=bilA at anneedebut,
+ nomassign="anneeDebut",
+ annee=anneedebut,
+ silent=silent)
+ bilA at anneefin@data<-bilA at anneedebut@data
+ bilA at anneefin<-choice_c(object=bilA at anneefin,
+ nomassign="anneeFin",
+ annee=anneefin,
+ silent=silent)
+ assign("bilanAnnuels",bilA,envir=envir_stacomi)
+ return(bilA)
+ })
+
+#' xtable funciton for \link{BilanAnnuels-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 "BilanAnnuels"
+#' @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 x at dc@dc_selectionne
+#' 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
+#' @export
+setMethod("xtable",signature=signature("BilanAnnuels"),definition=function(x,
+ caption=NULL,
+ label=NULL,
+ align=NULL,
+ digits=0,
+ display=NULL,
+ auto=FALSE,
+ dc_name=NULL,
+ tax_name=NULL,
+ std_name=NULL
+ ){
+ bilA<-x
+ dat=bilA at data
+ tax=bilA at taxons@data$tax_code
+ std=bilA at stades@data$std_code
+ dc=bilA at dc@dc_selectionne
+ # 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=bilA at dc@data[bilA at dc@data$dc==dc,"dc_code"] else
+ 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=bilA at taxons@data$tax_nom_latin else
+ 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=bilA at stades@data$std_libelle else
+ 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 agregated 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{BilanAnnuels}
+#' @param height An object of class BilanAnnuels
+#' @param legend.tex See barplot help
+#' @param ... additional arguments passed to barplot
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @aliases barplot.BilanAnnuels barplot.bilA
+#' @seealso \link{BilanAnnuels-class} for examples
+#' @export
+setMethod("barplot",signature(height = "BilanAnnuels"),definition=function(height,legend.text=NULL,...){
+ #bilanMigrationInterAnnuelle<-bmi
+ bilA<-height
+ # require(ggplot2)
+ if(nrow(bilA at data)>0){
+
+ dat=bilA at 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, taxon, 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<-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("No data")
+ }
+ })
+
+
+
+#' Plot method for BilanAnnuels
+#'
+#' @param x An object of class \link{BilanAnnuels}
+#' @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"at"eptb-vilaine.fr}
+#' @aliases plot.BilanAnnuels plot.bilA
+#' @seealso \link{BilanMigrationInterAnnuelle-class} for examples
+#' @export
+setMethod("plot",signature(x = "BilanAnnuels", y = "missing"),definition=function(x,
+ plot.type="point",
+ silent=FALSE){
+ bilA<-x
+ dat<-bilA at data
+ lesdic<-unique(dat$ope_dic_identifiant)
+ lestax<-unique(dat$lot_tax_code)
+ lesstd<-unique(dat$lot_std_code)
+
+ if(nrow(bilA at data)>0){
+ if (plot.type=="point"){
+
+ colnames(dat)<-c("effectif","annee","dc","taxon","stade")
+ dat$dc<-as.factor(dat$dc)
+ dat$taxon<-as.factor(dat$taxon)
+ if (length(lestax)==1 & length(lesstd) & length(lesdic)==1){
+
+ g<-ggplot(dat,aes(x=annee,y=effectif))+geom_point()+
+ geom_line()+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+
+ } 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))+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+
+ } else if (length(lestax)==1 & length(lesdic)==1){
+
+ g<-ggplot(dat,aes(x=annee,y=effectif))+geom_point(aes(col=stade))+
+ geom_line(aes(col=stade))+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+
+ } else if (length(lesdic)==1 & length(lesstd)==1){
+
+ g<-ggplot(dat,aes(x=annee,y=effectif))+geom_point(aes(col=taxon))+
+ geom_line(aes(col=taxon))+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+
+
+ } else if (length(lestax)==1){
+
+ g<-ggplot(dat,aes(x=annee,y=effectif))+geom_point(aes(col=dc,shape=stade))+
+ geom_line(aes(col=dc,shape=stade))+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+
+ } else if (length(lesstd)==1){
+
+ g<-ggplot(dat,aes(x=annee,y=effectif))+geom_point(aes(col=dc,shape=taxon))+
+ geom_line(aes(col=dc,shape=taxon))+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+
+ } else if (length(lesdic)==1){
+
+ g<-ggplot(dat,aes(x=annee,y=effectif))+geom_point(aes(col=taxon,shape=stade))+
+ geom_line(aes(col=taxon,shape=stade))+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+
+ } else {
+ if (length(lesdic)<3){
+ g<-ggplot(dat,aes(x=annee,y=effectif))+geom_point(aes(col=taxon,shape=stade))+
+ geom_line(aes(col=taxon,shape=stade))+
+ 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=stade))+
+ geom_line(aes(col=stade))+
+ facet_grid(dc~stade)+
+ theme_bw()
+ print(g)
+
+ assign("g",g,envir_stacomi)
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigrationPar.6)
+ }
+ }
+ }
+
+ } else {
+ funout("No data")
+ }
+ })
+
+
+#' Barplot handler
+#' @param h handler
+#' @param ... additional parameters
+hbarplotBilanAnnuels = function(h,...)
+{
+ bilA <- get("bilanAnnuels",envir=envir_stacomi)
+ bilA <- charge(bilA)
+ bilA <- connect(bilA)
+ barplot(bilA)
+}
+
+#' plot handler
+#' @param h handler
+#' @param ... additional parameters
+hplotBilanAnnuels = function(h,...)
+{
+ bilA <- get("bilanAnnuels",envir=envir_stacomi)
+ bilA <- charge(bilA)
+ bilA <- connect(bilA)
+ plot(bilA)
+}
+
+
+#' xtable handler
+#' @param h handler
+#' @param ... additional parameters
+hxtableBilanAnnuels = function(h,...)
+{
+ bilA <- get("bilanAnnuels",envir=envir_stacomi)
+ bilA <- charge(bilA)
+ bilA <- connect(bilA)
+ print(xtable(bilA))
+}
\ No newline at end of file
Modified: pkg/stacomir/R/BilanMigrationInterAnnuelle.r
===================================================================
--- pkg/stacomir/R/BilanMigrationInterAnnuelle.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/BilanMigrationInterAnnuelle.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -38,6 +38,8 @@
)
)
+
+
#' connect method for BilanMigrationInterannuelle class
#' @param object An object of class \link{BilanMigrationInterAnnuelle-class}
#' @param silent Stops messages from being displayed if silent=TRUE, default FALSE
Modified: pkg/stacomir/R/RefAnnee.r
===================================================================
--- pkg/stacomir/R/RefAnnee.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/RefAnnee.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -20,6 +20,7 @@
#' Class used to select one or several years
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("RefAnnee", data=data.frame(), annee_selectionnee=numeric())}.
+#' @include create_generic.r
#' @slot data A \code{data.frame} with the list of possible years selected as numerics
#' @slot annee_selectionnee A numeric vector
#' @keywords classes
@@ -77,6 +78,33 @@
requete at sql=paste("select DISTINCT ON (year) year from( select date_part('year', ope_date_debut) as year from ",
get("sch",envir=envir_stacomi),
"t_operation_ope) as tabletemp",sep="")
+ } else if (objectBilan=="BilanAnnuels") {
+ if (exists("refDC",envir_stacomi)) {
+ dc<-get("refDC",envir_stacomi)
+ and1<-paste(" AND ope_dic_identifiant in ",vector_to_listsql(dc at dc_selectionne))
+ } else {
+ and1<-""
+ }
+ if (exists("refTaxon",envir_stacomi)) {
+ taxons<-get("refTaxon",envir_stacomi)
+ and2<-stringr::str_c(" AND lot_tax_code in ",vector_to_listsql(taxons at data$tax_code))
+ } else {
+ and2<-""
+ }
+ if (exists("refStades",envir_stacomi)){
+ stades<-get("refStades",envir_stacomi)
+ and3<-stringr::str_c(" AND lot_std_code in ",vector_to_listsql(stades at data$std_code))
+ } else
+ {
+ and3=""
+ }
+ requete at sql=paste("select DISTINCT ON (year) year from (select date_part('year', ope_date_debut) as year from ",
+ get("sch",envir=envir_stacomi),
+ "t_operation_ope JOIN ",
+ get("sch",envir=envir_stacomi),
+ "t_lot_lot on lot_ope_identifiant=ope_identifiant",
+ " WHERE lot_lot_identifiant is null",
+ and1,and2,and3, ") as tabletemp", sep="")
} else {
funout(paste("Not implemented for objectBilan =",objectBilan),arret=TRUE)
}
@@ -156,7 +184,7 @@
if (class (annee)=="character") annee<-as.numeric(annee)
# the charge method must be performed before
- if (! annee %in% object at data$bjo_annee) {
+ if ( !annee %in% object at data$bjo_annee & !annee %in% object at data$year) {
warning(stringr::str_c("year,",annee," not available in the database, available years",stringr::str_c(object at data$bjo_annee,collapse=",")))
} else {
object at annee_selectionnee<-annee
Modified: pkg/stacomir/R/RefDC.r
===================================================================
--- pkg/stacomir/R/RefDC.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/RefDC.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -4,7 +4,7 @@
#'
#' Description of a control device.
#'
-#'
+#' @include create_generic.r
#' @slot dc_selectionne 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
Modified: pkg/stacomir/R/create_generic.r
===================================================================
--- pkg/stacomir/R/create_generic.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/create_generic.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -73,6 +73,7 @@
+
#' Environment where most objects from the package are stored and then loaded
#' by the charge method
#'
Modified: pkg/stacomir/R/data.r
===================================================================
--- pkg/stacomir/R/data.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/data.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -212,4 +212,18 @@
#' the dataset has been loaded as an example for the BilanMigrationInterAnnuelle-class
#' @format An object of class BilanMigrationInterAnnuelle-class with data slot loaded.
#' @keywords data
-"bmi"
\ No newline at end of file
+"bmi"
+
+#' An object of class \link{BilaAnnuels-class} with data loaded
+#'
+#' The dataset corresponds to the three fishways located on the Arzal dam, filled with annual data
+#' @format An object of class \link{BilanAnnuels-class} with data slot loaded.
+#' @keywords data
+"bilA"
+
+#' Annual migration of salmon by migradour
+#'
+#' The dataset corresponds to the fishways of the Adour for adult migrant salmons
+#' @format An object of class \link{BilanAnnuels-class} with data slot loaded.
+#' @keywords data
+"bilAM"
\ No newline at end of file
Deleted: pkg/stacomir/R/funBilanMigrationAnnuel.r
===================================================================
--- pkg/stacomir/R/funBilanMigrationAnnuel.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/funBilanMigrationAnnuel.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -1,51 +0,0 @@
-# Nom fichier : funBilanMigrationAnnuel
-# Projet : calcmig/prog/fonctions
-# Organisme : IAV/CSP
-# Auteur : Cedric Briand
-# Contact : cedric.briand"at"eptb-vilaine.fr
-# Date de creation : 23/05/2022
-# Compatibilite : R 2.14
-# Etat : fonctionne
-# Description Workhorse fonction pour le calcul des bilans migratoires
-#**********************************************************************
-#*
-#* Modifications :
-
-
-
-
-
-
-
-#' this functions performs the sum over the year attention this function does
-#' not count subsamples.
-#'
-#'
-#'
-#' @param bilanMigration an object of class \code{\linkS4class{BilanMigration}}
-#' @return A dataframe with column effectif, comprising the sum of bilanMigration counts
-#' @export
-funBilanMigrationAnnuel=function(bilanMigration) {
- # *********************
- # Boucle sur chacune des periodes du pas de temps
- # *********************
- req=new("RequeteODBC")
- req at baseODBC<-get("baseODBC", envir=envir_stacomi)
- ##############################
- ##############################"
- dateDebut=strftime(as.POSIXlt(bilanMigration at pasDeTemps@dateDebut),format="%Y-%m-%d %H:%M:%S")
- dateFin=strftime(as.POSIXlt(DateFin(bilanMigration at pasDeTemps)),format="%Y-%m-%d %H:%M:%S")
- year=as.numeric(strftime(as.POSIXlt(bilanMigration at pasDeTemps@dateDebut),format="%Y"))
- dcCode = as.character(bilanMigration at dc@dc_selectionne)
- req at sql = paste(" select sum(lot_effectif) as effectif from ",get("sch",envir=envir_stacomi),"t_operation_ope ",
- " join ",get("sch",envir=envir_stacomi),"t_lot_lot on lot_ope_identifiant=ope_identifiant where ope_dic_identifiant=",dcCode,
- " and extract(year from ope_date_debut)=", year,
- " and lot_tax_code='",bilanMigration at taxons@data$tax_code,
- "' and lot_std_code='",bilanMigration at stades@data$std_code,
- "' and lot_lot_identifiant is null",
- " ;",sep="" )
- req<-stacomirtools::connect(req)
- rs=req at query
- return (rs)
-
-}
Deleted: pkg/stacomir/R/funSousListeBilanMigration.r
===================================================================
--- pkg/stacomir/R/funSousListeBilanMigration.r 2016-10-28 09:58:55 UTC (rev 231)
+++ pkg/stacomir/R/funSousListeBilanMigration.r 2016-11-01 12:35:03 UTC (rev 232)
@@ -1,434 +0,0 @@
-# Nom fichier : funSousListeBilanMigration
-# Projet : calcmig/prog/fonctions
-# Organisme : IAV/CSP
-# Auteur : Cedric Briand
-# Contact : cedric.briand"at"eptb-vilaine.fr
-# Date de creation : 23/05/2006
-# Compatibilite : R 2.8.0
-# Etat : fonctionne
-# Description Workhorse fonction pour le calcul des bilans migratoires
-#**********************************************************************
-#*
-#* Modifications :
-
-
-
-
-
-
-
-
-#' funSousListeBilanMigration
-#'
-#' workhorse function for bilanMigration. Calculates the number for a stage and
-#' a taxa per day. The operation for the fishway is never from 00:00 to 00:00
-#' so the number per day is calculated according to the ration between the
-#' duration of the operation and the duration of the day. This function will
-#' allow daily reports to be saved into the database when graph is launched
-#'
-#'
-#' @param bilanMigration an object of class \code{\linkS4class{BilanMigration}}
-funSousListeBilanMigration=function(bilanMigration) {
- # *********************
- # Boucle sur chacune des periodes du pas de temps
- # *********************
- req=new("RequeteODBC")
- req at baseODBC<-get("baseODBC", envir=envir_stacomi)
- req at open<-TRUE
- mygtkProgressBar(title="Calcul des effectifs par pas de temps",
- progress_text=get("msg",envir=envir_stacomi)$BilanFonctionnementDF.5)
- ##############################
- on.exit(dispose(progres)) # fermeture de la barre de progres
- on.exit(if(!is.null(req at connection)) odbcClose(req at connection)) # ne pas lancer en debug
- ##############################"
- ##debug
- # bilanMigration at pasDeTemps<-get("pasDeTemps",envir_stacomi)
- #bilanMigration at pasDeTemps@noPasCourant=as.integer(-(difftime(as.POSIXlt(strptime("2006-01-01 00:00:00",format="%Y-%m-%d %H:%M:%S")),as.POSIXlt(strptime("2006-03-27 00:00:00",format="%Y-%m-%d %H:%M:%S")),unit="days")))
- #bilanMigration at pasDeTemps@noPasCourant=as.integer(264)
-
- dateFin=strftime(as.POSIXlt(DateFin(bilanMigration at pasDeTemps)),format="%Y-%m-%d %H:%M:%S")
- while (getnoPasCourant(bilanMigration at pasDeTemps) != -1) {
- zz=(getnoPasCourant(bilanMigration at pasDeTemps)+1)/bilanMigration at pasDeTemps@nbStep
- progress_bar$setFraction(zz)
- progress_bar$setText(sprintf("%d%% progression",round(100*zz)))
- #RGtk2::gtkMainIterationDo(FALSE)
- debutPas = as.POSIXlt(currentDateDebut(bilanMigration at pasDeTemps))
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/stacomir -r 232
More information about the Stacomir-commits
mailing list