tests/testthat/test-summarize.R

In tf: S3 Classes and Methods for Tidy Functional Data

# Create test data
grid <- seq(0, 1, length.out = 21)
lin <- -3:3 * tfd(grid, grid)
parallel <- 0:4 + tfd(0 * grid, grid)

# Create irregular data
lin_irreg <- {
  tmp <- as.matrix(lin)
  tmp[1:3, 1] <- NA
  tfd(tmp)
}
lin_too_irreg <- lin_irreg |> tf_jiggle() #no common gridpoints --> most summaries will be empty

# NA values
lin_na <- c(lin, NA)

lin_b <- tfb(lin, k = 5) |> suppressMessages()
parallel_b <- tfb(parallel, k = 5) |> suppressMessages()

test_that("mean.tf works correctly", {
  mean_lin <- colMeans(as.matrix(lin))

  # Test regular tfd
  mean_lin_tf <- mean(lin)
  expect_s3_class(mean_lin_tf, "tfd")
  expect_equal(tf_evaluations(mean_lin_tf)[[1]], mean_lin, ignore_attr = TRUE)

  # Test irregular tfd
  expect_warning(mean(lin_irreg), "irregular")
  mean_lin_irreg <- mean(lin_irreg) |> suppressWarnings()
  expect_s3_class(mean_lin_irreg, "tfd_irreg")

  mean_lin_irreg <- mean(lin_irreg, na.rm = TRUE)
  expect_equal(
    tf_evaluations(mean_lin_irreg)[[1]],
    mean_lin,
    ignore_attr = TRUE
  )

  expect_warning(mean(lin_too_irreg), "NA")
  mean_lin_too_irreg <- mean(lin_too_irreg) |> suppressWarnings()
  expect_true(is.na(mean_lin_too_irreg))

  # Test tfd with NA
  expect_warning(mean(lin_na), "NA")
  mean_lin_na <- suppressWarnings(mean(lin_na))
  expect_s3_class(mean_lin_na, "tfd")
  expect_true(is.na(mean_lin_na))
  expect_equal(mean(lin_na, na.rm = TRUE), mean(lin))

  # Test tfb
  mean_lin_b <- mean(lin_b)
  expect_s3_class(mean_lin_b, "tfb")
  expect_equal(
    tf_evaluations(mean_lin_b)[[1]],
    mean_lin,
    tolerance = 1e-10,
    ignore_attr = TRUE
  )
})

test_that("summary.tf works correctly", {
  # Test on tfd
  parallel_summary <- summary(parallel)
  expect_s3_class(parallel_summary, "tfd")
  expect_length(parallel_summary, 6) # min, lower_mid, median, mean, upper_mid, max

  # Verify names
  expect_named(
    parallel_summary,
    c("min", "lower_mid", "median", "mean", "upper_mid", "max")
  )

  # Verify specific values
  # Min should be the first function (0 + grid)
  expect_equal(
    tf_evaluations(parallel_summary)[["min"]],
    tf_evaluations(parallel)[[1]],
    ignore_attr = TRUE
  )

  # Max should be the last function (4 + grid)
  expect_equal(
    tf_evaluations(parallel_summary)[["max"]],
    tf_evaluations(parallel)[[5]],
    ignore_attr = TRUE
  )

  # Mean should match manual calculation
  expect_equal(
    tf_evaluations(parallel_summary)[["mean"]],
    colMeans(as.matrix(parallel)),
    ignore_attr = TRUE
  )

  # Median should be the middle function (2 + grid)
  expect_equal(
    tf_evaluations(parallel_summary)[["median"]],
    tf_evaluations(parallel)[[3]],
    ignore_attr = TRUE
  )
  expect_equal(
    tf_evaluations(parallel_summary)[["lower_mid"]],
    tf_evaluations(parallel)[[2]],
    ignore_attr = TRUE
  )
  expect_equal(
    tf_evaluations(parallel_summary)[["upper_mid"]],
    tf_evaluations(parallel)[[4]],
    ignore_attr = TRUE
  )

  # NAs don't affect summary:
  expect_equal(summary(parallel), summary(c(parallel, NA)))

  # Test on tfb
  parallel_b_summary <- summary(parallel_b)
  expect_s3_class(parallel_b_summary, "tfb")
  expect_length(parallel_b_summary, 6)

  # Min should be the first function (0 + grid)
  expect_equal(
    tf_evaluations(parallel_b_summary)[["min"]],
    tf_evaluations(parallel_b)[[1]],
    ignore_attr = TRUE
  )

  # Max should be the last function (4 + grid)
  expect_equal(
    tf_evaluations(parallel_b_summary)[["max"]],
    tf_evaluations(parallel_b)[[5]],
    ignore_attr = TRUE
  )

  # Mean should match manual calculation
  expect_equal(
    tf_evaluations(parallel_b_summary)[["mean"]],
    colMeans(as.matrix(parallel_b)),
    ignore_attr = TRUE
  )

  # Median should be the middle function (2 + grid)
  expect_equal(
    tf_evaluations(parallel_b_summary)[["median"]],
    tf_evaluations(parallel_b)[[3]],
    ignore_attr = TRUE
  )
})

