R/zzz-step-vpd-persistence-block.R

In tdarec: A 'recipes' Extension for Persistent Homology and Its Vectorizations

# ------------------------------------------------------------------------------
# Generated by 'pre-generate/generate-steps.R': do not edit by hand.
# ------------------------------------------------------------------------------

#' @title Persistence Block Vectorization of Persistent Homology
#' 
#' @description The function `step_vpd_persistence_block()` creates
#'   a _specification_ of a recipe step that will convert
#'   a list-column of 3-column matrices of persistence data
#'   to a list-column of 1-row matrices of vectorizations.
#' 

#' 
#' @template step-vpd-details
#' 
#' @section Engine:
#' 
#' The persistence block vectorization deploys
#' [TDAvec::computePersistenceBlock()].
#' See there for definitions and references.
#' 
#' @section Tuning Parameters:
#' 
#' This step has 2 tuning parameters:
#' \itemize{
#'   \item `hom_degree`: Homological degree (type: integer, default: `0L`)
#'   \item `block_size`: Square side length scaling factor (type: double, default: `0.3`)
#' }
#' 
#' @param hom_degree
#'   The homological degree of the features to be transformed.
#' @param xseq
#'   A discretization grid, as an increasing numeric vector.
#'   `xseq` overrides the other `x*` parameters with a warning.
#' @param xmin,xmax,xlen,xby
#'   Limits and resolution of a discretization grid;
#'   specify only one of `xlen` and `xby`.
#' @param yseq
#'   Combined with `xseq` to form a 2-dimensional discretization grid.
#' @param ymin,ymax,ylen,yby
#'   Limits and resolution of a discretization grid;
#'   specify only one of `ylen` and `yby`.
#' @param block_size
#'   The scaling factor of the squares used to obtain persistence blocks.
#'   The side length of the square centered at a feature \eqn{(b,p)}
#'   is obtained by multiplying \eqn{2p} by this factor.

#' @import recipes
#' @inheritParams recipes::step_pca
#' @inherit recipes::step_pca return
#' @example inst/examples/zzz-ex-step-vpd-persistence-block.R

#' @export
step_vpd_persistence_block <- function(
    recipe,
    ...,
    role = "predictor",
    trained = FALSE,
    hom_degree = 0L,
    xseq = NULL, xmin = NULL, xmax = NULL, xlen = NULL, xby = NULL,
    yseq = NULL, ymin = NULL, ymax = NULL, ylen = NULL, yby = NULL,
    block_size = 0.3,
    columns = NULL,
    keep_original_cols = TRUE,
    skip = FALSE,
    id = rand_id("vpd_persistence_block")
) {
  recipes_pkg_check(required_pkgs.step_vpd_persistence_block())
  
  add_step(
    recipe,
    step_vpd_persistence_block_new(
      terms = rlang::enquos(...),
      trained = trained,
      role = role,
      hom_degree = hom_degree,
      xseq = xseq, xmin = xmin, xmax = xmax, xlen = xlen, xby = xby,
      yseq = yseq, ymin = ymin, ymax = ymax, ylen = ylen, yby = yby,
      block_size = block_size,
      columns = columns,
      keep_original_cols = keep_original_cols,
      skip = skip,
      id = id
    )
  )
}

step_vpd_persistence_block_new <- function(
    terms,
    role, trained,
    hom_degree,
    xseq, xmin, xmax, xlen, xby,
    yseq, ymin, ymax, ylen, yby,
    block_size,
    columns, keep_original_cols,
    skip, id
) {
  step(
    subclass = "vpd_persistence_block",
    terms = terms,
    role = role,
    trained = trained,
    hom_degree = hom_degree,
    xseq = xseq, xmin = xmin, xmax = xmax, xlen = xlen, xby = xby,
    yseq = yseq, ymin = ymin, ymax = ymax, ylen = ylen, yby = yby,
    block_size = block_size,
    columns = columns,
    keep_original_cols = keep_original_cols,
    skip = skip,
    id = id
  )
}

