tests/testthat/test-concatenation.R

In tf: S3 Classes and Methods for Tidy Functional Data

x <- suppressMessages({
  tf_rgp(5, arg = 301L) |> tf_smooth() |> tfd(evaluator = tf_approx_fill_extend)
})
names(x) <- letters[1:5]

l <- list(
  x = x,
  x_short = x |> tf_zoom(0.1, 0.4),
  x_short_longdom = tfd(
    x |> tf_zoom(0.1, 0.4),
    domain = tf_domain(x),
    evaluator = tf_approx_linear
  ),
  x_sp = tf_sparsify(x, dropout = 0.1),
  x_ir = tf_sparsify(x, dropout = 0.1) |> tf_jiggle(amount = 0.2),
  x_fake_ir = as.tfd_irreg(x |> tf_zoom(0.1, 0.4)),
  b = tfb(x, k = 45, verbose = FALSE),
  b2 = tfb(x, k = 15, bs = "tp", sp = 0.1, verbose = FALSE),
  bu = tfb(x, k = 15, penalized = FALSE, verbose = FALSE),
  bg = tfb(x, k = 5, global = TRUE, verbose = FALSE),
  fp = tfb_fpc(x, pve = 1),
  fp_low = tfb_fpc(x, pve = 0.95)
)

test_that("vctrs basics & concatentation work for all subclasses", {
  for (i in seq_along(l)) {
    expect_identical(
      l[[i]],
      vec_restore(vec_proxy(l[[i]]), vec_ptype(l[[i]]))
    )
    expect_identical(
      vec_ptype2(l[[i]], l[[i]]),
      vec_ptype(l[[i]])
    )
    expect_identical(
      l[[i]],
      c(l[[i]], l[[i]])[seq_along(l[[i]])]
    )
  }
  expect_s3_class(
    vec_ptype_common(l$x, l$x_sp, l$x_b) |> suppressWarnings(),
    "tfd_irreg"
  )
  expect_s3_class(
    vec_ptype_common(l$x_ir, l$x_fp, l$b_u) |> suppressWarnings(),
    "tfd_irreg"
  )
  expect_s3_class(
    vec_ptype2(l$x, l$fp) |> suppressWarnings(),
    "tfd_reg"
  )
  expect_equal(
    vec_ptype2(l$fp, l$x) |> suppressWarnings(),
    vec_ptype2(l$x, l$fp) |> suppressWarnings()
  )
  expect_equal(
    vec_ptype2(l$x, l$x_ir) |> suppressWarnings(),
    vec_ptype2(l$x_ir, l$x) |> suppressWarnings()
  )
  # TODO: evaluator of result depends on order of args here - seems unavoidable?
  # expect_equal(
  #   vec_ptype2(l$x_short_longdom, l$x) |> suppressWarnings(),
  #   vec_ptype2(l$x, l$x_short_longdom) |> suppressWarnings())
})

test_that("concatentation of mixed tfs works as expected", {
  # tfd_reg - irreg
  expect_s3_class(c(l$x, l$x_ir) |> suppressWarnings(), "tfd_irreg")
  expect_warning(c(l$x, l$x_ir), "incompatible <tfd_reg> with <tfd_irreg>")
  expect_identical(
    c(l$x, l$x_ir) |> suppressWarnings() |> tf_evaluations(),
    c(tf_evaluations(l$x), tf_evaluations(l$x_ir))
  )

  # tfd_reg - spline
  expect_s3_class(c(l$x, l$b) |> suppressWarnings(), "tfd_reg")
  expect_warning(c(l$x, l$b), "incompatible <tfd_reg> with <tfb_spline>")
  expect_identical(
    c(l$x, l$b) |> tf_evaluations() |> suppressWarnings(),
    c(tf_evaluations(l$x), tf_evaluations(l$b)),
    tolerance = 0.01
  )

  # tfd_irreg - fpc
  expect_s3_class(c(l$fp, l$x_sp) |> suppressWarnings(), "tfd_irreg")
  expect_warning(c(l$fp, l$x_sp), "incompatible <tfd_irreg> with <tfb_fpc>")
  expect_identical(
    c(l$fp, l$x_sp) |> tf_evaluations() |> suppressWarnings(),
    c(tf_evaluations(l$fp), tf_evaluations(l$x_sp)),
    tolerance = 0.01,
    ignore_attr = TRUE
  )

  # fpc - spline
  expect_s3_class(c(l$fp, l$b) |> suppressWarnings(), "tfd_reg")
  expect_warning(c(l$fp, l$b), "incompatible <tfb_fpc> with <tfb_spline>")
  expect_identical(
    c(l$fp, l$b) |> tf_evaluations() |> suppressWarnings(),
    c(tf_evaluations(l$fp), tf_evaluations(l$b)),
    tolerance = 0.01,
    ignore_attr = TRUE
  )

  all_c <- c(
    l[[1]],
    l[[2]],
    l[[3]],
    l[[4]],
    l[[5]],
    l[[6]],
    l[[7]],
    l[[8]],
    l[[9]],
    l[[10]],
    l[[11]],
    l[[12]]
  ) |>
    suppressWarnings()
  # TODO: y do.call(c, l) no work?
  incremental_c <- l[[1]]
  for (i in 2:length(l))
    incremental_c <- c(incremental_c, l[[i]]) |> suppressWarnings()
  expect_identical(incremental_c, all_c)
})

# !! NA concatenating
# c(x, NA) works, c(NA, x) does not --
# but: vec_ptype2(NA, x) works
# and doing the concatenation manually with vec_init, vec_cast, vec_slice etc works as well.
# -- this is a vctrs issue - wontfix