Skip to content

Commit 0be1338

Browse files
jamesdunhamjamesdunham
committed
test and fix bugs in dgirtIn validation
1 parent a75e6ad commit 0be1338

File tree

3 files changed

+193
-29
lines changed

3 files changed

+193
-29
lines changed

‎R/class-dgirtin.r‎

Lines changed: 43 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
#' Class \code{dgirtIn}: data prepared for modeling with \code{dgirt}
22
#'
33
#' \code{shape} generates objects of class \code{dgirtIn} for modeling with
4-
#' \code{dgirt}.
4+
#' \code{dgirt} and \code{dgmrp}.
55
#'
66
#' @aliases dgirtin-class, get_item_n, get_item_names, get_n, dgirtIn-method,
77
#' print.dgirtIn,
@@ -21,38 +21,63 @@ NULL
2121
setOldClass("dgirtIn", "R6")
2222
dgirtIn <- R6::R6Class("dgirtIn",
2323
public = c(
24+
# model objects (N, G, T, ...) and shape objects (item_data, etc.) are
25+
# public and initially NULL
2426
setNames(lapply(c(model_objects, shape_objects), function(x) NULL),
2527
c(model_objects, shape_objects)),
28+
# the class is instantiated from a Control object
2629
initialize = function(ctrl) {
2730
if (length(ctrl@constant_item)) {
2831
self$constant_item <- ctrl@constant_item
2932
}
3033
self$mod_par_names <- c(ctrl@geo_name, ctrl@time_name)
3134
self$unmod_par_names <- ctrl@group_names
3235
},
36+
# the as_list method extracts attributes used in modeling as expected by
37+
# rstan. its arguments will be passed from a dgirt or dgmrp call
3338
as_list = function(separate_t, delta_tbar_prior_mean, delta_tbar_prior_sd,
3439
innov_sd_delta_scale, innov_sd_theta_scale, hierarchical_model) {
40+
41+
# model_objects is a character vector of attribute names for rstan data
3542
d_in_list <- Map(function(x) self[[x]], private$model_objects)
36-
if (!length(separate_t) == 1L && is.logical(separate_t))
43+
44+
# separate_t is a boolean in the stan code
45+
if (length(separate_t) != 1L || !is.logical(separate_t)) {
3746
stop("\"separate_t\" should be a single logical value")
38-
else d_in_list$separate_t <- separate_t
39-
if (!length(hierarchical_model) == 1L && is.logical(hierarchical_model))
47+
}
48+
d_in_list$separate_t <- separate_t
49+
50+
# hierarchical_model is also boolean in the stan code
51+
if (length(hierarchical_model) != 1L || !is.logical(hierarchical_model)) {
4052
stop("\"hierarchical_model\" should be a single logical value")
41-
else d_in_list$hierarchical_model <- hierarchical_model
42-
if (!length(delta_tbar_prior_mean) == 1L &&
43-
is.numeric(delta_tbar_prior_mean))
53+
}
54+
d_in_list$hierarchical_model <- hierarchical_model
55+
56+
if (length(delta_tbar_prior_mean) != 1L || !is.numeric(delta_tbar_prior_mean)) {
4457
stop("\"delta_tbar_prior_mean\" should be a single real value")
45-
else d_in_list$delta_tbar_prior_mean <- delta_tbar_prior_mean
46-
if (!length(delta_tbar_prior_sd) == 1L && is.numeric(delta_tbar_prior_sd))
58+
}
59+
d_in_list$delta_tbar_prior_mean <- delta_tbar_prior_mean
60+
61+
if (length(delta_tbar_prior_sd) != 1L || !is.numeric(delta_tbar_prior_sd)
62+
|| delta_tbar_prior_sd < 0)
63+
{
4764
stop("\"delta_tbar_prior_sd\" should be a single positive real value")
48-
else d_in_list$delta_tbar_prior_sd <- delta_tbar_prior_sd
49-
if (!length(innov_sd_delta_scale ) == 1L && is.numeric(innov_sd_delta_scale))
50-
stop("\"delta_tbar_delta_scale\" should be a single real value")
51-
else d_in_list$innov_sd_delta_scale <- innov_sd_delta_scale
52-
if (!length(innov_sd_theta_scale ) == 1L && is.numeric(innov_sd_theta_scale))
53-
stop("\"delta_tbar_theta_scale\" should be a single real value")
54-
else d_in_list$innov_sd_theta_scale <- innov_sd_theta_scale
65+
}
66+
d_in_list$delta_tbar_prior_sd <- delta_tbar_prior_sd
67+
68+
if (length(innov_sd_delta_scale) != 1L ||
69+
!is.numeric(innov_sd_delta_scale) || innov_sd_delta_scale < 0) {
70+
stop("\"innov_sd_delta_scale\" should be a single real value")
71+
}
72+
d_in_list$innov_sd_delta_scale <- innov_sd_delta_scale
73+
74+
if (length(innov_sd_theta_scale ) != 1L ||
75+
!is.numeric(innov_sd_theta_scale) || innov_sd_theta_scale < 0) {
76+
stop("\"innov_sd_theta_scale\" should be a single positive real value")
77+
}
78+
d_in_list$innov_sd_theta_scale <- innov_sd_theta_scale
79+
5580
d_in_list
5681
}),
57-
private = list(model_objects = model_objects,
58-
shape_objects = shape_objects))
82+
# keep track of which items will be used in modeling
83+
private = list(model_objects = model_objects, shape_objects = shape_objects))

