`%||%` <- function(x, y){if(is.null(x)) y else x}

utils::globalVariables("self")

as_mapper <- function(.f)
{
  if(is.function(.f)){return(.f)}
  if(inherits(.f, "formula"))
  {
    env <- environment(.f)
    expr <- .f[[length(.f)]]
    return(function(...)
    {
      args <- list(...)
      dots <- stats::setNames(args, paste0("..", seq_along(args)))
      dots$.x <- args[[1]]
      dots$. <- args[[1]]
      if(length(args) >= 2){dots$.y <- args[[2]]}
      eval(expr, envir = list2env(dots, parent = env))
    })
  }
  stop("mapper must be a function or one-sided formula")
}

map <- function(.x, .f, ...)
{
  f <- as_mapper(.f)
  lapply(.x, function(x) f(x, ...))
}

map_lgl <- function(.x, .f, ...)
{
  vapply(map(.x, .f, ...), isTRUE, logical(1))
}

map_dbl <- function(.x, .f, ...)
{
  vapply(map(.x, .f, ...), as.numeric, numeric(1))
}

map2 <- function(.x, .y, .f, ...)
{
  f <- as_mapper(.f)
  mapply(function(x, y) f(x, y, ...), .x, .y, SIMPLIFY = FALSE, USE.NAMES = FALSE)
}

map2_dbl <- function(.x, .y, .f, ...)
{
  vapply(map2(.x, .y, .f, ...), as.numeric, numeric(1))
}

pmap <- function(.l, .f, ...)
{
  f <- as_mapper(.f)
  n <- length(.l[[1]])
  lapply(seq_len(n), function(i) do.call(f, c(lapply(.l, function(x) x[[i]]), list(...))))
}

transpose <- function(.l)
{
  if(!length(.l)){return(list())}
  names0 <- names(.l[[1]])
  if(!is.null(names0))
  {
    out <- lapply(names0, function(nm) lapply(.l, `[[`, nm))
    names(out) <- names0
    return(out)
  }
  n <- length(.l[[1]])
  lapply(seq_len(n), function(i) lapply(.l, `[[`, i))
}

map_depth <- function(.x, .depth, .f, ...)
{
  f <- as_mapper(.f)
  if(.depth <= 1){return(lapply(.x, function(x) f(x, ...)))}
  lapply(.x, function(x) map_depth(x, .depth - 1, f, ...))
}

is.Date <- function(x)
{
  inherits(x, "Date")
}

seconds_to_period <- function(seconds)
{
  seconds <- max(0, as.numeric(seconds))
  hours <- floor(seconds / 3600)
  minutes <- floor((seconds %% 3600) / 60)
  secs <- round(seconds %% 60)
  label <- if(hours > 0) sprintf("%sH %sM %sS", hours, minutes, secs) else if(minutes > 0) sprintf("%sM %sS", minutes, secs) else sprintf("%sS", secs)
  structure(label, class = c("Period", "character"))
}

parse_number <- function(x)
{
  as.numeric(regmatches(as.character(x), regexpr("-?[0-9]+\\.?[0-9]*", as.character(x))))
}

number <- function(x)
{
  format(x, trim = TRUE, scientific = FALSE)
}

dummy_cols <- function(.data, select_columns = NULL, remove_first_dummy = FALSE,
                       remove_most_frequent_dummy = FALSE, ignore_na = FALSE,
                       split = NULL, remove_selected_columns = TRUE)
{
  data <- as.data.frame(.data, stringsAsFactors = FALSE)
  cols <- select_columns %||% names(data)
  out <- if(remove_selected_columns) data[setdiff(names(data), cols)] else data

  for(col in cols)
  {
    values <- as.character(data[[col]])
    if(ignore_na){values[is.na(values)] <- NA_character_}
    levels <- sort(unique(values[!is.na(values)]))
    if(remove_most_frequent_dummy && length(levels))
    {
      counts <- sort(table(values), decreasing = TRUE)
      levels <- setdiff(levels, names(counts)[1])
    }
    if(remove_first_dummy && length(levels)){levels <- levels[-1]}
    for(level in levels)
    {
      nm <- make.names(paste(col, level, sep = "_"))
      out[[nm]] <- as.integer(!is.na(values) & values == level)
    }
  }
  as.data.frame(out)
}

na_kalman <- function(x)
{
  impute_vector <- function(v)
  {
    if(!anyNA(v)){return(v)}
    idx <- seq_along(v)
    good <- which(!is.na(v))
    if(!length(good)){return(rep(0, length(v)))}
    if(length(good) == 1){return(rep(v[good], length(v)))}
    approx(good, v[good], xout = idx, method = "linear", rule = 2)$y
  }
  if(is.data.frame(x)){return(as.data.frame(lapply(x, impute_vector)))}
  impute_vector(x)
}

