swissgeo.core coverage - 97.41%

Files
Source


# Helper function to extract station information from an item
#' @importFrom dplyr bind_rows
#' @importFrom sf st_polygon st_point
#' @importFrom sf st_sfc st_crs st_as_sf
items_extract_features <- function(x, defaultcrs = 4326L) {
    stopifnot(x$type == "FeatureCollection",
              is.list(x$features) && length(x$features) > 0L)

    if (!all(sapply(x$features, function(x) length(x$assets))))
        stop("not all assets are of length 1 - currently not handled")

    x <- x$features

    # Checking CRS
    crs <- sapply(x, function(x) x$assets[[1L]]$`proj:epsg`) |> unlist()
    if (all(is.null(crs))) crs <- defaultcrs
    if (!is.null(crs) && !length(unique(crs)) == 1L)
        stop("CRS not identical for all items - currently not handled")

    get_geometry <- function(g) {
        #crs  <- g$assets[[1]]$`proj:epsg`
        type <- g$geometry$type
        if (type == "Polygon") {
            tmp <- g$geometry$coordinates |> unlist() |> matrix(ncol = 2, byrow = TRUE)
            res <- st_polygon(list(tmp))
        } else {
            res <- g$geometry$coordinates |> unlist() |> st_point()
        }
        return(res)
    }

    # Extracting geometries
    geometry <- lapply(x, get_geometry)
    geometry <- if (is.null(crs[[1L]])) st_sfc(geometry) else st_sfc(geometry, crs = crs[[1L]])

    # Search for atomic elements; the rest will be excluded by default
    atom <- sapply(x[[1]], is.atomic); names(atom)[atom]
    fn <- function(x) return(c(x[atom], x$properties))
    d <- as.data.frame(bind_rows(lapply(x, fn)))
    d <- cbind(geometry, d)
    d <- d |> autoconvert_datetime() |> st_as_sf(sf_column_name = "geometry")
    d$assets <- assets(lapply(x, function(y) y$assets))

    return(d)
}



#' Get Request Helper Function
#'
#' Auxilary function to send HTTPS requests with additional error handling.
#' Requests are sent over the httr2 requests object (see [sg_options()] for details).
#'
#' @param req object of class `httr2_request`.
#' @param query `NULL` (default) or a list with get parameters to be sent
#'        with the request. Warning: If the URL contains get requests and
#'        `query` is not `NULL`, the parameters in the URL (`url`) will
#'        be overwritten!
#' @param paging logical, defaults to `FALSE`. If `TRUE` we will send
#'        an initial request is sent to the `url` which returns a
#'        maximum of 100 entries. It is then checked if a 'next'
#'        link is included in the response used to request the
#'        next batch of up to 100 entries until finished.
#' @param limit integer, defaults to `100L`. Number of entries to
#'        be requested if `paging = TRUE`.
#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
#'        some messages are printed.
#' @param \dots forwarded to the `httr::GET()` function. TODO(R)
#'
#' @details We are expecting a JSON response from the API, thus
#' we expect that the request content is decoded to a list by the
#' httr package. IF `paging = FALSE` this list is returned.
#' If `paging = TRUE` a list of lists is returned, where each
#' element in the main list contains the results of one API call
#' following the 'next' links (see argument `paging`).
#'
#' If we do not get a proper HTTP status code, or
#' the extracted content is not a list, this function will throw
#' an error.
#'
#' @return List with the decoded information.
#'
#' @author Reto
#' @importFrom httr2 request req_url req_url_query req_perform
#' @importFrom httr2 resp_status resp_is_error resp_body_json
sg_send_api_request <- function(req, query = NULL, paging = FALSE, limit = 100L, verbose = FALSE, ...) {

    limit <- as.integer(limit)[1L]
    stopifnot(
        "argument `req` must be of class \"httr2_request\"" = inherits(req, "httr2_request"),
        "argument 'paging' must be TRUE or FALSE" = isTRUE(paging) || isFALSE(paging),
        "argument 'limit' must be a single positive integer" =
            is.integer(limit) && length(limit) == 1L && !is.na(limit) && limit > 0L,
        "argument 'verbose' must be TRUE or FALSE" = isTRUE(verbose) || isFALSE(verbose)
    )

    # Scoping 'req', 'verbose'
    downloadfn <- function(query) {

        # if 'query' is character, we assume we just got another URL including
        # the query parameters. This is needed as req_url_query() modifies
        # the query parameters, namely it escapes '%'s which breaks the request.
        if (is.character(query)) {
            req <- req |> req_url(query)
        } else {
            req <- req |> req_url_query(!!!query)
        }
        if (verbose) message("Sending request to ", req$url) # nocov

        # Sending query = NULL would kill (remove) the parameters specified in URL
        resp <- req |> req_perform()

        if (resp_is_error(resp)) {
            # 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(resp_body_json(resp), error = function(x) NULL)
            stop("Issues requesting data forom \"", url, "\"")
        }

        # Extracting content
        res <- resp |> resp_body_json()
        if (!is.list(res)) stop("Result of http request no list (not JSON)") # nocov
        return(res)
    }

    # No paging expected/required we simply do cone request
    # and return the result we get (the 'raw' encoded list)
    if (!paging) return(downloadfn(query = NULL))

    # Else we have to send an initial request first and check
    # if we get a 'next' link which allows us to request the
    # next page (or block) of results (using the default
    # limit = 100L).

    # Initial request, check for 'next' link. `get_link_next`
    # returns a character (url) if we have to do another
    # request (while loop), else `NULL`.
    tmp <- downloadfn(query = list(limit = limit))
    link_next <- get_link_next(tmp)

    # Store initial result as a list
    res <- list(tmp)

    # As long as we get a 'next' link there is an additional
    # batch to download.
    while (is.character(link_next)) {
        tmp       <- downloadfn(link_next)
        res[[length(res) + 1L]] <- tmp
        link_next <- get_link_next(tmp)
    }

    return(res)
}

# Auxilary function to extract the 'next' link from a previous
# items request. If not found (i.e., no additional next batch
# to be processed) NULL is returned, else the URL for the next
# get request.
get_link_next <- function(x) {
    stopifnot(
        "argument 'x' expected to be list" = is.list(x),
        "expected list 'x' to contain $links" = !is.null(x$links)
    )
    x   <- x$links
    idx <- which(sapply(x, function(k) k$rel == "next"))
    return(if (!length(idx) == 1L) NULL else x[[idx]]$href)
}


# Extract query parameters from URI
#####get_query_from_url <- function(x) {
#####    x <- regmatches(x, regexpr("(?<=(\\?)).*", x, perl = TRUE))
#####    if (length(x) == 0L || nchar(x) == 0L) return(NULL)
#####    # Extracting parameters, creating list
#####    q <- lapply(strsplit(x, "&"), strsplit, "=")[[1]]
#####    if (!all(sapply(q, length) == 2L))
#####        stop("Problems extracting query parameters from URL (key-value pairs): ", x)
#####    # Create named list and return
#####    lapply(q, function(x) x[[2L]]) |> setNames(lapply(q, function(x) x[[1L]]))
#####}

#' Collections
#'
#' Requesting a list of all available collections provided via the API.
#'
#' @param pattern `NULL` or a pattern used return a subset of all
#'        available collections, applied to the collection ID.
#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
#'        some messages are printed.
#' @param raw logical, defaults to `FALSE` (see Return).
#'
#' @return Returns a tibble data frame with the available collections.
#' If `pattern = NULL` all collections found are returned. If
#' a `pattern` is specified, all collections where the collection ID
#' (`id`) matches the pattern are returned. If no IDs match the
#' pattern, a warning is thrown and `NULL` is returned.
#'
#' If `raw = TRUE` is specified, `pattern` is ignored and the raw
#' data as retrieved by the API are returned as a list of lists.
#' Each element of the list corresponds to one API call containing
#' a set of lists corresponding to the different collections returned.
#'
#' @examples
#' \dontrun{
#' ## Fetch all available collections
#' collections <- sg_collections()
#'
#' ## Extract collections by MeteoSchweiz
#' subset(res, grepl("meteoschweiz", id))
#' }
#'
#' @export
#' @author Reto
#'
#' @importFrom dplyr bind_rows
#' @importFrom sf st_bbox st_crs
#' @importFrom parsedate parse_date
sg_collections <- function(pattern = NULL, verbose = FALSE, raw = FALSE) {

    stopifnot(
        "argument 'pattern' must be NULL or a single non-empty character" =
            is.null(pattern) ||
            (is.character(pattern) && length(pattern) == 1L && nchar(pattern) > 0L),
        "argument 'raw' must be TRUE or FALSE" = isTRUE(raw) || isFALSE(raw)
    )

    if (verbose) message("Retrieving collections") # nocov

    # Downloading the data from the API. Each time the API returns up to
    # 100 items, paging = TRUE calls the API until all items are fetched.
    res <- sg_send_api_request(getOption("swissgeo.req") |> sg_change_url("collections"),
                               paging = TRUE, verbose = verbose)

    extractfun <- function(x) {
        stopifnot(is.list(x))
        take <- c("id", "title", "description", "license", "created", "updated", "itemType")
        res  <- x[take[take %in% names(x)]]
        if (!is.null(x[[c("summaries", "proj:epsg")]])) {
            res$crs <- x[[c("summaries", "proj:epsg")]][[1]]

            # Spatial extent?
            if (!is.null(tmp <- x[[c("extent", "spatial")]])) {
                tmp <- tmp |> unlist() |> setNames(c("xmin", "ymin", "xmax", "ymax"))
                res$extent <- list(st_bbox(tmp, crs = res$crs))
            }
        }

        # Temporal extent?
        if (!is.null(tmp <- x[[c("extent", "temporal")]])) {
            res$data_from <- parse_date(unlist(tmp)[1L])
            res$data_to   <- parse_date(unlist(tmp)[2L])
        }

        return(res)
    }

    if (raw) return(do.call(c, res))

    if (verbose) message("Preparing data frame for the return") # nocov
    res <- lapply(res, function(x) bind_rows(lapply(x$collections, extractfun))) |> bind_rows()
    if (!is.null(pattern)) {
        idx <- grep(pattern, res$id)
        if (length(idx) == 0L) {
            warning("No collection ids matching ", pattern, ", returning NULL.")
            return(NULL)
        }
        res <- res[idx, ]
    }

    # Converting columns containing ISO 8601 datetime information
    # from character to POSIXct
    return(res |> autoconvert_datetime())
}

