tests/testthat/test-na-handling.R

In tf: S3 Classes and Methods for Tidy Functional Data

# NA entries should always be NULL internally.
# This ensures consistent behavior across constructors, operations, and display.

test_that("NA entries are NULL in tfd_reg via concatenation", {
  set.seed(1234)
  x <- tf_rgp(3)
  y <- c(x, NA)
  expect_length(y, 4)
  expect_equal(is.na(y), c(FALSE, FALSE, FALSE, TRUE), ignore_attr = "names")
  expect_null(unclass(y)[[4]])
  expect_no_error(capture.output(print(y)))
})

test_that("NA entries are NULL in tfd_reg via assignment", {
  set.seed(1234)
  x <- tf_rgp(5)
  x[c(2, 4)] <- NA
  expect_equal(
    is.na(x),
    c(FALSE, TRUE, FALSE, TRUE, FALSE),
    ignore_attr = "names"
  )
  expect_null(unclass(x)[[2]])
  expect_null(unclass(x)[[4]])
  expect_no_error(capture.output(print(x)))
})

test_that("NA entries are NULL in tfd_irreg", {
  set.seed(1234)
  x <- tf_rgp(3) |> tf_sparsify(0.5)
  y <- c(x, NA)
  expect_null(unclass(y)[[4]])
  expect_true(is.na(y)[4])
})

test_that("arithmetic with NA_real_ produces NULL entries", {
  set.seed(1234)
  x <- tf_rgp(3)
  for (op in list(`+`, `-`, `*`, `/`, `^`)) {
    y <- op(x, NA_real_)
    expect_equal(is.na(y), rep(TRUE, 3), ignore_attr = "names")
    for (i in 1:3) expect_null(unclass(y)[[i]])
  }
})

test_that("NA_real_ op tfd produces NULL entries", {
  set.seed(1234)
  x <- tf_rgp(3)
  y <- NA_real_ - x
  expect_equal(is.na(y), rep(TRUE, 3), ignore_attr = "names")
  for (i in 1:3) expect_null(unclass(y)[[i]])
})

test_that("vectorized arithmetic with NA produces NULL at correct positions", {
  set.seed(1234)
  x <- tf_rgp(4)
  y <- x + c(1, 2, NA_real_, 4)
  expect_equal(is.na(y)[3], TRUE)
  expect_null(unclass(y)[[3]])
  expect_false(is.na(y)[1])
})

test_that("tfd + tfd propagates NULL entries", {
  set.seed(1234)
  x <- tf_rgp(3)
  y <- tf_rgp(3)
  y[2] <- NA
  z <- suppressWarnings(x + y)
  expect_true(is.na(z)[2])
  expect_null(unclass(z)[[2]])
  expect_false(is.na(z)[1])
})

test_that("all-NA irregular tfd + tfd preserves vector size", {
  x <- tfd(list(c(1, 2, 3), c(4, 5, 6)), arg = list(c(0, 0.5, 1), c(0, 0.3, 1)))
  x[] <- NA
  y <- suppressWarnings(x + x)
  expect_length(y, 2)
  expect_equal(is.na(y), c(TRUE, TRUE), ignore_attr = "names")
  for (i in seq_along(y)) expect_null(unclass(y)[[i]])
})

test_that("irregular arithmetic with NA_real_ produces NULL entries", {
  set.seed(1234)
  x <- tf_rgp(3) |> tf_sparsify(0.6)
  y <- x - NA_real_
  expect_equal(is.na(y), rep(TRUE, 3), ignore_attr = "names")
  for (i in 1:3) expect_null(unclass(y)[[i]])
  expect_no_error(capture.output(print(y)))
})

test_that("Math ops preserve NULL entries and convert all-NA to NULL", {
  set.seed(1234)
  x <- tf_rgp(3)
  x[2] <- NA
  y <- suppressWarnings(log(x))
  expect_true(is.na(y)[2])
  expect_null(unclass(y)[[2]])

  # log of strictly negative function produces NULL
  t <- seq(0, 1, length.out = 51)
  neg <- tfd(list(-1 - abs(sin(2 * pi * t))), arg = t)
  y2 <- suppressWarnings(log(neg))
  expect_true(is.na(y2)[1])
  expect_null(unclass(y2)[[1]])
})

test_that("Math.tfb handles NULL entries correctly", {
  t <- seq(0, 1, length.out = 51)
  mixed <- tfd(
    list(
      1 + abs(sin(2 * pi * t)),
      -1 - abs(cos(2 * pi * t)),
      1 + abs(sin(4 * pi * t))
    ),
    arg = t
  )
  b <- suppressWarnings(suppressMessages({
    capture.output(b <- tfb(mixed, k = 7, verbose = FALSE))
    b
  }))
  y <- suppressWarnings(log(b))
  expect_true(is_tfb(y))
  expect_equal(is.na(y), c(FALSE, TRUE, FALSE), ignore_attr = "names")
  expect_null(unclass(y)[[2]])
  expect_no_error(capture.output(print(y)))
})

