R/helpfunctions.R

In metR: Tools for Easier Analysis of Meteorological Fields

# nocov start

# Helper functions for translation
catf = function(fmt, ..., sep = " ", domain = "R-metR") {
  cat(gettextf(fmt, ..., domain = domain), sep = sep)
}

stopf <- function(fmt, ..., call. = TRUE, domain = "R-metR") {
  x <- gettextf(fmt, ..., domain = domain)
  if (isTRUE(call.)) {
    call = sys.call(-1)
  } else {
    call = NULL
  }
  e <- simpleError(x, call = call)
  stop(e)
}


warningf <- function(
  fmt,
  ...,
  call. = TRUE,
  immediate. = FALSE,
  noBreaks. = FALSE,
  domain = "R-metR"
) {
  x <- gettextf(fmt, ..., domain = domain)
  if (isTRUE(call.)) {
    call = sys.call(-1)
  } else {
    call = NULL
  }
  e <- simpleWarning(x, call = call)
  warning(e)
}


messagef = function(fmt, ..., appendLF = TRUE, domain = "R-metR") {
  message(gettextf(fmt, ..., domain = domain), domain = NA, appendLF = appendLF)
}


.tidy2matrix <- function(data, formula, value.var, fill = NULL, ...) {
  row.vars <- all.vars(formula[[2]])
  col.vars <- all.vars(formula[[3]])
  data <- data.table::as.data.table(data)
  data[, row__ := .GRP, by = c(row.vars)]
  data[, col__ := .GRP, by = c(col.vars)]
  if (is.null(fill)) {
    fill <- 0
    # rowdims <- data[col__ == 1, (row.vars), with = FALSE]
    # coldims <- data[row__ == 1, (col.vars), with = FALSE]
  } else {
    # rowdims <- unique(data[, (row.vars), with = FALSE])
    # coldims <- unique(data[, (col.vars), with = FALSE])
  }
  rowdims <- unique(data[, (row.vars), with = FALSE])
  coldims <- unique(data[, (col.vars), with = FALSE])
  data.m <- matrix(
    fill[1],
    nrow = max(data[["row__"]]),
    ncol = max(data[["col__"]])
  )
  data.m[cbind(data[["row__"]], data[["col__"]])] <- data[[value.var]]

  return(list(matrix = data.m, coldims = coldims, rowdims = rowdims))
}


seq_range <- function(x, by = ggplot2::resolution(x, zero = FALSE), ...) {
  r <- range(x)
  seq.int(r[1], r[2], by = by, ...)
}

is.error <- function(x) inherits(x, "try-error")


# from data.table
#' @importFrom data.table %chin%
guess <- function(x) {
  if ("value" %chin% names(x)) {
    return("value")
  }
  if ("(all)" %chin% names(x)) {
    return("(all)")
  }
  var <- names(x)[ncol(x)]
  messagef("Using \"%s\" as value column. Use 'value.var' to override", var)
  return(var)
}

# from ggplot2
`%||%` <- function(a, b) {
  if (!is.null(a)) a else b
}
# from ggplot2
is.waive <- function(x) {
  inherits(x, "waiver")
}

# from ggplot2s
waiver <- function() {
  structure(list(), class = "waiver")
}

element_render <- function(theme, element, ..., name = NULL) {
  # Get the element from the theme, calculating inheritance
  el <- ggplot2::calc_element(element, theme)
  if (is.null(el)) {
    messagef("Theme element %s missing", element)
    return(ggplot2::zeroGrob())
  }

  grob <- ggplot2::element_grob(el, ...)
  ggname(paste(element, name, sep = "."), grob)
}

ggname <- function(prefix, grob) {
  grob$name <- grid::grobName(grob, prefix)
  grob
}


