#' codez
#'
#' @param df A data frame with time features on columns. They could be numeric variables or categorical, but not both.
#' @param seq_len Positive integer. Time-step number of the forecasting sequence. Default: NULL (random selection within 2 to max preset boundary).
#' @param n_windows Positive integer. Number of validation windows to test prediction error. Default: 10.
#' @param latent Positive integer. Dimensions of the latent space for encoding-decoding operations. Default: NULL (random selection within preset boundaries)
#' @param smoother Logical. Perform optimal smoothing using standard loess for each time feature. Default: FALSE
#' @param n_samp Positive integer. Number of samples for random search. Default: 30.
#' @param autoencoder_layers_n Positive integer. Number of layers for the encoder-decoder model. Default: NULL (random selection within preset boundaries)
#' @param autoencoder_layers_size Positive integer. Numbers of nodes for the encoder-decoder model. Default: NULL (random selection within preset boundaries)
#' @param autoencoder_activ String. Activation function to be used by the encoder-decoder model. Implemented functions are: "linear", "relu", "leaky_relu", "selu", "elu", "sigmoid", "tanh", "swish", "gelu". Default: NULL (random selection within standard activations)
#' @param forward_net_layers_n Positive integer. Number of layers for the forward net model. Default: NULL (random selection within preset boundaries)
#' @param forward_net_layers_size Positive integer. Numbers of nodes for the forward net model. Default: NULL (random selection within preset boundaries)
#' @param forward_net_activ String. Activation function to be used by the forward net model. Implemented functions are: "linear", "relu", "leaky_relu", "selu", "elu", "sigmoid", "tanh", "swish", "gelu". Default: NULL (random selection within standard activations)
#' @param forward_net_reg_L1 Positive numeric between. Weights for L1 regularization. Default: NULL (random selection within preset boundaries).
#' @param forward_net_reg_L2 Positive numeric between. Weights for L2 regularization. Default: NULL (random selection within preset boundaries).
#' @param forward_net_drop Positive numeric between 0 and 1. Value for the dropout parameter for each layer of the forward net model (for example, a neural net with 3 layers may have dropout = c(0, 0.5, 0.3)). Default: NULL (random selection within preset boundaries).
#' @param loss_metric String. Loss function for both models. Available metrics: "mse", "mae", "mape". Default: "mae".
#' @param autoencoder_optimizer String. Optimization method for autoencoder. Implemented methods are: "adam", "adadelta", "adagrad", "rmsprop", "sgd", "nadam", "adamax". Default: NULL (random selection within standard optimizers).
#' @param forward_net_optimizer String. Optimization method for forward net. Implemented methods are: "adam", "adadelta", "adagrad", "rmsprop", "sgd", "nadam", "adamax". Default: NULL (random selection within standard optimizers).
#' @param epochs Positive integer. Default: 100.
#' @param patience Positive integer. Waiting time (in epochs) before evaluating the overfit performance. Default: 10.
#' @param holdout Positive numeric between 0 and 1. Holdout sample for validation. Default: 0.5.
#' @param batch_size Positive integer. Mini-batch size for torch training. Default: 32.
#' @param validation_split Positive numeric between 0 and 1. Validation share used by the autoencoder. Default: 0.1.
#' @param n_sim Positive integer. Number of simulated paths generated from validation residuals. Default: 1000.
#' @param backend String. Neural backend. Only "torch" is supported in codez 2.0.
#' @param verbose Logical. Default: FALSE.
#' @param ci Positive numeric. Confidence interval. Default: 0.8
#' @param error_scale String. Scale for the scaled error metrics (for continuous variables). Two options: "naive" (average of naive one-step absolute error for the historical series) or "deviation" (standard error of the historical series). Default: "naive".
#' @param error_benchmark String. Benchmark for the relative error metrics (for continuous variables). Two options: "naive" (sequential extension of last value) or "average" (mean value of true sequence). Default: "naive".
#' @param dates Date. Vector with dates for time features.
#' @param seed Positive integer. Random seed. Default: 42.
#' @author Giancarlo Vercellino \email{giancarlo.vercellino@gmail.com}
#'
#' @return This function returns a list including:
#' \itemize{
#' \item history: a table with the sampled models, hyper-parameters, validation errors
#' \item best_model: results for the best selected model according to the weighted average rank, including:
#' \itemize{
#' \item predictions: for continuous variables, min, max, q25, q50, q75, quantiles at selected ci, mean, sd, mode, skewness, kurtosis, IQR to range, risk ratio, upside probability and divergence for each point fo predicted sequences; for factor variables, min, max, q25, q50, q75, quantiles at selected ci, proportions, difformity (deviation of proportions normalized over the maximum possible deviation), entropy, upgrade probability and divergence for each point fo predicted sequences
#' \item testing_errors: testing errors for each time feature for the best selected model (for continuous variables: me, mae, mse, rmsse, mpe, mape, rmae, rrmse, rame, mase, smse, sce, gmrae; for factor variables: czekanowski, tanimoto, cosine, hassebrook, jaccard, dice, canberra, gower, lorentzian, clark)
#' \item plots: standard plots with confidence interval for each time feature
#' }
#' \item time_log
#' }
#'
#'
#' @export
#'
#' @importFrom graphics lines par plot
#' @importFrom grDevices n2mfrow
#' @importFrom stats approx ecdf loess loess.control predict sd lm median na.omit quantile
#' @importFrom utils head tail
#'