#' Collection Items
#'
#' Retrieving all items of a specific collection.
#'
#' @param id character, ID of the collection for which to retrieve
#'        the items (see [sg_collections()]).
#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
#'        some messages are printed.
#' @param raw logical, defaults to `FALSE` (see Return).
#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
#'        some messages are printed.
#'
#' @return
#' If `raw = TRUE` a list of lists is returned with the
#' raw (json decoded) result from the API calls. Each element in
#' the list corresponds to one API call (paging).
#'
#' Else (default) the function tries to auto-detect the format.
#' As an example, if the returned data are of type "FeatureCollection"s
#' The data is converted to a simple feature data frame which is
#' then returned. If now only "FeatureCollection" is implemented,
#' if the returned data is of a different type the raw list
#' is returned (TODO).
#'
#' @examples
#' \dontrun{
#' ## Retrieving items for a collection w/ features
#' CID <- "ch.meteoschweiz.ogd-smn"
#' items <- sg_items(CID)
#'
#' ## Visualizing the features
#' library("ggplot2")
#' ggplot(st_transform(items, crs = st_crs(2056))) +
#'     geom_sf(col = "lightgreen") + geom_sf_text(aes(label = id))
#' }
#'
#' @export
#' @author Reto
#'
#' @importFrom stats setNames
#' @importFrom sf st_as_sf st_crs
sg_items <- function(id, raw = FALSE, verbose = FALSE) {

    raw <- as.logical(raw)[[1L]]
    verbose <- as.logical(verbose)[[1L]]

    stopifnot(
        "argument `id` must be character of length 1" = 
            is.character(id) && length(id) == 1L && nchar(id) > 0L,
        "argument `raw` must evaluate to TRUE or FALSE" = isTRUE(raw) || isFALSE(raw),
        "argument `verbose` must evaluate to TRUE or FALSE" = isTRUE(verbose) || isFALSE(verbose)
    )

    if (verbose) message("Retrieving items") # nocov

    # Downloading the data from the API. Each time the API returns up to
    # 100 items, paging = TRUE calls the API until all items are fetched.
    res <- sg_send_api_request(getOption("swissgeo.req") |>
                               sg_change_url("collections", id, "items"),
                               paging = TRUE, verbose = verbose)

    # RAW results requested? Job done ...
    if (raw) return(res)

    # Else we try to prepare the data in an R object. First, ensure
    # that the data all match by type. TODO: Not sure if there is a
    # situation where it can happen to get different types of data
    # from one single API end point; but leaving it in here for now.
    type <- sapply(res, function(x) x$type)
    if (!all(type == type[[1]]))
        stop("Not all item type identical, got ", paste(unique(type), collapse = ", "))
    type <- type[[1]] # Our type

    # Feature type? Create simple features data.frame
    if (type == "FeatureCollection") {
        # Extracting features
        res <- do.call(rbind, lapply(res, items_extract_features))
        res <- res |> dataframe_to_sf(verbose = verbose)
    }

    return(res |> autoconvert_datetime())
}

#' Collection Assets
#'
#' Retrieving all assets of a specific collection.
#'
#' @param id character, ID of the collection for which to retrieve
#'        the items (see [sg_collections()]).
#' @param raw logical, defaults to `FALSE` (see Return).
#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
#'        some messages are printed.
#'
#' @return A tbl data frame containing the asset details is returned.
#'
#' If `raw = TRUE` a list of lists is returned with the raw (json decoded)
#' result from the API calls. Each element in the list corresponds to one API
#' call (paging).
#'
#' @export
#' @author Reto
#'
#' @importFrom dplyr bind_rows
sg_assets <- function(id, raw = FALSE, verbose = FALSE) {

    verbose <- as.logical(verbose)[[1L]]
    raw     <- as.logical(raw)[[1L]]

    stopifnot(
        "argument 'id' must be character of length 1" = 
            is.character(id) && length(id) == 1L && nchar(id) > 0L,
        "argument `raw` must evaluate to single TRUE or FALSE" = isTRUE(raw) || isFALSE(raw),
        "argument `verbose` must evaluate to single TRUE or FALSE" = isTRUE(verbose) || isFALSE(verbose)
    )

    if (verbose) message("Retrieving assets") ## nocov

    # Downloading the data from the API. Each time the API returns up to
    # 100 items, paging = TRUE calls the API until all items are fetched.
    res <- sg_send_api_request(getOption("swissgeo.req") |>
                               sg_change_url("collections", id, "assets"),
                               paging = TRUE, verbose = verbose)

    # RAW results requested? Job done ...
    if (raw) return(res)

    # Extracting asset details and return as data.frame
    fn <- function(x) x[which(sapply(x, is.atomic))]
    res <- bind_rows(lapply(res, function(x) lapply(x$assets, fn)))

    return(autoconvert_datetime(res))
}

##  #' Data Inventory
##  #'
##  #' Downloading data inventory of a specific data set collection.
##  #'
##  #' @param id character, ID of the collection for which to retrieve
##  #'        the items (see [sg_collections()]).
##  #' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
##  #'        some messages are printed.
##  #'
##  #' @return If `raw = TRUE` a list of lists is returned with the
##  #' raw (json decoded) result from the API calls. Each element in
##  #' the list corresponds to one API call (paging).
##  #'
##  #' @export
##  #' @author Reto
##  #'
##  #' @importFrom stats setNames
##  #' @importFrom utils read.csv2
##  sg_inventory <- function(id, verbose = FALSE, raw = FALSE) {
##
##      stopifnot(
##          "argument 'id' must be character of length 1" =
##              is.character(id) && length(id) == 1L && nchar(id) > 0L,
##          "argument 'raw' must be TRUE or FALSE" = isTRUE(raw) || isFALSE(raw)
##      )
##
##      # Generate expected API end point
##      url <- sg_change_url("collections", id, "assets")
##
##      if (verbose) message("Retrieving items") # nocov
##
##      # Downloading the data from the API. Each time the API returns up to
##      # 100 items, paging = TRUE calls the API until all items are fetched.
##      res <- sg_send_api_request(req, paging = TRUE, verbose = verbose)
##
##      # RAW results requested? Job done ...
##      if (raw) return(res)
##
##      # Else we try to prepare the data in an R object
##      type <- sapply(res, function(x) x$type)
##      if (!all(type == type[[1]])) {
##          # TODO: Is that possible?
##          stop("Not all item type identical, got ", paste(unique(type), collapse = ", "))
##      }
##      type <- type[[1]] # Our type
##
##      # Feature type? Create simple features data.frame
##      if (type == "FeatureCollection") {
##          # Extracting features
##          res <- do.call(rbind, lapply(res, items_extract_features))
##      }
##
##      # Convert data frame to simple features data frame
##      return(st_as_sf(res, coords = c("lon", "lat"), crs = st_crs(4326)))
##  }




#' Download (Cache) and Import Assets/Data Sets
#'
#' @param x data frame (with one row) or list containing
#'        at least the following variables: id, type, href, file:checksum.
#' @param dir NULL or character, name/path to a directory where to store the file.
#'        Note that no file will be stored if CVS files are downloaded and
#'        `read_csv = TRUE`.
#' @param language character, one of `"all"` (default), `"en"`,
#'        `"de"`, `"fr"`, or `"it"`. If set different to `"all"`
#'        columns ending in `_<lang>` not matching the requested
#'        language will be removed.
#' @param use_crs character vector used to auto-detect coordinates.
#'        Can be set to `NULL`/`FALSE` to not do the conversion.
#' @param encoding file encoding, only used if the asset is a CSV file
#'        and `read_csv` is set `TRUE`.
#' @param read_csv logical, defaults to `TRUE`. If `TRUE` and the
#'        asset is a csv file it will be read and returned.
#' @param cachedir NULL or character, path to a cache directory. If set,
#'        the downloaded files are cached and re-used if needed.
#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
#'        some messages are printed.
#'
#' @details Assets (data sets) provided via geo.admin.ch come
#' with a file checksum which can be used to check if a file
#' changed. We use this to cache files.
#'
#' If a cache directory is specified (`cachedir`) it will be checked if that file has
#' already been downloaded and stored in the directory. In this situation, the
#' local file is used rather than downloading the data again. If not, the asset will
#' be downloaded and stored in the directory specified so that it can be
#' potentially used again next time.
#'
#' Please note that the the size of the directory can grow
#' fast, especially if this mechanic is used when downloading/accessing
#' data sets that rapidly change (i.e., most recent data) as
#' a new file will be created every time the checksum changes.
#'
#' @author Reto
#' @export
sg_download_assets <- function(x, dir = NULL, language = c("all", "en", "de", "fr", "it"),
                               use_crs = c("lv95", "wgs84"), encoding = "Latin1",
                               read_csv = TRUE, cachedir = NULL, verbose = FALSE) {

    verbose  <- as.logical(verbose)[[1L]]
    read_csv <- as.logical(read_csv)[[1L]]

    # We need NULL later
    if (isFALSE(use_crs)) use_crs <- NULL

    # Sanity checks
    stopifnot(
        "argument 'x' must be a data frame or list" = is.list(x),
        "argument 'dir' must be NULL or single character" =
            is.null(dir) || (is.character(dir) && length(dir) == 1L),
        "argument `use_crs` must be NULL/FALSE or a character vector" =
            is.null(use_crs) || (is.character(use_crs) && length(use_crs) > 0L),
        "argument 'read_csv' must be logical TRUE or FALSE" =
            isTRUE(read_csv) || isFALSE(read_csv),
        "argument 'cachedir' must be NULL or single character" =
            is.null(cachedir) || (is.character(cachedir) && length(cachedir) == 1L),
        "argument 'verbose' must be logical TRUE or FALSE" =
            isTRUE(verbose) || isFALSE(verbose)
    )
    language <- match.arg(language)

    # Check if directory exists
    if (!is.null(dir) && !dir.exists(dir)) 
        stop("directory \"", dir, "\" not found")
    if (!is.null(cachedir) && !dir.exists(cachedir))
        stop("directory \"", cachedir, "\" not found")

    # Converting data frame to list
    if (is.data.frame(x)) {
        x <- lapply(seq_len(nrow(x)), function(i) as.list(x[i, ])) |> setNames(rownames(x))
    } else {
        x <- list(x) # List of list
    }

    # Check that we have all required variables in our data set
    fn <- function(x) {
        sg_download_asset(x, dir = dir, language = language,
                          use_crs = use_crs, read_csv = read_csv,
                          cachedir = cachedir, verbose = verbose, encoding = encoding)
    }
    res <- lapply(x, fn) |> setNames(sapply(x, function(k) k$id))

    return(if (length(res) == 1L) res[[1L]] else res)
}

