tests/testthat/test_survtab_bad_surv_ints.R

testthat::context("Testing empty survival intervals in survtab")

testthat::test_that("removing consecutively bad surv.ints is logical w/ & w/out adjusting", {
  
  sire2 <- sire[dg_date < ex_date, ]
  sire2[, agegr := cut(dg_age, c(0,45,60,Inf), right=FALSE, labels=FALSE)]
  
  BL <- list(fot= seq(0,10,1/12), per=c(2008,2013))
  
  x <- lexpand(sire2, birth  = bi_date, entry = dg_date, exit = ex_date,
               status = status %in% 1:2, breaks=BL)
  setDT(x)
  
  setattr(x, "class", c("Lexis", "data.table", "data.frame"))
  ## NOTE: neither should give any messages!
  testthat::expect_message({
    st1 <-  survtab(Surv(fot, lex.Xst) ~ agegr,
                        subset = !(agegr == 1L & fot > 8.49),
                        data = x, surv.type="surv.obs")
    }, regexp = NA)
  
  ## INTENTION: 7.5+ intervals empty for one age group.
  ## this should make adjusted estimates missing altogether for 7.5+.
  testthat::expect_message({
    st2 <- survtab(Surv(fot, lex.Xst) ~ adjust(agegr), 
                      data = x, surv.type="surv.obs",
                      subset = !(agegr == 1L & fot > 8.49),
                      weights = list(agegr = c(0.33, 0.33, 0.33)))
  }, regexp = NA)
  setDT(st1)
  setDT(st2)
  
  
  testthat::expect_equal(st1[agegr==3 & Tstop>8.5, .N] ,  18L)
  testthat::expect_equal(st1[agegr==1 & Tstop>8.5, .N] ,  0L)
  testthat::expect_equal(st2[Tstop > 8.5, .N] , 0L)
})

## non-consecutively bad surv.ints ---------------------------------------------

testthat::test_that("survtab_ag messages & results due to non-consecutively bad surv.ints are OK", {
  ## non-consecutively bad surv.ints (missing years 5-6)
  sire2 <- sire[dg_date < ex_date, ]
  sire2[, agegr := cut(dg_age, c(0,45,60,Inf), right=FALSE, labels=FALSE)]
  sire2 <- sire2[!(dg_age > 60 & as.integer(as.integer(ex_date-dg_date)/365.25) %in% 5:6)]
  BL <- list(fot= seq(0,10,1/12), per=c(2008,2013))
  x <- lexpand(sire2, birth  = bi_date, entry = dg_date, exit = ex_date,
               status = status %in% 1:2,
               breaks=BL)
  tf1 <- quote(
    st1 <-  survtab(Surv(fot, lex.Xst)~1, data = x, surv.type="surv.obs", 
                        subset=!(fot >= 5 & fot < 7))
  )
  
  tf2 <- quote(
    st2 <- survtab(Surv(fot, lex.Xst)~adjust(agegr), data = x, surv.type="surv.obs",
                       subset=!(agegr==3 & fot >= 5 & fot < 7), 
                       weights = list(agegr = c(0.33, 0.33, 0.33)))
  )
  
  ## NOTE: \\ needed before "(" or ")"
  msgs <- c(paste0("The total person-time was zero in some survival ",
                   "intervals summed to the margins \\(over any stratifying ",
                   "/ adjusting variables\\) _non-consecutively_, i.e. some ",
                   "intervals after an empty interval had person-time in ",
                   "them. Keeping all survival intervals with some estimates ",
                   "as NA for inspection."),
            "Some cumulative surv.obs were zero or NA:")
  testthat::expect_message(eval(tf1), msgs[1],ignore.case=TRUE)
  testthat::expect_message(eval(tf1), msgs[2],ignore.case=TRUE)
  
  setDT(st1)
  
  testthat::expect_equal(st1[is.na(surv.obs), .N], 60L)
  
  msgs <- c(paste0("The total person-time was zero in some survival ",
                   "intervals, when summed to the variable\\(s\\) ",
                   "'agegr' \\(i.e. over all other variables, if any",
                   "\\) _non-consecutively_, i.e. some intervals after ",
                   "an empty interval had person-time in them. ",
                   "Keeping all survival intervals with some ",
                   "estimates as NA for inspection."),
            "Some cumulative surv.obs were zero or NA:")
  
  testthat::expect_message(eval(tf2), msgs[1])
  testthat::expect_message(eval(tf2), msgs[2])
  
  setDT(st2)
  testthat::expect_equal(st2[is.na(surv.obs.as), .N], 60L)
})

Try the popEpi package in your browser

Any scripts or data that you put into this service are public.

popEpi documentation built on Aug. 23, 2023, 5:08 p.m.