codez <- function(df, seq_len = NULL, n_windows = 10, latent = NULL, smoother = FALSE, n_samp = 30,
                  autoencoder_layers_n = NULL, autoencoder_layers_size = NULL, autoencoder_activ = NULL,
                  forward_net_layers_n = NULL, forward_net_layers_size = NULL, forward_net_activ = NULL,
                  forward_net_reg_L1 = NULL, forward_net_reg_L2 = NULL, forward_net_drop = NULL,
                  loss_metric = "mae", autoencoder_optimizer = NULL, forward_net_optimizer = NULL,
                  epochs = 100, patience = 10, holdout = 0.5, verbose = FALSE, ci = 0.8,
                  error_scale = "naive", error_benchmark = "naive", dates = NULL, seed = 42,
                  batch_size = 32, validation_split = 0.1, n_sim = 1000, backend = "torch")
{
  start_time <- proc.time()[["elapsed"]]

  set.seed(seed)
  n_length <- nrow(df)

  if(!is.data.frame(df)){stop("df must be a data frame")}
  if(!identical(backend, "torch")){stop("codez 2.0 supports only backend = 'torch'")}
  if(!requireNamespace("torch", quietly = TRUE)){stop("the torch package is required for codez 2.0; install torch before fitting models")}
  if(!torch_runtime_available()){stop("the torch runtime is not available; run torch::install_torch() before fitting models")}
  if(n_length < 1){stop("df must contain at least one row")}
  if(!is.null(dates) && (!is.Date(dates) || length(dates) != n_length)){stop("dates must be a Date vector with one value per row of df")}
  if(!is.numeric(ci) || length(ci) != 1 || ci <= 0 || ci >= 1){stop("ci must be a numeric value between 0 and 1")}
  if(!is.numeric(holdout) || length(holdout) != 1 || holdout <= 0 || holdout >= 1){stop("holdout must be a numeric value between 0 and 1")}
  if(!is.numeric(validation_split) || length(validation_split) != 1 || validation_split < 0 || validation_split >= 1){stop("validation_split must be a numeric value in [0, 1)")}
  if(!is.numeric(batch_size) || length(batch_size) != 1 || batch_size < 1){stop("batch_size must be a positive integer")}
  if(!is.numeric(n_sim) || length(n_sim) != 1 || n_sim < 1){stop("n_sim must be a positive integer")}

  class_index <- map_lgl(df, ~ is.factor(.x) | is.character(.x))
  all_classes <- all(class_index)
  numeric_index <- map_lgl(df, ~ is.integer(.x) | is.numeric(.x))
  all_numerics <- all(numeric_index)
  if(any(class_index) && any(numeric_index)){stop("mixed numeric and categorical features are not supported; pass all numeric or all categorical columns")}
  if(!(all_classes | all_numerics)){stop("df columns must be all numeric/integer or all factor/character")}

  if(all_classes){df <- dummy_cols(df, select_columns = NULL, remove_first_dummy = FALSE, remove_most_frequent_dummy = TRUE, ignore_na = FALSE, split = NULL, remove_selected_columns = TRUE); binary_class <- rep(TRUE, ncol(df))}
  if(all_numerics){binary_class <- rep(FALSE, ncol(df))}

  if(anyNA(df) & all_numerics){df <- as.data.frame(na_kalman(df)); message("local interpolation imputation on time features\n")}
  if(anyNA(df) & all_classes){df <- floor( as.data.frame(na_kalman(df))); message("local interpolation imputation on time features\n")}
  if(smoother == TRUE & all_numerics){df <- as.data.frame(map(df, ~ suppressWarnings(loess.as(x=1:n_length, y=.x)$fitted))); message("performing local loess smoothing\n")}

  n_feats <- ncol(df)
  feat_names <- colnames(df)

  if(all_numerics){deriv <- min(map_dbl(df, ~ best_deriv(.x)))}
  if(all_classes){deriv <- 0}

  max_limit <- floor((n_length/(n_windows + 1)/4 - max(deriv) + 2))###AT LEAST TWO ROW IN THE SEGMENTED FRAME
  if(max_limit < 2){stop("not enough data for the validation windows")}

  standard_activations <- c("linear", "relu", "leaky_relu", "selu", "elu", "sigmoid", "tanh", "swish", "gelu")
  standard_optimizations <- c("adam", "adadelta", "adagrad", "rmsprop", "sgd", "nadam", "adamax")
  if(!is.null(autoencoder_activ) && !all(autoencoder_activ %in% standard_activations)){stop("non-standard activation in autoencoder")}
  if(!is.null(forward_net_activ) && !all(forward_net_activ %in% standard_activations)){stop("non-standard activation in forward net")}
  if(!is.null(autoencoder_optimizer) && !(autoencoder_optimizer %in% standard_optimizations)){stop("non-standard optimizer in autoencoder")}
  if(!is.null(forward_net_optimizer) && !(forward_net_optimizer %in% standard_optimizations)){stop("non-standard optimizer in forward net")}

  finite_solution <- (length(seq_len) == 1) && (length(latent) == 1) && (length(autoencoder_layers_n)==1) && (length(autoencoder_layers_size)==autoencoder_layers_n) && (length(autoencoder_activ)==autoencoder_layers_n) && (length(forward_net_layers_n)==1) && (length(forward_net_layers_size)==forward_net_layers_n) && (length(forward_net_activ)==forward_net_layers_n) && (length(forward_net_reg_L1)==forward_net_layers_n) && (length(forward_net_reg_L2)==forward_net_layers_n) && (length(forward_net_drop)==forward_net_layers_n)
  if(finite_solution)
  {
    n_samp <- 1
    history <- NULL

    best_model <- windower(df = df, seq_len = seq_len, n_windows = n_windows, latent = latent,
                           autoencoder_form = autoencoder_layers_size, autoencoder_activ = autoencoder_activ,
                           forward_net_form = forward_net_layers_size, forward_net_activ = forward_net_activ,
                           forward_net_reg_L1 = forward_net_reg_L1, forward_net_reg_L2 = forward_net_reg_L2,
                           forward_net_drop = forward_net_drop, loss_metric = loss_metric,
                           autoencoder_optimizer = autoencoder_optimizer, forward_net_optimizer = forward_net_optimizer,
                           epochs = epochs, patience = patience, holdout = holdout, verbose = verbose, ci = ci,
                           error_scale = error_scale, error_benchmark = error_benchmark, dates = dates,
                           binary_class = binary_class, deriv = deriv, n_samp = n_samp, seed = seed,
                           batch_size = batch_size, validation_split = validation_split, n_sim = n_sim)
    if(n_feats > 1){best_model$errors <- Reduce(rbind, best_model$errors); rownames(best_model$errors) <- feat_names}
    if(n_feats == 1){best_model$errors <- round(t(as.data.frame(best_model$errors)), 4)}
    names(best_model$quant_pred) <- feat_names
    names(best_model$plot) <- feat_names
    best_model <- list(predictions = best_model$quant_pred,
                       errors = best_model$errors,
                       plot = best_model$plot)
  }

  if(!finite_solution & n_samp >= 1)
  {
    sqln_set <- sampler(seq_len, n_samp, range = c(3, max_limit), integer = TRUE)
    ltt_set <- sampler(latent, n_samp, range = c(2, max(sqln_set)), integer = TRUE)

    if(any(sqln_set < 2)){sqln_set[sqln_set < 2] <- 2; message("setting min seq_len to 2")}
    if(any(sqln_set > max_limit)){sqln_set[sqln_set > max_limit] <- max_limit; message(paste0("setting max seq_len to ", max_limit))}
    ltt_set[ltt_set > sqln_set] <- sqln_set[ltt_set > sqln_set]
    ltt_set[ltt_set >= sqln_set] <- sqln_set[ltt_set >= sqln_set] - 1

    autoencoder_lyr_set <- sampler(autoencoder_layers_n, n_samp,  range = c(1, 5), integer = TRUE) ###PROBLEMI CON IL SINGLE LAYER
    autoencoder_lsz_set <- map(autoencoder_lyr_set, ~ unlist(sampler(autoencoder_layers_size, 1, range = seq(8, 1024, by = 8), integer = TRUE, multi = .x)))
    autoencoder_act_set <- map(autoencoder_lyr_set, ~ unlist(sampler(autoencoder_activ, 1, range = standard_activations, integer = FALSE, multi = .x)))

    forward_net_lyr_set <- sampler(forward_net_layers_n, n_samp,  range = c(1, 5), integer = TRUE) ###PROBLEMI CON IL SINGLE LAYER
    forward_net_lsz_set <- map(forward_net_lyr_set, ~ unlist(sampler(forward_net_layers_size, 1, range = seq(8, 1024, by = 8), integer = TRUE, multi = .x)))
    forward_net_act_set <- map(forward_net_lyr_set, ~ unlist(sampler(forward_net_activ, 1, range = standard_activations, integer = FALSE, multi = .x)))
    forward_net_rL1_set <- map(forward_net_lyr_set, ~ round(unlist(sampler(forward_net_reg_L1, 1, range = c(0.001, 1000), integer = FALSE, multi = .x)), 4))
    forward_net_rL2_set <- map(forward_net_lyr_set, ~ round(unlist(sampler(forward_net_reg_L2, 1, range = c(0.001, 1000), integer = FALSE, multi = .x)), 4))
    forward_net_drp_set <- map(forward_net_lyr_set, ~ round(unlist(sampler(forward_net_drop, 1, range = c(0.1, 0.9), integer = FALSE, multi = .x)), 4))
    autoencoder_opt_set <- sampler(autoencoder_optimizer, n_samp, range = standard_optimizations)
    forward_net_opt_set <- sampler(forward_net_optimizer, n_samp, range = standard_optimizations)

    hyper_param <- list(sqln_set, ltt_set, autoencoder_lsz_set, autoencoder_act_set, forward_net_lsz_set, forward_net_act_set, forward_net_rL1_set, forward_net_rL2_set, forward_net_drp_set, autoencoder_opt_set, forward_net_opt_set, 1:n_samp)

    exploration <- pmap(hyper_param, function(sqln, ltt, ae_lsz, ae_act, fn_lsz, fn_act, fn_l1, fn_l2, fn_drop, ae_opt, fn_opt, sample_id)
      windower(df, seq_len = sqln, n_windows, latent = ltt,
               autoencoder_form = ae_lsz, autoencoder_activ = ae_act, forward_net_form = fn_lsz, forward_net_activ = fn_act,
               forward_net_reg_L1 = fn_l1, forward_net_reg_L2 = fn_l2, forward_net_drop = fn_drop,
               loss_metric, autoencoder_optimizer = ae_opt, forward_net_optimizer = fn_opt,
               epochs, patience, holdout, verbose, ci, error_scale, error_benchmark,
               dates, binary_class, deriv, n_samp = sample_id, seed,
               batch_size = batch_size, validation_split = validation_split, n_sim = n_sim))

    exploration <- transpose(exploration)

    models <- exploration$quant_pred
    errors <- exploration$errors
    plots <- exploration$plot

    if(n_feats > 1){aggr_errors <- map(errors, ~ colMeans(Reduce(rbind, .x)))} else {aggr_errors <- errors}
    aggr_errors <- t(as.data.frame(aggr_errors))

    history <- data.frame(seq_len = unlist(sqln_set))
    history$latent <- ltt_set
    history$autoencoder_layers <- autoencoder_lsz_set
    history$autoencoder_activations <- autoencoder_act_set
    history$autoencoder_optimizer <- autoencoder_opt_set
    history$forward_net_layers <- forward_net_lsz_set
    history$forward_net_activations <- forward_net_act_set
    history$forward_net_reg_L1 <- forward_net_rL1_set
    history$forward_net_reg_L2 <- forward_net_rL2_set
    history$forward_net_dropout <- forward_net_drp_set
    history$forward_net_optimizer <- forward_net_opt_set

    history <- data.frame(history, round(aggr_errors, 4))
    rownames(history) <- NULL

    if(all_numerics){history <- ranker(history, focus = -c(1:11), inverse = NULL, absolute = c("me", "mpe", "sce"), reverse = FALSE)}
    if(all_classes){history <- ranker(history, focus = -c(1:11), inverse = NULL, absolute = NULL, reverse = FALSE)}

    best_index <- as.numeric(rownames(history[1,]))
    predictions <- models[[best_index]]
    errors <- t(as.data.frame(errors[[best_index]]))
    plot <- plots[[best_index]]

    names(predictions) <- feat_names
    rownames(errors) <- feat_names
    names(plot) <- feat_names

    best_model <- list(predictions = predictions, errors = errors, plot = plot)
  }

  time_log <- seconds_to_period(round(proc.time()[["elapsed"]] - start_time, 0))

  outcome <- list(history = history, best_model = best_model, time_log = time_log)
  attr(outcome, "backend") <- backend
  attr(outcome, "ci") <- ci
  attr(outcome, "dates") <- dates

  return(outcome)
}