‎tests/testthat/test-dgirt.r‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
fit = suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1))
2+
3+
test_that("compiled model is accessible in stanmodel slot", {
4+
expect_is(fit@stanmodel, 'stanmodel')
5+
fit_with_model = suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1,
6+
model = fit@stanmodel))
7+
expect_identical(fit@stanmodel, fit_with_model@stanmodel)
8+
})
9+
10+
test_that("model indicated by 'version' must exist", {
11+
expect_error(
12+
with_mock(
13+
stanc = function(...) TRUE,
14+
stan_model = function(...) TRUE,
15+
sampling = function(...) fit,
16+
suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1,
17+
version = 'foo'))
18+
), "should give the name of a model")
19+
})
20+
21+
test_that("version can be a model name or an arbitrary stan file", {
22+
expect_silent(
23+
with_mock(
24+
stanc = function(...) TRUE,
25+
stan_model = function(...) TRUE,
26+
sampling = function(...) fit,
27+
suppressMessages(suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1,
28+
version = '2017_01_04')))
29+
))
30+
expect_silent(
31+
with_mock(
32+
stanc = function(...) TRUE,
33+
stan_model = function(...) TRUE,
34+
sampling = function(...) fit,
35+
suppressMessages(suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1,
36+
version = 'user-version.stan')))
37+
))
38+
})
39+
40+
test_that("pars argument is passed but can be overridden", {
41+
fit = suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1,
42+
model = fit@stanmodel))
43+
expect_equivalent(fit@sim$pars_oi, c(default_pars, 'lp__'))
44+
fit_with_pars = suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1,
45+
model = fit@stanmodel, pars = 'theta_bar'))
46+
expect_equivalent(fit_with_pars@sim$pars_oi, c('theta_bar', 'lp__'))
47+
})
48+
49+
test_that("dgmrp can't take more than one item", {
50+
expect_error(suppressWarnings(dgmrp(toy_dgirt_in, iter = 1, chains = 1,
51+
model = fit@stanmodel)), "Multiple items in item data")
52+
})
53+
54+
test_that("version argument is ignored when model is given", {
55+
fit_with_version = suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 1,
56+
model = fit@stanmodel, version = "2017_01_04_singleissue"))
57+
expect_identical(fit@stanmodel, fit_with_version@stanmodel)
58+
})
59+
60+
test_that("init_r defaults to 1L but can be overridden", {
61+
fit_default = suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 2,
62+
model = fit@stanmodel))
63+
expect_true(all(sapply(fit_default@stan_args, `[[`, 'init_r') == 1))
64+
fit_init_r_2 = suppressWarnings(dgirt(toy_dgirt_in, iter = 1, chains = 2,
65+
init_r = 2, model = fit@stanmodel))
66+
expect_true(all(sapply(fit_init_r_2@stan_args, `[[`, 'init_r') == 2))
67+
})
68+

‎tests/testthat/test-dgirtin.r‎

