R/convert-construct-utils.R

In tf: S3 Classes and Methods for Tidy Functional Data

#-------------------------------------------------------------------------------

# replaces functionality of tf_unnest.tf
# turn a tf object into a data.frame evaluated on arg with cols id-arg-value
tf_2_df <- function(tf, arg, interpolate = TRUE, ...) {
  assert_tf(tf)
  if (missing(arg)) {
    arg <- tf_arg(tf)
  }
  arg <- ensure_list(arg)
  assert_arg(arg, tf)

  tmp <- do.call(
    rbind,
    args = tf[, arg, matrix = FALSE, interpolate = interpolate]
  )
  n_evals <- lengths(arg)
  tmp$id <-
    if (length(n_evals) == 1) {
      rep(unique_id(names(tf)) %||% seq_along(tf), each = n_evals)
    } else {
      rep(unique_id(names(tf)) %||% seq_along(tf), times = n_evals)
    }
  # factor id avoids reordering of rows in tfb_fpc constructor and elsewhere..
  tmp$id <- factor(tmp$id, unique(tmp$id))
  tmp[, c("id", "arg", "value")]
}

# from refund
df_2_mat <- function(data, binning = FALSE, maxbins = 1000) {
  data <- data[complete.cases(data), ]
  nobs <- vec_unique_count(data$id)
  newid <- as.numeric(as.factor(data$id))
  bins <- sort_unique(data$arg)
  if (binning && (length(bins) > maxbins)) {
    binvalues <- seq(
      (1 - 0.001 * sign(bins[1])) * bins[1],
      (1 + 0.001 * sign(bins[length(bins)])) * bins[length(bins)],
      length.out = maxbins + 1
    )
    bins <- binvalues
    binvalues <- head(stats::filter(binvalues, c(0.5, 0.5)), -1)
  } else {
    binvalues <- bins
    bins <- c(
      (1 - 0.001 * sign(bins[1])) * bins[1],
      bins[-length(bins)],
      (1 + 0.001 * sign(bins[length(bins)])) * bins[length(bins)]
    )
    if (bins[1] == 0) {
      bins[1] <- -0.001
    }
    if (bins[length(bins)] == 0) {
      bins[length(bins)] <- 0.001
    }
  }
  newindex <- cut(data$arg, breaks = bins, include.lowest = TRUE)
  data_mat <- matrix(NA, nrow = nobs, ncol = nlevels(newindex))
  colnames(data_mat) <- binvalues
  attr(data_mat, "arg") <- binvalues
  data_mat[cbind(newid, as.numeric(newindex))] <- data$value
  data_mat
}

#-------------------------------------------------------------------------------
# input homogenizers for tfb_spline:

df_2_df <- function(data, id = 1, arg = 2, value = 3) {
  data <- na.omit(data[, c(id, arg, value)])
  assert_data_frame(data, min.rows = 1)
  assert_numeric(data[[arg]])
  assert_numeric(data[[value]])
  colnames(data) <- c("id", "arg", "value")
  data
}

mat_2_df <- function(x, arg) {
  assert_matrix(x)
  assert_numeric(arg)
  assert_true(length(arg) == ncol(x))

  id <- unique_id(rownames(x)) %||% seq_len(nrow(x))
  id <- ordered(id, levels = unique(id))
  t_x <- t(x)
  df_2_df(data_frame0(
    # use t(x) here so that order of vector remains unchanged...
    id = id[col(t_x)],
    arg = arg[row(t_x)],
    value = as.vector(t_x)
  ))
}

#-------------------------------------------------------------------------------

tf_2_fd <- function(x, ..., nbasis = NULL, lambda = 0) {
  rlang::check_installed("fda")

  domain <- tf_domain(x)
  arg <- tf_arg(x)
  y_mat <- t(as.matrix(x))
  nbasis <- nbasis %||% min(25, round(length(arg) / 4))

  basis <- fda::create.bspline.basis(
    rangeval = domain,
    nbasis = nbasis,
    norder = 4
  )
  param <- fda::fdPar(basis, lambda = lambda)
  fda::smooth.basis(argvals = arg, y = y_mat, fdParobj = param, ...)$fd
}