Nothing
testthat::context("aggre")
testthat::test_that("aggre leaves original data untouched", {
x <- sire[1:100,]
BL <- list(fot= seq(0,20,1/12), age= c(0:100, Inf), per= c(1960:2014))
x <- lexpand(x, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2, breaks=BL)
## scramble order
set.seed(1L)
x <- x[sample(x = .N, size = .N, replace = FALSE)]
setkeyv(x, NULL)
setDT(x)
forceLexisDT(x, breaks = BL, allScales = c("fot", "per", "age"), key = FALSE)
xor <- copy(x)
ag1 <- aggre(x, by = list(gender = factor(sex, 1, "f"), sex, surv.int = fot, per, agegr = age))
testthat::expect_identical(x, xor)
})
testthat::test_that("aggre works with by = NULL", {
sr <- popEpi::sire[dg_date < ex_date,][1:1000,]
BL <- list(fot= seq(0,20,1), age= c(0:100, Inf), per= c(1960:2014))
x <- lexpand(sr, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2, breaks=BL)
ag1 <- aggre(x, by = NULL)
testthat::expect_equal(as.numeric(ag1), c(9539.1903286174274, 1000, 373, 627))
})
testthat::test_that("aggre and lexpand produce the same results", {
sr <- popEpi::sire[dg_date < ex_date,][1:1000,]
BL <- list(fot= seq(0,20,1/12), age= c(0:100, Inf), per= c(1960:2014))
x <- lexpand(sr, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2, breaks=BL)
if (!is.data.table(x)) setDF2DT(x)
e <- quote(list(gender = factor(sex, 1, "f"), sex, surv.int = fot, per, agegr = age))
v <- c("gender", "sex", "sex", "surv.int", "per", "agegr")
forceLexisDT(x, breaks = BL, allScales = c("fot", "per", "age"))
x2 <- aggre(x, by = e, verbose = FALSE)
x3 <- aggre(x, by = e, type = "full", verbose = FALSE)
x4 <- lexpand(sr, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2, aggre.type = "non-empty",
breaks=BL, aggre = list(gender = factor(sex, 1, "f"), sex, surv.int = fot, per, agegr = age))
x5 <- lexpand(sr, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2, aggre.type = "cartesian",
breaks=BL, aggre = list(gender = factor(sex, 1, "f"), sex, surv.int = fot, per, agegr = age))
x[, fot := popEpi:::cutLow(fot, BL$fot)]
x[, age := popEpi:::cutLow(age, BL$age)]
x[, per := popEpi:::cutLow(per, BL$per)]
x <- x[, list(pyrs = sum(lex.dur), obs = sum(lex.Xst)), keyby = e]
x <- x[pyrs > 0 & !is.na(pyrs)]
if (!is.data.table(x2)) setDF2DT(x2)
if (!is.data.table(x3)) setDF2DT(x3)
if (!is.data.table(x4)) setDF2DT(x4)
if (!is.data.table(x5)) setDF2DT(x5)
setkeyv(x, v)
setkeyv(x2, v)
setkeyv(x3, v)
setkeyv(x4, v)
setkeyv(x5, v)
testthat::expect_equal(x2$pyrs, x$pyrs, tolerance = 1e-05)
testthat::expect_equal(x2$from0to1, x$obs, tolerance = 1e-05)
testthat::expect_equal(sum(x2$pyrs), sum(x3$pyrs), tolerance = 1e-05)
testthat::expect_equal(sum(x2$from0to1), sum(x3$from0to1), tolerance = 1e-05)
testthat::expect_equal(sum(x2$pyrs), sum(x4$pyrs), tolerance = 1e-05)
testthat::expect_equal(sum(x2$from0to1), sum(x4$from0to1), tolerance = 1e-05)
testthat::expect_equal(x3$pyrs, x5$pyrs, tolerance = 1e-05)
testthat::expect_equal(x3$from0to0, x5$from0to0, tolerance = 1e-05)
testthat::expect_equal(sum(x3$from0to1), sum(x5$from0to1), tolerance = 1e-05)
testthat::expect_equal(x2$pyrs, x4$pyrs, tolerance = 1e-05)
testthat::expect_equal(x2$from0to0, x4$from0to0, tolerance = 1e-05)
testthat::expect_equal(sum(x2$from0to1), sum(x4$from0to1), tolerance = 1e-05)
})
testthat::test_that("aggre()'s by argument works flexibly", {
library(Epi)
BL <- list(fot = 0:5, per = c(1995,2015))
for (cond in c(FALSE, TRUE)) {
x <- Lexis(data = sire[dg_date < ex_date,][1:500, ], entry = list(fot = 0, age = dg_age, per = get.yrs(dg_date)),
exit = list(per = get.yrs(ex_date)), exit.status = status,
entry.status = 0)
x <- splitMulti(x, breaks = BL)
setDF(x)
setattr(x, "class", c("Lexis", "data.frame"))
x$agegr <- cut(x$dg_age, 2)
if (cond) {
forceLexisDT(x, breaks = BL, allScales = c("fot", "per", "age"))
alloc.col(x)
}
a <- aggre(x, by = list(agegr = cut(dg_age, 2), sex, fot, per = per), type = "unique")
b <- aggre(x, by = c("agegr", "sex", "fot", "per"), type = "unique")
testthat::expect_equal(a, b)
a <- aggre(x, by = cut(dg_age, 2), type = "unique")
setnames(a, "cut", "agegr")
attr(a, "aggre.meta")$by <- "agegr"
b <- aggre(x, by = c("agegr"), type = "unique")
c <- aggre(x, by = list(agegr = cut(dg_age, 2)), type = "unique")
d<- aggre(x, by = agegr, type = "unique")
testthat::expect_equal(a, b)
testthat::expect_equal(b, c)
testthat::expect_equal(c, d)
}
})
testthat::test_that("subset argument works properly", {
x <- sire[dg_date < ex_date, ][1:1000,]
BL <- list(fot= seq(0,20,1/12), age= c(0:100, Inf), per= c(1960:2014))
x <- lexpand(x, birth = bi_date, entry = dg_date, exit = ex_date,
status = status %in% 1:2, breaks=BL)
# setDT2DF(x)
x2 <- x[x$dg_age <= 55L, ]
setDT(x)
setDT(x2)
forceLexisDT(x, breaks = BL, allScales = c("fot", "per", "age"), key = FALSE)
forceLexisDT(x2, breaks = BL, allScales = c("fot", "per", "age"), key = FALSE)
ag <- quote(list(gender = factor(sex, 1, "f"), sex, surv.int = fot, per, agegr = age))
ag1 <- aggre(x, by = ag, subset = dg_age <= 55L)
ag2 <- aggre(x2, by = ag)
ag3 <- aggre(x, by = ag, type = "full", subset = dg_age <= 55L)
ag4 <- aggre(x2, by = ag, type = "full")
testthat::expect_identical(ag1, ag2)
testthat::expect_identical(ag3, ag4)
})
testthat::test_that("at.risk column works as intended", {
## normal case - no late entry. Just lots of breaks.
popEpi:::skip_normally()
x <- sire[dg_date < ex_date, ][1:1000,]
BL <- list(fot= seq(0,20,1/12), age= c(0:100, Inf), per= c(1960:2014))
x <- Lexis(data = x,
entry = list(fot = 0, age = dg_age, per = get.yrs(dg_date)),
exit = list(per = get.yrs(ex_date)), exit.status = status,
entry.status = 0)
x <- splitMulti(x, breaks = BL, drop = TRUE)
ag <- aggre(x, by = list(sex, fot))
setkey(ag, sex, fot)
## total events and changes in at.risk should be congruent here
ag[, ndiff := at.risk - c(at.risk[-1], NA), by = list(sex)]
ag[!is.na(ndiff), events := from0to0 + from0to1 + from0to2]
testthat::expect_equal(ag$ndiff, ag$events)
## compare at.risk with manually computed at.risk and events
x[, evented := detectEvents(x, breaks = attr(x, "breaks"), by = "lex.id") != 0L]
x[, normalEntry := fot %in% BL$fot]
x[, cutFot := cutLow(fot, BL$fot)]
byDT <- CJ(sex = 1,
cutFot = BL$fot[-length(BL$fot)])
n.start <- x[byDT, .(sum(normalEntry & !duplicated(lex.id)),
sum(evented)), by = .EACHI,
on = names(byDT)]
n.start[is.na(ag$ndiff), V2 := NA]
testthat::expect_equal(ag$at.risk, n.start$V1)
testthat::expect_equal(ag$ndiff, n.start$V2)
})
testthat::test_that("at.risk column works as intended, Vol. 2", {
popEpi:::skip_normally()
## period analysis case - some observations are late entry.
data(sire)
BL <- list(fot=seq(0, 5, by = 1/12),
per = c(2008,2013))
x <- Lexis(data = sire[dg_date < ex_date,],
entry = list(fot = 0, age = dg_age, per = get.yrs(dg_date)),
exit = list(per = get.yrs(ex_date)), exit.status = status,
entry.status = 0)
x <- splitMulti(x, breaks = BL, drop = TRUE)
a <- aggre(x, by = list(sex, per, fot))
setkey(a, sex, per, fot)
a[, ndiff := at.risk - c(at.risk[-1], NA), by = list(sex, per)]
a[!is.na(ndiff), events := from0to0 + from0to1 + from0to2]
x[, normalEntry := fot %in% BL$fot]
x[, cutPer := cutLow(per, BL$per)]
x[, cutFot := cutLow(fot, BL$fot)]
byDT <- CJ(sex = 1, cutPer = BL$per[-length(BL$per)],
cutFot = BL$fot[-length(BL$fot)])
n.start <- x[byDT, sum(normalEntry & !duplicated(lex.id)), by = .EACHI,
on = names(byDT)]
testthat::expect_equal(a$at.risk, n.start$V1)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.