R/data.R

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

##' Read in point data and clean it
##'
##' @title read_point_data
##'
##' This function reads in data from SVA's database on CWD
##' submittions. The default is to read in a fake dataset that has the
##' same strucuture.
##'
##' @return A SpatialPointsDataframe
##' @author Thomas Rosendal
##' @import utils
##' @import sp
##' @import rgdal
##' @importFrom stats complete.cases
##' @export
##' @param path Path to file
##' @param encoding Encoding of the text file
##' @param proj4str projection of points in file
##' @param output_proj the projection of the returned dataframe (default WGS84)
##' @param long text string of the variable name that is longitude
##' @param lat text string of the variable name that is latitude
read_point_data <- function(path = system.file("sample_data_cwd.csv",
                                               package = "svamap"),
                            encoding = "UTF-8",
                            proj4str = RT90(),
                            output_proj = WGS84(),
                            long = "Gisy",
                            lat = "Gisx") {
    df <- read.csv2(path,
                    header = TRUE,
                    stringsAsFactors = FALSE,
                    encoding = encoding,
                    na.strings = "")

    ## Convert coords to numeric
    df[, long] <- as.numeric(df[, long])
    df[, lat]  <- as.numeric(df[, lat])

    ## Drop those without coords
    missing_coords <- length(which(!complete.cases(df[, c(long, lat)])))
    if(missing_coords > 0){
        warning(paste(missing_coords, "of the submitted points are missing coordinates"))
    }

    ## Convert to spatial
    df <- df[complete.cases(df[,c(long, lat)]),]
    pts <- SpatialPoints(cbind(df[, long], df[, lat]))
    proj4string(pts) <- proj4str
    pts <- spTransform(pts, CRSobj = output_proj)
    pts <- SpatialPointsDataFrame(pts, df)
    return(pts)
}

##' Write a geojson file from a dataset
##'
##' @title write_data
##' @import rgeos
##' @export
##' @param object A list of spatial polygon or point dataframes list may be of length 1
##' @param varname The name of the variable to be given to the geojson oject in javascript.
##' @param file The path to where the geojson will be written
##' @return path to the file
##' @author Thomas Rosendal
write_data <- function(object,
                       varname = "data",
                       file = tempfile()) {
    stopifnot(all(class(object) %in% c("list",
                                   "SpatialPointsDataFrame",
                                   "SpatialLinesDataFrame",
                                   "SpatialPolygonsDataFrame"))
              )
    if(class(object) != "list") {
        object <- list(object)
    }
    time <- paste0("timestamp = \"", as.character(Sys.time()), "\"")
    js <- do.call('c', lapply(seq_len(length(object)), function(x){
        innerfile <- tempfile()
        writeOGR(object[[x]],
                 innerfile,
                 layer = "main",
                 driver = "GeoJSON",
                 check_exists = FALSE)
        geojson <- readLines(innerfile, encoding = "UTF-8")
        js <- c(paste0(varname,x), " = ", geojson)
    }))
    js <- c(time, js)
    write_UTF8(js, file)
    return(file)
}
##' write_data_umbraco
##'
##' @title write_data_umbraco
##' @export
##' @import rgeos
##' @param object A list of spatial polygon or point dataframes list may be of length 1
##' @param file The path to where the geojson will be written
##' @param ID The ID of the page in umbraco
##' @param apikey The name of an environment variable storing the apikey.
##' If NULL, will look for file .sva_umbraco_credentials in home directory
##' @param update The update date
##' @param startdate The stat date for the time slider
##' @param enddate The end date for the timeslider
##' @return A path
write_data_umbraco <- function(object,
                               file = tempfile(),
                               ID = 999,
                               apikey = NULL,
                               update = as.character(Sys.time()),
                               startdate = Sys.Date() - 180,
                               enddate = Sys.Date()) {

    stopifnot(all(class(object) %in% c("list",
                                       "SpatialPointsDataFrame",
                                       "SpatialLinesDataFrame",
                                       "SpatialPolygonsDataFrame")))

    apikey <- get_umbraco_key(apikey)

    if(class(object) != "list") {
        object <- list(object)
    }
    time <- paste0("timestamp = \"", as.character(Sys.time()), "\"")
    js <- lapply(seq_len(length(object)), function(x) {
        innerfile <- tempfile()
        writeOGR(object[[x]],
                 innerfile,
                 layer = "main",
                 driver = "GeoJSON",
                 check_exists = FALSE)
        geojson <- readLines(innerfile, encoding = "UTF-8")
        paste(geojson, collapse = "\n")
    })
    ## browser()
    updatedDate <- paste0('"updatedDate": "', update, '"')
    startDates <- paste0('"startDates": {\n"start": "',
                         startdate, '",\n"end": "',
                         enddate, '"\n}')
    js <- paste0('"data":[\n',
                 paste(js, collapse = ",\n"),
                 "\n]")
    ID <- paste0('"id": ', ID)
    key <- paste0('"apiKey": "', apikey, '"')
    js <- paste0("{\n",
                 paste(list(updatedDate, startDates, js, ID, key),
                       collapse = ", \n"),
                 "\n}")
    write_UTF8(js, file)
    print(update)
    return(file)
}

