Overhaul to move most of the code to plumber.

(Temporarily include code to migrate from mariadb to plumber) Squashed commit of the following: commit ed9a8c0 Author: Conor Anderson <[email protected]> Date: Fri Dec 21 04:22:08 2018 +0000 Update .gitlab-ci.yml and appveyor.yml commit 9f4d8b0 Author: Conor Anderson <[email protected]> Date: Thu Dec 20 18:03:46 2018 -0500 Clean-up and improvements. commit abb1630 Author: Conor Anderson <[email protected]> Date: Thu Dec 20 13:16:30 2018 -0500 Fix missing year arg. commit c391e89 Author: Conor Anderson <[email protected]> Date: Thu Dec 20 13:12:15 2018 -0500 Clean up docker stuff. commit d7a1a3a Author: Conor Anderson <[email protected]> Date: Wed Dec 19 23:32:13 2018 -0500 Add missing import commit 9f768af Author: Conor Anderson <[email protected]> Date: Wed Dec 19 23:00:59 2018 -0500 Move to plumber, part 2 commit 7e7f081 Author: Conor Anderson <[email protected]> Date: Wed Dec 19 22:59:29 2018 -0500 Move to plumber, part 1
ConorIA · Dec 21, 2018 · 84db708 · 84db708
1 parent 273f814
commit 84db708
Show file tree

Hide file tree

Showing 20 changed files with 312 additions and 235 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -8,3 +8,6 @@
 ^README\..*$
 ^LICENSE\.md$
 ^install_senamhiR\.R$
+^plumber$
+^docker-compose.yml$
+^updateip.sh$
diff --git a/.gitignore b/.gitignore
@@ -5,3 +5,4 @@
 .directory
 senamhiR.Rproj
 README.html
+updateip.sh
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
@@ -9,6 +9,6 @@ r-base:
     - apt-get update -qq
     - apt-get install -y --no-install-recommends libmariadbclient-dev libcurl4-openssl-dev libssh2-1-dev libssl-dev libxml2-dev git
     - Rscript -e 'install.packages(c("devtools", "roxygen2", "testthat", "covr"), repos = "https://cran.rstudio.com/")'
-    - Rscript -e 'devtools::install_deps()'
+    - Rscript -e 'devtools::install_deps(dependencies = TRUE)'
     - Rscript -e 'devtools::check()'
     - Rscript -e 'covr::codecov(type = "all", quiet = FALSE)'
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: senamhiR
 Type: Package
 Title: A Collection of Functions to Obtain Peruvian Climate Data
