context("dscore")
# dscore, gsed lexicon
data <- data.frame(
age = rep(round(21 / 365.25, 4), 10),
ddifmd001 = c(NA, NA, 0, 0, 0, 1, 0, 1, 1, 1),
ddicmm029 = c(NA, NA, NA, 0, 1, 0, 1, 0, 1, 1),
ddigmd053 = c(NA, 0, 0, 1, 0, 0, 1, 1, 0, 1)
)
expect_silent(dscore(data, items = character(0)))
# explicit key "gsed2212"
expected_d <- c(NA, NA, 6.61, 5.60, 9.09, 9.09, 9.09, 9.09, 15.30, 15.30)
expected_daz <- c(NA, NA, -2.019, -2.235, -1.447, -1.447, -1.447, -1.447, 0.277, 0.277)
z <- dscore(data, key = "gsed2212", algorithm = "1.8.7")
test_that("produces expected D-scores - key gsed2212", {
expect_identical(z$d, expected_d)
expect_identical(z$daz, expected_daz)
})
z1 <- dscore(data, key = "dutch", algorithm = "1.8.7")
expected_d1 <- c(
NA, -1.87, -1.94, 1.26, 1.26, 1.26, 4.63, 4.63,
4.63, 12.06
)
test_that("produces expected D-scores - key dutch", {
expect_identical(z1$d, expected_d1)
})
z2 <- dscore(data, key = "gcdg", algorithm = "1.8.7")
expected_d2 <- c(
NA, NA, 3.47, 0.96, 4.83, 4.83, 4.83, 4.83,
11.81, 11.81
)
test_that("produces expected D-scores - key gcdg", {
expect_identical(z2$d, expected_d2)
})
# subset by items
items <- c("ddifmd001", "ddicmm029", "ddigmd053")
z4 <- dscore(data, items = items, key = "dutch", algorithm = "1.8.7")
expected_d4 <- expected_d1
test_that("produces expected D-scores - key dutch", {
expect_identical(z4$d, expected_d4)
})
z5 <- dscore(data, items = items[1:2], key = "dutch", algorithm = "1.8.7")
expected_d5 <- c(
NA, NA, 3.53, 0.59, 4.61, 4.61, 4.61, 4.61,
12.06, 12.06
)
test_that("produces expected D-scores - key dutch", {
expect_identical(z5$d, expected_d5)
})
test_that("Silently handles outside item code", {
expect_silent(dscore(data,
items = c(items[1:2], "gpagmc013"),
algorithm = "1.8.7"
))
})
# --- test zero rows
data <- data.frame(age = numeric(0))
test_that("handles zero rows", {
expect_identical(nrow(dscore(data)), 0L)
})
# --- test negative ages
# dscore, gsed lexicon
data <- data.frame(
age = c(-0.26, -0.26, NA, 1000, 0.5, -100, Inf, -Inf, 0, 1),
ddifmd001 = c(NA, NA, 0, 0, 0, 1, 0, 1, 1, 1),
ddicmm029 = c(NA, NA, NA, 0, 1, 0, 1, 0, 1, 1),
ddigmd053 = c(NA, 0, 0, 1, 0, 0, 1, 1, 1, 1)
)
test_that("silently handles out-of-range ages", {
expect_silent(dscore(data, key = "dutch"))
})
## D-score - test equivalence of dscore and logit metric
data <- data.frame(
age = rep(round(21 / 365.25, 4), 10),
ddifmd001 = c(NA, NA, 0, 0, 0, 1, 0, 1, 1, 1),
ddicmm029 = c(NA, NA, NA, 0, 1, 0, 1, 0, 1, 1),
ddigmd053 = c(NA, 0, 0, 1, 0, 0, 1, 1, 0, 1)
)
my_itembank <- data.frame(
key = "mykey",
item = items,
tau = get_tau(items = items, key = "dutch")
)
my_reference <- builtin_references[builtin_references$key == "dutch", ]
my_reference$key <- "mykey"
# externally specified transformation
# transform <- c(0, 1)
# transform <- c(0, 2)
transform <- c(50, 3)
qp <- -10:100
algorithm <- "1.8.7"
algorithm <- "current"
zd <- dscore(data,
items = items, dec = 4, metric = "dscore",
itembank = my_itembank, transform = transform, qp = qp,
key = "mykey", population = "dutch",
algorithm = algorithm,
verbose = TRUE
)
zl <- dscore(data,
items = items, dec = 4, metric = "logit",
itembank = my_itembank, key = "mykey", transform = transform, qp = qp,
algorithm = algorithm
)
lastkey <- builtin_keys[nrow(builtin_keys), ]
transform <- c(lastkey$intercept, lastkey$slope)
algorithm <- "1.8.7"
zd <- dscore(data, metric = "dscore", algorithm = algorithm, verbose = FALSE)
zl <- dscore(data, metric = "logit", algorithm = algorithm)
test_that("logit and dscore are identical (1.8.7)", {
expect_equal(zl$d, (zd$d - transform[1]) / transform[2], tolerance = 0.001)
expect_equal(zl$d * transform[2] + transform[1], zd$d, tolerance = 0.001)
})
algorithm <- "current"
zd <- dscore(data, metric = "dscore", algorithm = algorithm, verbose = FALSE)
zl <- dscore(data, metric = "logit", algorithm = algorithm)
test_that("logit and dscore are identical (current)", {
expect_equal(zl$d, (zd$d - transform[1]) / transform[2], tolerance = 0.001)
expect_equal(zl$d * transform[2] + transform[1], zd$d, tolerance = 0.001)
})
# check prior mean as column in data
data <- cbind(data, start = rep(c(0, 10), times = 5))
zp0 <- dscore(data)
zp1 <- dscore(data, prior_mean = "start")
test_that("D-score difference at uneven rows (with start 0) is higher than on uneven rows (with start 10)", {
expect_gt(zp0$d[3] - zp1$d[3], zp0$d[4] - zp1$d[4])
expect_gt(zp0$d[5] - zp1$d[5], zp0$d[6] - zp1$d[6])
expect_gt(zp0$d[7] - zp1$d[7], zp0$d[8] - zp1$d[8])
expect_gt(zp0$d[9] - zp1$d[9], zp0$d[10] - zp1$d[10])
})
test_that("get_mu() handles missing ages", {
expect_silent(get_mu(t = c(NA, NA),
key = "gsed2406",
prior_mean_NA = 50))
expect_silent(get_mu(t = c(NA, -3, 1:3, NA),
key = "gsed2406",
prior_mean_NA = 50))
})
# test empty score vector
scores <- structure(
list(
age = 0, ddifmd001 = NA_integer_, ddifmd002 = NA_real_,
ddifmd003 = NA_real_, ddifmm004 = NA_integer_, ddifmd005 = NA_integer_,
ddigmd006 = NA_real_, ddifmd007 = NA_integer_, ddifmd008 = NA_integer_,
ddifmm009 = NA_real_, ddifmd010 = NA_real_, ddifmd011 = NA_real_,
ddifmm012 = NA_integer_, ddifmd013 = NA_real_, ddifmm014 = NA_integer_,
ddifmd015 = NA_real_, ddifmm016 = NA_integer_, ddifmd017 = NA_integer_,
ddifmd018 = NA_integer_, ddifmm019 = NA_integer_, ddifmd020 = NA_integer_,
ddifmd021 = NA_integer_, ddifmd022 = NA_integer_, ddifmd023 = NA_integer_,
ddifmd024 = NA_integer_, ddifmm025 = NA_integer_, ddifmd026 = NA_integer_,
ddifmd027 = NA_integer_, ddifmd028 = NA_integer_, ddicmm029 = NA_integer_,
ddicmm030 = NA_integer_, ddicmm031 = NA_integer_, ddicmm032 = NA_integer_,
ddicmm033 = NA_integer_, ddicmm034 = NA_integer_, ddicmm035 = NA_integer_,
ddicmm036 = NA_integer_, ddicmm037 = NA_integer_, ddicmm038 = NA_integer_,
ddicmm039 = NA_integer_, ddicmm040 = NA_integer_, ddicmm041 = NA_integer_,
ddicmm042 = NA_integer_, ddicmm043 = NA_integer_, ddicmd044 = NA_integer_,
ddicmm045 = NA_integer_, ddicmm046 = NA_integer_, ddicmm047 = NA_integer_,
ddicmm048 = NA_integer_, ddicmd049 = NA_integer_, ddicmm050 = NA_integer_,
ddicmm051 = NA_integer_, ddigmd052 = NA_real_, ddigmd053 = NA_real_,
ddigmd054 = NA_integer_, ddigmd155 = NA_real_, ddigmd255 = NA_real_,
ddigmd355 = NA_real_, ddigmd055 = NA_real_, ddigmd056 = NA_integer_,
ddigmd057 = NA_integer_, ddigmd058 = NA_integer_, ddigmd059 = NA_real_,
ddigmm060 = NA_integer_, ddigmd061 = NA_integer_, ddigmd062 = NA_integer_,
ddigmd063 = NA_integer_, ddigmm064 = NA_integer_, ddigmm065 = NA_integer_,
ddigmm066 = NA_integer_, ddigmm067 = NA_integer_, ddigmd068 = NA_real_,
ddigmd168 = NA_real_, ddigmd268 = NA_real_, ddigmd069 = NA_integer_,
ddigmd070 = NA_integer_, ddigmd071 = NA_real_, ddigmd072 = NA_integer_,
ddigmm073 = NA_integer_, ddigmd074 = NA_integer_, ddigmd075 = NA_real_
),
class = "data.frame", row.names = c(NA, -1L)
)
test_that("empty vector works with all keys", {
expect_silent(dscore(scores, key = "dutch"))
expect_silent(dscore(scores, key = "gcdg"))
expect_silent(dscore(scores, key = "gsed"))
})
# Variables to append
n <- nrow(data)
ids <- data.frame(
id_chr = LETTERS[1:n],
id_num = 128 + 1:n,
a = NA_real_,
d = rnorm(n)
)
data2 <- data.frame(ids, data)
test_that("prepend attaches two ID columns", {
expect_equal(ncol(dscore(data2, prepend = c("id_chr", "id_num"))), 2 + 6)
})
test_that("unknown variables names produce notfound warning", {
expect_warning(dscore(data2, prepend = c("idonotexist")), "Not found: idonotexist")
})
test_that("reserved names produce overwrite warning", {
expect_warning(dscore(data2, prepend = c("a", "d")))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.