# see test-depth.R for median

test_that("cum* functions work for tfd objects", {
  # Test cumsum on tfd
  lin_cumsum <- cumsum(lin)
  expect_s3_class(lin_cumsum, "tfd")
  expect_length(lin_cumsum, length(lin))

  # Verify results match manual calculation
  lin_matrix <- as.matrix(lin)
  expected_cumsum <- apply(lin_matrix, 2, cumsum)
  for (i in seq_along(lin)) {
    expect_equal(
      tf_evaluations(lin_cumsum[i])[[1]],
      expected_cumsum[i, ],
      ignore_attr = TRUE
    )
  }

  # Test cummax on tfd
  lin_cummax <- cummax(lin)
  expect_s3_class(lin_cummax, "tfd")
  expect_length(lin_cummax, length(lin))

  # Verify results match manual calculation
  expected_cummax <- apply(lin_matrix, 2, cummax)
  for (i in seq_along(lin)) {
    expect_equal(
      tf_evaluations(lin_cummax[i])[[1]],
      expected_cummax[i, ],
      ignore_attr = TRUE
    )
  }

  # Test with NA values
  lin_na <- c(lin, NA)
  expect_warning(cumsum(lin_na))
  lin_na_cumsum <- suppressWarnings(cumsum(lin_na))

  # First elements should still be calculated
  for (i in seq_along(lin)) {
    expect_equal(
      tf_evaluations(lin_na_cumsum[i])[[1]],
      expected_cumsum[i, ],
      ignore_attr = TRUE
    )
  }
})

test_that("cum* functions work for tfb objects", {
  # Test cumsum on tfb
  lin_b_cumsum <- cumsum(lin_b)
  expect_s3_class(lin_b_cumsum, "tfb")
  expect_length(lin_b_cumsum, length(lin_b))

  # Verify results match manual calculation
  lin_b_matrix <- as.matrix(lin_b)
  expected_cumsum <- apply(lin_b_matrix, 2, cumsum)
  for (i in seq_along(lin_b)) {
    expect_equal(
      tf_evaluations(lin_b_cumsum[i])[[1]],
      expected_cumsum[i, ],
      ignore_attr = TRUE
    )
  }

  # Test cummax on tfd
  lin_b_cummax <- cummax(lin_b)
  expect_s3_class(lin_b_cummax, "tfb")
  expect_length(lin_b_cummax, length(lin_b))

  # Verify results match manual calculation
  expected_cummax <- apply(lin_b_matrix, 2, cummax)
  for (i in seq_along(lin_b)) {
    expect_equal(
      tf_evaluations(lin_b_cummax[i])[[1]],
      expected_cummax[i, ],
      ignore_attr = TRUE
    )
  }

  # # Test with NA values
  # lin_b_na <- c(lin_b, NA_real_*lin_b[1])
  # expect_warning(cumsum(lin_b_na))
  # lin_b_na_cumsum <- suppressWarnings(cumsum(lin_b_na))
  #
  #
  # # First elements should still be calculated
  # for (i in seq_along(lin_b)) {
  #   expect_equal(
  #     tf_evaluations(lin_b_na_cumsum[i])[[1]],
  #     expected_cumsum[i, ],
  #     ignore_attr = TRUE
  #   )
  # }
})