[Stacomir-commits] r347 - pkg/stacomir/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Apr 7 11:22:02 CEST 2017
Author: briand
Date: 2017-04-07 11:22:02 +0200 (Fri, 07 Apr 2017)
New Revision: 347
Added:
pkg/stacomir/R/interface_BilanMigrationCar.r
Removed:
pkg/stacomir/R/BilanMigrationCar.r.tex
pkg/stacomir/R/interface_BilanMigrationPar.r
Modified:
pkg/stacomir/R/BilanMigrationCar.r
pkg/stacomir/R/BilanMigrationMult.r
pkg/stacomir/R/BilanMigrationMultConditionEnv.r
pkg/stacomir/R/utilitaires.r
Log:
Modified: pkg/stacomir/R/BilanMigrationCar.r
===================================================================
--- pkg/stacomir/R/BilanMigrationCar.r 2017-04-07 07:37:04 UTC (rev 346)
+++ pkg/stacomir/R/BilanMigrationCar.r 2017-04-07 09:22:02 UTC (rev 347)
@@ -294,11 +294,11 @@
# resetting the right values for valqual
bmC at parqual@valqual<-rbind(bmC at parqual@valqual,
data.frame(val_identifiant=levels(tab$car_val_identifiant),
- val_qual_code=par,
- val_rang=1:length(levels(tab$car_val_identifiant)),
- val_libelle=NA))
-
+ val_qual_code=par,
+ val_rang=1:length(levels(tab$car_val_identifiant)),
+ val_libelle=NA))
+
if (!silent) funout(gettextf("%s lines have been converted from quantitative to qualitative parameters",nrow(tab)))
return(bmC)
})
@@ -372,34 +372,14 @@
setMethod("plot",signature=signature(x="BilanMigrationCar",y="missing"),definition=function(x,color_parm=NULL,plot.type="barplot",...){
bmC<-object
# transformation du tableau de donnees
- # color_parm<-c("age0"="red","age1"="blue","age2"="green")
-
+ # color_parm<-c("age 1"="red","age 2"="blue","age 3"="green")
+ # color_parm<-c("C001"="red")
if (plot.type=="qual") {
- #######################
- # setting colors
- ######################
- parlevels<-bmC at parqual@valqual$val_identifiant
- if (is.null(color_par)) {
- color_par=RColorBrewer::brewer.pal(length(parlevels),"Dark2")
- names(color_par)<-parlevels
- } else if (length(color_par)!=length(parlevels)){
- funout(gettextf("The color_par argument should have length %s",length(parlevels)),arret=TRUE)
- }
- if (!all(names(color_par)%in%parlevels)) {
- stop (gettextf("The following name(s) %s do not match station name: %s",
- names(color_par)[!names(color_par)%in%parlevels],
- paste(parlevels, collapse=", ")))
- }
- # creating a data frame to pass to merge later (to get the color in the data frame)
- cs<-data.frame(car_val_identifiant=names(color_par),color=color_par)
- # problem with different order (set by color name) implying different order
- # in the graph (ie by color not by car_val_identifiant
- levels(cs$color)<-cs$color
- bonordre<-match(levels(cs$color),cs$color)
- cs$color = factor(cs$color,levels(cs$color)[bonordre])
+ parlevels<-bmC at parqual@valqual$val_identifiant
+ cs<-colortable(color=color_parm,vec=parlevels,palette="Dark2")
+ cs<-stacomirtools::chnames(cs,"name","car_val_identifiant")
calcdata<-bmC at calcdata
calcdata<-merge(calcdata,cs)
- calcdata<-calcdata[order(calcdata$mois,calcdata$car_val_identifiant),]
g<-ggplot(calcdata)+
geom_bar(aes(x=mois,y=lot_effectif,fill=color),stat = "identity")+
xlab(gettext("Month"))+
@@ -414,16 +394,41 @@
funout(gettext("Writing the graphical object into envir_stacomi environment : write g=get(\"g\",envir_stacomi) \n",domain="R-stacomiR"))
print(g)
} #end plot.type = "qual"
- if (plot.type=="quant") {
- g<-ggplot(bmC at calcdata)
- g<-g+geom_point(aes(x=ope_date_debut,y=car_valeur_quantitatif,col=car_par_code_quan),stat='identity')
+ if (plot.type=="quant") {
+ calcdata<-bmC at calcdata
+ the_parms<-unique(calcdata$car_par_code_quan)
+ cs<-colortable(color=color_parm,vec=the_parms,palette="Dark2")
+ cs<-stacomirtools::chnames(cs,"name","car_par_code_quan")
+ calcdata<-merge(calcdata,cs)
+ g<-ggplot(calcdata)+
+ geom_point(aes(x=ope_date_debut,y=car_valeur_quantitatif,col=color),stat='identity')+
+ xlab(gettext("Month"))+
+ ylab(gettext("Number"))+
+ scale_colour_identity(name=gettext("Param"),
+ labels=cs[,"car_par_code_quan"],
+ breaks=cs[,"color"],
+ guide = "legend")+
+ theme_bw()
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="quant"
- if (plot.type=="crossed") {
- g<-ggplot(bmC at calcdata)
- g<-g+geom_point(aes(x=ope_date_debut,y=car_valeur_quantitatif,col=car_val_identifiant),stat='identity')
+ if (plot.type=="crossed") {
+ parlevels<-bmC at parqual@valqual$val_identifiant
+ cs<-colortable(color=color_parm,vec=parlevels,palette="Dark2")
+ cs<-stacomirtools::chnames(cs,"name","car_val_identifiant")
+ calcdata<-bmC at calcdata
+ calcdata<-merge(calcdata,cs)
+
+ g<-ggplot(calcdata)+
+ geom_point(aes(x=ope_date_debut,y=car_valeur_quantitatif,col=color),stat='identity')+
+ xlab(gettext("Month"))+
+ ylab(gettext("Number"))+
+ scale_colour_identity(name=gettext("Param"),
+ labels=cs[,"car_val_identifiant"],
+ breaks=cs[,"color"],
+ guide = "legend")+
+ theme_bw()
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)
Deleted: pkg/stacomir/R/BilanMigrationCar.r.tex
===================================================================
--- pkg/stacomir/R/BilanMigrationCar.r.tex 2017-04-07 07:37:04 UTC (rev 346)
+++ pkg/stacomir/R/BilanMigrationCar.r.tex 2017-04-07 09:22:02 UTC (rev 347)
@@ -1,418 +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, 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 main difference between this class and \link{Bilan_carlot} is that this class allows to
-#' select (or not) the samples, and that it handles quantitative and qualitative parameters separately.
-#' @section Objects from the Class: Objects can be created by calls of the form
-#' \code{new("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(
- echantillon="RefChoix",
- calcdata="list",
- parqual="Refparqual",
- parquan="Refparquan"),
- prototype=list(
- echantillon=new("RefChoix"),
- calcdata<-list(),
- parqual=new("Refparqual"),
- parquan=new("Refparquan")),
- contains="Bilan_carlot")
-
-
-setValidity("BilanMigrationCar",function(object)
- {
- 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(rep5,TRUE,retValue))
- } )
-
-
-#' command line interface for BilanMigrationCar class
-#' @param object An object of class \link{BilanMigrationCar-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 TODO
-#' @param car Sample TODO
-#' @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 echantillon Default TRUE,
-#' @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("BilanMigrationCar"),definition=function(object,
- dc,
- taxons,
- stades,
- parquan,
- parqual,
- horodatedebut,
- horodatefin,
- echantillon=TRUE,
- 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');parquan=c('1786','1785','C001','A124');parqual='COHO';silent=FALSE
- bmC<-object
- bmC at dc=charge(bmC at dc)
- bmC at dc<-choice_c(object=bmC at dc,dc)
- bmC at taxons<-charge_avec_filtre(object=bmC at taxons,bmC at dc@dc_selectionne)
- bmC at taxons<-choice_c(bmC at taxons,taxons)
- bmC at stades<-charge_avec_filtre(object=bmC at stades,bmC at dc@dc_selectionne,bmC at taxons@data$tax_code)
- bmC at stades<-choice_c(bmC at stades,stades,silent=silent)
- bmC at parquan<-charge_avec_filtre(object=bmC at parquan,dc_selectionne=bmC at dc@dc_selectionne,
- taxon_selectionne=bmC at taxons@data$tax_code,
- stade_selectionne=bmC at stades@data$std_code)
- bmC at parquan<-choice_c(bmC at parquan,parquan,silent=silent)
- # the method choice_c is written in refpar, and each time
- assign("refparquan",bmC at parquan,envir_stacomi)
- bmC at parqual<-charge_avec_filtre(object=bmC at parqual,bmC at dc@dc_selectionne,bmC at taxons@data$tax_code,bmC at stades@data$std_code)
- bmC at parqual<-choice_c(bmC at parqual,parqual,silent=silent)
- bmC at parqual<-charge_complement(bmC at parqual)
- # the method choice_c is written in refpar, and each time
- assign("refparqual",bmC at parqual,envir_stacomi)
- bmC at horodatedebut<-choice_c(object=bmC at horodatedebut,
- nomassign="bmC_date_debut",
- funoutlabel=gettext("Beginning date has been chosen\n",domain="R-stacomiR"),
- horodate=horodatedebut,
- silent=silent)
- bmC at horodatefin<-choice_c(bmC at horodatefin,
- nomassign="bmC_date_fin",
- funoutlabel=gettext("Ending date has been chosen\n",domain="R-stacomiR"),
- horodate=horodatefin,
- silent=silent)
- bmC at echantillon<-charge(bmC at echantillon,vecteur=c(TRUE,FALSE),label="essai",selected=as.integer(1))
- bmC at echantillon<-choice_c(bmC at echantillon,selectedvalue=echantillon)
- validObject(bmC)
- return(bmC)
- })
-
-
-
-
-setMethod("connect",signature=signature("BilanMigrationCar"),definition=function(object,silent=FALSE){
- if (!bmC at echantillon@selectedvalue) {
- echantillons=" AND lot_pere IS NULL"
- } else {
- echantillons=""
- }
- if (nrow(bmC at parquan@data$par_nom)==0 & nrow(bmC at parqual@data)==0) {
- stop("You need to choose at least one quantitative or qualitative attribute")
- } else if (nrow(bmC at parquan@data)==0) {
- #caracteristique qualitative uniquement
- req at sql=paste("SELECT ope_date_debut, ope_date_fin, lot_methode_obtention, SUM(lot_effectif) AS effectif,",
- " car_val_identifiant_tous as car_val_identifiant",
- " FROM (SELECT *,",
- " CASE when car_val_identifiant is not null then car_val_identifiant",
- " ELSE lot_pere_val_identifiant",
- " END as car_val_identifiant_tous",
- " FROM ",get("sch",envir=envir_stacomi),"vue_ope_lot_ech_parqual",
- " WHERE ope_dic_identifiant in ",vector_to_listsql(bmC at dc@dc_selectionne),
- echantillons,
- " AND lot_tax_code in ",vector_to_listsql(bmC at taxons@data$tax_code),
- " AND lot_std_code in ",vector_to_listsql(bmC at stades@data$std_code),
- " AND car_par_code in ",vector_to_listsql(bmC at parqual@data$par_code),
- " AND (ope_date_debut, ope_date_fin) OVERLAPS (TIMESTAMP '" , debutPas , "', TIMESTAMP '" , finPas , "')" ,
- " ) AS qan",
- " GROUP BY qan.ope_date_debut, qan.ope_date_fin, qan.lot_methode_obtention, qan.car_val_identifiant_tous " ,
- " ORDER BY qan.ope_date_debut",sep="")
- } else if (nrow(bmC at parqual==0)) {
- # Caracteristique quantitative uniquement
- req at sql=paste("SELECT ope_date_debut, ope_date_fin, lot_methode_obtention, SUM(lot_effectif) AS effectif, SUM(car_valeur_quantitatif) AS quantite",
- " FROM ",get("sch",envir=envir_stacomi),"vue_ope_lot_ech_parquan",
- " WHERE ope_dic_identifiant in ",vector_to_listsql(bmC at dc@dc_selectionne),
- echantillons,
- " AND lot_tax_code in ",vector_to_listsql(bmC at taxons@data$tax_code),
- " AND lot_std_code in ",vector_to_listsql(bmC at stades@data$std_code),
- " AND car_par_code in ",vector_to_listsql(bmC at parqual@data$par_code),
- " AND (ope_date_debut, ope_date_fin) OVERLAPS (TIMESTAMP '" , debutPas , "', TIMESTAMP '" , finPas , "')" ,
- " GROUP BY ope_date_debut, ope_date_fin, lot_methode_obtention" ,
- " ORDER BY ope_date_debut",sep="")
- } else {
- #les deux caracteristiques sont choisies, il faut faire un Bilancroise
- # attention je choisis un left join ea veut dire certaines caracteristiques quant n'ont pas de contrepartie quantitative
- req at sql=paste(
- " SELECT ope_date_debut,",
- " ope_date_fin,",
- " SUM(lot_effectif) AS effectif,",
- " SUM(car_valeur_quantitatif) AS quantite,",
- " car_val_identifiant_tous as car_val_identifiant",
- " FROM (",
- " SELECT *,",
- " CASE when car_val_identifiant is not null then car_val_identifiant",
- " ELSE lot_pere_val_identifiant",
- " END as car_val_identifiant_tous",
- " FROM (",
- " SELECT * FROM ",get("sch",envir=envir_stacomi),"vue_ope_lot_ech_parquan",
- " WHERE ope_dic_identifiant in ",vector_to_listsql(bmC at dc@dc_selectionne),
- echantillons,
- " AND lot_tax_code in ",vector_to_listsql(bmC at taxons@data$tax_code),
- " AND lot_std_code in ",vector_to_listsql(bmC at stades@data$std_code),
- " AND car_par_code in ",vector_to_listsql(bmC at parqual@data$par_code),
- " AND (ope_date_debut, ope_date_fin) OVERLAPS (TIMESTAMP '",debutPas,"',TIMESTAMP '",finPas,"') " ,
- " ) AS qan",
- " LEFT JOIN",
- " (SELECT lot_identifiant as lot_identifiant1,car_val_identifiant ",
- " FROM vue_ope_lot_ech_parqual ",
- " WHERE ope_dic_identifiant in ",vector_to_listsql(bmC at dc@dc_selectionne),
- echantillons,
- " AND lot_tax_code in ",vector_to_listsql(bmC at taxons@data$tax_code),
- " AND lot_std_code in ",vector_to_listsql(bmC at stades@data$std_code),
- " AND car_par_code in ",vector_to_listsql(bmC at parqual@data$par_code),
- " AND (ope_date_debut, ope_date_fin) OVERLAPS (TIMESTAMP '",debutPas,"',TIMESTAMP '",finPas,"') " ,
- " )as qal ",
- " ON qan.lot_identifiant=qal.lot_identifiant1",
- " )as qanqal",
- " GROUP BY qanqal.ope_date_debut, qanqal.ope_date_fin, qanqal.car_val_identifiant_tous",
- " ORDER BY qanqal.ope_date_debut",sep="")
- }
-
- })
-
-#' 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("BilanMigrationCar"),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("bmC_date_debut",envir_stacomi)) {
- bmC at horodatedebut@horodate<-get("bmC_date_debut",envir_stacomi)
- } else {
- funout(gettext("You need to choose the starting date\n",domain="R-stacomiR"),arret=TRUE)
- }
- if (exists("bmC_date_fin",envir_stacomi)) {
- bmC at horodatefin@horodate<-get("bmC_date_fin",envir_stacomi)
- } else {
- funout(gettext("You need to choose the ending date\n",domain="R-stacomiR"),arret=TRUE)
- }
-
- if (exists("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)|exists("refparqual",envir_stacomi))){
- funout(gettext("You need to choose at least one parameter qualitative or quantitative\n",domain="R-stacomiR"),arret=TRUE)
- }
-
- if (exists("refparquan",envir_stacomi)){
- bmC at parquan<-get("refparquan",envir_stacomi)
- }
- if (exists("refparqual",envir_stacomi)){
- bmC at parqual<-get("refparqual",envir_stacomi)
- }
-
- 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
- ###########################
- 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")
- 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",...){
-
- # 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
-
- })
-
-
-#' summary for BilanMigrationCar
-#' @param object An object of class \code{\link{BilanMigrationCar-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="BilanMigrationCar"),definition=function(object,silent=FALSE,...){
-
- 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
- })
Modified: pkg/stacomir/R/BilanMigrationMult.r
===================================================================
--- pkg/stacomir/R/BilanMigrationMult.r 2017-04-07 07:37:04 UTC (rev 346)
+++ pkg/stacomir/R/BilanMigrationMult.r 2017-04-07 09:22:02 UTC (rev 347)
@@ -270,6 +270,7 @@
#bilanMigrationMult<-bmM
bilanMigrationMult<-object
+
# retrieve the argument of the function and passes it to bilanMigrationMult
# easier to debug
req=new("RequeteODBCwheredate")
@@ -279,8 +280,11 @@
# we round the date to be consistent with daily values from the
req at datedebut=bilanMigrationMult at pasDeTemps@dateDebut
req at datefin=as.POSIXlt(DateFin(bilanMigrationMult at pasDeTemps)+as.difftime("23:59:59"))
+ if (length(bilanMigrationMult at dc@dc_selectionne)==0) stop("DC has length zero, are you connected to the right schema, do you use the right dc number ?")
dc = vector_to_listsql(bilanMigrationMult at dc@dc_selectionne)
+ if (length(bilanMigrationMult at taxons@data$tax_code)==0) stop("Taxa has length zero, are you connected to the right schema, do you use the right taxa ?")
tax=vector_to_listsql(bilanMigrationMult at taxons@data$tax_code)
+ if (length(bilanMigrationMult at stades@data$std_code)==0) stop("Stage has length zero, are you connected to the right schema, do you use the right stage ?")
std=vector_to_listsql(bilanMigrationMult at stades@data$std_code)
sch=get("sch",envir=envir_stacomi)
req at select = stringr::str_c("SELECT
Modified: pkg/stacomir/R/BilanMigrationMultConditionEnv.r
===================================================================
--- pkg/stacomir/R/BilanMigrationMultConditionEnv.r 2017-04-07 07:37:04 UTC (rev 346)
+++ pkg/stacomir/R/BilanMigrationMultConditionEnv.r 2017-04-07 09:22:02 UTC (rev 347)
@@ -171,39 +171,7 @@
if (nrow(tableauCE)==0) {
funout(gettext("You don't have any environmental conditions within the time period\n",domain="R-stacomiR"),arret=TRUE)
}
-
- 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"]<-
@@ -277,7 +245,20 @@
dplyr::group_by(date,DC)%>%dplyr::summarize(effectif=sum(effectif_total))%>%
dplyr::ungroup()
- # merging with colors
+ #######################
+ # color scheme for station
+ #######################
+ stations<-bmmCE at bilanConditionEnv@stationMesure at data
+ cs<-colortable(color=color_station,vec=stations$stm_libelle,palette="Accent")
+ cs<-stacomirtools::chnames(cs,"name","stm_libelle")
+ #######################
+ # color scheme for dc
+ #######################
+ cdc<-colortable(color=color_dc,vec=dc,color_function="gray.colors")
+ cdc<-stacomirtools::chnames(cdc,"name","DC")
+ #######################
+ # merging with colors for manual scales
+ ######################
plotdata<-killfactor(merge(plotdata,cdc,by="DC"))
tableauCEquan<-killfactor(merge(tableauCEquan,cs,by="stm_libelle"))
tableauCEqual<-killfactor(merge(tableauCEqual,cs,by="stm_libelle"))
Copied: pkg/stacomir/R/interface_BilanMigrationCar.r (from rev 342, pkg/stacomir/R/interface_BilanMigrationPar.r)
===================================================================
--- pkg/stacomir/R/interface_BilanMigrationCar.r (rev 0)
+++ pkg/stacomir/R/interface_BilanMigrationCar.r 2017-04-07 09:22:02 UTC (rev 347)
@@ -0,0 +1,67 @@
+#' interface for BilanMigrationPar class
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+interface_BilanMigrationPar = function()
+{
+ quitte()
+
+ bilanMigrationPar=new("BilanMigrationPar")
+ assign("bilanMigrationPar",bilanMigrationPar,envir=envir_stacomi)
+
+ bilanFonctionnementDC=new("BilanFonctionnementDC") # appel ici pour pouvoir utiliser les fonctions graphiques associees sur fonctionnement du DC
+ assign("bilanFonctionnementDC",bilanFonctionnementDC,envir=envir_stacomi)
+
+ funout(gettext("Loading of the lists for taxons, stages, counting devices, qualitative and quantitative parameters\n",domain="R-stacomiR"))
+ bilanMigrationPar at taxons=charge(bilanMigrationPar at taxons)
+ bilanMigrationPar at stades=charge(bilanMigrationPar at stades)
+ bilanMigrationPar at dc=charge(bilanMigrationPar at dc)
+ bilanMigrationPar at parquan=charge(bilanMigrationPar at parquan)
+ bilanMigrationPar at parqual=charge(bilanMigrationPar at parqual)
+ #TODO transformer la valeur logique de échantillon en un refchoix correct (radiobutton)
+ bilanMigrationPar at echantillon=charge(bilanMigrationPar at echantillon,vecteur=gettext("with","without",domain="R-stacomiR"),
+ label=gettext("Choice of batch type, inclusion of samples ?",domain="R-stacomiR"),
+ selected=as.integer(1))
+ #######################
+ # Interface Graphique
+ ##########################
+ group <- gWidgets::ggroup(horizontal=FALSE) # doit toujours s'appeller group
+
+ assign("group",group,envir = .GlobalEnv)
+
+ gWidgets::add(ggroupboutons,group)
+ choice(bilanMigrationPar at pasDeTemps)
+ choice(bilanMigrationPar at echantillon)
+ choice(bilanMigrationPar at dc,objectBilan=bilanMigrationPar,is.enabled=TRUE)
+
+
+ ggroupboutonsbas = gWidgets::ggroup(horizontal=FALSE)
+ gWidgets::add(ggroupboutons,ggroupboutonsbas)
+ assign("ggroupboutonsbas",ggroupboutonsbas, envir=.GlobalEnv)
+ toolbarlist = list(
+ Calc=gWidgets::gaction(handler = hbilanMigrationParcalc,
+ icon = "new",
+ label=gettext("calculation"),
+ action=bilanMigrationPar,
+ tooltip=gettext("Calculation of numbers by time step",domain="R-stacomiR")),
+ Graph=gWidgets::gaction(handler = hbilanMigrationPargraph,
+ icon = "graph",
+ label="graph",
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/stacomir -r 347
More information about the Stacomir-commits
mailing list