inst/deploy_scripts/PRRS.R

In SVA-SE/svamap: Package to produce data summaries for the web

library(svamap)
### Clean data
df <- read.csv2("//sva.se/UPP/Temp/Falkenrapporter/PRRS-2017-falkenrapport.csv", encoding = "UTF-8", stringsAsFactors = FALSE)
df$Ankomstdatum <- as.Date(df$Ankomstdatum)
t_breaks <- seq.Date(as.Date("2014-01-01"), as.Date("2020-01-01"), by = "year")
# Summarize the latest year by month
fix_data <- function(df, t_breaks) {
    monthly <- time_count(df$Ankomstdatum, "months", "freq", tmin = t_breaks[6], tmax = t_breaks[7])
    monthly$months <- as.Date(monthly$months)
    names(monthly)[names(monthly) == "n"] <- "count_sample"
    monthly$cumul <- time_count(df$Ankomstdatum, "months", "cumul", tmin = t_breaks[6], tmax = t_breaks[7])$n
    ## Take data from first 3 years and generate an 'expected':
    monthly$hist_count <- round(rowMeans(do.call("cbind", lapply(1:5, function(x){
        time_count(df$Ankomstdatum, "months", "freq", tmin = t_breaks[x], tmax = t_breaks[x+1])$n
    }))))
    monthly$hist_cumul <- round(rowMeans(do.call("cbind", lapply(1:5, function(x){
        time_count(df$Ankomstdatum, "months", "cumul", tmin = t_breaks[x], tmax = t_breaks[x+1])$n
    }))))
    monthly$months <- months(monthly$months, abbreviate = FALSE)
    monthly <- monthly[,c(1,4,5,2,3)]
    return(monthly)
}
df_abbatoir <- df[df[, "\u00D6verordnadeuppdrag"] == "\u00D609-022", ]
df_sows <- df[df[, "\u00D6verordnadeuppdrag"] == "\u00D609-021",]
## Write to web
data <- tempfile()
graph <- tempfile()
write_UTF8(timeseries_json(df = fix_data(df_abbatoir, t_breaks),
                           x = "months",
                           dataname = "data1",
                           series_label = c("Expected Number of samples per month",
                                            "Expected Cumulative samples per month",
                                            "Number of samples per month",
                                            "Cumulative number of samples"),
                           backgroundColor = c("#860000", "#005D82", "#D22630", "#00A9CE"),
                           hoverBackgroundColor = c("#6D0000", "#004469", "#B90D17", "#0090B5"),
                           hidden = c(FALSE, TRUE, FALSE, TRUE),
                           fill = FALSE,
                           pointRadius = 2,
                           type = c("line", "line", "bar", "bar")), data)
my_y_axis <- yAxes(list(yAxis("a", "linear", "left", NULL, NULL, display = TRUE, labelString = "Number of samples collected at slaughter")))
write_UTF8(timeseries_html("data1", "data1.js", my_y_axis), graph)
file.copy(data, "//webutv/ESS/PRRS/data1.js", overwrite = TRUE)
file.copy(graph, "//webutv/ESS/PRRS/graph_abbatoir.html", overwrite = TRUE)
## The sows
write_UTF8(timeseries_json(df = fix_data(df_sows, t_breaks),
                           x = "months",
                           dataname = "data2",
                           series_label = c("Expected Number of samples per month",
                                            "Expected Cumulative samples per month",
                                            "Number of samples per month",
                                            "Cumulative number of samples"),
                           backgroundColor = c("#860000", "#005D82", "#D22630", "#00A9CE"),
                           hoverBackgroundColor = c("#6D0000", "#004469", "#B90D17", "#0090B5"),
                           hidden = c(FALSE, TRUE, FALSE, TRUE),
                           fill = FALSE,
                           pointRadius = 2,
                           yAxisID = c("a", "a", "a", "a"),
                           type = c("line", "line", "bar", "bar")), data)
my_y_axis <- yAxes(list(yAxis(id = "a", type = "linear", position = "left", max = NULL, min = NULL, display = TRUE, labelString = "Number of samples collected on farms")))
write_UTF8(timeseries_html("data2", "data2.js", my_y_axis), graph)
file.copy(data, "//webutv/ESS/PRRS/data2.js", overwrite = TRUE)
file.copy(graph, "//webutv/ESS/PRRS/graph_sows.html", overwrite = TRUE)