R/internal.R

In segen: Sequence Generalization Through Similarity Network

# Internal base-R adapters for the limited mapping operations used by segen.
run_window_job <- function(args) do.call(windower, args)
worker_function <- function() {
  source_env <- environment(run_window_job)
  worker_env <- new.env(parent = baseenv())
  for (nm in c("weighted.mean", "ecdf", "na.omit", "quantile", "sd",
               "lm", "rnorm", "pnorm", "fft", "runif", "pf"))
    assign(nm, getExportedValue("stats", nm), worker_env)
  for (nm in c("head", "tail"))
    assign(nm, getExportedValue("utils", nm), worker_env)
  for (nm in ls(source_env, all.names = TRUE)) {
    obj <- get(nm, source_env)
    if (is.function(obj) && identical(environment(obj), source_env)) {
      environment(obj) <- worker_env
      assign(nm, obj, worker_env)
    }
  }
  worker_env$.segen_cache <- new.env(parent = emptyenv())
  worker_env$run_window_job
}
internal_mapper <- function(f) {
  if (is.function(f)) return(f)
  stopifnot(inherits(f, "formula"))
  body <- f[[2L]]
  env <- environment(f)
  fun <- function(..., .x = ..1, .y = ..2) NULL
  body(fun) <- body
  environment(fun) <- env
  fun
}
map <- function(.x, .f) lapply(.x, internal_mapper(.f))
map_lgl <- function(.x, .f) vapply(.x, internal_mapper(.f), logical(1))
map_dbl <- function(.x, .f) vapply(.x, internal_mapper(.f), numeric(1))
map2 <- function(.x, .y, .f) Map(internal_mapper(.f), .x, .y)
map2_dbl <- function(.x, .y, .f) unlist(map2(.x, .y, .f), use.names = FALSE)
pmap <- function(.l, .f) {
  fun <- internal_mapper(.f)
  lapply(seq_along(.l[[1L]]), function(i) do.call(fun, lapply(.l, function(x) x[[i]])))
}
map_depth <- function(.x, .depth, .f) {
  if (.depth == 0L) return(internal_mapper(.f)(.x))
  lapply(.x, function(x) map_depth(x, .depth - 1L, .f))
}
transpose <- function(x) lapply(seq_along(x[[1L]]), function(i) lapply(x, function(y) y[[i]]))
is.Date <- function(x) inherits(x, "Date")

impute_numeric <- function(x) {
  good <- which(is.finite(x))
  if (!length(good)) stop("No finite observations in a numeric column.")
  if (length(good) == 1L) return(rep(x[good], length(x)))
  stats::approx(good, x[good], xout = seq_along(x), rule = 2)$y
}
smooth_numeric <- function(x) {
  if (length(unique(x)) < 3L) return(x)
  fit <- stats::loess(y ~ t, data = data.frame(y = x, t = seq_along(x)),
                      span = 0.75, degree = 1)
  impute_numeric(as.numeric(fit$fitted))
}
dummy_cols <- function(df, ...) {
  out <- list()
  for (nm in names(df)) {
    x <- as.character(df[[nm]])
    counts <- table(x)
    if (!length(counts)) stop("All-missing categorical column.")
    baseline <- names(counts)[which.max(counts)]
    x[is.na(x)] <- baseline
    lev <- sort(unique(x))
    retained <- setdiff(lev, baseline)
    if (!length(retained)) retained <- baseline
    for (level in retained) out[[paste(nm, level, sep = "_")]] <- as.numeric(x == level)
  }
  as.data.frame(out, check.names = FALSE)
}
mlv1 <- function(x, method = "shorth") {
  x <- sort(x[is.finite(x)])
  n <- length(x)
  if (!n) return(NA_real_)
  k <- floor(n / 2)
  starts <- seq_len(n - k)
  i <- starts[which.min(x[starts + k] - x[starts])]
  mean(x[i:(i + k)])
}
skewness <- function(x, na.rm = FALSE) {
  if (na.rm) x <- x[!is.na(x)]
  v <- mean((x - mean(x))^2)
  if (v == 0) return(0)
  mean((x - mean(x))^3) / v^1.5
}
kurtosis <- function(x, na.rm = FALSE) {
  if (na.rm) x <- x[!is.na(x)]
  v <- mean((x - mean(x))^2)
  if (v == 0) return(0)
  mean((x - mean(x))^4) / v^2
}
entropy <- function(x) {
  p <- as.numeric(table(x)) / length(x)
  -sum(p[p > 0] * log(p[p > 0]))
}

#' Draw a segen forecast
#' @param x A forecast plot returned in best_model$plots.
#' @param ... Additional arguments passed to the base plot function.
#' @return The plot object, invisibly.
#' @export
plot.segen_plot <- function(x, ...) {
  graphics::plot(c(x$x_hist, x$x_forcat), c(x$y_hist, x$y_forcat),
    type = "n", xlab = x$label_x, ylab = x$label_y,
    ylim = range(c(x$y_hist, x$y_forcat, x$lower, x$upper), finite = TRUE), ...)
  if (!is.null(x$lower) && !is.null(x$upper))
    graphics::polygon(c(x$x_forcat, rev(x$x_forcat)), c(x$lower, rev(x$upper)),
      col = grDevices::adjustcolor("seagreen2", alpha.f = 0.3), border = NA)
  graphics::lines(x$x_hist, x$y_hist, col = "gray43")
  graphics::lines(c(tail(x$x_hist, 1), x$x_forcat),
    c(tail(x$y_hist, 1), x$y_forcat), col = "seagreen4")
  invisible(x)
}

#' @rdname plot.segen_plot
#' @export
print.segen_plot <- function(x, ...) plot.segen_plot(x, ...)