#' @importFrom httr2 req_url_path req_perform req_url
#' @importFrom httr2 resp_status resp_is_error resp_status_desc
#' @importFrom utils read.csv2
#' @importFrom tidyr as_tibble
sg_download_asset <- function(x, dir, language, use_crs, read_csv, cachedir, verbose, encoding) {
    expected <- c("type", "href", "file:checksum")
    if (!all(expected %in% names(x)))
        stop("missing at least one variable in 'x'. Expected: ",
             paste(sprintf("\"%s\"", expected), collapse = ", "), "; Found: ",
             paste(sprintf("\"%s\"", names(x)), collapse = ", "))

    # Must all be of length 1
    x <- lapply(x[expected], as.character)
    stopifnot(
        "all vectors in 'x' must be of length 1L" = all(sapply(x, length) == 1L),
        "empty characters in 'x' not allowed" = all(sapply(x, nchar) > 0L)
    )

    if (!"id" %in% names(x)) x$id <- basename(x$href)

    # Checking 'dir' and 'cachedir'.
    # - If cachedir is not NULL, we download the file into the cache directory
    # - If `dir` is not NULL we, at the end, place the file there.
    x$local_file <- if (is.null(cachedir)) {
        fileext <- regmatches(x$id, regexpr("\\.\\w{0,8}$", x$id))
        tempfile(fileext = if (length(fileext) == 1L) fileext else "")
    } else {
        file.path(cachedir, sprintf("%s_%s", x$`file:checksum`, x$id))
    }

    # Shall we download and store locally?
    if (!is.null(x$local_file) && !file.exists(x$local_file)) {
        if (verbose) message("Downloading ", x$id, ", saving to ", x$local_file) # nocov
        resp <- getOption("swissgeo.req") |> req_url(x$href) |> req_perform(path = x$local_file)
        if (resp_is_error(resp)) stop("Issues retrieving data from \"", x$href, "\": ", resp_status_desc(resp))
    } else if (file.exists(x$local_file)) {
        if (verbose) message("Using ", x$local_file) # nocov
    }

    # if `dir` is set, copy the file to the final location
    if (!is.null(dir)) file.copy(x$local_file, file.path(dir, x$id))

    # Importing file
    if (x$type == "text/csv" && read_csv) {
        res <- read.csv2(file(x$local_file, encoding = encoding),
                         dec = ".", na.strings = c("NA", "")) |>
                as_tibble() |>
                autoconvert_datetime() |>
                remove_language_cols(lang = language)
    } else {
        res <- NULL
    }

    # Cleaning up; only if we imported the data (CSV),
    # else we leave the temporary file there and return
    # the name to the user as it might be useful to download
    # the data and then actually also have it on disc :).
    if (!is.null(res) && is.null(cachedir) && is.null(dir) && file.exists(x$local_file))
        file.remove(x$local_file)

    # If res = NULL (we did not read CSV) simply return the local file name,
    # even if the file was already deleted.
    if (is.null(res)) return(x$local_file)

    # Else (potentially) convert the read data
    return(if (is.null(use_crs)) res else dataframe_to_sf(res, use_crs, verbose = verbose))
}

#' Removing Non-required Language-specific Variables
#'
#' @param x data frame to be checked and potentially modified.
#' @param lang character, languages to keep. If `"all"` no
#'        modifications are done. Else trying to remove
#'        all columns not matching the requested `lang`.
#'
#' @return A data frame, potentially modified by removing
#' all columns not matching the requested language.
#'
#' @author Reto
remove_language_cols <- function(x, lang) {
    if (lang == "all") return(x)

    # Else we remove columns/variables ending in:
    languages <- c("en", "de", "fr", "it")
    remove <- languages[!languages == lang]

    # Columns to remove
    pattern <- sprintf(".*_(%s)$", paste(remove, collapse = "|"))
    keep    <- !grepl(pattern, names(x))

    return(x[, keep])
}







#' Setting `swissgeo` Options
#'
#' Allows the user to overwrite a series of default options used in
#' the package, mainly fine-tuning how the HTTPS requests are handled.
#'
#'
#' @param timeout positive numeric, forwarded to [httr2::req_timeout()].
#'        Defaults to 20 seconds.
#' @param retry positive integer, forwarded to [httr2::req_retry()].
#'        Defaults to `3` (three retries).
#' @param capacity positive integer, forwarded to [httr2::req_throttle()].
#'        Defaults to size 3.
#' @param filltime positive numeric, forwarded to [httr2::req_throttle()].
#'        Defaults to size 3.
#' @param apiurl `NULL` (default) or character. Allows to overwrite the
#'        main URL (mainly for testing).
#' @param verbose logical, defaults to `FALSE`.
#'
#' @details A series of default options is set every time the package
#' is attached. They can be overruled by the user calling this function.
#'
#' @return Invisibly returns the current swissgeo settings, these are used
#' in the `sg_*` functions for request handling.
#'
#' @author Reto
#' @export
sg_options <- function(timeout = 20, retry = 3, capacity = 3, filltime = 3,
                       apiurl = NULL, verbose = FALSE) {

    verbose <- as.logical(verbose)[[1L]]
    stopifnot("argument `verbose` must evaluate to TRUE or FALSE" =
              isTRUE(verbose) || isFALSE(verbose))

    if (!is.null(apiurl)) options("swissgeo.apiurl" = apiurl)

    # Setting defaults for timeout, retry, and bucket
    # swissgeo.httr2_timeout:    Defaults to 20 seconds (handed over to req_timeout())
    # swissgeo.httr2_retry:      Defaults to 3 times (handed over to req_retry())
    # swissgeo.httr2_capacity:   Defaults to size 3 (handed over to req_throttle())
    # swissgeo.httr2_filltime:   Defaults to 3 second (handed over to req_throttle())
    # Note: swissgeo.httr2_capacity = 3 w/ swissgeo.httr2_filltime = 1 results in
    #       a maximum of three reqeuests per second.
    options("swissgeo.httr2_timeout"  = timeout)
    options("swissgeo.httr2_retry"    = retry)
    options("swissgeo.httr2_capacity" = capacity)
    options("swissgeo.httr2_filltime" = filltime)

    # Setting up new requests object
    options("swissgeo.req" = sg_get_req())

    opts <- grep("^swissgeo\\.", names(options()), value = TRUE)

    ## nocov start
    if (verbose) {
        message("swissgeo options:")
        for (o in opts) {
            tmp <- getOption(o)
            if (o == "swissgeo.req") tmp <- deparse(class(tmp))
            message(paste0(" - ", o, ": ", tmp))
        }
    }
    ## nocov end

    invisible(options()[opts])
}


#' Modify Request URL
#'
#' Modifies the URL of an existing `httr2_request` object.
#'
#' @param req object of class `httr2_request`.
#' @param ... additional arguments to extend the base API URL.
#'        All arguments (after coercion to character) must represent
#'        valid non-empty characters.
#'
#' @return Returns a modified version of the input argument `req` with
#' an updated (API) URL.
#'
#' @importFrom httr2 req_url_path_append
#' @author Reto
sg_change_url <- function(req, ...) {
    stopifnot(
        "argument `req` must be an object of class \"httr_request\"" =
            inherits(req, "httr2_request")
    )
    req |> req_url_path_append(...)
}

# TODO(R): Adjust to httr2 or remove
###  #' 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[httr]{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
###  #' @importFrom httr http_status
###  # Show http_status message if possible.
###  show_http_status_and_terminate <- function(scode, xtra = NULL) {
###
###      stopifnot("argument 'scode' must be numeric of length 1L" =
###                is.numeric(scode), length(scode) == 1)
###      if (scode %/% 100 == 2) return(NULL)
###
###      # Given we have to deal with the return code, ensure
###      # 'xtra' is a named list or NULL
###      stopifnot("argument 'xtra' must be NULL or a named list of length > 0L" =
###          is.null(xtra) || (is.list(xtra) && !is.null(names(xtra)) && length(xtra) > 0L))
###
###      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"))
###      }
###  }


#' Converting Datetime Columns
#'
#' Takes a data frame as input and tries to identify columns
#' containing datetime information.
#'
#' @param x data frame.
#'
#' @return Data frame with POSIXct variables if any variable
#' containing datetime information was detected.
#'
#' @details Data received by the API or read via the files
#' provided regularey contain date or datetime information
#' as character strings.
#'
#' This function takes a data frame and tries to identify
#' variables/columns containing date and time information
#' to coerce the information into Date or POSIXct objects.
#' Currently, the following formats are checked currently:
#'
#' * `2026-01-16T17:34:34(...)Z`: converted to POSIXct
#' * `16.01.2026`: converted to Date
#' * `2026-01-16`: converted to Date
#' * `16.01.2026 12:03`: converted to POSIXct w/ time zone Europe/Zuerich
#' * `16.01.2026 00:00`: converted to Date
#'
#' @examples
#' \dontrun{
#' autoconvert_datetime(data.frame(a = 1, b = "2026-01-16T12:34:56.23435Z"))
#' autoconvert_datetime(data.frame(a = 1, b = "2026-01-16T12:34:56Z"))
#' autoconvert_datetime(data.frame(a = 1, b = "16.01.2026 12:34"))
#' autoconvert_datetime(data.frame(a = 1, b = "16.01.2026 00:00"))
#' autoconvert_datetime(data.frame(a = 1, b = "16.01.2026"))
#' autoconvert_datetime(data.frame(a = 1, b = "2026-01-16"))
#' }
#'
#' @author Reto
#' @importFrom parsedate parse_iso_8601
autoconvert_datetime <- function(x) {
    stopifnot(is.data.frame(x))
    if (nrow(x) == 0L) return(x)

    get_idx <- function(x, pattern) {
        tmp <- sapply(x, function(x) grepl(pattern, x) | is.na(x))
        which(if (is.matrix(tmp)) colSums(tmp) == nrow(x) else tmp)
    }

    # Checking for ISO8601 format (Y-m-dTH:M:S..) and convert, if found
    idx <- get_idx(x, "^[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}")
    for (i in idx) x[[i]] <- parse_iso_8601(x[[i]])

    # Checking for 'german date' and convert, if found.
    idx <- get_idx(x, "^[0-9]{2}.[0-9]{2}.[0-9]{4}$")
    for (i in idx) x[[i]] <- as.Date(x[[i]], format = "%d.%m.%Y")

    # Checking for 'date' and convert, if found.
    idx <- get_idx(x, "^[0-9]{4}-[0-9]{2}-[0-9]{2}$")
    for (i in idx) x[[i]] <- as.Date(x[[i]], format = "%Y-%m-%d")

    # Checking for 'german date and time' and convert, if found.
    idx <- get_idx(x, "^[0-9]{2}.[0-9]{2}.[0-9]{4}\\s+[0-9]{2}:[0-9]{2}")
    for (i in idx) x[[i]] <- as.POSIXct(x[[i]], format = "%d.%m.%Y %H:%M", tz = "Europe/Zurich")

    return(x)
}