#' @export
prep.step_vpd_persistence_block <- function(x, training, info = NULL, ...) {
  col_names <- recipes_eval_select(x$terms, training, info)
  check_pd_list(training[, col_names, drop = FALSE])
  for (col_name in col_names) class(training[[col_name]]) <- "list"
  
  x[paste0("x", c("seq", "min", "max", "len", "by"))] <- 
    reconcile_scale_seq(x, training[, col_names, drop = FALSE], "x")
  
  x[paste0("y", c("seq", "min", "max", "len", "by"))] <- 
    reconcile_scale_seq(x, training[, col_names, drop = FALSE], "y")
  
  step_vpd_persistence_block_new(
    terms = col_names,
    role = x$role,
    trained = TRUE,
    hom_degree = x$hom_degree,
    xseq = x$xseq, xmin = x$xmin, xmax = x$xmax, xlen = x$xlen, xby = x$xby,
    yseq = x$yseq, ymin = x$ymin, ymax = x$ymax, ylen = x$ylen, yby = x$yby,
    block_size = x$block_size,
    columns = col_names,
    keep_original_cols = get_keep_original_cols(x),
    skip = x$skip,
    id = x$id
  )
}

#' @export
bake.step_vpd_persistence_block <- function(object, new_data, ...) {
  col_names <- names(object$columns)
  check_new_data(col_names, object, new_data)
  for (col_name in col_names) class(new_data[[col_name]]) <- "list"
  
  vph_data <- tibble::tibble(.rows = nrow(new_data))
  for (col_name in col_names) {
    col_vpd <- purrr::map(
      new_data[[col_name]],
      function(d) {
        v <- TDAvec::computePersistenceBlock(
          as.matrix(d),
          homDim = object$hom_degree,
          xSeq = object$xseq,
          ySeq = object$yseq,
          tau = object$block_size
        )
        vn <- vpd_suffix(v)
        v <- as.vector(v)
        names(v) <- vn
        v
      }
    )
    col_vpd <- purrr::map(
      col_vpd,
      function(v) as.data.frame(matrix(
        v, nrow = 1L, dimnames = list(NULL, names(v))
      ))
    )
    vph_data[[paste(col_name, "pb", sep = "_")]] <- col_vpd
  }
  vph_data <- tidyr::unnest(
    vph_data,
    cols = tidyr::all_of(paste(col_names, "pb", sep = "_")),
    names_sep = "_"
  )
  
  check_name(vph_data, new_data, object)
  new_data <- vctrs::vec_cbind(new_data, vph_data)
  new_data <- remove_original_cols(new_data, object, col_names)
  new_data
}

#' @export
print.step_vpd_persistence_block <- function(
    x, width = max(20, options()$width - 35), ...
) {
  title <- "persistence block of "
  
  print_step(
    untr_obj = x$terms,
    tr_obj = NULL,
    trained = x$trained,
    title = title,
    width = width
  )
  invisible(x)
}

#' @rdname required_pkgs.tdarec
#' @export
required_pkgs.step_vpd_persistence_block <- function(x, ...) {
  c("TDAvec", "tdarec")
}

#' @rdname step_vpd_persistence_block
#' @usage NULL
#' @export
tidy.step_vpd_persistence_block <- function(x, ...) {
  if (is_trained(x)) {
    res <- tibble::tibble(
      terms = unname(x$columns),
      value = rep(NA_real_, length(x$columns))
    )
  } else {
    term_names <- sel2char(x$terms)
    res <- tibble::tibble(
      terms = term_names,
      value = rep(NA_real_, length(term_names))
    )
  }
  res$id <- x$id
  res
}

#' @rdname tunable_tdavec
#' @export
tunable.step_vpd_persistence_block <- function(x, ...) {
  tibble::tibble(
    name = c("hom_degree", "block_size"),
    call_info = list(
      list(pkg = "tdarec", fun = "hom_degree", range = c(0L, unknown())),
      list(pkg = "tdarec", fun = "block_size", range = c(0, 1))
    ),
    source = "recipe",
    component = "step_vpd_persistence_block",
    component_id = x$id
  )
}