[Stacomir-commits] r341 - pkg/stacomir/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Apr 6 09:30:59 CEST 2017
Author: briand
Date: 2017-04-06 09:30:59 +0200 (Thu, 06 Apr 2017)
New Revision: 341
Modified:
pkg/stacomir/R/BilanMigrationCar.r
pkg/stacomir/R/funSousListeBilanMigrationPar.r
Log:
Modified: pkg/stacomir/R/BilanMigrationCar.r
===================================================================
--- pkg/stacomir/R/BilanMigrationCar.r 2017-04-06 06:54:27 UTC (rev 340)
+++ pkg/stacomir/R/BilanMigrationCar.r 2017-04-06 07:30:59 UTC (rev 341)
@@ -37,11 +37,13 @@
representation=representation(parquan="Refparquan",
parqual="Refparqual",
echantillon="RefChoix",
- valeurs_possibles="data.frame"),
+ valeurs_possibles="data.frame",
+ calcdata="list"),
prototype=prototype(parquan=new("Refparquan"),
parqual=new("Refparqual"),
echantillon=new("RefChoix"),
- valeurs_possibles=data.frame()),
+ valeurs_possibles=data.frame(),
+ calcdata<-list()),
contains="BilanMigrationMult")
#object=bmC
@@ -55,13 +57,13 @@
} )
-#' command line interface for BilanAgedemer class
-#' @param object An object of class \link{BilanAgedemer-class}
+#' 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 '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 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 silent Default FALSE, if TRUE the program should no display messages
@@ -70,49 +72,173 @@
#' 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,
+setMethod("choice_c",signature=signature("BilanMigrationCar"),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)
+ bmC<-object
+ bmC at dc=charge(bmC 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)
+ bmC at dc<-choice_c(object=bmC 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",
+ 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 par<-charge_avec_filtre(object=bmC at par,bmC at dc@dc_selectionne,bmC at taxons@data$tax_code,bmC at stades@data$std_code)
+ bmC at par<-choice_c(bmC at par,par,silent=silent)
+ 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)
- bilan_adm at horodatefin<-choice_c(bilan_adm at horodatefin,
- nomassign="bilan_adm_date_fin",
+ 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)
- 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)
+ bmC at limit1hm<-choice_c(bmC at limit1hm,as.character(limit1hm),"limit1hm")
+ bmC at limit2hm<-choice_c(bmC at limit2hm,as.character(limit2hm),"limit2hm")
+ validObject(bmC)
+ return(bmC)
})
+
+setMethod("connect",signature=signature("BilanMigrationCar"),definition=function(object,silent=FALSE){
+ if (bilanMigrationPar at parquan@data$par_nom=="aucune" & bilanMigrationPar at parqual@data$par_nom=="aucune") {
+ stop("You need to choose at least one quantitative or qualitative attribute")
+ } else if (bilanMigrationPar at parquan@data$par_nom=="aucune") {
+ #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 ='",bilanMigrationPar at dc@dc_selectionne,"'",
+ echantillons,
+ " AND lot_tax_code = '",bilanMigrationPar at taxons@data$tax_code,"'" ,
+ " AND lot_std_code = '",bilanMigrationPar at stades@data$std_code,"'" ,
+ " AND car_par_code = '",bilanMigrationPar 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 (bilanMigrationPar at parqual@data$par_nom=="aucune") {
+ # 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 ='",bilanMigrationPar at dc@dc_selectionne,"'",
+ echantillons,
+ " AND lot_tax_code = '",bilanMigrationPar at taxons@data$tax_code,"'" ,
+ " AND lot_std_code = '",bilanMigrationPar at stades@data$std_code,"'" ,
+ " AND car_par_code = '",bilanMigrationPar at parquan@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 ='",bilanMigrationPar at dc@dc_selectionne,"'",
+ echantillons,
+ " AND lot_tax_code = '",bilanMigrationPar at taxons@data$tax_code,"'" ,
+ " AND lot_std_code = '",bilanMigrationPar at stades@data$std_code,"'" ,
+ " AND car_par_code = '",bilanMigrationPar at parquan@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 ='",bilanMigrationPar at dc@dc_selectionne,"'",
+ echantillons,
+ " AND lot_tax_code = '",bilanMigrationPar at taxons@data$tax_code,"'" ,
+ " AND lot_std_code = '",bilanMigrationPar at stades@data$std_code,"'" ,
+ " AND car_par_code = '",bilanMigrationPar 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="")
+ }
+
+ })# end else
+
+ #cat(paste("Requete SQL : \n" , sql))
+ rs<-stacomirtools::connect(req)@query
+ #cat(nrow(rs))
+ if (nrow(rs)>0){
+
+ debutOpe=as.POSIXlt(rs$ope_date_debut)
+ finOpe= as.POSIXlt(rs$ope_date_fin)
+ effectif=rs$effectif
+ quantite=rs$quantite
+ if (bilanMigrationPar at parqual@data$par_nom!="aucune") {
+ rs$car_val_identifiant[is.na(rs$car_val_identifiant)]<-"autre"
+ }
+ # creation des sommes effectif_MESURE ...
+
+ # Si l'operation commence avant le pas de temps courant, et ne se termine pas apres, il faut conserver une seule partie de l'operation
+ # Si l'operation se termine apres la fin du pas mais ne debute pas avant, il faut conserver une seule partie de l'operation
+ # Si l'operation commence avant le pas de temps et se termine apres, on ne conserve qu'une partie de l'operation
+ # Cas ou l'operation est inferieure ou egale au pas de temps : pas de probleme, on compte l'operation complete
+ # ce qui revient e dire que pour ce qui concerne la time.sequence de l'operation effectif sur le pas de temps
+ # on prends le max du debut de ope et pas de temps (si l'ope commence avant on garde pas cette partie )
+ # et pour la fin on prend le min si l'ope se termine apres on garde pas... ouf
+
+ debut<-debutOpe
+ fin<-finOpe
+ debut[debut<debutPas]<-debutPas
+ fin[fin>finPas]<-finPas
+
+ # Repartition de l'effectif au prorata
+ effectif = effectif * as.double(difftime(time1=fin, time2=debut,units = "secs"))/as.double(difftime(time1=finOpe,time2=debutOpe,units = "secs"))
+ quantite= quantite * as.double(difftime(time1=fin, time2=debut,units = "secs"))/as.double(difftime(time1=finOpe,time2=debutOpe,units = "secs"))
+ if (bilanMigrationPar at parqual@data$par_nom!="aucune") { # il existe des caracteristiques qualitatives de lot
+ # i=c(valeurs_qal,"tous")[2]
+ for (i in valeurs_qal){
+ assign(eval(paste("effectif_",i,sep="")),sum(effectif[rs$car_val_identifiant==i]))
+ assign(eval(paste("quantite_",i,sep="")),sum(quantite[rs$car_val_identifiant==i]))
+ }
+ } else {# pas de caracteristiques qualitatives de lot et pas de decoupage supplementaire
+ effectif<-sum(effectif)
+ quantite<-sum(quantite)
+ }
+ } else {
+ # dans le cas ou le resultat de la requete est vide pas de ligne je met 0
+ if (bilanMigrationPar at parqual@data$par_nom!="aucune") { # il existe des caracteristiques qualitatives de lot
+ for (i in valeurs_qal){
+ assign(eval(paste("effectif_",i,sep="")),0)
+ assign(eval(paste("quantite_",i,sep="")),0)
+ }
+ } else {# pas de caracteristiques qualitatives de lot et pas de decoupage supplementaire
+ effectif<-0
+ quantite<-0
+ }
+
+ }
+
#' charge method for BilanMigrationCar
#'
#' Used by the graphical interface to collect and test objects in the environment envir_stacomi,
@@ -179,6 +305,8 @@
hbmCcalc=function(h,...){
calcule(h$action)
}
+
+
#' calcule methode
#'
#'
@@ -206,6 +334,27 @@
}
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)
@@ -258,27 +407,7 @@
#' @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") {
@@ -299,23 +428,30 @@
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
+
})
-
-
-
+#' 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/funSousListeBilanMigrationPar.r
===================================================================
--- pkg/stacomir/R/funSousListeBilanMigrationPar.r 2017-04-06 06:54:27 UTC (rev 340)
+++ pkg/stacomir/R/funSousListeBilanMigrationPar.r 2017-04-06 07:30:59 UTC (rev 341)
@@ -1,20 +1,4 @@
-# Nom fichier : funSousListeBilanMigrationPar
-# Projet : calcmig/prog/fonctions
-# Organisme : IAV/CSP
-# Auteur : Cedric Briand
-# Contact : cedric.briand"at"eptb-vilaine.fr
-# Date de creation : 23/05/2006
-# Compatibilite : R 2.8.0
-# Etat : developpement
-# Description Workhorse fonction pour le calcul des bilans migratoires adaptee au travail sur parametres qualitatifs et quantitatifs
-# Notes de devt Dans les requetes recuperer valeurs quan ou valeur qual ou l'interrogation croisee (trois cas differents)
-#
-#**********************************************************************
-
-
-
-
#' funSousListeBilanMigrationPar
#'
#' see \code{funSousListeBilanMigration} This function is similar to
More information about the Stacomir-commits
mailing list