##' publish map JSON data to web location via an HTTP POST request
##'
##' @title deploy_mapdata
##' @export
##' @param data path to data. Must be in JSON format
##' @param url address to make the POST request to. Default is map data folder on SVA Umbraco server
##' @param verbose Print full responese output (including a copy of the published data)? Default is TRUE
##' @return list of POST request server response data
##' @importFrom httr POST
##' @importFrom httr upload_file
##' @author Wiktor Gustafsson
deploy_mapdata <- function(data,
                           url = "https://kxs-sva.s1.umbraco.io/umbraco/api/mapimport/savemapdata",
                           verbose = TRUE) {
    stopifnot(file.exists(data), grepl("\\.json$", basename(data)))

    if (verbose) {
        POST(url = url,
             body = upload_file(data,
                                type = "application/json"),
             verbose())
    }
    else {
        POST(url = url,
             body = upload_file(data,
                                type = "application/json"))
    }
}

##' write a webpage
##'
##' Copy the files to a direcetory
##' @title write_page
##' @export
##' @param data path to data
##' @param path path to new webpage does not end in a "/"
##' @param ftp NULL if you want to you a path to a directory,
##'     otherwise specify the ftp server with credentials like:
##'     "ftp://User:Password@servername/Destination". This is the
##'     directory on the ftp server that the files will be placed. It
##'     must end in a '/' and will be expanded when called by
##'     curl_upload in the curl library.
##' @param template the name of the map template. This is a .html file
##'     in the inst directory of svamap
##' @param owntemplate path to you own template. This would include
##'     everything your map needs but the data including the assets,
##'     like .css, .js and .png files
##' @param overwrite Do you want to overwrite files in the destination
##'     directory?
##' @param browse Pop the browser and view the page?
##' @return The path to the map or NULL if ftp
##' @importFrom curl curl_upload
##' @author Thomas Rosendal
write_page <- function(data,
                       path = tempdir(),
                       ftp = NULL,
                       template = "CWD/map.html",
                       owntemplate = NULL,
                       overwrite = FALSE,
                       browse = TRUE) {
    if(is.null(owntemplate)) {
        mapfile <- system.file(template, package = "svamap")
        assets <- system.file(file.path("assets", assets(readLines(mapfile))), package = "svamap")
        from <- c(mapfile, assets)
    } else {
        mapfile <- owntemplate
        assets <- system.file(file.path("assets", assets(readLines(mapfile))), package = "svamap")
        from <- c(mapfile, assets)
    }
    if(is.null(ftp)) {
        pathmap <- file.path(path, "map")
        dir.create(pathmap, showWarnings = FALSE)
        file.copy(from = data,
                  to = file.path(pathmap,"data.js"),
                  overwrite = overwrite)
        file.copy(from = from,
                  to = pathmap,
                  overwrite = overwrite,
                  recursive = FALSE)
        if(browse) {
            browseURL(paste0("file://", file.path(pathmap, "map.html")))
        }
        return(path)
    } else {
        curl_upload(data, paste0(ftp, "data.js"))
        for (i in from) {
            curl_upload(i, paste0(ftp, basename(i)))
        }
    }
    return(NULL)
}

