[Stacomir-commits] r212 - in pkg/stacomir: . R data examples/03_BilanFonctionnementDF inst/config inst/tests/testthat man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Sep 19 16:55:10 CEST 2016
Author: briand
Date: 2016-09-19 16:55:10 +0200 (Mon, 19 Sep 2016)
New Revision: 212
Added:
pkg/stacomir/data/bfDF.rda
pkg/stacomir/man/bfDF.Rd
pkg/stacomir/man/plot-BilanFonctionnementDF-ANY-method.Rd
Modified:
pkg/stacomir/DESCRIPTION
pkg/stacomir/NAMESPACE
pkg/stacomir/R/BilanFonctionnementDF.r
pkg/stacomir/R/RefHorodate.r
pkg/stacomir/R/data.r
pkg/stacomir/R/stacomi.r
pkg/stacomir/data/bM_Arzal.rda
pkg/stacomir/data/msg.rda
pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R
pkg/stacomir/inst/config/generate_data.R
pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R
pkg/stacomir/man/BilanFonctionnementDF-class.Rd
pkg/stacomir/man/charge-BilanFonctionnementDF-method.Rd
pkg/stacomir/man/charge-BilanMigration-method.Rd
pkg/stacomir/man/choice_c-BilanFonctionnementDF-method.Rd
pkg/stacomir/man/choice_c-RefHorodate-method.Rd
pkg/stacomir/man/connect-BilanFonctionnementDF-method.Rd
Log:
Modified: pkg/stacomir/DESCRIPTION
===================================================================
--- pkg/stacomir/DESCRIPTION 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/DESCRIPTION 2016-09-19 14:55:10 UTC (rev 212)
@@ -101,7 +101,8 @@
grDevices,
Hmisc,
RGtk2,
- lubridate
+ lubridate,
+ dplyr
Suggests:
xtable
Author: Cedric Briand [aut, cre],
Modified: pkg/stacomir/NAMESPACE
===================================================================
--- pkg/stacomir/NAMESPACE 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/NAMESPACE 2016-09-19 14:55:10 UTC (rev 212)
@@ -23,6 +23,7 @@
export(hbilanMigrationConditionEnvcalc)
export(interface_BilanEspeces)
export(messages)
+export(mygtkProgressBar)
export(stacomi)
export(vector_to_listsql)
exportClasses(BilanConditionEnv)
@@ -53,6 +54,7 @@
import(RGtk2)
import(RODBC)
import(RPostgreSQL)
+import(dplyr)
import(gWidgets)
import(gWidgetsRGtk2)
import(ggplot2)
@@ -87,6 +89,9 @@
importFrom(lattice,simpleKey)
importFrom(lattice,trellis.par.get)
importFrom(lattice,trellis.par.set)
+importFrom(lubridate,"%m+%")
+importFrom(lubridate,floor_date)
+importFrom(lubridate,round_date)
importFrom(reshape2,dcast)
importFrom(reshape2,melt)
importFrom(stats,as.formula)
Modified: pkg/stacomir/R/BilanFonctionnementDF.r
===================================================================
--- pkg/stacomir/R/BilanFonctionnementDF.r 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/R/BilanFonctionnementDF.r 2016-09-19 14:55:10 UTC (rev 212)
@@ -1,9 +1,13 @@
#' Class "BilanFonctionnementDF" Report fishway work
#'
#' The DF (Dispositif de Franchissement) is a fishway. It may be automated and
-#' work only at certain times This report allows to see the detail of its work.
+#' be operated only during certain periods. This report allows to see the detail of its work.
+#' In the database four types of operation are set, "1"=normal operation,
+#' "2"=Device stopped in nomral operation (ie lift ascending, high tide...),
+#' "3"="Stopped for maintenance or other problem",
+#' "4"="Works but not fully operational, ie flow problem, flood, clogged with debris...",
+#' "5"="Not known")
#'
-#'
#' @include RefDF.r
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("BilanFonctionnementDF")}.
@@ -21,19 +25,19 @@
#' \code{\linkS4class{BilanMigrationInterAnnuelle}}
#' \code{\linkS4class{BilanMigrationPar}}
#' @concept Bilan Object
+#' @examples examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R
#' @export
setClass(Class="BilanFonctionnementDF",
representation= representation(data="data.frame",
df="RefDF",
horodatedebut="RefHorodate",
horodatefin="RefHorodate",
- requete="RequeteODBCwheredate",
- calcdata="data.frame"),
+ requete="RequeteODBCwheredate"),
prototype=prototype(data=data.frame(),df=new("RefDF"),
horodatedebut=new("RefHorodate"),
horodatefin=new("RefHorodate"),
- requete=new("RequeteODBCwheredate"),
- calcdata=data.frame())
+ requete=new("RequeteODBCwheredate")
+ )
)
@@ -65,7 +69,8 @@
object at requete@datefin<-object at horodatefin@horodate
object at requete@and=paste("AND per_dis_identifiant=",object at df@df_selectionne )
#object at requete@where=#defini dans la methode ODBCwheredate
- object at requete<-stacomirtools::connect(object at requete) # appel de la methode connect de l'object ODBCWHEREDATE
+ req<-stacomirtools::connect(object at requete) # appel de la methode connect de l'object ODBCWHEREDATE
+ object at data<-req at query
if (!silent) funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.1)
return(object)
})
@@ -120,50 +125,60 @@
#' @param df The df to set
#' @param horodatedebut A POSIXt or Date or character to fix the date of beginning of the Bilan
#' @param horodatefin A POSIXt or Date or character to fix the last date of the Bilan
+#' @param silent Should program be silent or display messages
#' @return An object of class \link{RefDC-class} with slots filled
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @export
-setMethod("choice_c",signature=signature("BilanFonctionnementDF"),definition=function(object,df,horodatedebut,horodatefin,...){
+setMethod("choice_c",signature=signature("BilanFonctionnementDF"),definition=function(object,df,horodatedebut,horodatefin,silent=FALSE){
# fonctionnementDF<-BfDF;df=2;horodatedebut="2013-01-01";horodatefin="2013-12-31"
fonctionnementDF<-object
assign("fonctionnementDF",fonctionnementDF,envir=envir_stacomi)
- funout(get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.1)
+ if (!silent) funout(get("msg",envir=envir_stacomi)$interface_BilanFonctionnementDC.1)
fonctionnementDF at df<-charge(fonctionnementDF at df)
fonctionnementDF at df<-choice_c(fonctionnementDF at df,df)
# assigns the parameter (horodatedebut) of the method to the object using choice_c method for RefDC
fonctionnementDF at horodatedebut<-choice_c(object=fonctionnementDF at horodatedebut,
nomassign="fonctionnementDF_date_debut",
funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.5,
- horodate=horodatedebut)
+ horodate=horodatedebut, silent)
fonctionnementDF at horodatefin<-choice_c(fonctionnementDF at horodatefin,
nomassign="fonctionnementDF_date_fin",
funoutlabel=get("msg",envir=envir_stacomi)$interface_Bilan_lot.6,
- horodate=horodatefin)
+ horodate=horodatefin,silent)
return(fonctionnementDF)
})
+#' Different plots for BilanFonctionnementDF
#'
-#'
#' \itemize{
-#' \item{plot.type="barchart"}{}
-#' \item{plot.type="box"}{}
+#' \item{plot.type=1}{A barplot of the operation time per month}
+#' \item{plot.type=2}{Barchat giving the time per type of operation }
+#' \item{plot.type=2}{Rectangle plots drawn along a line}
+#' \item{plot.type=4}{Plots per day drawn over the period to show the operation of a df, days in x, hours in y}
#' }
-#' }
-#' @note The program cuts periods which overlap between two month
+#'
+#' @note The program cuts periods which overlap between two month. The splitting of different periods into month is
+#' assigned to the \code{envir_stacomi} environment
#' @param x An object of class \link{BilanFonctionnementDF-class}
#' @param y From the formals but missing
#' @param plot.type One of \code{barchart},\code{box}. Defaut to \code{barchart} showing a summary of the df operation per month, can also be \code{box},
#' a plot with adjacent rectangles.
#' @param silent Stops displaying the messages.
#' @param title The title of the graph, if NULL a default title will be plotted with the number of the DF
-#' @retuns
+#' @return Nothing but prints the different plots
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @export
-setMethod("plot",signature(x = "BilanFonctionnementDF", y = "ANY"),definition=function(x, y,plot.type="barchart",silent=FALSE,title=NULL){
- #fonctionnementDF<-BfDF
- if (plot.type=="barchart"){
+setMethod("plot",signature(x = "BilanFonctionnementDF", y = "ANY"),definition=function(x, y,plot.type=1,silent=FALSE,title=NULL){
+ #&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+ # PLOT OF TYPE BARCHART (plot.type=1 (true/false) or plot.type=2)
+ #&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+ #fonctionnementDF<-bfDF; require(RGtk2); require(lubridate);require(ggplot2);title=NULL;silent=FALSE;plot.type="1"
+ fonctionnementDF<-x
+ plot.type<-as.character(plot.type)# to pass also characters
+ if (!plot.type%in%c("1","2","3","4")) stop('plot.type must be 1,2,3 or 4')
+ if (plot.type=="1"|plot.type=="2"){
if (!silent) funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2)
- t_periodefonctdispositif_per=fonctionnementDF at requete@query # on recupere le data.frame
+ 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
tempsfin<-t_periodefonctdispositif_per$per_date_fin
@@ -172,9 +187,12 @@
# id pour fin
tempsfin[tempsfin>fonctionnementDF at requete@datefin]<-fonctionnementDF at requete@datefin
t_periodefonctdispositif_per=cbind(t_periodefonctdispositif_per,tempsdebut,tempsfin)
- # BUG 06/02/2009 11:51:49 si la date choisie n'est pas le debut du mois
seqmois=seq(from=tempsdebut[1],to=tempsfin[nrow(t_periodefonctdispositif_per)],by="month",tz = "GMT")
- seqmois=as.POSIXlt(lubridate::round_date(seqmois,unit="month"))
+ seqmois=as.POSIXlt(round_date(seqmois,unit="month"))
+ # adding one month at the end to get a complete coverage of the final month
+ seqmois<-c(seqmois,
+ seqmois[length(seqmois)]%m+%months(1))
+
#seqmois<-c(seqmois,seqmois[length(seqmois)]+months(1))
t_periodefonctdispositif_per_mois=t_periodefonctdispositif_per[1,]
############################
@@ -200,9 +218,9 @@
t_periodefonctdispositif_per_mois[j+z,"tempsdebut"]=as.POSIXct(lemoissuivant)
t_periodefonctdispositif_per_mois[j+z-1,"tempsfin"]=as.POSIXct(lemoissuivant)
lemoissuivant=seqmois[match(as.character(lemoissuivant),as.character(seqmois))+1] # on decale de 1 mois avant de rerentrer dans la boucle
- if (is.na(lemoissuivant) ) break
+ #if (is.na(lemoissuivant) ) break
}
- if (is.na(lemoissuivant)) break
+ #if (is.na(lemoissuivant)) break
}
t_periodefonctdispositif_per_mois$sumduree<-as.numeric(difftime(t_periodefonctdispositif_per_mois$tempsfin, t_periodefonctdispositif_per_mois$tempsdebut,units = "hours"))
t_periodefonctdispositif_per_mois$mois1= strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),"%b")
@@ -232,21 +250,197 @@
geom_bar(stat='identity',aes(fill=fonctionnement))+
scale_fill_manual(values = c("#E41A1C","#4DAF4A"))
- if(length(unique(t_periodefonctdispositif_per_mois$annee))>1) {
+ if (plot.type=="1")
print(g)
- grDevices::dev.new () ;print(g1)
- }else {
- vplayout <- function(x, y) { grid::viewport(layout.pos.row = x, layout.pos.col = y) }
- grid::grid.newpage()
- grid::pushViewport(grid::viewport(layout = grid::grid.layout(1,2,just="center")))
- print(g, vp=vplayout(1,1))
- print(g1, vp=vplayout(1,2))
- }
+ if (plot.type=="2")
+ print(g1)
assign("periodeDF",t_periodefonctdispositif_per_mois,envir_stacomi)
if (!silent) funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.8)
- gtkWidgetDestroy(progres)
- } else if (plot.type=="box"){
+ # the progress bar has been assigned in envir_stacomi, we destroy it
+ gtkWidgetDestroy(get("progres",envir=envir_stacomi))
+ #&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+ # PLOT OF TYPE BOX (plot.type=3)
+ #&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+ } else if (plot.type=="3"){
+ #fonctionnementDF<-bfDF; require(RGtk2); require(lubridate);require(ggplot2);title=NULL;silent=FALSE;plot.type="3"
+ t_periodefonctdispositif_per=fonctionnementDF at data
+ graphdate<-function(vectordate){
+ vectordate<-as.POSIXct(vectordate)
+ attributes(vectordate)<-NULL
+ unclass(vectordate)
+ return(vectordate)
+ }
+ time.sequence=seq.POSIXt(from=fonctionnementDF at requete@datedebut,to=fonctionnementDF at requete@datefin,by="day")
+ debut=graphdate(time.sequence[1])
+ fin=graphdate(time.sequence[length(time.sequence)])
+ mypalette<-RColorBrewer::brewer.pal(12,"Paired")
+ #display.brewer.all()
+ mypalette1<-c("#1B9E77","#AE017E","orange", RColorBrewer::brewer.pal(12,"Paired"))
+ # creation d'un graphique vide
+ if (is.null(title)) title<-""
+ plot( graphdate(time.sequence),
+ seq(0,1,length.out=length(time.sequence)),
+ xlim=c(debut,fin),
+ type= "n",
+ xlab="",
+ xaxt="n",
+ yaxt="n",
+ ylab=get("msg",envir=envir_stacomi)$BilanFonctionnementDF.9,
+ main=title,
+ #bty="n",
+ cex=0.8)
+ r <- round(range(time.sequence), "day")
+ graphics::axis(1, at=graphdate(seq(r[1], r[2], by="weeks")),labels=strftime(as.POSIXlt(seq(r[1], r[2], by="weeks")),format="%d-%b"))
+ if (dim(t_periodefonctdispositif_per)[1]==0 ) {
+ rect( xleft=debut,
+ ybottom=0.6,
+ xright=fin,
+ ytop=0.9,
+ col = mypalette[4],
+ border = NA,
+ lwd = 1)
+ rect( xleft=debut,
+ ybottom=0.1,
+ xright=fin,
+ ytop=0.4,
+ col = mypalette[1],
+ border = NA,
+ lwd = 1)
+ legend( x= "bottom",
+ legend= get("msg",envir=envir_stacomi)$BilanFonctionnementDC.10,
+ pch=c(16,16),
+ col=c(mypalette[4],mypalette[6],mypalette[1]),
+ #horiz=TRUE,
+ ncol=5,
+ bty="n")
+ } else {
+
+ if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement==1)>0){
+ rect( xleft =graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement==1]),
+ ybottom=0.6,
+ xright=graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement==1]),
+ ytop=0.9,
+ col = mypalette[4],
+ border = NA,
+ lwd = 1) }
+ if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement==0)>0) {
+ rect( xleft =graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement==0]),
+ ybottom=0.6,
+ xright=graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement==0]),
+ ytop=0.9,
+ col = mypalette[6],
+ border = NA,
+ lwd = 1) }
+ listeperiode<-
+ fn_table_per_dis(typeperiode=t_periodefonctdispositif_per$per_tar_code,
+ tempsdebut= t_periodefonctdispositif_per$per_date_debut,
+ tempsfin=t_periodefonctdispositif_per$per_date_fin,
+ libelle=t_periodefonctdispositif_per$libelle,
+ date=FALSE)
+ nomperiode<-vector()
+
+ for (j in 1 : length(listeperiode)){
+ nomperiode[j]<-substr(listeperiode[[j]]$nom,1,17)
+ rect( xleft=graphdate(listeperiode[[j]]$debut),
+ ybottom=0.1,
+ xright=graphdate(listeperiode[[j]]$fin),
+ ytop=0.4,
+ col = mypalette1[j],
+ border = NA,
+ lwd = 1)
+ }
+ legend (x= debut,
+ y=0.6,
+ legend= get("msg",envir=envir_stacomi)$BilanFonctionnementDC.11,
+ pch=c(15,15),
+ col=c(mypalette[4],mypalette[6]),
+ bty="n",
+ horiz=TRUE,
+ text.width=(fin-debut)/6 ,
+ cex=0.8
+ )
+ legend (x= debut,
+ y=0.1,
+ legend= c(nomperiode),
+ pch=c(15,15),
+ col=c(mypalette1[1:length(listeperiode)]),
+ bty="n",
+ horiz=TRUE,
+ text.width=(fin-debut)/8,
+ cex=0.7
+ )
+ text(x=debut,y=0.95, label=get("msg",envir=envir_stacomi)$BilanFonctionnementDF.7,font=4,pos=4)
+ text(x=debut,y=0.45, label=get("msg",envir=envir_stacomi)$BilanFonctionnementDF.10, font=4,pos=4)
+ }
+ #&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+ # PLOT OF TYPE BOX (plot.type=4)
+ #&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
+ } else if (plot.type=="4"){
+ if (is.null(title)) title<-paste(get("msg",envir_stacomi)$BilanFonctionnementDF.7,fonctionnementDF at df@df_selectionne)
+
+ #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)
+ }
+ }
+
+ 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)+
+ 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"),
+ labels = get("msg",envir=envir_stacomi)$BilanFonctionnementDF.11)+
+ ylab("Heure")+theme(
+ plot.background = element_rect(fill ="black"),
+ panel.background = element_rect(fill="black"),
+ legend.background=element_rect(fill="black"),
+ panel.grid.major = element_blank(),
+ panel.grid.minor = element_blank(),
+ text=element_text(colour="white"),
+ line = element_line(colour = "grey50"),
+ legend.key=element_rect(fill="black",colour="black"),
+ axis.text=element_text(colour="white")
+ )
+
+ print(g)
+
}
+ return(invisible(NULL))
})
@@ -262,7 +456,9 @@
if( nrow(fonctionnementDF at requete@query)==0 ) {
funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.3, arret=TRUE)
}
- plot(fonctionnementDF,plot.type="barchart",silent=FALSE)
+ 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
@@ -278,116 +474,7 @@
funout(get("msg",envir=envir_stacomi)$BilanFonctionnementDF.2, arret=TRUE)
}
- t_periodefonctdispositif_per=fonctionnementDF at requete@query # on recupere le data.frame
- graphdate<-function(vectordate){
- vectordate<-as.POSIXct(vectordate)
- attributes(vectordate)<-NULL
- unclass(vectordate)
- return(vectordate)
- }
- time.sequence=seq.POSIXt(from=fonctionnementDF at requete@datedebut,to=fonctionnementDF at requete@datefin,by="day")
- debut=graphdate(time.sequence[1])
- fin=graphdate(time.sequence[length(time.sequence)])
- mypalette<-RColorBrewer::brewer.pal(12,"Paired")
- #display.brewer.all()
- mypalette1<-c("#1B9E77","#AE017E","orange", RColorBrewer::brewer.pal(12,"Paired"))
- ###################################
- # creation d'un graphique vide (2)
- ###################################
- plot( graphdate(time.sequence),
- seq(0,1,length.out=length(time.sequence)),
- xlim=c(debut,fin),
- type= "n",
- xlab="",
- xaxt="n",
- yaxt="n",
- ylab=get("msg",envir=envir_stacomi)$BilanFonctionnementDF.9,
- #bty="n",
- cex=0.8)
- r <- round(range(time.sequence), "day")
- graphics::axis(1, at=graphdate(seq(r[1], r[2], by="weeks")),labels=strftime(as.POSIXlt(seq(r[1], r[2], by="weeks")),format="%d-%b"))
- if (dim(t_periodefonctdispositif_per)[1]==0 ) {
- rect( xleft=debut,
- ybottom=0.6,
- xright=fin,
- ytop=0.9,
- col = mypalette[4],
- border = NA,
- lwd = 1)
- rect( xleft=debut,
- ybottom=0.1,
- xright=fin,
- ytop=0.4,
- col = mypalette[1],
- border = NA,
- lwd = 1)
- legend( x= "bottom",
- legend= get("msg",envir=envir_stacomi)$BilanFonctionnementDC.10,
- pch=c(16,16),
- col=c(mypalette[4],mypalette[6],mypalette[1]),
- #horiz=TRUE,
- ncol=5,
- bty="n")
- } else {
-
- if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement==1)>0){
- rect( xleft =graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement==1]),
- ybottom=0.6,
- xright=graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement==1]),
- ytop=0.9,
- col = mypalette[4],
- border = NA,
- lwd = 1) }
- if (sum(t_periodefonctdispositif_per$per_etat_fonctionnement==0)>0) {
- rect( xleft =graphdate(t_periodefonctdispositif_per$per_date_debut[t_periodefonctdispositif_per$per_etat_fonctionnement==0]),
- ybottom=0.6,
- xright=graphdate(t_periodefonctdispositif_per$per_date_fin[t_periodefonctdispositif_per$per_etat_fonctionnement==0]),
- ytop=0.9,
- col = mypalette[6],
- border = NA,
- lwd = 1) }
- listeperiode<-
- fn_table_per_dis(typeperiode=t_periodefonctdispositif_per$per_tar_code,
- tempsdebut= t_periodefonctdispositif_per$per_date_debut,
- tempsfin=t_periodefonctdispositif_per$per_date_fin,
- libelle=t_periodefonctdispositif_per$libelle,
- date=FALSE)
- nomperiode<-vector()
-
- for (j in 1 : length(listeperiode)){
- nomperiode[j]<-substr(listeperiode[[j]]$nom,1,17)
- rect( xleft=graphdate(listeperiode[[j]]$debut),
- ybottom=0.1,
- xright=graphdate(listeperiode[[j]]$fin),
- ytop=0.4,
- col = mypalette1[j],
- border = NA,
- lwd = 1)
- }
- legend (x= debut,
- y=0.6,
- legend= get("msg",envir=envir_stacomi)$BilanFonctionnementDC.11,
- pch=c(15,15),
- col=c(mypalette[4],mypalette[6]),
- bty="n",
- horiz=TRUE,
- text.width=(fin-debut)/6 ,
- cex=0.8
- )
- legend (x= debut,
- y=0.1,
- legend= c(nomperiode),
- pch=c(15,15),
- col=c(mypalette1[1:length(listeperiode)]),
- bty="n",
- horiz=TRUE,
- text.width=(fin-debut)/8,
- cex=0.7
- )
- text(x=debut,y=0.95, label=get("msg",envir=envir_stacomi)$BilanFonctionnementDF.7,font=4,pos=4)
- text(x=debut,y=0.45, label=get("msg",envir=envir_stacomi)$BilanFonctionnementDF.10, font=4,pos=4)
- }
}
#' FuntableDF create a table output for BilanFonctionnementDF class
#' @param h handler
Modified: pkg/stacomir/R/RefHorodate.r
===================================================================
--- pkg/stacomir/R/RefHorodate.r 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/R/RefHorodate.r 2016-09-19 14:55:10 UTC (rev 212)
@@ -105,6 +105,7 @@
#' @param nomassing The name assigned in environment envir_stacomi
#' @param funoutlabel, text displayed by the interface
#' @param affichecal Default TRUE, should the calendar be displayed
+#' @param silent Default FALSE, should messages be displayed
#' @param horodate The horodate to set, formats "\%d/\%m/\%Y \%H:\%M:\%s", "\%d/\%m/\%y \%H:\%M:\%s", "\%Y-\%m-\%d \%H:\%M:\%s" formats
#' can also be passed with the date set to the minute \%d/\%m/\%Y \%H:\%M or the day \%d/\%m/\%Y
#' \dots are accepted
@@ -113,7 +114,8 @@
nomassign="horodate",
funoutlabel="nous avons le choix dans la date\n",
#decal=0,
- horodate
+ horodate,
+ silent=FALSE
) {
# horodate="2013-01-01"
# parse the horohorodate
Modified: pkg/stacomir/R/data.r
===================================================================
--- pkg/stacomir/R/data.r 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/R/data.r 2016-09-19 14:55:10 UTC (rev 212)
@@ -83,3 +83,35 @@
#' the program will use a file installed in c:/program files/stacomi but
#' if not found will switch to the default
"calcmig"
+
+
+#' An object of class \link{BilanFonctionnementDF-class} with data loaded
+#'
+#' This data corresponds to the data collected at the vertical slot fishway
+#' in 2015, the fishway is working daily with a cycle depending on tide.
+#'
+#' @format An object of class bilanFonctionnementDF with 5 slots:
+#' \describe{
+#' #' \item{data}{ A dataframe with 4261 obs. of 7 variables
+#' \describe{
+#' \item{per_dis_identifiant}{The number of the DF}
+#' \item{per_date_debut}{Starting time a POSIXct}
+#' \item{per_date_fin }{Ending time a POSIXct}
+#' \item{ope_dic_identifiant}{DF id}
+#' \item{per_commentaires }{A comment}
+#' \item{per_etat_fonctionnement}{Integer 1= working, 0 not working}
+#' \item{per_tar_code}{The type of operation ("1"=normal operation,
+#' "2"=Device stopped in nomral operation (ie lift ascending, high tide...),
+#' "3"="Stopped for maintenance or other problem",
+#' "4"="Works but not fully operational, ie flow problem, flood, clogged with debris...",
+#' "5"="Not known")}
+#' \item{libelle}{label corresponding to per_tar_code}
+#' }
+#' }
+#' \item{df}{the \code{RefDF} object with 3 slots filled with data corresponding to the iav postgres schema}
+#' \item{horodatedebut}{the \code{RefHorodate} with horodate set for starting date}
+#' \item{horodatefin}{the \code{RefHorodate} with horodate set for ending date}
+#' \item{requete}{A stacomiRtools RequeteODBCWhereDate object}
+#' }
+#' @keywords data
+"bfDF"
\ No newline at end of file
Modified: pkg/stacomir/R/stacomi.r
===================================================================
--- pkg/stacomir/R/stacomi.r 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/R/stacomi.r 2016-09-19 14:55:10 UTC (rev 212)
@@ -270,6 +270,7 @@
#' @import RODBC
#' @import Hmisc
#' @import RGtk2
+#' @import dplyr
#' @importFrom intervals Intervals
#' @importFrom intervals closed<-
#' @importFrom intervals interval_overlap
@@ -293,6 +294,8 @@
#' @importFrom stats as.formula coef na.fail nls pbeta predict sd
#' @importFrom grDevices gray rainbow
#' @importFrom lubridate round_date
+#' @importFrom lubridate floor_date
+#' @importFrom lubridate %m+%
#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
#' @examples
#'
Modified: pkg/stacomir/data/bM_Arzal.rda
===================================================================
(Binary files differ)
Added: pkg/stacomir/data/bfDF.rda
===================================================================
(Binary files differ)
Property changes on: pkg/stacomir/data/bfDF.rda
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: pkg/stacomir/data/msg.rda
===================================================================
(Binary files differ)
Modified: pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R
===================================================================
--- pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R 2016-09-19 14:55:10 UTC (rev 212)
@@ -1,4 +1,21 @@
+require(stacomiR)
stacomi(gr_interface=FALSE,
login_window=FALSE,
database_expected=FALSE)
-bDF=new("BilanFonctionnementDF")
+## An example that will work with the database installed only
+\dontrun{
+ bfDF=new("BilanFonctionnementDF")
+ bfDF<-choice_c(bfDF,
+ 1,
+ horodatedebut="2015-01-01",
+ horodatefin="2015-12-31",
+ silent=TRUE)
+ 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")
+}
+
+
+
+
Modified: pkg/stacomir/inst/config/generate_data.R
===================================================================
--- pkg/stacomir/inst/config/generate_data.R 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/inst/config/generate_data.R 2016-09-19 14:55:10 UTC (rev 212)
@@ -88,8 +88,19 @@
#################################
# generates dataset for BilanFonctionnementDF
##################################
+require(stacomiR)
stacomi(gr_interface=FALSE,
login_window=FALSE,
database_expected=FALSE)
-bDF=new("BilanFonctionnementDF")
-bDF
+bfDF=new("BilanFonctionnementDF")
+bfDF<-choice_c(bfDF,
+ 1,
+ horodatedebut="2015-01-01",
+ horodatefin="2015-12-31",
+ silent=TRUE)
+Sys.setenv(TZ='GMT') # there are data when hour shift, without this the graph will fail
+bfDF<-charge(bfDF)
+#plot(bfDF,plot.type="1")
+#plot(bfDF,plot.type="2",title="A nice title")
+setwd("F:/workspace/stacomir/pkg/stacomir")
+devtools::use_data(bfDF,internal=FALSE,overwrite=TRUE)
\ No newline at end of file
Modified: pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R
===================================================================
--- pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/inst/tests/testthat/test-03BilanFonctionnementDF.R 2016-09-19 14:55:10 UTC (rev 212)
@@ -10,24 +10,24 @@
sch<-get("sch",envir=envir_stacomi) # "iav."
assign("sch","iav.",envir_stacomi)
- BfDF<-new("BilanFonctionnementDF")
- BfDF<-choice_c(BfDF,
+ bfDF<-new("BilanFonctionnementDF")
+ bfDF<-choice_c(bfDF,
2,
horodatedebut="2013-01-01",
horodatefin="2013-12-31")
- expect_gt(nrow(BfDF at df@data),0,
+ 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)")
- expect_s4_class(BfDF,
+the RefDF slot,nrow(bfDF at df@data)")
+ expect_s4_class(bfDF,
"BilanFonctionnementDF")
- expect_failure(BfDF<-choice_c(BfDF,
+ expect_failure(BfDF<-choice_c(bfDF,
2,
horodatedebut="2013 01 011",
horodatefin="2013-12-31"))
})
-test_that("BilanFonctionnementDF plot method works",{
+test_that("BilanFonctionnementDF charge method works",{
require(stacomiR)
stacomi(gr_interface=FALSE,login_window=FALSE,database_expected=FALSE)
# overriding user schema to point to iav
@@ -37,12 +37,24 @@
sch<-get("sch",envir=envir_stacomi) # "iav."
assign("sch","iav.",envir_stacomi)
- BfDF<-new("BilanFonctionnementDF")
- BfDF<-choice_c(BfDF,
+ bfDF<-new("BilanFonctionnementDF")
+ bfDF<-choice_c(bfDF,
2,
horodatedebut="2013-01-01",
- horodatefin="2013-12-31")
- BfDF<-charge(BfDF,silent=TRUE)
-
-
+ horodatefin="2013-12-31",
+ silent=TRUE)
+ bfDF<-charge(bfDF,silent=TRUE)
+ expect_equals(nrow(bfDF at data),5)
+ })
+
+
+test_that("BilanFonctionnementDF plot method works",{
+ require(stacomiR)
+ stacomi(gr_interface=FALSE,login_window=FALSE,database_expected=FALSE)
+ data(bfDF)
+ bfDF<-bfDF
+ plot(bfDF,plot.type="1",silent=TRUE)
+ 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")
})
\ No newline at end of file
Modified: pkg/stacomir/man/BilanFonctionnementDF-class.Rd
===================================================================
--- pkg/stacomir/man/BilanFonctionnementDF-class.Rd 2016-09-17 20:06:10 UTC (rev 211)
+++ pkg/stacomir/man/BilanFonctionnementDF-class.Rd 2016-09-19 14:55:10 UTC (rev 212)
@@ -6,12 +6,20 @@
\title{Class "BilanFonctionnementDF" Report fishway work}
\description{
The DF (Dispositif de Franchissement) is a fishway. It may be automated and
-work only at certain times This report allows to see the detail of its work.
+be operated only during certain periods. This report allows to see the detail of its work.
+In the database four types of operation are set, "1"=normal operation,
+"2"=Device stopped in nomral operation (ie lift ascending, high tide...),
+"3"="Stopped for maintenance or other problem",
+"4"="Works but not fully operational, ie flow problem, flood, clogged with debris...",
+"5"="Not known")
}
\section{Objects from the Class}{
Objects can be created by calls of the form
\code{new("BilanFonctionnementDF")}.
}
+\examples{
+examples/03_BilanFonctionnementDF/bilanFonctionnementDF_example.R
+}
\author{
Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
}
Added: pkg/stacomir/man/bfDF.Rd
===================================================================
--- pkg/stacomir/man/bfDF.Rd (rev 0)
+++ pkg/stacomir/man/bfDF.Rd 2016-09-19 14:55:10 UTC (rev 212)
@@ -0,0 +1,38 @@
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/stacomir -r 212
More information about the Stacomir-commits
mailing list