context("LifeTable-methods")
n.test <- 5
test.identity <- FALSE
test_that("collapseIntervals works", {
makeLx <- demlife:::makeLx
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
lt <- LifeTable(mx = mx)
ax <- lt@ax
## do not supply weights
ans.obtained <- collapseIntervals(lt,
dimension = "age",
breaks = seq(5, 70, 10))
Lx <- makeLx(mx = mx, ax = ax)
mx.collapsed <- collapseIntervals(lt@mx,
dimension = "age",
breaks = seq(5, 70, 10),
weights = Lx)
ax.collapsed <- collapseIntervals(lt@ax,
dimension = "age",
breaks = seq(5, 70, 10),
weights = Lx)
ans.expected <- LifeTable(mx = mx.collapsed,
ax = ax.collapsed)
expect_identical(ans.obtained, ans.expected)
## supply weights
popn <- 1000 * makeLx(mx = mx, ax = ax) + 5
ans.obtained <- collapseIntervals(lt,
dimension = "age",
breaks = seq(5, 70, 10),
weights = popn)
mx.collapsed <- collapseIntervals(lt@mx,
dimension = "age",
breaks = seq(5, 70, 10),
weights = popn)
ax.collapsed <- collapseIntervals(lt@ax,
dimension = "age",
breaks = seq(5, 70, 10),
weights = popn)
ans.expected <- LifeTable(mx = mx.collapsed,
ax = ax.collapsed)
expect_identical(ans.obtained, ans.expected)
## aggregate time periods, not age
mx <- dembase::subarray(al, subarray = fun == "mx")
lt <- LifeTable(mx)
ans.obtained <- collapseIntervals(lt,
dimension = "time",
width = 10)
Lx <- makeLx(mx = lt@mx, ax = lt@ax)
mx.collapsed <- collapseIntervals(lt@mx,
dimension = "time",
width = 10,
weights = Lx)
ax.collapsed <- collapseIntervals(lt@ax,
dimension = "time",
width = 10,
weights = Lx)
ans.expected <- LifeTable(mx = mx.collapsed,
ax = ax.collapsed)
expect_identical(ans.obtained, ans.expected)
})
test_that("lifeExpectancy works", {
## result has one dimension
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax)
ans.obtained <- lifeExpectancy(lt)
ans.expected <- lifeTableFun(lt, fun = "ex")
ans.expected <- dembase::slab(ans.expected,
dimension = "age",
elements = 1L)
expect_identical(ans.obtained, ans.expected)
ans.obtained <- lifeExpectancy(lt, age = 10)
ans.expected <- lifeTableFun(lt, fun = "ex")
ans.expected <- dembase::slab(ans.expected,
dimension = "age",
elements = 4L)
expect_identical(ans.obtained, ans.expected)
## result is number
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005") &
(sex == "Female"))
mx <- as(mx, "array")
names(dimnames(mx)) <- "age"
mx <- dembase::Values(mx)
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005") & (sex == "Female"))
ax <- as(ax, "array")
names(dimnames(ax)) <- "age"
ax <- dembase::Values(ax)
lt <- LifeTable(mx = mx, ax = ax)
ans.obtained <- lifeExpectancy(lt)
ans.expected <- lifeTableFun(lt, fun = "ex")[[1]]
expect_identical(ans.obtained, ans.expected)
})
test_that("lifeTableFun works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
## showTotal is TRUE
lt <- LifeTable(mx = mx,
ax = ax)
ans.obtained <- lifeTableFun(lt, fun = "qx")
ans.expected <- dembase::subarray(al,
subarray = (fun == "qx") & (time == "2001-2005"))
expect_equal(as.numeric(dembase::subarray(ans.obtained, sex %in% c("Female", "Male"))),
as.numeric(ans.expected), tol = 0.001)
## showTotal is FALSE
lt <- LifeTable(mx = mx,
ax = ax,
showTotal = FALSE)
ans.obtained <- lifeTableFun(lt, fun = "qx")
ans.expected <- dembase::subarray(al,
subarray = (fun == "qx") & (time == "2001-2005"))
expect_equal(ans.obtained, ans.expected, tol = 0.001)
## life expectancy
lt <- LifeTable(mx = mx,
ax = ax,
showTotal = FALSE)
ans.obtained <- lifeTableFun(lt, fun = "ex")
ans.expected <- dembase::subarray(al,
subarray = (fun == "ex") & (time == "2001-2005"))
ans.expected <- as.array(ans.expected)
dimnames(ans.expected)$age <- c(0, 1, seq(5, 85, 5))
ans.expected <- dembase::Values(ans.expected)
expect_equal(ans.obtained, ans.expected, tol = 0.001)
})
test_that("prob works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
prob = c(0.1, 0.9))
expect_identical(prob(lt), c(0.1, 0.9))
})
test_that("prob replacement function works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
prob = c(0.1, 0.9))
prob(lt) <- c(0.2, 0.8)
expect_identical(prob(lt), c(0.2, 0.8))
})
test_that("radix works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
radix = 123)
expect_identical(radix(lt), 123)
})
test_that("radix replacement function works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
radix = 123)
radix(lt) <- 321
expect_identical(radix(lt), 321)
})
test_that("showFun works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
showFun = c("ex", "Tx"))
expect_identical(showFun(lt), c("ex", "Tx"))
})
test_that("showFun replacement function works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
showFun = c("ex", "Tx"))
showFun(lt) <- c("lx", "dx")
expect_identical(showFun(lt), c("lx", "dx"))
})
test_that("showQuantiles works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
showQuantiles = FALSE)
expect_false(showQuantiles(lt))
})
test_that("showQuantiles replacement function works", {
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
ax <- dembase::subarray(al,
subarray = (fun == "ax") & (time == "2001-2005"))
lt <- LifeTable(mx = mx,
ax = ax,
showQuantiles = FALSE)
showQuantiles(lt) <- TRUE
expect_true(showQuantiles(lt))
})
## Lx1 <- dembase::Counts(array(c(96354,
## 377877,
## 467474,
## 464534,
## 460915,
## 455193,
## 447783,
## 439466,
## 429742,
## 418269,
## 403859,
## 384356,
## 358766,
## 324494,
## 279761,
## 223797,
## 155169,
## 89054,
## 55200) / 100000,
## dim = 19,
## dimnames = list(age = c("0",
## "1-4",
## paste(seq(5, 80, 5),
## seq(9, 84, 5),
## sep = "-"),
## "85+"))))
## Lx2 <- dembase::Counts(array(c(99410,
## 396947,
## 495676,
## 495275,
## 494459,
## 493254,
## 491863,
## 489996,
## 487383,
## 483743,
## 478583,
## 470679,
## 458397,
## 439689,
## 411580,
## 372191,
## 318738,
## 248061,
## 274139) / 100000,
## dim = 19,
## dimnames = list(age = c("0",
## "1-4",
## paste(seq(5, 80, 5),
## seq(9, 84, 5),
## sep = "-"),
## "85+"))))
## lx1 <- dembase::Counts(array(c(100000,
## 95458,
## 93887,
## 93174,
## 92613,
## 91681,
## 90341,
## 88746,
## 86997,
## 84847,
## 82368,
## 79012,
## 74539,
## 68688,
## 60779,
## 50757,
## 38276,
## 23930,
## 12281) / 100000,
## dim = 19,
## dimnames = list(age = c(0, 1, seq(5, 85, 5)))))
## lx2 <- dembase::Counts(array(c(100000,
## 99321,
## 99179,
## 99096,
## 98999,
## 98772,
## 98524,
## 98206,
## 97769,
## 97152,
## 96298,
## 95048,
## 93085,
## 90071,
## 85504,
## 78775,
## 69655,
## 57275,
## 41424) / 100000,
## dim = 19,
## dimnames = list(age = c(0, 1, seq(5, 85, 5)))))
## decompLifeExpPair(lx1, lx2, Lx1, Lx2)
test_that("Sx works", {
makeLx <- demlife:::makeLx
al <- demdata::afghan.life
al <- dembase::Values(al)
mx <- dembase::subarray(al,
subarray = (fun == "mx") & (time == "2001-2005"))
lt <- LifeTable(mx = mx)
## life table not regular
expect_error(Sx(lt),
"age groups have unequal lengths : consider using function 'collapseIntervals' to make lengths equal")
## life table regular; useLabelStart = TRUE
lt <- collapseIntervals(lt,
dimension = "age",
width = 5)
ans.obtained <- Sx(lt)
Lx <- lifeTableFun(lt, "Lx")
head <- 1/dembase::subarray(Lx, age < 80) * as.numeric(dembase::subarray(Lx, age > 5 & age < 85))
tail <- 1/collapseIntervals(dembase::subarray(Lx, age > 80), dimension = "age", breaks = 80) * as.numeric(dembase::subarray(Lx, age > 85))
ans.expected <- dembase::dbind(head, tail, along = "age")
ans.expected <- as(ans.expected, "Values")
if (test.identity)
expect_identical(ans.obtained, ans.expected)
else
expect_equal(ans.obtained, ans.expected)
## life table regular; useLabelStart = FALSE
lt <- collapseIntervals(lt,
dimension = "age",
width = 5)
ans.obtained <- Sx(lt, useLabelStart = FALSE)
Lx <- lifeTableFun(lt, "Lx")
head <- dembase::subarray(Lx, age > 5 & age < 85) / as.numeric(dembase::subarray(Lx, age < 80))
tail <- dembase::subarray(Lx, age > 85, drop = FALSE) / as.numeric(collapseIntervals(dembase::subarray(Lx, age > 80), dimension = "age", breaks = 80))
ans.expected <- dembase::dbind(head, tail, along = "age")
ans.expected <- as(ans.expected, "Values")
if (test.identity)
expect_identical(ans.obtained, ans.expected)
else
expect_equal(ans.obtained, ans.expected)
## make sure that function does no require age intervals and time
## intervals to have the same length
mx <- dembase::addDimension(mx, name = "time", labels = "2000", dimscale = "Intervals")
lt <- LifeTable(mx)
lt <- collapseIntervals(lt,
dimension = "age",
width = 5)
ans.obtained <- Sx(lt)
expect_identical(dimnames(ans.obtained)$time, "2000")
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.