fix: Fixed one bug + vignettes

.Rbuildignore

@@ -2,3 +2,10 @@
 ^Makefile$
 ^_pkgdown.yml$
 ^docs$
+^contact.md
+^pkgdown
+^test.R
+
+^vignettes/datasets.Rmd
+^vignettes/metadata.Rmd
+^vignettes/stationdata.Rmd

DESCRIPTION

@@ -1,15 +1,17 @@
 Package: gsdata
 Type: Package
-Title: Accessing Data from Geosphere Austria
-Version: 0.0-6
-Date: 2023-08-03
+Title: Interface to the GeoSphere Austria DataHub API (Data Access)
+Version: 0.0-7
+Date: 2024-01-23
 Authors@R: 
     person(given = "Reto", family = "Stauffer", role = c("cre", "aut"),
          email = "[email protected]",
          comment = c(ORCID = "0000-0002-3798-5507"))
 Maintainer: Reto Stauffer <[email protected]>
 Depends: httr, zoo, sf, parsedate
-Description: Package to download data from the Geosphere data hub (formerly known as ZAMG; Austrian National Weather Service).  Currently solely allows to download station data (no gridded data). More details about the data sets can be found on <https://data.hub.zamg.ac.at/> as well as in the API documentation available via <https://dataset.api.hub.zamg.ac.at/v1/docs/?anonymous=true>.
-License: GPL-2 | GPL-3
+Suggests: utils, ncdf4, stars, knitr, rmarkdown, tinytest
+Description: Package to download data from the Geosphere data hub (Austrian National Weather Service) which is the data provider. Currently solely allows to download station data (no gridded data). More details about the data sets can be found on <https://data.hub.zamg.ac.at/> as well as in the API documentation available via <https://dataset.api.hub.zamg.ac.at/v1/docs/?anonymous=true>.
+License: GPL-2
+VignetteBuilder: knitr
 RoxygenNote: 7.2.3
 Roxygen: list(markdown = TRUE)

Makefile

@@ -12,10 +12,14 @@ document:
 docs:
 	Rscript -e "pkgdown::build_site()"
 
+.PHONY: vignettes
+vignettes:
+	Rscript -e "devtools::build_vignettes()"
+
 install: document
 	Rscript -e "devtools::install()"
 
-check: document
+devcheck: document
 	Rscript -e "devtools::check()"
 
 test: install
@@ -26,3 +30,14 @@ testwarn: install
 coverage: install
 	Rscript -e 'covr::report(covr::package_coverage(), file = "../coverage.html")'
 
+# ---------------------------------------------------
+# R CMD build and check (--as-cran)
+# ---------------------------------------------------
+packageversion:=$(shell cat DESCRIPTION | egrep Version | sed 's/Version://g')
+
+build: document
+	cd ../ && \
+	R CMD build --no-build-vignettes gsdata
+check: build
+	cd ../ && \
+	R CMD check --as-cran gsdata_$(shell printf "%s"${packageversion}).tar.gz

NAMESPACE

@@ -8,12 +8,14 @@ export(gs_stationdata)
 export(gs_temporal_interval)
 importFrom(httr,GET)
 importFrom(httr,content)
+importFrom(httr,http_status)
 importFrom(httr,status_code)
 importFrom(parsedate,parse_iso_8601)
 importFrom(sf,st_as_sf)
 importFrom(sf,st_point)
 importFrom(utils,head)
 importFrom(utils,tail)
+importFrom(zoo,coredata)
 importFrom(zoo,index)
 importFrom(zoo,plot.zoo)
 importFrom(zoo,zoo)

R/datasets.R

@@ -37,14 +37,16 @@
 #'
 #' Can be combined (settinb both \code{type} and \code{mode}).
 #'
