R/dt-utils.R

In survalis: Interpretable Survival Machine Learning Framework

# Applies `f` to each grid row. With `learner` set (the tuners), a
# configuration that errors is dropped with an informative warning instead of
# aborting the whole search.
.pmap_rbind_dt <- function(grid, f, learner = NULL) {
  grid <- as.data.frame(grid)
  results <- lapply(seq_len(nrow(grid)), function(i) {
    row <- grid[i, , drop = FALSE]
    if (is.null(learner)) return(do.call(f, as.list(row)))
    tryCatch(do.call(f, as.list(row)),
             error = function(e) .tune_config_failed(learner, row, e))
  })
  .rbind_fill_dt(results)
}

.map_rbind_dt <- function(x, f) {
  results <- lapply(x, f)
  .rbind_fill_dt(results)
}

# Row-binds `results` (data.frames, possibly with differing columns --
# e.g. a failed tuning row that omits metric columns -- and possibly
# carrying a list-column, e.g. a `hidden` layer-size grid) via base rbind() after
# padding to a common column set. Not basetable::rbindfill(): rbindfill()
# coerces list-columns to NA instead of preserving them.
.rbind_fill_dt <- function(results) {
  results <- Filter(Negate(is.null), results)
  if (!length(results)) return(basetable::asbasetable(data.frame()))
  results <- lapply(results, as.data.frame)
  all_cols <- unique(unlist(lapply(results, names)))
  results <- lapply(results, function(df) {
    missing <- setdiff(all_cols, names(df))
    for (col in missing) df[[col]] <- NA
    df[all_cols]
  })
  out <- do.call(rbind, results)
  rownames(out) <- NULL
  basetable::asbasetable(out)
}

.complete_cases_df <- function(data, vars) {
  # a `.` in the formula stands for every column
  if ("." %in% vars) vars <- names(data)
  vars <- intersect(vars, names(data))
  data[stats::complete.cases(data[, vars, drop = FALSE]), , drop = FALSE]
}

.tune_config_failed <- function(learner, params, e) {
  cfg <- paste(names(params),
               vapply(params, function(v) paste(format(v), collapse = ","), ""),
               sep = " = ", collapse = ", ")
  warning("Tuning '", learner, "' (", cfg, ") failed: ", conditionMessage(e),
          call. = FALSE)
  NULL
}

.wide_metric_row <- function(params, cv_summary_dt) {
  metric_vals <- as.list(stats::setNames(cv_summary_dt$mean, cv_summary_dt$metric))
  # list-valued params (e.g. a `hidden` layer-size grid) must stay a single list-column
  # entry rather than being spread across columns by base data.frame()'s
  # default list-argument handling.
  params <- lapply(params, function(x) if (is.list(x)) I(x) else x)
  do.call(data.frame, c(params, metric_vals, stringsAsFactors = FALSE, check.names = FALSE))
}

.arrange_by_metric_dt <- function(dt, metric, maximize) {
  basetable::orderrows(dt, by = metric, decreasing = maximize)
}

# A plain data.frame/tibble/basetable's `[i, j, drop = FALSE]` always
# selects columns when `j` is a variable holding column names.
.select_cols <- function(x, cols) {
  x[, cols, drop = FALSE]
}