[Stacomir-commits] r336 - in pkg/stacomir: R inst/config inst/examples
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 4 17:52:31 CEST 2017
Author: briand
Date: 2017-04-04 17:52:31 +0200 (Tue, 04 Apr 2017)
New Revision: 336
Modified:
pkg/stacomir/R/BilanAgedemer.r
pkg/stacomir/R/BilanMigrationMult.r
pkg/stacomir/R/BilanMigrationMultConditionEnv.r
pkg/stacomir/R/ReftextBox.r
pkg/stacomir/R/interface_BilanAgedemer.r
pkg/stacomir/R/interface_BilanMigrationMult.r
pkg/stacomir/R/interface_BilanMigrationMultConditionEnv.r
pkg/stacomir/R/stacomi.r
pkg/stacomir/inst/config/stacomi_manual_launch.r
pkg/stacomir/inst/examples/bilanAgedemer_example.R
pkg/stacomir/inst/examples/bilanMigrationMultConditionEnv_example.R
Log:
development agede mer and bilanMigrationMultconditionEnv
Modified: pkg/stacomir/R/BilanAgedemer.r
===================================================================
--- pkg/stacomir/R/BilanAgedemer.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/BilanAgedemer.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -138,7 +138,17 @@
object at horodatefin@horodate<-get("bilan_adm_date_fin",envir_stacomi)
} else {
funout(gettext("You need to choose the ending date\n",domain="R-stacomiR"),arret=TRUE)
- }
+ }
+ if (exists("limit1hm",envir_stacomi)) {
+ object at limit1hm<-get("limit1hm",envir_stacomi)
+ } else {
+ funout(gettext("you need to choose a value for limit1hm",domain="R-stacomiR"),arret=TRUE)
+ }
+ if (exists("limit2hm",envir_stacomi)) {
+ object at limit2hm<-get("limit2hm",envir_stacomi)
+ } else {
+ funout(gettext("you need to choose a value for limit2hm",domain="R-stacomiR"),arret=TRUE)
+ }
return(object)
validObject(object)
@@ -199,8 +209,8 @@
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))
- bilan_adm at limit2hm<-choice_c(bilan_adm at limit2hm,as.character(limit2hm))
+ 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)
})
@@ -254,7 +264,7 @@
#browser()
bilan_adm<-x
plot.type<-as.character(plot.type)# to pass also characters
- if (!plot.type%in%c("1","2","3","4")) stop('plot.type must be 1,2,3 or 4')
+ if (!plot.type%in%c("1","2")) stop('plot.type must be 1,2')
if (nrow(bilan_adm at calcdata[["data"]])==0) {
if (!silent) funout(gettext("You need to launch computation first, clic on calc\n",domain="R-stacomiR"),arret=TRUE)
}
Modified: pkg/stacomir/R/BilanMigrationMult.r
===================================================================
--- pkg/stacomir/R/BilanMigrationMult.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/BilanMigrationMult.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -548,33 +548,7 @@
}
#==========================type=3=============================
if (plot.type=="multiple"){
- lestaxons= paste(bilanMigrationMult at taxons@data$tax_nom_latin,collapse=",")
- lesstades= paste(bilanMigrationMult at stades@data$std_code,collapse=",")
- grdata<-data.frame()
- for (i in 1:length(bilanMigrationMult at calcdata)){
- data<-bilanMigrationMult at calcdata[[i]]$data
- # extracting similar columns (not those calculated)
- data<-data[,c(
- "No.pas","debut_pas","fin_pas","ope_dic_identifiant","lot_tax_code","lot_std_code",
- "MESURE","CALCULE","EXPERT","PONCTUEL","Effectif_total"
- )]
- grdata<-rbind(grdata,data)
- }
- names(grdata)<-tolower(names(grdata))
- grdata<-funtraitementdate(grdata,
- nom_coldt="debut_pas",
- annee=FALSE,
- mois=TRUE,
- quinzaine=TRUE,
- semaine=TRUE,
- jour_an=TRUE,
- jour_mois=FALSE,
- heure=FALSE)
- annee=unique(strftime(as.POSIXlt(bilanMigrationMult at time.sequence),"%Y"))
- dis_commentaire= paste(as.character(bilanMigrationMult at dc@dc_selectionne),collapse=",")
- grdata<-stacomirtools::chnames(grdata,c("ope_dic_identifiant","lot_tax_code","lot_std_code"),c("DC","taxon","stade"))
- grdata$DC<-as.factor(grdata$DC)
- grdata$taxon<-as.factor(grdata$taxon)
+ grdata<-fun_aggreg_for_plot(bilanMigrationMult)
if (length(unique(grdata$taxon))==1&length(unique(grdata$stade))==1){
p<-ggplot(grdata,aes(x=debut_pas,y=effectif_total),fill="black")+
geom_bar(position="stack", stat="identity")+
@@ -602,7 +576,7 @@
assign("grdata",grdata,envir_stacomi)
funout(gettext("The data for the plot have been assigned to envir_stacomi,write grdata<-get('grdata',envir_stacomi) to retreive the object"))
- }
+ }
#==========================end / type=3=============================
})
@@ -881,8 +855,8 @@
}
}
-
-
+
+
# df ["lot_identifiant","coef","ts.id"]
# lot_identifiant= identifiant du lot, coef = part du lot dans chaque id_seq (sequence de jours), "id_seq" numero du jour
# creating a table with lot_identifiant, sequence, and the coeff to apply
@@ -940,7 +914,7 @@
# then the calculation will have hampered our numbers of a small amount
# and the following test is not expected to be TRUE.
if (!overlapping_samples_between_year)
- stopifnot(all.equal(sum(datasub$value,na.rm=TRUE),sum(datasub2$value,na.rm=TRUE)))
+ stopifnot(all.equal(sum(datasub$value,na.rm=TRUE),sum(datasub2$value,na.rm=TRUE)))
datasub3<-reshape2::dcast(datasub2, debut_pas+fin_pas+ope_dic_identifiant+lot_tax_code+lot_std_code+type_de_quantite~lot_methode_obtention,value.var="value")
if (!"MESURE"%in%colnames(datasub3)) datasub3$MESURE=0
if (!"CALCULE"%in%colnames(datasub3)) datasub3$CALCULE=0
@@ -1082,3 +1056,43 @@
stopifnot(nr==nrow(tableau))
return(tableau)
}
+
+#' returns a table where all components within the list calcdata are aggregated
+#' and formatted for plot
+#' @param object An object of class \ref{BilanMigrationMult-class}
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+fun_aggreg_for_plot<-function(object){
+ if (class(object)!="BilanMigrationMult") stop("This function must have for argument an object of class BilanMigrationMult")
+ lestaxons= paste(object at taxons@data$tax_nom_latin,collapse=",")
+ lesstades= paste(object at stades@data$std_code,collapse=",")
+ grdata<-data.frame()
+ for (i in 1:length(object at calcdata)){
+ data<-object at calcdata[[i]]$data
+ # extracting similar columns (not those calculated)
+ data<-data[,c(
+ "No.pas","debut_pas","fin_pas","ope_dic_identifiant","lot_tax_code","lot_std_code",
+ "MESURE","CALCULE","EXPERT","PONCTUEL","Effectif_total"
+ )]
+ grdata<-rbind(grdata,data)
+ }
+ names(grdata)<-tolower(names(grdata))
+ grdata<-funtraitementdate(grdata,
+ nom_coldt="debut_pas",
+ annee=FALSE,
+ mois=TRUE,
+ quinzaine=TRUE,
+ semaine=TRUE,
+ jour_an=TRUE,
+ jour_mois=FALSE,
+ heure=FALSE)
+ annee=unique(strftime(as.POSIXlt(object at time.sequence),"%Y"))
+ dis_commentaire= paste(as.character(object at dc@dc_selectionne),collapse=",")
+ grdata<-stacomirtools::chnames(grdata,c("ope_dic_identifiant","lot_tax_code","lot_std_code"),c("DC","taxon","stade"))
+ grdata$DC<-as.factor(grdata$DC)
+ grdata$taxon<-as.factor(grdata$taxon)
+ return(grdata)
+}
+
+
+
Modified: pkg/stacomir/R/BilanMigrationMultConditionEnv.r
===================================================================
--- pkg/stacomir/R/BilanMigrationMultConditionEnv.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/BilanMigrationMultConditionEnv.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -50,6 +50,7 @@
#' @export
setMethod("connect",signature=signature("BilanMigrationMultConditionEnv"),definition=function(object,silent=FALSE) {
#object<-bmmCE
+ bmmCE<-object
bmmCE at bilanMigrationMult<-connect(bmmCE at bilanMigrationMult,silent=silent)
bmmCE at bilanConditionEnv<-connect(bmmCE at bilanConditionEnv,silent=silent)
return(bmmCE)
@@ -95,12 +96,27 @@
# silent=FALSE
bmmCE<-object
bmmCE at bilanMigrationMult<-charge(bmmCE at bilanMigrationMult,silent=silent)
+ # the values for date are not initiated by the interface
+ assign("bilanConditionEnv_date_debut",get("pasDeTemps",envir_stacomi)@"dateDebut",envir_stacomi)
+ assign("bilanConditionEnv_date_fin",as.POSIXlt(DateFin(get("pasDeTemps",envir_stacomi))),envir_stacomi)
bmmCE at bilanConditionEnv<-charge(bmmCE at bilanConditionEnv,silent=silent)
return(bmmCE)
})
+#' Internal handler function
+#' @param h a handler
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+hbmmCEcalc=function(h=null,...){
+ bmmCE<-get("bmmCE",envir_stacomi)
+ bmmCE<-charge(bmmCE)
+ bmmCE<-connect(bmmCE)
+ bmmCE<-calcule(bmmCE)
+ assign("bmmCE",bmmCE,envir_stacomi)
+ enabled(toolbarlist[["Graph"]])<-TRUE
+ return(invisible(NULL))
+}
-
#' Calculation for the BilanMigrationMultConditionEnv
#'
#' @param object An object of class \code{\link{BilanMigrationMultConditionEnv-class}}
@@ -118,31 +134,38 @@
#' internal method for graphical interface
#' @param h A handler
-hbilanMigrationMultConditionEnvgraph = function(h){
+hbmmCEgraph = function(h=null,...){
bmmCE<-get("bmmCE",envir_stacomi)
- bmmCE<-charge(bmmCE)
- bmmCE<-connect(bmmCE)
- bmmCE<-calcule(bmmCE)
bmmCE<-plot(bmmCE)
+ return(invisible(NULL))
}
#' Plot method for BilanMigrationMultConditionEnv
-#' @param x An object of class Bilan_carlot
+#' @param x An object of class \link{BilanMigrationMultConditionEnv}
#' @param silent Stops displaying the messages.
-#' @param ... Additional arguments, see \code{plot}, \code{plot.default} and \code{par}
+#' @param color_station A named vector of station color (e.g. c("temp_gabion"="red","coef_maree"="blue","phases_lune"="green")) default null
+#' @param color_dc A named vector giving the color for each dc default null (e.g. c("5"="#4D4D4D","6"="#E6E6E6","12"="#AEAEAE"))
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @aliases plot.BilanMigrationMultConditionEnv plot.bmmCE
#' @export
-setMethod("plot", signature(x = "BilanMigrationMultConditionEnv", y = "missing"), definition=function(x, silent=FALSE){
- bmmCE<-object
- plot(bmmCE at bilanMigrationMult,plot.type="multiple")
- # on va chercher les données du graphique
+setMethod("plot", signature(x = "BilanMigrationMultConditionEnv", y = "missing"), definition=function(x, color_station=NULL,color_dc=NULL, silent=FALSE){
+ #color_station=NULL;color_dc=NULL
+ # color_station<-c("temp_gabion"="red","coef_maree"="blue","phases_lune"="green")
+ # color_dc=c("5"="#4D4D4D","6"="#E6E6E6","12"="#AEAEAE")
+ bmmCE<-x
- time.sequence<-as.Date(as.POSIXlt(bmmCE at bilanMigrationMult@time.sequence))
- tableau<-get("grdata",envir_stacomi)
- tableau<-cbind("time.sequence"=time.sequence,tableau)
- tableau$time.sequencechar<-as.character(tableau$time.sequence)
+ grdata<-fun_aggreg_for_plot(bmmCE at bilanMigrationMult)
+ # we collect the dataset used to build the graph
+
+ taxons= as.character(bmmCE at bilanMigrationMult@taxons at data$tax_nom_latin)
+ stades= as.character(bmmCE at bilanMigrationMult@stades at data$std_libelle)
+ dc<-unique(grdata$DC)
+ # pour avoir dans le graphique le dc_code des dc
+ # ggplot passe les dc dans l'ordre dans lequel ils apparaissent dans le tableau
+ # et unique fait ça aussi .... OUIIIII
+ dc_code<-bmmCE at bilanMigrationMult@dc at data$dc_code[
+ match(dc,bmmCE at bilanMigrationMult@dc at data$dc)]
# tableau conditions environnementales
tableauCE<-bmmCE at bilanConditionEnv@data
if (nrow(tableauCE)==0) {
@@ -150,114 +173,138 @@
}
stations<-bmmCE at bilanConditionEnv@stationMesure at data
+ #######################
+ # color scheme for station
+ #######################
+ if (is.null(color_station)) {
+ color_station=rep(RColorBrewer::brewer.pal(8,"Accent"),2)[1:nrow(stations)]
+ names(color_station)<-stations$stm_libelle
+ } else if (length(color_station)!=nrow(stations)){
+ funout(gettextf("The color_station argument should have length %s",nrow(stations)),arret=TRUE)
+ }
+ if (!all(names(color_station)%in%stations$stm_libelle)) {
+ stop (gettextf("The following name(s) %s do not match station name: %s",
+ names(color_station)[!names(color_station)%in%stations$stm_libelle],
+ paste(stations$stm_libelle, collapse=", ")))
+ }
+ cs<-cbind(stm_libelle=names(color_station),"color"=color_station)
+ #######################
+ # color scheme for dc
+ #######################
+ if (is.null(color_dc)) {
+ color_dc=grDevices::gray.colors(length(dc))
+ names(color_dc)<-dc
+ } else if (length(color_dc)!=length(dc)){
+ funout(gettextf("The color_dc argument should have length %s",length(dc)),arret=TRUE)
+ }
+ if (!all(names(color_dc)%in%dc))
+ stop (gettextf("The following name(s) %s do not match DC codes: %s",
+ names(color_dc)[!names(color_dc)%in%dc],
+ paste(dc, collapse=", ")))
+ cdc<-cbind("DC"=names(color_dc),"color"=color_dc)
+
+ # we collect libelle from station
for (i in 1:length(unique(tableauCE$env_stm_identifiant))){
tableauCE[unique(tableauCE$env_stm_identifiant)[i]==tableauCE$env_stm_identifiant,"stm_libelle"]<-
stations[stations$stm_identifiant==unique(tableauCE$env_stm_identifiant)[i],"stm_libelle"]
}
- tableauCE$env_date_debutchar=as.character(as.Date(tableauCE$env_date_debut))
+ # the data can be in the POSIXct format, we need to round them
+ tableauCE$date<-as.POSIXct(round.POSIXt(tableauCE$env_date_debut,units="days"))
+ qualitative<-!is.na(tableauCE$env_val_identifiant)
+ tableauCEquan<-tableauCE[!qualitative,]
+ tableauCEqual<-tableauCE[qualitative,]
+ if (nrow(unique(cbind(tableauCE$date,tableauCE$stm_libelle)))!= nrow(tableauCE)) {
+ funout(gettextf("Attention, on one station :%s there are several entries for the same day :%s we will calculate average for numeric
+ and use the first value for qualitative parameter",
+ sta,
+ paste(unique(tableauCEst$env_date_debut[duplicated(tableauCEst$env_date_debut)]),sep="")),
+ arret=FALSE)
+ # for quantitative parameters we group by date and station and use the average to
+ # extract one value per day
+ tableauCEquan<-dplyr::select(tableauCEquan,date,stm_libelle,env_valeur_quantitatif)%>%
+ dplyr::group_by(date,stm_libelle)%>%
+ dplyr::summarize(valeur=mean(env_valeur_quantitatif))%>%
+ dplyr::ungroup()
+ # for qualitative value, when there are several values for the same date
+ # we arbitrarily select the first
+ tableauCEqual<-dplyr::select(tableauCEqual,date,stm_libelle,env_val_identifiant)%>%
+ dplyr::group_by(date,stm_libelle)%>%
+ dplyr::summarize(valeur=first(env_val_identifiant))%>%
+ dplyr::ungroup()
+ } else {
+ # we want the same format as above
+ tableauCEquan<-dplyr::select(tableauCEquan,date,stm_libelle,env_valeur_quantitatif)%>%
+ dplyr::rename(valeur=env_valeur_quantitatif)
+ tableauCEqual<-dplyr::select(tableauCEqual,date,stm_libelle,env_val_identifiant)%>%
+ dplyr::rename(valeur=env_val_identifiant)
+ }
+ variables_quant<-unique(tableauCEquan$stm_libelle)
+ variables_qual<-unique(tableauCEqual$stm_libelle)
+ grdata<-funtraitementdate(grdata,
+ nom_coldt="debut_pas",
+ annee=FALSE,
+ mois=TRUE,
+ quinzaine=TRUE,
+ semaine=TRUE,
+ jour_an=TRUE,
+ jour_mois=FALSE,
+ heure=FALSE)
- for (sta in as.character(stations$stm_libelle)){
- tableauCEst<-tableauCE[tableauCE$stm_libelle==sta,] #tableau CE d'une station
- if (length(unique(tableauCEst$env_date_debutchar))!=length(tableauCEst$env_date_debutchar)) {
- funout(gettextf("Attention, on one station :%s there are several entries for the same day :%s only the first value will be incuded in the summary\n",
- sta,
- paste(unique(tableauCEst$env_date_debutchar[duplicated(tableauCEst$env_date_debutchar)]),sep="")),
- arret=FALSE)
- tableauCEst<-tableauCEst[induk(tableauCEst$env_date_debutchar),]
- }
-
- if (is.na(tableauCEst$env_val_identifiant[1])){
- #variable quantitative
- tableauCEst<-tableauCEst[,c("env_date_debutchar","env_valeur_quantitatif")]
- tableauCEst<-stacomirtools::chnames(tableauCEst,"env_valeur_quantitatif",sta)
- stations[stations$stm_libelle==sta,"stm_typevar"]<-"quantitatif"
- # je renomme la colonne e rentrer par le nom de la station
- } else {
- # variable qualitative
- tableauCEst<-tableauCEst[,c("env_date_debutchar","env_val_identifiant")]
- tableauCEst$"env_val_identifiant"=as.factor(tableauCEst$"env_val_identifiant")
- tableauCEst<-stacomirtools::chnames(tableauCEst,"env_val_identifiant",sta)
-
- stations[stations$stm_libelle==sta,"stm_typevar"]<-"qualitatif"
- } # end else
- # le merge ci dessous est l'equivalent d'une jointure gauche (LEFT JOIN)
- tableau<-merge(tableau,tableauCEst,by.x = "time.sequencechar", by.y = "env_date_debutchar", all.x = TRUE)
- # les donnees sont normalement collees dans le tableau dans une nouvelle colonne et aux dates correspondantes
- if (length(time.sequence)!=nrow(tableau)) funout(gettextf("The number of lines of the environmental conditions table (%s) doesn't fit the duration of the migration summary (%s)\n",
- nrow(tableau),
- length(time.sequence)),
- arret=TRUE)
- #si la jointure e rajoute des lignes ea craint je ne sais pas comment se fera le traitement
- } # end for
- taxon= as.character(bmmCE at bilanMigration@taxons at data$tax_nom_latin)
- stade= as.character(bmmCE at bilanMigration@stades at data$std_libelle)
-
- bilanMigrationConditionEnv at bilanMigration@dc<-get("refDC",envir_stacomi)
- annee=strftime(as.POSIXlt(mean(time.sequence)),"%Y")
- dis_commentaire= as.character(bilanMigrationConditionEnv at bilanMigration@dc at data$dis_commentaires[bilanMigrationConditionEnv at bilanMigration@dc at data$dc%in%bilanMigrationConditionEnv at bilanMigration@dc at dc_selectionne]) # commentaires sur le DC
- tableau<-funtraitementdate(tableau,
- nom_coldt="time.sequence",
- annee=FALSE,
- mois=TRUE,
- quinzaine=TRUE,
- semaine=TRUE,
- jour_an=TRUE,
- jour_mois=FALSE,
- heure=FALSE)
- couleurs=rep(RColorBrewer::brewer.pal(8,"Accent"),2)
- maxeff=floor(log10(max(tableau$Effectif_total,na.rm=TRUE)))
- lab_les_stations=stations$stm_libelle
- for (i in 1:nrow(stations)){
- tableau[,paste("couleur",i,sep="")]<-couleurs[i]
- if (stations$stm_typevar[i]=="quantitatif") {
- diff=maxeff-round(log10(max(tableau[,stations$stm_libelle[i]],na.rm=TRUE)))
-
- if (diff!=0 & !is.na(diff)){
- tableau[,stations$stm_libelle[i]] = as.numeric(tableau[,stations$stm_libelle[i]])*10^diff
- lab_les_stations[i]=paste(stations$stm_libelle[i],".10^",diff,sep="")
- } # end if
- } #end if
- } # end for
- tableau$yqualitatif=(10^(maxeff))/2
- name=gettextf("Number %s",paste(lab_les_stations,collapse=", "))
- g<-ggplot(tableau, aes(x=time.sequence,y=Effectif_total))+geom_bar(stat="identity",fill="grey50")+scale_x_date(name="Date")+
- scale_y_continuous(name=name)+labs(title=gettextf("Number %s, %s, %s, %s",dis_commentaire,taxon,stade,annee))
- for (i in 1:nrow(stations)){
- if (stations$stm_typevar[i]=="quantitatif") {
- if (all(!is.na(tableau[,stations$stm_libelle[i]]))){
- g<-g+geom_line(aes_string(x="time.sequence",y=stations$stm_libelle[i],colour=paste("couleur",i,sep="")),size=1)+
- scale_colour_identity(name="stations",breaks=couleurs[1:i],labels=stations$stm_libelle[1:i])
- } else {
- g<-g+geom_point(aes_string(x="time.sequence",y=stations$stm_libelle[i],colour=paste("couleur",i,sep="")),size=2)+
- scale_colour_identity(name="stations",breaks=couleurs[1:i],labels=stations$stm_libelle[1:i])
- }
- } else if (stations$stm_typevar[i]=="qualitatif") {
- stableau=subset(tableau, !is.na(tableau[,stations$stm_libelle[i]]))
- stableau[,stations$stm_libelle[i]]<- as.factor(as.character( stableau[,stations$stm_libelle[i]]))
- if (stations$stm_par_code[i]=="AAAA")# phases lunaires
- g<-g+geom_point(aes_string(x="time.sequence",y="yqualitatif",colour=paste("couleur",i,sep=""),shape=stations$stm_libelle[i]),data=stableau,size=3)+
- scale_colour_identity(name="stations",breaks=couleurs[1:i],labels=stations$stm_libelle[1:i])
- } else stop("internal error")
- } # end for
- assign("g",g,envir_stacomi)
- funout(gettext("Writing of the graphical object in the environment envir_stacomi : write g=get(g,envir_stacomi)\n",domain="R-stacomiR"))
- print(g)
+ # to rescale everything on the same graph
+ maxeff=floor(log10(max(grdata$effectif_total,na.rm=TRUE)))
-
-}# end function
+ for (i in 1:length(variables_quant)){
+ diff=maxeff-round(log10(max(tableauCEquan[tableauCEquan$stm_libelle==variables_quant[i],"valeur"],na.rm=TRUE)))
+ if (diff!=0 & !is.na(diff)){
+ tableauCEquan[tableauCEquan$stm_libelle==variables_quant[i],"valeur"] = as.numeric(tableauCEquan[tableauCEquan$stm_libelle==variables_quant[i],"valeur"])*10^diff
+ variables_quant[i]=paste(variables_quant[i],".10^",diff,sep="")
+ } # end if
+ } #end for
+ yqualitatif=(10^(maxeff))/2
+
+ ylegend=gettextf("Number, %s, %s",paste(variables_quant,collapse=", "),
+ paste(variables_qual,collapse=", "))
+
+
+
+
+
+ ######################
+ # traitement des données pour grouper par dc (group_by dc)
+ # les stades et taxons seront aggrégés avec warning
+ #################################
+ if (length(unique(taxons))>1) warning(gettextf("you have %s taxa in the bilan, those will be aggregated",length(unique(taxons))))
+ if (length(unique(stades))>1) warning(gettextf("you have %s stages in the bilan, those will be aggregated",length(unique(stades))))
+ plotdata<-dplyr::select(grdata,debut_pas,DC,effectif_total)%>%dplyr::rename(date=debut_pas)%>%
+ dplyr::group_by(date,DC)%>%dplyr::summarize(effectif=sum(effectif_total))%>%
+ dplyr::ungroup()
+
+ # merging with colors
+ plotdata<-killfactor(merge(plotdata,cdc,by="DC"))
+ tableauCEquan<-killfactor(merge(tableauCEquan,cs,by="stm_libelle"))
+ tableauCEqual<-killfactor(merge(tableauCEqual,cs,by="stm_libelle"))
+
+ g<-ggplot(plotdata)+
+ geom_bar(aes(x=date,y=effectif,fill =color),position="stack", stat="identity")+
+ ylab(ylegend)+
+ geom_line(aes(x=date,y=valeur,colour=color),data=tableauCEquan,size=1)+
+ geom_point(aes(x=date,shape=valeur,
+ colour=color),
+ y=yqualitatif,data=tableauCEqual,size=3)+
+ scale_fill_identity(name=gettext("DC"),labels=dc_code,guide = "legend")+
+ scale_colour_identity(name=gettext("stations"),
+ labels=names(cs[,"color"]),
+ breaks=cs[,"color"],
+ guide = "legend")+
+ scale_shape(guide="legend",name=gettext("Qualitative parm"))+
+ theme_bw()
+ print(g)
+ assign("g",g,envir_stacomi)
+ funout(gettext("the ggplot object has been assigned to envir_stacomi, type g<-get('g',envir_stacomi)"))
+
+ })# end function
-#' handler du graphique BilanMigrationMultConditionEnv
-#' realise le calcul du bilan migration avec CE, l'ecrit dans l'environnement envir_stacomi
-#' traite eventuellement les quantites de lots (si c'est des civelles)
-#' @param h a handler
-#' @param ... Additional parameters
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @export
-hbilanMigrationMultConditionEnvcalc=function(h,...){
- calcule(h$action)
- enabled(toolbarlist[["Graph"]])<-TRUE
- # calcule(bilanMigrationMultConditionEnv)
-}
+
Modified: pkg/stacomir/R/ReftextBox.r
===================================================================
--- pkg/stacomir/R/ReftextBox.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/ReftextBox.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -30,6 +30,8 @@
#'
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @param object An object of class \link{RefTextBox-class}
+#' @param nomassign The name with which the object will be assigned in envir_stacomi
+
#' @examples
#' \dontrun{
#' object=new("RefTextBox")
@@ -39,10 +41,10 @@
#' choice(object)
#' dispose(win)
#' }
-setMethod("choice",signature=signature("RefTextBox"),definition=function(object) {
+setMethod("choice",signature=signature("RefTextBox"),definition=function(object,nomassign="refTextBox") {
hlist=function(h,...){
object at label<-svalue(choice)
- assign("refTextBox",object,envir_stacomi)
+ assign(nomassign,object,envir_stacomi)
funout(paste("choice",object at label,"\n"))
}
@@ -59,7 +61,8 @@
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @param object An object of class \link{RefTextBox-class}
#' @param value The value to set
-setMethod("choice_c",signature=signature("RefTextBox"),definition=function(object,value) {
+setMethod("choice_c",signature=signature("RefTextBox"),definition=function(object,value,nomassign="refTextBox") {
object at label<-value
+ assign(nomassign,object,envir_stacomi)
return(object)
})
Modified: pkg/stacomir/R/interface_BilanAgedemer.r
===================================================================
--- pkg/stacomir/R/interface_BilanAgedemer.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/interface_BilanAgedemer.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -32,46 +32,32 @@
nomassign="bilan_adm_date_fin",
funoutlabel=gettext("Ending date has been chosen\n",domain="R-stacomiR"),
decal=-1)
- bilan_adm at dc<-choice(bilan_adm at dc,objectBilan=bilan_adm,is.enabled=TRUE)
+ bilan_adm at dc<-choice(bilan_adm at dc,objectBilan=NULL,is.enabled=TRUE)
bilan_adm at limit1hm<-charge(bilan_adm at limit1hm,title="Limit s1 for 1sw (L(1sw)<=s1), click to edit",label="0")
bilan_adm at limit2hm<-charge(bilan_adm at limit2hm,title="Limit s2 for 2sw (s1<L(2sw)<=s2) & L(3sw)>s2, click to edit",label="0")
# the choice method for RefDC will stop there and the other slots are filled with choicec
# we only want silver eels in this bilan, and parameters length, eye diameter, pectoral length, contrast...
- choice(bilan_adm at limit1hm)
- choice(bilan_adm at limit2hm)
+ choice(bilan_adm at limit1hm,nomassign="limit1hm")
+ choice(bilan_adm at limit2hm,nomassign="limit2hm")
choice_c(bilan_adm at taxons,2220)
choice_c(bilan_adm at stades,c('5','11','BEC','BER','IND'))
choice_c(bilan_adm at par,c('1786','1785','C001','A124'))
- aplot1=gWidgets::gaction(label="plot-1",
+ aplot1=gWidgets::gaction(label="plot-1",
icon="gWidgetsRGtk2-cloud",
handler=funplotBilanAgedemer,
action="1",
tooltip="1")
-
aplot2=gWidgets::gaction(label="plot-2",
icon="gWidgetsRGtk2-cloud",
handler=funplotBilanAgedemer,
action="2",
tooltip="2")
- aplot3=gWidgets::gaction(label="plot-3",
- icon="gWidgetsRGtk2-cloud",
- handler=funplotBilanAgedemer,
- action="3",
- tooltip="3")
- aplot4=gWidgets::gaction(label="plot-4",
- icon="gWidgetsRGtk2-cloud",
- handler=funplotBilanAgedemer,
- action="4",
- tooltip="4")
asummary=gWidgets::gaction(label="Summary",icon="dataframe",handler=funtableBilanAgedemer,tooltip="Summary")
- aquit=gWidgets::gaction(label=gettext("Exit",icon="close", handler=quitte,tooltip="Exit",domain="R-stacomiR"))
-
+ aquit=gWidgets::gaction(label=gettext("Exit",domain="R-stacomiR"),icon="close", handler=quitte,tooltip="Exit")
toolbarlist <- list(
plot1= aplot1,
- plot2= aplot2,
- plot3= aplot3,
- plot4= aplot4,
+ plot2= aplot2,
summary= asummary,
quit = aquit)
ggroupboutonsbas = gWidgets::ggroup(horizontal=FALSE)
Modified: pkg/stacomir/R/interface_BilanMigrationMult.r
===================================================================
--- pkg/stacomir/R/interface_BilanMigrationMult.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/interface_BilanMigrationMult.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -28,7 +28,6 @@
bilanMigrationMult at dc=charge(bilanMigrationMult at dc)
group = ggroup(horizontal=TRUE) # doit toujours s'appeller group
assign("group",group,envir = .GlobalEnv)
- # the notebook will contain all elements from
notebook <- gnotebook(container=group)
assign("notebook",notebook,envir=.GlobalEnv)
size(notebook)<-c(400,300)
Modified: pkg/stacomir/R/interface_BilanMigrationMultConditionEnv.r
===================================================================
--- pkg/stacomir/R/interface_BilanMigrationMultConditionEnv.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/interface_BilanMigrationMultConditionEnv.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -7,22 +7,46 @@
assign("bmmCE",bmmCE,envir=envir_stacomi)
funout(gettext("Loading of the lists for taxons, stages, counting devices and monitoring stations\n",domain="R-stacomiR"))
bmmCE at bilanConditionEnv@stationMesure=charge(bmmCE at bilanConditionEnv@stationMesure)
+ #(destroys everything in envir_stacomi except stuff required at to level)
+ objectBilan="bilanMigrationMult"
+ # the following name is created by the interface
+ # as I can't get the name from within the function (deparse(substitute(objectBilan)) does not return
+ # "bilanMigrationMult" see refDC choice_c method)
+ # so this will allow to assign "bilanMigrationMult" in envir_stacomi while using other class
+ # like refDC
+ assign("objectBilan",objectBilan,envir=envir_stacomi)
+ bmmCE at bilanMigrationMult=new("BilanMigrationMult")
+ assign("bilanMigrationMult",bmmCE at bilanMigrationMult,envir = envir_stacomi)
+ bilanFonctionnementDC=new("BilanFonctionnementDC")
+ assign("bilanFonctionnementDC",bilanFonctionnementDC,envir = envir_stacomi)
+ bilanFonctionnementDF=new("BilanFonctionnementDF")
+ assign("bilanFonctionnementDF",bilanFonctionnementDF,envir = envir_stacomi)
+ bilanOperation=new("BilanOperation")
+ assign("bilanOperation",bilanOperation, envir=envir_stacomi)
+ bilanMigration=new("BilanMigration")
+ assign("bilanMigration",bilanMigration,envir = envir_stacomi)
+
+
bmmCE at bilanMigrationMult@taxons=charge(bmmCE at bilanMigrationMult@taxons)
bmmCE at bilanMigrationMult@stades=charge(bmmCE at bilanMigrationMult@stades)
bmmCE at bilanMigrationMult@dc=charge(bmmCE at bilanMigrationMult@dc)
-
- group <- gWidgets::ggroup(horizontal=FALSE) # doit toujours s'appeller group
- assign("group",group,envir=.GlobalEnv)
+ group = ggroup(horizontal=TRUE) # doit toujours s'appeller group
+ assign("group",group,envir = .GlobalEnv)
+ choice(bmmCE at bilanConditionEnv@stationMesure)
+ notebook <- gnotebook(container=group)
+ assign("notebook",notebook,envir=.GlobalEnv)
+ size(notebook)<-c(400,300)
add(ggroupboutons,group)
- choice(bmmCE at bilanMigrationMult@pasDeTemps)
- choice(bmmCE at bilanConditionEnv@stationMesure)
- choice(bmmCE at bilanMigrationMult@dc,objectBilan=bmmCE at bilanMigrationMult,is.enabled=TRUE)
-
+ choicemult(bmmCE at bilanMigrationMult@pasDeTemps)
+ choicemult(bmmCE at bilanMigrationMult@dc,objectBilan=bmmCE at bilanMigrationMult,is.enabled=TRUE)
+ svalue(notebook)<-1
ggroupboutonsbas = gWidgets::ggroup(horizontal=FALSE)
+ assign("ggroupboutonsbas",ggroupboutonsbas,envir=.GlobalEnv)
gWidgets::add(ggroupboutons,ggroupboutonsbas)
+
toolbarlist = list(
- Calc=gWidgets::gaction(handler = hbmmCEcalc,action=bmmCE,
+ Calc=gWidgets::gaction(handler = hbmmCEcalc,
icon = "new",
label="calcul",
tooltip=gettext("Calculation of environnemental conditions by time step",domain="R-stacomiR")),
@@ -30,18 +54,13 @@
icon = "graph",
label="graph",
tooltip=gettext("Balance graphic",domain="R-stacomiR")),
- #Graph2=gWidgets::gaction(handler = hbmmCEgraph2,icon = "graph2",label="grcum",tooltip="graphe cumul"),
- #Stat =gWidgets::gaction(handler= hbmmCEstat,icon = "matrix",label="stat",tooltip="tables bilan en .csv"),
annuler=gWidgets::gaction(handler= quitte,
icon = "close",
label="quitter"))
assign("toolbarlist",toolbarlist,envir=.GlobalEnv)
enabled(toolbarlist[["Graph"]])<-FALSE
gWidgets::add(ggroupboutonsbas, gtoolbar(toolbarlist))
-assign("ggroupboutonsbas",ggroupboutonsbas,envir=.GlobalEnv)
+ assign("ggroupboutonsbas",ggroupboutonsbas,envir=.GlobalEnv)
gWidgets::addSpring(group)
- #graphes=ggraphics(width=600,height=400)
- #add(ggrouptotal1,graphes ) # on ajoute au groupe horizontal
- #assign("graphes",graphes,envir=envir_stacomi)
- dev.new()
+ return(invisible(NULL))
}
\ No newline at end of file
Modified: pkg/stacomir/R/stacomi.r
===================================================================
--- pkg/stacomir/R/stacomi.r 2017-04-04 07:14:26 UTC (rev 335)
+++ pkg/stacomir/R/stacomi.r 2017-04-04 15:52:31 UTC (rev 336)
@@ -52,9 +52,9 @@
#' handler function used by the main interface
#' @param h handler
#' @param ... additional parameters
-hBilanMigrationConditionEnv=function(h,...){
+hBilanMigrationMultConditionEnv=function(h,...){
funout(gettext("Summary of migration environnemental conditions\n",domain="R-stacomiR"),wash=TRUE)
- eval(interface_BilanMigrationConditionEnv(),envir = .GlobalEnv)
+ eval(interface_BilanMigrationMultConditionEnv(),envir = .GlobalEnv)
}
#' handler function used by the main interface
#' @param h handler
@@ -299,6 +299,7 @@
#' @importFrom stats xtabs
#' @importFrom stats AIC
#' @importFrom grDevices dev.new
+#' @importFrom grDevices gray.colors
#' @importFrom stats sd
#' @importFrom reshape2 dcast
#' @importFrom reshape2 melt
@@ -448,7 +449,7 @@
menubarlist[[gettext("Summary",domain="R-stacomiR")]][[gettext("Environnemental conditions",domain="R-stacomiR")]]$handler=hBilanConditionEnv
menubarlist[[gettext("Summary",domain="R-stacomiR")]][[gettext("Environnemental conditions",domain="R-stacomiR")]]$icon="gWidgetsRGtk2-curve"
- menubarlist[[gettext("Summary",domain="R-stacomiR")]][[gettext("Migration. ~Environnemental conditions",domain="R-stacomiR")]]$handler=hBilanMigrationConditionEnv
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/stacomir -r 336
More information about the Stacomir-commits
mailing list