width_cm <- function(x) {
  if (grid::is.grob(x)) {
    grid::convertWidth(grid::grobWidth(x), "cm", TRUE)
  } else if (grid::is.unit(x)) {
    grid::convertWidth(x, "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, width_cm, numeric(1))
  } else {
    stopf("Unknown input.")
  }
}
height_cm <- function(x) {
  if (grid::is.grob(x)) {
    grid::convertHeight(grid::grobHeight(x), "cm", TRUE)
  } else if (grid::is.unit(x)) {
    grid::convertHeight(x, "cm", TRUE)
  } else if (is.list(x)) {
    vapply(x, height_cm, numeric(1))
  } else {
    stopf("Unknown input.")
  }
}

message_wrap <- function(...) {
  msg <- paste(..., collapse = "", sep = "")
  wrapped <- strwrap(msg, width = getOption("width") - 2)
  message(paste0(wrapped, collapse = "\n"))
}

.seq_range <- function(x, by = ggplot2::resolution(x, zero = FALSE), ...) {
  r <- range(x)
  seq.int(r[1], r[2], by = by, ...)
}


# Interleave (or zip) multiple units into one vector
interleave <- function(...) UseMethod("interleave")
#' @export
interleave.unit <- function(...) {
  do.call(
    "grid::unit.c",
    do.call("interleave.default", plyr::llply(list(...), as.list))
  )
}
#' @export
interleave.default <- function(...) {
  vectors <- list(...)

  # Check lengths
  lengths <- unique(setdiff(plyr::laply(vectors, length), 1))
  if (length(lengths) == 0) {
    lengths <- 1
  }
  stopifnot(length(lengths) <= 1)

  # Replicate elements of length one up to correct length
  singletons <- plyr::laply(vectors, length) == 1
  vectors[singletons] <- plyr::llply(vectors[singletons], rep, lengths)

  # Interleave vectors
  n <- lengths
  p <- length(vectors)
  interleave <- rep(1:n, each = p) + seq(0, p - 1) * n
  unlist(vectors, recursive = FALSE)[interleave]
}

matched_aes <- function(layer, guide, defaults) {
  all <- names(c(
    layer$mapping,
    if (layer$inherit.aes) defaults,
    layer$stat$default_aes
  ))
  geom <- c(layer$geom$required_aes, names(layer$geom$default_aes))
  matched <- intersect(intersect(all, geom), names(guide$key))
  matched <- setdiff(matched, names(layer$geom_params))
  setdiff(matched, names(layer$aes_params))
}

rename_aes <- function(x) {
  names(x) <- ggplot2::standardise_aes_names(names(x))
  duplicated_names <- names(x)[duplicated(names(x))]
  if (length(duplicated_names) > 0L) {
    duplicated_message <- paste0(unique(duplicated_names), collapse = ", ")
    warningf(
      "Duplicated aesthetics after name standardisation: %s",
      duplicated_message,
      call. = FALSE
    )
  }
  x
}

#' @importFrom stats line runif var
#' @importFrom utils head
#' @importFrom rlang .data
if (getRversion() >= "2.15.1") {
  utils::globalVariables(
    c(
      "as",
      "dep.names",
      "ecdf",
      "equal",
      "fft",
      "hasArg",
      "id",
      "ind.names",
      "inside",
      "int.level",
      "land",
      "latrad",
      "lon",
      "lonrad",
      "piece",
      "psi",
      "psi.dx",
      "psi.dxx",
      "psi.dxy",
      "psi.dy",
      "psi.dyy",
      "r2",
      "sd",
      "time",
      "u.mean",
      "v.mean",
      "x",
      "y",
      "z",
      ".",
      "time2",
      "group",
      "step",
      "point",
      "change",
      "end",
      "level",
      "m",
      "rotate",
      "x.d",
      "y.d",
      "PC",
      "step2",
      "N",
      "angle",
      "var",
      "col__",
      "row__",
      "t1",
      "z1",
      "z2",
      "..n",
      ".N",
      ":=",
      ".SD",
      ".I",
      ".GRP"
    )
  )
}


.has_single_value <- function(data, coords) {
  lengths <- data[, .N, by = coords]$N
  !any(lengths > 1)
}


.is.regular_grid <- function(x, y, dups_allowed = FALSE) {
  data <- data.table::data.table(x = x, y = y)
  nx <- data[, data.table::uniqueN(x), by = y]$V1
  ny <- data[, data.table::uniqueN(y), by = x]$V1

  xs <- data.table::uniqueN(data$x)
  ys <- data.table::uniqueN(data$y)

  # Conditions for regular grid
  # 1. each y has the same number of unique values of x
  # 2. each x has the same number of unique values of y
  regularity <- sum(abs(ys - ny)) == 0 & sum(abs(xs - nx)) == 0

  if (dups_allowed) {
    return(regularity)
  }

  # 3. there are no duplicated values
  lengths <- data[, .N, by = .(x, y)]$N
  unicity <- !any(lengths > 1)

  regularity & unicity
}

.simple.scale <- function(x) {
  r <- range(x)
  (x - r[1]) / diff(r)
}

isFALSE <- function(x) {
  is.logical(x) && length(x) == 1L && !is.na(x) && !x
}

.pasteand <- function(x) {
  l <- length(x)
  paste0(paste0(x[-l], collapse = ", "), " and ", x[l])
}

checkListSameLengh <- function(x, names = "x") {
  l <- lengths(x)
  if (slow_equal(l)) {
    return(TRUE)
  }

  if (isTRUE(names)) {
    names <- .pasteand(names(x))
  } else {
    names <- paste0("Elements of ", names)
  }

  return(paste0(names, " must have the same length"))
}

assertListSameLength <- checkmate::makeAssertionFunction(checkListSameLengh)

# fast_equal = inline::cxxfunction(signature(x = 'numeric', y = 'numeric'), '
#   NumericVector var(x);
#   double precision = as<double>(y);
#
#   for (int i = 0, size = var.size(); i < size; ++i) {
#     if (var[i] - var[0] > precision || var[0] - var[i] > precision)
#       return Rcpp::wrap(false);
#   }
#
#   return Rcpp::wrap(true);
# ', plugin = 'Rcpp')

slow_equal <- function(x) diff(range(x)) < sqrt(.Machine$double.eps)

checkSameLength <- function(x) {
  if (!slow_equal(x)) {
    return(paste0(.pasteand(names(x)), " must have the same length"))
  }
  return(TRUE)
}

assertSameLength <- checkmate::makeAssertionFunction(checkSameLength)

checkDateish <- function(x, ...) {
  x <- try(as.Date(x), TRUE)
  if (is.error(x)) {
    return("Must be coercible to date")
  }
  checkDate(x, ...)
}

assertDateish <- checkmate::makeAssertionFunction(checkDateish)

.datatable.aware <- TRUE

a <- 6371000


# from fields::interp.surface
interpolate_locations <- function(obj, loc) {
  x <- obj$x
  y <- obj$y
  z <- obj$z
  nx <- length(x)
  ny <- length(y)
  lx <- approx(x, 1:nx, loc[, 1])$y
  ly <- approx(y, 1:ny, loc[, 2])$y
  lx1 <- floor(lx)
  ly1 <- floor(ly)
  ex <- lx - lx1
  ey <- ly - ly1
  ex[lx1 == nx] <- 1
  ey[ly1 == ny] <- 1
  lx1[lx1 == nx] <- nx - 1
  ly1[ly1 == ny] <- ny - 1
  return(
    z[cbind(lx1, ly1)] *
      (1 - ex) *
      (1 - ey) +
      z[cbind(
        lx1 +
          1,
        ly1
      )] *
        ex *
        (1 - ey) +
      z[cbind(lx1, ly1 + 1)] *
        (1 - ex) *
        ey +
      z[cbind(lx1 + 1, ly1 + 1)] * ex * ey
  )
}


downsample <- function(x, y, value, byx = 1, byy = 1, fill = mean) {
  data <- data.table::data.table(x, y, value)
  fill <- mean(value, na.rm = TRUE)
  g <- .tidy2matrix(data, x ~ y, value.var = "value", fill = fill)
  g$matrix[is.na(g$matrix)] <- fill
  f <- fft(g$matrix)
  f1 <- f

  kx <- 1 / byx
  ky <- 1 / byy

  kx <- c(0, seq_len(floor(nrow(f) / 2 * kx)))
  kx <- c(kx + 1, nrow(f) - kx[kx != 0] + 1)

  ky <- c(0, seq_len(floor(ncol(f) / 2 * ky)))
  ky <- c(ky + 1, ncol(f) - ky[ky != 0] + 1)

  f1[, -ky] <- 0
  f1[-kx, ] <- 0

  data$value_smooth <- c(Re(fft(f1, inverse = TRUE) / length(f1)))

  data <- subset(
    data,
    x %in% JumpBy(sort(unique(x)), byx) & y %in% JumpBy(sort(unique(y)), byy)
  )
  data
}

# nocov end