###
windower <- function(df, seq_len, n_windows = 10, latent, autoencoder_form = c(128, 64),
                     autoencoder_activ = c("gelu", "gelu"), forward_net_form = c(128, 64), forward_net_activ = c("gelu", "gelu"),
                     forward_net_reg_L1 = c(0.5, 0.5), forward_net_reg_L2 = c(0.5, 0.5), forward_net_drop = c(0.5, 0.5),
                     loss_metric = "mae", autoencoder_optimizer = "adam", forward_net_optimizer = "adam", epochs = 100, patience = 10, holdout = 0.5,
                     verbose = FALSE, ci = 0.8, error_scale = "naive", error_benchmark = "naive",
                     dates = NULL, binary_class = rep(FALSE, ncol(df)), deriv = 0, n_samp, seed = 42,
                     batch_size = 32, validation_split = 0.1, n_sim = 1000)
{
  n_length <- nrow(df)
  fnames <- colnames(df)

  idx <- c(base::rep(1, n_length%%(n_windows + 1)), base::rep(1:(n_windows + 1), each = n_length/(n_windows + 1)))

  window_results <- map(1:n_windows, ~ engine(df[idx <= .x, , drop = FALSE], seq_len, holdout_truth = head(df[idx > .x, , drop = FALSE], seq_len), latent, autoencoder_form, autoencoder_activ, forward_net_form, forward_net_activ, forward_net_reg_L1, forward_net_reg_L2, forward_net_drop, loss_metric, autoencoder_optimizer, forward_net_optimizer, epochs, patience, holdout, verbose, ci, error_scale, error_benchmark, binary_class, deriv, seed, batch_size, validation_split, n_sim))
  window_results <- transpose(window_results)
  errors <- map(map_depth(window_results, 2, ~ .x$testing_error), ~ colMeans(t(as.data.frame(.x))))
  pred_scores <- map(map_depth(window_results, 2, ~ .x$quant_pred$pred_scores), ~ colMeans(t(as.data.frame(.x))))

  model <- engine(df, seq_len, holdout_truth = NULL, latent, autoencoder_form, autoencoder_activ, forward_net_form, forward_net_activ, forward_net_reg_L1, forward_net_reg_L2, forward_net_drop, loss_metric, autoencoder_optimizer, forward_net_optimizer, epochs, patience, holdout, verbose, ci, error_scale, error_benchmark, binary_class, deriv, seed, batch_size, validation_split, n_sim)
  message(paste0("model n. ", n_samp))

  quant_pred <- transpose(model)[[1]]
  quant_pred <- map2(quant_pred, pred_scores, ~ cbind(.x, pred_scores = .y))
  plot <- pmap(list(quant_pred, df, fnames), function(qp, ts, fname) plotter(quant_pred = qp, ci, ts = ts, n_class = NULL, level_names = NULL, dates, feat_name = fname))
  quant_pred <- map(quant_pred, ~ dater(.x, dates))
  names(quant_pred) <- fnames
  names(errors) <- fnames
  names(plot) <- fnames

  outcome <- list(quant_pred = quant_pred, errors = errors, plot = plot)

  return(outcome)
}