loess.as <- function(x, y)
{
  spans <- c(0.25, 0.4, 0.6, 0.8, 1)
  best <- NULL
  best_score <- Inf
  for(span in spans)
  {
    fit <- try(stats::loess(y ~ x, span = span, degree = 1, control = stats::loess.control(surface = "direct")), silent = TRUE)
    if(inherits(fit, "try-error")){next}
    fitted <- stats::predict(fit, data.frame(x = x))
    score <- mean((y - fitted)^2, na.rm = TRUE)
    if(is.finite(score) && score < best_score)
    {
      best <- fitted
      best_score <- score
    }
  }
  if(is.null(best)){best <- y}
  list(fitted = as.numeric(best))
}

mlv1 <- function(x, method = "shorth")
{
  x <- sort(x[is.finite(x)])
  n <- length(x)
  if(!n){return(NA_real_)}
  if(n <= 2){return(mean(x))}
  k <- max(2, ceiling(n / 2))
  widths <- x[k:n] - x[seq_len(n - k + 1)]
  i <- which.min(widths)
  mean(c(x[i], x[i + k - 1]))
}

skewness <- function(x, na.rm = FALSE)
{
  if(na.rm){x <- x[!is.na(x)]}
  m <- mean(x)
  s <- stats::sd(x)
  if(!is.finite(s) || s == 0){return(NA_real_)}
  mean(((x - m) / s)^3)
}

kurtosis <- function(x, na.rm = FALSE)
{
  if(na.rm){x <- x[!is.na(x)]}
  m <- mean(x)
  s <- stats::sd(x)
  if(!is.finite(s) || s == 0){return(NA_real_)}
  mean(((x - m) / s)^4)
}

entropy <- function(x)
{
  tab <- table(x)
  p <- as.numeric(tab) / sum(tab)
  p <- p[p > 0]
  -sum(p * log(p))
}

safe_div <- function(num, den)
{
  ifelse(abs(den) < 1e-12, 0, num / den)
}

distance <- function(x, method)
{
  a <- as.numeric(x[1,])
  b <- as.numeric(x[2,])
  eps <- 1e-12
  dot <- sum(a * b, na.rm = TRUE)
  na <- sqrt(sum(a * a, na.rm = TRUE))
  nb <- sqrt(sum(b * b, na.rm = TRUE))
  absdiff <- abs(a - b)
  method <- tolower(method)
  switch(method,
         "dice" = 1 - safe_div(2 * dot, sum(a * a, na.rm = TRUE) + sum(b * b, na.rm = TRUE) + eps),
         "jaccard" = 1 - safe_div(sum(pmin(a, b), na.rm = TRUE), sum(pmax(a, b), na.rm = TRUE) + eps),
         "cosine" = 1 - safe_div(dot, na * nb + eps),
         "canberra" = sum(safe_div(absdiff, abs(a) + abs(b) + eps), na.rm = TRUE),
         "gower" = mean(safe_div(absdiff, diff(range(c(a, b), na.rm = TRUE)) + eps), na.rm = TRUE),
         "tanimoto" = 1 - safe_div(dot, sum(a * a, na.rm = TRUE) + sum(b * b, na.rm = TRUE) - dot + eps),
         "hassebrook" = 1 - safe_div(dot, sum(a * a, na.rm = TRUE) + sum(b * b, na.rm = TRUE) - dot + eps),
         "taneja" = sum(((a + b) / 2) * log(safe_div((a + b) / 2 + eps, sqrt(abs(a * b)) + eps)), na.rm = TRUE),
         "lorentzian" = sum(log(1 + absdiff), na.rm = TRUE),
         "clark" = sqrt(sum(safe_div(absdiff, abs(a) + abs(b) + eps)^2, na.rm = TRUE)),
         "sorensen" = safe_div(sum(absdiff, na.rm = TRUE), sum(a + b, na.rm = TRUE) + eps),
         "harmonic_mean" = sum(safe_div(2 * absdiff, abs(a) + abs(b) + eps), na.rm = TRUE),
         "avg" = mean(absdiff, na.rm = TRUE),
         stop("unsupported distance method"))
}

