Nothing
#' Class "report_dc" report du fonctionnement du dispositif de
#' comptage
#'
#' The counting device is not always working. It may me stopped either
#' following a monitoring protocol, or due to malfunction of the device, this
#' class allows to draw graphics allowing an overview of the device operation
#' @slot data A data frame
#' @slot dc An object of class \code{ref_dc-class}
#' @slot horodatedebut An object of class \code{ref_horodate-class}
#' @slot horodatefin An object of class \code{ref_horodate-class}
#' @section Objects from the Class: Objects can be created by calls of the form
#' \code{new("report_dc", ...)}.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @example inst/examples/report_dc-example.R
#' @family report Objects
#' @keywords classes
#' @aliases report_dc
#' @export
setClass(
Class = "report_dc",
representation = representation(
data = "data.frame",
dc = "ref_dc",
horodatedebut = "ref_horodate",
horodatefin = "ref_horodate"
),
prototype = prototype(
data = data.frame(),
dc = new("ref_dc"),
horodatedebut = new("ref_horodate"),
horodatefin = new("ref_horodate")
)
)
#' connect method for report_dc
#'
#' loads the working periods and type of arrest or disfunction of the DC
#' @param object An object of class \link{report_dc-class}
#' @param silent boolean, default FALSE, if TRUE messages are not displayed
#' @return An object of class \link{report_dc-class} with slot data filled from the database
#' @aliases connect.report_dc
#' @author cedric.briand
setMethod(
"connect",
signature = signature("report_dc"),
definition = function(object, silent = FALSE) {
#object<-report_dc
if (length(object@dc@dc_selected)==0) stop("No selected dc in repor_dc@dc@dc_selected, did you forget to use the method charge ?")
req <- new("RequeteDBwheredate")
req@select = sql <- paste(
"SELECT",
" per_dis_identifiant,",
" per_date_debut,",
" per_date_fin,",
" per_commentaires,",
" per_etat_fonctionnement,",
" per_tar_code,",
" tar_libelle AS libelle",
" FROM ",
get_schema(),
"t_periodefonctdispositif_per per",
" INNER JOIN ref.tr_typearretdisp_tar tar ON tar.tar_code=per.per_tar_code",
sep = ""
)
req@colonnedebut <- "per_date_debut"
req@colonnefin <- "per_date_fin"
req@datedebut <- object@horodatedebut@horodate
req@datefin <- object@horodatefin@horodate
req@order_by <- "ORDER BY per_date_debut"
req@and <-
paste("AND per_dis_identifiant in ",
vector_to_listsql(object@dc@dc_selected))
#req@where=#defini dans la methode DBwheredate
req <-
stacomirtools::query(req) # appel de la methode connect de l'object DBWHEREDATE
object@data <- req@query
if (!silent)
funout(gettext("Time steps loaded for this counting device\n", domain =
"R-stacomiR"))
return(object)
}
)
#' charge method for report_dc
#'
#' used by the graphical interface to retrieve the objects of referential classes
#' assigned to envir_stacomi
#' @param object An object of class \link{report_dc-class}
#' @param silent boolean, default FALSE, if TRUE messages are not displayed.
#' @aliases charge.report_dc
#' @return object An object of class \link{report_dc-class} with data set from values assigned in \code{envir_stacomi} environment
#' @keywords internal
setMethod(
"charge",
signature = signature("report_dc"),
definition = function(object, silent = FALSE) {
if (exists("ref_dc", envir_stacomi)) {
object@dc <- get("ref_dc", envir_stacomi)
} else {
funout(
gettext(
"You need to choose a counting device, clic on validate\n",
domain = "R-stacomiR"
),
arret = TRUE
)
}
if (exists("report_dc_date_debut", envir_stacomi)) {
object@horodatedebut@horodate <-
get("report_dc_date_debut", envir_stacomi)
} else {
funout(gettext("You need to choose the starting date\n", domain = "R-stacomiR"),
arret = TRUE)
}
if (exists("report_dc_date_fin", envir_stacomi)) {
object@horodatefin@horodate <- get("report_dc_date_fin", envir_stacomi)
} else {
funout(gettext("You need to choose the ending date\n", domain = "R-stacomiR"),
arret = TRUE)
}
return(object)
}
)
#' command line interface for report_dc class
#'
#' The choice_c method fills in the data slot for ref_dc, and then
#' uses the choice_c methods of these object to "select" the data.
#' @param object An object of class \link{ref_dc-class}
#' @param dc The dc to set
#' @param horodatedebut A POSIXt or Date or character to fix the date of beginning of the report
#' @param horodatefin A POSIXt or Date or character to fix the last date of the report
#' @param silent Should program be silent or display messages
#' @aliases choice_c.report_dc
#' @return An object of class \link{ref_dc-class} with data selected
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @export
setMethod(
"choice_c",
signature = signature("report_dc"),
definition = function(object,
dc,
horodatedebut,
horodatefin,
silent = FALSE) {
# report_dc<-r_dc;dc=5;horodatedebut="2000-01-01";horodatefin="2015-12-31";silent=TRUE
report_dc <- object
assign("report_dc", report_dc, envir = envir_stacomi)
if (!silent)
funout(
gettext(
"Loading of the list for fishways and choice of the time step\n",
domain = "R-stacomiR"
)
)
report_dc@dc <- charge(report_dc@dc)
report_dc@dc <- choice_c(report_dc@dc, dc)
# assigns the parameter (horodatedebut) of the method to the object using choice_c method for ref_dc
report_dc@horodatedebut <- choice_c(
object = report_dc@horodatedebut,
nomassign = "report_dc_date_debut",
funoutlabel = gettext("Beginning date has been chosen\n", domain = "R-stacomiR"),
horodate = horodatedebut,
silent = silent
)
report_dc@horodatefin <- choice_c(
report_dc@horodatefin,
nomassign = "report_dc_date_fin",
funoutlabel = gettext("Ending date has been chosen\n", domain = "R-stacomiR"),
horodate = horodatefin,
silent = silent
)
assign("report_dc", report_dc, envir = envir_stacomi)
return(report_dc)
}
)
#' Different plots for report_dc
#'
#' \itemize{
#' \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.
#' The splitting of different periods into month is
#' assigned to the \code{envir_stacomi} environment.
#' @param x An object of class \link{report_dc-class}.
#' @param plot.type 1 to 4, barplot, barchart, rectangle plot and box showing details of daily operation,
#' a plot with adjacent rectangles.
#' @param silent Stops displaying the messages default to FALSE
#' @param main The title of the graph, if NULL a default title will be plotted
#' with the number of the DF.
#' @param color_type_oper Named vector of color for the graph, must match type operation default to
#' c("Fonc normal" = "#76BEBE",
#' "Arr ponctuel" = "#FF6700",
#' "Arr maint" = "#9E0142",
#' "Dysfonc" = "#EE1874",
#' "Non connu" = "#999999").
#' @param color_etat Named vector state value (must match the names "TRUE", "FALSE").
#' @return Nothing but prints the different plots.
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases plot.report_dc
#' @importFrom utils setTxtProgressBar
#' @export
setMethod(
"plot",
signature(x = "report_dc", y = "missing"),
definition =
function(x,
plot.type = 1,
silent = FALSE,
main = NULL,
color_type_oper = c("Fonc normal" = "#76BEBE",
"Arr ponctuel" = "#FF6700",
"Arr maint" = "#9E0142",
"Dysfonc" = "#EE1874",
"Non connu" = "#999999"),
color_etat=c("TRUE"="#0F313A","FALSE"="#CEB99A")) {
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
# PLOT OF TYPE BARCHART (plot.type=1 (true/false) or plot.type=2)
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
#report_dc<-r_dc; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="1"
report_dc <- 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 (nrow(report_dc@data) == 0)
funout(gettext("No data for this counting device\n", domain = "R-stacomiR"),
arret = TRUE)
if (plot.type == "1" | plot.type == "2") {
t_periodefonctdispositif_per = report_dc@data # on recupere le data.frame
tempsdebut <- t_periodefonctdispositif_per$per_date_debut
tempsfin <- t_periodefonctdispositif_per$per_date_fin
tempsdebut[tempsdebut < report_dc@horodatedebut@horodate] <-
report_dc@horodatedebut@horodate
tempsfin[tempsfin > report_dc@horodatefin@horodate] <-
report_dc@horodatefin@horodate
t_periodefonctdispositif_per = cbind(t_periodefonctdispositif_per, tempsdebut, tempsfin)
seqmois = seq(
from = tempsdebut[1],
to = tempsfin[nrow(t_periodefonctdispositif_per)],
by = "month",
tz = "GMT"
)
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))
t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per[1, ]
############################
# progress bar
###########################
progress_bar <- utils::txtProgressBar()
# this function assigns
z = 0 # compteur tableau t_periodefonctdispositif_per_mois
for (j in 1:nrow(t_periodefonctdispositif_per)) {
#cat( j
setTxtProgressBar(progress_bar,j / nrow(t_periodefonctdispositif_per))
if (j > 1)
t_periodefonctdispositif_per_mois = rbind(t_periodefonctdispositif_per_mois,
t_periodefonctdispositif_per[j, ])
lemoisnext = seqmois[seqmois > tempsdebut[j]][1] # le premier mois superieur a tempsdebut
while (tempsfin[j] > lemoisnext) {
# on est a cheval sur deux periodes
#if (z>0) stop("erreur")
z = z + 1
t_periodefonctdispositif_per_mois = rbind(t_periodefonctdispositif_per_mois,
t_periodefonctdispositif_per[j, ])
t_periodefonctdispositif_per_mois[j + z, "tempsdebut"] = as.POSIXct(lemoisnext)
t_periodefonctdispositif_per_mois[j + z - 1, "tempsfin"] = as.POSIXct(lemoisnext)
lemoisnext = seqmois[match(as.character(lemoisnext), as.character(seqmois)) +
1] # on decale de 1 mois avant de rerentrer dans la boucle
#if (is.na(lemoisnext) ) break
}
#if (is.na(lemoisnext)) 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")
t_periodefonctdispositif_per_mois$mois = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
"%m")
t_periodefonctdispositif_per_mois$annee = strftime(as.POSIXlt(t_periodefonctdispositif_per_mois$tempsdebut),
"%Y")
cat("All done.\n")
close(progress_bar)
if (is.null(main))
main <-
gettextf("Operation of the counting device %s",
report_dc@dc@dc_selected)
# graphic
#modification of the order
t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per_mois[order(t_periodefonctdispositif_per_mois$per_etat_fonctionnement,
decreasing = TRUE), ]
g <- ggplot(t_periodefonctdispositif_per_mois,
aes(x = mois, y = sumduree, fill = libelle)) +
facet_grid(annee ~ .) +
ggtitle(main) +
ylab(gettext("duration", domain = "R-stacomiR")) +
xlab(gettext("month", domain = "R-stacomiR")) +
geom_bar(stat = 'identity') +
scale_fill_manual(
gettext("type_oper.", domain = "R-stacomiR"),
values = color_type_oper
) +
theme(
plot.background = element_rect(fill = "white"),
panel.background = element_rect(fill = "white"),
legend.background = element_rect(fill = "white"),
strip.background = element_rect(colour = "pink", fill = "brown"),
strip.text = element_text(colour = "white"),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
text = element_text(colour = "navyblue"),
line = element_line(colour = "black"),
legend.key = element_rect(fill = "white", colour = "black"),
axis.text = element_text(colour = "black")
)
t_periodefonctdispositif_per_mois = t_periodefonctdispositif_per_mois[order(t_periodefonctdispositif_per_mois$per_etat_fonctionnement), ]
t_periodefonctdispositif_per_mois$per_etat_fonctionnement = as.factor(t_periodefonctdispositif_per_mois$per_etat_fonctionnement)
g1 <-
ggplot(t_periodefonctdispositif_per_mois,
aes(x = mois, y = sumduree)) +
facet_grid(annee ~ .) +
ggtitle(main) +
ylab(gettext("duration", domain = "R-stacomiR")) +
xlab(gettext("month", domain = "R-stacomiR")) +
geom_bar(stat = 'identity', aes(fill = per_etat_fonctionnement)) +
scale_fill_manual(gettext("operation", domain = "R-stacomiR"),
values = color_etat) +
theme(
plot.background = element_rect(fill = "white"),
panel.background = element_rect(fill = "white"),
legend.background = element_rect(fill = "white"),
strip.background = element_rect(colour = "#C07C44", fill = "#A07C68"),
strip.text = element_text(colour = "#41DADE"),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
text = element_text(colour = "#482E21"),
line = element_line(colour = "black"),
legend.key = element_rect(fill = "white", colour = "black"),
axis.text = element_text(colour = "black")
)
if (plot.type == "1") {
print(g)
assign(x = "g_report_dc_1",
value = g,
envir = envir_stacomi)
if (!silent){
funout(text =
gettext(
"Writing the ggplot into envir_stacomi environment : g_report_dc_1=get('g_report_dc_1',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
}
} # end if plot 1
if (plot.type == "2"){
print(g1)
assign("g_report_dc_2",
g1,
envir = envir_stacomi)
if (!silent){
funout(
gettext(
"Writing the ggplot into envir_stacomi environment : g_report_dc_2=get('g_report_dc_2',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
}
} # end if plot 2
assign("periodeDC",
t_periodefonctdispositif_per_mois,
envir = envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the table into envir_stacomi environment : write periodeDC=get('periodeDC',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
# PLOT OF TYPE BOX (plot.type=3)
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
} else if (plot.type == "3") {
#report_dc<-r_dc; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="3"
t_periodefonctdispositif_per = report_dc@data
graphdate <- function(vectordate) {
vectordate <- as.POSIXct(vectordate)
attributes(vectordate) <- NULL
unclass(vectordate)
return(vectordate)
}
time.sequence = seq.POSIXt(
from = report_dc@horodatedebut@horodate,
to = report_dc@horodatefin@horodate,
by = "day"
)
debut = graphdate(time.sequence[1])
fin = graphdate(time.sequence[length(time.sequence)])
# creation d'un graphique vide
if (is.null(main))
main <- ""
plot(
graphdate(time.sequence),
seq(0, 1, length.out = length(time.sequence)),
xlim = c(debut, fin),
type = "n",
xlab = "",
xaxt = "n",
yaxt = "n",
ylab = gettext("Counting device", domain = "R-stacomiR"),
main = main,
#bty="n",
cex = 0.8
)
r <- round(range(time.sequence), "day")
graphics::axis(1,
at = graphdate(seq(r[1], r[2], by = "month")),
labels = strftime(as.POSIXlt(seq(r[1], r[2], by = "month")), format = "%d-%b"))
if (dim(t_periodefonctdispositif_per)[1] == 0) {
rect(
xleft = debut,
ybottom = 0.6,
xright = fin,
ytop = 0.9,
col = "grey",
border = NA,
lwd = 1
)
rect(
xleft = debut,
ybottom = 0.1,
xright = fin,
ytop = 0.4,
col = color_type_oper["Non connu"],
border = NA,
lwd = 1
)
legend(
x = "bottom",
legend = gettext("Func.", "Stop", "Normal func", domain = "R-stacomiR"),
pch = c(16, 16),
col = c("grey", color_type_oper["Non connu"]),
#horiz=TRUE,
ncol = 3,
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 = color_etat["TRUE"],
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 = color_etat["FALSE"],
border = NA,
lwd = 1
)
}
}
listeperiode <-
fun_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,
color = color_type_oper[t_periodefonctdispositif_per$libelle],
date = FALSE
)
for (j in 1:length(listeperiode)) {
rect(
xleft = graphdate(listeperiode[[j]]$debut),
ybottom = 0.1,
xright = graphdate(listeperiode[[j]]$fin),
ytop = 0.4,
col = listeperiode[[j]]$color,
border = NA,
lwd = 1
)
}
legend (
x = debut,
y = 0.6,
legend = gettext(
"Normal",
"Stop",
domain = "R-stacomiR"
),
pch = c(15, 15),
col = color_etat,
bty = "n",
horiz = TRUE,
text.width = (fin - debut) / 6 ,
cex = 0.8
)
legend (
x = debut,
y = 0.1,
legend = names(color_type_oper),
pch = c(15, 15),
col = color_type_oper,
bty = "n",
horiz = TRUE,
text.width = (fin - debut) / 6,
cex = 0.8
)
graphics::text(
x = debut,
y = 0.95,
label = gettext("Operation of the counting device", domain = "R-stacomiR"),
font = 4,
pos = 4
)
graphics::text(
x = debut,
y = 0.45,
label = gettext("Shutdowns types for this counting device", domain = "R-stacomiR"),
font = 4,
pos = 4
)
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
# PLOT OF TYPE BOX (plot.type=4)
#&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
} else if (plot.type == "4") {
if (is.null(main))
main <-
gettext("Working of the counting device",
report_dc@dc@dc_selected)
#report_dc<-r_dc; require(RGtk2); require(lubridate);require(ggplot2);main=NULL;silent=FALSE;plot.type="4"
t_periodefonctdispositif_per = report_dc@data
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,
fill = libelle
),
alpha = 0.8) +
scale_fill_manual(
"type",
values = c(
color_type_oper
),
labels = gettext(
"Normal oper",
"Operational stop",
"Stop",
"Dysfunct",
"Unknown",
domain = "R-stacomiR"
)
) +
#scale_colour_manual("type",values=c("1"="#40CA2C","2"="#C8B22D","3"="#AB3B26","4"="#B46BED","5"="#B8B8B8"),
# labels = gettext("Normal oper","Operational stop","Stop","Dysfunct","Unknown")+ )
ggtitle(main) +
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)
assign("g_report_dc_4",
g,
envir = envir_stacomi)
if (!silent)
funout(
gettext(
"Writing the ggplot into envir_stacomi environment : g_report_dc_4 <- get('g_report_dc_4',envir_stacomi)\n",
domain = "R-stacomiR"
)
)
}
return(invisible(NULL))
}
)
#' Method to print the command line of the object.
#' @param x An object of class report_dc
#' @param ... Additional parameters passed to print
#' @return Nothing, called for its side effect
#' @author cedric.briand
#' @aliases print.report_dc
#' @export
setMethod(
"print",
signature = signature("report_dc"),
definition = function(x, ...) {
sortie1 <- "report_dc=new('report_dc')\n"
sortie2 <- stringr::str_c(
"report_dc=choice_c(report_dc,",
"dc=",
x@dc@dc_selected,
",",
"horodatedebut=",
shQuote(as.character(x@horodatedebut@horodate)),
",",
"horodatefin=",
shQuote(as.character(x@horodatefin@horodate)),
")"
)
# removing backslashes
funout(stringr::str_c(sortie1, sortie2), ...)
return(invisible(NULL))
}
)
#' summary for report_dc, write csv and html output, and prints summary statistics
#' @param object An object of class \code{\link{report_dc-class}}
#' @param silent Should the program stay silent or display messages, default FALSE
#' @param ... Additional parameters (not used there)
#' @return Nothing, called for its side effect of writing html, csv files and printing summary
#' @author Cedric Briand \email{cedric.briand@eptb-vilaine.fr}
#' @aliases summary.report_dc
#' @export
setMethod(
"summary",
signature = signature(object = "report_dc"),
definition = function(object, silent = FALSE, ...) {
#report_dc<-r_dc
report_dc <- object
t_periodefonctdispositif_per <-
report_dc@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)
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_DC_",
report_dc@dc@dc_selected,
"_",
annee,
".csv",
sep = ""
),
fsep = "\\"
)
res <- tryCatch(
write.table(
t_periodefonctdispositif_per,
file = path1,
row.names = FALSE,
col.names = TRUE,
sep = ";"
), error = function(e) e,
finally =
if (!silent) funout(gettextf("Writing of %s \n", path1, domain = "R-stacomiR"))
)
if (inherits(res, "simpleError")) {
warnings("The table could not be reported, please modify datawd with options(stacomiR.path='path/to/directory'")
} else {
# reports works anyways, write html
path1html <-
file.path(
path.expand(get("datawd", envir = envir_stacomi)),
paste(
"t_periodefonctdispositif_per_DC_",
report_dc@dc@dc_selected,
"_",
annee,
".html",
sep = ""
),
fsep = "\\"
)
funout(gettextf(
"Writing of %s this might take a while, please be patient ...\n",
path1html
))
funhtml(
t_periodefonctdispositif_per,
caption = gettextf(
"t_periodefonctdispositif_per_DC_%s_%s",
report_dc@dc@dc_selected,
annee
),
top = TRUE,
outfile = path1html,
clipboard = FALSE,
append = FALSE,
digits = 2
)
}
print(gettextf("summary statistics for CD=%s", report_dc@dc@dc_selected),
domain = "R-stacomiR")
print(gettextf("dc_code=%s", report_dc@dc@data[report_dc@dc@data$dc ==
report_dc@dc@dc_selected, "dc_code"], domain = "R-stacomiR"))
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(gettext("Duration in days (operation type):", domain = "R-stacomiR"))
funout(paste(
gettext(
"Normal oper",
"Operational stop",
"Stop",
"Dysfunct",
"Unknown",
gettext("Func.", "Stop", "Normal func", domain = "R-stacomiR")
),
" :",
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(gettext("Duration in days (operation):", domain = "R-stacomiR"))
funout(paste(rev(
gettext("Func.", "Stop", domain = "R-stacomiR")
),
" :",
sommes, "(", perc, "%)", sep = ""))
return(invisible(NULL))
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.