#' Convert Dataframe to Simple Feature Dataframe
#'
#' Many data sets retrieved via the Geoportal are geolocated, providing
#' coordinates of e.g., a station location. This function tries to auto-detect
#' locations, converting a dataframe into a simple feature dataframe.
#'
#' @param x a data frame which (potentially) contains coordinates.
#' @param use_crs character, order of coordinate reference to use (if found).
#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
#'        some messages are printed.
#'
#' @details Some data sets like station locations come their geolocation (coordinates),
#' sometimes given in two different reference systems. This function takes a
#' data frame and checks if it can find coordinates. If found, the object is
#' converted into a simple feature data frame dropping all coordinates from the
#' data part.
#'
#' @return If no matching coordinates are found, `x` is returned as is. Else
#' `x` is converted into a simple feature data frame, removing all coordinate
#' related columns.
#'
#' @importFrom sf st_as_sf st_crs
dataframe_to_sf <- function(x, use_crs = c("lv95", "wgs84"), verbose = FALSE) {
    stopifnot("argument `x` must be a data frame" = is.data.frame(x))
    use_crs <- match.arg(use_crs, several.ok = TRUE)

    # Renaming 'lon' to 'coordinates_wgs84_east' and
    # 'lat' to 'coordinates_wgs84_north' if both are found.
    if (length(grep("^(lon|lat)$", names(x))) == 2L) {
        names(x)[grep("^lon$", names(x))] <- "coordinates_wgs84_lon"
        names(x)[grep("^lat$", names(x))] <- "coordinates_wgs84_lat"
    }

    # Check for coordinate columns
    coord_cols <- grep("coordinates_", names(x), value = TRUE)
    if (length(coord_cols) == 0L) return(x) # No coordinates found

    fn <- function(z) {
        # Currently only prepared
        tmp <- switch(z,
                   lv95    = list(postfix = c("east", "north"), crs = 2056L),
                   wgs84   = list(postfix = c("lon", "lat"),    crs = 4326L)
               )
        tmp$columns <- sprintf("coordinates_%s_%s", z, tmp$postfix)
        tmp$columns <- sapply(tmp$columns, function(k) grep(k, names(x), value = TRUE))
        tmp$found   <- is.character(tmp$columns) && length(tmp$columns) == 2L # Both columns in the data frame?
        return(tmp)
    }

    # Check what we have, if we can't find the required columns we return x as is
    coords_check <- lapply(use_crs, fn)
    i <- which(sapply(coords_check, function(x) x$found))
    if (length(i) == 0L) {
        if (verbose) message("No coordinates found") ## nocov
        return(x)
    }

    # Take first match
    coords <- coords_check[min(i)]

    # Else we convert the data frame to a simple feature data frame and remove
    # all coordinate related columns.
    if (verbose) message(sprintf("Found coordinates \"%s\" (crs = %d), converting", names(coords), coords[[1]]$crs)) ## nocov
    x <- st_as_sf(x, coords = coords[[1]]$columns, crs = st_crs(coords[[1]]$crs))
    return(x[, !names(x) %in% coord_cols])

}






#' Assets
#'
#' Each item as returned by [sg_items()] can provide multiple assets. An asset
#' specifies the type of data (e.g., historical, recent) as well as the
#' temporal resolution of the data and the data period (if suitable). The
#' `sg_assets` class is used to handle these assets within the package.
#'
#' @param x list of named lists containing the asset details.
#'
#' @return An asset data frame with the name of the asset and all provided
#' additional information.
#'
#' @author Reto
#'
#' @importFrom dplyr bind_rows
assets <- function(x) {
    stopifnot(
        "argument 'x' must be an unnamed list (of assets)" =
            is.list(x) && is.null(names(x)),
        "elements in 'x' must be named lists" = 
            all(sapply(x, function(y) is.list(y) && !is.null(names(y))))
    )

    fn <- function(x)
        cbind(data.frame(name = names(x)), bind_rows(x)) |> autoconvert_datetime()
    return(structure(lapply(x, fn), class = "assets"))
}


#' @param x object of class 'assets'.
#' @exportS3Method format assets
#' @rdname assets
#' @author Reto
format.assets <- function(x, ...) {
    sprintf("assets: %d", sapply(x, function(y) length(y[[1]])))
}

#' @exportS3Method print assets
#' @rdname assets
#' @author Reto
print.assets <- function(x, ...) {
    fn <- function(i) {
        y <- x[[i]]
        c(sprintf("[%d] Assets: %d", i, nrow(y)),
          sprintf("      [%s] %s", y$type, y$name))
    }
    res <- do.call(c, lapply(seq_along(x), fn))
    cat(res, sep = "\n")
    invisible(x)
}

#' @param i elements to extract or replace. Numeric values coerced
#'        to integer identifying the `i`th element(s) for subsetting.
#'
#' @exportS3Method `[` assets
#' @rdname assets
#' @author Reto
`[.assets` <- function(x, i, ...) {
    out <- NextMethod()
    return(structure(out, class = class(x)))
}

#' @exportS3Method as.double assets
#' @rdname assets
#' @author Reto
as.double.assets <- function(x, ...) sapply(x, function(y) length(y[[1]]))

#' @exportS3Method names assets
#' @rdname assets
#' @author Reto
names.assets <- function(x) {
    res <- lapply(x, function(y) y$name)
    return(if (length(res) == 1L) res[[1]] else res)
}

#' @param row.names `NULL` (default) or a character vector giving the row names for
#'        the data frame. Only used if `x` is of length 1L.
#' @param optional currently ignored.
#' @param \dots currently ignored.
#'
#' @exportS3Method as.data.frame assets
#' @rdname assets
#' @author Reto
#'
#' @importFrom dplyr bind_rows
as.data.frame.assets <- function(x, row.names = NULL, optional = NA, ...) {
    # TODO(R): nUntested, currently returns an unnamed list of dfs - intended?
    res <- lapply(x, function(y) structure(y, class = "data.frame")) |> bind_rows()
    if (!is.null(row.names) && is.data.frame(res))
        rownames(res) <- row.names
    return(res)
}




