R/utils.R

In finbif: Interface for the 'Finnish Biodiversity Information Facility' API

# misc -------------------------------------------------------------------------
#' @noRd
get_el_recurse <- function(
  obj,
  nms,
  type
) {
  if (length(nms) < 1L) {
    if (is.null(obj) || identical(obj, "")) {
      obj <- switch(
        type,
        double = NA_real_,
        integer = NA_integer_,
        logical = NA,
        NA_character_
      )
    }

    return(obj)
  }

  nm <- nms[[1L]]
  obj_names <- names(obj)
  has_name <- FALSE

  if (is.null(obj_names)) {
    for (i in obj) {
      has_name <- nm %in% names(i)

      if (has_name) {
        break
      }

    }
  }

  next_obj <- getElement(obj, nm)

  if (has_name) {
    next_obj <- lapply(obj, getElement, nm)
    null_elements <- vapply(next_obj, is.null, NA)
    next_obj[null_elements] <- switch(
      type,
      double = NA_real_,
      integer = NA_integer_,
      logical = NA,
      NA_character_
    )
    next_obj <- unlist(next_obj, recursive = FALSE)
  }

  get_el_recurse(next_obj, nms[-1L], type)
}

#' @noRd
truncate_string <- function(
  x,
  sl = 20L
) {
  x <- as.character(x)
  x_sl <- substr(x, 1L, sl - 1L)
  x_sl <- sprintf("%s\u2026", x_sl)
  too_many_chars <- nchar(x) > sl
  ifelse(too_many_chars, x_sl, x)
}

#' @noRd
truncate_string_to_unique <- function(x) {
  ind <- !is.na(x)
  y <- x[ind]
  i <- 0L
  cond <- TRUE

  while (cond) {
    substr(y, i, i) <- " "
    i <- i + 1L
    unique_y <- unique(y)
    cond <- length(unique_y) > 1L && char_all_equal(y, i)
  }

  y_trimmed <- trimws(y)
  unchanged <- y == y_trimmed
  y_trimmed <- paste0("\u2026", y_trimmed)
  y <- ifelse(unchanged, y, y_trimmed)
  x[ind] <- y
  x
}

#' @noRd

char_all_equal <- function(
  x,
  i
) {
  chars <- substr(x, i, i)
  all(chars == chars[[1L]])
}

#' @noRd
value <- function(obj) {
  obj
}

#' @noRd
col_type_string <- function(dwc) {
  ans <- "translated_var"

  if (dwc) {
    ans <- "dwc"
  }

  ans
}

#' @noRd
has_pkgs <- function(...) {
  pkgs <- list(...)
  ans <- vapply(pkgs, requireNamespace, NA, quietly = TRUE)
  all(ans)
}

#' @noRd
name_chr_vec <- function(
  x = NULL,
  unique = TRUE,
  na_rm = TRUE
) {

  if (!is.null(x)) {
    stopifnot("'x' is not a character vector" = inherits(x, "character"))

    if (na_rm) {
      x <- x[!is.na(x)]
    }

    nms <- names(x)

    if (is.null(nms)) {
      nms <- x
    } else {
      nms <- ifelse(nms == "", x, nms)
    }

    if (unique) {
      nms <- make.unique(nms)
    }

    names(x) <- nms
  }

  x
}

#' @noRd
remove_domain <- function(x) {
  sub("^http://tun.fi/", "", x)
}

#' @noRd
concat_string <- function(x) {
  ans <- NA_character_
  not_na <- !is.na(x)

  if (any(not_na)) {
    ans <- paste(x[not_na], collapse = "; ")
  }

  ans
}

#' @noRd
concat_two_strings <- function(x, y) {
  concat_string(c(x, y))
}

#' @noRd
cast_to_type <- function(
  x,
  type
) {
  switch(
    type,
    double = as.double(x),
    integer = as.integer(x),
    logical = as.logical(x),
    gsub("\r\n", "\n", as.character(x))
  )
}

#' @noRd
all_na <- function(x) {
  na <- is.na(x)
  all(na)
}

#' @noRd
get_rows <- function(
  rows,
  df
) {
  df[rows, , drop = FALSE]
}