test_that("all-NA objects print correctly", {
  set.seed(1234)
  x <- tf_rgp(3)
  x[1:3] <- NA
  printed <- capture.output(print(x))
  expect_true(any(grepl("\\[NA,NA\\]", printed)))
  expect_false(any(grepl("Inf", printed)))
})

test_that("as.tfd_irreg preserves NULL entries", {
  set.seed(1234)
  x <- tf_rgp(3)
  x[2] <- NA
  y <- as.tfd_irreg(x)
  expect_true(is.na(y)[2])
  expect_null(unclass(y)[[2]])
})

test_that("tfd() re-evaluation preserves NULL entries", {
  set.seed(1234)
  x <- tf_rgp(3)
  x[2] <- NA
  y <- suppressWarnings(tfd(x, arg = seq(0, 1, length.out = 101)))
  expect_true(is.na(y)[2])
  expect_null(unclass(y)[[2]])
})

test_that("subsetting preserves NULL entries", {
  set.seed(1234)
  x <- tf_rgp(5)
  x[c(2, 4)] <- NA
  sub <- x[c(1, 2, 3)]
  expect_true(is.na(sub)[2])
  expect_null(unclass(sub)[[2]])
})

test_that("tfb arithmetic with NA_real_ produces NULL entries and returns tfb", {
  set.seed(1234)
  x <- suppressMessages({
    capture.output(x <- tf_rgp(3) |> tfb(k = 15, verbose = FALSE))
    x
  })
  y <- suppressWarnings(x + NA_real_)
  expect_true(is_tfb(y))
  expect_equal(is.na(y), rep(TRUE, 3), ignore_attr = "names")
  for (i in 1:3) expect_null(unclass(y)[[i]])
  # partial NA: numeric_op_tfb
  z <- suppressWarnings(NA_real_ - x[1:2])
  expect_true(is_tfb(z))
  expect_equal(is.na(z), rep(TRUE, 2), ignore_attr = "names")
  # tfb_op_tfb
  x2 <- x
  x2[2] <- NA
  w <- suppressWarnings(x + x2)
  expect_true(is_tfb(w))
  expect_equal(is.na(w), c(FALSE, TRUE, FALSE), ignore_attr = "names")
})

test_that("data.frame constructor handles all-NA rows", {
  df <- data.frame(
    id = rep(1:3, each = 10),
    arg = rep(1:10, 3),
    value = c(1:10, rep(NA, 10), 21:30)
  )
  x <- suppressWarnings(tfd(df))
  expect_true(is.na(x)[2])
  expect_null(unclass(x)[[2]])
  expect_no_error(capture.output(print(x)))
})

# --- tf_arg accessor for tfd_irreg with NAs ---

test_that("tf_arg returns numeric(0) for NA entries in tfd_irreg", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0, 0.5, 1), c(0, 0.3, 1), c(0, 0.7, 1))
  )
  x[2] <- NA
  args <- tf_arg(x)
  expect_length(args, 3)
  expect_equal(args[[2]], numeric(0))
  expect_true(length(args[[1]]) > 0)
  expect_true(length(args[[3]]) > 0)
})

test_that("tfd_irreg with NA survives round-trip via tf_arg", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0, 0.5, 1), c(0, 0.3, 1), c(0, 0.7, 1))
  )
  x[2] <- NA
  y <- suppressWarnings(tfd(x, arg = tf_arg(x)))
  expect_equal(is.na(y), c(FALSE, TRUE, FALSE), ignore_attr = "names")
  expect_s3_class(y, "tfd_irreg")
})

test_that("tf_fmean works on tfd_irreg with NA entries", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0, 0.5, 1), c(0, 0.3, 1), c(0, 0.7, 1))
  )
  x[2] <- NA
  result <- suppressWarnings(tf_fmean(x))
  expect_true(is.na(result[2]))
  expect_false(is.na(result[1]))
  expect_false(is.na(result[3]))
})

# --- tfd.tf re-evaluation with NAs: systematic test matrix ---
# Tests cover all combinations of:
#   shared vs per-function arg
#   with vs without NULL entries
#   same vs different extrapolation NAs vs no extrapolation NAs
# This exercises the normalize-prune-collapse logic in tfd.tf lines 370-418.

test_that("re-eval: shared arg, no NULLs, no extrapolation NAs", {
  x <- tfd(list(c(1, 2, 3), c(4, 5, 6)), arg = list(c(0, 0.5, 1), c(0, 0.5, 1)))
  y <- tfd(x, arg = seq(0, 1, length.out = 11))
  expect_s3_class(y, "tfd_reg")
  expect_equal(is.na(y), c(FALSE, FALSE), ignore_attr = "names")
})

