tests/testthat/test-basis.R

In VAJointSurv: Variational Approximation for Joint Survival and Marker Models

test_that("The C++ version of poly gives the right result", {
  in_x <- 2:5
  obj_truth <- poly(in_x, degree = 3)
  out_x <- 1:6
  truth <- predict(obj_truth, out_x)

  # without an intercept
  obj_cpp <- poly_term(in_x, degree = 3)
  expect_s3_class(obj_cpp, "poly_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, t(truth), ignore_attr = TRUE)

  # with an intercept
  obj_cpp <- poly_term(in_x, degree = 3, intercept = TRUE)
  expect_s3_class(obj_cpp, "poly_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, rbind(1, t(truth)), ignore_attr = TRUE)

  # without an intercept and raw is TRUE
  obj_cpp <- poly_term(in_x, degree = 3, raw = TRUE)
  expect_s3_class(obj_cpp, "poly_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, t(outer(out_x, 1:3, `^`)))

  # with an intercept and raw is TRUE
  obj_cpp <- poly_term(in_x, degree = 3, raw = TRUE, intercept = TRUE)
  expect_s3_class(obj_cpp, "poly_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, t(outer(out_x, 0:3, `^`)))

  # without an intercept and degree == 0
  obj_cpp <- poly_term(in_x, degree = 0)
  expect_s3_class(obj_cpp, "poly_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, matrix(0, 0, length(out_x)))

  # with an intercept and degree == 0
  obj_cpp <- poly_term(in_x, degree = 0, intercept = TRUE)
  expect_s3_class(obj_cpp, "poly_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, matrix(1, 1, length(out_x)))
})

test_that("The C++ version of bs gives the right result", {
  # without an intercept
  in_x <- 2:5
  obj_truth <- bs(in_x, df = 4)
  out_x <- c(2, 2.5, 3, 3.5, 4, 4.5, 5)
  truth <- predict(obj_truth, out_x)

  obj_cpp <- bs_term(in_x, df = 4)
  expect_s3_class(obj_cpp, "bs_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, t(truth),  ignore_attr = TRUE)

  # with an intercept
  obj_truth <- bs(in_x, df = 4, intercept = TRUE)
  truth <- predict(obj_truth, out_x)

  obj_cpp <- bs_term(in_x, df = 4, intercept = TRUE)
  expect_s3_class(obj_cpp, "bs_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, t(truth),  ignore_attr = TRUE)
})

test_that("The C++ version of ns gives the right result", {
  # without an intercept
  in_x <- 2:5
  obj_truth <- ns(in_x, df = 4)
  out_x <- c(2, 2.5, 3, 3.5, 4, 4.5, 5)
  truth <- predict(obj_truth, out_x)

  obj_cpp <- ns_term(in_x, df = 4)
  expect_s3_class(obj_cpp, "ns_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, t(truth),  ignore_attr = TRUE)

  # with an intercept
  obj_truth <- ns(in_x, df = 4, intercept = TRUE)
  truth <- predict(obj_truth, out_x)

  obj_cpp <- ns_term(in_x, df = 4, intercept = TRUE)
  expect_s3_class(obj_cpp, "ns_term")
  expect_equal(obj_cpp$time, in_x)

  expansion <- obj_cpp$eval(out_x)
  expect_equal(expansion, t(truth),  ignore_attr = TRUE)
})

test_that("The plot_surv works with one-dimensional basis", {
  g1_basis <- ns_term(knots = c(3.33, 6.67), Boundary.knots = c(0, 10))
  g2_basis <- ns_term(knots = c(3.33, 6.67), Boundary.knots = c(0, 10))
  m1_basis <- poly_term(degree = 1, raw = TRUE, intercept = TRUE)
  m2_basis <- poly_term(degree = 0, raw = TRUE, intercept = TRUE)

  vcov_vary <- structure(c(0.021875, 5e-04, -0.003125, 5e-04, 0.012, -0.0015, -0.003125, -0.0015, 0.02), .Dim = c(3L, 3L))

  # the survival parameters
  fixef_surv <- c(-3, .4)
  association <- c(-1, 2)
  fixef_vary_surv <- c(.5, .1, -.015)
  fvar <- matrix(1e-6^2, 1)

  b_basis <- poly_term(degree = 3, raw = TRUE)

  # this failed in one version
  res <- plot_surv(
    time_fixef = b_basis, time_rng = list(m1_basis, m2_basis),
    x_range = c(0, 10), fixef_vary = fixef_vary_surv,  vcov_vary = vcov_vary,
    frailty_var = fvar, ps = c(.1, .5, .9), log_hazard_shift = fixef_surv[1],
    associations = association)

  expect_snapshot_value(res, cran = TRUE, style = "serialize")
})

test_that("A weighted poly_term gives the right resutls", {
  w_term <- weighted_term(poly_term(degree=3,raw = TRUE),x)
  expect_s3_class(w_term,"weighted_term")

  s <- c(3,4)
  x <- 2:3
  dat <- data.frame(x = x)

  expect_equal(w_term$eval(s,newdata = dat),
               matrix(c(s*x,s^2*x,s^3*x),ncol = length(s),byrow = TRUE))

  expect_error(weighted_term(w_term,2),
               "weighted_term of weighted_term is not supported")
  expect_error(weighted_term(1,x))
})

test_that("A stacked_term gives the right resutls", {
  main_term <- stacked_term(
    poly_term(degree=1,raw=TRUE),
    weighted_term(poly_term(degree=2,raw=TRUE),x),
    weighted_term(poly_term(degree=3,raw = TRUE),y),
    stacked_term(
      poly_term(degree=3,raw=TRUE),
      weighted_term(poly_term(degree=2,raw=TRUE),x)),
    stacked_term(
      poly_term(degree=3,raw=TRUE),
      weighted_term(
        stacked_term(
          poly_term(degree=3,raw=TRUE),
          weighted_term(poly_term(degree=2,raw=TRUE),x)),
        z)))

  s <- c(3,4)
  x <- 2:3
  y <- 1:2
  z <- c(10,10)

  correct_main_term <- matrix(
    c(s,s*x,s^2*x,s*y,s^2*y,s^3*y,s,s^2,s^3,s*x,s^2*x,s,s^2,s^3,s*z,s^2*z,s^3*z,s*x*z,s^2*x*z),
    ncol=length(s), byrow = TRUE)

  dat <- data.frame(x = x, y = y, z = z)

  expect_equal(main_term$eval(s,newdata = dat),correct_main_term)

  expect_s3_class(main_term, "stacked_term")

  expect_error(stacked_term(),
               "stacked_term created with less than two arguments")
  expect_error(stacked_term(1),
               "stacked_term created with less than two arguments")
  expect_error(main_term$eval(s,newdata = dat[1, ]))
  expect_error(main_term$eval(s,
                              newdata = transform(dat, x = as.character(x))))
  expect_error(stacked_term(1,2,3))
})