###
engine <- function(df, seq_len, holdout_truth = NULL,
                   latent, autoencoder_form = c(128, 64), autoencoder_activ = c("gelu", "gelu"),
                   forward_net_form = c(128, 64), forward_net_activ = c("gelu", "gelu"),
                   forward_net_reg_L1 = c(0.5, 0.5), forward_net_reg_L2 = c(0.5, 0.5), forward_net_drop = c(0.5, 0.5),
                   loss_metric = "mae", autoencoder_optimizer = "Adam", forward_net_optimizer = "Adam",
                   epochs = 100, patience = 10, holdout = 0.5, verbose = FALSE, ci = 0.8,
                   error_scale = "naive", error_benchmark = "naive", binary_class, deriv = 0, seed = 42,
                   batch_size = 32, validation_split = 0.1, n_sim = 1000)
{

  seq_len <- seq_len + deriv
  segment_tensor <- bind_arrays(map(df, ~ smart_reframer(.x, seq_len, seq_len)), along = 3)
  difframed_model <- reframed_differentiation(segment_tensor, deriv)
  difframed <- difframed_model$reframed

  autoencoder_model <- torch_autoencoder(tensor = difframed, n_layers = length(autoencoder_form),
                                      activations = autoencoder_activ, layer_sizes = autoencoder_form, latent_space = latent,
                                      latent_activation = "linear", output_activation = "linear",
                                      epochs, batch_size = batch_size, validation_split = validation_split,
                                      optimizer = autoencoder_optimizer, loss_metric,
                                      min_delta = 0.001, patience = patience, seed)

  encoded <- autoencoder_model$encoding(difframed)

  network_model <- torch_snap(input_tensor = head(encoded, -1), output_tensor = tail(encoded, -1), holdout = holdout,
                           layers = length(forward_net_activ), activations = forward_net_activ, regularization_L1 = forward_net_reg_L1, regularization_L2 = forward_net_reg_L2, nodes = forward_net_form, dropout = forward_net_drop,
                           min_delta = 0.001,  batch_size = batch_size, epochs, output_activation = "linear",
                           optimizer = forward_net_optimizer, loss_metric, seed, verbose = 0)


  ###TEST ERROR ESTIMATION
  test_index <- network_model$test_index
  encoded_input <- autoencoder_model$encoding(difframed)
  encoded_output <- network_model$pred_fun(encoded_input)
  decoded_output <- autoencoder_model$decoding(encoded_output)
  raw_errors <- segment_tensor[test_index,,,drop = FALSE] - reframed_integration(decoded_output, difframed_model$head_list, add = TRUE)[test_index,,,drop = FALSE]
  if(deriv > 0){raw_errors <- raw_errors[, - c(1:deriv),, drop = FALSE]}
  seq_len <- seq_len - deriv
  dimnames(raw_errors)[[2]] <- paste0("t", 1:seq_len)

  ###PREDICTION
  encoded_input <- autoencoder_model$encoding(difframed[dim(difframed)[1],,, drop = FALSE])
  encoded_output <- network_model$pred_fun(encoded_input)
  decoded_output <- autoencoder_model$decoding(encoded_output)

  diff_model <- map(df, ~ recursive_diff(.x, deriv))
  diff_tails <- map(diff_model, ~ .x$tail_value)
  seeds <- map2(array_split(decoded_output, along = 3), diff_tails, ~ invdiff(.x, .y))
  raw_errors <- map(array_split(raw_errors, along = 3), ~ as.data.frame(.x))

  raw_predictions <- map2(seeds, raw_errors, ~ prediction_integration(.x, .y, n_sim = n_sim))
  if(is.null(holdout_truth)){quantile_predictions <- pmap(list(raw_predictions, df, binary_class), function(raw_pred, ts, bin) qpred(raw_pred = raw_pred, holdout_truth = NULL, ts = ts, ci, error_scale, error_benchmark, binary_class = bin, seed))}
  if(!is.null(holdout_truth)){quantile_predictions <- pmap(list(raw_predictions, df, binary_class, holdout_truth), function(raw_pred, ts, bin, truth) qpred(raw_pred = raw_pred, holdout_truth = truth, ts = ts, ci, error_scale, error_benchmark, binary_class = bin, seed))}

  return(quantile_predictions)
}

###
prediction_integration <- function(seeds, raw_errors, n_sim = 1000){as.matrix(as.data.frame(map2(seeds, raw_errors, ~ .x + sample(.y, size = n_sim, replace = TRUE))))}

###
qpred <- function(raw_pred, holdout_truth = NULL, ts, ci, error_scale = "naive", error_benchmark = "naive", binary_class = FALSE, seed = 42)
{
  set.seed(seed)

  raw_pred <- doxa_filter(ts, raw_pred, binary_class)
  quants <- sort(unique(c((1-ci)/2, 0.25, 0.5, 0.75, ci+(1-ci)/2)))

  if(binary_class == FALSE)
  {
    p_stats <- function(x){c(min = suppressWarnings(min(x, na.rm = TRUE)), quantile(x, probs = quants, na.rm = TRUE), max = suppressWarnings(max(x, na.rm = TRUE)), mean = mean(x, na.rm = TRUE), sd = sd(x, na.rm = TRUE), mode = suppressWarnings(mlv1(x[is.finite(x)], method = "shorth")), kurtosis = suppressWarnings(kurtosis(x[is.finite(x)], na.rm = TRUE)), skewness = suppressWarnings(skewness(x[is.finite(x)], na.rm = TRUE)))}
    quant_pred <- as.data.frame(t(as.data.frame(apply(raw_pred, 2, p_stats))))
    p_value <- apply(raw_pred, 2, function(x) ecdf(x)(seq(min(raw_pred), max(raw_pred), length.out = 1000)))
    divergence <- c(max(p_value[,1] - seq(0, 1, length.out = 1000)), apply(p_value[,-1, drop = FALSE] - p_value[,-ncol(p_value), drop = FALSE], 2, function(x) abs(max(x, na.rm = TRUE))))
    upside_prob <- c(mean((raw_pred[,1]/tail(ts, 1)) > 1, na.rm = TRUE), apply(apply(raw_pred[,-1, drop = FALSE]/raw_pred[,-ncol(raw_pred), drop = FALSE], 2, function(x) x > 1), 2, mean, na.rm = TRUE))
    iqr_to_range <- (quant_pred[, "75%"] - quant_pred[, "25%"])/(quant_pred[, "max"] - quant_pred[, "min"])
    above_to_below_range <- (quant_pred[, "max"] - quant_pred[, "50%"])/(quant_pred[, "50%"] - quant_pred[, "min"])
    quant_pred <- round(cbind(quant_pred, iqr_to_range, above_to_below_range, upside_prob, divergence), 4)
  }

  if(binary_class == TRUE)
  {
    p_stats <- function(x){c(min = suppressWarnings(min(x, na.rm = TRUE)), quantile(x, probs = quants, na.rm = TRUE), max = suppressWarnings(max(x, na.rm = TRUE)), prop = mean(x, na.rm = TRUE), sd = sd(x, na.rm = TRUE), entropy = entropy(x))}
    quant_pred <- as.data.frame(t(as.data.frame(apply(raw_pred, 2, p_stats))))
    p_value <- apply(raw_pred, 2, function(x) ecdf(x)(c(0, 1)))
    divergence <- c(max(p_value[,1] - c(0, 1)), apply(p_value[,-1, drop = FALSE] - p_value[,-ncol(p_value), drop = FALSE], 2, function(x) abs(max(x, na.rm = TRUE))))
    upgrade_prob <- c(mean((raw_pred[,1]/tail(ts, 1)) > 1, na.rm = TRUE), apply(apply(raw_pred[,-1, drop = FALSE]/raw_pred[,-ncol(raw_pred), drop = FALSE], 2, function(x) x > 1), 2, mean, na.rm = TRUE))
    quant_pred <- round(cbind(quant_pred, upgrade_prob = upgrade_prob, divergence = divergence), 4)
  }

  testing_error <- NULL
  if(!is.null(holdout_truth))
  {
    mean_pred <- colMeans(raw_pred)
    testing_error <- custom_metrics(holdout_truth, mean_pred, ts, error_scale, error_benchmark, binary_class)
    pred_scores <- round(prediction_score(raw_pred, holdout_truth), 4)
    quant_pred <- cbind(quant_pred, pred_scores = pred_scores)
  }

  rownames(quant_pred) <- NULL

  outcome <- list(quant_pred = quant_pred, testing_error = testing_error)
  return(outcome)
}