Lines changed: 82 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,30 +1,101 @@
1+
context("dgirt_in class")
2+
3+
test_that("as_list method validates inputs", {
4+
5+
expect_error(minimal_indiv_agg_result$as_list(separate_t = c(TRUE, FALSE),
6+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
7+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
8+
innov_sd_theta_scale = 2.5), "should be a single logical value")
9+
10+
expect_error(minimal_indiv_agg_result$as_list(separate_t = 1,
11+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
12+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
13+
innov_sd_theta_scale = 2.5), "should be a single logical value")
14+
15+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
16+
hierarchical_model = 1, delta_tbar_prior_mean = 0.65,
17+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
18+
innov_sd_theta_scale = 2.5), "should be a single logical value")
19+
20+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
21+
hierarchical_model = c(TRUE, TRUE), delta_tbar_prior_mean = 0.65,
22+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
23+
innov_sd_theta_scale = 2.5), "should be a single logical value")
24+
25+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
26+
hierarchical_model = TRUE, delta_tbar_prior_mean = c(1, 1),
27+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
28+
innov_sd_theta_scale = 2.5), "should be a single real value")
29+
30+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
31+
hierarchical_model = TRUE, delta_tbar_prior_mean = TRUE,
32+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
33+
innov_sd_theta_scale = 2.5), "should be a single real value")
34+
35+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
36+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
37+
delta_tbar_prior_sd = c(1, 1), innov_sd_delta_scale = 2.5,
38+
innov_sd_theta_scale = 2.5), "should be a single positive real value")
39+
40+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
41+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
42+
delta_tbar_prior_sd = TRUE, innov_sd_delta_scale = 2.5,
43+
innov_sd_theta_scale = 2.5), "should be a single positive real value")
44+
45+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
46+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
47+
delta_tbar_prior_sd = -1, innov_sd_delta_scale = 2.5,
48+
innov_sd_theta_scale = 2.5), "should be a single positive real value")
49+
50+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
51+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
52+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = c(1, 1),
53+
innov_sd_theta_scale = 2.5), "should be a single real value")
54+
55+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
56+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
57+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = TRUE,
58+
innov_sd_theta_scale = 2.5), "should be a single real value")
59+
60+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
61+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
62+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
63+
innov_sd_theta_scale = c(1, 1)), "should be a single positive real value")
64+
65+
expect_error(minimal_indiv_agg_result$as_list(separate_t = TRUE,
66+
hierarchical_model = TRUE, delta_tbar_prior_mean = 0.65,
67+
delta_tbar_prior_sd = 0.25, innov_sd_delta_scale = 2.5,
68+
innov_sd_theta_scale = TRUE), "should be a single positive real value")
69+
70+
})
71+
172
context("dgirt_in methods")
273

374
data(aggregates)
4-
aggregate_items <- unique(aggregates$item)
575
data.table::setDT(aggregates)
6-
shaped <- suppressMessages(shape(opinion, item_names = "abortion", aggregate_data = aggregates,
7-
aggregate_item_names = aggregate_items, time_name = "year", geo_name =
8-
"state", group_names = c("race3", "female")))
76+
shaped <- suppressMessages(
77+
shape(opinion,
78+
item_names = "abortion",
79+
aggregate_data = aggregates,
80+
time_name = "year",
81+
geo_name = "state",
82+
group_names = c("race3", "female")))
983

1084
test_that("by argument to get_n works", {
11-
data(toy_dgirt_in)
12-
expect_named(get_n(toy_dgirt_in, by = "state"), c("state", "n"))
13-
expect_named(get_n(toy_dgirt_in, by = c("state", "race3")), c("state", "race3", "n"))
85+
expect_named(get_n(shaped, by = "state"), c("state", "n"))
86+
expect_named(get_n(shaped, by = c("state", "race3")), c("state", "race3", "n"))
1487
})
1588

1689
test_that("aggregate_name argument to get_n works", {
1790
expect_named(get_n(shaped, aggregate_name = "state"), c("state", "n"))
18-
expect_error(get_n(toy_dgirt_in, aggregate_name = "state"),
19-
"no aggregate data")
91+
expect_error(get_n(toy_dgirt_in, aggregate_name = "state"), "no aggregate data")
2092
})
2193

2294
test_that("by argument to get_item_n works", {
2395
data(toy_dgirt_in)
2496
item_names <- c("affirmative_action", "gaymarriage_amendment")
2597
expect_named(get_item_n(toy_dgirt_in, by = "state"), c("state", item_names))
26-
expect_named(get_item_n(toy_dgirt_in, by = c("state", "race3")), c("state",
27-
"race3", item_names))
98+
expect_named(get_item_n(toy_dgirt_in, by = c("state", "race3")), c("state", "race3", item_names))
2899
})
29100

30101
test_that("by argument to get_item_n works with aggregate data", {

0 commit comments

Comments
 (0)