inst/doc/intro-viz.R

In meow: Unified Framework for Computer Adaptive Testing Simulations

## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(collapse = TRUE, comment = "#>", eval = FALSE)

## -----------------------------------------------------------------------------
# # remotes::install_github("klintkanopka/meow")
# library(meow)
# library(tidyverse)

## -----------------------------------------------------------------------------
# out_none <- meow(
#   select_fun = select_max_info,
#   update_fun = update_theta_mle,
#   data_loader = data_simple_1pl,
#   init = NULL,
#   fix = "item"
# )

## -----------------------------------------------------------------------------
# results_none <- out_none$results |>
#   mutate(control = "None")

## -----------------------------------------------------------------------------
# results_none |>
#   select(iter, control, starts_with("pers_")) |>
#   select(iter, control, ends_with("_bias")) |>
#   pivot_longer(ends_with("_bias"), names_to = "person", values_to = "bias") |>
#   group_by(iter, control) |>
#   summarize(rmse = sqrt(mean(bias^2)), .groups = "drop") |>
#   ggplot(aes(x = iter, y = rmse, color = control)) +
#   geom_line() +
#   labs(x = "Number of Items Delivered", y = "RMSE for Person Ability",
#        color = "Exposure Controls") +
#   theme_minimal() +
#   theme(legend.position = "bottom")

## -----------------------------------------------------------------------------
# results_none |>
#   select(iter, control, starts_with("pers_")) |>
#   select(iter, control, ends_with("_bias")) |>
#   pivot_longer(ends_with("_bias"), names_to = "person", values_to = "bias") |>
#   ggplot(aes(x = iter, y = bias, color = control, group = person)) +
#   geom_line(alpha = 0.4) +
#   labs(x = "Number of Items Delivered", y = "Bias in Estimated Person Ability",
#        color = "Exposure Controls") +
#   theme_minimal() +
#   theme(legend.position = "bottom")

## -----------------------------------------------------------------------------
# select_restrict_rate <- function(pers, item, R, admin, adj_mat = NULL, r_max = 0.025) {
#   # if no items have been administered, give the first five to everyone
#   if (!any(admin != 0)) {
#     admin[, seq_len(min(5, ncol(admin)))] <- 1L
#     return(admin)
#   }
# 
#   # compute an exposure rate for every item
#   exposures <- diag(adj_mat)
#   r_obs <- exposures / sum(exposures)
#   allowed <- which(r_obs < r_max)
# 
#   # 2PL information for every respondent-item combination; column-major
#   # recycling avoids materializing extra matrices (matching the package internals)
#   n <- nrow(R)
#   lin <- (pers$theta - rep(item$b, each = n)) * rep(item$a, each = n)
#   p <- stats::plogis(lin)
#   info <- matrix(p * (1 - p) * rep(item$a^2, each = n), nrow = n)
# 
#   for (i in which(rowSums(admin == 0) > 0)) {
#     candidates <- intersect(which(admin[i, ] == 0), allowed)
#     if (length(candidates) == 0) next            # no permitted items remain
#     admin[i, candidates[which.max(info[i, candidates])]] <- 1L
#   }
#   admin
# }

## -----------------------------------------------------------------------------
# out_rest <- meow(
#   select_fun = select_restrict_rate,
#   update_fun = update_theta_mle,
#   data_loader = data_simple_1pl,
#   init = NULL,
#   fix = "item",
#   select_args = list(r_max = 0.02)
# )

## -----------------------------------------------------------------------------
# results_rest <- out_rest$results |>
#   mutate(control = "Restricted")
# 
# results <- bind_rows(results_none, results_rest)
# 
# results |>
#   select(iter, control, starts_with("pers_")) |>
#   select(iter, control, ends_with("_bias")) |>
#   pivot_longer(ends_with("_bias"), names_to = "person", values_to = "bias") |>
#   group_by(iter, control) |>
#   summarize(rmse = sqrt(mean(bias^2)), .groups = "drop") |>
#   ggplot(aes(x = iter, y = rmse, color = control)) +
#   geom_line() +
#   labs(x = "Number of Items Delivered", y = "RMSE for Person Ability",
#        color = "Exposure Controls") +
#   theme_minimal() +
#   theme(legend.position = "bottom")

## -----------------------------------------------------------------------------
# results |>
#   select(iter, control, starts_with("pers_")) |>
#   select(iter, control, ends_with("_bias")) |>
#   pivot_longer(ends_with("_bias"), names_to = "person", values_to = "bias") |>
#   filter(iter <= 20) |>
#   ggplot(aes(x = iter, y = bias, color = control, group = person)) +
#   geom_line(alpha = 0.4) +
#   facet_grid(control ~ .) +
#   labs(x = "Number of Items Delivered", y = "Bias in Estimated Person Ability",
#        color = "Exposure Controls") +
#   theme_minimal() +
#   theme(legend.position = "bottom")

## -----------------------------------------------------------------------------
# library(statnet)
# library(ndtv)
# 
# rest_nets <- lapply(out_rest$adj_mats, network)
# dyn_rest <- networkDynamic(network.list = rest_nets)
# 
# render.d3movie(
#   dyn_rest,
#   usearrows = FALSE,
#   main = "Maximum Fisher Information Item Selection",
#   vertex.cex = abs(out_rest$item_tru$b),
#   vertex.col = ifelse(out_rest$item_tru$b < 0, "dodgerblue", "tomato")
# )