###
doxa_filter <- function(ts, mat, binary_class = FALSE)
{
  discrete_check <- all(ts%%1 == 0)
  all_positive_check <- all(ts >= 0)
  all_negative_check <- all(ts <= 0)
  monotonic_increase_check <- all(diff(ts) >= 0)
  monotonic_decrease_check <- all(diff(ts) <= 0)

  monotonic_fixer <- function(x, mode)
  {
    model <- recursive_diff(x, 1)
    vect <- model$vector
    if(mode == 0){vect[vect < 0] <- 0; vect <- invdiff(vect, model$head_value, add = TRUE)}
    if(mode == 1){vect[vect > 0] <- 0; vect <- invdiff(vect, model$head_value, add = TRUE)}
    return(vect)
  }

  if(all_positive_check){mat[mat < 0] <- 0}
  if(all_negative_check){mat[mat > 0] <- 0}
  if(discrete_check){mat <- round(mat)}
  if(monotonic_increase_check){mat <- t(apply(mat, 1, function(x) monotonic_fixer(x, mode = 0)))}
  if(monotonic_decrease_check){mat <- t(apply(mat, 1, function(x) monotonic_fixer(x, mode = 1)))}

  if(binary_class == TRUE){mat[mat > 1] <- 1; mat[mat < 1] <- 0}
  mat <- na.omit(mat)

  return(mat)
}

###
recursive_diff <- function(vector, deriv)
{
  vector <- unlist(vector)
  head_value <- vector("numeric", deriv)
  tail_value <- vector("numeric", deriv)
  if(deriv==0){head_value = NULL; tail_value = NULL}
  if(deriv > 0){for(i in 1:deriv){head_value[i] <- head(vector, 1); tail_value[i] <- tail(vector, 1); vector <- diff(vector)}}
  outcome <- list(vector = vector, head_value = head_value, tail_value = tail_value)
  return(outcome)
}

###
invdiff <- function(vector, heads, add = FALSE)
{
  vector <- unlist(vector)
  if(is.null(heads)){return(vector)}
  for(d in length(heads):1){vector <- cumsum(c(heads[d], vector))}
  if(add == FALSE){return(vector[-c(1:length(heads))])} else {return(vector)}
}

###
custom_metrics <- function(holdout, forecast, actuals, error_scale = "naive", error_benchmark = "naive", binary_class = FALSE)
{

 if(binary_class == FALSE)
  {
    scale <- switch(error_scale, "deviation" = sd(actuals), "naive" = mean(abs(diff(actuals))))
    benchmark <- switch(error_benchmark, "average" = rep(mean(actuals), length(forecast)), "naive" = rep(tail(actuals, 1), length(forecast)))
    me <- ME(holdout, forecast, na.rm = TRUE)
    mae <- MAE(holdout, forecast, na.rm = TRUE)
    mse <- MSE(holdout, forecast, na.rm = TRUE)
    rmsse <- RMSSE(holdout, forecast, scale, na.rm = TRUE)
    mre <- MRE(holdout, forecast, na.rm = TRUE)
    mpe <- MPE(holdout, forecast, na.rm = TRUE)
    mape <- MAPE(holdout, forecast, na.rm = TRUE)
    rmae <- rMAE(holdout, forecast, benchmark, na.rm = TRUE)
    rrmse <- rRMSE(holdout, forecast, benchmark, na.rm = TRUE)
    rame <- rAME(holdout, forecast, benchmark, na.rm = TRUE)
    mase <- MASE(holdout, forecast, scale, na.rm = TRUE)
    smse <- sMSE(holdout, forecast, scale, na.rm = TRUE)
    sce <- sCE(holdout, forecast, scale, na.rm = TRUE)
    gmrae <- GMRAE(holdout, forecast, benchmark, na.rm = TRUE)
    out <- round(c(me = me, mae = mae, mse = mse, rmsse = rmsse, mpe = mpe, mape = mape, rmae = rmae, rrmse = rrmse, rame = rame, mase = mase, smse = smse, sce = sce, gmrae = gmrae), 3)
  }

  if(binary_class == TRUE)
  {
    dice <- suppressMessages(distance(rbind(holdout, forecast), method = "dice"))
    jaccard <- suppressMessages(distance(rbind(holdout, forecast), method = "jaccard"))
    cosine <- suppressMessages(distance(rbind(holdout, forecast), method = "cosine"))
    canberra <- suppressMessages(distance(rbind(holdout, forecast), method = "canberra"))
    gower <- suppressMessages(distance(rbind(holdout, forecast), method = "gower"))
    tanimoto <- suppressMessages(distance(rbind(holdout, forecast), method = "tanimoto"))
    hassebrook <- 1 - suppressMessages(distance(rbind(holdout, forecast), method = "hassebrook"))
    taneja <- suppressMessages(distance(rbind(holdout, forecast), method = "taneja"))
    lorentzian <- suppressMessages(distance(rbind(holdout, forecast), method = "lorentzian"))
    clark <- suppressMessages(distance(rbind(holdout, forecast), method = "clark"))
    sorensen <- suppressMessages(distance(rbind(holdout, forecast), method = "sorensen"))
    harmonic_mean <- suppressMessages(distance(rbind(holdout, forecast), method = "harmonic_mean"))
    avg <- suppressMessages(distance(rbind(holdout, forecast), method = "avg"))

    out <- round(c(dice, jaccard, cosine, canberra, gower, tanimoto, hassebrook, taneja, lorentzian, clark, sorensen, harmonic_mean, avg), 4)
  }

  return(out)
}

###
prediction_score <- function(integrated_preds, ground_truth)
{
  pfuns <- apply(integrated_preds, 2, ecdf)
  pvalues <- map2_dbl(pfuns, ground_truth, ~ .x(.y))
  scores <- 1 - 2 * abs(pvalues - 0.5)
  return(scores)
}

###

best_deriv <- function(ts, max_diff = 3, thresh = 0.001)
{
  pvalues <- vector(mode = "double", length = as.integer(max_diff))

  for(d in 1:(max_diff + 1))
  {
    model <- lm(ts ~ t, data.frame(ts, t = 1:length(ts)))
    pvalues[d] <- with(summary(model), pf(fstatistic[1], fstatistic[2], fstatistic[3],lower.tail=FALSE))
    ts <- diff(ts)
  }

  best <- tail(cumsum(pvalues < thresh), 1)

  return(best)
}

###

ranker <- function(df, focus, inverse = NULL, absolute = NULL, reverse = FALSE)
{
  rank_set <- df[, focus, drop = FALSE]
  if(!is.null(inverse)){rank_set[, inverse] <- - rank_set[, inverse]}###INVERSION BY COL NAMES
  if(!is.null(absolute)){rank_set[, absolute] <- abs(rank_set[, absolute])}###ABS BY COL NAMES
  index <- apply(scale(rank_set), 1, mean, na.rm = TRUE)
  if(reverse == FALSE){df <- df[order(index),]}
  if(reverse == TRUE){df <- df[order(-index),]}
  return(df)
}

