[Stacomir-commits] r310 - in pkg/stacomir: R inst/tests/testthat
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 16 17:26:23 CET 2017
Author: briand
Date: 2017-03-16 17:26:23 +0100 (Thu, 16 Mar 2017)
New Revision: 310
Modified:
pkg/stacomir/R/BilanAnnuels.r
pkg/stacomir/R/BilanMigrationMult.r
pkg/stacomir/R/stacomi.r
pkg/stacomir/inst/tests/testthat/test-02BilanMigration.R
pkg/stacomir/inst/tests/testthat/test-09Bilan_MigrationAnnuelle.R
Log:
splitting beginning and endof the year
Modified: pkg/stacomir/R/BilanAnnuels.r
===================================================================
--- pkg/stacomir/R/BilanAnnuels.r 2017-03-16 12:33:22 UTC (rev 309)
+++ pkg/stacomir/R/BilanAnnuels.r 2017-03-16 16:26:23 UTC (rev 310)
@@ -100,100 +100,75 @@
reqdiff=new("RequeteODBC")
reqdiff at baseODBC<-get("baseODBC", envir=envir_stacomi)
- #Pour Marion
- sch<-get("sch",envir=envir_stacomi) # "iav."
- assign("sch","iav.",envir_stacomi)
+ #For Marion
+ #sch<-get("sch",envir=envir_stacomi) # "iav."
+ #assign("sch","iav.",envir_stacomi)
- reqdiff at sql= paste("select ope_dic_identifiant, extract(year from ope_date_debut) as annee_debut, extract(year from ope_date_fin) as annee_fin
+ reqdiff at sql= paste("select *, extract(year from ope_date_debut) as annee_debut, extract(year from ope_date_fin) as annee_fin
FROM ",get("sch",envir=envir_stacomi),"t_operation_ope join ", get("sch",envir=envir_stacomi),"t_lot_lot on lot_ope_identifiant=ope_identifiant
- where ope_dic_identifiant in('5','6','12')
- and extract(year from ope_date_debut)>=1996
- and extract(year from ope_date_fin)<=2015
- and ope_dic_identifiant in ('5','6','12')
- and lot_tax_code in ('2038')
- and lot_std_code in ('AGG','AGJ')
- and lot_lot_identifiant is null
+ where ope_dic_identifiant in ",dc,
+ " and extract(year from ope_date_debut)>=",anneedebut,
+ " and extract(year from ope_date_fin)<=", anneefin,
+ " and ope_dic_identifiant in ", dc,
+ " and lot_tax_code in ",tax,
+ " and lot_std_code in ",std,
+ " and lot_lot_identifiant is null
order by ope_dic_identifiant, annee_debut,annee_fin; ",sep="")
reqdiff at sql<-stringr::str_replace_all(reqdiff at sql,"[\r\n\t]" , "")
reqdiff<-stacomirtools::connect(reqdiff)
- diff<-new("BilanAnnuels")
- diff at data=reqdiff at query
-
- # If there are some operations whith year of date_debut different to the year of date_fin we need to find these operations
- # and apply on it the overlaps function to separate fish that arrive during the first year from the all
+ detailed_data<-reqdiff at query
+ # If there are some operations with year of date_debut different to the year of date_fin we need to find these operations
+ # and apply on it the overlaps function to separate fish that arrive during the first year from the rest
#If we don't have operation on two years we apply the simple sum per year
- if (diff at data$ope_dic_identifiant==diff at data$ope_dic_identifiant & diff at data$annee_debut!=diff at data$annee_fin){
- reqdiffan=new("RequeteODBC")
- reqdiffan at baseODBC<-get("baseODBC", envir=envir_stacomi)
- #Pour Marion
- sch<-get("sch",envir=envir_stacomi) # "iav."
- assign("sch","iav.",envir_stacomi)
+ annee_differentes<-detailed_data$annee_debut!=detailed_data$annee_fin
+ if (any(annee_differentes)){
+ data_to_cut<-detailed_data[annee_differentes,]
+ data_not_to_cut<-detailed_data[!annee_differentes,]
+ # vector of years of cut
+ round_years<-lubridate::floor_date(data_to_cut$ope_date_debut,"years")+lubridate::years(1)
+ end_of_the_year=difftime(round_years,data_to_cut$ope_date_debut,units="days")
+ beginning_of_the_year=difftime(data_to_cut$ope_date_fin,round_years,units="day")
+ operation_duration=difftime(data_to_cut$ope_date_fin,data_to_cut$ope_date_debut,units="day")
+ data_beginning_of_the_year<-data_to_cut
+ data_beginning_of_the_year$lot_effectif<-data_beginning_of_the_year$lot_effectif*
+ as.numeric(beginning_of_the_year)/as.numeric(operation_duration)
+ data_beginning_of_the_year$ope_date_debut<-round_years
+ data_beginning_of_the_year$annee_debut<-lubridate::year(round_years)
+ data_end_of_the_year<-data_to_cut
+ data_end_of_the_year$lot_effectif<-data_end_of_the_year$lot_effectif*
+ as.numeric(end_of_the_year)/as.numeric(operation_duration)
+ data_end_of_the_year$ope_date_fin<-round_years
+ final_data<-rbind(data_not_to_cut,data_beginning_of_the_year,data_end_of_the_year)
+ sqldf(" select sum(lot_effectif) as effectif, annee_debut as annee,
+ ope_dic_identifiant,
+ lot_tax_code,
+ lot_std_code
+ from
+ final_data
+ group by annee, ope_dic_identifiant, lot_tax_code, lot_std_code
+ order by ope_dic_identifiant, annee, lot_tax_code, lot_std_code; ")
+
+ }
+ #If we have dc and years with no difference in the years of start and end for the same operation we calculate the "classical" sum by year
+ else {
- # we select operation with different years between the beginning and the end of the operation
- reqdiffan at sql= paste("select *, extract(year from ope_date_debut) as annee
- FROM ",get("sch",envir=envir_stacomi),"t_operation_ope join ",get("sch",envir=envir_stacomi),"t_lot_lot on lot_ope_identifiant=ope_identifiant
- where ope_dic_identifiant in('5','6','12')
- and extract(year from ope_date_debut)>=1996
- and extract(year from ope_date_fin)<=2015
- and ope_dic_identifiant in ('5','6','12')
- and lot_tax_code in ('2038')
- and lot_std_code in ('AGG','AGJ')
- and lot_lot_identifiant is null
- and extract(year from ope_date_debut)<>extract(year from ope_date_fin)
- order by ope_dic_identifiant,annee; ",sep="")
- reqdiffan at sql<-stringr::str_replace_all(reqdiffan at sql,"[\r\n\t]" , "")
- reqdiffan<-stacomirtools::connect(reqdiffan)
- diffan<-new("BilanAnnuels")
- diffan at data=reqdiffan at query
-
- # we apply the overlaps function
-
- # we select all the other operations (without difference of years)
- reqssdiffan=new("RequeteODBC")
- reqssdiffan at baseODBC<-get("baseODBC", envir=envir_stacomi)
- #Pour Marion
- sch<-get("sch",envir=envir_stacomi) # "iav."
- assign("sch","iav.",envir_stacomi)
-
- reqssdiffan at sql= paste("select *, extract(year from ope_date_debut) as annee
- FROM ",get("sch",envir=envir_stacomi),"t_operation_ope join ",get("sch",envir=envir_stacomi),"t_lot_lot on lot_ope_identifiant=ope_identifiant
- where ope_dic_identifiant in('5','6','12')
- and extract(year from ope_date_debut)>=1996
- and extract(year from ope_date_fin)<=2015
- and ope_dic_identifiant in ('5','6','12')
- and lot_tax_code in ('2038')
- and lot_std_code in ('AGG','AGJ')
- and lot_lot_identifiant is null
- and extract(year from ope_date_debut)=extract(year from ope_date_fin)
- order by ope_dic_identifiant,annee; ",sep="")
- reqssdiffan at sql<-stringr::str_replace_all(reqssdiffan at sql,"[\r\n\t]" , "")
- reqssdiffan<-stacomirtools::connect(reqssdiffan)
- ssdiffan<-new("BilanAnnuels")
- ssdiffan at data=reqssdiffan at query
-
- # we merge the two dataset together
- data<-merge(ssdiffan at data,diffan at data,all.x=TRUE,all.y=TRUE,by=c("ope_dic_identifiant","annee","lot_ope_identifiant"))
- }
- #If we have dc and years with no difference in the years of start and end for the same operation we calculate the "classical" sum by year
- else {
-
-
- req at sql = paste(" select sum(lot_effectif) as effectif, annee, ope_dic_identifiant,lot_tax_code, lot_std_code from
- (select *, extract(year from ope_date_debut) as annee FROM ",get("sch",envir=envir_stacomi),"t_operation_ope ",
- " join ",get("sch",envir=envir_stacomi),"t_lot_lot on lot_ope_identifiant=ope_identifiant where ope_dic_identifiant in",dc,
- " and extract(year from ope_date_debut)>=", anneedebut,
- " and extract(year from ope_date_fin)<=", anneefin,
- " and ope_dic_identifiant in ", dc,
- " and lot_tax_code in ", tax,
- " and lot_std_code in ",std,
- " and lot_lot_identifiant is null) as tmp",
- " group by annee, ope_dic_identifiant, lot_tax_code, lot_std_code ",
- " order by ope_dic_identifiant, annee, lot_tax_code, lot_std_code; ",sep="" )
- req at sql<-stringr::str_replace_all(req at sql,"[\r\n\t]" , "")
- req<-stacomirtools::connect(req)
- bilA at data=req at query
- return(bilA)
- }
+
+ req at sql = paste(" select sum(lot_effectif) as effectif, annee, ope_dic_identifiant,lot_tax_code, lot_std_code from
+ (select *, extract(year from ope_date_debut) as annee FROM ",get("sch",envir=envir_stacomi),"t_operation_ope ",
+ " join ",get("sch",envir=envir_stacomi),"t_lot_lot on lot_ope_identifiant=ope_identifiant where ope_dic_identifiant in",dc,
+ " and extract(year from ope_date_debut)>=", anneedebut,
+ " and extract(year from ope_date_fin)<=", anneefin,
+ " and ope_dic_identifiant in ", dc,
+ " and lot_tax_code in ", tax,
+ " and lot_std_code in ",std,
+ " and lot_lot_identifiant is null) as tmp",
+ " group by annee, ope_dic_identifiant, lot_tax_code, lot_std_code ",
+ " order by ope_dic_identifiant, annee, lot_tax_code, lot_std_code; ",sep="" )
+ req at sql<-stringr::str_replace_all(req at sql,"[\r\n\t]" , "")
+ req<-stacomirtools::connect(req)
+ bilA at data=req at query
+ return(bilA)
+ }
})
#' command line interface for \link{BilanAnnuels-class}
@@ -314,7 +289,7 @@
les_valeurs_final<-stringr::str_c(" & ",stringr::str_c(les_valeurs_final,collapse=" & ")," & Total\\\\\n")
} else {
les_valeurs_final<-stringr::str_c(" & ",stringr::str_c(les_valeurs_final,collapse=" & ")," & \\\\\n")
- }
+ }
return(les_valeurs_final)
}
les_dc<-unlist(lapply(stringr::str_split(coln,"_"),function(X)X[1]))
Modified: pkg/stacomir/R/BilanMigrationMult.r
===================================================================
--- pkg/stacomir/R/BilanMigrationMult.r 2017-03-16 12:33:22 UTC (rev 309)
+++ pkg/stacomir/R/BilanMigrationMult.r 2017-03-16 16:26:23 UTC (rev 310)
@@ -93,7 +93,7 @@
}
if (exists("pasDeTemps",envir_stacomi)){
bilanMigrationMult at pasDeTemps<-get("pasDeTemps",envir_stacomi)
- } else {
+ } else {
# todo addmsg
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")
@@ -107,7 +107,7 @@
assign("bilanFonctionnementDF_date_fin",as.POSIXlt(DateFin(get("pasDeTemps",envir_stacomi))),envir_stacomi)
assign("bilanOperation_date_debut",get("pasDeTemps",envir_stacomi)@"dateDebut",envir_stacomi)
assign("bilanOperation_date_fin",as.POSIXlt(DateFin(get("pasDeTemps",envir_stacomi))),envir_stacomi)
-
+
bilanOperation<-get("bilanOperation",envir=envir_stacomi)
bilanOperation<-charge(bilanOperation)
# charge will search for refDC (possible multiple choice), bilanOperation_date_debut
@@ -188,7 +188,7 @@
if (!silent) funout(gettext("Starting migration summary ... be patient\n",domain="R-stacomiR"))
bilanMigrationMult<-object
-
+
debut=bilanMigrationMult at pasDeTemps@dateDebut
fin=DateFin(bilanMigrationMult at pasDeTemps)
time.sequence<-seq.POSIXt(from=debut,to=fin,
@@ -340,8 +340,8 @@
assign("bilanFonctionnementDF",bilanFonctionnementDF,envir=envir_stacomi)
assign("bilanFonctionnementDC",bilanFonctionnementDC,envir=envir_stacomi)
assign("bilanOperation",bilanOperation,envir=envir_stacomi)
-
-
+
+
return(bilanMigrationMult)
})
@@ -812,22 +812,75 @@
time.sequence[vec[length(vec)]],
units="days")
)
- listei2[[i]]<-as.numeric(tps)/(as.numeric(sum(tps))) # on ramene e 1
+ listei2[[i]]<-as.numeric(tps)/(as.numeric(sum(tps))) # on ramene a 1
stopifnot(all.equal(as.numeric(sum(listei2[[i]])),1))
}
}
- # 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
+
+ # specific case of operations across two years
+ # In this case we want to split the operation and retain only the part corresponding to
+ # the current year
+ #######################
+ #beginning of the year
+ ########################
+ # initializing variable
+ overlapping_samples_between_year<-FALSE
+ imat3<-imat1[1,]
+ listei3<-intervals::interval_overlap(imat2,imat3)
+ # vector of samples (lot) wich are overlapping between two years
+ lots_across<-names(listei3)[vapply(listei3,function(X)length(X)>0,NA)]
+ if (length(lots_across)>0){
+ overlapping_samples_between_year<-TRUE
+ for (i in 1:length(lots_across)){
+ the_lot<-lots_across[i]
+ duration_in_the_year<-as.numeric(difftime(
+ datasub[datasub$lot_identifiant==the_lot,"ope_date_fin"],
+ time.sequence[1],
+ units="days"))
+ duration_of_the_sample<-as.numeric(difftime(datasub[datasub$lot_identifiant==the_lot,"ope_date_fin"],
+ datasub[datasub$lot_identifiant==the_lot,"ope_date_debut"],
+ units="days"))
+ listei2[[the_lot]]<-listei2[[the_lot]]* (duration_in_the_year/duration_of_the_sample)
+
+ }
+ }
+ #######################
+ #end of the year
+ #######################
+ imat3<-imat1[dim(imat1)[1],]
+ listei3<-intervals::interval_overlap(imat2,imat3)
+# vector of samples (lot) wich are overlapping between two years
+# vector of samples (lot) wich are overlapping between two years
+ lots_across<-names(listei3)[vapply(listei3,function(X)length(X)>0,NA)]
+ if (length(lots_across)>0){
+ overlapping_samples_between_year<-TRUE
+ for (i in 1:length(lots_across)){
+ the_lot<-lots_across[i]
+ duration_in_the_year<-as.numeric(difftime(
+ time.sequence[length(time.sequence)]+lubridate::days(1),
+ datasub[datasub$lot_identifiant==the_lot,"ope_date_debut"],
+ units="days"))
+ duration_of_the_sample<-as.numeric(difftime(datasub[datasub$lot_identifiant==the_lot,"ope_date_fin"],
+ datasub[datasub$lot_identifiant==the_lot,"ope_date_debut"],
+ units="days"))
+ listei2[[the_lot]]<-listei2[[the_lot]]* (duration_in_the_year/duration_of_the_sample)
+
+ }
+ }
+
+
+# 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
df<-data.frame(lot_identifiant = rep(names(listei2), sapply(listei2, length)),
coef = unlist(listei2),ts_id=unlist(listei) )
- # dataframe corresponding to the whole time sequence
+# dataframe corresponding to the whole time sequence
df.ts=data.frame(debut_pas=time.sequence,
fin_pas=time.sequence+as.difftime(1,units="days"),
ts_id=as.numeric(strftime(time.sequence,format="%j")),stringsAsFactors =FALSE)
dfts<-merge(df.ts,df,by="ts_id")
datasub1<-merge(dfts,datasub,by="lot_identifiant")
- # ci dessous pour faire du group by c'est quand meme bien de passer par sqldf
+# ci dessous pour faire du group by c'est quand meme bien de passer par sqldf
datasub1$value<-as.numeric(datasub1$value) # sinon arrondis e des entiers
if (negative){
datasub2<-sqldf::sqldf("SELECT debut_pas,
@@ -869,6 +922,10 @@
GROUP BY ope_dic_identifiant,lot_tax_code, lot_std_code, lot_methode_obtention, debut_pas,fin_pas,type_de_quantite
ORDER BY ope_dic_identifiant,debut_pas, lot_tax_code, lot_std_code,type_de_quantite ")
}
+ # if some samples overlap between the current year and the year arround the current year,
+ # 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)))
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
@@ -879,7 +936,7 @@
datasub3$CALCULE[is.na(datasub3$CALCULE)]<-0
datasub3$EXPERT[is.na(datasub3$EXPERT)]<-0
datasub3$PONCTUEL[is.na(datasub3$PONCTUEL)]<-0
- # pour compatibilite
+# pour compatibilite
datasub3<-cbind(data.frame("No.pas"=as.numeric(strftime(datasub3$debut_pas,format="%j"))-1),datasub3)
datasub3$Effectif_total=rowSums(datasub3[,c("MESURE","CALCULE","EXPERT","PONCTUEL")])
return(datasub3)
Modified: pkg/stacomir/R/stacomi.r
===================================================================
--- pkg/stacomir/R/stacomi.r 2017-03-16 12:33:22 UTC (rev 309)
+++ pkg/stacomir/R/stacomi.r 2017-03-16 16:26:23 UTC (rev 310)
@@ -311,6 +311,7 @@
#' @importFrom lubridate floor_date
#' @importFrom lubridate %m+%
#' @importFrom lubridate isoweek
+#' @importFrom lubridate years
#' @importFrom Hmisc wtd.quantile
#' @importFrom Hmisc capitalize
#' @importFrom mgcv gam
Modified: pkg/stacomir/inst/tests/testthat/test-02BilanMigration.R
===================================================================
--- pkg/stacomir/inst/tests/testthat/test-02BilanMigration.R 2017-03-16 12:33:22 UTC (rev 309)
+++ pkg/stacomir/inst/tests/testthat/test-02BilanMigration.R 2017-03-16 16:26:23 UTC (rev 310)
@@ -23,6 +23,37 @@
rm("envir_stacomi",envir =.GlobalEnv)
})
+
+test_that("Test an instance of BilanMigration, check that operations accross two years are split correcly",{
+ require(stacomiR)
+ stacomi(gr_interface=FALSE,login_window=FALSE,database_expected=FALSE)
+ # overriding user schema to point to iav
+ baseODBC<-get("baseODBC",envir=envir_stacomi)
+ baseODBC[c(2,3)]<-rep("iav",2)
+ assign("baseODBC",baseODBC,envir_stacomi)
+ sch<-get("sch",envir=envir_stacomi) # "iav."
+ assign("sch","iav.",envir_stacomi)
+
+ bilanMigration<-new("BilanMigration")
+ options(warn = -1)
+ bilanMigration<-choice_c(bilanMigration,
+ dc=c(6),
+ taxons=c("Anguilla anguilla"),
+ stades=c("AGJ"),
+ datedebut="1997-01-01",
+ datefin="1997-12-31")
+ options(warn = 0)
+ bilanMigration<-charge(bilanMigration,silent=TRUE)
+ bilanMigration<-connect(bilanMigration,silent=TRUE)
+ bilanMigration<-calcule(bilanMigration,silent=TRUE)
+ # before doing the split per year the sum was 8617
+ # now it is less, only one third of the 7 eel belong to 1997
+ # the rest are in 1998
+ expect_equal(round(sum(bilanMigration at calcdata[["dc_6"]][["data"]]$Effectif_total)),
+ 8614)
+ rm("envir_stacomi",envir =.GlobalEnv)
+ })
+
test_that("Test connect method",{
stacomi(gr_interface=FALSE,
login_window=FALSE,
Modified: pkg/stacomir/inst/tests/testthat/test-09Bilan_MigrationAnnuelle.R
===================================================================
--- pkg/stacomir/inst/tests/testthat/test-09Bilan_MigrationAnnuelle.R 2017-03-16 12:33:22 UTC (rev 309)
+++ pkg/stacomir/inst/tests/testthat/test-09Bilan_MigrationAnnuelle.R 2017-03-16 16:26:23 UTC (rev 310)
@@ -1,4 +1,4 @@
-context("Bilan_MigrationAnnuelle")
+context("BilanAnnuels")
test_that("Test an instance of BilanAnnuels loaded with choice_c",{
More information about the Stacomir-commits
mailing list