tests/testthat/test-rebase.R

In tf: S3 Classes and Methods for Tidy Functional Data

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

l <- list(
  x_sp = tf_sparsify(x, dropout = 0.1),
  x_ir = tf_sparsify(x, dropout = 0.1) |> tf_jiggle(amount = 0.05),
  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),
  fpc = tfb_fpc(x, pve = 1),
  fpc_low = tfb_fpc(x, pve = 0.95)
)

for (i in seq_along(l)) {
  test_that("tf_rebase.tfd preserves args & evals and transfers attributes", {
    x_rebase <- tf_rebase(x, l[[i]], verbose = FALSE)
    expect_equal(
      x_rebase |> tf_evaluations(),
      l[[i]] |> tf_evaluations(),
      tolerance = 0.01
    )
    expect_equal(
      x_rebase |> tf_arg(),
      l[[i]] |> tf_arg()
    )
    expect_named(x_rebase, names(x))
    skip_on_cran() # to avoid non-reproducible BS-error on Fedora 36 - MKL
    expect_true(
      compare_tf_attribs(x_rebase, l[[i]], check_attrib = FALSE) |> all()
    )
  })
}

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

set.seed(1133111)
x <- tf_rgp(5, arg = 301L) |>
  tf_smooth() |>
  tfd(evaluator = tf_approx_fill_extend) |>
  suppressMessages()
names(x) <- letters[1:5]
b <- tfb(x, k = 45, verbose = FALSE)

l <- list(
  x = x,
  x_sp = tf_sparsify(x, dropout = 0.1),
  x_ir = tf_sparsify(x, dropout = 0.1) |> tf_jiggle(amount = 0.2),
  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),
  fpc = tfb_fpc(x, pve = 1),
  fpc_low = tfb_fpc(x, pve = 0.95)
)

for (i in seq_along(l)) {
  test_that(
    paste0(
      "tf_rebase.tfb_spline preserves args & evals and transfers attributes for l[",
      i,
      "]"
    ),
    {
      x_rebase <- tf_rebase(b, l[[i]], verbose = FALSE)
      expect_equal(
        x_rebase |> tf_evaluations(),
        l[[i]] |> tf_evaluations(),
        tolerance = 0.01
      )
      expect_equal(
        x_rebase |> tf_arg(),
        l[[i]] |> tf_arg()
      )
      expect_named(x_rebase, names(x))
      skip_on_cran() # to avoid non-reproducible BS-error on Fedora 36 - MKL
      expect_true(
        compare_tf_attribs(x_rebase, l[[i]], check_attrib = FALSE) |> all()
      )
    }
  )
}

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

set.seed(1133111)
x <- suppressMessages({
  tf_rgp(5, arg = 301L) |>
    tf_smooth() |>
    tfd(evaluator = tf_approx_fill_extend) |>
    setNames(letters[1:5])
})
fpc <- tfb_fpc(x, pve = 1)

l <- list(
  x = x,
  x_sp = tf_sparsify(x, dropout = 0.1),
  x_ir = tf_sparsify(x, dropout = 0.1) |> tf_jiggle(amount = 0.2),
  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),
  fpc_low = tfb_fpc(x, pve = 0.95)
)
for (i in seq_along(l)) {
  test_that("tf_rebase.tfb_fpc preserves args & evals and transfers attributes", {
    x_rebase <- tf_rebase(fpc, l[[i]], verbose = FALSE)
    expect_equal(
      x_rebase |> tf_evaluations(),
      l[[i]] |> tf_evaluations(),
      tolerance = 0.01
    )
    expect_equal(
      x_rebase |> tf_arg(),
      l[[i]] |> tf_arg()
    )
    expect_named(x_rebase, names(x))
    skip_on_cran() # to avoid non-reproducible BS-error on Fedora 36 - MKL
    expect_true(
      compare_tf_attribs(x_rebase, l[[i]], check_attrib = FALSE) |> all()
    )
  })
}