inst/deploy_scripts/influenza_timeslider.R

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

library(svamap)
library(sp)
##
data(NUTS_20M)
##
##Read in the point data
########################
pts <- read_point_data("//sva.se/UPP/Temp/Falkenrapporter/AI_vilda.csv")
pts@data$Ankomstdatum <- as.Date(pts@data$Ankomstdatum)
pts <- pts[!is.na(pts@data$Aiv313),]
pts@data$Aiv313[pts@data$Aiv313 == "ej p\u00E5visad, ej p\u00E5visad"] <- "ej p\u00E5visad"
## Make sure the unique values in the Aiv313 vector are what we expect
stopifnot(all(pts@data$Aiv313 %in% c("ej p\u00E5visad", "P\u00C5VISAD")))
stopifnot(all(pts@data$Aivh5313 %in% c(NA, "P\u00C5VISAD", "ej p\u00E5visad")))
stopifnot(all(pts@data$Aivh7313 %in% c(NA, "ej p\u00E5visad")))
pts@data$result <- ifelse(pts@data$Aiv313 == "P\u00C5VISAD", 1,
                   ifelse(pts@data$Aiv313 == "ej p\u00E5visad", 0, 2))
pts@data$result <- as.integer(pts@data$result)
pts <- pts[pts@data$Ankomstdatum > "2016/01/01 00:00:00", ]
##drop duplicates
pts <- pts[!duplicated(pts@data$Namn), ]
## drop those positive on 'Matrix' but are negative for H5 and H7
pts <- pts[!(pts@data$result == 1 & !(pts@data$Aivh5313 == "P\u00C5VISAD" | pts@data$Aivh7313 == "P\u00C5VISAD")),]
pts@data$Namn[pts@data$Namn == ""] <- pts@data[, "Ringm\u00E4rkning"][pts@data$Namn == ""]
##View(pts@data[order(pts@data$Ankomstdatum),])
pts@data <- data.frame(species = pts@data$Djurslag,
                       result = pts@data$result,
                       ViltID = pts@data$Namn,
                       Ankomstdatum = pts@data$Ankomstdatum,
                       stringsAsFactors = FALSE)
## Drop if the sample is not yet complete:
pts <- pts[pts$result != 2,]
## sort by påvisade to get the positives plotted last
pts <- pts[order(pts@data$result),]
## Only keep those positives that have been approved to be published:
approved <- readLines("ai_approved_to_publish.txt")
pts <- pts[pts@data$result == 0 | pts@data$ViltID %in% approved, ]
pts@data <- subset(pts@data, select = -c(ViltID))
pts@data$location <- as.numeric(as.factor(paste0(coordinates(pts)[, 1], coordinates(pts)[, 2])))
## Deal with points that land in exactly the same position, deal with
## overlapping points separately in the positives and negatives. This
## is done so that the positives and negatives are always plotted
## separately and that the positives are always plotting on top of the
## negatives.
pos <- pts[pts$result == 1,]
neg <- pts[pts$result == 0,]
neg_un <- do.call("rbind", lapply(unique(neg@data$location), function(x){
    neg[neg@data$location == x,][1,]
}))
for(i in neg_un@data$location){
    temp <- as.data.frame(table(neg[neg@data$location == i,]$Ankomstdatum,
                                neg[neg@data$location == i,]$species)
                          )
    names(temp) <- c("Datum", "Art", "Antal")
    temp <- temp[temp$Antal != 0,]
    neg_un@data$popup_text[neg_un@data$location == i] <- paste0(html_table(temp, fragment = TRUE, file = NULL), collapse = "\n")
    neg_un@data$n[neg_un@data$location == i] <- sum(temp$Antal)
}
pos_un <- do.call("rbind", lapply(unique(pos@data$location), function(x){
    pos[pos@data$location == x,][1,]
}))
for(i in pos_un@data$location){
    temp <- as.data.frame(table(pos[pos@data$location == i,]$Ankomstdatum,
                                pos[pos@data$location == i,]$species)
                          )
    names(temp) <- c("Datum", "Art", "Antal")
    temp <- temp[temp$Antal != 0,]
    pos_un@data$popup_text[pos_un@data$location == i] <- paste0(html_table(temp, fragment = TRUE, file = NULL), collapse = "\n")
    pos_un@data$n[pos_un@data$location == i] <- sum(temp$Antal)
}
##Order the positive second so they get plotted last
pts <- rbind(neg_un, pos_un)
##Calculate the radius of the point
pts@data$radius <- round((pts@data$n*50/3.1415)^0.5, 1)
pts@data <- subset(pts@data, select = c(result, popup_text, radius, Ankomstdatum))
##Write data to geojson
########################
path_to_data <- write_data(pts)
##
## Write out to Umbraco format and POST it:
path_to_data_umbraco <- write_data_umbraco(pts, ID = 1925, apikey = "UMBRACO_KEY")
publish_umbraco(path_to_data_umbraco,
                live = FALSE)

## And to live umbraco
## Write out to Umbraco format and POST it:
path_to_data_umbraco <- write_data_umbraco(pts, ID = 4893, apikey = "UMBRACO_KEY")
(response <- publish_umbraco(path_to_data_umbraco,
                live = TRUE))