test_that("re-eval: shared arg, with NULLs, no extrapolation NAs", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0, 0.5, 1), c(0, 0.5, 1), c(0, 0.5, 1))
  )
  x[2] <- NA
  y <- suppressWarnings(tfd(x, arg = seq(0, 1, length.out = 11)))
  expect_s3_class(y, "tfd_reg")
  expect_equal(is.na(y), c(FALSE, TRUE, FALSE), ignore_attr = "names")
  expect_null(unclass(y)[[2]])
})

test_that("re-eval: shared arg, with NULLs, same extrapolation NAs", {
  # All non-NULL functions have same domain, so same NAs on wider grid
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0.1, 0.5, 0.9), c(0.1, 0.5, 0.9), c(0.1, 0.5, 0.9))
  )
  x[2] <- NA
  y <- suppressWarnings(tfd(x, arg = seq(0.1, 0.9, length.out = 11)))
  expect_equal(is.na(y), c(FALSE, TRUE, FALSE), ignore_attr = "names")
  expect_null(unclass(y)[[2]])
})

test_that("re-eval: shared arg, with NULLs, different extrapolation NAs", {
  # Functions have different original domains -> different extrapolation NAs
  x <- tfd(
    list(c(1, 2, 3, 4, 5), c(6, 7, 8, 9, 10), c(11, 12, 13, 14, 15)),
    arg = list(
      c(0, 0.25, 0.5, 0.75, 1),
      c(0, 0.3, 0.5, 0.7, 1),
      c(0.1, 0.3, 0.5, 0.7, 0.9)
    )
  )
  x[2] <- NA
  y <- suppressWarnings(tfd(x, arg = seq(0, 1, length.out = 21)))
  expect_s3_class(y, "tfd_irreg")
  expect_equal(is.na(y), c(FALSE, TRUE, FALSE), ignore_attr = "names")
  expect_null(unclass(y)[[2]])
})

test_that("re-eval: shared arg, no NULLs, different extrapolation NAs", {
  # No NULL entries, but different arg ranges -> different extrapolation NAs
  # Domain is [0.1, 0.9] (union). Grid within domain but outside individual ranges.
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6)),
    arg = list(c(0.1, 0.5, 0.9), c(0.2, 0.5, 0.8))
  )
  y <- suppressWarnings(tfd(x, arg = seq(0.1, 0.9, length.out = 11)))
  expect_s3_class(y, "tfd_irreg")
  expect_false(anyNA(y))
})

test_that("re-eval: per-function arg, with NULLs, no extrapolation NAs", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0, 0.5, 1), c(0, 0.3, 1), c(0, 0.7, 1))
  )
  x[2] <- NA
  new_args <- list(
    seq(0, 1, length.out = 11),
    seq(0, 1, length.out = 11),
    seq(0, 1, length.out = 11)
  )
  y <- suppressWarnings(tfd(x, arg = new_args))
  expect_s3_class(y, "tfd_irreg")
  expect_equal(is.na(y), c(FALSE, TRUE, FALSE), ignore_attr = "names")
  expect_null(unclass(y)[[2]])
})

test_that("re-eval: per-function arg, with NULLs, different extrapolation NAs", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0.1, 0.5, 0.9), c(0, 0.5, 1.0), c(0.2, 0.5, 0.8))
  )
  x[2] <- NA
  new_args <- list(
    seq(0, 1, length.out = 11),
    seq(0, 1, length.out = 11),
    seq(0, 1, length.out = 11)
  )
  y <- suppressWarnings(tfd(x, arg = new_args))
  expect_s3_class(y, "tfd_irreg")
  expect_equal(is.na(y), c(FALSE, TRUE, FALSE), ignore_attr = "names")
  expect_null(unclass(y)[[2]])
})

test_that("re-eval: all NULLs", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6), c(7, 8, 9)),
    arg = list(c(0, 0.5, 1), c(0, 0.5, 1), c(0, 0.5, 1))
  )
  x[1:3] <- NA
  y <- suppressWarnings(tfd(x, arg = seq(0, 1, length.out = 11)))
  expect_equal(is.na(y), c(TRUE, TRUE, TRUE), ignore_attr = "names")
})

test_that("re-eval: single non-NULL entry with extrapolation NAs", {
  x <- tfd(
    list(c(1, 2, 3), c(4, 5, 6)),
    arg = list(c(0.1, 0.5, 0.9), c(0.1, 0.5, 0.9))
  )
  x[1] <- NA
  y <- suppressWarnings(tfd(x, arg = seq(0.1, 0.9, length.out = 11)))
  expect_true(is.na(y)[1])
  expect_null(unclass(y)[[1]])
  expect_false(is.na(y)[2])
})