###
ts_graph <- function(x_hist, y_hist, x_forcat, y_forcat, lower = NULL, upper = NULL, line_size = 1.3, label_size = 11,
                     forcat_band = "seagreen2", forcat_line = "seagreen4", hist_line = "gray43", label_x = "Horizon", label_y= "Forecasted Var", dbreak = NULL, date_format = "%b-%d-%Y")
{
  if(is.character(y_hist)){y_hist <- as.factor(y_hist)}
  if(is.character(y_forcat)){y_forcat <- factor(y_forcat, levels = levels(y_hist))}
  if(is.character(lower)){lower <- factor(lower, levels = levels(y_hist))}
  if(is.character(upper)){upper <- factor(upper, levels = levels(y_hist))}

  n_class <- NULL
  if(is.factor(y_hist)){class_levels <- levels(y_hist); n_class <- length(class_levels)}

  all_data <- data.frame(x_all = c(x_hist, x_forcat), y_all = as.numeric(c(y_hist, y_forcat)))
  forcat_data <- data.frame(x_forcat = x_forcat, y_forcat = as.numeric(y_forcat))

  if(!is.null(lower) & !is.null(upper)){forcat_data$lower <- as.numeric(lower); forcat_data$upper <- as.numeric(upper)}

  return(codez_plot(data = list(history = all_data, forecast = forcat_data),
                    type = "forecast",
                    labels = list(x = label_x, y = label_y)))
}

###
sampler <- function(vect, n_samp, range = NULL, integer = FALSE, fun = NULL, multi = NULL)
{
  if(is.null(vect) & is.null(fun))
  {
    if(!is.character(range)){if(integer){set <- min(range):max(range)} else {set <- seq(min(range), max(range), length.out = 1000)}} else {set <- range}
    if(is.null(multi)){samp <- sample(set, n_samp, replace = TRUE)}
    if(is.numeric(multi)){samp <- replicate(n_samp, sample(set, multi, replace = TRUE), simplify = FALSE)}
  }

  if(is.null(vect) & !is.null(fun)){samp <- fun}

  if(is.null(multi)){
    if(length(vect)==1){samp <- rep(vect, n_samp)}
    if(length(vect) > 1){samp <- sample(vect, n_samp, replace = TRUE)}}

  if(is.numeric(multi)){
    if(length(vect)==1){samp <- replicate(n_samp, rep(vect, multi), simplify = FALSE)}
    if(length(vect) > 1){samp <- replicate(n_samp, sample(vect, multi, replace = TRUE), simplify = FALSE)}}

  return(samp)
}

smart_reframer <- function(ts, seq_len, stride)
{
  n_length <- length(ts)
  if(seq_len > n_length | stride > n_length){stop("vector too short for sequence length or stride")}
  if(n_length%%seq_len > 0){ts <- tail(ts, - (n_length%%seq_len))}
  n_length <- length(ts)
  idx <- base::seq(from = 1, to = (n_length - seq_len + 1), by = 1)
  reframed <- t(sapply(idx, function(x) ts[x:(x+seq_len-1)]))
  if(seq_len == 1){reframed <- t(reframed)}
  idx <- rev(base::seq(nrow(reframed), 1, - stride))
  reframed <- reframed[idx,,drop = FALSE]
  colnames(reframed) <- paste0("t", 1:seq_len)
  return(reframed)
}


###
reframed_differentiation <- function(reframed, diff)
{
  ddim <- dim(reframed)[2]

  if(diff == 0){return(list(reframed = reframed, head_list = NULL, tail_list = NULL))}

  if(diff > 0)
  {
    if(diff >= ddim){stop("diff is greater/ equal to dim 2")}
    head_list <- list()
    tail_list <- list()

    for(d in 1:diff)
    {
      head_list <- append(head_list, list(reframed[, 1,, drop = FALSE]))
      tail_list <- append(tail_list,  list(reframed[, dim(reframed)[2],, drop = FALSE]))
      reframed <- reframed[,2:(ddim - d + 1),, drop = FALSE] - reframed[,1:(ddim - d + 1 - 1),, drop = FALSE]
    }
  }

  outcome <- list(reframed = reframed, head_list = head_list, tail_list = tail_list)
  return(outcome)
}

###
reframed_integration <- function(reframed, head_list, add = FALSE)
{
  if(is.null(head_list)){return(reframed)}

  diff <- length(head_list)
  for(d in diff:1)
  {
    reframed <- bind_arrays(head_list[[d]], reframed, along = 2)
    reframed <- aperm(apply(reframed, - 2, cumsum), c(2, 1, 3))
  }

  if(add == FALSE){reframed <- reframed[,-c(1:diff),, drop = FALSE]}

  return(reframed)
}

###
plotter <- function(quant_pred, ci, ts, n_class = NULL, level_names = NULL, dates = NULL, feat_name)
{
  seq_len <- nrow(quant_pred)
  n_ts <- length(ts)

  if(is.Date(dates))
  {
    new_dates<- seq.Date(tail(dates, 1), tail(dates, 1) + seq_len * mean(diff(dates)), length.out = seq_len)
    x_hist <- dates
    x_forcat <- new_dates
    rownames(quant_pred) <- as.character(new_dates)
  }
  else
  {
    x_hist <- 1:n_ts
    x_forcat <- (n_ts + 1):(n_ts + seq_len)
    rownames(quant_pred) <- paste0("t", 1:seq_len)
  }

  quant_pred <- as.data.frame(quant_pred)
  x_lab <- paste0("Forecasting Horizon for sequence n = ", seq_len)
  y_lab <- paste0("Forecasting Values for ", feat_name)

  if(is.numeric(n_class) & !is.null(level_names)){ts <- level_names[ts + 1]}
  lower_b <- paste0((1-ci)/2 * 100, "%")
  upper_b <- paste0((ci+(1-ci)/2) * 100, "%")

  plot <- ts_graph(x_hist = x_hist, y_hist = ts, x_forcat = x_forcat, y_forcat = quant_pred[, "50%"], lower = quant_pred[, lower_b], upper = quant_pred[, upper_b], label_x = x_lab, label_y = y_lab)
  return(plot)
}

###
dater <- function(quant_pred, dates)
{
  seq_len <- nrow(quant_pred)

  if(is.Date(dates))
  {
    new_dates<- seq.Date(tail(dates, 1), tail(dates, 1) + seq_len * mean(diff(dates)), length.out = seq_len)
    rownames(quant_pred) <- as.character(new_dates)
  }

  else

  {
    rownames(quant_pred) <- paste0("t", 1:seq_len)
  }

  return(quant_pred)
}

###
torch_activation <- function(x, activation = "linear")
{
  activation <- tolower(activation)
  switch(activation,
         "linear" = x,
         "relu" = torch::nnf_relu(x),
         "leaky_relu" = torch::nnf_leaky_relu(x),
         "selu" = torch::nnf_selu(x),
         "elu" = torch::nnf_elu(x),
         "sigmoid" = torch::torch_sigmoid(x),
         "tanh" = torch::torch_tanh(x),
         "swish" = x * torch::torch_sigmoid(x),
         "gelu" = 0.5 * x * (1 + torch::torch_tanh(sqrt(2 / pi) * (x + 0.044715 * x * x * x))),
         stop("non-standard activation"))
}

torch_loss <- function(predicted, actual, loss_metric = "mae")
{
  metric <- tolower(loss_metric %||% "mae")
  switch(metric,
         "mae" = torch::torch_mean(torch::torch_abs(predicted - actual)),
         "mean_absolute_error" = torch::torch_mean(torch::torch_abs(predicted - actual)),
         "mse" = torch::torch_mean((predicted - actual) * (predicted - actual)),
         "mean_squared_error" = torch::torch_mean((predicted - actual) * (predicted - actual)),
         "mape" = torch::torch_mean(torch::torch_abs((actual - predicted) / torch::torch_clamp(torch::torch_abs(actual), min = 1e-8))),
         stop("unsupported loss_metric"))
}

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