-Version: 0.6.5
-Date: 2018-06-27
+Version: 0.7.0
+Date: 2018-12-20
 Authors@R: c(person(given = c("Conor", "I."), family = "Anderson", 
            role = c("aut","cre"), email = "[email protected]"),
            person(given = c("William", "A."), family = "Gough", role = "ths",
@@ -13,15 +13,15 @@ Description: A collection of functions to obtain archived Peruvian climatologica
 Depends:
     R (>= 3.1.0)
 Imports:
-    DBI,
     dplyr,
     geosphere,
-    leaflet,
-    RMySQL,
+    httr,
+    rlang,
     tibble,
     utils,
     zoo
-Suggests: 
+Suggests:
+    leaflet,
     testthat,
     covr
 License: GPL (>= 3)

diff --git a/NAMESPACE b/NAMESPACE
@@ -7,12 +7,6 @@ export(qc)
 export(quick_audit)
 export(senamhiR)
 export(station_search)
-importFrom(DBI,dbConnect)
-importFrom(DBI,dbDisconnect)
-importFrom(DBI,dbGetQuery)
-importFrom(DBI,dbListTables)
-importFrom(DBI,dbReadTable)
-importFrom(RMySQL,MySQL)
 importFrom(dplyr,"%>%")
 importFrom(dplyr,arrange)
 importFrom(dplyr,bind_rows)
@@ -21,20 +15,14 @@ importFrom(dplyr,mutate)
 importFrom(dplyr,rowwise)
 importFrom(dplyr,select)
 importFrom(geosphere,distGeo)
-importFrom(leaflet,WMSTileOptions)
-importFrom(leaflet,addAwesomeMarkers)
-importFrom(leaflet,addCircleMarkers)
-importFrom(leaflet,addTiles)
-importFrom(leaflet,addWMSTiles)
-importFrom(leaflet,awesomeIcons)
-importFrom(leaflet,leaflet)
-importFrom(leaflet,leafletCRS)
-importFrom(leaflet,leafletOptions)
-importFrom(leaflet,setView)
+importFrom(httr,GET)
+importFrom(httr,POST)
+importFrom(httr,add_headers)
+importFrom(httr,content)
+importFrom(httr,stop_for_status)
+importFrom(rlang,.data)
 importFrom(stats,sd)
 importFrom(tibble,add_column)
-importFrom(tibble,as_tibble)
-importFrom(tibble,has_name)
 importFrom(tibble,tibble)
 importFrom(utils,glob2rx)
 importFrom(zoo,as.yearmon)
diff --git a/R/download_data.R b/R/download_data.R
@@ -1,6 +1,6 @@
-##' @title Access data from the Peruvian National Hydrological and Meterological Service via MySQL
+##' @title Access data from the Peruvian National Hydrological and Meterological Service via API
 ##'
-##' @description Download Peruvian historical climate data from the Senamhi via a MySQL archive.
+##' @description Download archived Peruvian historical climate data from the Senamhi via an independent API.
 ##'
 ##' @param station character; the station id number to process.
 ##' @param year numeric; an ordered vector of years to retrieve.
@@ -9,47 +9,18 @@
 ##'
 ##' @author Conor I. Anderson
 ##' 
-##' @importFrom DBI dbConnect dbDisconnect dbGetQuery dbListTables dbReadTable
-##' @importFrom RMySQL MySQL
-##' @importFrom tibble as_tibble
+##' @importFrom httr add_headers content POST stop_for_status
 ##'
 ##' @export
 ##' 
 ##' @examples
 ##' \dontrun{download_data('000401')}
 
-download_data <- function(station, year) {
-
-  catalogue <- .get_catalogue()
-
-  if (nchar(station) < 6) {
-    station <- suppressWarnings(try(sprintf("%06d", as.numeric(station)), silent = TRUE))
-    if (inherits(station, "try-error") | !station %in% catalogue$StationID) {
-      stop("Station ID appears invalid.")
-    }
-  }
-
-  station_data <- catalogue[catalogue$StationID == station, ]
-  type = station_data$Type
-  config = station_data$Configuration
 
-  conn <- dbConnect(MySQL(), user = "anonymous", host = "pcd.conr.ca", dbname = "pcd")
-  on.exit(dbDisconnect(conn))
-
-  sql_table <- paste0("ID_", station)
-  if (sum(dbListTables(conn) %in% sql_table) != 1) {
-    dbDisconnect(conn)
-    stop("There was an error getting that table.")
-  }
-
-  if (missing(year) || is.null(year)) {
-    dat <- as_tibble(dbReadTable(conn, sql_table, row.names = NULL))
-  } else {
-    start <- min(year)
-    end <- max(year)
-    dat <- as_tibble(dbGetQuery(conn, paste0("SELECT * FROM ", sql_table, " WHERE Fecha BETWEEN \"", start, "-01-01\" AND \"", end, "-12-31\";")))
-  }
-  dat <- .clean_table(dat, config, type, clean_names = TRUE, fix_types = TRUE)
-
-  dat
+download_data <- function(station, year = NULL) {
+  r <- POST("https://api.conr.ca/pcd/get", 
+            body = list(station = station, year = year), encode = "json",
+            config = list(add_headers(accept = "application/octet-stream")))
+  stop_for_status(r)
+  unserialize(content(r))
 }
diff --git a/R/fix_bad_data.R b/R/fix_bad_data.R
@@ -2,9 +2,10 @@
   # First, let's see where this is happening.
   yearmon <- as.yearmon(bad_table$Fecha[bad_row])
   # Let's look at all months other than the bad month
-  context <- filter(bad_table, !as.yearmon(Fecha) == yearmon & format(Fecha, format = "%m") == format(yearmon, format = "%m"))
+  context <- filter(bad_table, !as.yearmon(.data$Fecha) == yearmon &
+                      format(.data$Fecha, format = "%m") == format(yearmon, format = "%m"))
   # Let's make sure we don't have other bad data
-  context <- filter(context, var > -50 & var < 50)
+  context <- filter(context, .data$var > -50 & .data$var < 50)
   context <- unlist(context$var)
   # We should now have *fairly* clean context
   bad_data <- unlist(bad_table$var[bad_row])

diff --git a/R/get_catalogue.R b/R/get_catalogue.R
@@ -2,24 +2,15 @@
 #'
 #' @return tbl_df
 #' 
-#' @importFrom DBI dbConnect dbDisconnect dbReadTable
-#' @importFrom RMySQL MySQL
-#' @importFrom tibble as_tibble
+#' @importFrom httr content GET stop_for_status
 #' 
 #' @keywords internal
 #'
 #' @author Conor I. Anderson
 
 .get_catalogue <- function() {
-  conn <- dbConnect(MySQL(), user = "anonymous", host = "pcd.conr.ca", dbname = "pcd")
-  on.exit(dbDisconnect(conn))
-  cat <- try(as_tibble(dbReadTable(conn, "catalogue", row.names = NULL)))
-  if (inherits(cat, "try-error")) {
-    warning(paste("We couldn't download the catalogue.",
-                  "These results might be slightly outdated."))
-    return(catalogue)
-  } else {
-    names(cat) <- names(catalogue)
-    cat
-  }
+  r <- GET("https://api.conr.ca/pcd/catalogue", 
+           config = list(add_headers(accept = "application/octet-stream")))
+  stop_for_status(r)
+  unserialize(content(r))
 }
diff --git a/R/map_stations.R b/R/map_stations.R
@@ -6,7 +6,7 @@
 ##' @param type character; either "osm" for OpenStreetMap tiles, or "sentinel" for cloudless satellite by EOX IT Services GmbH (\url{https://s2maps.eu}).
 ##' 
 ##' @importFrom dplyr "%>%" filter
-##' @importFrom leaflet addAwesomeMarkers addCircleMarkers addTiles addWMSTiles awesomeIcons leaflet leafletCRS leafletOptions setView WMSTileOptions
+##' @importFrom rlang .data
 ##' 
 ##' @export
 ##'
@@ -20,6 +20,11 @@
 
 map_stations <- function(station, type = "osm") {
 
+  if (!requireNamespace("leaflet", quietly = TRUE)) {
+    stop("The \"leaflet\" packge is required to create maps. Please install it.",
+         call. = FALSE)
+  }
+
   catalogue <- .get_catalogue()
 
   if (!inherits(station, "data.frame")) {
@@ -33,10 +38,10 @@ map_stations <- function(station, type = "osm") {
       stop("One or more requested stations invalid.")
     }
 
-    station <- filter(catalogue, StationID %in% station)
+    station <- filter(catalogue, .data$StationID %in% station)
   }
 
-  icons <- awesomeIcons(
+  icons <- leaflet::awesomeIcons(
     icon = unname(sapply(station$Configuration, function(x) {
       if (x %in% c("M", "M1", "M2")) "thermometer" else "waterdrop"
     })),
@@ -48,22 +53,23 @@ map_stations <- function(station, type = "osm") {
   )
 
   map <- if (type == "sentinel") {
-    leaflet(station, options = leafletOptions(crs = leafletCRS("L.CRS.EPSG4326"))) %>%
-      addWMSTiles(
+    leaflet::leaflet(station, options = leaflet::leafletOptions(
+      crs = leaflet::leafletCRS("L.CRS.EPSG4326"))) %>%
+      leaflet::addWMSTiles(
         "https://tiles.maps.eox.at/wms?service=wms",
         layers = "s2cloudless",
-        options = WMSTileOptions(format = "image/jpeg"),
+        options = leaflet::WMSTileOptions(format = "image/jpeg"),
         attribution = paste("Sentinel-2 cloudless - https://s2maps.eu by EOX",
                             "IT Services GmbH (Contains modified Copernicus",
                             "Sentinel data 2016 & 2017)")
       )
   } else {
     if (type != "osm") warning("Unrecognized map type. Defaulting to osm.")
-    leaflet(station) %>% addTiles()
+    leaflet::leaflet(station) %>% leaflet::addTiles()
   }
 
   map <- map %>%
-    addAwesomeMarkers(~Longitude, ~Latitude, icon = icons,
+    leaflet::addAwesomeMarkers(~Longitude, ~Latitude, icon = icons,
                       label = paste0(station$StationID, " - ",
                                      station$Station, 
                                      " (", station$Configuration, ")",
@@ -73,7 +79,7 @@ map_stations <- function(station, type = "osm") {
   # Add a target if it exists
   target <- c(attr(station, "target_lon"), attr(station, "target_lat"))
   if (!is.null(target)) {
-    map <- map %>% addCircleMarkers(lng = target[1], lat = target[2],
+    map <- map %>% leaflet::addCircleMarkers(lng = target[1], lat = target[2],
                                     color = "red", label = paste0("Target: ",
                                                                   target[2],
                                                                   ", ",

diff --git a/R/qc.R b/R/qc.R
@@ -9,6 +9,7 @@
 ##' 
 ##' @importFrom dplyr select filter
 ##' @importFrom tibble add_column
+##' @importFrom rlang .data
 ##' @importFrom stats sd
 ##' 
 ##' @export
@@ -24,7 +25,7 @@ qc <- function(dat) {
     if (length(dat) > 1L) {
       stop("Sorry, for now this script can only process one station at a time.")
     } else {
-      dat <- try(read_data(dat))
+      dat <- download_data(dat)
     }
   }
 
@@ -33,7 +34,7 @@ qc <- function(dat) {
   }
 
   if (grepl("Observations", colnames(dat)[15])) {
-    observations <- select(dat, 15) %>% unlist
+    observations <- select(dat, 15) %>% unlist()
   } else {
     observations <- rep(NA, nrow(dat))
   }
@@ -44,7 +45,7 @@ qc <- function(dat) {
 
   if (length(maxshifts) > 0) {
     for (i in 1:length(maxshifts)) {
-      bad_table <- select(dat, Fecha, var = `Tmax (C)`)
+      bad_table <- select(dat, .data$Fecha, var = "Tmax (C)")
       fixes <- .fix_bad_data(bad_table, maxshifts[i], "Tmax", "dps")
       dat$`Tmax (C)`[maxshifts[i]] <- unlist(fixes[1])
       existingobs <- if (!is.na(observations[maxshifts[i]]) && observations[maxshifts[i]] != '') paste(observations[maxshifts[i]], ifelse((unlist(fixes[2]) != ''), "/ ", "")) else ""
@@ -54,7 +55,7 @@ qc <- function(dat) {
 
   if (length(minshifts) > 0) {
     for (i in 1:length(minshifts)) {
-      bad_table <- select(dat, Fecha, var = `Tmin (C)`)
+      bad_table <- select(dat, .data$Fecha, var = "Tmin (C)")
       fixes <- .fix_bad_data(bad_table, minshifts[i], "Tmin", "dps")
       dat$`Tmin (C)`[minshifts[i]] <- unlist(fixes[1])
       existingobs <- if (!is.na(observations[minshifts[i]]) && observations[minshifts[i]] != '') paste(observations[minshifts[i]], ifelse((unlist(fixes[2]) != ''), "/ ", "")) else ""
@@ -68,14 +69,14 @@ qc <- function(dat) {
     for (i in 1:length(minmaxerr)) {
 
       # First check Tmax
-      bad_table <- select(dat, Fecha, var = `Tmax (C)`)
+      bad_table <- select(dat, .data$Fecha, var = "Tmax (C)")
       fixes <- .fix_bad_data(bad_table, minmaxerr[i], "Tmax", "mme")
       dat$`Tmax (C)`[minmaxerr[i]] <- unlist(fixes[1])
       existingobs <- if (!is.na(observations[minmaxerr[i]]) && observations[minmaxerr[i]] != '') paste(observations[minmaxerr[i]], ifelse((unlist(fixes[2]) != ''), "/ ", "")) else ""
       observations[minmaxerr[i]] <- paste0(existingobs, unlist(fixes[2]))
 
       # Repeat the same for Tmin
-      bad_table <- select(dat, Fecha, var = `Tmin (C)`)
+      bad_table <- select(dat, .data$Fecha, var = "Tmin (C)")
       fixes <- .fix_bad_data(bad_table, minmaxerr[i], "Tmin", "mme")
       dat$`Tmin (C)`[minmaxerr[i]] <- unlist(fixes[1])
       existingobs <- if (!is.na(observations[minmaxerr[i]]) && observations[minmaxerr[i]] != '') paste(observations[minmaxerr[i]], ifelse((unlist(fixes[2]) != ''), "/ ", "")) else ""

diff --git a/R/senamhiR.R b/R/senamhiR.R
@@ -36,6 +36,7 @@ senamhiR <- function(station, year, collapse = FALSE) {
   }
 
   pull_data <- function(stn, year) {
+
     rtn <- download_data(stn, year)
     attributes(rtn) <- append(attributes(rtn), catalogue[catalogue$StationID == stn,])
     rownames(rtn) <- NULL