[Stacomir-commits] r340 - in pkg/stacomir: R inst/examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Apr 6 08:54:27 CEST 2017
Author: briand
Date: 2017-04-06 08:54:27 +0200 (Thu, 06 Apr 2017)
New Revision: 340
Added:
pkg/stacomir/R/BilanMigrationCar.r
pkg/stacomir/inst/examples/bilanMigrationCar-example.R
Removed:
pkg/stacomir/R/BilanMigrationPar.r
Modified:
pkg/stacomir/R/BilanOperation.r
pkg/stacomir/inst/examples/bilanAgedemer_example.R
Log:
Copied: pkg/stacomir/R/BilanMigrationCar.r (from rev 335, pkg/stacomir/R/BilanMigrationPar.r)
===================================================================
--- pkg/stacomir/R/BilanMigrationCar.r (rev 0)
+++ pkg/stacomir/R/BilanMigrationCar.r 2017-04-06 06:54:27 UTC (rev 340)
@@ -0,0 +1,321 @@
+#' 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 BilanMigration and BilanMigrationMult
+#' the whole time span of the migration operation is not considered, only the date of beginning of
+#' the operation is used to perform calculation.
+#'
+#' @include Refparquan.r
+#' @include Refparqual.r
+#' @include RefChoix.r
+#' @note The program by default uses two parameter choice, checking box "none" will
+#' allow the program to ignore the parameter
+#' @section Objects from the Class: Objects can be created by calls of the form
+#' \code{new("BilanMigrationCar", ...)}. they are loaded by the interface
+#' using interface_BilanMigrationCar function.
+#' @slot parquan An object of class \link{Refparquan-class}, quantitative parameter
+#' @slot parqual An object of class \link{Refparqual-class}, quanlitative parameter
+#' @slot echantillon An object of class \link{RefChoix-class}, vector of choice
+#' @slot valeurs_possibles A \code{data.frame} choice among possible choice of a qualitative parameter (discrete)
+#' @slot dc an object of class \link{RefDC-class} inherited from \link{BilanMigration-class}
+#' @slot taxons An object of class \link{RefTaxon-class} inherited from \link{BilanMigration-class}
+#' @slot stades An object of class \link{RefStades-class} inherited from \link{BilanMigration-class}
+#' @slot pasDeTemps An object of class \link{PasDeTempsJournalier-class} inherited from \link{BilanMigration-class}
+#' @slot data A \code{data.frame} inherited from \link{BilanMigration-class}, stores the results
+#' @slot time.sequence An object of class "POSIXct" inherited from \link{BilanMigration-class}
+#' #' @family Bilan Objects
+#' @aliases BilanMigrationMult bilanMigrationMult
+#' @note program : default two parameter choice, checking box "aucun" will allow the program to ignore the parameter
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+
+#' @concept Bilan Object
+#' @keywords classes
+setClass(Class="BilanMigrationCar",
+ representation=representation(parquan="Refparquan",
+ parqual="Refparqual",
+ echantillon="RefChoix",
+ valeurs_possibles="data.frame"),
+ prototype=prototype(parquan=new("Refparquan"),
+ parqual=new("Refparqual"),
+ echantillon=new("RefChoix"),
+ valeurs_possibles=data.frame()),
+ contains="BilanMigrationMult")
+#object=bmC
+
+setValidity("BilanMigrationCar",function(object)
+ {
+ rep4=length(object at pasDeTemps)==1
+ if (!rep4) retValue="length(object at pasDeTemps) different de 1, plusieurs stades alors que la classe n'en comporte qu'un"
+ rep5=length(object at parqual)==1|length(object at parquan)==1 #au moins un qualitatif ou un quantitatif
+ if (!rep5) retValue="length(object at parqual)==1|length(object at parquan)==1 non respecte"
+ return(ifelse(rep4 & rep5,TRUE,retValue))
+ } )
+
+
+#' command line interface for BilanAgedemer class
+#' @param object An object of class \link{BilanAgedemer-class}
+#' @param dc A numeric or integer, the code of the dc, coerced to integer,see \link{choice_c,RefDC-method}
+#' @param taxons '2220=Salmo salar',
+#' these should match the ref.tr_taxon_tax referential table in the stacomi database, see \link{choice_c,RefTaxon-method}
+#' @param stades '5','11','BEC','BER','IND'
+#' @param par Parameters chosen for the Bilan are mesured body size (1786), mesured 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 Bilan, for this class this will be used to calculate the number of daily steps.
+#' @param silent Default FALSE, if TRUE the program should no display messages
+#' @return An object of class \link{BilanAgedemer-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("BilanAgedemer"),definition=function(object,
+ dc,
+ taxons=2220,
+ stades=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);
+ #taxons='2220'; stades=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)
+
+ bilan_adm<-object
+ bilan_adm at dc=charge(bilan_adm at dc)
+ # loads and verifies the dc
+ # this will set dc_selectionne slot
+ bilan_adm at dc<-choice_c(object=bilan_adm at dc,dc)
+ # only taxa present in the bilanMigration are used
+ bilan_adm at taxons<-charge_avec_filtre(object=bilan_adm at taxons,bilan_adm at dc@dc_selectionne)
+ bilan_adm at taxons<-choice_c(bilan_adm at taxons,taxons)
+ bilan_adm at stades<-charge_avec_filtre(object=bilan_adm at stades,bilan_adm at dc@dc_selectionne,bilan_adm at taxons@data$tax_code)
+ bilan_adm at stades<-choice_c(bilan_adm at stades,stades,silent=silent)
+ bilan_adm at par<-charge_avec_filtre(object=bilan_adm at par,bilan_adm at dc@dc_selectionne,bilan_adm at taxons@data$tax_code,bilan_adm at stades@data$std_code)
+ bilan_adm at par<-choice_c(bilan_adm at par,par,silent=silent)
+ bilan_adm at horodatedebut<-choice_c(object=bilan_adm at horodatedebut,
+ nomassign="bilan_adm_date_debut",
+ funoutlabel=gettext("Beginning date has been chosen\n",domain="R-stacomiR"),
+ horodate=horodatedebut,
+ silent=silent)
+ bilan_adm at horodatefin<-choice_c(bilan_adm at horodatefin,
+ nomassign="bilan_adm_date_fin",
+ funoutlabel=gettext("Ending date has been chosen\n",domain="R-stacomiR"),
+ horodate=horodatefin,
+ silent=silent)
+ bilan_adm at limit1hm<-choice_c(bilan_adm at limit1hm,as.character(limit1hm),"limit1hm")
+ bilan_adm at limit2hm<-choice_c(bilan_adm at limit2hm,as.character(limit2hm),"limit2hm")
+ validObject(bilan_adm)
+ return(bilan_adm)
+ })
+#' charge method for BilanMigrationCar
+#'
+#' Used by the graphical interface to collect and test objects in the environment envir_stacomi,
+#' fills also the data slot by the connect method
+#' @param object An object of class \link{BilanMigrationMult-class}
+#' @param silent Default FALSE, if TRUE the program should no display messages
+#' @return \link{BilanMigrationCar-class} with slots filled by user choice
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+setMethod("charge",signature=signature("BilanMigrationMult"),definition=function(object,silent=FALSE){
+ bmC<-object
+ if (exists("refDC",envir_stacomi)) {
+ bmC at dc<-get("refDC",envir_stacomi)
+ } else {
+ funout(gettext("You need to choose a counting device, clic on validate\n",domain="R-stacomiR"),arret=TRUE)
+ }
+ if (exists("refTaxon",envir_stacomi)) {
+ bmC at taxons<-get("refTaxon",envir_stacomi)
+ } else {
+ funout(gettext("You need to choose a taxa, clic on validate\n",domain="R-stacomiR"),arret=TRUE)
+ }
+ if (exists("refStades",envir_stacomi)){
+ bmC at stades<-get("refStades",envir_stacomi)
+ } else
+ {
+ funout(gettext("You need to choose a stage, clic on validate\n",domain="R-stacomiR"),arret=TRUE)
+ }
+ if (exists("pasDeTemps",envir_stacomi)){
+ bmC at pasDeTemps<-get("pasDeTemps",envir_stacomi)
+ # pour permettre le fonctionnement de Fonctionnement DC
+ assign("bilanFonctionnementDC_date_debut",get("pasDeTemps",envir_stacomi)@"dateDebut",envir_stacomi)
+ assign("bilanFonctionnementDC_date_fin",as.POSIXlt(DateFin(get("pasDeTemps",envir_stacomi))),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")
+ }
+ if (exists("refchoice",envir_stacomi)){
+ bmC at echantillon<-get("refchoice",envir_stacomi)
+ } else
+ {
+ bmC at echantillon@listechoice<-"avec"
+ bmC at echantillon@selected<-as.integer(1)
+ }
+ if (exists("refparquan",envir_stacomi)){
+ bmC at parquan<-get("refparquan",envir_stacomi)
+ } else
+ {
+ funout(gettext("You need to choose a quantitative parameter\n",domain="R-stacomiR"),arret=TRUE)
+ }
+ if (exists("refparqual",envir_stacomi)){
+ bmC at parqual<-get("refparqual",envir_stacomi)
+ } else
+ {
+ funout(gettext("You need to choose a qualitative parameter\n",domain="R-stacomiR"),arret=TRUE)
+ }
+
+ stopifnot(validObject(bmC, test=TRUE))
+ funout(gettext("Attention, no time step selected, compunting with default value\n",domain="R-stacomiR"))
+
+ })
+
+#' handler for bilanmigrationpar
+#' @param h handler
+#' @param ... Additional parameters
+ hbmCcalc=function(h,...){
+ calcule(h$action)
+ }
+#' calcule methode
+#'
+#'
+#'@param object An object of class \code{\link{BilanMigrationCar-class}}
+setMethod("calcule",signature=signature("BilanMigrationCar"),definition=function(object){
+ bmC<-object
+ if (bmC at parquan@data$par_nom=="aucune" & bmC at parqual@data$par_nom=="aucune") {
+ funout(gettext("You need to choose at least one quantitative or qualitative attribute\n",domain="R-stacomiR"),arret=TRUE)}
+ res<-funSousListeBilanMigrationCar(bmC=bmC)
+ if (exists("progres")) close(progres)
+ data<-res[[1]]
+ data[,"debut_pas"]<-as.POSIXct(strptime(x=data[,"debut_pas"],format="%Y-%m-%d")) # je repasse de caractere
+ data[,"fin_pas"]<-as.POSIXct(strptime(data[,"fin_pas"],format="%Y-%m-%d"))
+ bmC at valeurs_possibles<-res[[2]] # definitions des niveaux de parametres qualitatifs rencontres.
+ # funout("\n")
+ # assign("data",data,envir_stacomi)
+ #funout(gettext("the migration summary table is stored in envir_stacomi\n",domain="R-stacomiR"))
+ #data<-get("data",envir_stacomi)
+ # chargement des donnees suivant le format chargement_donnees1
+ bmC at time.sequence=seq.POSIXt(from=min(data$debut_pas),to=max(data$debut_pas),by=as.numeric(bmC at pasDeTemps@stepDuration)) # il peut y avoir des lignes repetees poids effectif
+
+ if (bmC at taxons@data$tax_nom_commun=="Anguilla anguilla"& bmC at stades@data$std_libelle=="civelle")
+ {
+ funout(gettext("Be careful, the processing doesnt take lot\"s quantities into account \n",domain="R-stacomiR"))
+ }
+ funout(gettext("Writing data into envir_stacomi environment : write data=get(\"data\",envir_stacomi) \n",domain="R-stacomiR"))
+ bmC at data<-data
+ assign("bmC",bmC,envir_stacomi)
+ assign("data",data,envir_stacomi)
+ # graphiques (a affiner pb si autre chose que journalier)
+ # pour sauvegarder sous excel
+ })
+#' le handler appelle la methode generique graphe sur l'object plot.type=1
+#'
+#' @param h handler
+#' @param ... Additional parameters
+hbmCgraph = function(h,...) {
+ if (exists("bmC",envir_stacomi)) {
+ bmC<-get("bmC",envir_stacomi)
+ plot(bmC,plot.type="barplot")
+ } else {
+ funout(gettext("You need to launch computation first, clic on calc\n",domain="R-stacomiR"),arret=TRUE)
+ }
+}
+#' le handler appelle la methode generique graphe sur l'object plot.type=2
+#'
+#' @param h handler
+#' @param ... Additional parameters
+hbmCgraph2=function(h,...){
+ if (exists("bmC",envir_stacomi)) {
+ bmC<-get("bmC",envir_stacomi)
+ plot(bmC,plot.type="xyplot")
+ } else {
+ funout(gettext("You need to launch computation first, clic on calc\n",domain="R-stacomiR"),arret=TRUE)
+ }
+}
+#' This handler calls the generic method graphe on object plot.type 3
+#'
+#'
+#' @param h handler
+#' @param ... Additional parameters
+hbmCstat=function(h){
+ if (exists("bmC",envir_stacomi)) {
+ bmC<-get("bmC",envir_stacomi)
+ plot(bmC,plot.type="summary")
+ } else {
+ funout(gettext("You need to launch computation first, clic on calc\n",arret=TRUE) )
+ }
+}
+
+#' plot method for BilanMigrationCar
+#'
+#'
+#' @param x An object of class BilanMigrationCar
+#' @param y not used there
+#' @param plot.type One of "barplot", "xyplot", "summary table
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+setMethod("plot",signature=signature(x="BilanMigrationCar",y="ANY"),definition=function(x,y,plot.type="barplot",...){
+ ###########################
+ bmC<-x # ne pas passer dessus en debug manuel
+ ##########################
+ colnames(bmC at data)<-gsub("debut_pas","Date",colnames(bmC at data))
+ if (bmC at parqual@data$par_nom!="aucune"& bmC at parquan@data$par_nom!="aucune") {# il y a des qualites et des quantites de lots
+ nmvarqan=gsub(" ","_",bmC at parquan@data$par_nom) # nom variable quantitative
+ colnames(bmC at data)<-gsub("quantite",nmvarqan,colnames(bmC at data))
+ mb=reshape2::melt(bmC at data,id.vars=c(1:4),measure.vars=grep(nmvarqan,colnames(bmC at data)))
+ # ici je ne sors que les variables quantitatives pour les graphes ulterieurs (j'ignore les effectifs)
+ } else if (bmC at parqual@data$par_nom!="aucune"){ # c'est que des caracteristiques qualitatives
+ mb=reshape2::melt(bmC at data,id.vars=c(1:4),measure.vars=grep("effectif",colnames(bmC at data))) # effectifs en fonction des variables qualitatives, il n'y a qu'une seule colonne
+ } else if (bmC at parquan@data$par_nom!="aucune"){ # c'est que des caracteristiques quantitatives
+ nmvarqan=gsub(" ","_",bmC at parquan@data$par_nom) # nom variable quantitative
+ colnames(bmC at data)<-gsub("quantite",nmvarqan,colnames(bmC at data)) # je renomme la variable quant
+ mb=reshape2::melt(bmC at data,id.vars=c(1:4),measure.vars=grep(nmvarqan,colnames(bmC at data))) # valeurs quantitatives (il n'y a qu'une)
+ } else if (bmC at parquan@data$par_nom=="aucune"&bmC at parqual@data$par_nom=="aucune"){
+ stop("This shouldn't be possible")
+ # ce cas est impossible
+ }
+ mb=stacomirtools::chnames(mb,"value","sum")
+ mb=funtraitementdate(data=mb,nom_coldt="Date")
+ # transformation du tableau de donnees
+
+ if (plot.type=="barplot") {
+
+ g<-ggplot(mb)
+ g<-g+geom_bar(aes(x=mois,y=sum,fill=variable),stat='identity',
+ stack=TRUE)
+ assign("g",g,envir_stacomi)
+ 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 = "barplot"
+ if (plot.type=="xyplot") {
+
+ g<-ggplot(mb)
+ g<-g+geom_point(aes(x=Date,y=sum,col=variable),stat='identity',stack=TRUE)
+ assign("g",g,envir_stacomi)
+ 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"
+ #TODO create summary method
+ if (plot.type=="summary") {
+ table=round(tapply(mb$sum,list(mb$mois,mb$variable),sum),1)
+ table=as.data.frame(table)
+ table[,"total"]<-rowSums(table)
+ gdf(table, container=TRUE)
+ nomdc=bmC at dc@data$df_code[match(bmC at dc@dc_selectionne,bmC at dc@data$dc)]
+ annee=unique(strftime(as.POSIXlt(bmC at time.sequence),"%Y"))
+ path1=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste(nmvarqan,"_mensuel_",nomdc,"_",bmC at taxons@data$tax_nom_commun,"_",bmC at stades@data$std_libelle,"_",annee,".csv",sep=""),fsep ="\\")
+ write.table(table,file=path1,row.names=FALSE,col.names=TRUE,sep=";")
+ funout(gettextf("Writing of %s",path1))
+ path1=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste(nmvarqan,"_journalier_",nomdc,"_",bmC at taxons@data$tax_nom_commun,"_",bmC at stades@data$std_libelle,"_",annee,".csv",sep=""),fsep ="\\")
+ write.table(bmC at data,file=path1,row.names=FALSE,col.names=TRUE,sep=";")
+ funout(gettextf("Writing of %s",path1))
+ } # end plot.type summary
+ })
+
+
+
+
+
Deleted: pkg/stacomir/R/BilanMigrationPar.r
===================================================================
--- pkg/stacomir/R/BilanMigrationPar.r 2017-04-05 09:56:38 UTC (rev 339)
+++ pkg/stacomir/R/BilanMigrationPar.r 2017-04-06 06:54:27 UTC (rev 340)
@@ -1,266 +0,0 @@
-#' 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. This class does not split migration evenly over
-#' time period. So, unlike calculations made in class BilanMigration and BilanMigrationMult
-#' the whole time span of the migration operation is not considered, only the date of beginning of
-#' the operation is used to perform calculation.
-#'
-#' @include Refparquan.r
-#' @include Refparqual.r
-#' @include RefChoix.r
-#' @note The program by default uses two parameter choice, checking box "aucun" will
-#' allow the program to ignore the parameter
-#' @section Objects from the Class: Objects can be created by calls of the form
-#' \code{new("BilanMigrationPar", ...)}. they are loaded by the interface
-#' using interface_BilanMigrationPar function.
-#' @slot parquan An object of class \link{Refparquan-class}, quantitative parameter
-#' @slot parqual An object of class \link{Refparqual-class}, quanlitative parameter
-#' @slot echantillon An object of class \link{RefChoix-class}, vector of choice
-#' @slot valeurs_possibles A \code{data.frame} choice among possible choice of a qualitative parameter (discrete)
-#' @slot dc an object of class \link{RefDC-class} inherited from \link{BilanMigration-class}
-#' @slot taxons An object of class \link{RefTaxon-class} inherited from \link{BilanMigration-class}
-#' @slot stades An object of class \link{RefStades-class} inherited from \link{BilanMigration-class}
-#' @slot pasDeTemps An object of class \link{PasDeTempsJournalier-class} inherited from \link{BilanMigration-class}
-#' @slot data A \code{data.frame} inherited from \link{BilanMigration-class}, stores the results
-#' @slot time.sequence An object of class "POSIXct" inherited from \link{BilanMigration-class}
-#' @note program : default two parameter choice, checking box "aucun" will allow the program to ignore the parameter
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @seealso Other Bilan Class
-#' \code{\linkS4class{Bilan_carlot}},
-#' \code{\linkS4class{Bilan_poids_moyen}},
-#' \code{\linkS4class{Bilan_stades_pigm}},
-#' \code{\linkS4class{Bilan_taille}},
-#' \code{\linkS4class{BilanConditionEnv}},
-#' \code{\linkS4class{BilanEspeces}},
-#' \code{\linkS4class{BilanFonctionnementDC}},
-#' \code{\linkS4class{BilanFonctionnementDF}},
-#' \code{\linkS4class{BilanMigration}},
-#' \code{\linkS4class{BilanMigrationConditionEnv}},
-#' \code{\linkS4class{BilanMigrationInterAnnuelle}},
-#' \code{\linkS4class{BilanMigrationPar}}
-#' @concept Bilan Object
-#' @keywords classes
-setClass(Class="BilanMigrationPar",
- representation=representation(parquan="Refparquan",
- parqual="Refparqual",
- echantillon="RefChoix",
- valeurs_possibles="data.frame"),
- prototype=prototype(parquan=new("Refparquan"),
- parqual=new("Refparqual"),
- echantillon=new("RefChoix"),
- valeurs_possibles=data.frame()),
- contains="BilanMigration")
-#object=bilanMigrationPar
-
-setValidity("BilanMigrationPar",function(object)
- {
- rep1=length(object at dc)==1
- if (!rep1) retValue="length(object at dc) different de 1, plusieurs dc alors que la classe n'en comporte qu'un"
- rep2=length(object at taxons)==1
- if (!rep2) retValue="length(object at taxons) different de 1, plusieurs taxons alors que la classe n'en comporte qu'un"
- rep3=length(object at stades)==1
- if (!rep3) retValue="length(object at stades) different de 1, plusieurs stades alors que la classe n'en comporte qu'un"
- rep4=length(object at pasDeTemps)==1
- if (!rep4) retValue="length(object at pasDeTemps) different de 1, plusieurs stades alors que la classe n'en comporte qu'un"
- rep5=length(object at parqual)==1|length(object at parquan)==1 #au moins un qualitatif ou un quantitatif
- if (!rep5) retValue="length(object at parqual)==1|length(object at parquan)==1 non respecte"
- return(ifelse(rep1 & rep2 & rep3 & rep4 & rep5,TRUE,retValue))
- } )
-
-#' handler for bilanmigrationpar
-#' @param h handler
-#' @param ... Additional parameters
-hbilanMigrationParcalc=function(h,...){
- calcule(h$action)
-}
-
-#' calcule methode
-#'
-#'
-#'@param object An object of class \code{\link{BilanMigrationPar-class}}
-setMethod("calcule",signature=signature("BilanMigrationPar"),definition=function(object){
- bilanMigrationPar<-object
- if (exists("refDC",envir_stacomi)) {
- bilanMigrationPar at dc<-get("refDC",envir_stacomi)
- } else {
- funout(gettext("You need to choose a counting device, clic on validate\n",domain="R-stacomiR"),arret=TRUE)
- }
- if (exists("refTaxon",envir_stacomi)) {
- bilanMigrationPar at taxons<-get("refTaxon",envir_stacomi)
- } else {
- funout(gettext("You need to choose a taxa, clic on validate\n",domain="R-stacomiR"),arret=TRUE)
- }
- if (exists("refStades",envir_stacomi)){
- bilanMigrationPar at stades<-get("refStades",envir_stacomi)
- } else
- {
- funout(gettext("You need to choose a stage, clic on validate\n",domain="R-stacomiR"),arret=TRUE)
- }
- if (exists("pasDeTemps",envir_stacomi)){
- bilanMigrationPar at pasDeTemps<-get("pasDeTemps",envir_stacomi)
- # pour permettre le fonctionnement de Fonctionnement DC
- assign("bilanFonctionnementDC_date_debut",get("pasDeTemps",envir_stacomi)@"dateDebut",envir_stacomi)
- assign("bilanFonctionnementDC_date_fin",as.POSIXlt(DateFin(get("pasDeTemps",envir_stacomi))),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")
- }
- if (exists("refchoice",envir_stacomi)){
- bilanMigrationPar at echantillon<-get("refchoice",envir_stacomi)
- } else
- {
- bilanMigrationPar at echantillon@listechoice<-"avec"
- bilanMigrationPar at echantillon@selected<-as.integer(1)
- }
- if (exists("refparquan",envir_stacomi)){
- bilanMigrationPar at parquan<-get("refparquan",envir_stacomi)
- } else
- {
- funout(gettext("You need to choose a quantitative parameter\n",domain="R-stacomiR"),arret=TRUE)
- }
- if (exists("refparqual",envir_stacomi)){
- bilanMigrationPar at parqual<-get("refparqual",envir_stacomi)
- } else
- {
- funout(gettext("You need to choose a qualitative parameter\n",domain="R-stacomiR"),arret=TRUE)
- }
-
- stopifnot(validObject(bilanMigrationPar, test=TRUE))
- funout(gettext("Attention, no time step selected, compunting with default value\n",domain="R-stacomiR"))
- if (bilanMigrationPar at parquan@data$par_nom=="aucune" & bilanMigrationPar at parqual@data$par_nom=="aucune") {
- funout(gettext("You need to choose at least one quantitative or qualitative attribute\n",domain="R-stacomiR"),arret=TRUE)}
- res<-funSousListeBilanMigrationPar(bilanMigrationPar=bilanMigrationPar)
- if (exists("progres")) close(progres)
- data<-res[[1]]
- data[,"debut_pas"]<-as.POSIXct(strptime(x=data[,"debut_pas"],format="%Y-%m-%d")) # je repasse de caractere
- data[,"fin_pas"]<-as.POSIXct(strptime(data[,"fin_pas"],format="%Y-%m-%d"))
- bilanMigrationPar at valeurs_possibles<-res[[2]] # definitions des niveaux de parametres qualitatifs rencontres.
- # funout("\n")
- # assign("data",data,envir_stacomi)
- #funout(gettext("the migration summary table is stored in envir_stacomi\n",domain="R-stacomiR"))
- #data<-get("data",envir_stacomi)
- # chargement des donnees suivant le format chargement_donnees1
- bilanMigrationPar at time.sequence=seq.POSIXt(from=min(data$debut_pas),to=max(data$debut_pas),by=as.numeric(bilanMigrationPar at pasDeTemps@stepDuration)) # il peut y avoir des lignes repetees poids effectif
-
- if (bilanMigrationPar at taxons@data$tax_nom_commun=="Anguilla anguilla"& bilanMigrationPar at stades@data$std_libelle=="civelle")
- {
- funout(gettext("Be careful, the processing doesnt take lot\"s quantities into account \n",domain="R-stacomiR"))
- }
- funout(gettext("Writing data into envir_stacomi environment : write data=get(\"data\",envir_stacomi) \n",domain="R-stacomiR"))
- bilanMigrationPar at data<-data
- assign("bilanMigrationPar",bilanMigrationPar,envir_stacomi)
- assign("data",data,envir_stacomi)
- # graphiques (a affiner pb si autre chose que journalier)
- # pour sauvegarder sous excel
- })
-#' le handler appelle la methode generique graphe sur l'object plot.type=1
-#'
-#' @param h handler
-#' @param ... Additional parameters
-hbilanMigrationPargraph = function(h,...) {
- if (exists("bilanMigrationPar",envir_stacomi)) {
- bilanMigrationPar<-get("bilanMigrationPar",envir_stacomi)
- plot(bilanMigrationPar,plot.type="barplot")
- } else {
- funout(gettext("You need to launch computation first, clic on calc\n",domain="R-stacomiR"),arret=TRUE)
- }
-}
-#' le handler appelle la methode generique graphe sur l'object plot.type=2
-#'
-#' @param h handler
-#' @param ... Additional parameters
-hbilanMigrationPargraph2=function(h,...){
- if (exists("bilanMigrationPar",envir_stacomi)) {
- bilanMigrationPar<-get("bilanMigrationPar",envir_stacomi)
- plot(bilanMigrationPar,plot.type="xyplot")
- } else {
- funout(gettext("You need to launch computation first, clic on calc\n",domain="R-stacomiR"),arret=TRUE)
- }
-}
-#' This handler calls the generic method graphe on object plot.type 3
-#'
-#'
-#' @param h handler
-#' @param ... Additional parameters
-hbilanMigrationParstat=function(h){
- if (exists("bilanMigrationPar",envir_stacomi)) {
- bilanMigrationPar<-get("bilanMigrationPar",envir_stacomi)
- plot(bilanMigrationPar,plot.type="summary")
- } else {
- funout(gettext("You need to launch computation first, clic on calc\n",arret=TRUE) )
- }
-}
-
-#' plot method for BilanMigrationPar
-#'
-#'
-#' @param x An object of class BilanMigrationPar
-#' @param y not used there
-#' @param plot.type One of "barplot", "xyplot", "summary table
-#' @param ... Additional parameters
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-setMethod("plot",signature=signature(x="BilanMigrationPar",y="ANY"),definition=function(x,y,plot.type="barplot",...){
- ###########################
- bilanMigrationPar<-x # ne pas passer dessus en debug manuel
- ##########################
- colnames(bilanMigrationPar at data)<-gsub("debut_pas","Date",colnames(bilanMigrationPar at data))
- if (bilanMigrationPar at parqual@data$par_nom!="aucune"& bilanMigrationPar at parquan@data$par_nom!="aucune") {# il y a des qualites et des quantites de lots
- nmvarqan=gsub(" ","_",bilanMigrationPar at parquan@data$par_nom) # nom variable quantitative
- colnames(bilanMigrationPar at data)<-gsub("quantite",nmvarqan,colnames(bilanMigrationPar at data))
- mb=reshape2::melt(bilanMigrationPar at data,id.vars=c(1:4),measure.vars=grep(nmvarqan,colnames(bilanMigrationPar at data)))
- # ici je ne sors que les variables quantitatives pour les graphes ulterieurs (j'ignore les effectifs)
- } else if (bilanMigrationPar at parqual@data$par_nom!="aucune"){ # c'est que des caracteristiques qualitatives
- mb=reshape2::melt(bilanMigrationPar at data,id.vars=c(1:4),measure.vars=grep("effectif",colnames(bilanMigrationPar at data))) # effectifs en fonction des variables qualitatives, il n'y a qu'une seule colonne
- } else if (bilanMigrationPar at parquan@data$par_nom!="aucune"){ # c'est que des caracteristiques quantitatives
- nmvarqan=gsub(" ","_",bilanMigrationPar at parquan@data$par_nom) # nom variable quantitative
- colnames(bilanMigrationPar at data)<-gsub("quantite",nmvarqan,colnames(bilanMigrationPar at data)) # je renomme la variable quant
- mb=reshape2::melt(bilanMigrationPar at data,id.vars=c(1:4),measure.vars=grep(nmvarqan,colnames(bilanMigrationPar at data))) # valeurs quantitatives (il n'y a qu'une)
- } else if (bilanMigrationPar at parquan@data$par_nom=="aucune"&bilanMigrationPar at parqual@data$par_nom=="aucune"){
- stop("This shouldn't be possible")
- # ce cas est impossible
- }
- mb=stacomirtools::chnames(mb,"value","sum")
- mb=funtraitementdate(data=mb,nom_coldt="Date")
- # transformation du tableau de donnees
-
- if (plot.type=="barplot") {
-
- g<-ggplot(mb)
- g<-g+geom_bar(aes(x=mois,y=sum,fill=variable),stat='identity',
- stack=TRUE)
- assign("g",g,envir_stacomi)
- 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 = "barplot"
- if (plot.type=="xyplot") {
-
- g<-ggplot(mb)
- g<-g+geom_point(aes(x=Date,y=sum,col=variable),stat='identity',stack=TRUE)
- assign("g",g,envir_stacomi)
- 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"
- #TODO create summary method
- if (plot.type=="summary") {
- table=round(tapply(mb$sum,list(mb$mois,mb$variable),sum),1)
- table=as.data.frame(table)
- table[,"total"]<-rowSums(table)
- gdf(table, container=TRUE)
- nomdc=bilanMigrationPar at dc@data$df_code[match(bilanMigrationPar at dc@dc_selectionne,bilanMigrationPar at dc@data$dc)]
- annee=unique(strftime(as.POSIXlt(bilanMigrationPar at time.sequence),"%Y"))
- path1=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste(nmvarqan,"_mensuel_",nomdc,"_",bilanMigrationPar at taxons@data$tax_nom_commun,"_",bilanMigrationPar at stades@data$std_libelle,"_",annee,".csv",sep=""),fsep ="\\")
- write.table(table,file=path1,row.names=FALSE,col.names=TRUE,sep=";")
- funout(gettextf("Writing of %s",path1))
- path1=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste(nmvarqan,"_journalier_",nomdc,"_",bilanMigrationPar at taxons@data$tax_nom_commun,"_",bilanMigrationPar at stades@data$std_libelle,"_",annee,".csv",sep=""),fsep ="\\")
- write.table(bilanMigrationPar at data,file=path1,row.names=FALSE,col.names=TRUE,sep=";")
- funout(gettextf("Writing of %s",path1))
- } # end plot.type summary
- })
-
-
-
-
-
Modified: pkg/stacomir/R/BilanOperation.r
===================================================================
--- pkg/stacomir/R/BilanOperation.r 2017-04-05 09:56:38 UTC (rev 339)
+++ pkg/stacomir/R/BilanOperation.r 2017-04-06 06:54:27 UTC (rev 340)
@@ -21,6 +21,7 @@
#' \code{\linkS4class{BilanMigrationPar}}
#' @concept Bilan Object
#' @keywords classes
+#' @aliases BilanOperation bilanoperation bilanOperation
#' @export
setClass(Class="BilanOperation",
representation= representation(data="data.frame",
Modified: pkg/stacomir/inst/examples/bilanAgedemer_example.R
===================================================================
--- pkg/stacomir/inst/examples/bilanAgedemer_example.R 2017-04-05 09:56:38 UTC (rev 339)
+++ pkg/stacomir/inst/examples/bilanAgedemer_example.R 2017-04-06 06:54:27 UTC (rev 340)
@@ -1,10 +1,7 @@
require(stacomiR)
-# launching stacomi without selecting the scheme or interface
stacomi(gr_interface=FALSE,
login_window=FALSE,
database_expected=FALSE)
-# the following script will load data from the two Anguillere monitored in the Somme
-
\dontrun{
#create an instance of the class
bilan_adm<-new("BilanAgedemer")
@@ -25,6 +22,7 @@
}
# load the dataset generated by previous lines
+# Salmons from the loire on two dams
data("bilan_adm")
# the calculation will fill the slot calcdata
bilan_adm<-calcule(bilan_adm)
@@ -34,7 +32,7 @@
# plot data to confirm the split by limits is correct
plot(bilan_adm, plot.type=1)
-# plot data to confirm the split by limits is correct
+# if there are several dc, data it split by dc
plot(bilan_adm, plot.type=2)
# print a summary statistic, and save the output in a list for later use
Added: pkg/stacomir/inst/examples/bilanMigrationCar-example.R
===================================================================
--- pkg/stacomir/inst/examples/bilanMigrationCar-example.R (rev 0)
+++ pkg/stacomir/inst/examples/bilanMigrationCar-example.R 2017-04-06 06:54:27 UTC (rev 340)
@@ -0,0 +1,75 @@
+require(stacomiR)
+
+stacomi(gr_interface=FALSE,
+ login_window=FALSE,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/stacomir -r 340
More information about the Stacomir-commits
mailing list