torch_optimizer <- function(parameters, optimizer = "adam", lr = 0.001, weight_decay = 0)
{
  optimizer <- tolower(optimizer %||% "adam")
  if(optimizer == "nadam"){warning("torch backend does not expose nadam here; using adam instead"); optimizer <- "adam"}
  if(optimizer == "adamax" && exists("optim_adamax", asNamespace("torch"), inherits = FALSE)){
    return(get("optim_adamax", asNamespace("torch"))(parameters, lr = lr, weight_decay = weight_decay))
  }
  switch(optimizer,
         "adam" = torch::optim_adam(parameters, lr = lr, weight_decay = weight_decay),
         "adadelta" = torch::optim_adadelta(parameters, lr = lr, weight_decay = weight_decay),
         "adagrad" = torch::optim_adagrad(parameters, lr = lr, weight_decay = weight_decay),
         "rmsprop" = torch::optim_rmsprop(parameters, lr = lr, weight_decay = weight_decay),
         "sgd" = torch::optim_sgd(parameters, lr = lr, weight_decay = weight_decay),
         "adamax" = torch::optim_adam(parameters, lr = lr, weight_decay = weight_decay),
         stop("unsupported optimizer"))
}

torch_to_array <- function(x)
{
  if(exists("as_array", asNamespace("torch"), inherits = FALSE)){
    return(get("as_array", asNamespace("torch"))(x$detach()$cpu()))
  }
  as.array(x$detach()$cpu())
}

torch_tensor_from_matrix <- function(x)
{
  torch::torch_tensor(as.matrix(x), dtype = torch::torch_float())
}

torch_flatten_samples <- function(x)
{
  dims <- dim(x)
  if(is.null(dims)){return(matrix(as.numeric(x), ncol = 1))}
  matrix(as.numeric(x), nrow = dims[1])
}

torch_regularization <- function(model, l1 = 0, l2 = 0)
{
  l1 <- mean(l1, na.rm = TRUE)
  l2 <- mean(l2, na.rm = TRUE)
  if(!is.finite(l1)){l1 <- 0}
  if(!is.finite(l2)){l2 <- 0}
  if(l1 == 0 && l2 == 0){return(NULL)}

  penalty <- NULL
  for(param in model$parameters)
  {
    term <- 0
    if(l1 > 0){term <- term + l1 * torch::torch_sum(torch::torch_abs(param))}
    if(l2 > 0){term <- term + l2 * torch::torch_sum(param * param)}
    penalty <- if(is.null(penalty)) term else penalty + term
  }
  penalty
}

torch_history_plot <- function(history)
{
  codez_plot(data = history, type = "training", labels = list(x = "Epoch", y = "Loss"))
}

torch_fit_matrix <- function(model, x_train, y_train, x_valid = NULL, y_valid = NULL,
                             optimizer = "adam", loss_metric = "mae", epochs = 50,
                             batch_size = 32, patience = 10, min_delta = 0,
                             verbose = FALSE, l1 = 0, l2 = 0)
{
  if(!requireNamespace("torch", quietly = TRUE)){stop("the torch package is required")}
  n <- nrow(x_train)
  batch_size <- max(1, as.integer(batch_size))
  patience <- max(1, as.integer(patience))
  opt <- torch_optimizer(model$parameters, optimizer = optimizer, weight_decay = mean(l2, na.rm = TRUE))
  history <- data.frame(epoch = integer(), loss = numeric(), val_loss = numeric())
  best_loss <- Inf
  stale_epochs <- 0

  for(epoch in seq_len(epochs))
  {
    order <- sample.int(n)
    losses <- numeric()
    for(start in seq(1, n, by = batch_size))
    {
      idx <- order[start:min(start + batch_size - 1, n)]
      xb <- torch_tensor_from_matrix(x_train[idx,, drop = FALSE])
      yb <- torch_tensor_from_matrix(y_train[idx,, drop = FALSE])
      opt$zero_grad()
      prediction <- model(xb)
      loss <- torch_loss(prediction, yb, loss_metric)
      penalty <- torch_regularization(model, l1 = l1, l2 = 0)
      if(!is.null(penalty)){loss <- loss + penalty / n}
      loss$backward()
      opt$step()
      losses <- c(losses, as.numeric(loss$item()))
    }

    train_loss <- mean(losses, na.rm = TRUE)
    val_loss <- train_loss
    if(!is.null(x_valid) && nrow(x_valid) > 0)
    {
      torch::with_no_grad({
        validation_prediction <- model(torch_tensor_from_matrix(x_valid))
        validation_loss <- torch_loss(validation_prediction, torch_tensor_from_matrix(y_valid), loss_metric)
      })
      val_loss <- as.numeric(validation_loss$item())
    }
    history <- rbind(history, data.frame(epoch = epoch, loss = train_loss, val_loss = val_loss))
    if(isTRUE(verbose)){message(sprintf("epoch %s loss %.5f val_loss %.5f", epoch, train_loss, val_loss))}

    if((best_loss - val_loss) > min_delta)
    {
      best_loss <- val_loss
      stale_epochs <- 0
    }
    else
    {
      stale_epochs <- stale_epochs + 1
      if(stale_epochs >= patience){break}
    }
  }

  history
}

