[Stacomir-commits] r233 - 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 15 19:17:56 CET 2016
Author: briand
Date: 2016-11-15 19:17:55 +0100 (Tue, 15 Nov 2016)
New Revision: 233
Added:
pkg/stacomir/R/BilanArgentee.r
pkg/stacomir/R/interface_BilanArgentee.r
pkg/stacomir/data/bilanArg.rda
pkg/stacomir/data/coef_Durif.rda
pkg/stacomir/inst/examples/bilanArgentee_example.R
pkg/stacomir/man/BilanArgentee-class.Rd
pkg/stacomir/man/bilanArg.Rd
pkg/stacomir/man/calcule-BilanArgentee-method.Rd
pkg/stacomir/man/charge-BilanArgentee-method.Rd
pkg/stacomir/man/choice_c-BilanArgentee-method.Rd
pkg/stacomir/man/coef_Durif.Rd
pkg/stacomir/man/connect-BilanArgentee-method.Rd
pkg/stacomir/man/f_stade_Durif.Rd
pkg/stacomir/man/funboxplotBilanArgentee.Rd
pkg/stacomir/man/fundensityBilanArgentee.Rd
pkg/stacomir/man/funpointBilanArgentee.Rd
pkg/stacomir/man/funtableBilanArgentee.Rd
pkg/stacomir/man/hsilver.Rd
pkg/stacomir/man/interface_BilanArgentee.Rd
pkg/stacomir/man/plot-BilanArgentee-missing-method.Rd
pkg/stacomir/man/print-BilanArgentee-method.Rd
pkg/stacomir/man/summary-BilanArgentee-method.Rd
Modified:
pkg/stacomir/DESCRIPTION
pkg/stacomir/NAMESPACE
pkg/stacomir/R/Bilan_carlot.r
pkg/stacomir/R/RefDC.r
pkg/stacomir/R/Refpar.r
pkg/stacomir/R/data.r
pkg/stacomir/R/interface_BilanAnnuels.r
pkg/stacomir/R/interface_Bilan_carlot.r
pkg/stacomir/R/stacomi.r
pkg/stacomir/data/bilAM.rda
pkg/stacomir/data/msg.rda
pkg/stacomir/inst/config/generate_data.R
pkg/stacomir/inst/config/stacomi_manual_launch.r
pkg/stacomir/man/BilanAnnuels-class.Rd
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
pkg/stacomir/man/barplot-BilanAnnuels-method.Rd
pkg/stacomir/man/bilA.Rd
pkg/stacomir/man/bilAM.Rd
pkg/stacomir/man/bmi.Rd
Log:
Modified: pkg/stacomir/DESCRIPTION
===================================================================
--- pkg/stacomir/DESCRIPTION 2016-11-01 12:35:03 UTC (rev 232)
+++ pkg/stacomir/DESCRIPTION 2016-11-15 18:17:55 UTC (rev 233)
@@ -16,9 +16,11 @@
'RefTaxon.r'
'RefDC.r'
'BilanAnnuels.r'
+ 'Refpar.r'
+ 'RefHorodate.r'
+ 'BilanArgentee.r'
'utilitaires.r'
'RefStationMesure.r'
- 'RefHorodate.r'
'BilanConditionEnv.r'
'RefListe.r'
'BilanEspeces.r'
@@ -32,7 +34,6 @@
'BilanMigrationInterAnnuelle.r'
'BilanMigrationMult.r'
'RefChoix.r'
- 'Refpar.r'
'Refparqual.r'
'Refparquan.r'
'BilanMigrationPar.r'
@@ -59,6 +60,7 @@
'funtable.r'
'funtraitement_poids.r'
'interface_BilanAnnuels.r'
+ 'interface_BilanArgentee.r'
'interface_BilanConditionEnv.r'
'interface_BilanFonctionnementDC.r'
'interface_BilanFonctionnementDF.r'
Modified: pkg/stacomir/NAMESPACE
===================================================================
--- pkg/stacomir/NAMESPACE 2016-11-01 12:35:03 UTC (rev 232)
+++ pkg/stacomir/NAMESPACE 2016-11-15 18:17:55 UTC (rev 233)
@@ -1,17 +1,22 @@
# Generated by roxygen2: do not edit by hand
export(chargecsv)
+export(f_stade_Durif)
export(fn_EcritBilanJournalier)
export(fn_EcritBilanMensuel)
export(fun_bilanMigrationMult)
export(fun_bilanMigrationMult_Overlaps)
export(fun_char_spe)
+export(funboxplotBilanArgentee)
export(funboxplotBilan_carlot)
export(fundat)
+export(fundensityBilanArgentee)
export(fundensityBilan_carlot)
export(funout)
+export(funpointBilanArgentee)
export(funpointBilan_carlot)
export(funstat)
+export(funtableBilanArgentee)
export(funtableBilan_carlot)
export(funtraitement_poids)
export(funtraitementdate)
@@ -26,6 +31,7 @@
export(stacomi)
export(vector_to_listsql)
exportClasses(BilanAnnuels)
+exportClasses(BilanArgentee)
exportClasses(BilanConditionEnv)
exportClasses(BilanEspeces)
exportClasses(BilanFonctionnementDC)
Added: pkg/stacomir/R/BilanArgentee.r
===================================================================
--- pkg/stacomir/R/BilanArgentee.r (rev 0)
+++ pkg/stacomir/R/BilanArgentee.r 2016-11-15 18:17:55 UTC (rev 233)
@@ -0,0 +1,474 @@
+#' Class "BilanArgentee"
+#'
+#' the BilanArgentee class is used to calculate various statistics about the silver eel run
+#' @include RefDC.r
+#' @include RefTaxon.r
+#' @include RefStades.r
+#' @include RefHorodate.r
+#' @include Refpar.r
+#' @note This class is displayed by interface_bilanArgentee
+#' @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
+#' \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{RefDC-class}: the control devices
+#' @slot taxons Object of class \link{RefTaxon-class}: the speciess
+#' @slot stades Object of class \link{RefStades-class} : the stages of the fish
+#' @slot par Object of class \link{Refpar-class}: the parameters used
+#' @slot horodatedebut An object of class \code{RefHorodate-class}
+#' @slot horodatefin An object of class \code{RefHorodate-class}
+#' @section Objects from the Class: Objects can be created by calls of the form
+#' \code{new("BilanArgentee", ...)}
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @family Bilan Objects
+#' @keywords classes
+#' @example inst/examples/bilancarlot_example.R
+#' @export
+setClass(Class="BilanArgentee",
+ representation= representation(
+ data="data.frame",
+ calcdata="list",
+ dc="RefDC",
+ taxons="RefTaxon",
+ stades="RefStades",
+ par="Refpar",
+ horodatedebut="RefHorodate",
+ horodatefin="RefHorodate"
+ ),
+ prototype=prototype(data=data.frame(),
+ calcdata=list(),
+ dc=new("RefDC"),
+ taxons=new("RefTaxon"),
+ stades=new("RefStades"),
+ par=new("Refpar"),
+ horodatedebut=new("RefHorodate"),
+ horodatefin=new("RefHorodate")
+ ))
+setValidity("BilanArgentee",function(object)
+ {
+ rep1=object at taxons@data$tax_code[1]=='2038'
+ label1<-'BilanArgentee should only be for eel (tax_code=2038)'
+ rep2=all(object at stades@data$std_code%in%c('AGG','AGJ'))
+ label2<-'Only stages silver (AGG) and yellow (AGJ) should be used in BilanArgentee'
+ return(ifelse(rep1 & rep2 , TRUE ,c(label1,label2)[!c(rep1, rep2)]))
+ }
+)
+#' connect method for BilanArgentee
+#'
+#' @param object An object of class \link{BilanArgentee-class}
+#' @param silent Boolean if TRUE messages are not displayed
+#' @return An object of class \link{BilanArgentee-class}
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+setMethod("connect",signature=signature("BilanArgentee"),definition=function(object,silent=FALSE) {
+ requete<-new("RequeteODBCwheredate")
+ requete at baseODBC=get("baseODBC",envir=envir_stacomi)
+ requete at select= paste("SELECT * FROM ",get("sch",envir=envir_stacomi),"vue_lot_ope_car",sep="")
+ requete at colonnedebut="ope_date_debut"
+ requete at colonnefin="ope_date_fin"
+ requete at datedebut<-object at horodatedebut@horodate
+ requete at datefin<-object at horodatefin@horodate
+ requete at order_by="ORDER BY ope_date_debut"
+ requete at and=paste(" AND ope_dic_identifiant in ",vector_to_listsql(object at dc@dc_selectionne),
+ " AND lot_tax_code in ", vector_to_listsql(object at taxons@data$tax_code),
+ " AND lot_std_code in ", vector_to_listsql(object at stades@data$std_code),
+ " AND car_par_code in ", vector_to_listsql(object at par@par_selectionne), sep="")
+ requete<-stacomirtools::connect(requete)
+ object at data<-requete at query
+ if (!silent) funout(get("msg",envir_stacomi)$BilanArgentee.1)
+ return(object)
+ })
+
+
+#' charge method for BilanArgentee 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{BilanArgentee-class}
+#' @param h a handler
+#' @return An object of class \link{BilanArgentee-class} with slots filled with user choice
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+#' @return An object of the class
+setMethod("charge",signature=signature("BilanArgentee"),definition=function(object,h) {
+ if (exists("refDC",envir_stacomi)) {
+ object at dc<-get("refDC",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.1,arret=TRUE)
+ }
+ if (exists("refTaxon",envir_stacomi)) {
+ object at taxons<-get("refTaxon",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.2,arret=TRUE)
+ }
+ if (exists("refStades",envir_stacomi)) {
+ object at stades<-get("refStades",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.3,arret=TRUE)
+ }
+ if (exists("refpar",envir_stacomi)) {
+ object at par<-get("refpar",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.4,arret=TRUE)
+ }
+ # rem pas tres satisfaisant car ce nom est choisi dans l'interface
+ if (exists("bilanArg_date_debut",envir_stacomi)) {
+ object at horodatedebut<-get("bilanArg_date_debut",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.5,arret=TRUE)
+ }
+ # rem id
+ if (exists("bilanArg_date_fin",envir_stacomi)) {
+ object at horodatefin<-get("bilanArg_date_fin",envir_stacomi)
+ } else {
+ funout(get("msg",envir_stacomi)$ref.6,arret=TRUE)
+ }
+
+ return(object)
+ validObject(object)
+ })
+
+
+#' command line interface for BilanArgentee class
+#' @param object An object of class \link{BilanArgentee-class}
+#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,RefDC-method}
+#' @param taxons '2038=Anguilla anguilla',
+#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,RefTaxon-method}
+#' @param stades 'AGG'
+#' @param par Parameters chosen for the Bilan 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 Bilan, 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{BilanMigration-class}
+#' The choice_c method fills in the data slot for classes \link{RefDC-class}, \link{RefTaxon-class}, \link{RefStades-class}, \link{Refpar-class} and two slots of \link{RefHorodate-class} and then
+#' uses the choice_c methods of these object to select the data.
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+setMethod("choice_c",signature=signature("BilanArgentee"),definition=function(object,
+ dc,
+ taxons=2038,
+ stades='AGG',
+ par=c('1786','CCCC','BBBB','CONT','LINP','A111','PECT'),
+ horodatedebut,
+ horodatefin,
+ silent=FALSE){
+ # code for debug using example
+ #bilanArg<-b_carlothorodatedebut="2010-01-01";horodatefin="2015-12-31"
+ bilanArg<-object
+ bilanArg at dc=charge(bilanArg at dc)
+ # loads and verifies the dc
+ # this will set dc_selectionne slot
+ bilanArg at dc<-choice_c(object=bilanArg at dc,dc)
+ # only taxa present in the bilanMigration are used
+ bilanArg at taxons<-charge_avec_filtre(object=bilanArg at taxons,bilanArg at dc@dc_selectionne)
+ bilanArg at taxons<-choice_c(bilanArg at taxons,taxons)
+ bilanArg at stades<-charge_avec_filtre(object=bilanArg at stades,bilanArg at dc@dc_selectionne,bilanArg at taxons@data$tax_code)
+ bilanArg at stades<-choice_c(bilanArg at stades,stades)
+ bilanArg at par<-charge_avec_filtre(object=bilanArg at par,bilanArg at dc@dc_selectionne,bilanArg at taxons@data$tax_code,bilanArg at stades@data$std_code)
+ bilanArg at par<-choice_c(bilanArg at par,par,silent=silent)
+ bilanArg at horodatedebut<-choice_c(object=bilanArg at horodatedebut,
+ nomassign="bilanArg_date_debut",
+ funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.5,
+ horodate=horodatedebut,
+ silent=silent)
+ bilanFonctionnementDC at horodatefin<-choice_c(bilanFonctionnementDC at horodatefin,
+ nomassign="bilanArg_date_fin",
+ funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.6,
+ horodate=horodatefin,
+ silent=silent)
+ validObject(bilanArg)
+ return(bilanArg)
+ })
+#' Calcule method for BilanArgentee, this method will pass the data from long to wide format
+#' ( one line per individual) and calculate Durif silvering index
+#'
+#' @param object An object of class \code{\link{BilanArgentee-class}}
+#' @param silent Boolean, if TRUE, information messages are not displayed, only warnings and errors
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+setMethod("calcule",signature=signature("BilanArgentee"),definition=function(object,silent) {
+ #bilanArg<-b_carlot
+ bilanArg<-object
+ if(nrow(bilanArg at data)==0) {
+ funout(get("msg",envir_stacomi)$BilanArgentee.2, arret=TRUE)
+ }
+ arg=bilanArg at data # on recupere le data.frame
+
+
+ lesdc<-bilanArg at dc@dc_selectionne
+ 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<-funtraitementdate(other,"ope_date_debut",jour_an = TRUE, jour_mois = FALSE)
+ # extracting the dc from the array
+ # all parms are there but some are null, ie 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
+ matqual3<-matrix(NA,nrow=nrow(matqual2[[1]]),ncol=length(parqual))
+ 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(f_stade_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
+ ddd<-cbind(other,dd)
+ bilanArg at calcdata[[as.character(dc)]]<-ddd
+ }
+ assign("bilanArg",bilanArg,envir_stacomi)
+ return(bilanArg)
+ })
+
+
+#' Plots of various type for BilanArgentee
+#'
+#' \itemize{
+#' \item{plot.type="standard"}{calls \code{\link{fungraph}} and \code{\link{fungraph_civelle}} functions to plot as many "bilanmigration"
+#' 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 BilanMigrationMult. Data are summed per day for different dc taxa and stages}
+#' \item{plot.type="multiple"}{Method to overlay graphs for BilanMigrationMult (multiple dc/taxa/stage in the same plot)}
+#' }
+#' @note When plotting the "standard" plot, the user will be prompted to "write" the daily migration and monthly migration in the database.
+#' these entries are necessary to run the Interannual Migration class. If the stacomi has been launched with database_expected=FALSE,
+#' then no entry will be written to the database
+#' @param x An object of class BilanMigrationMult
+#' @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.
+#' @param ... Additional arguments, see \code{plot}, \code{plot.default} and \code{par}
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @aliases plot.BilanArgentee plot.bilanArg plot.b_carlot
+#' @export
+setMethod("plot", signature(x = "BilanArgentee", y = "missing"), definition=function(x, plot.type="1", silent=FALSE){
+ #bilanArg<-b_carlot;require(ggplot2);plot.type="1"
+ #browser()
+ bilanArg<-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("bilanArg",envir_stacomi)) {
+ bilanArg<-get("bilanArg",envir_stacomi)
+ } else {
+ if (!silent) funout(get("msg",envir_stacomi)$BilanMigration.5,arret=TRUE)
+ }
+ dat<-bilanArg at calcdata
+ # cols are using viridis::inferno(6,alpha=0.9)
+ blue_for_males<-adjustcolor("#008490", alpha.f = 0.8)
+
+ datdc<-data.frame()
+
+ #########################"
+ # plot.type
+
+ if (plot.type==1){
+
+ for (i in 1:length(dat)){
+ datdc<-rbind(datdc,dat[[i]])
+ }
+
+ #creating a shingle with some overlaps
+ datdc$Date = lattice::equal.count(datdc$ope_date_debut, number=4,
+ overlap=.1)
+
+
+ # 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(bilanArg at dc@dc_selectionne)){
+ datdc$ouv[datdc$ope_dic_identifiant==bilanArg at dc@dc_selectionne[i]]<-
+ bilanArg at dc@data[bilanArg at dc@data$dc==bilanArg at dc@dc_selectionne[i],"ouv_libelle"]
+ }
+
+
+ my.settings <- list(
+ superpose.symbol=list(
+ col=c("#FBA338","#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="Taille (BL mm) ",
+ ylab=iconv("Diamètre moyen de l'oeil (MD mm) ","UTF8"),
+ par.strip.text=list(col="white", font=2),
+ auto.key=list(title="Stades (Durif et al. 2009)",
+ cex.title=1.2,
+ space="top",
+ columns=6,
+ between.columns=1
+ )
+ )
+ 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(invisible(NULL))
+ })
+
+#' summary for BilanArgentee
+#' @param object An object of class \code{\link{BilanArgentee-class}}
+#' @param silent Should the program stay silent or display messages, default FALSE
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+setMethod("summary",signature=signature(object="BilanArgentee"),definition=function(object,silent=FALSE,...){
+ Hmisc::describe(object at data)
+ })
+
+#' Method to print the command line of the object
+#' @param x An object of class BilanArgentee
+#' @param ... Additional parameters passed to print
+#' @return NULL
+#' @author cedric.briand
+#' @export
+setMethod("print",signature=signature("BilanArgentee"),definition=function(x,...){
+ sortie1<-"bilanArg=new('BilanArgentee')"
+ sortie2<-stringr::str_c("bilanArg=choice_c(bilanArg,",
+ "dc=c(",stringr::str_c(x at dc@dc_selectionne,collapse=","),"),",
+ "taxons=c(",stringr::str_c(shQuote(x at taxons@data$tax_nom_latin),collapse=","),"),",
+ "stades=c(",stringr::str_c(shQuote(x at stades@data$std_code),collapse=","),"),",
+ "par=c(",stringr::str_c(shQuote(x at par@par_selectionne),collapse=","),"),",
+ "horodatedebut=",shQuote(strftime(x at horodatedebut@horodate,format="%d/%m/%Y %H-%M-%S")),
+ ",horodatefin=",shQuote(strftime(x at horodatefin@horodate,format="%d/%m/%Y %H-%M-%S")),")")
+ # removing backslashes
+ funout(sortie1)
+ funout(stringr::str_c(sortie2,...))
+ return(invisible(NULL))
+ })
+
+
+#' fundensityBilanArgentee uses ggplot2 to draw density plots
+#'
+#' assigns an object g in envir_stacomi for eventual modification of the plot
+#' @param h A handler
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+fundensityBilanArgentee = function(h,...) {
+ bilanArg<-charge(bilanArg)
+ bilanArg<-connect(bilanArg)
+ bilanArg<-calcule(bilanArg)
+ bilanArg<-plot(bilanArg,plot.type="1")
+}
+
+#' Boxplots for ggplot2
+#'
+#' assigns an object g in envir_stacomi for eventual modification of the plot
+#' @param h A handler passed by the graphical interface
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+funboxplotBilanArgentee = function(h,...) {
+ bilanArg<-charge(bilanArg)
+ bilanArg<-connect(bilanArg)
+ bilanArg<-calcule(bilanArg)
+ bilanArg<-plot(bilanArg,plot.type="2")
+}
+
+
+#' Point graph from ggplot
+#'
+#' assigns an object g in envir_stacomi for eventual modification of the plot
+#' @param h handler passed by the graphical interface
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+funpointBilanArgentee = function(h,...) {
+ bilanArg<-charge(bilanArg)
+ bilanArg<-connect(bilanArg)
+ bilanArg<-calcule(bilanArg)
+}
+
+#' table function
+#'
+#' funtableBilanArgentee shows a table of results in gdf
+#' @param h hanlder passed by the graphical interface
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+funtableBilanArgentee = function(h,...) {
+ bilanArg=charge(bilanArg)
+ bilanArg<-connect(bilanArg)
+ vue_ope_lot=bilanArg at requete@query # on recupere le data.frame
+ assign("bilanArg",bilanArg,envir_stacomi)#assign("bilanArg",vue_ope_lot,envir_stacomi)
+ funout(get("msg",envir_stacomi)$BilanArgentee.3)
+ vue_ope_lot[is.na(vue_ope_lot)]<-""
+ vue_ope_lot$ope_date_debut=as.character(vue_ope_lot$ope_date_debut)
+ vue_ope_lot$ope_date_fin=as.character(vue_ope_lot$ope_date_fin)
+ gdf(vue_ope_lot, container=TRUE)
+}
+
+
+#' Function to calculate the stages from Durif
+#'
+#' @author Laurent Beaulaton \email{laurent.beaulaton"at"onema.fr}
+#' @export
+f_stade_Durif = function(data){
+ data(coef_Durif)
+ 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")
+ indices<-data%*%coef_Durif
+ return(unlist(apply(indices,1,function(X)ifelse(is.na(X[1]),NA,names(which.max(X))))))
+}
+
Modified: pkg/stacomir/R/Bilan_carlot.r
===================================================================
--- pkg/stacomir/R/Bilan_carlot.r 2016-11-01 12:35:03 UTC (rev 232)
+++ pkg/stacomir/R/Bilan_carlot.r 2016-11-15 18:17:55 UTC (rev 233)
@@ -98,17 +98,17 @@
}
# rem pas tres satisfaisant car ce nom est choisi dans l'interface
if (exists("bilan_carlot_date_debut",envir_stacomi)) {
- object at horodatedebut<-get("bilan_carlot_date_debut",envir_stacomi)
+ object at horodatedebut@horodate<-get("bilan_carlot_date_debut",envir_stacomi)
} else {
funout(get("msg",envir_stacomi)$ref.5,arret=TRUE)
}
# rem id
if (exists("bilan_carlot_date_fin",envir_stacomi)) {
- object at horodatefin<-get("bilan_carlot_date_fin",envir_stacomi)
+ object at horodatefin@horodate<-get("bilan_carlot_date_fin",envir_stacomi)
} else {
funout(get("msg",envir_stacomi)$ref.6,arret=TRUE)
}
-
+ assign("bilan_carlot",object,envir_stacomi)
return(object)
})
@@ -207,17 +207,7 @@
#' Plots of various type for BilanMigration, and performs writing to the database of daily values.
-#'
-#' \itemize{
-#' \item{plot.type="standard"}{calls \code{\link{fungraph}} and \code{\link{fungraph_civelle}} functions to plot as many "bilanmigration"
-#' 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 BilanMigrationMult. Data are summed per day for different dc taxa and stages}
-#' \item{plot.type="multiple"}{Method to overlay graphs for BilanMigrationMult (multiple dc/taxa/stage in the same plot)}
-#' }
-#' @note When plotting the "standard" plot, the user will be prompted to "write" the daily migration and monthly migration in the database.
-#' these entries are necessary to run the Interannual Migration class. If the stacomi has been launched with database_expected=FALSE,
-#' then no entry will be written to the database
-#' @param x An object of class BilanMigrationMult
+#' @param x An object of class Bilan_carlot
#' @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.
@@ -304,10 +294,11 @@
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @export
fundensityBilan_carlot = function(h,...) {
+ bilan_carlot<-get("bilan_carlot",envir=envir_stacomi)
bilan_carlot<-charge(bilan_carlot)
bilan_carlot<-connect(bilan_carlot)
bilan_carlot<-calcule(bilan_carlot)
- bilan_carlot<-plot(bilan_carlot,plot.type="1")
+ plot(bilan_carlot,plot.type="1")
}
#' Boxplots for ggplot2
@@ -318,10 +309,11 @@
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @export
funboxplotBilan_carlot = function(h,...) {
+ bilan_carlot<-get("bilan_carlot",envir=envir_stacomi)
bilan_carlot<-charge(bilan_carlot)
bilan_carlot<-connect(bilan_carlot)
bilan_carlot<-calcule(bilan_carlot)
- bilan_carlot<-plot(bilan_carlot,plot.type="2")
+ plot(bilan_carlot,plot.type="2")
}
@@ -333,9 +325,11 @@
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @export
funpointBilan_carlot = function(h,...) {
+ bilan_carlot<-get("bilan_carlot",envir=envir_stacomi)
bilan_carlot<-charge(bilan_carlot)
bilan_carlot<-connect(bilan_carlot)
bilan_carlot<-calcule(bilan_carlot)
+ plot(bilan_carlot,plot.type="3")
}
#' table function
@@ -346,6 +340,7 @@
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @export
funtableBilan_carlot = function(h,...) {
+ bilan_carlot<-get("bilan_carlot",envir=envir_stacomi)
bilan_carlot=charge(bilan_carlot)
bilan_carlot<-connect(bilan_carlot)
vue_ope_lot=bilan_carlot at requete@query # on recupere le data.frame
Modified: pkg/stacomir/R/RefDC.r
===================================================================
--- pkg/stacomir/R/RefDC.r 2016-11-01 12:35:03 UTC (rev 232)
+++ pkg/stacomir/R/RefDC.r 2016-11-15 18:17:55 UTC (rev 233)
@@ -114,7 +114,8 @@
# ici comme on fait appel e un autre object il faut appeller le conteneur qui contient l'object
if (!is.null(objectBilan)) {
# ci dessous pas d'appel de charge_avec_filtre pour les bilanEspeces (tous les taxons)
- if("RefTaxon"%in%as.character(getSlots(class(objectBilan)))){
+ # pas non plus d'appel pour les bilanArgentee dont les slots taxon, stade ,et par sont fixes
+ if("RefTaxon"%in%as.character(getSlots(class(objectBilan)))&class(objectBilan)!="BilanArgentee"){
objectBilan at taxons<<-charge_avec_filtre(object=objectBilan at taxons,dc_selectionne=get("refDC",object,envir_stacomi)@dc_selectionne)
if (exists("frame_tax")) delete(group,frame_tax)
if (exists("frame_std")) delete(group,frame_std)
Modified: pkg/stacomir/R/Refpar.r
===================================================================
--- pkg/stacomir/R/Refpar.r 2016-11-01 12:35:03 UTC (rev 232)
+++ pkg/stacomir/R/Refpar.r 2016-11-15 18:17:55 UTC (rev 233)
@@ -115,8 +115,8 @@
if (nrow(object at data) > 0){
hcar=function(h,...){
carchoisi=svalue(choice)
- object at par_selectionne<-carchoisi
- #object at data<-object at data[car_libelle%in%carchoisi ,]
+ object at par_selectionne<-object at data[car_libelle%in%carchoisi ,"par_code"]
+ #object at data<-object at data[car_libelle%in%carchoisi ,"par_code"]
assign(nomassign,object,envir_stacomi)
funout(get("msg",envir=envir_stacomi)$Refpar.3)
}
Modified: pkg/stacomir/R/data.r
===================================================================
--- pkg/stacomir/R/data.r 2016-11-01 12:35:03 UTC (rev 232)
+++ pkg/stacomir/R/data.r 2016-11-15 18:17:55 UTC (rev 233)
@@ -209,7 +209,8 @@
#' The first eel trapping ladder in France was built by Antoine Legault and the team from Rennes
#' in the Sevre Niortaise, Marais Poitevin. Also refurbished several times since 1984 it has been
#' operational at the same location and provides one of the longest series of eel migration. For this reason,
-#' the dataset has been loaded as an example for the BilanMigrationInterAnnuelle-class
+#' the dataset has been loaded as an example for the BilanMigrationInterAnnuelle-class. It has been
+#' kindly given by the parc du Marais Poitevin.
#' @format An object of class BilanMigrationInterAnnuelle-class with data slot loaded.
#' @keywords data
"bmi"
@@ -223,7 +224,32 @@
#' Annual migration of salmon by migradour
#'
-#' The dataset corresponds to the fishways of the Adour for adult migrant salmons
+#' The dataset corresponds to the fishways DC=33:40 of the Adour for adult migrant salmons
+#' from 1996 to 2005 (annual counts). It has been kinly provided as an example set by the Migradour
+#' association.
#' @format An object of class \link{BilanAnnuels-class} with data slot loaded.
#' @keywords data
-"bilAM"
\ No newline at end of file
+"bilAM"
+
+
+#' Silver eel migration in the Somme
+#'
+#' The dataset corresponds to the silver eel traps ("anguilleres) for 2015-2016.
+#' This dataset has been kindly provided by the Federation de Peche de la Somme,
+#' given the upstream location of the trap, all individuals are female
+#'
+#' @format An object of class \link{BilanAnnuels-class} with data slot loaded.
+#' @keywords data
+"bilanArg"
+
+#' Silvering index coefficients from Caroline Durif (2009) to predict silvering stage from morphological parameters
+#' Classification scores are calculated by multiplying the metrics
+#' BL = body length, W = weight, MD = mean eye diameter (Dv+Dh)/2, and FL length of the pectoral fin,
+#' with each parameter p as S=Constant+BL*p(bl)+W*p(W)... The stage chosen is the one achieving the
+#' highest score
+#' @references Durif, C.M., Guibert, A., and Elie, P. 2009.
+#' Morphological discrimination of the silvering stages of the European eel.
+#' In American Fisheries Society Symposium. pp. 103–111.
+#' \url{http://fishlarvae.org/common/SiteMedia/durif\%20et\%20al\%202009b.pdf}
+"coef_Durif"
+
Modified: pkg/stacomir/R/interface_BilanAnnuels.r
===================================================================
--- pkg/stacomir/R/interface_BilanAnnuels.r 2016-11-01 12:35:03 UTC (rev 232)
+++ pkg/stacomir/R/interface_BilanAnnuels.r 2016-11-15 18:17:55 UTC (rev 233)
@@ -27,7 +27,7 @@
size(notebook)<-c(400,300)
# pour preselectionner une date on lui fournit l'indice de la date dans le RefAnnee. indice = 11 pour 2005
- choice(bilA at anneedebut,
+ choice(bilanAnnuels at anneedebut,
nomassign="anneedebut",
funoutlabel=get("msg",envir=envir_stacomi)$interface_BilanMigrationInterannuelle.2,
titleFrame=get("msg",envir=envir_stacomi)$interface_BilanMigrationInterannuelle.3,
@@ -37,7 +37,7 @@
funoutlabel=get("msg",envir=envir_stacomi)$interface_BilanMigrationInterannuelle.4,
titleFrame=get("msg",envir=envir_stacomi)$interface_BilanMigrationInterannuelle.5,
preselect=which(bilA at anneefin@data==max(bilanAnnuels at anneefin@data)))
- choicemult(bilA at dc,objectBilan=bilanAnnuels,is.enabled=TRUE)
+ choicemult(bilanAnnuels at dc,objectBilan=bilanAnnuels,is.enabled=TRUE)
svalue(notebook)<-1
ggroupboutonsbas = gWidgets::ggroup(horizontal=FALSE)
Added: pkg/stacomir/R/interface_BilanArgentee.r
===================================================================
--- pkg/stacomir/R/interface_BilanArgentee.r (rev 0)
+++ pkg/stacomir/R/interface_BilanArgentee.r 2016-11-15 18:17:55 UTC (rev 233)
@@ -0,0 +1,74 @@
+#' An interface that calls the object to build the user interface
+#' @note always has to be called within a group constructed and deleted using quitte()
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+interface_BilanArgentee = function()
+{
+ quitte() # vidange de l'interface
+ bilan_arg=new("BilanArgentee")
+ assign("bilan_arg",bilan_arg,envir = envir_stacomi)
+
+ funout(get("msg",envir=envir_stacomi)$interface_Bilan_lot.1)
+ bilan_arg at dc=charge(bilan_arg at dc)
+ bilan_arg at taxons=charge(bilan_arg at taxons)
+ bilan_arg at stades=charge(bilan_arg at stades)
+ bilan_arg at par=charge(bilan_arg at par)
+
+ group <- gWidgets::ggroup(horizontal=FALSE) # doit toujours s'appeller group
+
+ assign("group",group,envir = .GlobalEnv)
+ gWidgets::add(ggroupboutons,group)
+ gl=glabel(text=get("msg",envir=envir_stacomi)$interface_Bilan_lot.2,container=group)
+ # dans l'ordre
+ # dans le handler, modifier le contenu de l'object fils si il existe
+ # supprimer les widgets fils si ils existent (appel de la methode delete)
+ # appeller la methode choice pour l'affichage du fils si il existe
+
+
+ choice(bilan_arg at horodate,label=get("msg",envir=envir_stacomi)$interface_Bilan_lot.3,
+ nomassign="bilan_arg_date_debut",
+ funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.5,
+ decal=-2,
+ affichecal=FALSE)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/stacomir -r 233
More information about the Stacomir-commits
mailing list