.onAttach <- function(libname, pkgname) {
    packageStartupMessage("
        TODO: Startup message with some information to geo.admin.ch and
        how to cite the data if used, though that is tricky as it is
        different for different data sets and must be found somewhere
        on the data providers home page.
    ")

    # Currently version 1 (v1); can be overruled by overwriting
    # the option using `options(swissgeo.apiurl = ...)`.
    apiurl <- sprintf("https://data.geo.admin.ch/api/stac/v%d", 1L)
    options("swissgeo.apiurl" = apiurl)

    # Setting defaults for timeout, retry, and bucket
    # swissgeo.httr2_timeout:    Defaults to 20 seconds (handed over to req_timeout())
    # swissgeo.httr2_retry:      Defaults to 3 times (handed over to req_retry())
    # swissgeo.httr2_capacity:   Defaults to size 3 (handed over to req_throttle())
    # swissgeo.httr2_filltime:   Defaults to 3 second (handed over to req_throttle())
    # Note: swissgeo.httr2_capacity = 3 w/ swissgeo.httr2_filltime = 1 results in
    #       a maximum of three reqeuests per second.
    options("swissgeo.httr2_timeout"  = 20)
    options("swissgeo.httr2_retry"    = 3)
    options("swissgeo.httr2_capacity" = 3)
    options("swissgeo.httr2_filltime" = 1)

    options("swissgeo.req" = sg_get_req())

}

#' @importFrom httr2 request req_timeout req_retry req_throttle 
sg_get_req <- function() {
    req <- request(getOption("swissgeo.apiurl")) |>
            req_timeout(getOption("swissgeo.httr2_timeout")) |>
            req_retry(getOption("swissgeo.httr2_retry")) |>
            req_throttle(capacity    = getOption("swissgeo.httr2_capacity"),
                         fill_time_s = getOption("swissgeo.httr2_filltime"))

    return(req)
}

1
2
3		#' Download (Cache) and Import Assets/Data Sets
4		#'
5		#' @param x data frame (with one row) or list containing
6		#' at least the following variables: id, type, href, file:checksum.
7		#' @param dir NULL or character, name/path to a directory where to store the file.
8		#' Note that no file will be stored if CVS files are downloaded and
9		#' `read_csv = TRUE`.
10		#' @param language character, one of `"all"` (default), `"en"`,
11		#' `"de"`, `"fr"`, or `"it"`. If set different to `"all"`
12		#' columns ending in `_<lang>` not matching the requested
13		#' language will be removed.
14		#' @param use_crs character vector used to auto-detect coordinates.
15		#' Can be set to `NULL`/`FALSE` to not do the conversion.
16		#' @param encoding file encoding, only used if the asset is a CSV file
17		#' and `read_csv` is set `TRUE`.
18		#' @param read_csv logical, defaults to `TRUE`. If `TRUE` and the
19		#' asset is a csv file it will be read and returned.
20		#' @param cachedir NULL or character, path to a cache directory. If set,
21		#' the downloaded files are cached and re-used if needed.
22		#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
23		#' some messages are printed.
24		#'
25		#' @details Assets (data sets) provided via geo.admin.ch come
26		#' with a file checksum which can be used to check if a file
27		#' changed. We use this to cache files.
28		#'
29		#' If a cache directory is specified (`cachedir`) it will be checked if that file has
30		#' already been downloaded and stored in the directory. In this situation, the
31		#' local file is used rather than downloading the data again. If not, the asset will
32		#' be downloaded and stored in the directory specified so that it can be
33		#' potentially used again next time.
34		#'
35		#' Please note that the the size of the directory can grow
36		#' fast, especially if this mechanic is used when downloading/accessing
37		#' data sets that rapidly change (i.e., most recent data) as
38		#' a new file will be created every time the checksum changes.
39		#'
40		#' @author Reto
41		#' @export
42		sg_download_assets <- function(x, dir = NULL, language = c("all", "en", "de", "fr", "it"),
43		use_crs = c("lv95", "wgs84"), encoding = "Latin1",
44		read_csv = TRUE, cachedir = NULL, verbose = FALSE) {
45
46	30x	verbose <- as.logical(verbose)[[1L]]
47	29x	read_csv <- as.logical(read_csv)[[1L]]
48
49		# We need NULL later
50	1x	if (isFALSE(use_crs)) use_crs <- NULL
51
52		# Sanity checks
53	28x	stopifnot(
54	28x	"argument 'x' must be a data frame or list" = is.list(x),
55	28x	"argument 'dir' must be NULL or single character" =
56	28x	is.null(dir) \|\| (is.character(dir) && length(dir) == 1L),
57	28x	"argument `use_crs` must be NULL/FALSE or a character vector" =
58	28x	is.null(use_crs) \|\| (is.character(use_crs) && length(use_crs) > 0L),
59	28x	"argument 'read_csv' must be logical TRUE or FALSE" =
60	28x	isTRUE(read_csv) \|\| isFALSE(read_csv),
61	28x	"argument 'cachedir' must be NULL or single character" =
62	28x	is.null(cachedir) \|\| (is.character(cachedir) && length(cachedir) == 1L),
63	28x	"argument 'verbose' must be logical TRUE or FALSE" =
64	28x	isTRUE(verbose) \|\| isFALSE(verbose)
65		)
66	19x	language <- match.arg(language)
67
68		# Check if directory exists
69	17x	if (!is.null(dir) && !dir.exists(dir))
70	1x	stop("directory \"", dir, "\" not found")
71	16x	if (!is.null(cachedir) && !dir.exists(cachedir))
72	1x	stop("directory \"", cachedir, "\" not found")
73
74		# Converting data frame to list
75	15x	if (is.data.frame(x)) {
76	14x	x <- lapply(seq_len(nrow(x)), function(i) as.list(x[i, ])) \|> setNames(rownames(x))
77		} else {
78	1x	x <- list(x) # List of list
79		}
80
81		# Check that we have all required variables in our data set
82	15x	fn <- function(x) {
83	19x	sg_download_asset(x, dir = dir, language = language,
84	19x	use_crs = use_crs, read_csv = read_csv,
85	19x	cachedir = cachedir, verbose = verbose, encoding = encoding)
86		}
87	15x	res <- lapply(x, fn) \|> setNames(sapply(x, function(k) k$id))
88
89	13x	return(if (length(res) == 1L) res[[1L]] else res)
90		}
91
92		#' @importFrom httr2 req_url_path req_perform req_url
93		#' @importFrom httr2 resp_status resp_is_error resp_status_desc
94		#' @importFrom utils read.csv2
95		#' @importFrom tidyr as_tibble
96		sg_download_asset <- function(x, dir, language, use_crs, read_csv, cachedir, verbose, encoding) {
97	19x	expected <- c("type", "href", "file:checksum")
98	19x	if (!all(expected %in% names(x)))
99	2x	stop("missing at least one variable in 'x'. Expected: ",
100	2x	paste(sprintf("\"%s\"", expected), collapse = ", "), "; Found: ",
101	2x	paste(sprintf("\"%s\"", names(x)), collapse = ", "))
102
103		# Must all be of length 1
104	17x	x <- lapply(x[expected], as.character)
105	17x	stopifnot(
106	17x	"all vectors in 'x' must be of length 1L" = all(sapply(x, length) == 1L),
107	17x	"empty characters in 'x' not allowed" = all(sapply(x, nchar) > 0L)
108		)
109
110	17x	if (!"id" %in% names(x)) x$id <- basename(x$href)
111
112		# Checking 'dir' and 'cachedir'.
113		# - If cachedir is not NULL, we download the file into the cache directory
114		# - If `dir` is not NULL we, at the end, place the file there.
115	17x	x$local_file <- if (is.null(cachedir)) {
116	1x	fileext <- regmatches(x$id, regexpr("\\.\\w{0,8}$", x$id))
117	1x	tempfile(fileext = if (length(fileext) == 1L) fileext else "")
118		} else {
119	16x	file.path(cachedir, sprintf("%s_%s", x$`file:checksum`, x$id))
120		}
121
122		# Shall we download and store locally?
123	17x	if (!is.null(x$local_file) && !file.exists(x$local_file)) {
124		if (verbose) message("Downloading ", x$id, ", saving to ", x$local_file) # nocov
125	4x	resp <- getOption("swissgeo.req") \|> req_url(x$href) \|> req_perform(path = x$local_file)
126	!	if (resp_is_error(resp)) stop("Issues retrieving data from \"", x$href, "\": ", resp_status_desc(resp))
127	13x	} else if (file.exists(x$local_file)) {
128		if (verbose) message("Using ", x$local_file) # nocov
129		}
130
131		# if `dir` is set, copy the file to the final location
132	1x	if (!is.null(dir)) file.copy(x$local_file, file.path(dir, x$id))
133
134		# Importing file
135	17x	if (x$type == "text/csv" && read_csv) {
136	13x	res <- read.csv2(file(x$local_file, encoding = encoding),
137	13x	dec = ".", na.strings = c("NA", "")) \|>
138	13x	as_tibble() \|>
139	13x	autoconvert_datetime() \|>
140	13x	remove_language_cols(lang = language)
141		} else {
142	4x	res <- NULL
143		}
144
145		# Cleaning up; only if we imported the data (CSV),
146		# else we leave the temporary file there and return
147		# the name to the user as it might be useful to download
148		# the data and then actually also have it on disc :).
149	17x	if (!is.null(res) && is.null(cachedir) && is.null(dir) && file.exists(x$local_file))
150	1x	file.remove(x$local_file)
151
152		# If res = NULL (we did not read CSV) simply return the local file name,
153		# even if the file was already deleted.
154	4x	if (is.null(res)) return(x$local_file)
155
156		# Else (potentially) convert the read data
157	13x	return(if (is.null(use_crs)) res else dataframe_to_sf(res, use_crs, verbose = verbose))
158		}
159
160		#' Removing Non-required Language-specific Variables
161		#'
162		#' @param x data frame to be checked and potentially modified.
163		#' @param lang character, languages to keep. If `"all"` no
164		#' modifications are done. Else trying to remove
165		#' all columns not matching the requested `lang`.
166		#'
167		#' @return A data frame, potentially modified by removing
168		#' all columns not matching the requested language.
169		#'
170		#' @author Reto
171		remove_language_cols <- function(x, lang) {
172	11x	if (lang == "all") return(x)
173
174		# Else we remove columns/variables ending in:
175	2x	languages <- c("en", "de", "fr", "it")
176	2x	remove <- languages[!languages == lang]
177
178		# Columns to remove
179	2x	pattern <- sprintf(".*_(%s)$", paste(remove, collapse = "\|"))
180	2x	keep <- !grepl(pattern, names(x))
181
182	2x	return(x[, keep])
183		}
184
185
186
187

1
2		# Helper function to extract station information from an item
3		#' @importFrom dplyr bind_rows
4		#' @importFrom sf st_polygon st_point
5		#' @importFrom sf st_sfc st_crs st_as_sf
6		items_extract_features <- function(x, defaultcrs = 4326L) {
7	5x	stopifnot(x$type == "FeatureCollection",
8	5x	is.list(x$features) && length(x$features) > 0L)
9
10	5x	if (!all(sapply(x$features, function(x) length(x$assets))))
11	!	stop("not all assets are of length 1 - currently not handled")
12
13	5x	x <- x$features
14
15		# Checking CRS
16	5x	crs <- sapply(x, function(x) x$assets[[1L]]$`proj:epsg`) \|> unlist()
17	4x	if (all(is.null(crs))) crs <- defaultcrs
18	5x	if (!is.null(crs) && !length(unique(crs)) == 1L)
19	!	stop("CRS not identical for all items - currently not handled")
20
21	5x	get_geometry <- function(g) {
22		#crs <- g$assets[[1]]$`proj:epsg`
23	317x	type <- g$geometry$type
24	317x	if (type == "Polygon") {
25	1x	tmp <- g$geometry$coordinates \|> unlist() \|> matrix(ncol = 2, byrow = TRUE)
26	1x	res <- st_polygon(list(tmp))
27		} else {
28	316x	res <- g$geometry$coordinates \|> unlist() \|> st_point()
29		}
30	317x	return(res)
31		}
32
33		# Extracting geometries
34	5x	geometry <- lapply(x, get_geometry)
35	5x	geometry <- if (is.null(crs[[1L]])) st_sfc(geometry) else st_sfc(geometry, crs = crs[[1L]])
36
37		# Search for atomic elements; the rest will be excluded by default
38	5x	atom <- sapply(x[[1]], is.atomic); names(atom)[atom]
39	5x	fn <- function(x) return(c(x[atom], x$properties))
40	5x	d <- as.data.frame(bind_rows(lapply(x, fn)))
41	5x	d <- cbind(geometry, d)
42	5x	d <- d \|> autoconvert_datetime() \|> st_as_sf(sf_column_name = "geometry")
43	5x	d$assets <- assets(lapply(x, function(y) y$assets))
44
45	5x	return(d)
46		}
47
48
49
50		#' Get Request Helper Function
51		#'
52		#' Auxilary function to send HTTPS requests with additional error handling.
53		#' Requests are sent over the httr2 requests object (see [sg_options()] for details).
54		#'
55		#' @param req object of class `httr2_request`.
56		#' @param query `NULL` (default) or a list with get parameters to be sent
57		#' with the request. Warning: If the URL contains get requests and
58		#' `query` is not `NULL`, the parameters in the URL (`url`) will
59		#' be overwritten!
60		#' @param paging logical, defaults to `FALSE`. If `TRUE` we will send
61		#' an initial request is sent to the `url` which returns a
62		#' maximum of 100 entries. It is then checked if a 'next'
63		#' link is included in the response used to request the
64		#' next batch of up to 100 entries until finished.
65		#' @param limit integer, defaults to `100L`. Number of entries to
66		#' be requested if `paging = TRUE`.
67		#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
68		#' some messages are printed.
69		#' @param \dots forwarded to the `httr::GET()` function. TODO(R)
70		#'
71		#' @details We are expecting a JSON response from the API, thus
72		#' we expect that the request content is decoded to a list by the
73		#' httr package. IF `paging = FALSE` this list is returned.
74		#' If `paging = TRUE` a list of lists is returned, where each
75		#' element in the main list contains the results of one API call
76		#' following the 'next' links (see argument `paging`).
77		#'
78		#' If we do not get a proper HTTP status code, or
79		#' the extracted content is not a list, this function will throw
80		#' an error.
81		#'
82		#' @return List with the decoded information.
83		#'
84		#' @author Reto
85		#' @importFrom httr2 request req_url req_url_query req_perform
86		#' @importFrom httr2 resp_status resp_is_error resp_body_json
87		sg_send_api_request <- function(req, query = NULL, paging = FALSE, limit = 100L, verbose = FALSE, ...) {
88
89	10x	limit <- as.integer(limit)[1L]
90	10x	stopifnot(
91	10x	"argument `req` must be of class \"httr2_request\"" = inherits(req, "httr2_request"),
92	10x	"argument 'paging' must be TRUE or FALSE" = isTRUE(paging) \|\| isFALSE(paging),
93	10x	"argument 'limit' must be a single positive integer" =
94	10x	is.integer(limit) && length(limit) == 1L && !is.na(limit) && limit > 0L,
95	10x	"argument 'verbose' must be TRUE or FALSE" = isTRUE(verbose) \|\| isFALSE(verbose)
96		)
97
98		# Scoping 'req', 'verbose'
99	10x	downloadfn <- function(query) {
100
101		# if 'query' is character, we assume we just got another URL including
102		# the query parameters. This is needed as req_url_query() modifies
103		# the query parameters, namely it escapes '%'s which breaks the request.
104	28x	if (is.character(query)) {
105	18x	req <- req \|> req_url(query)
106		} else {
107	10x	req <- req \|> req_url_query(!!!query)
108		}
109	10x	if (verbose) message("Sending request to ", req$url) # nocov
110
111		# Sending query = NULL would kill (remove) the parameters specified in URL
112	28x	resp <- req \|> req_perform()
113
114	28x	if (resp_is_error(resp)) {
115		# Trying to read the response and see if the API answered
116		# with an error message (error details). If so, that will be
117		# shown, else a more generic error will be displayed.
118	!	tmp <- tryCatch(resp_body_json(resp), error = function(x) NULL)
119	!	stop("Issues requesting data forom \"", url, "\"")
120		}
121
122		# Extracting content
123	28x	res <- resp \|> resp_body_json()
124	10x	if (!is.list(res)) stop("Result of http request no list (not JSON)") # nocov
125	28x	return(res)
126		}
127
128		# No paging expected/required we simply do cone request
129		# and return the result we get (the 'raw' encoded list)
130	!	if (!paging) return(downloadfn(query = NULL))
131
132		# Else we have to send an initial request first and check
133		# if we get a 'next' link which allows us to request the
134		# next page (or block) of results (using the default
135		# limit = 100L).
136
137		# Initial request, check for 'next' link. `get_link_next`
138		# returns a character (url) if we have to do another
139		# request (while loop), else `NULL`.
140	10x	tmp <- downloadfn(query = list(limit = limit))
141	10x	link_next <- get_link_next(tmp)
142
143		# Store initial result as a list
144	10x	res <- list(tmp)
145
146		# As long as we get a 'next' link there is an additional
147		# batch to download.
148	10x	while (is.character(link_next)) {
149	18x	tmp <- downloadfn(link_next)
150	18x	res[[length(res) + 1L]] <- tmp
151	18x	link_next <- get_link_next(tmp)
152		}
153
154	10x	return(res)
155		}
156
157		# Auxilary function to extract the 'next' link from a previous
158		# items request. If not found (i.e., no additional next batch
159		# to be processed) NULL is returned, else the URL for the next
160		# get request.
161		get_link_next <- function(x) {
162	28x	stopifnot(
163	28x	"argument 'x' expected to be list" = is.list(x),
164	28x	"expected list 'x' to contain $links" = !is.null(x$links)
165		)
166	28x	x <- x$links
167	28x	idx <- which(sapply(x, function(k) k$rel == "next"))
168	28x	return(if (!length(idx) == 1L) NULL else x[[idx]]$href)
169		}
170
171
172		# Extract query parameters from URI
173		#####get_query_from_url <- function(x) {
174		##### x <- regmatches(x, regexpr("(?<=(\\?)).*", x, perl = TRUE))
175		##### if (length(x) == 0L \|\| nchar(x) == 0L) return(NULL)
176		##### # Extracting parameters, creating list
177		##### q <- lapply(strsplit(x, "&"), strsplit, "=")[[1]]
178		##### if (!all(sapply(q, length) == 2L))
179		##### stop("Problems extracting query parameters from URL (key-value pairs): ", x)
180		##### # Create named list and return
181		##### lapply(q, function(x) x[[2L]]) \|> setNames(lapply(q, function(x) x[[1L]]))
182		#####}
183
184		#' Collections
185		#'
186		#' Requesting a list of all available collections provided via the API.
187		#'
188		#' @param pattern `NULL` or a pattern used return a subset of all
189		#' available collections, applied to the collection ID.
190		#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
191		#' some messages are printed.
192		#' @param raw logical, defaults to `FALSE` (see Return).
193		#'
194		#' @return Returns a tibble data frame with the available collections.
195		#' If `pattern = NULL` all collections found are returned. If
196		#' a `pattern` is specified, all collections where the collection ID
197		#' (`id`) matches the pattern are returned. If no IDs match the
198		#' pattern, a warning is thrown and `NULL` is returned.
199		#'
200		#' If `raw = TRUE` is specified, `pattern` is ignored and the raw
201		#' data as retrieved by the API are returned as a list of lists.
202		#' Each element of the list corresponds to one API call containing
203		#' a set of lists corresponding to the different collections returned.
204		#'
205		#' @examples
206		#' \dontrun{
207		#' ## Fetch all available collections
208		#' collections <- sg_collections()
209		#'
210		#' ## Extract collections by MeteoSchweiz
211		#' subset(res, grepl("meteoschweiz", id))
212		#' }
213		#'
214		#' @export
215		#' @author Reto
216		#'
217		#' @importFrom dplyr bind_rows
218		#' @importFrom sf st_bbox st_crs
219		#' @importFrom parsedate parse_date
220		sg_collections <- function(pattern = NULL, verbose = FALSE, raw = FALSE) {
221
222	7x	stopifnot(
223	7x	"argument 'pattern' must be NULL or a single non-empty character" =
224	7x	is.null(pattern) \|\|
225	7x	(is.character(pattern) && length(pattern) == 1L && nchar(pattern) > 0L),
226	7x	"argument 'raw' must be TRUE or FALSE" = isTRUE(raw) \|\| isFALSE(raw)
227		)
228
229		if (verbose) message("Retrieving collections") # nocov
230
231		# Downloading the data from the API. Each time the API returns up to
232		# 100 items, paging = TRUE calls the API until all items are fetched.
233	3x	res <- sg_send_api_request(getOption("swissgeo.req") \|> sg_change_url("collections"),
234	3x	paging = TRUE, verbose = verbose)
235
236	3x	extractfun <- function(x) {
237	1024x	stopifnot(is.list(x))
238	1024x	take <- c("id", "title", "description", "license", "created", "updated", "itemType")
239	1024x	res <- x[take[take %in% names(x)]]
240	1024x	if (!is.null(x[[c("summaries", "proj:epsg")]])) {
241	942x	res$crs <- x[[c("summaries", "proj:epsg")]][[1]]
242
243		# Spatial extent?
244	942x	if (!is.null(tmp <- x[[c("extent", "spatial")]])) {
245	942x	tmp <- tmp \|> unlist() \|> setNames(c("xmin", "ymin", "xmax", "ymax"))
246	942x	res$extent <- list(st_bbox(tmp, crs = res$crs))
247		}
248		}
249
250		# Temporal extent?
251	1024x	if (!is.null(tmp <- x[[c("extent", "temporal")]])) {
252	1024x	res$data_from <- parse_date(unlist(tmp)[1L])
253	1024x	res$data_to <- parse_date(unlist(tmp)[2L])
254		}
255
256	1024x	return(res)
257		}
258
259	1x	if (raw) return(do.call(c, res))
260
261		if (verbose) message("Preparing data frame for the return") # nocov
262	2x	res <- lapply(res, function(x) bind_rows(lapply(x$collections, extractfun))) \|> bind_rows()
263	2x	if (!is.null(pattern)) {
264	2x	idx <- grep(pattern, res$id)
265	2x	if (length(idx) == 0L) {
266	1x	warning("No collection ids matching ", pattern, ", returning NULL.")
267	1x	return(NULL)
268		}
269	1x	res <- res[idx, ]
270		}
271
272		# Converting columns containing ISO 8601 datetime information
273		# from character to POSIXct
274	1x	return(res \|> autoconvert_datetime())
275		}
276
277		#' Collection Items
278		#'
279		#' Retrieving all items of a specific collection.
280		#'
281		#' @param id character, ID of the collection for which to retrieve
282		#' the items (see [sg_collections()]).
283		#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
284		#' some messages are printed.
285		#' @param raw logical, defaults to `FALSE` (see Return).
286		#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
287		#' some messages are printed.
288		#'
289		#' @return
290		#' If `raw = TRUE` a list of lists is returned with the
291		#' raw (json decoded) result from the API calls. Each element in
292		#' the list corresponds to one API call (paging).
293		#'
294		#' Else (default) the function tries to auto-detect the format.
295		#' As an example, if the returned data are of type "FeatureCollection"s
296		#' The data is converted to a simple feature data frame which is
297		#' then returned. If now only "FeatureCollection" is implemented,
298		#' if the returned data is of a different type the raw list
299		#' is returned (TODO).
300		#'
301		#' @examples
302		#' \dontrun{
303		#' ## Retrieving items for a collection w/ features
304		#' CID <- "ch.meteoschweiz.ogd-smn"
305		#' items <- sg_items(CID)
306		#'
307		#' ## Visualizing the features
308		#' library("ggplot2")
309		#' ggplot(st_transform(items, crs = st_crs(2056))) +
310		#' geom_sf(col = "lightgreen") + geom_sf_text(aes(label = id))
311		#' }
312		#'
313		#' @export
314		#' @author Reto
315		#'
316		#' @importFrom stats setNames
317		#' @importFrom sf st_as_sf st_crs
318		sg_items <- function(id, raw = FALSE, verbose = FALSE) {
319
320	9x	raw <- as.logical(raw)[[1L]]
321	9x	verbose <- as.logical(verbose)[[1L]]
322
323	9x	stopifnot(
324	9x	"argument `id` must be character of length 1" =
325	9x	is.character(id) && length(id) == 1L && nchar(id) > 0L,
326	9x	"argument `raw` must evaluate to TRUE or FALSE" = isTRUE(raw) \|\| isFALSE(raw),
327	9x	"argument `verbose` must evaluate to TRUE or FALSE" = isTRUE(verbose) \|\| isFALSE(verbose)
328		)
329
330		if (verbose) message("Retrieving items") # nocov
331
332		# Downloading the data from the API. Each time the API returns up to
333		# 100 items, paging = TRUE calls the API until all items are fetched.
334	4x	res <- sg_send_api_request(getOption("swissgeo.req") \|>
335	4x	sg_change_url("collections", id, "items"),
336	4x	paging = TRUE, verbose = verbose)
337
338		# RAW results requested? Job done ...
339	1x	if (raw) return(res)
340
341		# Else we try to prepare the data in an R object. First, ensure
342		# that the data all match by type. TODO: Not sure if there is a
343		# situation where it can happen to get different types of data
344		# from one single API end point; but leaving it in here for now.
345	3x	type <- sapply(res, function(x) x$type)
346	3x	if (!all(type == type[[1]]))
347	!	stop("Not all item type identical, got ", paste(unique(type), collapse = ", "))
348	3x	type <- type[[1]] # Our type
349
350		# Feature type? Create simple features data.frame
351	3x	if (type == "FeatureCollection") {
352		# Extracting features
353	3x	res <- do.call(rbind, lapply(res, items_extract_features))
354	3x	res <- res \|> dataframe_to_sf(verbose = verbose)
355		}
356
357	3x	return(res \|> autoconvert_datetime())
358		}
359
360		#' Collection Assets
361		#'
362		#' Retrieving all assets of a specific collection.
363		#'
364		#' @param id character, ID of the collection for which to retrieve
365		#' the items (see [sg_collections()]).
366		#' @param raw logical, defaults to `FALSE` (see Return).
367		#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
368		#' some messages are printed.
369		#'
370		#' @return A tbl data frame containing the asset details is returned.
371		#'
372		#' If `raw = TRUE` a list of lists is returned with the raw (json decoded)
373		#' result from the API calls. Each element in the list corresponds to one API
374		#' call (paging).
375		#'
376		#' @export
377		#' @author Reto
378		#'
379		#' @importFrom dplyr bind_rows
380		sg_assets <- function(id, raw = FALSE, verbose = FALSE) {
381
382	8x	verbose <- as.logical(verbose)[[1L]]
383	8x	raw <- as.logical(raw)[[1L]]
384
385	8x	stopifnot(
386	8x	"argument 'id' must be character of length 1" =
387	8x	is.character(id) && length(id) == 1L && nchar(id) > 0L,
388	8x	"argument `raw` must evaluate to single TRUE or FALSE" = isTRUE(raw) \|\| isFALSE(raw),
389	8x	"argument `verbose` must evaluate to single TRUE or FALSE" = isTRUE(verbose) \|\| isFALSE(verbose)
390		)
391
392		if (verbose) message("Retrieving assets") ## nocov
393
394		# Downloading the data from the API. Each time the API returns up to
395		# 100 items, paging = TRUE calls the API until all items are fetched.
396	3x	res <- sg_send_api_request(getOption("swissgeo.req") \|>
397	3x	sg_change_url("collections", id, "assets"),
398	3x	paging = TRUE, verbose = verbose)
399
400		# RAW results requested? Job done ...
401	1x	if (raw) return(res)
402
403		# Extracting asset details and return as data.frame
404	2x	fn <- function(x) x[which(sapply(x, is.atomic))]
405	2x	res <- bind_rows(lapply(res, function(x) lapply(x$assets, fn)))
406
407	2x	return(autoconvert_datetime(res))
408		}
409
410		## #' Data Inventory
411		## #'
412		## #' Downloading data inventory of a specific data set collection.
413		## #'
414		## #' @param id character, ID of the collection for which to retrieve
415		## #' the items (see [sg_collections()]).
416		## #' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
417		## #' some messages are printed.
418		## #'
419		## #' @return If `raw = TRUE` a list of lists is returned with the
420		## #' raw (json decoded) result from the API calls. Each element in
421		## #' the list corresponds to one API call (paging).
422		## #'
423		## #' @export
424		## #' @author Reto
425		## #'
426		## #' @importFrom stats setNames
427		## #' @importFrom utils read.csv2
428		## sg_inventory <- function(id, verbose = FALSE, raw = FALSE) {
429		##
430		## stopifnot(
431		## "argument 'id' must be character of length 1" =
432		## is.character(id) && length(id) == 1L && nchar(id) > 0L,
433		## "argument 'raw' must be TRUE or FALSE" = isTRUE(raw) \|\| isFALSE(raw)
434		## )
435		##
436		## # Generate expected API end point
437		## url <- sg_change_url("collections", id, "assets")
438		##
439		## if (verbose) message("Retrieving items") # nocov
440		##
441		## # Downloading the data from the API. Each time the API returns up to
442		## # 100 items, paging = TRUE calls the API until all items are fetched.
443		## res <- sg_send_api_request(req, paging = TRUE, verbose = verbose)
444		##
445		## # RAW results requested? Job done ...
446		## if (raw) return(res)
447		##
448		## # Else we try to prepare the data in an R object
449		## type <- sapply(res, function(x) x$type)
450		## if (!all(type == type[[1]])) {
451		## # TODO: Is that possible?
452		## stop("Not all item type identical, got ", paste(unique(type), collapse = ", "))
453		## }
454		## type <- type[[1]] # Our type
455		##
456		## # Feature type? Create simple features data.frame
457		## if (type == "FeatureCollection") {
458		## # Extracting features
459		## res <- do.call(rbind, lapply(res, items_extract_features))
460		## }
461		##
462		## # Convert data frame to simple features data frame
463		## return(st_as_sf(res, coords = c("lon", "lat"), crs = st_crs(4326)))
464		## }
465

1
2
3		#' Setting `swissgeo` Options
4		#'
5		#' Allows the user to overwrite a series of default options used in
6		#' the package, mainly fine-tuning how the HTTPS requests are handled.
7		#'
8		#'
9		#' @param timeout positive numeric, forwarded to [httr2::req_timeout()].
10		#' Defaults to 20 seconds.
11		#' @param retry positive integer, forwarded to [httr2::req_retry()].
12		#' Defaults to `3` (three retries).
13		#' @param capacity positive integer, forwarded to [httr2::req_throttle()].
14		#' Defaults to size 3.
15		#' @param filltime positive numeric, forwarded to [httr2::req_throttle()].
16		#' Defaults to size 3.
17		#' @param apiurl `NULL` (default) or character. Allows to overwrite the
18		#' main URL (mainly for testing).
19		#' @param verbose logical, defaults to `FALSE`.
20		#'
21		#' @details A series of default options is set every time the package
22		#' is attached. They can be overruled by the user calling this function.
23		#'
24		#' @return Invisibly returns the current swissgeo settings, these are used
25		#' in the `sg_*` functions for request handling.
26		#'
27		#' @author Reto
28		#' @export
29		sg_options <- function(timeout = 20, retry = 3, capacity = 3, filltime = 3,
30		apiurl = NULL, verbose = FALSE) {
31
32	3x	verbose <- as.logical(verbose)[[1L]]
33	3x	stopifnot("argument `verbose` must evaluate to TRUE or FALSE" =
34	3x	isTRUE(verbose) \|\| isFALSE(verbose))
35
36	2x	if (!is.null(apiurl)) options("swissgeo.apiurl" = apiurl)
37
38		# Setting defaults for timeout, retry, and bucket
39		# swissgeo.httr2_timeout: Defaults to 20 seconds (handed over to req_timeout())
40		# swissgeo.httr2_retry: Defaults to 3 times (handed over to req_retry())
41		# swissgeo.httr2_capacity: Defaults to size 3 (handed over to req_throttle())
42		# swissgeo.httr2_filltime: Defaults to 3 second (handed over to req_throttle())
43		# Note: swissgeo.httr2_capacity = 3 w/ swissgeo.httr2_filltime = 1 results in
44		# a maximum of three reqeuests per second.
45	2x	options("swissgeo.httr2_timeout" = timeout)
46	2x	options("swissgeo.httr2_retry" = retry)
47	2x	options("swissgeo.httr2_capacity" = capacity)
48	2x	options("swissgeo.httr2_filltime" = filltime)
49
50		# Setting up new requests object
51	2x	options("swissgeo.req" = sg_get_req())
52
53	2x	opts <- grep("^swissgeo\\.", names(options()), value = TRUE)
54
55		## nocov start
56		if (verbose) {
57		message("swissgeo options:")
58		for (o in opts) {
59		tmp <- getOption(o)
60		if (o == "swissgeo.req") tmp <- deparse(class(tmp))
61		message(paste0(" - ", o, ": ", tmp))
62		}
63		}
64		## nocov end
65
66	2x	invisible(options()[opts])
67		}

1
2		#' Modify Request URL
3		#'
4		#' Modifies the URL of an existing `httr2_request` object.
5		#'
6		#' @param req object of class `httr2_request`.
7		#' @param ... additional arguments to extend the base API URL.
8		#' All arguments (after coercion to character) must represent
9		#' valid non-empty characters.
10		#'
11		#' @return Returns a modified version of the input argument `req` with
12		#' an updated (API) URL.
13		#'
14		#' @importFrom httr2 req_url_path_append
15		#' @author Reto
16		sg_change_url <- function(req, ...) {
17	15x	stopifnot(
18	15x	"argument `req` must be an object of class \"httr_request\"" =
19	15x	inherits(req, "httr2_request")
20		)
21	13x	req \|> req_url_path_append(...)
22		}
23
24		# TODO(R): Adjust to httr2 or remove
25		### #' Show HTTP Error Status and Terminate
26		### #'
27		### #' This function is called whenever \code{httr::GET} returns an
28		### #' http status code out of the \code{200} range (success).
29		### #' Shows \code{\link[httr]{http_status}} code information alongside
30		### #' with additional messages returned by the API (if any).
31		### #'
32		### #' @param scode numeric, http status code.
33		### #' @param xtra \code{NULL} or named list with additional information.
34		### #'
35		### #' @return No return, will terminate R.
36		### #'
37		### #' @author Reto Stauffer
38		### #' @importFrom httr http_status
39		### # Show http_status message if possible.
40		### show_http_status_and_terminate <- function(scode, xtra = NULL) {
41		###
42		### stopifnot("argument 'scode' must be numeric of length 1L" =
43		### is.numeric(scode), length(scode) == 1)
44		### if (scode %/% 100 == 2) return(NULL)
45		###
46		### # Given we have to deal with the return code, ensure
47		### # 'xtra' is a named list or NULL
48		### stopifnot("argument 'xtra' must be NULL or a named list of length > 0L" =
49		### is.null(xtra) \|\| (is.list(xtra) && !is.null(names(xtra)) && length(xtra) > 0L))
50		###
51		### cat('---\n')
52		###
53		### info <- tryCatch(http_status(scode),
54		### error = function(x) NULL)
55		###
56		### # Depending on the status code these are somewhat redundant
57		### if (!is.null(xtra))
58		### xtra <- paste(c(" status returned by API:",
59		### sprintf(" %-20s %s", sprintf("%s:", names(xtra)), xtra)),
60		### collapse = "\n")
61		### if (!is.null(info))
62		### info <- paste(c(" http_status description:",
63		### sprintf(" %-20s %s", sprintf("%s:", names(info)), info)),
64		### collapse = "\n")
65		###
66		### if (is.null(info) & is.null(xtra)) {
67		### stop("HTTP request error: server returned status code ", scode)
68		### } else {
69		### stop(paste("HTTP request error", xtra, info, sep = "\n"))
70		### }
71		### }
72
73
74		#' Converting Datetime Columns
75		#'
76		#' Takes a data frame as input and tries to identify columns
77		#' containing datetime information.
78		#'
79		#' @param x data frame.
80		#'
81		#' @return Data frame with POSIXct variables if any variable
82		#' containing datetime information was detected.
83		#'
84		#' @details Data received by the API or read via the files
85		#' provided regularey contain date or datetime information
86		#' as character strings.
87		#'
88		#' This function takes a data frame and tries to identify
89		#' variables/columns containing date and time information
90		#' to coerce the information into Date or POSIXct objects.
91		#' Currently, the following formats are checked currently:
92		#'
93		#' * `2026-01-16T17:34:34(...)Z`: converted to POSIXct
94		#' * `16.01.2026`: converted to Date
95		#' * `2026-01-16`: converted to Date
96		#' * `16.01.2026 12:03`: converted to POSIXct w/ time zone Europe/Zuerich
97		#' * `16.01.2026 00:00`: converted to Date
98		#'
99		#' @examples
100		#' \dontrun{
101		#' autoconvert_datetime(data.frame(a = 1, b = "2026-01-16T12:34:56.23435Z"))
102		#' autoconvert_datetime(data.frame(a = 1, b = "2026-01-16T12:34:56Z"))
103		#' autoconvert_datetime(data.frame(a = 1, b = "16.01.2026 12:34"))
104		#' autoconvert_datetime(data.frame(a = 1, b = "16.01.2026 00:00"))
105		#' autoconvert_datetime(data.frame(a = 1, b = "16.01.2026"))
106		#' autoconvert_datetime(data.frame(a = 1, b = "2026-01-16"))
107		#' }
108		#'
109		#' @author Reto
110		#' @importFrom parsedate parse_iso_8601
111		autoconvert_datetime <- function(x) {
112	366x	stopifnot(is.data.frame(x))
113	1x	if (nrow(x) == 0L) return(x)
114
115	364x	get_idx <- function(x, pattern) {
116	1456x	tmp <- sapply(x, function(x) grepl(pattern, x) \| is.na(x))
117	1456x	which(if (is.matrix(tmp)) colSums(tmp) == nrow(x) else tmp)
118		}
119
120		# Checking for ISO8601 format (Y-m-dTH:M:S..) and convert, if found
121	364x	idx <- get_idx(x, "^[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}")
122	364x	for (i in idx) x[[i]] <- parse_iso_8601(x[[i]])
123
124		# Checking for 'german date' and convert, if found.
125	364x	idx <- get_idx(x, "^[0-9]{2}.[0-9]{2}.[0-9]{4}$")
126	14x	for (i in idx) x[[i]] <- as.Date(x[[i]], format = "%d.%m.%Y")
127
128		# Checking for 'date' and convert, if found.
129	364x	idx <- get_idx(x, "^[0-9]{4}-[0-9]{2}-[0-9]{2}$")
130	19x	for (i in idx) x[[i]] <- as.Date(x[[i]], format = "%Y-%m-%d")
131
132		# Checking for 'german date and time' and convert, if found.
133	364x	idx <- get_idx(x, "^[0-9]{2}.[0-9]{2}.[0-9]{4}\\s+[0-9]{2}:[0-9]{2}")
134	8x	for (i in idx) x[[i]] <- as.POSIXct(x[[i]], format = "%d.%m.%Y %H:%M", tz = "Europe/Zurich")
135
136	364x	return(x)
137		}
138
139
140		#' Convert Dataframe to Simple Feature Dataframe
141		#'
142		#' Many data sets retrieved via the Geoportal are geolocated, providing
143		#' coordinates of e.g., a station location. This function tries to auto-detect
144		#' locations, converting a dataframe into a simple feature dataframe.
145		#'
146		#' @param x a data frame which (potentially) contains coordinates.
147		#' @param use_crs character, order of coordinate reference to use (if found).
148		#' @param verbose logical, defaults to `FALSE`. If set `TRUE` the
149		#' some messages are printed.
150		#'
151		#' @details Some data sets like station locations come their geolocation (coordinates),
152		#' sometimes given in two different reference systems. This function takes a
153		#' data frame and checks if it can find coordinates. If found, the object is
154		#' converted into a simple feature data frame dropping all coordinates from the
155		#' data part.
156		#'
157		#' @return If no matching coordinates are found, `x` is returned as is. Else
158		#' `x` is converted into a simple feature data frame, removing all coordinate
159		#' related columns.
160		#'
161		#' @importFrom sf st_as_sf st_crs
162		dataframe_to_sf <- function(x, use_crs = c("lv95", "wgs84"), verbose = FALSE) {
163	25x	stopifnot("argument `x` must be a data frame" = is.data.frame(x))
164	24x	use_crs <- match.arg(use_crs, several.ok = TRUE)
165
166		# Renaming 'lon' to 'coordinates_wgs84_east' and
167		# 'lat' to 'coordinates_wgs84_north' if both are found.
168	22x	if (length(grep("^(lon\|lat)$", names(x))) == 2L) {
169	1x	names(x)[grep("^lon$", names(x))] <- "coordinates_wgs84_lon"
170	1x	names(x)[grep("^lat$", names(x))] <- "coordinates_wgs84_lat"
171		}
172
173		# Check for coordinate columns
174	22x	coord_cols <- grep("coordinates_", names(x), value = TRUE)
175	7x	if (length(coord_cols) == 0L) return(x) # No coordinates found
176
177	15x	fn <- function(z) {
178		# Currently only prepared
179	26x	tmp <- switch(z,
180	26x	lv95 = list(postfix = c("east", "north"), crs = 2056L),
181	26x	wgs84 = list(postfix = c("lon", "lat"), crs = 4326L)
182		)
183	26x	tmp$columns <- sprintf("coordinates_%s_%s", z, tmp$postfix)
184	26x	tmp$columns <- sapply(tmp$columns, function(k) grep(k, names(x), value = TRUE))
185	26x	tmp$found <- is.character(tmp$columns) && length(tmp$columns) == 2L # Both columns in the data frame?
186	26x	return(tmp)
187		}
188
189		# Check what we have, if we can't find the required columns we return x as is
190	15x	coords_check <- lapply(use_crs, fn)
191	15x	i <- which(sapply(coords_check, function(x) x$found))
192	15x	if (length(i) == 0L) {
193		if (verbose) message("No coordinates found") ## nocov
194	1x	return(x)
195		}
196
197		# Take first match
198	14x	coords <- coords_check[min(i)]
199
200		# Else we convert the data frame to a simple feature data frame and remove
201		# all coordinate related columns.
202		if (verbose) message(sprintf("Found coordinates \"%s\" (crs = %d), converting", names(coords), coords[[1]]$crs)) ## nocov
203	14x	x <- st_as_sf(x, coords = coords[[1]]$columns, crs = st_crs(coords[[1]]$crs))
204	14x	return(x[, !names(x) %in% coord_cols])
205
206		}
207
208
209

1
2
3		#' Assets
4		#'
5		#' Each item as returned by [sg_items()] can provide multiple assets. An asset
6		#' specifies the type of data (e.g., historical, recent) as well as the
7		#' temporal resolution of the data and the data period (if suitable). The
8		#' `sg_assets` class is used to handle these assets within the package.
9		#'
10		#' @param x list of named lists containing the asset details.
11		#'
12		#' @return An asset data frame with the name of the asset and all provided
13		#' additional information.
14		#'
15		#' @author Reto
16		#'
17		#' @importFrom dplyr bind_rows
18		assets <- function(x) {
19	9x	stopifnot(
20	9x	"argument 'x' must be an unnamed list (of assets)" =
21	9x	is.list(x) && is.null(names(x)),
22	9x	"elements in 'x' must be named lists" =
23	9x	all(sapply(x, function(y) is.list(y) && !is.null(names(y))))
24		)
25
26	6x	fn <- function(x)
27	6x	cbind(data.frame(name = names(x)), bind_rows(x)) \|> autoconvert_datetime()
28	6x	return(structure(lapply(x, fn), class = "assets"))
29		}
30
31
32		#' @param x object of class 'assets'.
33		#' @exportS3Method format assets
34		#' @rdname assets
35		#' @author Reto
36		format.assets <- function(x, ...) {
37	1x	sprintf("assets: %d", sapply(x, function(y) length(y[[1]])))
38		}
39
40		#' @exportS3Method print assets
41		#' @rdname assets
42		#' @author Reto
43		print.assets <- function(x, ...) {
44	4x	fn <- function(i) {
45	4x	y <- x[[i]]
46	4x	c(sprintf("[%d] Assets: %d", i, nrow(y)),
47	4x	sprintf(" [%s] %s", y$type, y$name))
48		}
49	4x	res <- do.call(c, lapply(seq_along(x), fn))
50	4x	cat(res, sep = "\n")
51	4x	invisible(x)
52		}
53
54		#' @param i elements to extract or replace. Numeric values coerced
55		#' to integer identifying the `i`th element(s) for subsetting.
56		#'
57		#' @exportS3Method `[` assets
58		#' @rdname assets
59		#' @author Reto
60		`[.assets` <- function(x, i, ...) {
61	4x	out <- NextMethod()
62	4x	return(structure(out, class = class(x)))
63		}
64
65		#' @exportS3Method as.double assets
66		#' @rdname assets
67		#' @author Reto
68	2x	as.double.assets <- function(x, ...) sapply(x, function(y) length(y[[1]]))
69
70		#' @exportS3Method names assets
71		#' @rdname assets
72		#' @author Reto
73		names.assets <- function(x) {
74	11x	res <- lapply(x, function(y) y$name)
75	11x	return(if (length(res) == 1L) res[[1]] else res)
76		}
77
78		#' @param row.names `NULL` (default) or a character vector giving the row names for
79		#' the data frame. Only used if `x` is of length 1L.
80		#' @param optional currently ignored.
81		#' @param \dots currently ignored.
82		#'
83		#' @exportS3Method as.data.frame assets
84		#' @rdname assets
85		#' @author Reto
86		#'
87		#' @importFrom dplyr bind_rows
88		as.data.frame.assets <- function(x, row.names = NULL, optional = NA, ...) {
89		# TODO(R): nUntested, currently returns an unnamed list of dfs - intended?
90	1x	res <- lapply(x, function(y) structure(y, class = "data.frame")) \|> bind_rows()
91	1x	if (!is.null(row.names) && is.data.frame(res))
92	!	rownames(res) <- row.names
93	1x	return(res)
94		}
95

1
2
3		.onAttach <- function(libname, pkgname) {
4	2x	packageStartupMessage("
5	2x	TODO: Startup message with some information to geo.admin.ch and
6	2x	how to cite the data if used, though that is tricky as it is
7	2x	different for different data sets and must be found somewhere
8	2x	on the data providers home page.
9		")
10
11		# Currently version 1 (v1); can be overruled by overwriting
12		# the option using `options(swissgeo.apiurl = ...)`.
13	2x	apiurl <- sprintf("https://data.geo.admin.ch/api/stac/v%d", 1L)
14	2x	options("swissgeo.apiurl" = apiurl)
15
16		# Setting defaults for timeout, retry, and bucket
17		# swissgeo.httr2_timeout: Defaults to 20 seconds (handed over to req_timeout())
18		# swissgeo.httr2_retry: Defaults to 3 times (handed over to req_retry())
19		# swissgeo.httr2_capacity: Defaults to size 3 (handed over to req_throttle())
20		# swissgeo.httr2_filltime: Defaults to 3 second (handed over to req_throttle())
21		# Note: swissgeo.httr2_capacity = 3 w/ swissgeo.httr2_filltime = 1 results in
22		# a maximum of three reqeuests per second.
23	2x	options("swissgeo.httr2_timeout" = 20)
24	2x	options("swissgeo.httr2_retry" = 3)
25	2x	options("swissgeo.httr2_capacity" = 3)
26	2x	options("swissgeo.httr2_filltime" = 1)
27
28	2x	options("swissgeo.req" = sg_get_req())
29
30		}
31
32		#' @importFrom httr2 request req_timeout req_retry req_throttle
33		sg_get_req <- function() {
34	5x	req <- request(getOption("swissgeo.apiurl")) \|>
35	5x	req_timeout(getOption("swissgeo.httr2_timeout")) \|>
36	5x	req_retry(getOption("swissgeo.httr2_retry")) \|>
37	5x	req_throttle(capacity = getOption("swissgeo.httr2_capacity"),
38	5x	fill_time_s = getOption("swissgeo.httr2_filltime"))
39
40	5x	return(req)
41		}