torch_snap <- function(input_tensor, output_tensor, holdout = 0.2,
                       layers = 1, activations = "relu", regularization_L1 = 0, regularization_L2 = 0, nodes = 32, dropout = 0,
                       min_delta = 0, batch_size = 32, epochs = 50, output_activation = NULL,
                       optimizer = "adam", loss_metric = NULL, seed = 42, verbose = 0)
{
  if(!requireNamespace("torch", quietly = TRUE)){stop("the torch package is required")}
  torch::torch_manual_seed(seed)
  set.seed(seed)

  regr_metrics <- function(actual, predicted)
  {
    actual <- unlist(actual)
    predicted <- unlist(predicted)
    if(length(actual) != length(predicted)){stop("different lengths")}

    rmse <- sqrt(mean((actual - predicted)^2))
    mae <- mean(abs(actual - predicted))
    mdae <- median(abs(actual - predicted))
    mape <- mean(abs(actual - predicted) / pmax(abs(actual), 1e-8))
    rrse <- sqrt(sum((actual - predicted)^2)) / sqrt(sum((actual - mean(actual))^2))
    rae <- sum(abs(actual - predicted)) / sum(abs(actual - mean(actual)))

    round(c(rmse = rmse, mae = mae, mdae = mdae, mape = mape, rrse = rrse, rae = rae), 4)
  }

  x_matrix <- torch_flatten_samples(input_tensor)
  y_matrix <- torch_flatten_samples(output_tensor)
  x_rows <- nrow(x_matrix)
  output_dims <- dim(output_tensor)[-1]
  if(is.null(output_dims)){output_dims <- ncol(y_matrix)}

  test_index <- sample(x_rows, max(1, ceiling(holdout * x_rows)))
  train_index <- setdiff(seq_len(x_rows), test_index)
  if(length(train_index) == 0){train_index <- test_index}

  if(length(activations) < layers){activations <- replicate(layers, activations[1])}
  if(length(regularization_L1) < layers){regularization_L1 <- replicate(layers, regularization_L1[1])}
  if(length(regularization_L2) < layers){regularization_L2 <- replicate(layers, regularization_L2[1])}
  if(length(nodes) < layers){nodes <- replicate(layers, nodes[1])}
  if(length(dropout) < layers){dropout <- replicate(layers, dropout[1])}

  configuration <- data.frame(layers = layers)
  configuration$activations <- list(activations)
  configuration$regularization_L1 <- list(regularization_L1)
  configuration$regularization_L2 <- list(regularization_L2)
  configuration$nodes <- list(nodes)
  configuration$dropout <- list(dropout)

  dense_module <- torch::nn_module(
    initialize = function(input_dim, output_dim, layers, activations, nodes, dropout, output_activation)
    {
      self$layers_n <- layers
      self$activations <- activations
      self$dropout_rates <- dropout
      self$output_activation <- output_activation %||% "linear"
      self$dense <- torch::nn_module_list()
      in_dim <- input_dim
      for(i in seq_len(layers))
      {
        self$dense$append(torch::nn_linear(in_dim, nodes[i]))
        in_dim <- nodes[i]
      }
      self$output <- torch::nn_linear(in_dim, output_dim)
    },
    forward = function(x)
    {
      for(i in seq_len(self$layers_n))
      {
        x <- self$dense[[i]](x)
        x <- torch_activation(x, self$activations[i])
        if(self$dropout_rates[i] > 0){x <- torch::nnf_dropout(x, p = self$dropout_rates[i], training = self$training)}
      }
      torch_activation(self$output(x), self$output_activation)
    }
  )

  model <- dense_module(ncol(x_matrix), ncol(y_matrix), layers, activations, nodes, dropout, output_activation)

  history <- torch_fit_matrix(model, x_matrix[train_index,, drop = FALSE], y_matrix[train_index,, drop = FALSE],
                              x_valid = x_matrix[test_index,, drop = FALSE], y_valid = y_matrix[test_index,, drop = FALSE],
                              optimizer = optimizer, loss_metric = loss_metric %||% "mae", epochs = epochs,
                              batch_size = batch_size, patience = max(1, floor(epochs * 0.2)),
                              min_delta = min_delta, verbose = verbose, l1 = regularization_L1, l2 = regularization_L2)

  pred_fun <- function(new)
  {
    new_matrix <- torch_flatten_samples(new)
    model$eval()
    torch::with_no_grad({
      prediction <- model(torch_tensor_from_matrix(new_matrix))
    })
    prediction <- torch_to_array(prediction)
    array(prediction, dim = c(nrow(new_matrix), output_dims))
  }

  test_prediction <- pred_fun(input_tensor[test_index,, drop = FALSE])
  test_metrics <- suppressWarnings(regr_metrics(output_tensor[test_index,, drop = FALSE], test_prediction))

  list(configuration = configuration, model = model, pred_fun = pred_fun, test_index = test_index,
       history = history, plot = torch_history_plot(history), test_metrics = test_metrics)
}

###
torch_autoencoder <- function(tensor, n_layers = 3, activations = c("relu", "relu", "relu"),
                              layer_sizes = c(128, 64, 32), latent_space, latent_activation = "linear", output_activation = "linear",
                              epochs = 30, batch_size = 32, validation_split = 0.3, optimizer = "adam", loss_metric = "mae",
                              min_delta = 0.001, patience = 10, seed = 42)
{
  if(!requireNamespace("torch", quietly = TRUE)){stop("the torch package is required")}
  if(!is.array(tensor)){stop("tensor required")}
  torch::torch_manual_seed(seed)
  set.seed(seed)

  standard_activations <- c("linear", "relu", "leaky_relu", "selu", "elu", "sigmoid", "tanh", "swish", "gelu")
  if(!all(activations %in% standard_activations)){stop("non-standard activation")}
  if(length(activations) != n_layers){activations <- rep(activations[1], n_layers)}
  if(length(layer_sizes) != n_layers){layer_sizes <- rep(layer_sizes[1], n_layers)}

  input_dims <- dim(tensor)[-1]
  flat <- torch_flatten_samples(tensor)
  n <- nrow(flat)
  valid_n <- if(validation_split > 0 && n > 2) max(1, floor(validation_split * n)) else 0
  valid_index <- if(valid_n > 0) sample(seq_len(n), valid_n) else integer()
  train_index <- setdiff(seq_len(n), valid_index)
  if(length(train_index) == 0){train_index <- seq_len(n)}

  autoencoder_module <- torch::nn_module(
    initialize = function(input_dim, n_layers, activations, layer_sizes, latent_space, latent_activation, output_activation)
    {
      self$n_layers <- n_layers
      self$activations <- activations
      self$latent_activation <- latent_activation
      self$output_activation <- output_activation
      self$encoder_layers <- torch::nn_module_list()
      in_dim <- input_dim
      for(i in seq_len(n_layers))
      {
        self$encoder_layers$append(torch::nn_linear(in_dim, layer_sizes[i]))
        in_dim <- layer_sizes[i]
      }
      self$latent_layer <- torch::nn_linear(in_dim, latent_space)

      self$decoder_layers <- torch::nn_module_list()
      in_dim <- latent_space
      decoder_sizes <- rev(layer_sizes)
      decoder_activations <- rev(activations)
      self$decoder_activations <- decoder_activations
      for(i in seq_len(n_layers))
      {
        self$decoder_layers$append(torch::nn_linear(in_dim, decoder_sizes[i]))
        in_dim <- decoder_sizes[i]
      }
      self$output_layer <- torch::nn_linear(in_dim, input_dim)
    },
    encode = function(x)
    {
      for(i in seq_len(self$n_layers))
      {
        x <- self$encoder_layers[[i]](x)
        x <- torch_activation(x, self$activations[i])
      }
      torch_activation(self$latent_layer(x), self$latent_activation)
    },
    decode = function(x)
    {
      for(i in seq_len(self$n_layers))
      {
        x <- self$decoder_layers[[i]](x)
        x <- torch_activation(x, self$decoder_activations[i])
      }
      torch_activation(self$output_layer(x), self$output_activation)
    },
    forward = function(x)
    {
      self$decode(self$encode(x))
    }
  )

  model <- autoencoder_module(ncol(flat), n_layers, activations, layer_sizes, latent_space, latent_activation, output_activation)

  history <- torch_fit_matrix(model, flat[train_index,, drop = FALSE], flat[train_index,, drop = FALSE],
                              x_valid = flat[valid_index,, drop = FALSE], y_valid = flat[valid_index,, drop = FALSE],
                              optimizer = optimizer, loss_metric = loss_metric, epochs = epochs,
                              batch_size = batch_size, patience = patience, min_delta = min_delta, verbose = FALSE)

  model$eval()
  torch::with_no_grad({
    reconstructed <- model(torch_tensor_from_matrix(flat))
    mean_error <- torch_loss(reconstructed, torch_tensor_from_matrix(flat), loss_metric)
  })

  encoding <- function(new)
  {
    new_matrix <- torch_flatten_samples(new)
    model$eval()
    torch::with_no_grad({
      encoded <- model$encode(torch_tensor_from_matrix(new_matrix))
    })
    torch_to_array(encoded)
  }

  decoding <- function(new)
  {
    new_matrix <- as.matrix(new)
    model$eval()
    torch::with_no_grad({
      decoded <- model$decode(torch_tensor_from_matrix(new_matrix))
    })
    decoded <- torch_to_array(decoded)
    array(decoded, dim = c(nrow(new_matrix), input_dims))
  }

  list(history = torch_history_plot(history), encoder = NULL, decoder = NULL, model = model,
       mean_error = as.numeric(mean_error$item()), encoding = encoding, decoding = decoding)
}
