[Stacomir-commits] r213 - in pkg/stacomir: R examples/03_BilanFonctionnementDF inst/tests/testthat
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 21 11:51:22 CEST 2016
Author: briand
Date: 2016-09-21 11:51:22 +0200 (Wed, 21 Sep 2016)
New Revision: 213
Modified:
pkg/stacomir/R/BilanFonctionnementDF.r
pkg/stacomir/R/BilanMigrationMult.r
pkg/stacomir/R/interface_BilanFonctionnementDF.r
pkg/stacomir/R/stacomi.r
pkg/stacomir/R/utilitaires.r
pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R
pkg/stacomir/inst/tests/testthat/test-00zRefclasses.R
pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R
Log:
Modified: pkg/stacomir/R/BilanFonctionnementDF.r
===================================================================
--- pkg/stacomir/R/BilanFonctionnementDF.r 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/R/BilanFonctionnementDF.r 2016-09-21 09:51:22 UTC (rev 213)
@@ -113,7 +113,8 @@
} else {
funout(get("msg",envir=envir_stacomi)$ref.6,arret=TRUE)
}
- object<-connect(object,silent)
+ object<-connect(object,silent)
+ assign("fonctionnementDF",object,envir=envir_stacomi)
return(object)
})
@@ -145,6 +146,7 @@
nomassign="fonctionnementDF_date_fin",
funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.6,
horodate=horodatefin,silent)
+ assign("fonctionnementDF",fonctionnementDF,envir=envir_stacomi)
return(fonctionnementDF)
})
@@ -177,7 +179,7 @@
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=="1"|plot.type=="2"){
- if (!silent) funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2)
+ if (!silent) funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.3)
t_periodefonctdispositif_per=fonctionnementDF at data # on recupere le data.frame
# l'objectif du programme ci dessous est de calculer la time.sequence mensuelle de fonctionnement du dispositif.
tempsdebut<-t_periodefonctdispositif_per$per_date_debut
@@ -263,6 +265,7 @@
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
} else if (plot.type=="3"){
#fonctionnementDF<-bfDF; require(RGtk2); require(lubridate);require(ggplot2);title=NULL;silent=FALSE;plot.type="3"
+ if (!silent) funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.3)
t_periodefonctdispositif_per=fonctionnementDF at data
graphdate<-function(vectordate){
vectordate<-as.POSIXct(vectordate)
@@ -380,47 +383,10 @@
#fonctionnementDF<-bfDF; require(RGtk2); require(lubridate);require(ggplot2);title=NULL;silent=FALSE;plot.type="4"
t_periodefonctdispositif_per=fonctionnementDF at data
- time.sequence=seq.POSIXt(from=fonctionnementDF at requete@datedebut,to=fonctionnementDF at requete@datefin,by="day")
- tt<-data.frame(per_date_debut=time.sequence)
- # data<-t_periodefonctdispositif_per
- horaires<-function(data){
- data$Hdeb<-as.numeric(strftime(data$per_date_debut,"%H"))+as.numeric(strftime(data$per_date_debut,"%M"))/60
- data$Hfin<-as.numeric(strftime(data$per_date_fin,"%H"))+round(as.numeric(strftime(data$per_date_fin,"%M"))/60,2)
- data$Hfin[data$Hfin==0]<-24
- indx<-data$Hfin==24&data$Hdeb==0
- data[indx,"Hfin"]<-24.0
- data[indx,"Hdeb"]<-23.5
- data$xmin<-lubridate::floor_date(data$per_date_debut,unit="day") # pour les graphiques en rectangle
- data$xmax<-data$xmin+lubridate::days(1)
- return(data)
- }
- tpp<-horaires(t_periodefonctdispositif_per)
- tpp$id=1:nrow(tpp)
- # extract last line per day and round it to 24 h
- tpp_idmax<-tpp%>%dplyr::select(id,Hfin,xmin)%>%
- dplyr::group_by(xmin)%>%filter(min_rank(desc(Hfin)) ==1)
- tpp[tpp$id%in%tpp_idmax$id,"Hfin"]<-24
- # same with Hdeb rounded to OO for the first date of the day
- tpp_idmin<-tpp%>%dplyr::select(id,Hdeb,xmin)%>%
- dplyr::group_by(xmin)%>%filter(min_rank(Hdeb) ==1)
- tpp[tpp$id%in%tpp_idmin$id,"Hdeb"]<-0
- # some days don't have value
- tpp<-dplyr::full_join(tt,tpp,by="per_date_debut")
- # now we have some rows with NA
- # those correspond to period covering more than one day
- # we will extend data over those period using the first line without NA
- for (i in 2: nrow(tpp)){
- if (is.na(tpp$per_tar_code[i])){
- # we replace all values except 1st column, (per_date_debut) which was used to join
- # by the previous line
- tpp[i,c(2:ncol(tpp))]<-tpp[i-1,c(2:ncol(tpp))]
- # but the period is full day ie 0:24
- tpp[i,c("Hdeb","Hfin")]<-c(0,24)
- }
- }
+ tpp<-split_per_day(t_periodefonctdispositif_per,horodatedebut="per_date_debut",horodatefin="per_date_fin")
g<-ggplot(tpp)+
- geom_rect(aes(xmin=xmin,xmax=xmax,ymin=Hdeb,ymax=Hfin,col=factor(per_tar_code),fill=factor(per_tar_code)),alpha=0.8)+
+ geom_rect(aes(xmin=xmin,xmax=xmax,ymin=Hdeb,ymax=Hfin,col=factor(per_tar_code),fill=factor(per_tar_code)),alpha=0.5)+
scale_fill_manual("type",values=c("1"="#40CA2C","2"="#C8B22D","3"="#AB3B26","4"="#B46BED","5"="#B8B8B8"),
labels = get("msg",envir=envir_stacomi)$BilanFonctionnementDF.11)+
scale_colour_manual("type",values=c("1"="#40CA2C","2"="#C8B22D","3"="#AB3B26","4"="#B46BED","5"="#B8B8B8"),
@@ -444,67 +410,156 @@
})
-#' funbarchartDF creates a barchart for BilanFonctionnementDF class
+#' Handler for barchart for BilanFonctionnementDF class from the graphical interface
#'
#' @note The program cuts periods which overlap between two month
#' @param h handler
#' @param ... additional parameters
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @export
funbarchartDF = function(h,...) {
+ fonctionnementDF<-get("fonctionnementDF",envir=envir_stacomi)
fonctionnementDF=charge(fonctionnementDF)
- if( nrow(fonctionnementDF at requete@query)==0 ) {
- funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.3, arret=TRUE)
+ if( nrow(fonctionnementDF at data)==0 ) {
+ funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2, arret=TRUE)
}
plot(fonctionnementDF,plot.type=1,silent=FALSE)
- dev.new()
- plot(fonctionnementDF,plot.type=2,silent=FALSE)
}
-#' FunboxDF draws rectangles to describe the DF work for BilanFonctionnementDF class
+
+#' Handler for barchart for BilanFonctionnementDF class from the graphical interface
+#'
+#' @note The program cuts periods which overlap between two month
#' @param h handler
#' @param ... additional parameters
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @export
+funbarchart1DF = function(h,...) {
+ fonctionnementDF<-get("fonctionnementDF",envir=envir_stacomi)
+ fonctionnementDF=charge(fonctionnementDF)
+ if( nrow(fonctionnementDF at data)==0 ) {
+ funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2, arret=TRUE)
+ }
+ plot(fonctionnementDF,plot.type=2,silent=FALSE)
+}
+#' Internal use, rectangles to describe the DF work for BilanFonctionnementDF class,
+#' graphical interface handler
+#' @param h handler
+#' @param ... additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
funboxDF = function(h,...) {
+ fonctionnementDF<-get("fonctionnementDF",envir=envir_stacomi)
+ fonctionnementDF=charge(fonctionnementDF)
+ if( nrow(fonctionnementDF at data)==0 ) {
+ funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2, arret=TRUE)
+ }
+ plot(fonctionnementDF,plot.type=3,silent=FALSE)
+
+}
+
+#' Handler fonction to plot calendar like graph, internal use
+#' @param h handler
+#' @param ... additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+funchartDF = function(h,...) {
+ fonctionnementDF<-get("fonctionnementDF",envir=envir_stacomi)
fonctionnementDF=charge(fonctionnementDF)
- if( nrow(fonctionnementDF at requete@query)==0 ) {
+ if( nrow(fonctionnementDF at data)==0 ) {
funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2, arret=TRUE)
}
+ plot(fonctionnementDF,plot.type=4,silent=FALSE)
-
}
-#' FuntableDF create a table output for BilanFonctionnementDF class
+
+#' Table output for BilanFonctionnementDF class
#' @param h handler
#' @param ... additional parameters
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @export
funtableDF = function(h,...) {
+ fonctionnementDF<-get("fonctionnementDF",envir=envir_stacomi)
fonctionnementDF=charge(fonctionnementDF)
- if( nrow(fonctionnementDF at requete@query)==0 ) {
+ if( nrow(fonctionnementDF at data)==0 ) {
funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2, arret=TRUE)
}
+ summary(fonctionnementDF)
+}
+
+#' handler to print the command line
+#' @param h a handler
+#' @param ... Additional parameters
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+houtDF = function(h,...) {
+ fonctionnementDF<-get("fonctionnementDF",envir=envir_stacomi)
+ fonctionnementDF<-charge(fonctionnementDF)
+ #the charge method will check that all objects necessary to build the formula
+ # are in envir_stacomi
+ print(fonctionnementDF)
- t_periodefonctdispositif_per=fonctionnementDF at requete@query # on recupere le data.frame
- t_periodefonctdispositif_per$per_date_debut=as.character(t_periodefonctdispositif_per$per_date_debut)
- t_periodefonctdispositif_per$per_date_fin=as.character(t_periodefonctdispositif_per$per_date_fin)
- gdf(t_periodefonctdispositif_per, container=TRUE)
- annee=paste(unique(strftime(as.POSIXlt(t_periodefonctdispositif_per$per_date_debut),"%Y")),collapse="+")
- path1=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste("t_periodefonctdispositif_per_DF_",fonctionnementDF at df@df_selectionne,"_",annee,".csv",sep=""),fsep ="\\")
- write.table(t_periodefonctdispositif_per,file=path1,row.names=FALSE,col.names=TRUE,sep=";")
- funout(paste(get("msg",envir=envir_stacomi)$FonctionnementDC.14,path1,"\n"))
- path1html=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste("t_periodefonctdispositif_per_DF_",fonctionnementDF at df@df_selectionne,"_",annee,".html",sep=""),fsep ="\\")
- funout(paste(get("msg",envir=envir_stacomi)$FonctionnementDC.14,path1html,get("msg",envir=envir_stacomi)$BilanFonctionnementDF.15))
- funhtml(t_periodefonctdispositif_per,
- caption=paste("t_periodefonctdispositif_per_DF_",fonctionnementDF at df@df_selectionne,"_",annee,sep=""),
- top=TRUE,
- outfile=path1html,
- clipboard=FALSE,
- append=FALSE,
- digits=2
- )
-
-}
+}
+
+#' Method to print the command line of the object
+#' @param x An object of class BilanFonctionnementDF
+#' @param ... Additional parameters passed to print
+#' @return NULL
+#' @author cedric.briand
+#' @export
+setMethod("print",signature=signature("BilanFonctionnementDF"),definition=function(x,...){
+
+ sortie1<-"bilanFonctionnementDF=new('BilanFonctionnementDF')\n"
+ sortie2<-stringr::str_c("bilanFonctionnementDF=choice_c(bilanFonctionnementDF,",
+ "df=",x at df@df_selectionne,",",
+ "horodatedebut=",shQuote(as.character(x at horodatedebut@horodate)),",",
+ "horodatefin=",shQuote(as.character(x at horodatefin@horodate)),")")
+ # removing backslashes
+ funout(stringr::str_c(sortie1,sortie2),...)
+ return(invisible(NULL))
+ })
+
+
+#' summary for BilanFonctionnementDF, write csv and html output, and prints summary statistics
+#' @param object An object of class \code{\link{BilanFonctionnementDF-class}}
+#' @param silent Should the program stay silent or display messages, default FALSE
+#' @param ... Additional parameters (not used there)
+#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
+#' @export
+setMethod("summary",signature=signature(object="BilanFonctionnementDF"),definition=function(object,silent=FALSE,...){
+ #fonctionnementDF<-bfDF;
+ t_periodefonctdispositif_per=fonctionnementDF at data # on recupere le data.frame
+ t_periodefonctdispositif_per$per_date_debut=as.character(t_periodefonctdispositif_per$per_date_debut)
+ t_periodefonctdispositif_per$per_date_fin=as.character(t_periodefonctdispositif_per$per_date_fin)
+ #gdf(t_periodefonctdispositif_per, container=TRUE)
+ annee=paste(unique(strftime(as.POSIXlt(t_periodefonctdispositif_per$per_date_debut),"%Y")),collapse="+")
+ path1=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste("t_periodefonctdispositif_per_DF_",fonctionnementDF at df@df_selectionne,"_",annee,".csv",sep=""),fsep ="\\")
+ write.table(t_periodefonctdispositif_per,file=path1,row.names=FALSE,col.names=TRUE,sep=";")
+ if(!silent) funout(paste(get("msg",envir=envir_stacomi)$FonctionnementDC.14,path1,"\n"))
+ path1html=file.path(path.expand(get("datawd",envir=envir_stacomi)),paste("t_periodefonctdispositif_per_DF_",fonctionnementDF at df@df_selectionne,"_",annee,".html",sep=""),fsep ="\\")
+ if(!silent) funout(paste(get("msg",envir=envir_stacomi)$FonctionnementDC.14,path1html,get("msg",envir=envir_stacomi)$BilanFonctionnementDF.15))
+ funhtml(t_periodefonctdispositif_per,
+ caption=paste("t_periodefonctdispositif_per_DF_",fonctionnementDF at df@df_selectionne,"_",annee,sep=""),
+ top=TRUE,
+ outfile=path1html,
+ clipboard=FALSE,
+ append=FALSE,
+ digits=2
+ )
+ t_periodefonctdispositif_per=fonctionnementDF at data
+ print(paste("summary statistics for DF=",fonctionnementDF at df@df_selectionne))
+ print(paste("df_code=",fonctionnementDF at df@data[fonctionnementDF at df@data$df==fonctionnementDF at df@df_selectionne,"df_code"]))
+ duree<-difftime(t_periodefonctdispositif_per$per_date_fin,t_periodefonctdispositif_per$per_date_debut,units="day")
+ sommes<-tapply(duree,t_periodefonctdispositif_per$per_tar_code,sum)
+ perc<-round(100*sommes/as.numeric(sum(duree)))
+ sommes<-round(sommes,2)
+ funout(get("msg",envir=envir_stacomi)$FonctionnementDF.12)
+ funout(paste(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.11,
+ " :",
+ sommes,"(",perc,"%)",sep=""))
+ sommes<-tapply(duree,t_periodefonctdispositif_per$per_etat_fonctionnement,sum)
+ perc<-round(100*sommes/as.numeric(sum(duree)))
+ sommes<-round(sommes,2)
+ funout(get("msg",envir=envir_stacomi)$FonctionnementDF.13)
+ funout(paste(rev(get("msg",envir=envir_stacomi)$BilanFonctionnementDC.11),
+ " :",
+ sommes,"(",perc,"%)",sep=""))
+
+ })
Modified: pkg/stacomir/R/BilanMigrationMult.r
===================================================================
--- pkg/stacomir/R/BilanMigrationMult.r 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/R/BilanMigrationMult.r 2016-09-21 09:51:22 UTC (rev 213)
@@ -593,7 +593,7 @@
summary(bilanMigrationMult)
}
-#' summary for bilanMigrationMult
+#' summary for BilanMigrationMult
#' calls functions funstat and funtable to create migration overviews
#' and generate csv and html output in the user data directory
#' @param object An object of class \code{\link{BilanMigrationMult-class}}
@@ -680,7 +680,7 @@
#' @author cedric.briand
#' @export
setMethod("print",signature=signature("BilanMigrationMult"),definition=function(x,...){
- sortie1<-"bilanMigrationMult=new(bilanMigrationMult)\n"
+ sortie1<-"bilanMigrationMult=new('bilanMigrationMult')\n"
sortie2<-stringr::str_c("bilanMigrationMult=choice_c(bilanMigrationMult,",
"dc=c(",stringr::str_c(x at dc@dc_selectionne,collapse=","),"),",
"taxons=c(",stringr::str_c(shQuote(x at taxons@data$tax_nom_latin),collapse=","),"),",
Modified: pkg/stacomir/R/interface_BilanFonctionnementDF.r
===================================================================
--- pkg/stacomir/R/interface_BilanFonctionnementDF.r 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/R/interface_BilanFonctionnementDF.r 2016-09-21 09:51:22 UTC (rev 213)
@@ -2,42 +2,48 @@
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
interface_BilanFonctionnementDF = function()
{
- fonctionnementDF=new("BilanFonctionnementDF")
- assign("fonctionnementDF",fonctionnementDF,envir=envir_stacomi)
- funout(get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.1)
- fonctionnementDF at df=charge(fonctionnementDF at df)
- group <- gWidgets::ggroup(horizontal=FALSE) # doit toujours s'appeller group
- quitte()
- assign("group",group,envir=.GlobalEnv)
-
- gWidgets::add(ggroupboutons,group)
-
- choice(fonctionnementDF at df)
+ quitte()
+
+ fonctionnementDF=new("BilanFonctionnementDF")
+ assign("fonctionnementDF",fonctionnementDF,envir=envir_stacomi)
+ funout(get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.1)
+ fonctionnementDF at df=charge(fonctionnementDF at df)
+ group <- gWidgets::ggroup(horizontal=FALSE) # doit toujours s'appeller group
+ assign("group",group,envir=.GlobalEnv)
+ gWidgets::add(ggroupboutons,group)
+
+ choice(fonctionnementDF at df)
# here decale =-1 or -2 will make the bilan for the year preceeding the current date
choice(fonctionnementDF at horodatedebut,
label=get("msg",envir=envir_stacomi)$interface_Bilan_lot.3,
nomassign="fonctionnementDF_date_debut",
funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.5,
- decal=-1)
+ decal=-2)
choice(fonctionnementDF at horodatefin,
label=get("msg",envir=envir_stacomi)$interface_Bilan_lot.4,
nomassign="fonctionnementDF_date_fin",
funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.6,
- decal=-2)
+ decal=-1)
- aBarchart=gWidgets::gaction(label="barchart",icon="barplot",handler=funbarchartDF,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.2)
- aBox=gWidgets::gaction(label="boites",icon="graph2",handler=funboxDF,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.3)
- aTable=gWidgets::gaction(label="table",icon="dataframe",handler=funtableDF,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.4)
- aQuit=gWidgets::gaction(label="Quitter",icon="close", handler=quitte,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.5)
-
- toolbarlist <- list(
- barchart=aBarchart,
- box= aBox,
- table=aTable,
- Quit = aQuit)
-
- add(group, gmenu(toolbarlist))
- add(group,gbutton(text = "graph", handler = function(h,...){X11()}))
- gWidgets::addSpring(group)
+ aBarchart=gWidgets::gaction(label="barchart_typefct",icon="barplot",handler=funbarchartDF,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.2)
+ aBarchart1=gWidgets::gaction(label="barchart_fct",icon="barplot",handler=funbarchart1DF,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.2)
+ aBox=gWidgets::gaction(label="box",icon="graph2",handler=funboxDF,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.3)
+ aChart=gWidgets::gaction(label="chart",icon="graph",handler=funchartDF,tooltip="Calendar")
+ aTable=gWidgets::gaction(label="table",icon="dataframe",handler=funtableDF,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.4)
+ aOut=gWidgets::gaction(label="code",handler=houtDF, icon="gtk-info", tooltip=get("msg",envir=envir_stacomi)$BilanMigrationMult.1)
+ aQuit=gWidgets::gaction(label="Close",icon="close", handler=quitte,tooltip=get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.5)
+
+ toolbarlist <- list(
+ barchart=aBarchart,
+ barchart1=aBarchart1,
+ box= aBox,
+ chart=aChart,
+ table=aTable,
+ out=aOut,
+ Quit = aQuit)
+
+ add(group, gmenu(toolbarlist))
+ add(group,gbutton(text = "graph", handler = function(h,...){X11()}))
+ gWidgets::addSpring(group)
dev.new()
}
\ No newline at end of file
Modified: pkg/stacomir/R/stacomi.r
===================================================================
--- pkg/stacomir/R/stacomi.r 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/R/stacomi.r 2016-09-21 09:51:22 UTC (rev 213)
@@ -296,6 +296,7 @@
#' @importFrom lubridate round_date
#' @importFrom lubridate floor_date
#' @importFrom lubridate %m+%
+#' @importFrom lubridate %d+%
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @examples
#'
Modified: pkg/stacomir/R/utilitaires.r
===================================================================
--- pkg/stacomir/R/utilitaires.r 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/R/utilitaires.r 2016-09-21 09:51:22 UTC (rev 213)
@@ -240,3 +240,58 @@
}
+
+#' Create a dataframe suitable for charts per 24h and day
+#'
+#' This functions takes a data frame with a column with starting time and another with ending time
+#' If the period extends over midnight, it will be split into new lines, starting and ending at midnight
+#'
+#' @param data The dataframe
+#' @param horodatedebut The beginning time
+#' @param horodatefin The ending time
+#' @return A data frame with four new columns, Hmin (hour min), Hmax (hmax), xmin (day) and xmax (next day),
+#' and new rows
+#' @author cedric.briand
+#' @example
+#' datatemp<-structure(list(per_dis_identifiant = c(1L, 1L, 1L), per_date_debut = structure(c(1420056600,
+#' 1420071000, 1420081200), class = c("POSIXct", "POSIXt"), tzone = ""),
+#' per_date_fin = structure(c(1420071000, 1420081200, 1421000000
+#' ), class = c("POSIXct", "POSIXt"), tzone = ""), per_commentaires = c("fonct calcul",
+#' "fonct calcul", "fonct calcul"), per_etat_fonctionnement = c(1L,
+#' 0L, 0L), per_tar_code = 1:3, libelle = c("Fonc normal", "Arr ponctuel",
+#' "Arr maint")), .Names = c("per_dis_identifiant", "per_date_debut",
+#' "per_date_fin", "per_commentaires", "per_etat_fonctionnement",
+#' "per_tar_code", "libelle"), row.names = c(NA, 3L), class = "data.frame")
+#'newdf<-split_per_day(data=datatemp,horodatedebut="per_date_debut",horodatefin="per_date_fin")
+#' @export
+split_per_day<-function(data,horodatedebut,horodatefin){
+ if(!horodatedebut%in%colnames(data)) stop("horodatedebut not in column names for data")
+ if(!horodatefin%in%colnames(data)) stop("horodatefin not column names for data")
+ data$Hdeb<-as.numeric(strftime(data[,horodatedebut],"%H"))+as.numeric(strftime(data[,horodatedebut],"%M"))/60
+ data$Hfin<-as.numeric(strftime(data[,horodatefin],"%H"))+round(as.numeric(strftime(data[,horodatefin],"%M"))/60,2)
+ data$xmin<-lubridate::floor_date(data[,horodatedebut],unit="day") # pour les graphiques en rectangle
+ data$xmax<-data$xmin+lubridate::days(1)
+ # number of times we pass to midnigth
+ # round is for when we switch hour
+ data$n0<-round(difftime(floor_date(data[,horodatefin],unit="day"),floor_date(data[,horodatedebut],unit="day"),units="days"))
+ # rows that will be duplicated
+ data$id=sequence(nrow(data))
+ data<-data[rep(sequence(nrow(data)),data$n0+1),]
+ data$newid<-sequence(nrow(data))
+ # within a group where dates overlap between two days
+ #the first will and all lines except the last be set 24 for Hfin
+ data1<-data%>%filter(n0>0)%>%group_by(id)%>%filter(min_rank(desc(newid)) !=1)%>%mutate("Hfin"=24)
+ #replacing rows in data
+ data[match(data1$newid,data$newid),]<-data1
+ # all except the first will be set 0 to Hdeb
+ data2<-data%>%filter(n0>0)%>%group_by(id)%>%filter(min_rank(newid) !=1)%>%mutate("Hdeb"=0)
+ #replacing rows in data
+ data[match(data2$newid,data$newid),]<-data2
+ # now get the sequence of days righly set by adding the number of days to xmin and xmax
+ data3<-data%>%filter(n0>0)%>%group_by(id)%>%mutate(xmin=xmin+ as.difftime(rank(newid)-1, unit="days"),
+ xmax=xmax+as.difftime(rank(newid)-1, unit="days"))
+ data[match(data3$newid,data$newid),]<-data3
+ data<-as.data.frame(data)
+ return(data)
+}
+
Modified: pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R
===================================================================
--- pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R 2016-09-21 09:51:22 UTC (rev 213)
@@ -10,10 +10,15 @@
horodatedebut="2015-01-01",
horodatefin="2015-12-31",
silent=TRUE)
+ # the times at Arzal are recorded continuously
+ # they are converted to date when a time appears while the hour is changing
+ # hence the following
+ Sys.setenv(TZ='GMT')
bfDF<-charge(bfDF)
plot(bfDF,plot.type="1")
plot(bfDF,plot.type="2",title="A nice title")
plot(bfDF,plot.type="3",title="A nice title")
+ plot(bfDF,plot.type="4")
}
Modified: pkg/stacomir/inst/tests/testthat/test-00zRefclasses.R
===================================================================
--- pkg/stacomir/inst/tests/testthat/test-00zRefclasses.R 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/inst/tests/testthat/test-00zRefclasses.R 2016-09-21 09:51:22 UTC (rev 213)
@@ -15,8 +15,8 @@
horodate="2013-01-01 00:00"),prints_text("^\\[1\\].+date.+"))
expect_that(refHorodate<-choice_c(refHorodate,
horodate="01-01-2013"),prints_text("^\\[1\\].+date.+"))
- refHorodate<-choice_c(refHorodate,
- horodate="2013/01/01 00:00:00")
+ expect_error(refHorodate<-choice_c(refHorodate,
+ horodate="2013/01/01 00:00:00"))
rm("envir_stacomi",envir =.GlobalEnv)
})
Modified: pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R
===================================================================
--- pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R 2016-09-19 14:55:10 UTC (rev 212)
+++ pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R 2016-09-21 09:51:22 UTC (rev 213)
@@ -14,7 +14,8 @@
bfDF<-choice_c(bfDF,
2,
horodatedebut="2013-01-01",
- horodatefin="2013-12-31")
+ horodatefin="2013-12-31",
+ silent=TRUE)
expect_gt(nrow(bfDF at df@data),0,
label="There should be data loaded by the choice_c method in the data slot of
the RefDF slot,nrow(bfDF at df@data)")
@@ -57,4 +58,22 @@
plot(bfDF,plot.type="2",silent=TRUE,title="An example title")
plot(bfDF,plot.type="3",silent=TRUE,title="An example title")
plot(bfDF,plot.type="4",silent=TRUE,title="An example title")
+ })
+
+
+test_that("BilanFonctionnementDF summary method works",{
+ require(stacomiR)
+ stacomi(gr_interface=FALSE,login_window=FALSE,database_expected=FALSE)
+ data(bfDF)
+ bfDF<-bfDF
+ expect_output(summary(bfDF))
+ })
+
+
+test_that("BilanFonctionnementDF print method works",{
+ require(stacomiR)
+ stacomi(gr_interface=FALSE,login_window=FALSE,database_expected=FALSE)
+ data(bfDF)
+ bfDF<-bfDF
+ expect_output(print(bfDF))
})
\ No newline at end of file
More information about the Stacomir-commits
mailing list