##' Assets
##'
##' @title assets
##' @param l the lines of an html file
##' @return a vector of the css, js and png files called locally in the file
##' @author Thomas Rosendal
##' @export
assets <- function(l) {

    ## Get the js source files that are needed except those that are read remotely
    ## And not the file named data.js because that is added separately
    l1 <- l[grep("[[:space:]]*<script[[:space:]]src=", l)]
    l1 <- gsub("[[:space:]]*<script[[:space:]]src=\"([^\"]*).*$", "\\1", l1)
    l1 <- l1[!grepl("http", l1)]
    l1 <- l1[!grepl("data.js", l1)]

    ## Get the css files that are needed except those that are read remotely
    l2 <- l[grep("[[:space:]]*<link[[:space:]]rel=\"stylesheet\"[[:space:]]href=", l)]
    l2 <- gsub("[[:space:]]*<link[[:space:]]rel=\"stylesheet\"[[:space:]]href=\"([^\"]*).*$", "\\1", l2)
    l2 <- l2[!grepl("http", l2)]

    ## Check for any needed png file (icons)
    l3 <- l[grep("src[[:space:]]?=[[:space:]]?.*[.]png", l)]
    l3 <- gsub(".*src[[:space:]]?=[[:space:]]?\"(.*[.]png).*$", "\\1", l3)
    l3 <- l3[!grepl("http", l3)]

    return(c(l1, l2, l3))
}

##' Write a file with UTF-8 encoding
##'
##' @title write_UTF8
##' @param x a character vector to write to file
##' @param file a path where to write the file
##' @param bom include the byte order mark?
##' @author Wiktor Gustafsson
##' @export
write_UTF8 <- function(x, file, bom = F) {
    x <- enc2utf8(paste0(x, "\n", collapse = ""))
    con <- file(file, "wb")
    if (isTRUE(bom)) {
        BOM <- charToRaw('\xEF\xBB\xBF')
        writeBin(BOM, con, endian = "little")
    }
    writeBin(charToRaw(x), con, endian = "little")
    close(con)
}

##' Retrieve Umbraco API credential key
##'
##' @title get_umbraco_key
##' @param name name of an environment variable that contains key.
##' If NULL, will look for file .sva_umbraco_api_credentials in home
##' directory instead
##' @return the API key
##' @author Wiktor Gustafsson
get_umbraco_key <- function(name = NULL) {
    if (is.null(name)) {
        if (file.exists("~/.sva_umbraco_api_credentials"))
            readLines("~/.sva_umbraco_api_credentials")
        else
            stop("No umbraco credential found")
    } else {
        env <- Sys.getenv(name)
        if (env == "")
            stop("No umbraco credential found")
        env
    }
}

##' PUblish map to Umbraco using POST request
##'
##' @title publish_umbraco
##' @param data path to the data to publish
##' @param live post to live Umbraco server? FALSE == dev
##' @author Wiktor Gustafsson
##' @export
##' @importFrom httr POST content_type upload_file
publish_umbraco <- function(data, live = FALSE) {
    stopifnot(file.exists(data))

    url <- ifelse(isTRUE(live),
                  "https://kxs-sva.s1.umbraco.io/umbraco/api/mapimport/savemapdata",
                  "https://dev-kxs-sva.s1.umbraco.io/umbraco/api/mapimport/savemapdata")

    POST(
        url,
        content_type("application/json"),
        body = upload_file(data)
    )
}