Nothing
tests/testthat/test_survtab_usage.R
In popEpi: Functions for Epidemiological Analysis using Population Data
testthat::context("survtab usage")
testthat::test_that("Dates and frac. yrs produce congruent results", {
popEpi:::skip_normally()
library(Epi)
x <- data.table(popEpi::sire)
x <- x[dg_date<ex_date]
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
## yrs
xy <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = x,
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
## dates
xd <- Lexis(entry = list(FUT = 0L, AGE = dg_date-bi_date, CAL = dg_date),
exit = list(CAL = ex_date),
data = x,
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
yd <- 365.242199
BLy <- list(FUT = seq(0, 5, 1/4))
BLd <- lapply(BLy, function(el) el * yd)
pmy <- data.table(popEpi::popmort)
setnames(pmy, c("year", "agegroup"), c("CAL", "AGE"))
pmd <- data.table(pmy)
pmd[, CAL := as.Date(paste0(CAL, "-01-01"))]
pmd[, AGE := AGE * yd]
pmd[, haz := haz/yd]
#### hazard method
## observed survival & Ederer II
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "hazard",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "hazard",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$surv.obs.lo, std$surv.obs.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs, std$surv.obs, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs.hi, std$surv.obs.hi, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.lo, std$r.e2.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2, std$r.e2, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.hi, std$r.e2.hi, scale = 1L, tolerance = 0.0005)
## pohar perme
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "hazard",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "hazard",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$r.pp.lo, std$r.pp.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp, std$r.pp, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp.hi, std$r.pp.hi, scale = 1L, tolerance = 0.0005)
#### lifetable method
## observed survival & Ederer II
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "lifetable",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "lifetable",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$surv.obs.lo, std$surv.obs.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs, std$surv.obs, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs.hi, std$surv.obs.hi, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.lo, std$r.e2.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2, std$r.e2, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.hi, std$r.e2.hi, scale = 1L, tolerance = 0.0005)
## pohar perme
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "lifetable",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "lifetable",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$r.pp.lo, std$r.pp.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp, std$r.pp, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp.hi, std$r.pp.hi, scale = 1L, tolerance = 0.0005)
})
testthat::test_that("hazard and lifetable produce congruent results", {
popEpi:::skip_normally()
library(Epi)
x <- data.table(popEpi::sire)
x <- x[dg_date<ex_date]
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
xy <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = x,
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
pmy <- data.table(popEpi::popmort)
setnames(pmy, c("year", "agegroup"), c("CAL", "AGE"))
BL <- list(FUT = seq(0, 5, 1/12))
sth <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
pophaz = pmy, breaks = BL,
surv.type = "surv.rel", surv.method = "hazard")
stl <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
pophaz = pmy, breaks = BL,
surv.type = "surv.rel", surv.method = "lifetable")
testthat::expect_equal(sth$r.e2, stl$r.e2, scale = 1, tol = 0.0003415)
testthat::expect_equal(sth$r.e2.lo, stl$r.e2.lo, scale = 1, tol = 0.000354)
testthat::expect_equal(sth$r.e2.hi, stl$r.e2.hi, scale = 1, tol = 0.00033)
testthat::expect_equal(sth$surv.obs, stl$surv.obs, scale = 1, tol = 0.00002575)
testthat::expect_equal(sth$surv.obs.lo, stl$surv.obs.lo, scale = 1, tol = 0.000027)
testthat::expect_equal(sth$surv.obs.hi, stl$surv.obs.hi, scale = 1, tol = 0.000025)
})
## test below even should not work, since period analysis
## means that at.risk counts (subjects entering an interval in its beginning)
## will not necessarily equal the counts of events.
# test_that("lifetable counts work with period analysis", {
# library(Epi)
# x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
# exit = list(CAL = get.yrs(ex_date)),
# data = sire[sire$dg_date < sire$ex_date, ],
# exit.status = as.integer(status %in% 1:2),
# entry.status = 0,
# merge = TRUE)
#
# ## phony group variable
# set.seed(1L)
# x$group <- rbinom(nrow(x), 1, 0.5)
#
# BL <- list(FUT = seq(0, 5, 1/12), CAL = c(2008,2013))
# x <- splitMulti(x, BL)
#
# st1 <- survtab(Surv(FUT, lex.Xst) ~ 1, data = x,
# surv.type = "surv.obs",
# surv.method = "lifetable")
#
# a <- aggre(x, by = FUT)
#
# st2 <- survtab_ag(FUT ~ 1, data = a, surv.type = "surv.obs",
# surv.method = "lifetable",
# n = "at.risk", d = c("from0to1"),
# n.cens = "from0to0", pyrs = "pyrs")
#
# expect_equal(st1$surv.obs, st2$surv.obs)
#
# })
testthat::test_that("its possible to pass dynamically created arguments", {
popEpi:::skip_normally()
library(Epi)
x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = sire[sire$dg_date < sire$ex_date, ],
exit.status = as.integer(status %in% 1:2),
entry.status = 0,
merge = TRUE)
TF <- environment()
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
agegr <- cut(x$dg_age, 4, right = FALSE)
x$agegr <- NULL
w <- as.data.frame(table(agegr))
names(w) <- c("agegr", "weights")
BL <- list(FUT = seq(0, 5, 1/12), CAL = c(2008,2013))
form <- Surv(FUT, lex.Xst) ~ group
st1 <- survtab(form, data = x,
adjust = agegr,
weights = w, breaks = BL,
surv.type = "surv.obs",
surv.method = "hazard")
x <- splitMulti(x, breaks = BL)
x$agegr <- cut(x$dg_age, 4, right = FALSE)
a <- aggre(x, by = list(group, agegr, FUT))
group <- a$group
set(a, j = "group", value = NULL)
form <- FUT ~ group + adjust(agegr)
pyrs <- a$pyrs
set(a, j = "pyrs", value = NULL)
st2 <- survtab_ag(form, data = a, surv.type = "surv.obs",
surv.method = "hazard",
d = c("from0to1"),
weights = "internal",
pyrs = pyrs)
testthat::expect_equal(st1$surv.obs, st2$surv.obs)
})
testthat::test_that("getCall & formula methods for survtab work", {
data("sire")
BL <- list(fot=seq(0, 5, by = 1/12),
per = c("2008-01-01", "2013-01-01"))
set.seed(1)
x <- lexpand(sire[sample(1:.N, 100)],
birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
pophaz = popmort,
aggre = list(sex, fot))
form <- fot ~ sex
e <- quote(survtab_ag(formula = form, data = x))
st <- eval(e)
testthat::expect_equal(formula(st), form)
testthat::expect_equal(getCall(st), e)
})
testthat::test_that("survtab_ag allows for certain arguments to be length > 1", {
data(sire)
set.seed(1)
sire <- sire[sample(1:.N, 100)]
BL <- list(fot=0:5)
x <- lexpand(sire,
birth = bi_date, entry = dg_date, exit = ex_date,
status = status,
breaks = BL,
pophaz = popmort,
aggre = list(fot))
st1 <- survtab_ag(fot ~ 1, data = x,
surv.method = "lifetable",
n.cens = c("from0to0", "from0to2"), d = "from0to1")
st2 <- survtab_ag(fot ~ 1, data = x,
surv.method = "lifetable",
relsurv.method = "pp",
n.cens = c("from0to0", "from0to2"),
d = "from0to1",
d.pp = "from0to1.pp",
d.pp.2 = "from0to1.pp.2",
n.pp = "at.risk.pp",
n.cens.pp = c("from0to0.pp", "from0to2.pp"))
st3 <- survtab_ag(fot ~ 1, data = x,
surv.method = "lifetable",
relsurv.method = "pp",
d = c("from0to0", "from0to2"),
n.cens = "from0to1",
n.cens.pp = "from0to1.pp",
n.pp = "at.risk.pp",
d.pp = c("from0to0.pp", "from0to2.pp"),
d.pp.2 = c("from0to0.pp.2", "from0to2.pp.2"))
testthat::expect_true("surv.obs" %in% names(st1))
testthat::expect_true("surv.obs" %in% names(st2))
testthat::expect_true("surv.obs" %in% names(st3))
testthat::expect_equal(st1[["surv_obs"]], st2[["surv_obs"]])
testthat::expect_equal(st2[["surv_obs"]], st3[["surv_obs"]])
})
testthat::test_that("update() works with survtab objects", {
data(sire)
set.seed(1)
sire <- sire[sample(1:.N, 100)]
BL <- list(fot=seq(0, 5, by = 1/12),
per = c("2008-01-01", "2013-01-01"))
x <- lexpand(sire,
birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
pophaz = popmort,
aggre = list(sex, fot))
st <- survtab_ag(fot ~ 1, data = x)
sts <- survtab_ag(fot ~ sex, data = x)
testthat::expect_equal(sts, update(st, formula. = fot ~ sex))
library(Epi)
x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = sire[sire$dg_date < sire$ex_date, ],
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
st <- survtab(FUT ~ group, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)))
sts <- survtab(FUT ~ 1, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)))
testthat::expect_equal(sts, update(st, . ~ -group))
})
testthat::test_that("internal weights work as intended", {
library("data.table")
data("sire")
sire$agegr <- cut(sire$dg_age,c(0,45,55,65,75,Inf),right=FALSE)
BL <- list(fot=seq(0, 5, by = 1/12),
per = c("2008-01-01", "2013-01-01"))
x <- lexpand(sire, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
pophaz = popmort,
aggre = list(fot,agegr))
## age standardisation using internal weights (age distribution of
## patients diagnosed within the period window)
w <- x[fot == 0, .(weights = sum(at.risk)), keyby = agegr]
st <- survtab_ag(fot ~ adjust(agegr), data = x, weights=w)
st2 <- survtab_ag(fot ~ adjust(agegr), data = x, weights = "internal")
testthat::expect_equal(st$surv.obs.as.lo, st2$surv.obs.as.lo)
})
testthat::test_that("survtab_ag works with bare data.frames", {
data(sire)
BL <- list(fot = 0:5,
per = c("2008-01-01", "2013-01-01"))
x <- lexpand(sire, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
aggre = list(fot))
e <- quote(survtab_ag(fot ~ 1, data = x, surv.type = "surv.obs"))
eb <- quote(survtab_ag(fot ~ 1, data = x, surv.type = "surv.obs",
surv.breaks = 0:5))
la <- list(eval(e), eval(eb))
testthat::expect_equal(la[[1]]$surv.obs.hi, la[[2]]$surv.obs.hi)
x <- data.frame(x)
er <- paste0("Data did not contain breaks and no breaks ",
"were supplied by hand.")
testthat::expect_error(eval(e), regexp = er)
testthat::expect_equal(eval(eb)$surv.obs.hi, la[[2]]$surv.obs.hi)
})
testthat::test_that("confidence intervals are as intended", {
popEpi:::skip_normally()
library(Epi)
## NOTE: recommended to use factor status variable
x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = popEpi::sire[sire$dg_date < sire$ex_date, ],
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
## log-log transformation
st <- survtab(FUT ~ group, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)),
conf.type = "log-log", conf.level = 0.99)
dt <- data.table(st)
dt[, "SE.A" := sqrt(SE.surv.obs^2*(1/(surv.obs*log(surv.obs)))^2)]
dt[, "s.lo" := surv.obs^exp(qnorm(0.995)*SE.A)]
dt[, "s.hi" := surv.obs^exp(qnorm(0.005)*SE.A)]
testthat::expect_equal(dt[, .(lo = surv.obs.lo, hi = surv.obs.hi)],
dt[, .(lo = s.lo, hi = s.hi)])
## log transformation
st <- survtab(FUT ~ group, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)),
conf.type = "log", conf.level = 0.80)
dt <- data.table(st)
dt[, "SE.A" := SE.surv.obs/surv.obs]
dt[, "s.lo" := surv.obs*exp(qnorm(0.10)*SE.A)]
dt[, "s.hi" := surv.obs*exp(qnorm(0.90)*SE.A)]
testthat::expect_equal(dt[, .(lo = surv.obs.lo, hi = surv.obs.hi)],
dt[, .(lo = s.lo, hi = s.hi)])
})
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.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
testthat::context("survtab usage")
testthat::test_that("Dates and frac. yrs produce congruent results", {
popEpi:::skip_normally()
library(Epi)
x <- data.table(popEpi::sire)
x <- x[dg_date<ex_date]
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
## yrs
xy <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = x,
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
## dates
xd <- Lexis(entry = list(FUT = 0L, AGE = dg_date-bi_date, CAL = dg_date),
exit = list(CAL = ex_date),
data = x,
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
yd <- 365.242199
BLy <- list(FUT = seq(0, 5, 1/4))
BLd <- lapply(BLy, function(el) el * yd)
pmy <- data.table(popEpi::popmort)
setnames(pmy, c("year", "agegroup"), c("CAL", "AGE"))
pmd <- data.table(pmy)
pmd[, CAL := as.Date(paste0(CAL, "-01-01"))]
pmd[, AGE := AGE * yd]
pmd[, haz := haz/yd]
#### hazard method
## observed survival & Ederer II
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "hazard",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "hazard",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$surv.obs.lo, std$surv.obs.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs, std$surv.obs, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs.hi, std$surv.obs.hi, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.lo, std$r.e2.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2, std$r.e2, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.hi, std$r.e2.hi, scale = 1L, tolerance = 0.0005)
## pohar perme
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "hazard",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "hazard",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$r.pp.lo, std$r.pp.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp, std$r.pp, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp.hi, std$r.pp.hi, scale = 1L, tolerance = 0.0005)
#### lifetable method
## observed survival & Ederer II
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "lifetable",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "e2",
surv.method = "lifetable",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$surv.obs.lo, std$surv.obs.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs, std$surv.obs, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$surv.obs.hi, std$surv.obs.hi, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.lo, std$r.e2.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2, std$r.e2, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.e2.hi, std$r.e2.hi, scale = 1L, tolerance = 0.0005)
## pohar perme
sty <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "lifetable",
breaks = BLy, pophaz = pmy)
std <- survtab(Surv(FUT, lex.Xst) ~ group, data = xd,
surv.type = "surv.rel", relsurv.method = "pp",
surv.method = "lifetable",
breaks = BLd, pophaz = pmd)
testthat::expect_equal(sty$r.pp.lo, std$r.pp.lo, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp, std$r.pp, scale = 1L, tolerance = 0.0005)
testthat::expect_equal(sty$r.pp.hi, std$r.pp.hi, scale = 1L, tolerance = 0.0005)
})
testthat::test_that("hazard and lifetable produce congruent results", {
popEpi:::skip_normally()
library(Epi)
x <- data.table(popEpi::sire)
x <- x[dg_date<ex_date]
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
xy <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = x,
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
pmy <- data.table(popEpi::popmort)
setnames(pmy, c("year", "agegroup"), c("CAL", "AGE"))
BL <- list(FUT = seq(0, 5, 1/12))
sth <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
pophaz = pmy, breaks = BL,
surv.type = "surv.rel", surv.method = "hazard")
stl <- survtab(Surv(FUT, lex.Xst) ~ group, data = xy,
pophaz = pmy, breaks = BL,
surv.type = "surv.rel", surv.method = "lifetable")
testthat::expect_equal(sth$r.e2, stl$r.e2, scale = 1, tol = 0.0003415)
testthat::expect_equal(sth$r.e2.lo, stl$r.e2.lo, scale = 1, tol = 0.000354)
testthat::expect_equal(sth$r.e2.hi, stl$r.e2.hi, scale = 1, tol = 0.00033)
testthat::expect_equal(sth$surv.obs, stl$surv.obs, scale = 1, tol = 0.00002575)
testthat::expect_equal(sth$surv.obs.lo, stl$surv.obs.lo, scale = 1, tol = 0.000027)
testthat::expect_equal(sth$surv.obs.hi, stl$surv.obs.hi, scale = 1, tol = 0.000025)
})
## test below even should not work, since period analysis
## means that at.risk counts (subjects entering an interval in its beginning)
## will not necessarily equal the counts of events.
# test_that("lifetable counts work with period analysis", {
# library(Epi)
# x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
# exit = list(CAL = get.yrs(ex_date)),
# data = sire[sire$dg_date < sire$ex_date, ],
# exit.status = as.integer(status %in% 1:2),
# entry.status = 0,
# merge = TRUE)
#
# ## phony group variable
# set.seed(1L)
# x$group <- rbinom(nrow(x), 1, 0.5)
#
# BL <- list(FUT = seq(0, 5, 1/12), CAL = c(2008,2013))
# x <- splitMulti(x, BL)
#
# st1 <- survtab(Surv(FUT, lex.Xst) ~ 1, data = x,
# surv.type = "surv.obs",
# surv.method = "lifetable")
#
# a <- aggre(x, by = FUT)
#
# st2 <- survtab_ag(FUT ~ 1, data = a, surv.type = "surv.obs",
# surv.method = "lifetable",
# n = "at.risk", d = c("from0to1"),
# n.cens = "from0to0", pyrs = "pyrs")
#
# expect_equal(st1$surv.obs, st2$surv.obs)
#
# })
testthat::test_that("its possible to pass dynamically created arguments", {
popEpi:::skip_normally()
library(Epi)
x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = sire[sire$dg_date < sire$ex_date, ],
exit.status = as.integer(status %in% 1:2),
entry.status = 0,
merge = TRUE)
TF <- environment()
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
agegr <- cut(x$dg_age, 4, right = FALSE)
x$agegr <- NULL
w <- as.data.frame(table(agegr))
names(w) <- c("agegr", "weights")
BL <- list(FUT = seq(0, 5, 1/12), CAL = c(2008,2013))
form <- Surv(FUT, lex.Xst) ~ group
st1 <- survtab(form, data = x,
adjust = agegr,
weights = w, breaks = BL,
surv.type = "surv.obs",
surv.method = "hazard")
x <- splitMulti(x, breaks = BL)
x$agegr <- cut(x$dg_age, 4, right = FALSE)
a <- aggre(x, by = list(group, agegr, FUT))
group <- a$group
set(a, j = "group", value = NULL)
form <- FUT ~ group + adjust(agegr)
pyrs <- a$pyrs
set(a, j = "pyrs", value = NULL)
st2 <- survtab_ag(form, data = a, surv.type = "surv.obs",
surv.method = "hazard",
d = c("from0to1"),
weights = "internal",
pyrs = pyrs)
testthat::expect_equal(st1$surv.obs, st2$surv.obs)
})
testthat::test_that("getCall & formula methods for survtab work", {
data("sire")
BL <- list(fot=seq(0, 5, by = 1/12),
per = c("2008-01-01", "2013-01-01"))
set.seed(1)
x <- lexpand(sire[sample(1:.N, 100)],
birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
pophaz = popmort,
aggre = list(sex, fot))
form <- fot ~ sex
e <- quote(survtab_ag(formula = form, data = x))
st <- eval(e)
testthat::expect_equal(formula(st), form)
testthat::expect_equal(getCall(st), e)
})
testthat::test_that("survtab_ag allows for certain arguments to be length > 1", {
data(sire)
set.seed(1)
sire <- sire[sample(1:.N, 100)]
BL <- list(fot=0:5)
x <- lexpand(sire,
birth = bi_date, entry = dg_date, exit = ex_date,
status = status,
breaks = BL,
pophaz = popmort,
aggre = list(fot))
st1 <- survtab_ag(fot ~ 1, data = x,
surv.method = "lifetable",
n.cens = c("from0to0", "from0to2"), d = "from0to1")
st2 <- survtab_ag(fot ~ 1, data = x,
surv.method = "lifetable",
relsurv.method = "pp",
n.cens = c("from0to0", "from0to2"),
d = "from0to1",
d.pp = "from0to1.pp",
d.pp.2 = "from0to1.pp.2",
n.pp = "at.risk.pp",
n.cens.pp = c("from0to0.pp", "from0to2.pp"))
st3 <- survtab_ag(fot ~ 1, data = x,
surv.method = "lifetable",
relsurv.method = "pp",
d = c("from0to0", "from0to2"),
n.cens = "from0to1",
n.cens.pp = "from0to1.pp",
n.pp = "at.risk.pp",
d.pp = c("from0to0.pp", "from0to2.pp"),
d.pp.2 = c("from0to0.pp.2", "from0to2.pp.2"))
testthat::expect_true("surv.obs" %in% names(st1))
testthat::expect_true("surv.obs" %in% names(st2))
testthat::expect_true("surv.obs" %in% names(st3))
testthat::expect_equal(st1[["surv_obs"]], st2[["surv_obs"]])
testthat::expect_equal(st2[["surv_obs"]], st3[["surv_obs"]])
})
testthat::test_that("update() works with survtab objects", {
data(sire)
set.seed(1)
sire <- sire[sample(1:.N, 100)]
BL <- list(fot=seq(0, 5, by = 1/12),
per = c("2008-01-01", "2013-01-01"))
x <- lexpand(sire,
birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
pophaz = popmort,
aggre = list(sex, fot))
st <- survtab_ag(fot ~ 1, data = x)
sts <- survtab_ag(fot ~ sex, data = x)
testthat::expect_equal(sts, update(st, formula. = fot ~ sex))
library(Epi)
x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = sire[sire$dg_date < sire$ex_date, ],
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
st <- survtab(FUT ~ group, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)))
sts <- survtab(FUT ~ 1, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)))
testthat::expect_equal(sts, update(st, . ~ -group))
})
testthat::test_that("internal weights work as intended", {
library("data.table")
data("sire")
sire$agegr <- cut(sire$dg_age,c(0,45,55,65,75,Inf),right=FALSE)
BL <- list(fot=seq(0, 5, by = 1/12),
per = c("2008-01-01", "2013-01-01"))
x <- lexpand(sire, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
pophaz = popmort,
aggre = list(fot,agegr))
## age standardisation using internal weights (age distribution of
## patients diagnosed within the period window)
w <- x[fot == 0, .(weights = sum(at.risk)), keyby = agegr]
st <- survtab_ag(fot ~ adjust(agegr), data = x, weights=w)
st2 <- survtab_ag(fot ~ adjust(agegr), data = x, weights = "internal")
testthat::expect_equal(st$surv.obs.as.lo, st2$surv.obs.as.lo)
})
testthat::test_that("survtab_ag works with bare data.frames", {
data(sire)
BL <- list(fot = 0:5,
per = c("2008-01-01", "2013-01-01"))
x <- lexpand(sire, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2,
breaks = BL,
aggre = list(fot))
e <- quote(survtab_ag(fot ~ 1, data = x, surv.type = "surv.obs"))
eb <- quote(survtab_ag(fot ~ 1, data = x, surv.type = "surv.obs",
surv.breaks = 0:5))
la <- list(eval(e), eval(eb))
testthat::expect_equal(la[[1]]$surv.obs.hi, la[[2]]$surv.obs.hi)
x <- data.frame(x)
er <- paste0("Data did not contain breaks and no breaks ",
"were supplied by hand.")
testthat::expect_error(eval(e), regexp = er)
testthat::expect_equal(eval(eb)$surv.obs.hi, la[[2]]$surv.obs.hi)
})
testthat::test_that("confidence intervals are as intended", {
popEpi:::skip_normally()
library(Epi)
## NOTE: recommended to use factor status variable
x <- Lexis(entry = list(FUT = 0, AGE = dg_age, CAL = get.yrs(dg_date)),
exit = list(CAL = get.yrs(ex_date)),
data = popEpi::sire[sire$dg_date < sire$ex_date, ],
entry.status = 0L,
exit.status = as.integer(status %in% 1:2),
merge = TRUE)
## phony group variable
set.seed(1L)
x$group <- rbinom(nrow(x), 1, 0.5)
## log-log transformation
st <- survtab(FUT ~ group, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)),
conf.type = "log-log", conf.level = 0.99)
dt <- data.table(st)
dt[, "SE.A" := sqrt(SE.surv.obs^2*(1/(surv.obs*log(surv.obs)))^2)]
dt[, "s.lo" := surv.obs^exp(qnorm(0.995)*SE.A)]
dt[, "s.hi" := surv.obs^exp(qnorm(0.005)*SE.A)]
testthat::expect_equal(dt[, .(lo = surv.obs.lo, hi = surv.obs.hi)],
dt[, .(lo = s.lo, hi = s.hi)])
## log transformation
st <- survtab(FUT ~ group, data = x,
surv.type = "surv.obs",
breaks = list(FUT = seq(0, 5, 1/12)),
conf.type = "log", conf.level = 0.80)
dt <- data.table(st)
dt[, "SE.A" := SE.surv.obs/surv.obs]
dt[, "s.lo" := surv.obs*exp(qnorm(0.10)*SE.A)]
dt[, "s.hi" := surv.obs*exp(qnorm(0.90)*SE.A)]
testthat::expect_equal(dt[, .(lo = surv.obs.lo, hi = surv.obs.hi)],
dt[, .(lo = s.lo, hi = s.hi)])
})
Try the popEpi package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.