#' @noRd
cache_is_valid <- function(timeout, created) {
  timeout_offset <- getOption("finbif_timeout_offset")
  timeout_offset <- pmax(timeout_offset, 0)
  timeout_offset <- pmin(timeout_offset, 1)
  timeout_offset <- timeout_offset * 1000
  timeout_seq <- seq(1000 - timeout_offset, 1000 + timeout_offset)
  seq_length <- length(timeout_seq)
  timeout_secs <- timeout * timeout_seq[sample.int(seq_length, 1L)] * 3.6
  timeout_secs > difftime(Sys.time(), created, units = "secs")
}

# random sampling --------------------------------------------------------------
#' @noRd
sample_with_seed <- function(
  n,
  seed
) {
  if (exists(".Random.seed", 1L)) {
    oldseed <- get(".Random.seed", 1L)

    on.exit({
      assign(".Random.seed", oldseed, 1L)
    })

  }

  args <- list(seed, "default", "default")

  if (getRversion() >= "3.6.0") {
    args <- c(args, "default")
  }

  do.call(set.seed, args)
  sample.int(n)
}

#' @importFrom digest digest
#' @noRd
gen_seed <- function(x) {
  hash <- lapply(x, getElement, "hash")
  hash <- digest::digest(hash)
  hash <- substr(hash, 1L, 7L)
  strtoi(hash, 16L)
}

# errors -----------------------------------------------------------------------
# modified from https://github.com/reside-ic/defer/blob/master/R/defer.R
#' @noRd
deferrable_error <- function(message) {
  withRestarts(
    {
      calls <- sys.calls()
      i <- length(calls) - 1L
      i <- max(i, 1L)
      e <- error(message, "deferrable_error", call = calls[[i]], calls = calls)
      stop(e)
    },
    continue_deferrable_error = continue
  )
}

#' @noRd
continue <- function(...) {
  NULL
}

#' @noRd
defer_errors <- function(
  expr,
  handler = stop
) {
  errors <- list()
  calls <- sys.calls()

  value <- withCallingHandlers(
    expr,
    deferrable_error = function(e) {
      sq <- seq_along(calls)
      e_calls <- e[["calls"]]

      if (identical(calls[], e_calls[sq])) {
        l <- length(calls) + 1L
        e_calls <- e_calls[-seq_len(l)]
        e[["calls"]] <- e_calls
      }

      e_list <- list(e)
      errors <<- c(errors, e_list)
      invokeRestart("continue_deferrable_error")

    }
  )

  deferred_errors(errors, handler, calls, value)
}

#' @noRd
deferred_errors <- function(
  errors,
  handler,
  calls,
  value = NULL
) {

  if (length(errors) > 0L) {
    errors <- errors[!duplicated(lapply(errors, getElement, "message"))]
    err <- list(errors = errors, value = value)
    class(err) <- c("dfrd_errors", "error", "condition")
    handler(err)
  } else {
    value
  }

}

#' @noRd
error <- function(
  message,
  class,
  ...
) {
  message <- list(message = message, ...)
  structure(message, class = c(class, "error", "condition"))
}

#' @export
#' @noRd
conditionMessage.dfrd_errors <- function(c) {
  errors <- vapply(c[["errors"]], getElement, "", "message")
  n <- length(errors)
  n_errors <- ngettext(n, "error", "errors")
  errors <- paste0("  - ", errors, collapse = "\n")
  sprintf("%d %s occurred:\n%s", n, n_errors, errors)
}

# localization -----------------------------------------------------------------
#' @noRd
get_locale <- function() {
  ans <- "en"
  supported <- sysdata(list(which = "supported_langs"))
  matches <- name_chr_vec(c(unname(supported), supported))
  env <- Sys.getenv(c("LANGUAGE", "LANG"))
  collate <- Sys.getlocale("LC_COLLATE")

  for (l in c(env, collate)) {
    reg <- regexpr(".+?(?=[[:punct:]])", l, perl = TRUE)
    l <- regmatches(l, reg)

    if (isTRUE(l %in% names(matches))) {
      ans <- matches[[l]]
      break
    }

  }

  ans
}

#' @noRd
with_locale <- function(
  x,
  locale = getOption("finbif_locale")
) {
  l <- length(x)
  ans <- NA_character_

  if (identical(l, 1L)) {
    ans <- x[[1L]]
  } else if (l > 1L) {
    nms <- names(x)
    supported_langs <- sysdata(list(which = "supported_langs"))
    locales <- setdiff(supported_langs, locale)
    locales <- c(locale, locales)
    ind <- intersect(locales, nms)
    ind <- ind[[1L]]
    ans <- x[[ind]]
  }

  ans
}