-#' @importFrom httr GET content status_code
 #' @author Reto Stauffer
 #' @export
 gs_datasets <- function(type = "station", mode = NULL, version = 1L, config = list(), verbose = FALSE) {
-    stopifnot("argument 'verbose' must be logical TRUE or FALSE" = isTRUE(verbose) || isFALSE(verbose))
+    stopifnot("argument 'verbose' must be logical TRUE or FALSE" =
+              isTRUE(verbose) || isFALSE(verbose))
     stopifnot("argument 'config' must be a (named) list" = is.list(config))
-    stopifnot("argument 'type' must be NULL or a character string" = is.null(type) || (is.character(type) & length(type) == 1L))
-    stopifnot("argument 'mode' must be NULL or a character string" = is.null(mode) || (is.character(mode) & length(mode) == 1L))
+    stopifnot("argument 'type' must be NULL or a character string" =
+              is.null(type) || (is.character(type) & length(type) == 1L))
+    stopifnot("argument 'mode' must be NULL or a character string" =
+              is.null(mode) || (is.character(mode) & length(mode) == 1L))
 
     # Parsing 'query' arguments (if any)
     # Get base URL; performs version sanity check
@@ -54,41 +56,26 @@ gs_datasets <- function(type = "station", mode = NULL, version = 1L, config = li
     # Query args
     query <- list(); query$type <- type; query$mode <- mode
 
-    # Verbosity
-    if (verbose)
-        message(sprintf("Calling: %s%s%s", URL,
-                        if (!length(query)) "" else "?",
-                        if (!length(query)) "" else paste(paste(names(query), query, sep = "="), collapse = "&")))
-
-    # Requesting data
-    req  <- GET(URL, config = config, query = query)
-    if (!status_code(req) == 200) {
-        tmp <- try(content(req))
-        if (is.list(tmp) && !is.null(tmp$detail[[1]]$msg)) {
-            stop(tmp$detail[[1]]$msg)
-        } else {
-            stop("HTTP request error: got status code", status_code(req))
-        }
-    }
-    content <- content(req)
-    keys    <- unique(unlist(lapply(content, names)))
+    # Calling API
+    res  <- API_GET(URL, config = config, query = query, verbose = verbose)
+    keys <- unique(unlist(lapply(res, names)))
 
     # Splitting up the path to get the information
-    tmp <- strsplit(sub("^\\/", "", names(content)), "/")
+    tmp <- strsplit(sub("^\\/", "", names(res)), "/")
     if (!all(sapply(tmp, length)))
         stop("problems decoding the path argument (expected three-part-path)")
 
     # Else setting up results data.frame
-    res <- data.frame(type = sapply(tmp, function(x) x[1]),
-                      mode = sapply(tmp, function(x) x[2]),
-                      resource_id = sapply(tmp, function(x) x[3]))
+    rval <- data.frame(type        = sapply(tmp, function(x) x[1]),
+                       mode        = sapply(tmp, function(x) x[2]),
+                       resource_id = sapply(tmp, function(x) x[3]))
 
     fn <- function(x, k) if (is.character(x[[k]])) x[[k]] else paste(x[[k]], collapse = "|")
     for (k in keys) {
         kn <- if (k == "type") "data_format" else k # New name to not overwrite 'type'
-        res[[kn]] <- unname(sapply(content, fn, k = k))
+        rval[[kn]] <- unname(sapply(res, fn, k = k))
     }
 
     # Return data.frame
-    return(res)
+    return(rval)
 }

R/gsdata.R

@@ -0,0 +1,66 @@
+
+#' \code{gsdata}: Interface to the GeoSphere Austria DataHub API (Data Access)
+#'
+#' This package allows convenient access to data provided by GeoSphere Austria
+#' (Austrias federal agency for geology, geophysics, climatology and
+#' meteorology) via their data API which exists since around mid 2023.
+#'
+#' The API not only provides access to station data (the one thing currently
+#' covered by this package; will be extended) but also access to spatial
+#' data; a catalogue which has been extended over and over again over the past
+#' 10 months. Details about all available data sets and their temporal and
+#' spatial extent can be found on their website:
+#'
+#' \itemize{
+#'    \item <https://data.hub.geosphere.at/>
+#' }
+#'
+#' @section Data request limit:
+#'
+#' The API has a request limit; a limit to how much data one is allowed
+#' to retrieve in one API request. Details on the current limit can be found
+#' in the [GeoSphere Dataset API Documentation](https://dataset.api.hub.geosphere.at/v1/docs/user-guide/request_size_limit.html).
+#'
+#' This package internally tries to estimate the request size and split the
+#' request into multiple batches in case one single request would (likely)
+#' exceed these limits.
+#'
+#' Thus, one single call to e.g., \code{gs_stationdata()} can trigger multiple
+#' API calls. If used without `expert = TRUE` two initial calls are made to
+#' check if the data set requested does exist, and that the
+#' stations and parameters requested exist in this data set. If the data request
+#' needs to be split in addition, this can cause a series of calls to the API
+#' which also has a limit on number of requests per time.
+#'
+#' In the worst case this causes a temporary ban (timeout due to too many requests)
+#' from the servers. One way around is to limit the number of requests per time,
+#' more details about this in the next section.
+#'
+#'
+#' @section Cooldown time/limiting number of requests per time:
+#'
+#'
+#' Note that each function call can result in multiple API requests which can
+#' lead to a timeout (too many requests). To avoid running into timeout issues:
+#'
+#' \itemize{
+#'      \item use \code{expert = TURUE} where possible as it
+#'            lowers the number of calls to the api.
+#'      \item request data for multiple stations at once, especially
+#'            when requesting short time periods/few parameters as, in the best case,
+#'            all data can be retrieved on one single call (if below estimated
+#'            data request limit).
+#'      \item wait between requests using e.g., \code{Sys.sleep(...)}.
+#'      \item or use the packages own 'cooldown' option. By default,
+#'            a cooldown time of \code{0.1} seconds is used (the minimum
+#'            time between two requests. You can set a custom cooldown time
+#'            via \code{options('gsdata.cooldown' = 1)}. Will overwrite the
+#'            default and ensure that there will be at least one second
+#'            between consecutive API calls. If you have no time critical
+#'            requests this is a good way to be nice to the data provider!
+#' }
+#'
+#' @docType package
+#' @name gsdata
+"_PACKAGE"
+

R/helperfunctions.R

@@ -75,3 +75,128 @@ gs_temporal_interval <- function(resource_id) {
     return(res)
 }
 
+
+
+
+#' Show HTTP Error Status and Terminate
+#'
+#' This function is called whenever \code{httr::GET} returns an
+#' http status code out of the \code{200} range (success).
+#' Shows \code{\link[http]{http_status()}} code information alongside
+#' with additional messages returned by the API (if any).
+#'
+#' @param scode numeric, http status code.
+#' @param xtra \code{NULL} or named list with additional information.
+#'
+#' @return No return, will terminate R.
+#'
+#' @author Reto Stauffer
+# Show http_status message if possible.
+show_http_status_and_terminate <- function(scode, xtra = NULL) {
+
+    stopifnot(is.numeric(scode), length(scode) == 1)
+    if (scode %/% 100 == 2) return(NULL)
+    cat('---\n')
+
+    info <- tryCatch(http_status(scode),
+                     error = function(x) NULL)
+
+    # Depending on the status code these are somewhat redundant
+    if (!is.null(xtra))
+        xtra <- paste(c("  status returned by API:",
+                      sprintf("    %-20s %s", sprintf("%s:", names(xtra)), xtra)),
+                      collapse = "\n")
+    if (!is.null(info))
+        info <- paste(c("  http_status description:",
+                      sprintf("    %-20s %s", sprintf("%s:", names(info)), info)),
+                      collapse = "\n")
+
+    if (is.null(info) & is.null(xtra)) {
+        stop("HTTP request error: server returned status code ", scode)
+    } else {
+        stop(paste("HTTP request error", xtra, info, sep = "\n"))
+    }
+}
+
+#' Handling API Calls
+#' 
+#' Small helper function to handle http requests to the API.
+#'
+#' @param URL the URL to be called.
+#' @param config \code{NULL} or \code{list}, forwarded to \code{httr::GET}.
+#' @param query \code{NULL} or \code{list}, forwarded to \code{httr::GET}.
+#' @param expected_class \code{NULL} or character vector. If set, it is checked
+#'        if the returned object is of this class. If not, a warning will be thrown
+#'        (no error).
+#' @param verbose logical, shows some additional information if \code{TRUE}.
+#'
+#' @return Returns the object we get from \code{httr::content()} after a successful
+#' API call. If an error is detected, an error with additional details will be displayed.
+#'
+#' @importFrom httr GET status_code content http_status
+#' @author Reto Stauffer
+API_GET <- function(URL, config = NULL, query = NULL,
+                    expected_class = NULL, verbose = FALSE) {
+    # Checking URL
+    URL <- as.character(URL)[[1]]                    
+    stopifnot("argument `URL` is invalid" =
+              grepl("^https:\\/\\/dataset.api.hub.geosphere.at", URL))
+
+    stopifnot("argument `config` must be NULL or a list" =
+              is.null(config) || is.list(config))
+    stopifnot("argument `query` must be NULL or a list" =
+              is.null(query) || is.list(query))
+    stopifnot("argument `expected` must be NULL or character" =
+              is.null(expected_class) || is.character(expected_class))
+    stopifnot("argument `verbose` must be logical TRUE or FALSE" =
+              isTRUE(verbose) || isFALSE(verbose))
+
+
+    # Checking and executing cooldown
+    gsdata_lastcall <- getOption("gsdata.lastcall", default = Sys.time() - 1); # 1s ago
+    gsdata_cooldown <- getOption("gsdata.cooldown", default = .1) # cooldown in secs
+    # Ensure positive numeric, if there is an error or any warning we reset to default .1
+    gsdata_cooldown <- tryCatch(max(0, as.numeric(gsdata_cooldown)),
+                                warning = function(x) .1,
+                                error = function(x) .1)
+    sleep_time <- gsdata_cooldown - as.numeric(Sys.time() - gsdata_lastcall, units = "secs")
+    if (sleep_time > 0.1) {
+        if (verbose) message(sprintf("Cooldown, waiting for %.3f seconds", sleep_time))
+        Sys.sleep(sleep_time)
+    }
+
+
+    if (verbose) {
+        msgq <- if (is.list(query)) {
+            paste0("?", paste(paste(names(query), query, sep = "="), collapse = "&"))
+        } else { "" }
+        message(sprintf("Calling: %s%s", URL, msgq))
+    }
+
+    # Requesting data
+    req  <- GET(URL, config = config, query = query)
+    options("gsdata.lastcall" = Sys.time()) # Updating last call
+
+    if (!status_code(req) %/% 100 == 2) {
+        # Trying to read the response and see if the API answered
+        # with an error message (error details). If so, that will be
+        # shown, else a more generic error will be displayed.
+        tmp <- tryCatch(content(req), error = function(x) NULL)
+        show_http_status_and_terminate(status_code(req), tmp)
+    }
+
+    # Else extracting the content
+    content <- content(req)
+
+    # If a certain class is expected check and throw a warning
+    # if the object is not of the correct class.
+    if (!is.null(expected_class)) {
+        if (!inherits(content, expected_class)) {
+            warning("expected returned object from HTTP request to be of class ",
+                    paste(expected_class, collapse = ", "), " but it is of ",
+                    paste(class(content), collapse = ", "))
+        }
+    }
+
+    return(content)
+}