ME <- function(actual, forecast, na.rm = TRUE){mean(actual - forecast, na.rm = na.rm)}
MAE <- function(actual, forecast, na.rm = TRUE){mean(abs(actual - forecast), na.rm = na.rm)}
MSE <- function(actual, forecast, na.rm = TRUE){mean((actual - forecast)^2, na.rm = na.rm)}
RMSSE <- function(actual, forecast, scale, na.rm = TRUE){sqrt(MSE(actual, forecast, na.rm = na.rm)) / pmax(abs(scale), 1e-12)}
MRE <- function(actual, forecast, na.rm = TRUE){mean(safe_div(actual - forecast, actual), na.rm = na.rm)}
MPE <- function(actual, forecast, na.rm = TRUE){100 * MRE(actual, forecast, na.rm = na.rm)}
MAPE <- function(actual, forecast, na.rm = TRUE){100 * mean(abs(safe_div(actual - forecast, actual)), na.rm = na.rm)}
rMAE <- function(actual, forecast, benchmark, na.rm = TRUE){safe_div(MAE(actual, forecast, na.rm = na.rm), MAE(actual, benchmark, na.rm = na.rm))}
rRMSE <- function(actual, forecast, benchmark, na.rm = TRUE){safe_div(sqrt(MSE(actual, forecast, na.rm = na.rm)), sqrt(MSE(actual, benchmark, na.rm = na.rm)))}
rAME <- function(actual, forecast, benchmark, na.rm = TRUE){safe_div(abs(ME(actual, forecast, na.rm = na.rm)), abs(ME(actual, benchmark, na.rm = na.rm)))}
MASE <- function(actual, forecast, scale, na.rm = TRUE){safe_div(MAE(actual, forecast, na.rm = na.rm), abs(scale))}
sMSE <- function(actual, forecast, scale, na.rm = TRUE){safe_div(MSE(actual, forecast, na.rm = na.rm), scale^2)}
sCE <- function(actual, forecast, scale, na.rm = TRUE){safe_div(sum(actual - forecast, na.rm = na.rm), abs(scale))}
GMRAE <- function(actual, forecast, benchmark, na.rm = TRUE)
{
  ratio <- safe_div(abs(actual - forecast), abs(actual - benchmark))
  ratio <- ratio[is.finite(ratio) & ratio > 0]
  if(!length(ratio)){return(NA_real_)}
  exp(mean(log(ratio), na.rm = na.rm))
}

array_split <- function(x, along = 3)
{
  dims <- dim(x)
  if(is.null(dims)){return(as.list(x))}
  lapply(seq_len(dims[along]), function(i)
  {
    idx <- rep(list(TRUE), length(dims))
    idx[[along]] <- i
    do.call(`[`, c(list(x), idx, list(drop = TRUE)))
  })
}

bind_arrays <- function(..., along)
{
  arrays <- list(...)
  if(length(arrays) == 1 && is.list(arrays[[1]]) && is.null(dim(arrays[[1]]))){arrays <- arrays[[1]]}
  max_dim <- max(c(along, vapply(arrays, function(x) length(dim(x)), integer(1))))
  arrays <- lapply(arrays, function(x)
  {
    d <- dim(x)
    if(is.null(d)){d <- length(x)}
    if(length(d) < max_dim){d <- c(d, rep(1, max_dim - length(d)))}
    array(x, dim = d)
  })
  dims <- dim(arrays[[1]])
  out_dim <- dims
  out_dim[along] <- sum(vapply(arrays, function(x) dim(x)[along], numeric(1)))
  out <- array(NA_real_, dim = out_dim)
  start <- 1
  for(x in arrays)
  {
    n <- dim(x)[along]
    idx <- rep(list(TRUE), length(out_dim))
    idx[[along]] <- start:(start + n - 1)
    out <- do.call(`[<-`, c(list(out), idx, list(value = x)))
    start <- start + n
  }
  out
}

codez_plot <- function(data, type = "forecast", labels = list())
{
  structure(list(data = data, type = type, labels = labels), class = "codez_plot")
}

torch_runtime_available <- function()
{
  if(!requireNamespace("torch", quietly = TRUE)){return(FALSE)}
  tryCatch({
    torch::torch_manual_seed(1)
    invisible(torch::torch_tensor(1))
    TRUE
  }, error = function(e) FALSE)
}

#' @export
plot.codez_plot <- function(x, ...)
{
  data <- x$data
  if(identical(x$type, "training"))
  {
    plot(data$epoch, data$loss, type = "l", col = "gray40", xlab = "Epoch", ylab = "Loss", ...)
    if("val_loss" %in% names(data)){lines(data$epoch, data$val_loss, col = "seagreen4")}
    return(invisible(x))
  }
  if(identical(x$type, "model_forecast"))
  {
    features <- unique(data$feature)
    old <- par(no.readonly = TRUE)
    on.exit(par(old), add = TRUE)
    par(mfrow = grDevices::n2mfrow(length(features)))
    for(feature in features)
    {
      sub <- data[data$feature == feature,, drop = FALSE]
      plot(sub$.x, sub$.mid, type = "l", col = "seagreen4", xlab = "Horizon", ylab = "Forecast", main = feature, ...)
    }
    return(invisible(x))
  }
  if(is.list(data) && all(c("history", "forecast") %in% names(data)))
  {
    hist <- data$history
    fore <- data$forecast
    plot(hist$x_all, hist$y_all, type = "l", col = "gray40",
         xlab = x$labels$x %||% "Horizon", ylab = x$labels$y %||% "Forecast", ...)
    lines(fore$x_forcat, fore$y_forcat, col = "seagreen4", lwd = 2)
    return(invisible(x))
  }
  plot(data$x_all, data$y_all, type = "l", col = "gray40",
       xlab = x$labels$x %||% "Horizon", ylab = x$labels$y %||% "Forecast", ...)
  lines(data$x_forcat, data$y_forcat, col = "seagreen4", lwd = 2)
  invisible(x)
}
