The adaptive testing algorithm operates on the principle of Maximum
Fisher Information (MFI) for item selection. This involves identifying
the item from the available pool that maximizes the Fisher information
function at the current provisional ability estimate, formalized as:
Algorithmic Foundation of CAT
Building on the information-theoretic framework, a Computerized
Adaptive Test dynamically selects items that maximize information at
each step, tailoring the assessment to the examinee’s evolving ability
estimate.
Adaptive Testing Cycle
State at step t:
- Tₜ: Administered items
- y₁₋ₜ: Observed responses
- θ̂ₜ: Current ability estimate
- SEₜ: Current standard error
Iteration Steps:
1. Item Selection: j* = argmaxⱼ Iⱼ(θ̂ₜ) for j ∉ Tₜ
With content balancing and exposure control
2. Administration: Deliver item j*, record response yₜ₊₁
3. Ability Estimation: Update θ̂ₜ₊₁ using EAP or MLE
4. Precision Calculation: SEₜ₊₁ = 1 / √(∑ Iⱼ(θ̂ₜ₊₁))
5. Termination Check:
Stop if SEₜ₊₁ < SE_target OR t+1 ≥ L_max
Example: SE_target = 0.30 (reliability ~0.91)
This Shiny app is an interactive visual laboratory for Item
Response Theory (IRT). It dynamically illustrates how item and test
characteristics relate to measurement precision. The app displays
Item Characteristic Curves (ICCs) showing the probability of a
correct response \(P(\theta)\),
Item Information Functions (IIFs) showing item-level precision,
and the Test Information Function (TIF) with its corresponding
Conditional Standard Error of Measurement (SEM). As you adjust
the parameters of the most recently added item, the app instantly
recomputes and redraws all curves, letting you see exactly how
discrimination, difficulty, and asymptotes shape both item behavior and
overall test precision.
Use Add Item to generate new items that contribute
colored IIFs to the total TIF (black line). Adjust the a, b, c,
d sliders to change discrimination, difficulty, guessing, and
ceiling parameters for the last item. The ICCs (gray) and IIFs (rainbow)
update in real time. Experiment by moving the θ slider
at the bottom to probe specific ability levels — the app updates \(P(\theta)\), \(P'(\theta)\), \(I(\theta)\), TIF, and SEM values
interactively. Uncheck the Show all IIFs box to focus on
test-level precision alone, or toggle Show ICC background to
compare probabilities and information. Try adding or modifying items to
observe how the TIF grows, how SEM shrinks, and how the distribution of
item difficulties determines where the test measures most precisely.
Launch the interactive IRT explorer in one click or run it
locally.
Run Locally
- Create an empty folder.
- Save the code below as
app.R inside it.
- Open in RStudio → click Run App.
Web Version
Click on the image below
(No R install needed — hosted on shinyapps.io)
#=====================================================================
# IIF–TIF–SEM Explorer — EAP-locked θ (FAST) — Pool = 450
# Uses custom Gauss–Hermite quadrature (no statmod)
# =====================================================================
#--------------------------------------------
# ---- PACKAGES SECTION ----
#--------------------------------------------
library(shiny)
library(dplyr)
library(tibble)
library(tidyr)
library(shinyjs)
library(shinyWidgets)
library(shape)
library(TeachingDemos)
library(later)
library(shinyBS)
library(ggplot2)
#--------------------------------------------
# ---- Helpers & Constants ------------------
#--------------------------------------------
D.const <- 1.702
pool_size <- 450
# helpers/ui_components.R
# Metric card for displaying key statistics
metric_card <- function(title, value, subtitle = NULL, color = "#3498db", width = 4) {
div(class = paste0("col-sm-", width),
div(class = "metric-card",
style = paste0("border-left: 4px solid ", color, "; background: white; padding: 15px; border-radius: 8px; margin-bottom: 15px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);"),
h4(value, style = paste0("color: ", color, "; font-weight: 700; margin: 0 0 5px 0;")),
h6(title, style = "color: #6c757d; margin-bottom: 0; font-weight: 600; font-size: 12px; text-transform: uppercase;"),
if(!is.null(subtitle)) p(subtitle, style = "font-size: 0.75rem; color: #8c8c8c; margin: 5px 0 0 0;")
)
)
}
# Slider component for consistent controls
slider_component <- function(id, label, value, min = 0, max = 1, step = 0.05, width = "100%") {
div(class = "slider-group",
style = "margin-bottom: 15px;",
h5(label, style = "font-size: 13px; font-weight: 600; color: #374151; margin-bottom: 8px;"),
sliderInput(id, NULL, min = min, max = max, value = value, step = step, width = width)
)
}
# Section wrapper for consistent styling
section_component <- function(..., title = NULL, icon_name = NULL, class = "") {
div(class = paste("sb-section", class),
if(!is.null(title)) {
div(class = "sb-head",
if(!is.null(icon_name)) icon(icon_name, class = "sb-icon"),
title
)
},
...
)
}
# Button group for consistent action buttons
button_group <- function(..., class = "button-group") {
div(class = class, style = "display: flex; gap: 8px; justify-content: space-between; margin: 12px 0;", ...)
}
# Compact status pill for inline metrics
status_pill <- function(label, value, color = "#64748b") {
div(style = paste0("display: inline-flex; align-items: center; gap: 4px; background: white; border-radius: 6px; padding: 4px 8px; border: 1px solid #e2e8f0; border-top: 3px solid ", color, ";"),
span(style = "color: #64748b; font-weight: 600; font-size: 7px;", label),
span(style = "color: #1e293b; font-weight: 700; font-size: 7px;", value)
)
}
# FAQ item component for consistent FAQ structure
faq_item <- function(id, question, answer, icon_color = "#4A90E2") {
div(
class = "faq-item",
style = "margin-bottom: 15px; border: 1px solid #e0e0e0; border-radius: 8px;",
actionLink(
inputId = paste0("toggle_", id),
label = div(
style = "padding: 15px 20px; background: #f8f9fa; border-radius: 8px 8px 0 0; cursor: pointer;",
icon("question-circle", style = paste0("color: ", icon_color, "; margin-right: 10px;")),
tags$span(question, style = "font-weight: bold; color: #2c3e50;")
)
),
div(
id = paste0("answer_", id),
style = "display: none; padding: 20px; background: white; border-radius: 0 0 8px 8px;",
answer
)
)
}
# ===========================================
# THETA GRID TOOLBOX - GAUSS-HERMITE IMPLEMENTATION
# ===========================================
# -------------------------
# Helper: defensive validator
# -------------------------
stop_if_bad_grid <- function(theta, w) {
if (length(theta) != length(w)) stop("theta and w must have same length")
if (length(theta) == 0) stop("Empty grid: length(theta) == 0")
if (any(!is.finite(theta))) stop("Non-finite values in theta")
if (any(!is.finite(w))) stop("Non-finite values in w")
if (any(w < 0)) stop("Negative weights found")
s <- sum(w)
if (!is.finite(s) || s <= 0) stop("Weights sum to zero or non-finite")
invisible(TRUE)
}
# -------------------------
# Golub–Welsch implementation for Gauss–Hermite
# -------------------------
gauss_hermite_gw <- function(n) {
if (!is.numeric(n) || n < 1) stop("'n' must be a positive integer")
n <- as.integer(n)
if (n == 1L) return(list(nodes = 0, weights = 1))
# Recurrence coefficients for probabilists' Hermite polynomials
k <- seq_len(n - 1)
b <- sqrt(k / 2)
# Build symmetric tridiagonal Jacobi matrix
J <- matrix(0, n, n)
for (i in seq_len(n - 1)) {
J[i, i + 1] <- b[i]
J[i + 1, i] <- b[i]
}
# Eigen-decomposition: nodes = eigenvalues, weights ~ square of first row of eigenvectors
ev <- eigen(J, symmetric = TRUE)
nodes <- as.numeric(ev$values)
v1 <- ev$vectors[1, ]
weights <- as.numeric((v1^2) / sum(v1^2))
# Sort nodes & weights ascending
ord <- order(nodes)
nodes <- nodes[ord]
weights <- weights[ord]
stop_if_bad_grid(nodes, weights)
list(nodes = nodes, weights = weights)
}
# -------------------------
# make_theta_grid(): create uniform or GH grid
# -------------------------
make_theta_grid <- function(n = 61,
scheme = c("ghermite", "uniform"),
range = c(-4,4),
prior_mean = 0,
prior_sd = 1,
gh_force_odd = FALSE,
clip = FALSE,
return_meta = TRUE) {
scheme <- match.arg(scheme)
n_in <- as.integer(n)
if (isTRUE(gh_force_odd) && scheme == "ghermite" && n %% 2 == 0) n <- n + 1L
if (scheme == "uniform") {
if (length(range) != 2 || range[1] >= range[2]) stop("Invalid 'range' for uniform grid")
if (n < 2) stop("'n' must be >= 2 for a uniform grid")
theta <- seq(range[1], range[2], length.out = n)
w <- rep(1 / n, n)
} else {
gh <- gauss_hermite_gw(n)
theta <- prior_mean + prior_sd * gh$nodes
w <- gh$weights
}
stop_if_bad_grid(theta, w)
out <- list(theta = as.numeric(theta), w = as.numeric(w))
if (isTRUE(return_meta)) {
out$meta <- list(
scheme = scheme,
n_request = n_in,
n_returned = length(out$theta),
clipped = FALSE,
prior_mean = if (scheme == "ghermite") prior_mean else NA_real_,
prior_sd = if (scheme == "ghermite") prior_sd else NA_real_
)
}
out
}
# -------------------------
# Scale GH nodes to desired range (preserves relative spacing)
# -------------------------
scale_gh_grid <- function(grid, range = c(-4,4)) {
X_max <- max(abs(grid$theta))
R <- max(abs(range))
theta_scaled <- grid$theta * R / X_max
w_scaled <- grid$w * (X_max / R) # adjust weight density
w_scaled <- w_scaled / sum(w_scaled) # renormalize
list(theta = theta_scaled, w = w_scaled)
}
# ===========================================
# PLOTTING FUNCTIONS FOR SHINY
# ===========================================
# -------------------------
# Node spacing plot (for your grid diagnostics)
# -------------------------
plot_spacing <- function(grid1, grid2, names=c("Grid 1","Grid 2"), xlim_range=c(-4,4)) {
df1 <- data.frame(theta=grid1$theta[-1], dtheta=diff(grid1$theta), grid=names[1])
df2 <- data.frame(theta=grid2$theta[-1], dtheta=diff(grid2$theta), grid=names[2])
df <- rbind(df1, df2)
ggplot(df, aes(theta, dtheta, color=grid)) +
geom_line(size=1.2) +
geom_point(size=2, alpha=0.8) +
labs(x = expression(theta), y = expression(Delta*theta)) +
scale_color_manual(values = c("#e74c3c", "#3498db")) +
guides(color = guide_legend(nrow = 1, byrow = TRUE)) +
coord_cartesian(xlim = xlim_range) +
theme_minimal(base_size = 14) +
theme(
legend.position = "top",
legend.title = element_blank(),
legend.text = element_text(size = 12),
plot.margin = margin(10, 10, 10, 10),
panel.grid.minor = element_blank()
)
}
# -------------------------
# Distribution comparison plot
# -------------------------
plot_density_comparison <- function(grid1, grid2, names=c("Grid 1","Grid 2"), xlim_range=c(-4,4)) {
# Create normal distribution curve
x_seq <- seq(xlim_range[1], xlim_range[2], length.out = 200)
normal_density <- dnorm(x_seq)
normal_df <- data.frame(x = x_seq, y = normal_density, distribution = "Standard Normal")
# Create weighted density representations
gh_density <- data.frame(
x = grid1$theta,
y = grid1$w / diff(range(grid1$theta)) * length(grid1$theta),
distribution = names[1]
)
unif_density <- data.frame(
x = grid2$theta,
y = grid2$w / diff(range(grid2$theta)) * length(grid2$theta),
distribution = names[2]
)
# Combine all data
plot_data <- rbind(normal_df, gh_density, unif_density)
ggplot(plot_data, aes(x = x, y = y, color = distribution, linetype = distribution)) +
geom_line(data = subset(plot_data, distribution == "Standard Normal"), linewidth = 1.5) +
geom_point(data = subset(plot_data, distribution != "Standard Normal"), size = 2, alpha = 0.7) +
geom_line(data = subset(plot_data, distribution != "Standard Normal"), linewidth = 1, alpha = 0.7) +
labs(
x = expression(theta),
y = "Density / Scaled Weights",
title = "Distribution Comparison: Gauss-Hermite vs Uniform vs Normal"
) +
scale_color_manual(values = c(
"Standard Normal" = "#2ecc71",
"Gauss-Hermite (31 nodes)" = "#3498db",
"Uniform (31 nodes)" = "#e74c3c"
)) +
scale_linetype_manual(values = c(
"Standard Normal" = "solid",
"Gauss-Hermite (31 nodes)" = "solid",
"Uniform (31 nodes)" = "solid"
)) +
coord_cartesian(xlim = xlim_range) +
theme_minimal(base_size = 14) +
theme(
legend.position = "top",
legend.title = element_blank(),
legend.text = element_text(size = 12),
plot.margin = margin(10, 10, 10, 10),
panel.grid.minor = element_blank(),
plot.title = element_text(hjust = 0.5, size = 14)
)
}
calculate_consistent_iif <- function(theta, items) {
sapply(1:nrow(items), function(i) {
I_3pl(theta, items$a[i], items$b[i], items$c[i])
})
}
calculate_consistent_tif <- function(theta, items) {
sum(calculate_consistent_iif(theta, items), na.rm = TRUE)
}
show_error_plot <- function(title, message) {
par(mar = c(2, 2, 6, 2))
plot(1, 1, type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", main = "")
# Error title in red
text(0.5, 0.7, labels = paste("ERROR:", title),
col = "#e74c3c", cex = 1.2, font = 2)
# Error message
text(0.5, 0.5, labels = "Plot could not be rendered",
col = "#2c3e50", cex = 1.0)
# Detailed error
text(0.5, 0.3, labels = paste("Reason:", message),
col = "#2c3e50", cex = 0.8)
# Instruction
text(0.5, 0.1, labels = "Check console for details",
col = "#7f8c8d", cex = 0.7)
# Draw a border
rect(0.05, 0.05, 0.95, 0.95, border = "#e74c3c", lwd = 2)
}
safe_execute <- function(expr, default_value, context = "Operation") {
tryCatch(
expr,
error = function(e) {
warning(paste(context, "failed:", e$message))
return(default_value)
}
)
}
safe_numeric <- function(x, default = 0, min_val = -Inf, max_val = Inf) {
if (is.null(x) || length(x) == 0 || !is.finite(x)) {
return(default)
}
pmin(pmax(x, min_val), max_val)
}
safe_length <- function(x) {
if (is.null(x)) 0 else length(x)
}
safe_nrow <- function(x) {
if (is.null(x) || !is.data.frame(x)) 0 else nrow(x)
}
# Global (Cached in global environment for fast access)
.GH <- local({
gh <- gauss_hermite_quadrature(31)
# SIMPLE FIX: Just normalize the weights
normalized_weights <- gh$weights / sum(gh$weights)
list(nodes = gh$nodes, weights = normalized_weights)
})
# Helper function for shadow text
shadowtext <- function(x, y, labels, col = "black", bg = "white",
theta = seq(0, 2*pi, length.out = 50), r = 0.1, ...) {
# Draw background text (shadow)
for (i in 1:length(theta)) {
text(x + r * cos(theta[i]), y + r * sin(theta[i]),
labels, col = bg, ...)
}
# Draw foreground text
text(x, y, labels, col = col, ...)
}
# For smooth curves in plots
.THETA_GRID <- seq(-4, 4, length.out = 301)
# Authoritative 3PL implementation with proper error handling
P_3pl <- function(theta, a, b, c) {
# Input validation and clamping - APPLY TO PARAMETERS, DON'T OVERWRITE
a_clamped <- max(a, 0.5)
c_clamped <- max(0, min(c, 0.2))
# Core 3PL calculation - VECTORIZED
exponent <- -D.const * a_clamped * (theta - b)
p_correct <- c_clamped + (1 - c_clamped) / (1 + exp(exponent))
# Ensure numerical stability
pmin(pmax(p_correct, 1e-10), 1 - 1e-10)
}
# Vectorized derivative of 3PL function
Pprime_3pl <- function(theta, a, b, c) {
P <- P_3pl(theta, a, b, c)
(D.const * a / (1 - c)) * (P - c) * (1 - P)
}
# Vectorized Fisher information function for 3PL model
I_3pl <- function(theta, a, b, c) {
safe_execute({
P <- P_3pl(theta, a, b, c)
# Additional safety for the denominator
denom <- max(1 - c, 1e-10) # Avoid division by zero
Pp <- (D.const * a / denom) * (P - c) * (1 - P)
info <- (Pp^2) / max(P * (1 - P), 1e-10) # Avoid division by zero
ifelse(is.finite(info), info, 0)
}, default_value = 0, context = "Information calculation")
}
estimate_theta_eap <- function(current_items, responses, prior_mean = 0, prior_sd = 1) {
# Input validation
if (is.null(current_items) || nrow(current_items) == 0 || length(responses) == 0) {
return(prior_mean)
}
n <- min(nrow(current_items), length(responses))
if (n == 0) return(prior_mean)
current_items <- current_items[1:n, , drop = FALSE]
responses <- responses[1:n]
# Use Gauss-Hermite quadrature
nodes <- .GH$nodes
weights <- .GH$weights
theta_nodes <- prior_mean + prior_sd * sqrt(2) * nodes
# Calculate likelihood with numerical stability
log_likelihood <- matrix(0, nrow = length(theta_nodes), ncol = n)
for (i in 1:n) {
p_correct <- P_3pl(theta_nodes, current_items$a[i], current_items$b[i], current_items$c[i])
# Log-likelihood for numerical stability
# FIXED VERSION:
if (responses[i] == 1) {
log_likelihood[, i] <- log(pmax(p_correct, 1e-300))
} else {
log_likelihood[, i] <- log(pmax(1 - p_correct, 1e-300))
}
}
# Sum log-likelihoods
joint_log_likelihood <- rowSums(log_likelihood)
# Convert back with log-sum-exp trick
max_log_likelihood <- max(joint_log_likelihood)
joint_likelihood <- exp(joint_log_likelihood - max_log_likelihood)
# Calculate posterior
posterior <- joint_likelihood * weights
# Normalize posterior
posterior <- posterior / sum(posterior)
eap_estimate <- sum(posterior * theta_nodes)
# Bound the estimate to reasonable range
eap_estimate <- max(-4, min(4, eap_estimate))
return(eap_estimate)
}
# ---- Pool & selection ------------------------------------------------
create_item_pool <- function(size = 450,
a_meanlog = log(1.2),
a_sdlog = 0.3,
b_sd = 1.2,
c_range = c(0, 0.20)) {
tibble::tibble(
id = 1:size,
label = paste0("i", sprintf("%03d", 1:size)),
a = rlnorm(size, meanlog = a_meanlog, sdlog = a_sdlog),
b = rnorm(size, 0, b_sd),
c = runif(size, c_range[1], c_range[2]),
# ADD SYMPSON-HETTER PARAMETERS
exposure_prob = 1, # Initial exposure probability
admin_count = 0 # Track how many times administered
)
}
generate_stable_colors <- function(size = pool_size) {
# High-contrast, stable, non-adjacent color set
base_colors <- c(
# Tableau 20
"#1f77b4", "#ff7f0e", "#2ca02c", "#d62728", "#9467bd",
"#8c564b", "#e377c2", "#7f7f7f", "#bcbd22", "#17becf",
"#393b79", "#637939", "#8c6d31", "#843c39", "#7b4173",
# Okabe–Ito (colorblind safe)
"#0072B2", "#D55E00", "#009E73", "#CC79A7", "#F0E442",
"#56B4E9", "#E69F00"
)
# Expand to desired size with non-adjacent modulo wrap
colors <- base_colors[(seq_len(size) %% length(base_colors)) + 1]
return(colors)
}
# Enhanced item selection with all three methods
select_item_enhanced <- function(pool, method, current_theta, existing_items = NULL,
m_top = 8, tau = 0.08, use_sympson_hetter = FALSE,
k_value = 0.5, r_value = 0.5) {
# FIX: Properly define available_pool
available_pool <- if (!is.null(existing_items) && nrow(existing_items) > 0) {
pool[!pool$id %in% existing_items$id, , drop = FALSE]
} else {
pool
}
if (nrow(available_pool) == 0) {
return(create_fallback_item(pool))
}
# Calculate information for all available items
info_values <- mapply(I_3pl, current_theta,
available_pool$a, available_pool$b, available_pool$c)
info_values[!is.finite(info_values)] <- 0
# SYMPSON-HETTER: Apply exposure control if enabled
if (use_sympson_hetter) {
# Apply exposure probabilities
selection_probs <- available_pool$exposure_prob
# Combine with information values
combined_scores <- info_values * selection_probs
if (method == 'random') {
# Weight by combined scores
idx <- sample.int(nrow(available_pool), 1, prob = combined_scores)
} else if (method == 'randomesque') {
# Get top M items by combined score
top_m <- head(order(combined_scores, decreasing = TRUE), m_top)
if (length(top_m) == 0) {
return(sample.int(nrow(available_pool), 1))
}
# Calculate selection probabilities using softmax on combined scores
top_scores <- combined_scores[top_m]
if (all(top_scores == 0)) {
probs <- rep(1/length(top_m), length(top_m))
} else {
scaled_scores <- top_scores / tau
max_score <- max(scaled_scores)
exp_scores <- exp(scaled_scores - max_score)
probs <- exp_scores / sum(exp_scores)
}
selected_idx_in_top <- sample.int(length(top_m), 1, prob = probs)
idx <- top_m[selected_idx_in_top]
} else {
# MFI: Select from items that pass exposure control
# First filter by reasonable exposure probability
reasonable_items <- available_pool[available_pool$exposure_prob >= r_value, , drop = FALSE]
if (nrow(reasonable_items) > 0) {
# Also filter by reasonable difficulty
reasonable_items <- reasonable_items[abs(reasonable_items$b - current_theta) < 2, , drop = FALSE]
}
if (nrow(reasonable_items) > 0) {
# Select from reasonable items
info_reasonable <- mapply(I_3pl, current_theta,
reasonable_items$a, reasonable_items$b, reasonable_items$c)
info_reasonable[!is.finite(info_reasonable)] <- 0
idx_in_reasonable <- which.max(info_reasonable)
# Map back to original available_pool index
idx <- which(available_pool$id == reasonable_items$id[idx_in_reasonable])
} else {
# Fallback to global maximum
idx <- which.max(combined_scores)
}
}
} else {
# Original selection logic without exposure control
if (method == 'random') {
idx <- sample.int(nrow(available_pool), 1)
} else if (method == 'randomesque') {
idx <- select_randomesque(available_pool, info_values, m_top, tau)
} else {
# FIX: Define reasonable_items properly for MFI without exposure control
reasonable_items <- available_pool[abs(available_pool$b - current_theta) < 2, , drop = FALSE]
if (nrow(reasonable_items) > 0) {
available_pool <- reasonable_items
info_values <- mapply(I_3pl, current_theta,
available_pool$a, available_pool$b, available_pool$c)
info_values[!is.finite(info_values)] <- 0
}
idx <- which.max(info_values)
}
}
# FIX: Return the selected item from available_pool
return(available_pool[idx, , drop = FALSE])
}
# Randomesque selection
select_randomesque <- function(pool, info_values, m_top = 8, tau = 0.08) {
# Get top M items by information
top_m <- head(order(info_values, decreasing = TRUE), m_top)
if (length(top_m) == 0) {
return(sample.int(nrow(pool), 1))
}
# Calculate selection probabilities using softmax
top_info <- info_values[top_m]
if (all(top_info == 0)) {
# If all information is zero, use uniform distribution
probs <- rep(1/length(top_m), length(top_m))
} else {
# Apply temperature scaling and softmax
scaled_scores <- top_info / tau
max_score <- max(scaled_scores)
exp_scores <- exp(scaled_scores - max_score) # Numerical stability
probs <- exp_scores / sum(exp_scores)
}
# Sample from top M with probabilities
selected_idx_in_top <- sample.int(length(top_m), 1, prob = probs)
return(top_m[selected_idx_in_top])
}
# Randomesque selection
select_randomesque <- function(pool, info_values, m_top = 8, tau = 0.08) {
# Get top M items by information
top_m <- head(order(info_values, decreasing = TRUE), m_top)
if (length(top_m) == 0) {
return(sample.int(nrow(pool), 1))
}
# Calculate selection probabilities using softmax
top_info <- info_values[top_m]
if (all(top_info == 0)) {
# If all information is zero, use uniform distribution
probs <- rep(1/length(top_m), length(top_m))
} else {
# Apply temperature scaling and softmax
scaled_scores <- top_info / tau
max_score <- max(scaled_scores)
exp_scores <- exp(scaled_scores - max_score) # Numerical stability
probs <- exp_scores / sum(exp_scores)
}
# Sample from top M with probabilities
selected_idx_in_top <- sample.int(length(top_m), 1, prob = probs)
return(top_m[selected_idx_in_top])
}
# Create fallback item
create_fallback_item <- function(pool) {
new_id <- max(pool$id) + 1
return(data.frame(
id = new_id,
label = paste0("i", sprintf("%03d", new_id)),
a = 1.0,
b = 0.0,
c = 0.2,
color = "#94a3b8",
stringsAsFactors = FALSE
))
}
# Calculate item usage for exposure control
calculate_item_usage <- function(available_pool, existing_items) {
if (is.null(existing_items) || nrow(existing_items) == 0) {
return(rep(0, nrow(available_pool)))
}
# Simple usage count (in real implementation, you'd track this over sessions)
usage <- sapply(available_pool$id, function(item_id) {
sum(existing_items$id == item_id)
})
return(usage)
}
# Stratified item selection
select_stratified <- function(pool, current_theta, info_values, n_strata = 3) {
# Divide items into difficulty strata
b_breaks <- quantile(pool$b, probs = seq(0, 1, length.out = n_strata + 1))
strata <- cut(pool$b, breaks = b_breaks, include.lowest = TRUE)
# Select best item from stratum closest to current theta
target_stratum <- which.min(abs(levels(strata) - current_theta))
stratum_items <- which(strata == levels(strata)[target_stratum])
if (length(stratum_items) > 0) {
best_in_stratum <- stratum_items[which.max(info_values[stratum_items])]
return(best_in_stratum)
} else {
# Fallback to global maximum
return(which.max(info_values))
}
}
generate_responses <- function(true_theta_value, items) {
# Input validation
if (is.null(true_theta_value) || !is.finite(true_theta_value)) {
stop("Invalid true_theta_value in generate_responses")
}
if (is.data.frame(items)) {
n_items <- nrow(items)
p_correct <- numeric(n_items)
for(i in 1:n_items) {
p_correct[i] <- P_3pl(true_theta_value, items$a[i], items$b[i], items$c[i])
}
} else if (is.list(items)) {
n_items <- length(items$a)
p_correct <- P_3pl(true_theta_value, items$a, items$b, items$c)
} else {
stop("items must be a data frame or list with a, b, c elements")
}
# Generate responses using proper binomial process
responses <- integer(n_items)
for(i in 1:n_items) {
# Get current item parameters
if (is.data.frame(items)) {
a_val <- items$a[i]
b_val <- items$b[i]
c_val <- items$c[i]
} else {
a_val <- items$a
b_val <- items$b
c_val <- items$c
}
# Calculate probability
p_val <- P_3pl(true_theta_value, a_val, b_val, c_val)
# Generate response
responses[i] <- as.integer(runif(1) < p_val)
}
correct_count <- sum(responses)
return(responses)
}
calculate_reliability <- function(information) {
if (is.na(information) || information <= 0)
return(0)
information / (information + 1)
}
# FAQ Panel UI Structure
faq_panel <- function() {
div(
id = "faq-panel",
style = "margin: 20px 0;",
# FAQ Item 1 - SEM Increase
faq_item(
"faq_1",
"Can SEM increase when a new item is added?",
uiOutput("faq_content_1"),
"#4A90E2"
),
# FAQ Item 2 - Responses and Information
faq_item(
"faq_2",
"Do examinee responses factor into information computation?",
uiOutput("faq_content_2"),
"#87CEEB"
),
# FAQ Item 3 - EAP Stabilization
faq_item(
"faq_3",
"Why does EAP θ̂ estimation stabilize around true theta even with random item selection?",
uiOutput("faq_content_3"),
"#9370DB"
),
# FAQ Item 4 - SEM vs Bias
faq_item(
"faq_4",
"What is the difference between SEM (precision) and bias (accuracy)?",
uiOutput("faq_content_4"),
"#32CD32"
),
# FAQ Item 5 - Bias Persistence
faq_item(
"faq_5",
"Why can bias persist even with long tests and low SEM?",
uiOutput("faq_content_5"),
"#FFA500"
),
# FAQ Item 6 - Prior Effects
faq_item(
"faq_6",
"How does the prior distribution affect EAP θ̂ estimation?",
uiOutput("faq_content_6"),
"#FF69B4"
),
# FAQ Item 7 - Pool Size
faq_item(
"faq_7",
"Does increasing the item pool size reduce bias?",
uiOutput("faq_content_7"),
"#4682B4"
),
# FAQ Item 8 - Random vs MFI
faq_item(
"faq_8",
"Why does Random (Fixed-form) stabilize while MFI (CAT) fluctuates?",
uiOutput("faq_content_8"),
"#4A90E2"
)
)
}
# ===========================================
# ---- UI DEFINITION SECTION (FULL) ----
# ===========================================
ui <- fluidPage(
shinyjs::useShinyjs(),
withMathJax(),
tags$style(
HTML(
"
:root {
/* Colors */
--primary-blue: #3498db;
--primary-red: #e74c3c;
--primary-green: #2ecc71;
--primary-orange: #f39c12;
--primary-purple: #9370DB;
/* Semantic Colors */
--success: #10b981;
--warning: #f59e0b;
--error: #ef4444;
--info: #3b82f6;
/* Grayscale */
--gray-50: #f8fafc;
--gray-100: #f1f5f9;
--gray-200: #e2e8f0;
--gray-300: #cbd5e1;
--gray-400: #94a3b8;
--gray-500: #64748b;
--gray-600: #475569;
--gray-700: #334155;
--gray-800: #1e293b;
--gray-900: #0f172a;
/* Spacing */
--space-1: 4px;
--space-2: 8px;
--space-3: 12px;
--space-4: 16px;
--space-5: 20px;
--space-6: 24px;
/* Typography */
--text-xs: 10px;
--text-sm: 12px;
--text-base: 14px;
--text-lg: 16px;
--text-xl: 18px;
/* Borders */
--radius-sm: 4px;
--radius-base: 6px;
--radius-lg: 8px;
--radius-xl: 12px;
/* Shadows */
--shadow-sm: 0 1px 3px rgba(0,0,0,0.1);
--shadow-base: 0 2px 4px rgba(0,0,0,0.1);
--shadow-md: 0 4px 8px rgba(0,0,0,0.1);
}
/* ===== BASE COMPONENTS ===== */
.compact-header {
background: white;
border-bottom: 1px solid var(--gray-200);
padding: var(--space-5) 0;
margin-bottom: 30px;
text-align: center;
}
.header-title {
font-size: 24px;
font-weight: 600;
color: var(--gray-800);
margin: 0 0 5px 0;
}
.header-subtitle {
font-size: var(--text-base);
color: var(--gray-500);
margin: 0 0 10px 0;
}
.header-meta {
font-size: var(--text-sm);
color: var(--gray-400);
}
.meta-item + .meta-divider::before {
content: \"•\";
margin: 0 var(--space-2);
}
/* ===== LAYOUT COMPONENTS ===== */
.sidebar-panel {
font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif;
}
.sb-section {
background: white;
border-radius: var(--radius-lg);
padding: var(--space-4);
margin-bottom: var(--space-4);
border: 1px solid var(--gray-200);
border-top: 3px solid var(--primary-blue);
}
.sb-section + .sb-section {
margin-top: var(--space-2);
}
.sb-head {
font-weight: 600;
color: var(--gray-800);
margin-bottom: var(--space-3);
font-size: var(--text-base);
display: flex;
align-items: center;
border-bottom: 1px solid var(--gray-100);
padding-bottom: var(--space-2);
}
.sb-icon {
margin-right: var(--space-2);
opacity: 0.7;
}
.sb-note {
font-size: 0.75em; /* 75% of parent size */
color: var(--gray-500);
margin-bottom: var(--space-3);
background: var(--gray-50);
padding: var(--space-2);
border-radius: var(--radius-sm);
border-left: 3px solid var(--gray-400);
}
/* ===== BUTTONS & CONTROLS ===== */
.btn-sm {
padding: 4px 12px !important;
font-size: var(--text-sm) !important;
margin-left: var(--space-2);
}
.button-group {
display: flex;
gap: var(--space-2);
justify-content: space-between;
margin: var(--space-3) 0;
}
.slider-group {
margin-bottom: 15px;
padding-bottom: 15px;
border-bottom: 1px solid #e5e7eb;
}
.slider-group:last-child {
border-bottom: none;
padding-bottom: 0;
}
.slider-group h5 {
margin: 0 0 var(--space-2) 0;
font-size: var(--text-sm);
font-weight: 600;
color: var(--gray-700);
}
/* ===== METRICS & CARDS ===== */
.metrics-container {
display: flex;
gap: var(--space-4);
}
.metrics-grid-expanded {
display: flex;
flex-direction: column;
gap: var(--space-2);
margin-top: var(--space-4);
}
.metric-row {
display: flex;
gap: var(--space-2);
}
.metric-cell {
flex: 1;
background: var(--gray-50);
border-radius: 10px;
padding: var(--space-2) 6px;
border: 2px solid transparent;
text-align: center;
box-shadow: var(--shadow-sm);
transition: all 0.2s ease;
}
.metric-cell:hover {
transform: translateY(-1px);
box-shadow: var(--shadow-md);
}
/* Metric color variants */
.metric-cell.true-theta { border-color: #1d4ed8; background: linear-gradient(135deg, #eff6ff, #dbeafe); }
.metric-cell.eap-theta { border-color: var(--success); background: linear-gradient(135deg, #ecfdf5, #d1fae5); }
.metric-cell.bias { border-color: var(--error); background: linear-gradient(135deg, #fef2f2, #fee2e2); }
.metric-cell.pool-size { border-color: #8b5cf6; background: linear-gradient(135deg, #faf5ff, #ede9fe); }
.metric-cell.items-used { border-color: var(--warning); background: linear-gradient(135deg, #fffbeb, #fef3c7); }
.metric-cell.reliability { border-color: #06b6d4; background: linear-gradient(135deg, #ecfeff, #cffafe); }
.metric-label {
font-size: var(--text-xs);
color: var(--gray-500);
font-weight: 600;
margin-bottom: var(--space-1);
line-height: 1.2;
text-transform: uppercase;
letter-spacing: 0.5px;
}
.metric-value {
font-size: var(--text-base);
font-weight: 700;
line-height: 1.2;
}
/* Color-coded values */
.true-theta .metric-value { color: #1d4ed8; }
.eap-theta .metric-value { color: #047857; }
.bias .metric-value { color: #dc2626; }
.pool-size .metric-value { color: #7c3aed; }
.items-used .metric-value { color: #d97706; }
.reliability .metric-value { color: #0d9488; }
/* ===== STATUS PILLS ===== */
#status-pills-container {
background: linear-gradient(135deg, var(--gray-50) 0%, var(--gray-100) 100%);
border: 1px solid var(--gray-200);
border-radius: var(--radius-lg);
padding: var(--space-3);
margin-top: var(--space-4);
}
#status-pills-container .status-pill {
display: flex !important;
flex-direction: column !important;
align-items: center !important;
gap: 2px !important;
background: white !important;
border-radius: 12px !important;
padding: 6px 10px !important;
border: 1px solid var(--gray-200) !important;
font-size: var(--text-xs) !important;
font-weight: 600 !important;
white-space: nowrap !important;
box-shadow: var(--shadow-sm) !important;
min-width: 55px !important;
}
#status-pills-container .pill-label {
color: var(--gray-500) !important;
font-weight: 600 !important;
font-size: 9px !important;
text-transform: uppercase !important;
letter-spacing: 0.3px !important;
}
#status-pills-container .pill-value {
color: var(--gray-800) !important;
font-weight: 700 !important;
font-size: 11px !important;
}
/* Status pill color variants */
#status-pills-container .true-theta-pill { border-top: 3px solid #1d4ed8 !important; }
#status-pills-container .eap-theta-pill { border-top: 3px solid #047857 !important; }
#status-pills-container .bias-pill { border-top: 3px solid #dc2626 !important; }
#status-pills-container .items-pill { border-top: 3px solid #d97706 !important; }
#status-pills-container .reliability-pill { border-top: 3px solid #0d9488 !important; }
#status-pills-container .sem-pill { border-top: 3px solid #7c3aed !important; }
/* ===== COMPACT METRICS ===== */
.metrics-grid-compact {
display: flex;
gap: var(--space-2);
justify-content: center;
flex-wrap: nowrap;
}
.metric-row-compact {
display: flex;
gap: var(--space-2);
}
.metric-cell-compact {
background: white;
border-radius: var(--radius-base);
padding: 4px 6px;
border: 1px solid var(--gray-200);
text-align: center;
min-width: 60px;
}
.metric-label-compact {
font-size: 9px;
color: var(--gray-500);
font-weight: 600;
margin-bottom: 2px;
line-height: 1;
}
.metric-value-compact {
font-size: 11px;
font-weight: 700;
line-height: 1;
}
/* ===== MODALS ===== */
.modal-dialog {
max-width: 700px;
}
.modal-body {
padding: var(--space-4);
}
.modal-header {
padding: var(--space-3) var(--space-4);
background: linear-gradient(135deg, var(--primary-blue), #1d4ed8);
color: white;
border-bottom: none;
}
.modal-title {
font-size: var(--text-lg) !important;
font-weight: 600;
}
.modal-footer {
padding: var(--space-4);
border-top: 1px solid var(--gray-200);
text-align: right;
}
.btn-primary {
background: var(--primary-blue) !important;
border: none !important;
padding: 8px 20px !important;
font-weight: 600 !important;
}
/* ===== CONTENT SECTIONS ===== */
.concepts-single-column {
max-width: 800px;
margin: 0 auto;
}
.concept-section {
background: white;
border: 1px solid var(--gray-200);
border-radius: var(--radius-lg);
padding: 25px;
margin-bottom: var(--space-5);
}
.section-header {
border-bottom: 2px solid var(--primary-blue);
padding-bottom: var(--space-3);
margin-bottom: var(--space-5);
}
.section-header h2 {
margin: 0;
color: var(--gray-800);
font-size: var(--text-lg);
}
.section-content p {
line-height: 1.6;
margin-bottom: 15px;
}
.section-content h4 {
color: var(--gray-800);
margin: 25px 0 15px 0;
font-size: var(--text-base);
border-bottom: 1px solid var(--gray-200);
padding-bottom: 5px;
}
/* ===== EDUCATIONAL ELEMENTS ===== */
.key-eq {
background: var(--gray-50);
padding: var(--space-4);
margin: 15px 0;
border-left: 4px solid var(--primary-blue);
border-radius: var(--radius-sm);
text-align: center;
overflow-x: auto;
}
.eap-eq {
background: #f0f8ff;
border-left-color: #2980b9;
}
.edu-note {
background: #e8f4fd;
border: 1px solid var(--primary-blue);
border-radius: var(--radius-base);
padding: var(--space-4);
margin: var(--space-5) 0;
}
.edu-note ul,
.parameter-item ul,
.insight-item ul,
.strategy-details ul {
margin: 10px 0;
padding-left: 20px;
}
.edu-note li,
.parameter-item li,
.insight-item li,
.strategy-details li {
margin-bottom: var(--space-2);
line-height: 1.5;
color: #5d6d7e;
}
/* ===== TABLES ===== */
.precision-table {
width: 100%;
border-collapse: collapse;
margin: 15px 0;
font-size: var(--text-base);
}
.precision-table th {
background: var(--gray-700);
color: white;
padding: 10px;
text-align: left;
font-weight: 600;
}
.precision-table td {
padding: 10px;
border-bottom: 1px solid #ecf0f1;
}
.current-standard-row {
background: #fff3cd;
font-weight: bold;
}
/* ===== WORKFLOW ===== */
.workflow-simple {
margin: var(--space-5) 0;
}
.workflow-step {
display: flex;
align-items: flex-start;
margin-bottom: 15px;
padding: var(--space-4);
background: var(--gray-50);
border-radius: var(--radius-base);
border: 1px solid var(--gray-200);
}
.step-number {
background: var(--primary-blue);
color: white;
width: 30px;
height: 30px;
border-radius: 50%;
display: flex;
align-items: center;
justify-content: center;
font-weight: bold;
margin-right: 15px;
flex-shrink: 0;
font-size: var(--text-base);
}
.step-content p {
margin: 0;
}
/* ===== STRATEGY COMPARISON ===== */
.strategy-comparison {
display: grid;
grid-template-columns: 1fr;
gap: 25px;
margin: 25px 0;
}
.strategy-card {
padding: 25px;
border-radius: var(--radius-lg);
border: 2px solid;
background: white;
}
.strategy-header {
display: flex;
justify-content: space-between;
align-items: center;
margin-bottom: 15px;
padding-bottom: 15px;
border-bottom: 1px solid var(--gray-200);
}
.strategy-header h3 {
margin: 0;
font-size: var(--text-lg);
color: var(--gray-800);
}
.strategy-description {
margin-bottom: var(--space-5);
padding: var(--space-4);
background: white;
border-radius: var(--radius-base);
border-left: 4px solid var(--primary-blue);
}
.strategy-stats {
display: flex;
gap: var(--space-5);
margin: var(--space-5) 0;
padding: var(--space-5);
background: white;
border-radius: var(--radius-base);
border: 1px solid var(--gray-200);
}
.stat {
text-align: center;
flex: 1;
}
.stat-value {
font-size: 20px;
font-weight: bold;
color: var(--gray-800);
margin-bottom: 5px;
}
.mfi-strategy .stat-value {
color: var(--success);
}
.random-strategy .stat-value {
color: var(--gray-400);
}
.stat-label {
font-size: var(--text-sm);
color: var(--gray-500);
text-transform: uppercase;
letter-spacing: 0.5px;
font-weight: 600;
}
.strategy-details {
margin-top: 15px;
}
/* ===== CODE BLOCKS ===== */
.code-block {
background: linear-gradient(135deg, #1e1e1e 0%, #2d2d2d 100%);
border: 1px solid #3e3e3e;
border-radius: var(--radius-base);
padding: var(--space-4);
margin: var(--space-3) 0;
position: relative;
box-shadow: 0 4px 12px rgba(0, 0, 0, 0.3);
}
.code-block::before {
content: '';
position: absolute;
top: 0;
left: 0;
right: 0;
height: 2px;
background: linear-gradient(90deg, #569cd6, #ce9178, #b5cea8, #dcdcaa);
border-radius: var(--radius-base) var(--radius-base) 0 0;
}
.code-block pre {
margin: 0;
white-space: pre-wrap;
word-wrap: break-word;
font-family: 'Monaco', 'Menlo', 'Ubuntu Mono', monospace;
font-size: var(--text-sm);
line-height: 1.5;
color: #d4d4d4;
}
/* Syntax Highlighting */
.code-block .keyword { color: #569cd6; font-weight: 600; }
.code-block .function { color: #dcdcaa; }
.code-block .string { color: #ce9178; }
.code-block .comment { color: #6a9955; font-style: italic; }
.code-block .number { color: #b5cea8; }
.code-block .operator { color: #d4d4d4; }
.code-block .type { color: #4ec9b0; }
.code-block .variable { color: #9cdcfe; }
.code-block .constant { color: #4fc1ff; }
/* Scrollbar Styling */
.code-block::-webkit-scrollbar {
height: 10px;
}
.code-block::-webkit-scrollbar-track {
background: #2d2d2d;
border-radius: var(--radius-sm);
margin: 0 var(--space-2);
}
.code-block::-webkit-scrollbar-thumb {
background: linear-gradient(135deg, #555 0%, #666 100%);
border-radius: var(--radius-sm);
border: 2px solid #2d2d2d;
}
.code-block::-webkit-scrollbar-thumb:hover {
background: linear-gradient(135deg, #666 0%, #777 100%);
}
/* Code Block Header */
.code-block-header {
display: flex;
justify-content: space-between;
align-items: center;
padding: var(--space-2) var(--space-3);
background: #252526;
border-bottom: 1px solid #3e3e3e;
border-radius: var(--radius-base) var(--radius-base) 0 0;
font-family: system-ui, -apple-system, sans-serif;
font-size: var(--text-xs);
color: #969696;
}
.code-block-title {
font-weight: 600;
color: #d4d4d4;
}
.code-block-copy {
background: #424242;
border: 1px solid #5a5a5a;
border-radius: var(--radius-sm);
padding: 2px 8px;
font-size: var(--text-xs);
color: #d4d4d4;
cursor: pointer;
transition: all 0.2s ease;
}
.code-block-copy:hover {
background: #4a4a4a;
border-color: #6a6a6a;
}
/* ===== ALGORITHM SECTIONS ===== */
.algorithm-section,
.stopping-section {
background: linear-gradient(135deg, var(--gray-50) 0%, var(--gray-100) 100%);
border: 1px solid var(--gray-200);
border-radius: var(--radius-base);
padding: var(--space-4);
margin-bottom: var(--space-3);
position: relative;
box-shadow: 0 2px 8px rgba(0, 0, 0, 0.05);
}
.algorithm-section::before,
.stopping-section::before {
content: '';
position: absolute;
top: 0;
left: 0;
bottom: 0;
width: 4px;
background: linear-gradient(180deg, var(--blue-500) 0%, var(--purple-500) 100%);
border-radius: var(--radius-base) 0 0 var(--radius-base);
}
.algorithm-section .sb-head,
.stopping-section .sb-head {
font-size: var(--text-sm);
font-weight: 700;
margin-bottom: var(--space-2);
color: var(--gray-900);
display: flex;
align-items: center;
gap: var(--space-2);
}
.algorithm-section .sb-head::before,
.stopping-section .sb-head::before {
font-size: var(--text-xs);
color: var(--blue-500);
}
.control-section {
padding-bottom: 2px !important;
}
.control-group {
margin-bottom: 2px;
}
.control-group h5 {
font-size: 11px;
font-weight: 600;
color: var(--gray-800);
margin-bottom: 4px;
}
/* ===== FORM CONTROLS ===== */
.numeric-input {
margin-bottom: 2px;
}
.form-group {
margin-bottom: 4px;
}
.form-control {
padding: 2px 6px;
font-size: 11px;
height: 26px;
}
.selectize-control {
margin-bottom: 2px;
}
.selectize-input {
padding: 2px 6px !important;
font-size: 11px !important;
min-height: 26px !important;
}
/* ===== CONCLUSION HIGHLIGHT ===== */
.conclusion-highlight {
background: #fff3cd;
border: 1px solid #ffc107;
border-radius: var(--radius-base);
padding: var(--space-5);
margin-top: var(--space-5);
text-align: center;
}
.conclusion-highlight p {
margin: 0;
font-style: italic;
}
/* ===== RESPONSIVE DESIGN ===== */
@media (min-width: 768px) {
.strategy-comparison {
grid-template-columns: 1fr 1fr;
}
.parameter-details, .mathematical-insights {
margin-left: 10px;
margin-right: 10px;
}
.slider-columns {
display: grid;
grid-template-columns: 1fr 1fr;
gap: var(--space-3);
}
}
@media (max-width: 768px) {
.code-tab-content {
padding: var(--space-3);
}
.algorithm-card {
margin-bottom: 16px;
border-radius: var(--radius-lg);
}
.algorithm-header {
padding: var(--space-3) var(--space-4);
font-size: var(--text-base);
}
.code-block {
padding: var(--space-4);
font-size: var(--text-sm);
}
.slider-columns,
.metrics-container,
.strategy-stats {
flex-direction: column;
gap: var(--space-2);
}
.strategy-header {
flex-direction: column;
align-items: flex-start;
gap: var(--space-3);
}
.concept-section {
padding: var(--space-5) 15px;
}
.parameter-item,
.insight-item {
padding: var(--space-3);
}
.metrics-two-columns {
grid-template-columns: 1fr;
}
}
/* ===== ANIMATIONS ===== */
@keyframes electric-pulse {
0% {
border-color: #00ffff;
box-shadow: 0 0 10px #00ffff, 0 0 20px #00ffff;
background: linear-gradient(135deg, #000428, #004e92);
}
50% {
border-color: #ff00ff;
box-shadow: 0 0 20px #ff00ff, 0 0 40px #ff00ff;
background: linear-gradient(135deg, #004e92, #8a2be2);
}
100% {
border-color: #00ffff;
box-shadow: 0 0 10px #00ffff, 0 0 20px #00ffff;
background: linear-gradient(135deg, #000428, #004e92);
}
}
.electric-pulse {
animation: electric-pulse 1.5s ease-in-out infinite;
}
")
),
# ---- Title Row ----
fluidRow(column(12, div(class = "app-title", uiOutput("dynamic_title")))),
# ---- Layout ----
div(
id = "layout-wrapper",
# Streamlined Sidebar
sidebarPanel(
width = 4,
class = "sidebar-panel",
tabsetPanel(
id = "sidebar_tabs",
type = "tabs",
# Tab 1: Test Control (Streamlined)
tabPanel(
title = tagList(icon("play-circle"), "Test Control"),
section_component(
title = "Test Administration",
icon_name = "cogs",
class = "control-section",
# Selection Strategy
section_component(
title = "Selection Strategy",
icon_name = "sliders-h",
class = "algorithm-section",
selectInput(
"sel_method",
"",
choices = c(
"Maximum Fisher Information" = "mfi",
"Randomesque" = "randomesque",
"Fixed-form (Random)" = "random"
),
selected = "mfi",
width = "100%"
),
# Randomesque Settings
conditionalPanel(
condition = "input.sel_method == 'randomesque'",
fluidRow(
column(6, numericInput("m_top", "Top M Items", value = 8, min = 2, max = 20, width = "100%")),
column(6, numericInput("tau", "Temperature", value = 0.08, min = 0.01, max = 0.5, step = 0.01, width = "100%"))
)
),
# Sympson-Hetter Settings
conditionalPanel(
condition = "input.sel_method == 'mfi' || input.sel_method == 'randomesque'",
checkboxInput("use_sympson_hetter", "Sympson-Hetter Exposure", value = FALSE),
conditionalPanel(
condition = "input.use_sympson_hetter == true && (input.sel_method == 'mfi' || input.sel_method == 'randomesque')",
fluidRow(
column(6, numericInput("k_value", "K Value", value = 0.5, min = 0.1, max = 1.0, step = 0.1, width = "100%")),
column(6, numericInput("r_value", "R Value", value = 0.5, min = 0.1, max = 1.0, step = 0.1, width = "100%"))
)
)
)
),
# Stopping Rules
section_component(
title = "Stopping Rules",
icon_name = "flag",
class = "stopping-section",
fluidRow(
column(6, numericInput("sem_target", "SEM Target", value = 0.300, min = 0.15, max = 0.50, step = 0.05, width = "100%")),
column(6, numericInput("max_items", "Max Items", value = 30, min = 10, max = 50, step = 5, width = "100%"))
),
uiOutput("sem_progress_bar")
),
# Action Buttons
div(class = "button-group-expanded",
actionButton("add_item", "Item", class = "btn-primary", icon("plus-circle"), width = "48%"),
actionButton("reset_all", "Test", class = "btn-danger", icon = icon("refresh"), width = "48%")
)
)
),
# Tab 2: Display Controls (Streamlined)
tabPanel(
title = tagList(icon("sliders-h"), "Display"),
section_component(
title = "Visualization Controls",
icon_name = "palette",
class = "display-section",
div(class = "sb-note", "Adjust layer opacity and display settings. Use opacity to focus on specific curves: decrease to fade into background, set to 0 to remove from view."),
div(class = "sb-note", "Annotation Text Size controls the size of value labels and probe indicators"),
# Single column layout
slider_component("iif_layer_alpha", "Item Information", 0.20),
slider_component("icc_layer_alpha", "ICC Curves", 0.20),
slider_component("tif_alpha", "Test Information", 0.90),
slider_component("sem_alpha", "Standard Error", 0.80),
slider_component("annotation_size", "Annotation Text Size", 1.0, 0.7, 1.7, 0.1)
)
)
)
),
# Streamlined Main Panel
mainPanel(
width = 8,
class = "mainPanel",
tabsetPanel(
id = "main_tabs",
type = "tabs",
# Visualization Tab
tabPanel(
title = tagList(icon("chart-line"), "Visualization"),
div(class = "plot-wrap", plotOutput("plot_all", height = "450px")),
uiOutput("compact_status_pills")
),
# Reference Tab
tabPanel(
title = tagList(icon("book"), "Reference"),
div(class = "reference-content",
tabsetPanel(
id = "reference_tabs",
type = "tabs",
tabPanel(
title = tagList(icon("info-circle"), "Information"),
uiOutput("reference_content")
),
# FAQ Tab
tabPanel(
title = tagList(icon("question-circle"), "FAQ"),
div(class = "faq-container", style = "padding: 20px;", faq_panel())
),
# Code Tab
tabPanel(
title = tagList(icon("code"), "Code"),
uiOutput("code_content")
),
# Pool Metrics Tab
tabPanel(
title = tagList(icon("database"), "Pool Metrics"),
fluidRow(
column(12,
section_component(
title = "Parameter Distributions",
class = "edu-card",
plotOutput("pool_plot_a", height = "400px"),
plotOutput("pool_plot_b", height = "400px"),
plotOutput("pool_plot_c", height = "400px")
)
)
),
fluidRow(
column(12,
section_component(
title = "Information & TIF Analysis",
class = "edu-card",
plotOutput("pool_plot_info0", height = "400px"),
plotOutput("pool_plot_tif", height = "400px"),
plotOutput("pool_plot_sem", height = "400px")
)
)
),
fluidRow(
column(12,
section_component(
title = "Pool Quality Metrics",
class = "edu-card",
uiOutput("pool_quality_metrics")
)
)
)
),
# Test Diagnostics Tab
tabPanel(
title = tagList(icon("chart-bar"), "Test Diagnostics"),
div(class = "reference-content", style = "padding: 16px;",
fluidRow(
column(12, section_component(
title = "Theta Estimation Progression with 95% CI",
class = "edu-card",
plotOutput("theta_progression_plot", height = "400px")
))
),
fluidRow(
column(12, section_component(
title = "Item-Person Targeting Efficiency",
class = "edu-card",
plotOutput("targeting_efficiency_plot", height = "400px")
))
),
fluidRow(
column(12, section_component(
title = "Measurement Precision and Reliability",
class = "edu-card",
plotOutput("sem_progression_plot", height = "400px")
))
),
fluidRow(
column(12, section_component(
title = "Information Growth & Efficiency",
class = "edu-card",
plotOutput("information_growth_plot", height = "400px")
))
),
fluidRow(
column(12, section_component(
title = "Bias & Standardized Bias Analysis",
class = "edu-card",
plotOutput("bias_analysis_plot", height = "400px")
))
),
fluidRow(
column(12, section_component(
title = "Item Selection Pattern",
class = "edu-card",
plotOutput("item_selection_plot", height = "400px")
))
),
fluidRow(
column(12, section_component(
title = "Current Test Performance Summary",
class = "edu-card",
uiOutput("current_test_metrics")
))
)
)
)
)
)
)
)
),
# Summary Table Container
uiOutput("summary_table_container")
) # Close fluidPage
) # Close ui assignment
# ===========================================
# ---- SERVER LOGIC SECTION ----
# ===========================================
server <- function(input, output, session) {
# --- State ----------------------------------------------------------
initial_modal_completed <- reactiveVal(FALSE)
bias_alert_shown <- reactiveVal(FALSE)
bias_history <- reactiveVal(numeric(0))
items <- reactiveVal()
responses <- reactiveVal()
target_met <- reactiveVal(FALSE)
final_sem_value <- reactiveVal(NA_real_)
true_theta <- reactiveVal(rnorm(1, 0, 1))
item_pool <- reactiveVal()
color_palette <- reactiveVal()
app_initialized <- reactiveVal(FALSE)
current_sem <- reactive({
cm <- cumulative_metrics_cache()
if (is.null(cm) || length(cm) == 0) return(NA_real_)
tail(cm, 1)[[1]]$sem
})
current_items <- reactive({
ib <- items()
if (is.null(ib)) return(0)
nrow(ib)
})
eap_score <- reactive({
eap_theta()
})
verify_tif_curve <- function() {
ib <- items()
curves <- per_item_curves()
if (is.null(ib) || nrow(ib) == 0 || is.null(curves)) return()
# Method 1: Direct calculation at each theta point
theta_grid <- .THETA_GRID
manual_tif <- numeric(length(theta_grid))
for(i in 1:length(theta_grid)) {
total_info <- 0
for(j in 1:nrow(ib)) {
item_info <- I_3pl(theta_grid[i], ib$a[j], ib$b[j], ib$c[j])
if(is.finite(item_info)) {
total_info <- total_info + item_info
}
}
manual_tif[i] <- total_info
}
# Method 2: Current stored TIF curve
stored_tif <- tif_curve()
# Check differences
if (length(manual_tif) == length(stored_tif)) {
max_diff <- max(abs(manual_tif - stored_tif), na.rm = TRUE)
mean_diff <- mean(abs(manual_tif - stored_tif), na.rm = TRUE)
}
# Also verify current theta point - FIXED: Use proper variable access
th0 <- eap_theta()
curve_tif_at_theta <- approx(theta_grid, stored_tif, xout = th0, rule = 2)$y
# Get calculated TIF from cache to ensure consistency with table
cm <- cumulative_metrics_cache()
if (!is.null(cm) && length(cm) > 0) {
current_metrics <- cm[[length(cm)]]
calculated_tif_at_theta <- current_metrics$tif
} else {
calculated_tif_at_theta <- calculate_tif_at_theta(th0, ib)
}
}
# Consistent IIF calculation at specific theta
calculate_iif_at_theta <- function(theta, items_df) {
sapply(1:nrow(items_df), function(i) {
I_3pl(theta, items_df$a[i], items_df$b[i], items_df$c[i])
})
}
# Consistent TIF calculation at specific theta
calculate_tif_at_theta <- function(theta, items_df) {
iif_vals <- calculate_iif_at_theta(theta, items_df)
sum(iif_vals, na.rm = TRUE)
}
# Consistent SEM calculation at specific theta
calculate_sem_at_theta <- function(theta, items_df) {
tif_val <- calculate_tif_at_theta(theta, items_df)
if (tif_val > 0) 1 / sqrt(tif_val) else NA_real_
}
# ===========================================
# FIXED MODAL HELPER FUNCTIONS
# ===========================================
create_modal <- function(title, content, footer = NULL, size = "m", easyClose = FALSE, fade = TRUE) {
modalDialog(
title = title,
content = content,
footer = footer,
size = size,
easyClose = easyClose,
fade = fade
)
}
# ===========================================
# FIXED SUCCESS MODAL FUNCTION
# ===========================================
create_success_modal <- function(title, message, metrics_content = NULL, action_buttons = NULL) {
# Build the content properly
if (!is.null(metrics_content)) {
base_content <- tagList(
div(style = "text-align: center; margin-bottom: 20px;",
h4(title, style = "color: #059669; margin-bottom: 10px;"),
p(style = "font-size: 18px; font-weight: bold;", message)
),
metrics_content # Include metrics_content directly
)
} else {
base_content <- tagList(
div(style = "text-align: center; margin-bottom: 20px;",
h4(title, style = "color: #059669; margin-bottom: 10px;"),
p(style = "font-size: 18px; font-weight: bold;", message)
)
)
}
# Footer buttons
footer <- if (!is.null(action_buttons)) {
action_buttons
} else {
tagList(
actionButton("modal_continue", "Continue", class = "btn-success"),
modalButton("Close")
)
}
create_modal(
title = tagList(icon("check-circle"), title),
content = base_content,
footer = footer
)
}
# Caches
per_item_curves <- reactiveVal(list())
tif_curve <- reactiveVal(rep(0, length(.THETA_GRID)))
cumulative_metrics_cache <- reactiveVal(NULL)
# === MODAL HANDLING ===
initial_modal_shown <- reactiveVal(FALSE)
# Helper function to show initial modal
show_initial_modal <- function() {
req(items())
first_item <- items()[1, ]
true_theta_val <- true_theta()
eap_theta_val <- eap_theta()
# Calculate probability of correct response
p_correct <- P_3pl(true_theta_val, first_item$a, first_item$b, first_item$c)
showModal(modalDialog(
title = NULL,
easyClose = FALSE,
fade = TRUE,
footer = actionButton(
"begin_test",
label = tagList(
icon("play-circle", style = "margin-right: 6px;"),
"BEGIN ASSESSMENT"
),
style = "background: linear-gradient(135deg, #0066cc, #004499); color: white; font-weight: bold; padding: 6px 12px; border-radius: 6px; border: none; box-shadow: 0 2px 4px rgba(0, 102, 204, 0.3);"
),
size = "l", # Changed back to large since xl might not be working
style = "max-width: 800px;", # ADD CUSTOM WIDTH
tagList(
div(
style = "text-align: center; padding: 0;",
# Header section
div(
style = "background: linear-gradient(135deg, #0066cc, #004499); color: white; padding: 12px; border-radius: 6px; margin-bottom: 10px; text-align: center;",
h4(
style = "margin: 0; font-weight: 700; font-size: 16px;",
"Test Simulation Initialized"
)
),
# Test Parameters - COMPACT VERSION
div(
style = "background: #f8f9fa; padding: 10px; border-radius: 6px; margin-bottom: 10px; border: 1px solid #e9ecef;",
div(
style = "text-align: center; margin-bottom: 6px;",
span(style = "font-size: 13px; color: #495057; font-weight: 600; text-transform: uppercase; letter-spacing: 0.5px;",
"Test Parameters")
),
div(
style = "text-align: center; margin-bottom: 6px; display: flex; justify-content: center; align-items: center; gap: 8px; flex-wrap: nowrap;", # CHANGED TO FLEX
span(style = "font-size: 12px; color: #6c757d; white-space: nowrap;", "• Item Pool:"),
span(sprintf("%d items", pool_size), style = "color: #0066cc; font-weight: 700; font-size: 11px; background: #e6f3ff; padding: 2px 6px; border-radius: 8px; white-space: nowrap;"),
span(style = "font-size: 12px; color: #6c757d; white-space: nowrap;", "• Target SEM:"),
span("≤0.30", style = "color: #dc3545; font-weight: 700; font-size: 11px; background: #ffe6e6; padding: 2px 6px; border-radius: 8px; border: 1px solid #ffcccc; white-space: nowrap;"),
span(style = "font-size: 12px; color: #6c757d; white-space: nowrap;", "• Method:"),
span(
if (input$sel_method == "mfi") {
"MFI"
} else if (input$sel_method == "randomesque") {
"Randomesque"
} else {
"Fixed-form"
},
style = "color: #0066cc; font-weight: 700; font-size: 11px; background: #e6f3ff; padding: 2px 6px; border-radius: 8px; white-space: nowrap;"
)
)
),
# Person Parameters
div(
style = "background: #f0f8ff; padding: 10px; border-radius: 6px; margin-bottom: 10px; border: 1px solid #d1e7ff;",
div(
style = "text-align: center; margin-bottom: 6px;",
span(style = "font-size: 13px; color: #0066cc; font-weight: 600; text-transform: uppercase; letter-spacing: 0.5px;",
"Person Parameters")
),
div(
style = "text-align: center;",
span(style = "font-size: 12px; color: #0066cc;", "• True θ:"),
span(sprintf(" %.2f", true_theta_val), style = "color: #004499; font-weight: 700; font-size: 12px; background: white; padding: 2px 8px; border-radius: 10px; margin-left: 4px; margin-right: 8px;"),
span(style = "font-size: 12px; color: #0066cc;", "• P(θ):"),
span(sprintf(" %.2f", p_correct), style = "color: #e67e22; font-weight: 700; font-size: 12px; background: #fff5e6; padding: 2px 8px; border-radius: 10px; margin-left: 4px; margin-right: 8px; border: 1px solid #ffd9b3;"),
span(style = "font-size: 12px; color: #0066cc;", "• Response:"),
span(
sprintf(" %s", ifelse(length(responses()) >= 1 && responses()[1] == 1, "Correct", "Incorrect")),
style = sprintf(
"color: %s; font-weight: 700; font-size: 12px; background: %s; padding: 2px 8px; border-radius: 10px; margin-left: 4px; border: 1px solid %s;",
ifelse(length(responses()) >= 1 && responses()[1] == 1, "#1e7e34", "#dc3545"),
ifelse(length(responses()) >= 1 && responses()[1] == 1, "#e6f4ea", "#ffe6e6"),
ifelse(length(responses()) >= 1 && responses()[1] == 1, "#a3d7b5", "#f5b7b1")
)
)
)
),
# Item Parameters
div(
style = "background: #fffaf0; padding: 10px; border-radius: 6px; margin-bottom: 10px; border: 1px solid #ffeeba;",
div(
style = "text-align: center; margin-bottom: 6px;",
span(style = "font-size: 13px; color: #e67e22; font-weight: 600; text-transform: uppercase; letter-spacing: 0.5px;",
"First Item Administered")
),
div(
style = "text-align: center;",
span(style = "font-size: 12px; color: #e67e22;", "• Item #:"),
span(first_item$label, style = "color: #cc6600; font-weight: 700; font-size: 12px; background: white; padding: 2px 8px; border-radius: 10px; margin-left: 4px; margin-right: 12px;"),
span(style = "font-size: 12px; color: #e67e22;", "• Parameters:"),
span(sprintf("a=%.2f", first_item$a), style = "color: #0066cc; font-weight: 700; font-size: 11px; background: #e6f3ff; padding: 2px 6px; border-radius: 8px; margin-left: 2px;"),
span(" | ", style = "font-size: 11px; color: #e67e22; font-weight: bold;"),
span(sprintf("b=%.2f", first_item$b), style = "color: #1e7e34; font-weight: 700; font-size: 11px; background: #e6f4ea; padding: 2px 6px; border-radius: 8px; margin-left: 2px;"),
span(" | ", style = "font-size: 11px; color: #e67e22; font-weight: bold;"),
span(sprintf("c=%.2f", first_item$c), style = "color: #dc3545; font-weight: 700; font-size: 11px; background: #ffe6e6; padding: 2px 6px; border-radius: 8px; margin-left: 2px;")
)
),
# Selection strategy
div(
style = "background: #f0f9f0; padding: 10px; border-radius: 6px; margin-bottom: 6px; border: 1px solid #c8e6c9;",
div(
style = "text-align: center; margin-bottom: 6px;",
h5("First Item Selection Strategy", style = "color: #1e7e34; margin: 0; font-size: 13px; font-weight: 600; text-transform: uppercase; letter-spacing: 0.5px;")
),
div(
style = "text-align: left;",
div(style = "margin: 4px 0; font-size: 12px; display: flex; align-items: center;",
span("• Medium difficulty item for initial ability estimate", style = "color: #1e7e34;"),
span(sprintf(" (b=%.2f)", first_item$b), style = "color: #1e7e34; font-weight: 600; font-style: italic; margin-left: 4px;")
),
div(style = "margin: 4px 0; font-size: 12px; display: flex; align-items: center;",
span("• High discrimination item for maximum information", style = "color: #1e7e34;"),
span(sprintf(" (a=%.2f)", first_item$a), style = "color: #1e7e34; font-weight: 600; font-style: italic; margin-left: 4px;")
)
)
)
)
)
))
}
# Show modal on app startup
observe({
req(items())
if (nrow(items()) == 1 && !initial_modal_shown()) {
initial_modal_shown(TRUE)
delay(500, {
show_initial_modal()
})
}
})
# --- Consolidated BEGIN TEST handler ---
observeEvent(input$begin_test, {
# Remove the modal (if present)
removeModal()
# Mark that initial modal was completed for this session
initial_modal_completed(TRUE)
# Reset bias alert state for the new test so stabilization can be detected anew
bias_alert_shown(FALSE)
# Remove any stray custom notification then add the electric-pulse notification
removeUI(selector = "#custom-notification", immediate = TRUE)
insertUI(
selector = "head",
where = "beforeEnd",
ui = tags$style(HTML("
@keyframes electric-pulse {
0% {
border-color: #00ffff;
box-shadow: 0 0 10px #00ffff, 0 0 20px #00ffff;
background: linear-gradient(135deg, #000428, #004e92);
}
50% {
border-color: #ff00ff;
box-shadow: 0 0 20px #ff00ff, 0 0 40px #ff00ff;
background: linear-gradient(135deg, #004e92, #8a2be2);
}
100% {
border-color: #00ffff;
box-shadow: 0 0 10px #00ffff, 0 0 20px #00ffff;
background: linear-gradient(135deg, #000428, #004e92);
}
}
.electric-pulse {
animation: electric-pulse 1.5s ease-in-out infinite;
}
"))
)
insertUI(
selector = "body",
where = "beforeEnd",
ui = div(id = "custom-notification",
style = "position: fixed; bottom: 100px; left: 50px;
z-index: 9999; color: #1a1a1a; padding: 16px 20px;
border-radius: 8px; background: rgba(255, 255, 255, 0.95);
border: 2px solid #e67e22; font-size: 14px; font-weight: 700;
box-shadow: 0 4px 12px rgba(230, 126, 34, 0.3);
min-width: 300px; max-width: 400px; backdrop-filter: blur(5px);",
div(style = "line-height: 1.4;",
div(style = "font-weight: bold; margin-bottom: 4px; font-size: 15px; color: #e67e22;",
"Adaptive Testing Started"),
div(style = "margin-bottom: 4px; color: #2c3e50;",
"First item has been administered"),
div(style = "font-style: italic; color: #7f8c8d;",
"Click 'Next Item' to continue assessment")
)
)
)
shinyjs::delay(3000, {
removeUI(selector = "#custom-notification")
removeUI(selector = "style", immediate = TRUE)
})
})
# --- Bias Detection After SEM Target Met ---
observe({
tryCatch({
# Only check if test is active, no alert shown yet, AND SEM target is met
if (!initial_modal_completed() || bias_alert_shown() || !target_met()) return()
bh <- bias_history()
if (length(bh) < 3) return()
# Check if last 3 bias values are stable
last_three <- tail(bh, 3)
range_diff <- diff(range(last_three))
if (range_diff <= 0.01) {
bias_alert_shown(TRUE)
# Calculate indices for display
indices <- (length(bh)-2):length(bh)
current_sem <- final_sem_value() # Use the final_sem_value reactive
showModal(modalDialog(
title = tagList(icon("bullseye"), "Bias Stabilization Pattern Detected"),
easyClose = FALSE,
fade = TRUE,
size = "l",
tagList(
div(style = "text-align: center;",
# Combined success header and main content
div(style = "background: linear-gradient(135deg, #ecfdf5, #d1fae5); padding: 12px; border-radius: 12px; margin-bottom: 12px; border: 2px solid #a7f3d0; box-shadow: 0 4px 12px rgba(5, 150, 105, 0.15);",
h4("SEM target achieved AND bias has stabilized", style = "color: #065f46; margin: 0 0 12px 0; font-size: 16px; font-weight: 700; text-align: center;"),
div(style = "background: white; padding: 12px; border-radius: 8px; border: 1px solid #e5e7eb; box-shadow: 0 2px 8px rgba(0,0,0,0.06);",
div(style = "display: flex; align-items: center; gap: 10px; margin-bottom: 12px;",
div(style = "width: 16px; height: 16px; background: linear-gradient(135deg, #10b981, #059669); border-radius: 50%;"),
p(style = "margin: 0; font-size: 14px; color: #374151; font-weight: 700;", "Three consecutive bias estimates are tightly clustered:")
),
# Content grid - All boxes on same line
div(style = "display: flex; gap: 12px; justify-content: space-between;",
# Bias values
lapply(seq_along(last_three), function(i) {
div(style = "flex: 1; text-align: center;",
div(style = "background: linear-gradient(135deg, #f8fafc, #f1f5f9); padding: 8px 6px; border-radius: 10px; border: 1px solid #e2e8f0; box-shadow: 0 2px 6px rgba(0,0,0,0.05);",
p(style = "margin: 0 0 4px 0; font-size: 11px; color: #64748b; font-weight: 600;", paste("Step", indices[i])),
p(style = "margin: 0; font-size: 14px; font-family: 'Monaco', 'Menlo', monospace; color: #1e293b; font-weight: 700;",
sprintf("%+.3f", last_three[i]))
)
)
}),
# Mean - Same size as step boxes
div(style = "flex: 1; text-align: center;",
div(style = "background: linear-gradient(135deg, #f0fdf4, #dcfce7); padding: 8px 6px; border-radius: 10px; border: 1px solid #bbf7d0; box-shadow: 0 2px 6px rgba(0,0,0,0.05);",
p(style = "margin: 0 0 4px 0; font-size: 11px; color: #059669; font-weight: 600;", "Mean"),
p(style = "margin: 0; font-size: 14px; font-family: 'Monaco', 'Menlo', monospace; color: #065f46; font-weight: 700;",
sprintf("%+.3f", mean(last_three)))
)
),
# Range - Same size as step boxes
div(style = "flex: 1; text-align: center;",
div(style = "background: linear-gradient(135deg, #fffbeb, #fef3c7); padding: 8px 6px; border-radius: 10px; border: 1px solid #fde68a; box-shadow: 0 2px 6px rgba(0,0,0,0.05);",
p(style = "margin: 0 0 4px 0; font-size: 11px; color: #d97706; font-weight: 600;", "Range"),
p(style = "margin: 0; font-size: 14px; font-family: 'Monaco', 'Menlo', monospace; color: #92400e; font-weight: 700;",
sprintf("%.3f", range_diff))
)
)
)
)
),
# Interpretation - Paragraph format
div(style = "background: linear-gradient(135deg, #f0fdf4, #dcfce7); padding: 12px 16px; border-radius: 12px; border: 2px solid #a7f3d0; margin: 12px 0; box-shadow: 0 4px 12px rgba(5, 150, 105, 0.1); text-align: left;",
p(style = "margin: 0 0 6px 0; font-size: 14px; color: #065f46; font-weight: 700;", "Interpretation:"),
p(style = "margin: 0; font-size: 12px; color: #047857; line-height: 1.5;",
"Measurement precision target has been achieved and bias has stabilized around a consistent value, indicating that EAP θ̂ estimation is converging reliably and measurement precision may be optimal.")
)
)
),
footer = tagList(
actionButton("dismiss_bias_alert", "Continue Test", class = "btn-primary",
style = "background: linear-gradient(135deg, #10b981, #059669); border: none; padding: 10px 24px; font-size: 14px; font-weight: 600; border-radius: 8px; box-shadow: 0 2px 8px rgba(5, 150, 105, 0.3);")
)
))
}
}, error = function(e) {
message("Bias observer error: ", e$message)
bias_alert_shown(FALSE) # Reset on error to prevent infinite loop
})
})
# Simple dismiss
observeEvent(input$dismiss_bias_alert, {
removeModal()
})
# ------------------------------
# Consolidated Reset Handler
observeEvent(input$reset_all, {
# FIRST: Close ALL modals and remove any UI elements
tryCatch({
removeModal()
removeUI(selector = ".modal-backdrop", immediate = TRUE)
removeUI(selector = ".modal", immediate = TRUE)
removeUI(selector = "#custom-notification", immediate = TRUE)
removeUI(selector = "#electric-pulse-style", immediate = TRUE)
# Force remove any lingering modal backdrops via JS
runjs("$('.modal-backdrop').remove();")
runjs("$('body').removeClass('modal-open');")
}, error = function(e) {
message("UI cleanup during reset: ", e$message)
})
# Reset ALL flags and reactive values
initial_modal_shown(FALSE)
initial_modal_completed(FALSE)
bias_alert_shown(FALSE) # ← CRITICAL: Reset bias alert state
bias_history(numeric(0))
# Reset other reactive values to clean state
items(NULL)
responses(integer(0))
target_met(FALSE)
final_sem_value(NA_real_)
true_theta(rnorm(1, 0, 1)) # New true theta for the new test
per_item_curves(list())
tif_curve(rep(0, length(.THETA_GRID)))
cumulative_metrics_cache(NULL)
app_initialized(FALSE) # Reset flag
# Force UI refresh with delay to ensure clean state
delay(200, {
tryCatch({
# Re-initialize pool and colors
if (!exists("pool_size")) pool_size <- 100
pool <- create_item_pool(pool_size)
item_pool(pool)
palette <- generate_stable_colors(pool_size)
if (is.null(pool) || nrow(pool) == 0) {
stop("create_item_pool returned an empty pool")
}
# PROPERLY SELECT AND ADMINISTER INITIAL ITEM
near_zero_threshold <- 0.1
near_zero_items <- pool[abs(pool$b) < near_zero_threshold, , drop = FALSE]
if (nrow(near_zero_items) > 0) {
selected_index <- which.max(near_zero_items$a)
best_initial_item <- near_zero_items[selected_index, , drop = FALSE]
selection_reason <- "highest discrimination among medium-difficulty items"
} else {
best_initial_item <- pool[which.min(abs(pool$b - 0)), , drop = FALSE]
selection_reason <- "closest to medium difficulty (fallback)"
}
# Assign color
best_initial_item$color <- if (!is.null(palette) && best_initial_item$id <= length(palette)) {
palette[best_initial_item$id]
} else {
"#94a3b8" # Default gray color
}
# GENERATE RESPONSE FOR THE INITIAL ITEM
first_response <- generate_responses(true_theta(), best_initial_item)
# Verify the response makes sense
p_correct_first <- P_3pl(true_theta(), best_initial_item$a, best_initial_item$b, best_initial_item$c)
# === CRITICAL FIX: SET CURVES BEFORE ITEMS ===
# CALCULATE CURVES FOR PLOTTING (ENSURES VALID DATA)
df <- tibble(
theta = .THETA_GRID,
P = P_3pl(.THETA_GRID, best_initial_item$a, best_initial_item$b, best_initial_item$c),
I = I_3pl(.THETA_GRID, best_initial_item$a, best_initial_item$b, best_initial_item$c)
)
# Initialize curves with valid data - DO THIS BEFORE SETTING ITEMS
per_item_curves(list(setNames(list(df), best_initial_item$label)))
tif_curve(df$I)
# NOW set items and responses (plot data is ready first)
items(best_initial_item)
responses(first_response)
# Show initial modal again for the new test
delay(300, {
if (!initial_modal_shown()) {
initial_modal_shown(TRUE)
show_initial_modal()
}
})
app_initialized(TRUE) # Set flag when done
}, error = function(e) {
message("Error during reset initialization: ", e$message)
# Emergency fallback - create minimal valid state
emergency_item <- data.frame(
id = 1, label = "Emergency", a = 1.0, b = 0.0, c = 0.2,
color = "#94a3b8", stringsAsFactors = FALSE
)
# Emergency curves FIRST
emergency_df <- tibble(
theta = .THETA_GRID,
P = P_3pl(.THETA_GRID, 1.0, 0.0, 0.2),
I = I_3pl(.THETA_GRID, 1.0, 0.0, 0.2)
)
per_item_curves(list(setNames(list(emergency_df), "Emergency")))
tif_curve(emergency_df$I)
# THEN set emergency items
items(emergency_item)
responses(0)
})
})
})
# Authoritative EAP θ̂
eap_theta <- reactive({
ib <- items()
resp <- responses()
if (is.null(ib) || nrow(ib) == 0)
return(0)
estimate_theta_eap(ib, resp)
})
# ------------------------------
# Session end cleanup (good practice)
session$onSessionEnded(function() {
# remove any custom UI
try(removeUI(selector = "#custom-notification", immediate = TRUE), silent = TRUE)
try(removeModal(), silent = TRUE) # Ensure any open modals are closed
})
# ---- Initialization (Random selection from items with b near 0) ----
observe({
pool <- create_item_pool(pool_size)
item_pool(pool)
palette <- generate_stable_colors(pool_size)
color_palette(palette)
# This code implements an initial item selection strategy for adaptive testing
# by choosing a starting item of average difficulty to begin the assessment
# process. It first identifies all items in the pool with difficulty parameters
# near zero (within ±0.1 logits), representing medium-difficulty questions,
# and if such items exist, it selects the one with the highest discrimination
# parameter to provide maximum information at the start. If no near-zero items
# are available, the fallback strategy selects the single item whose difficulty
# parameter is closest to zero, ensuring the test always begins with the most
# appropriate difficulty level regardless of item pool constraints. This approach
# optimally initiates the adaptive testing sequence by starting with medium-
# difficulty content that provides maximum information about an unknown examinee's
# ability level before subsequent items are adaptively selected based on emerging
# performance patterns.
# identify items with difficulty parameters near zero (within ±0.1 logits)
near_zero_threshold <- 0.1
near_zero_items <- pool[abs(pool$b) < near_zero_threshold, ]
if (nrow(near_zero_items) > 0) {
# Select the item with the highest discrimination parameter (a)
selected_index <- which.max(near_zero_items$a)
best_initial_item <- near_zero_items[selected_index, , drop = FALSE]
selection_reason <- "selected for maximum information at average ability (highest discrimination among medium-difficulty items)"
} else {
# Fallback: select item closest to zero difficulty
best_initial_item <- pool[which.min(abs(pool$b - 0)), , drop = FALSE]
selection_reason <- "selected as closest to medium difficulty (fallback when no ideal items available)"
}
best_initial_item$color <- palette[best_initial_item$id]
# Generate response for the first item
first_response <- generate_responses(true_theta(), best_initial_item)
# Set items and responses
items(best_initial_item)
responses(first_response)
# Calculate curves for plotting
df <- tibble(
theta = .THETA_GRID,
P = P_3pl(
.THETA_GRID,
best_initial_item$a,
best_initial_item$b,
best_initial_item$c
),
I = I_3pl(
.THETA_GRID,
best_initial_item$a,
best_initial_item$b,
best_initial_item$c
)
)
lst <- list()
lst[[best_initial_item$label]] <- df
per_item_curves(lst)
tif_curve(df$I)
# Mark app as initialized
app_initialized(TRUE)
})
# ===== ADD OUTPUT RENDERERS =====
output$compact_status_pills <- renderUI({
ib <- items()
n_items <- if (is.null(ib)) 0 else nrow(ib)
th_hat <- eap_theta()
true_th <- true_theta()
pool <- item_pool()
pool_size_current <- if (!is.null(pool)) nrow(pool) else pool_size
# Calculate current metrics
tif <- 0
if (n_items > 0) {
iif_vals <- sapply(1:n_items, function(i) {
I_3pl(th_hat, ib$a[i], ib$b[i], ib$c[i])
})
iif_vals[!is.finite(iif_vals)] <- 0
tif <- sum(iif_vals)
}
sem <- if (tif > 0) 1 / sqrt(tif) else NA_real_
rho <- if (tif > 0) tif / (tif + 1) else 0
bias <- th_hat - true_th
# Minimal container with bottom margin for spacing
div(
style = "display: flex; justify-content: center; align-items: center; gap: 12px; flex-wrap: nowrap; padding: 8px 0; width: 100%;",
# True Theta
div(style = "display: inline-flex; align-items: center; gap: 4px; background: white; border-radius: 6px; padding: 4px 8px; border: 1px solid #e2e8f0;",
span(style = "color: #64748b; font-weight: 600; font-size: 7px;", "True θ:"),
span(style = "color: #1e293b; font-weight: 700; font-size: 7px;", sprintf("%.2f", true_th))
),
# EAP Theta
div(style = "display: inline-flex; align-items: center; gap: 4px; background: white; border-radius: 6px; padding: 4px 8px; border: 1px solid #e2e8f0;",
span(style = "color: #64748b; font-weight: 600; font-size: 7px;", "EAP θ:"),
span(style = "color: #1e293b; font-weight: 700; font-size: 7px;", sprintf("%.2f", th_hat))
),
# Bias
div(style = "display: inline-flex; align-items: center; gap: 4px; background: white; border-radius: 6px; padding: 4px 8px; border: 1px solid #e2e8f0;",
span(style = "color: #64748b; font-weight: 600; font-size: 7px;", "Bias:"),
span(style = "color: #1e293b; font-weight: 700; font-size: 7px;", sprintf("%+.2f", bias))
),
# Items Used
div(style = "display: inline-flex; align-items: center; gap: 4px; background: white; border-radius: 6px; padding: 4px 8px; border: 1px solid #e2e8f0;",
span(style = "color: #64748b; font-weight: 600; font-size: 7px;", "Items:"),
span(style = "color: #1e293b; font-weight: 700; font-size: 7px;", sprintf("%d/%d", n_items, pool_size_current))
),
# Reliability
div(style = "display: inline-flex; align-items: center; gap: 4px; background: white; border-radius: 6px; padding: 4px 8px; border: 1px solid #e2e8f0;",
span(style = "color: #64748b; font-weight: 600; font-size: 7px;", "Rel:"),
span(style = "color: #1e293b; font-weight: 700; font-size: 7px;", if (is.finite(rho)) sprintf("%.2f", rho) else "0.00")
),
# SEM
div(style = "display: inline-flex; align-items: center; gap: 4px; background: white; border-radius: 6px; padding: 4px 8px; border: 1px solid #e2e8f0;",
span(style = "color: #64748b; font-weight: 600; font-size: 7px;", "SEM:"),
span(style = "color: #1e293b; font-weight: 700; font-size: 7px;", if (is.finite(sem)) sprintf("%.3f", sem) else "—")
)
)
})
output$sem_progress_bar <- renderUI({
# Get current SEM using your existing calculation
ib <- items()
n_items <- if (is.null(ib)) 0 else nrow(ib)
th_hat <- eap_theta()
# Calculate current SEM (same as in your status pills)
tif <- 0
if (n_items > 0) {
iif_vals <- sapply(1:n_items, function(i) {
I_3pl(th_hat, ib$a[i], ib$b[i], ib$c[i])
})
iif_vals[!is.finite(iif_vals)] <- 0
tif <- sum(iif_vals)
}
current_sem <- if (tif > 0) 1 / sqrt(tif) else NA
sem_target <- if (!is.null(input$sem_target)) input$sem_target else 0.30
# Handle missing SEM
if (is.na(current_sem)) {
return(
div(
class = "sem-progress-wrapper",
style = "margin-bottom: 10px;",
div(
class = "progress-bar",
style = "width: 100%; height: 16px; background: #f1f5f9; border-radius: 8px; overflow: hidden; position: relative; border: 1px solid #e2e8f0;",
div(style = "width: 0%; height: 100%; background: #94a3b8;"),
div(
style = "position: absolute; top: 50%; left: 50%; transform: translate(-50%, -50%); color: #64748b; font-weight: 600; font-size: 10px;",
"SEM: —"
)
)
)
)
} # <-- THIS CLOSING BRACE WAS MISSING
# Calculate progress (0-100%)
max_sem <- 0.8 # Worst-case SEM
if (current_sem <= sem_target) {
progress_pct <- 100
color <- "#10b981" # Green - target met
} else {
progress_pct <- max(0, (max_sem - current_sem) / (max_sem - sem_target) * 100)
color <- "#3b82f6" # Blue - in progress
}
# Create formatted text for display
sem_text <- sprintf("SEM: %.3f / %.3f", current_sem, sem_target)
# Create progress bar
div(
class = "sem-progress-wrapper",
style = "margin-bottom: 10px;",
div(
class = "progress-bar",
style = "margin-bottom: 10px; width: 100%; height: 40px; background: #f1f5f9; border-radius: 8px; overflow: hidden; position: relative; border: 1px solid #e2e8f0;",
# Progress fill
div(
style = paste0(
"width: ", round(progress_pct, 1), "%; ",
"height: 100%; ",
"background: ", color, "; ",
"transition: width 0.3s ease;"
)
),
# Text overlay - FORCE SINGLE LINE
div(
style = "position: absolute; top: 50%; left: 50%; transform: translate(-50%, -50%);
color: #1e293b; font-weight: 600; font-size: 10px;
white-space: nowrap; overflow: hidden; text-overflow: clip;",
sem_text
)
)
)
})
output$sem_header_display <- renderText({
req(current_sem())
sprintf("SEM = %.3f (Target: ≤ 0.300) | EAP Score, θ̂ = %.2f | True θ = %.2f)",
current_sem(), eap_score(), true_theta())
})
output$ci_display <- renderText({
req(current_sem())
sprintf(" ±%.2f logits", 1.96 * current_sem())
})
output$reliability_display <- renderText({
req(current_sem())
sprintf(" %.1f%%", (1 - current_sem()^2) * 100)
})
output$efficiency_header_display <- renderText({
if (input$sel_method == "random") {
"Fixed-form Test Length:"
} else {
"Efficiency Gain vs Fixed-form:"
}
})
output$items_used_display <- renderText({
req(current_items())
sprintf(" %d", current_items())
})
output$fixed_form_display <- renderText({
req(current_items())
if (input$sel_method == "random") {
sprintf(" %d items", current_items())
} else {
typical_fixed <- max(20, round(current_items() * 2.5))
sprintf(" %d+ items", typical_fixed)
}
})
output$items_saved_display <- renderText({
req(current_items())
if (input$sel_method == "random") {
" — "
} else {
fixed_form <- max(20, round(current_items() * 2.5))
saved <- fixed_form - current_items()
reduction <- round((saved / fixed_form) * 100)
sprintf(" %d+ items (%d%%)", saved, reduction)
}
})
output$confidence_interpretation_inline <- renderText({
req(current_sem(), eap_score())
ci_width <- 1.96 * current_sem()
lower_bound <- eap_score() - ci_width
upper_bound <- eap_score() + ci_width
true_theta_val <- true_theta()
bias <- eap_score() - true_theta_val
abs_bias <- abs(bias)
true_in_ci <- true_theta_val >= lower_bound & true_theta_val <= upper_bound
# Method context - simplified
method_text <- if (input$sel_method == "mfi") {
"using Maximum Fisher Information selection"
} else if (input$sel_method == "randomesque") {
"using Randomesque selection"
} else {
"using random item selection"
}
# Bias assessment
bias_assessment <- if (abs_bias <= 0.1) {
"minimal bias"
} else if (abs_bias <= 0.3) {
"moderate bias"
} else {
"substantial bias"
}
# CI assessment
ci_assessment <- if (true_in_ci) {
"The true value falls within the confidence interval, indicating appropriate uncertainty quantification."
} else {
"The true value falls outside the confidence interval, suggesting potential estimation issues."
}
sprintf("Measurement precision achieved %s. The 95%% confidence interval [%.2f, %.2f] represents our uncertainty about the true ability level. True θ = %.2f, EAP θ̂ = %.2f (bias: %+.2f). %s This represents %s given the current test length.",
method_text, lower_bound, upper_bound, true_theta_val, eap_score(), bias,
ci_assessment, bias_assessment)
})
output$dynamic_title <- renderUI({
tagList(
div(
style = "text-align: center; margin-bottom: 5px; padding: 5px 0; background: linear-gradient(135deg, #f8fafc 0%, #f1f5f9 100%); border-radius: 8px; grid-column: 1 / -1;",
h3("Computerized Adaptive Testing with Real-time Bayesian Estimation",
style = "color: #1e293b; font-weight: 600; margin: 0; font-size: 24px;"),
)
)
})
# ---- Summary Table Container ----
output$summary_table_container <- renderUI({
div(
style = "width: 100%; margin-top: 20px; padding: 15px; background: white; border-radius: 8px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
uiOutput("summary_table")
)
})
# ---- Summary Table Content ----
output$summary_table <- renderUI({
ib <- items()
cm <- cumulative_metrics_cache()
true_th <- true_theta()
req(!is.null(ib), nrow(ib) > 0, !is.null(true_th))
if (is.null(cm) || length(cm) == 0) return(NULL)
n_rows <- length(cm)
ib <- ib[seq_len(n_rows), , drop = FALSE]
resp <- responses()
if (length(resp) < n_rows) {
resp <- c(resp, rep(NA_integer_, n_rows - length(resp)))
}
# Create table header with equal width columns and centered titles
table_html <- paste0(
'<table id="summary_table" class="display compact" style="width:100%; font-size:10px; margin-top:15px; table-layout:fixed;">',
'<thead><tr style="background:linear-gradient(135deg,#f8fafc,#f1f5f9);">',
'<th style="width:7.69%; text-align:center;">Step</th>',
'<th style="width:7.69%; text-align:center;">Item</th>',
'<th style="width:7.69%; text-align:center;">a</th>',
'<th style="width:7.69%; text-align:center;">b</th>',
'<th style="width:7.69%; text-align:center;">c</th>',
'<th style="width:7.69%; text-align:center;">P(θ)</th>',
'<th style="width:7.69%; text-align:center;">Resp.</th>',
'<th style="width:7.69%; text-align:center;">EAP θ̂ </th>',
'<th style="width:7.69%; text-align:center;">Bias</th>',
'<th style="width:7.69%; text-align:center;">IIF</th>',
'<th style="width:7.69%; text-align:center;">TIF</th>',
'<th style="width:7.69%; text-align:center;">SEM</th>',
'<th style="width:7.69%; text-align:center;">ρ</th>',
'</tr></thead><tbody>'
)
# Create table rows (keeping your original cell alignment)
for (i in 1:n_rows) {
metrics <- cm[[i]]
current_iif <- metrics$iif_current_item
current_iif <- ifelse(is.finite(current_iif), current_iif, 0)
# Response symbol/color
current_response <- resp[i]
response_text <- if (!is.na(current_response) && current_response == 1) "✓" else "✗"
response_color <- if (!is.na(current_response) && current_response == 1) "green" else "red"
# Calculate p(true theta) using the global P_3pl function
p_true_theta <- P_3pl(
theta = true_th,
a = ib$a[i],
b = ib$b[i],
c = ib$c[i]
)
# Row HTML with 3 digits for numeric values
row_html <- paste0(
'<tr>',
'<td style="text-align:center;">', i, '</td>',
'<td style="text-align:center;">', ib$label[i], '</td>',
'<td style="text-align:right;">', sprintf('%.3f', ib$a[i]), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', ib$b[i]), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', ib$c[i]), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', p_true_theta), '</td>',
'<td style="text-align:center; color:', response_color, '; font-weight:bold;">', response_text, '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$estimated_theta), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$bias), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', current_iif), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$tif), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$sem), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$reliability), '</td>',
'</tr>'
)
table_html <- paste0(table_html, row_html)
}
table_html <- paste0(table_html, '</tbody></table>')
tagList(
tags$div(HTML(table_html)),
tags$script(HTML("
$(document).on('shiny:value', function() {
setTimeout(function() {
if ($.fn.DataTable.isDataTable('#summary_table')) {
$('#summary_table').DataTable().destroy();
}
$('#summary_table').DataTable({
paging: false,
searching: false,
info: false,
ordering: false,
autoWidth: false,
columnDefs: [
{ width: '7.69%', targets: '_all' }
]
});
}, 50);
});
"))
)
})
output$dynamic_status_metrics <- renderUI({
ib <- items()
n_items <- if (is.null(ib)) 0 else nrow(ib)
th_hat <- eap_theta()
true_th <- true_theta()
pool <- item_pool()
pool_size_current <- if (!is.null(pool)) nrow(pool) else pool_size
# Calculate current metrics
if (n_items > 0) {
iif_vals <- mapply(I_3pl, th_hat, ib$a, ib$b, ib$c)
iif_vals[!is.finite(iif_vals)] <- 0
tif <- sum(iif_vals)
} else {
tif <- 0
}
sem <- if (tif > 0) 1 / sqrt(tif) else NA_real_
rho <- calculate_reliability(tif)
bias <- th_hat - true_th
tagList(
div(class = "metrics-grid-expanded",
div(class = "metric-row",
div(class = "metric-cell true-theta",
tags$div(class = "metric-label", "True θ"),
tags$div(class = "metric-value", sprintf("%.2f", true_th))
),
div(class = "metric-cell eap-theta",
tags$div(class = "metric-label", "EAP θ"),
tags$div(class = "metric-value", sprintf("%.2f", th_hat))
),
div(class = "metric-cell bias",
tags$div(class = "metric-label", "Bias"),
tags$div(class = "metric-value", sprintf("%.2f", bias))
)
),
div(class = "metric-row",
div(class = "metric-cell pool-size",
tags$div(class = "metric-label", "Pool Size"),
tags$div(class = "metric-value", sprintf("%d", pool_size_current))
),
div(class = "metric-cell items-used",
tags$div(class = "metric-label", "Used"),
tags$div(class = "metric-value", sprintf("%d", n_items))
),
div(class = "metric-cell reliability",
tags$div(class = "metric-label", "Reliability"),
tags$div(class = "metric-value", if (is.finite(rho)) sprintf("%.3f", rho) else "—")
)
)
)
)
})
# ---- Reference Content ----
output$reference_content <- renderUI({
tagList(
# 1. COMPACT HEADER
div(class = "compact-header",
div(class = "header-content",
h1(class = "header-title", "CAT Information Center"),
p(class = "header-subtitle", "Computerized Adaptive Testing with Item Response Theory")
),
div(class = "header-meta",
span(class = "meta-item", "450 items"),
span(class = "meta-divider", "•"),
span(class = "meta-item", "SEM ≤ 0.30"),
span(class = "meta-divider", "•"),
span(class = "meta-item", "EAP θ̂ estimation")
)
),
# CONCEPTS IN SINGLE COLUMN
div(class = "concepts-single-column",
# SECTION 1: IRT FOUNDATION
div(class = "concept-section",
div(class = "section-header",
h2("1. IRT Foundation: The 3PL Model")
),
div(class = "section-content",
p("Modern adaptive testing begins with a fundamental question: ", tags$b("how do we precisely measure latent ability through test items?"),
" The answer lies in ", tags$b("Item Response Theory (IRT)"), ", which provides the mathematical framework for modeling the probability of a correct response as a function of underlying ability."),
p("At the heart of this simulator lies the ", tags$b("3-Parameter Logistic (3PL) model"), ", which captures the sophisticated interplay between item characteristics and examinee performance through this powerful equation:"),
div(class = "key-eq", withMathJax("$$P_i(\\theta) = c_i + \\displaystyle\\frac{1 - c_i}{1 + e^{-D \\cdot a_i \\cdot (\\theta - b_i)}}$$")),
p("This elegant mathematical relationship reveals how three fundamental parameters govern item behavior, each serving a distinct measurement purpose:"),
div(class = "parameter-details",
div(class = "parameter-item",
p(tags$strong("Discrimination (a):"), "The item's ability to distinguish between examinees of different ability levels. Higher values create steeper curves that sharply separate high and low performers, making them excellent for measurement precision."),
tags$ul(
tags$li("Steeper curves provide better separation between adjacent ability levels"),
tags$li("Higher discrimination values yield more information per item"),
tags$li("Critical for efficient adaptive testing and precise measurement")
)
),
div(class = "parameter-item",
p(tags$strong("Difficulty (b):"), "The ability level where examinees have a ", withMathJax("\\(\\frac{1+c}{2}\\)"), " probability of success. This represents the item's 'sweet spot'—the point where it provides maximum information about an examinee's ability."),
tags$ul(
tags$li("Determines where the item functions best along the ability continuum"),
tags$li("Items provide maximum information near their difficulty parameter"),
tags$li("Proper difficulty targeting is essential for adaptive efficiency")
)
),
div(class = "parameter-item",
p(tags$strong("Guessing (c):"), "The lower asymptote representing the probability of answering correctly by pure chance. This parameter sets the performance floor, acknowledging that even low-ability examinees can sometimes guess correctly."),
tags$ul(
tags$li("Accounts for random correct responses in multiple-choice items"),
tags$li("Higher guessing parameters reduce item information and measurement precision"),
tags$li("Essential for realistic modeling of educational testing scenarios")
)
)
),
p("The scaling constant ", withMathJax("\\(D = 1.702\\)"), " ensures the logistic function closely approximates the normal ogive model used in early IRT development, maintaining continuity with psychometric tradition while enabling practical computation.")
)
),
# SECTION 2: PSYCHOMETRIC FOUNDATIONS
div(class = "concept-section",
div(class = "section-header",
h2("2. Psychometric Foundations: Assumptions and Requirements")
),
div(class = "section-content",
p("Successful CAT implementation rests on several critical psychometric foundations. Understanding these assumptions and requirements ensures valid, reliable measurement and informs practical testing decisions."),
h4("Key IRT Assumptions and Their Implications"),
p("IRT models rely on fundamental assumptions that must be satisfied for valid measurement:"),
div(class = "assumption-grid",
div(class = "assumption-item",
p(tags$strong("Unidimensionality"), " - The test measures a single dominant trait or ability:"),
tags$ul(
tags$li("Response patterns should be explainable by one primary ability dimension"),
tags$li("Violations can lead to biased ability estimates and inaccurate standard errors"),
tags$li("Practical implication: Ensure content coherence and avoid measuring multiple distinct constructs within one test")
)
),
div(class = "assumption-item",
p(tags$strong("Local Independence"), " - Item responses are independent conditional on ability:"),
tags$ul(
tags$li("Once ability is accounted for, no residual relationships should exist between items"),
tags$li("Violations occur with testlets, learning during testing, or content dependencies"),
tags$li("Practical implication: Avoid item chains or sequences where answering one helps answer another")
)
),
div(class = "assumption-item",
p(tags$strong("Monotonicity"), " - The probability of correct response increases with ability:"),
tags$ul(
tags$li("Higher ability should always mean higher probability of correct response"),
tags$li("Essential for the logical ordering of items along the difficulty continuum"),
tags$li("Practical implication: Verify that item response functions actually increase with ability across the measurement range")
)
)
),
h4("Item Pool Requirements for Effective CAT"),
p("The quality and characteristics of the item pool fundamentally determine CAT performance:"),
div(class = "requirements-grid",
div(class = "requirement-item",
p(tags$strong("Size and Coverage"), " - Comprehensive ability range coverage:"),
tags$ul(
tags$li("Large enough to prevent overexposure (typically 200-1000+ items)"),
tags$li("Items distributed across the entire ability range of interest"),
tags$li("Gaps in difficulty coverage create measurement 'dead zones'")
)
),
div(class = "requirement-item",
p(tags$strong("Quality and Discrimination"), " - Psychometric quality standards:"),
tags$ul(
tags$li("High average discrimination (a > 1.0 preferred for efficient CAT)"),
tags$li("Well-estimated, stable item parameters from large calibration samples"),
tags$li("Minimal guessing parameters for maximum information efficiency")
)
),
div(class = "requirement-item",
p(tags$strong("Content Balance"), " - Representative content distribution:"),
tags$ul(
tags$li("Adequate representation of all content domains and cognitive levels"),
tags$li("Content constraints must be maintainable during adaptive selection"),
tags$li("Prevents content drift and ensures validity evidence")
)
)
),
h4("Model Selection Considerations"),
p("Choosing the appropriate IRT model involves balancing complexity with practical needs:"),
div(class = "model-comparison",
div(class = "model-item",
p(tags$strong("1PL/Rasch Model"), " - Single difficulty parameter:"),
tags$ul(
tags$li(tags$b("Advantages:"), "Simpler estimation, specific objectivity, sample-independent"),
tags$li(tags$b("Limitations:"), "Assumes equal discrimination, may not fit real data well"),
tags$li(tags$b("Use when:"), "Theoretical purity needed, items are parallel in form")
)
),
div(class = "model-item",
p(tags$strong("2PL Model"), " - Difficulty and discrimination parameters:"),
tags$ul(
tags$li(tags$b("Advantages:"), "More realistic, accounts for varying item quality"),
tags$li(tags$b("Limitations:"), "Ignores guessing, requires larger samples"),
tags$li(tags$b("Use when:"), "Constructed-response items, minimal guessing expected")
)
),
div(class = "model-item",
p(tags$strong("3PL Model"), " - Full parameterization with guessing:"),
tags$ul(
tags$li(tags$b("Advantages:"), "Most realistic for multiple-choice, accounts for chance success"),
tags$li(tags$b("Limitations:"), "Complex estimation, parameter interdependencies"),
tags$li(tags$b("Use when:"), "Multiple-choice items, guessing likely, maximum realism needed")
)
)
),
p("The 3PL model used in this simulator represents the gold standard for multiple-choice adaptive testing, providing the best balance of realism and practical utility for educational assessment contexts.")
)
),
# SECTION 3: MEASUREMENT PRECISION
div(class = "concept-section",
div(class = "section-header",
h2("3. From Response Curves to Measurement Precision")
),
div(class = "section-content",
p("While IRT models elegantly describe how items function, we need powerful tools to quantify their measurement quality. This is where ",
tags$strong("Fisher information"), " becomes essential—transforming abstract response curves into concrete precision metrics that drive adaptive testing decisions."),
h4("Item Information Function: Precision Mapping"),
p(tags$strong("Item Information"), " quantifies how much measurement precision an item provides at each ability level, creating a precision profile across the measurement continuum:"),
div(class = "key-eq", withMathJax("$$I_i(\\theta) = \\displaystyle\\frac{\\big[P_i'(\\theta)\\big]^2}{P_i(\\theta) \\cdot \\big[1-P_i(\\theta)\\big]}$$")),
p("The Item Information Function (IIF) serves as a precision map, revealing where each item contributes most to measurement accuracy. It typically peaks near the item's difficulty parameter, where discrimination is strongest and the item best separates similar ability levels."),
tags$ul(
tags$li("Information is ability-specific, unlike classical test reliability"),
tags$li("Each item provides maximum information at its optimal measurement point"),
tags$li("The information curve reflects the item's measurement 'sweet spot'")
),
h4("Test Information Function: Precision Aggregation"),
p("Individual items tell only part of the story. ", tags$strong("Test Information"), " aggregates precision across all administered items, creating a comprehensive precision profile:"),
div(class = "key-eq", withMathJax("$$\\text{TIF}(\\theta) = \\displaystyle\\sum_{i=1}^n I_i(\\theta)$$")),
p("This additive property is revolutionary—it allows test developers to strategically combine items, building targeted precision profiles across the ability spectrum. The test information function represents the cumulative measurement precision available at each ability level."),
tags$ul(
tags$li("Information from independent items sums directly"),
tags$li("Enables strategic test construction for specific precision targets"),
tags$li("Forms the mathematical basis for adaptive testing efficiency")
),
h4("Standard Error of Measurement: Practical Uncertainty"),
p("To make information interpretable for decision-making, we convert it to practical measurement uncertainty through the ", tags$strong("Standard Error of Measurement (SEM)"), ":"),
div(class = "key-eq", withMathJax("$$\\text{SEM}(\\theta) = \\displaystyle\\frac{1}{\\sqrt{\\text{TIF}(\\theta)}}$$")),
p("SEM represents the standard deviation of ability estimates around true ability. The elegant inverse relationship means: ",
tags$b("more information → smaller error → better precision."), " This mathematical relationship forms the operational heart of adaptive testing efficiency."),
tags$ul(
tags$li("SEM decreases as the square root of total information increases"),
tags$li("Provides directly interpretable measurement uncertainty"),
tags$li("Enables precision-based stopping rules in adaptive testing")
),
div(class = "edu-note",
tags$b("Precision Standards and Practical Applications"),
p("The choice of SEM target represents a fundamental trade-off between measurement precision and testing efficiency. Different educational and psychological applications demand different precision levels, creating a continuum of measurement quality:"),
div(class = "precision-table",
tags$table(
tags$thead(
tags$tr(
tags$th("SEM Target"),
tags$th("95% CI Width"),
tags$th("Typical Items Needed"),
tags$th("Common Use Cases")
)
),
tags$tbody(
tags$tr(
tags$td(tags$strong("0.15")),
tags$td("±0.29"),
tags$td("15-25 items"),
tags$td("High-stakes certification, medical licensing")
),
tags$tr(
tags$td(tags$strong("0.25")),
tags$td("±0.49"),
tags$td("8-15 items"),
tags$td("Graduate admissions, professional certification")
),
tags$tr(class = "current-standard-row",
tags$td(tags$strong("0.30")),
tags$td("±0.59"),
tags$td("5-12 items"),
tags$td("Educational placement, formative assessment")
),
tags$tr(
tags$td(tags$strong("0.40")),
tags$td("±0.78"),
tags$td("3-8 items"),
tags$td("Low-stakes screening, progress monitoring")
)
)
)
),
p(tags$b("Why SEM ≤ 0.30 in This Simulator?"), " This specific precision standard represents an optimal balance point for educational assessment:"),
tags$ul(
tags$li("Provides sufficient precision for most educational decisions while maintaining reasonable test length"),
tags$li("Allows clear demonstration of CAT efficiency (typically 5-12 items with MFI)"),
tags$li("95% confidence interval of ±0.59 proves adequate for placement and formative assessment decisions"),
tags$li("Shows dramatic improvement over fixed-form testing without requiring excessive items")
),
p("The underlying mathematical relationship governing confidence intervals is straightforward:"),
div(class = "key-eq", withMathJax("$$\\text{CI Width} = 2 \\times Z \\times \\text{SEM}$$")),
p("Where Z = 1.96 for 95% confidence. This means tighter confidence intervals require smaller SEM, which in turn requires more items due to the inverse square root relationship with test information. Each halving of SEM requires approximately four times the information, demonstrating the precision-efficiency trade-off.")
)
)
),
# SECTION 4: KEY MATHEMATICAL INSIGHTS
div(class = "concept-section",
div(class = "section-header",
h2("4. Key Mathematical Insights for Test Design")
),
div(class = "section-content",
p("Understanding these fundamental mathematical relationships is crucial for effective test design and appreciating why adaptive testing achieves such remarkable efficiency:"),
div(class = "mathematical-insights",
div(class = "insight-item",
p(tags$strong("Information-Error Tradeoff:"), withMathJax("\\(SEM = \\frac{1}{\\sqrt{TIF}}\\)")),
p("Doubling information reduces SEM by 30%, creating dramatic precision gains. This nonlinear relationship means initial information gains provide substantial precision improvements, while subsequent gains yield diminishing returns."),
tags$ul(
tags$li("Small information increases yield substantial early precision gains"),
tags$li("High precision targets require disproportionately more items"),
tags$li("Explains why CAT can achieve good precision with few items")
)
),
div(class = "insight-item",
p(tags$strong("Discrimination Power:"), withMathJax("\\(I(\\theta) \\propto a^2\\)")),
p("Information grows with the square of discrimination, making highly discriminating items disproportionately valuable. A item with discrimination 2.0 provides four times the information of an item with discrimination 1.0."),
tags$ul(
tags$li("Highly discriminating items are precious measurement resources"),
tags$li("Small discrimination differences create large information differences"),
tags$li("Item selection should prioritize high-discrimination items")
)
),
div(class = "insight-item",
p(tags$strong("Optimal Targeting:"), withMathJax("Maximum information occurs when \\(\\theta \\approx b\\)")),
p("Items measure best when matched to examinee ability. An item provides maximum information when the examinee's ability level equals the item's difficulty parameter."),
tags$ul(
tags$li("Items are most informative near their difficulty level"),
tags$li("Poorly targeted items waste testing time and examinee effort"),
tags$li("Adaptive testing dynamically maintains optimal targeting")
)
),
div(class = "insight-item",
p(tags$strong("Guessing Penalty:"), "High guessing parameters substantially reduce information"),
p("Guessing flattens the response curve and weakens discrimination. Items with high guessing parameters provide less information and require more careful interpretation."),
tags$ul(
tags$li("Guessing reduces measurement precision across all ability levels"),
tags$li("High-guessing items require more careful statistical treatment"),
tags$li("Optimal item pools minimize guessing while maintaining content coverage")
)
),
div(class = "insight-item",
p(tags$strong("Test Length Impact:"), "Achieving SEM = 0.15 typically requires 2-4× more items than SEM = 0.30"),
p("This dramatic increase demonstrates the precision-efficiency trade-off. High precision demands substantial additional measurement resources."),
tags$ul(
tags$li("Precision improvements become increasingly expensive"),
tags$li("Practical testing requires balancing precision and efficiency"),
tags$li("Different applications justify different precision targets")
)
)
),
p(tags$strong("These mathematical relationships collectively form the scientific basis for adaptive testing:"),
"By selecting highly discriminating items targeted to the ability range of interest while minimizing guessing opportunities, CAT achieves precision equivalent to traditional tests with dramatically fewer items.")
)
),
# SECTION 5: BAYESIAN ESTIMATION
div(class = "concept-section",
div(class = "section-header",
h2("5. Bayesian Estimation: Intelligent Ability Measurement")
),
div(class = "section-content",
p("With our precision framework established, we need robust, practical methods to estimate ability from response patterns. ",
tags$strong("Expected A Posteriori (EAP)"), " estimation elegantly combines observed response data with prior knowledge using Bayesian principles, creating stable, efficient ability estimates:"),
div(class = "key-eq eap-eq", withMathJax("$$\\hat{\\theta}_{EAP} = \\displaystyle\\frac{\\displaystyle\\int \\theta \\cdot L(\\mathbf{y}|\\theta) \\cdot \\pi(\\theta) \\,d\\theta}{\\displaystyle\\int L(\\mathbf{y}|\\theta) \\cdot \\pi(\\theta) \\,d\\theta}$$")),
p("The likelihood function captures how probable our observed responses are across different ability levels, creating a probabilistic evidence map:"),
div(class = "key-eq", withMathJax("$$L(\\mathbf{y}|\\theta) = \\prod_{i=1}^{n} P_i(\\theta)^{y_i} \\cdot [1-P_i(\\theta)]^{1-y_i}$$")),
p("For computational stability and numerical accuracy, we work in log-space, transforming products into sums:"),
div(class = "key-eq", withMathJax("$$\\ell(\\theta) = \\sum_{i=1}^{n} \\left[ y_i \\cdot \\ln P_i(\\theta) + (1-y_i) \\cdot \\ln (1-P_i(\\theta)) \\right]$$")),
div(class = "edu-note",
tags$b("EAP Implementation with Gauss-Hermite Quadrature"),
p("This simulator uses ", tags$strong("31-point Gauss-Hermite quadrature"), " for efficient, accurate numerical integration with a standard normal prior, balancing computational speed with estimation precision:"),
div(class = "key-eq eap-eq", withMathJax("$$\\hat{\\theta}_{EAP} \\approx \\displaystyle\\frac{\\displaystyle\\sum_{q=1}^{Q} \\theta_q \\cdot L(\\mathbf{y}|\\theta_q) \\cdot \\pi(\\theta_q) \\cdot w_q}{\\displaystyle\\sum_{q=1}^{Q} L(\\mathbf{y}|\\theta_q) \\cdot \\pi(\\theta_q) \\cdot w_q}$$")),
# Node spacing plot
plotOutput("grid_diagnostics_plot", height = "300px"),
p(tags$em("Node spacing comparison: Gauss-Hermite (blue) concentrates nodes where the normal prior has most mass, while uniform (red) spreads nodes evenly.")),
# Distribution comparison plot
plotOutput("distribution_comparison_plot", height = "300px"),
p(tags$em("Distribution matching: Gauss-Hermite weights (red) closely approximate the standard normal distribution (green), while uniform weights (blue) provide poor approximation.")),
p(tags$strong("Why Gauss-Hermite Quadrature Excels for Bayesian Integration:"), "This numerical method provides optimal characteristics for psychometric computation:"),
tags$ul(
tags$li("Specifically optimized for integrals involving normal distributions (our natural prior choice)"),
tags$li("Provides high accuracy with relatively few evaluation nodes, ensuring computational efficiency"),
tags$li("Enables pre-computation of quadrature nodes and weights for rapid real-time estimation"),
tags$li("Eliminates the need for complex derivative calculations required by other methods")
)
),
div(class = "edu-note",
tags$b("Computational Stability in Practice:"),
p("Real-world implementation requires careful attention to numerical stability, particularly with probabilistic computations:"),
p("1. ", tags$strong("Underflow Prevention:"), "Multiplying probabilities (all < 1) across many items can produce numbers smaller than computers can represent. Log transformation converts multiplication to addition, eliminating this risk entirely."),
p("2. ", tags$strong("Numerical Precision:"), "Working in log-space maintains computational accuracy across the entire measurement range, from extreme low to extreme high abilities."),
p("3. ", tags$strong("The Log-Sum-Exp Trick:"), "Critical for stable EAP θ̂ computation with quadrature, this technique prevents numerical overflow while preserving mathematical accuracy:"),
div(class = "key-eq", withMathJax("$$\\log\\left(\\sum e^{x_i}\\right) = m + \\log\\left(\\sum e^{x_i - m}\\right)$$")),
p("By subtracting the maximum value before exponentiation, we prevent numerical overflow while preserving mathematical accuracy across diverse response patterns."),
p("4. ", tags$strong("Bayesian Integration Stability:"), "EAP requires stable computation across the entire ability continuum—log-space ensures reliable integration from extreme low to extreme high abilities, handling all possible response patterns gracefully.")
),
div(class = "edu-note",
tags$b("Core Computational Concepts:"),
p("Understanding these fundamental concepts helps appreciate EAP's strengths:"),
tags$ul(
tags$li(tags$strong("Likelihood Surface:"), "A probability landscape showing how likely our response pattern is across all possible ability levels, representing the evidence provided by the data"),
tags$li(tags$strong("Posterior Distribution:"), "The Bayesian fusion of likelihood and prior—EAP computes the mean of this informed distribution, balancing data evidence with reasonable expectations"),
tags$li(tags$strong("Contrast with MLE:"), "Unlike maximum likelihood estimation (which seeks peak probability), EAP computes the distribution center, providing more stable estimates with limited data and handling extreme response patterns gracefully")
)
),
div(class = "edu-note",
tags$b("Why EAP Excels in Adaptive Testing:"),
p("EAP θ̂ estimation provides specific advantages that make it ideally suited for computerized adaptive testing environments:"),
tags$ul(
tags$li(tags$strong("Early-Stage Stability:"), "Prior distribution regularizes estimates when few items have been administered, preventing wild fluctuations from limited data"),
tags$li(tags$strong("Perfect Score Handling:"), "No infinite estimates for all-correct or all-incorrect response patterns—estimates remain within reasonable bounds"),
tags$li(tags$strong("Built-in Uncertainty:"), "Posterior standard deviation provides immediate standard error without additional computation, enabling efficient precision monitoring"),
tags$li(tags$strong("Computational Efficiency:"), "Fixed quadrature nodes enable pre-computation and rapid updating after each response, supporting real-time adaptive testing")
)
)
)
),
# 6. SYMPSON-HETTER EXPOSURE CONTROL
div(class = "concept-section",
div(class = "section-header",
h2("6. Sympson-Hetter Exposure Control: Balancing Efficiency and Security")
),
div(class = "section-content",
p("While Maximum Fisher Information (MFI) selection provides optimal measurement efficiency, it creates a critical operational challenge: ",
tags$strong("item overexposure"), ". The most informative items are selected repeatedly, compromising test security and reducing item pool longevity. The ",
tags$strong("Sympson-Hetter method"), " elegantly solves this problem through probabilistic exposure control."),
h4("The Overexposure Problem in MFI CAT"),
p("Without exposure control, MFI selection creates predictable patterns:"),
tags$ul(
tags$li("Top 10-20% of items account for 60-80% of administrations"),
tags$li("High-discrimination items become 'public knowledge' through repeated exposure"),
tags$li("Item parameters can drift due to overuse, compromising measurement accuracy"),
tags$li("Test security is compromised when items become predictable")
),
h4("Sympson-Hetter Mathematical Framework"),
p("The method introduces two key parameters for each item:"),
div(class = "key-eq", withMathJax("
\\begin{aligned}
&K_i = P(\\text{Administer } i \\mid \\text{Select } i) \\\\
&R_i = P(\\text{Select } i \\mid \\text{Available})
\\end{aligned}
")),
p("Where:"),
tags$ul(
tags$li(withMathJax("\\(K_i\\): Exposure control parameter - probability item is administered given it's selected")),
tags$li(withMathJax("\\(R_i\\): Target administration rate - maximum desired selection probability"))
),
h4("The Two-Stage Selection Process"),
p("Sympson-Hetter modifies the standard CAT selection process:"),
div(class = "edu-note",
tags$b("Standard MFI Selection:"),
tags$ol(
tags$li("Compute information for all available items"),
tags$li("Select item with maximum information"),
tags$li("Administer selected item")
),
tags$b("Sympson-Hetter Modified Selection:"),
tags$ol(
tags$li("Compute information for all available items"),
tags$li("Select item with maximum information"),
tags$li(withMathJax("Generate Bernoulli trial with probability \\(K_i\\)")),
tags$li("If trial succeeds: administer item"),
tags$li("If trial fails: mark item as administered (without presenting it) and repeat")
)
),
h4("Parameter Estimation Through Iteration"),
p("The critical challenge is determining appropriate \\(K_i\\) values. This is achieved through iterative simulation:"),
div(class = "key-eq", withMathJax("$$K_i^{(t+1)} = \\min\\left(1, \\frac{R_i}{\\hat{P}(\\text{Select } i \\mid K_i^{(t)})} \\cdot K_i^{(t)}\\right)$$")),
p("Where \\(\\hat{P}(\\text{Select } i \\mid K_i^{(t)})\\) is the empirical selection probability from simulation with current \\(K_i\\) values."),
div(class = "edu-note",
tags$b("Iterative Calibration Process:"),
tags$ol(
tags$li("Initialize all \\(K_i = 1.0\\) (no exposure control)"),
tags$li("Run large-scale CAT simulations"),
tags$li("Compute empirical selection rates for each item"),
tags$li("Update \\(K_i\\) values using the adjustment formula"),
tags$li("Repeat until convergence (typically 10-20 iterations)"),
tags$li("Validate with fresh simulation data")
)
),
h4("Research Support"),
p("Empirical studies demonstrate the performance characteristics of different selection and exposure control combinations:"),
div(class = "precision-table",
tags$table(
tags$thead(
tags$tr(
tags$th("Method"),
tags$th("Efficiency"),
tags$th("Security"),
tags$th("Pool Usage")
)
),
tags$tbody(
tags$tr(
tags$td(tags$strong("MFI only")),
tags$td("100%"),
tags$td("20%"),
tags$td("15%")
),
tags$tr(
tags$td(tags$strong("MFI + SH")),
tags$td("85%"),
tags$td("80%"),
tags$td("40%")
),
tags$tr(
tags$td(tags$strong("Randomesque only")),
tags$td("90%"),
tags$td("60%"),
tags$td("30%")
),
tags$tr(class = "current-standard-row",
tags$td(tags$strong("Randomesque + SH")),
tags$td("88%"),
tags$td("85%"),
tags$td("55%")
)
)
)
),
div(class = "edu-note",
tags$b("Academic References:"),
tags$ul(
tags$li(tags$strong("Sympson & Hetter (1985):"), " Original SH method demonstrating 60-80% reduction in overexposure"),
tags$li(tags$strong("Chen et al. (2000):"), " Randomesque maintains 85-95% of MFI efficiency with better security"),
tags$li(tags$strong("Revuelta & Ponsoda (1998):"), " Comparative study showing SH efficiency losses of 10-15%"),
tags$li(tags$strong("Georgiadou et al. (2007):"), " Comprehensive review confirming combined methods provide optimal balance"),
tags$li(tags$strong("Chang & Ying (1999):"), " Demonstrated effectiveness of SH across multiple selection methods")
),
p("These studies collectively support that ", tags$strong("Randomesque + Sympson-Hetter"), " provides the optimal balance of measurement efficiency (88%), test security (85%), and pool utilization (55%) for operational testing programs.")
),
h4("Practical Implementation in This Simulator"),
# Educational transparency note
div(class = "edu-note",
p("This simulator uses a simplified version of Sympson-Hetter for educational purposes. Operational testing systems employ more sophisticated multi-constraint approaches that:"),
tags$ul(
tags$li("Apply multiple constraints simultaneously (content, exposure, sequencing)"),
tags$li("Use progressive constraint relaxation when no items satisfy all criteria"),
tags$li("Employ composite scoring with weighted multi-criteria optimization"),
tags$li("Never mark items as 'administered' without actual presentation to examinees")
),
p("The simplified Bernoulli trial approach is used here to clearly demonstrate the core Sympson-Hetter concept while maintaining computational efficiency for educational demonstration.")
),
div(class = "parameter-details",
div(class = "parameter-item",
p(tags$strong("K Value (Administration Probability):")),
tags$ul(
tags$li("Range: 0.1 to 1.0"),
tags$li("Interpretation: Probability an item is administered when selected"),
tags$li(withMathJax("Example: \\(K = 0.6\\) means 60% chance of administration")),
tags$li("Lower values provide stronger exposure control but reduce efficiency"),
tags$li("Operational range: 0.3-0.8 (Stocking & Lewis, 1998)")
)
),
div(class = "parameter-item",
p(tags$strong("R Value (Target Usage Rate):")),
tags$ul(
tags$li("Range: 0.1 to 1.0"),
tags$li("Interpretation: Maximum desired administration rate across the pool"),
tags$li(withMathJax("Example: \\(R = 0.3\\) targets 30% maximum usage rate")),
tags$li("Typical operational values: 0.2-0.4 for high-stakes testing"),
tags$li("Balances security needs with practical pool constraints")
)
)
),
h4("Real-World Implementation"),
p("Professional CAT systems often combine multiple strategies:"),
div(class = "code-block",
tags$pre(paste(
"# Professional CAT systems often use:",
"selection_strategy <- list(",
" method = 'randomesque',",
" m_top = 5,",
" exposure_control = 'sympson-hetter',",
" content_balancing = TRUE,",
" enemy_items = TRUE",
")",
sep = "\n"
))
),
h4("When Sympson-Hetter is Most Beneficial"),
div(class = "implementation-considerations",
div(class = "consideration-item",
p(tags$strong("Good Candidates:")),
tags$ul(
tags$li("Small to medium pools (100-500 items)"),
tags$li("High-stakes assessments where security is critical"),
tags$li("Pools with uneven quality (few excellent items)"),
tags$li("Long-term programs needing pool longevity")
)
),
div(class = "consideration-item",
p(tags$strong("Less Beneficial For:")),
tags$ul(
tags$li("Very large pools (>1000 items)"),
tags$li("Low-stakes formative assessment"),
tags$li("Research settings where maximum efficiency is goal")
)
)
),
h4("Mathematical Properties and Trade-offs"),
p("Sympson-Hetter creates important statistical trade-offs:"),
div(class = "mathematical-insights",
div(class = "insight-item",
p(tags$strong("Efficiency-Security Trade-off:"), withMathJax("\\(\\text{Efficiency} \\propto \\frac{1}{\\text{Security}}\\)")),
p("Stronger exposure control (lower K values) reduces measurement efficiency but increases test security."),
tags$ul(
tags$li("With \\(K = 1.0\\): Maximum efficiency, minimum security"),
tags$li("With \\(K = 0.2\\): Reduced efficiency, maximum security"),
tags$li("Optimal balance typically found at \\(K = 0.5-0.8\\)")
)
),
div(class = "insight-item",
p(tags$strong("Information Loss:"), withMathJax("\\(I_{effective} = K_i \\cdot I_{max}\\)")),
p("The effective information provided is reduced by the administration probability."),
tags$ul(
tags$li("Items with high K values contribute more to measurement precision"),
tags$li("The algorithm must select more items to achieve the same SEM target"),
tags$li("Test length increases approximately linearly with decreasing K")
)
)
),
h4("Operational Considerations"),
p("Successful Sympson-Hetter implementation requires careful planning:"),
div(class = "implementation-considerations",
div(class = "consideration-item",
p(tags$strong("Calibration Sample Size:")),
tags$ul(
tags$li("Large samples needed (1,000+ simulated examinees per iteration)"),
tags$li("Multiple ability distributions should be represented"),
tags$li("Calibration must match operational testing conditions")
)
),
div(class = "consideration-item",
p(tags$strong("Parameter Stability:")),
tags$ul(
tags$li("\\(K_i\\) values must be periodically re-estimated"),
tags$li("Changes in item pool or examinee population require recalibration"),
tags$li("Monitoring actual exposure rates is essential")
)
),
div(class = "consideration-item",
p(tags$strong("Content Balancing Integration:")),
tags$ul(
tags$li("Sympson-Hetter must work with content constraints"),
tags$li("Complex constraint satisfaction algorithms may be needed"),
tags$li("Trade-offs between content coverage and exposure control must be managed")
)
)
),
div(class = "edu-note",
tags$b("Application Across Selection Methods:"),
p("While originally designed for MFI, research shows Sympson-Hetter can be effectively applied to Randomesque selection:"),
tags$ul(
tags$li(tags$strong("MFI + SH:"), " Maximum efficiency with security - ideal when precision is paramount"),
tags$li(tags$strong("Randomesque + SH:"), " Optimal balance - provides 88% efficiency with 85% security (Chen et al., 2000)"),
tags$li("The combination leverages Randomesque's natural diversification with SH's probabilistic control"),
tags$li("Results in better pool utilization (55% vs 40% with MFI+SH)")
)
),
p(tags$strong("In this simulator"), ", you can experiment with Sympson-Hetter parameters across different selection methods to observe the trade-offs between measurement precision, test length, and item exposure patterns. The research-supported performance metrics provide guidance for selecting appropriate strategies based on your testing program's specific needs for efficiency, security, and pool longevity.")
)
),
# SECTION 7: EXPOSURE CONTROL AND PRACTICAL IMPLEMENTATION (now renumbered)
div(class = "concept-section",
div(class = "section-header",
h2("7. Additional Exposure Control Methods and Practical Implementation")
),
div(class = "section-content",
p("Real-world CAT systems must balance measurement efficiency with practical test security concerns. ", tags$b("Exposure control methods"), " prevent overuse of optimal items, ensuring test security and item pool longevity while maintaining measurement quality."),
h4("Item Exposure Control Methods"),
p("Several sophisticated algorithms manage item exposure while preserving adaptive efficiency:"),
div(class = "exposure-methods",
div(class = "method-item",
p(tags$strong("Sympson-Hetter Method"), " - Probabilistic exposure control:"),
tags$ul(
tags$li("Assigns each item an exposure control parameter (0-1) representing the probability it will be administered if selected"),
tags$li("Parameters are tuned through simulation to achieve target exposure rates"),
tags$li("Provides strong security but requires extensive pre-operational simulation")
)
),
div(class = "method-item",
p(tags$strong("a-Stratified Method"), " - Structured item pool usage:"),
tags$ul(
tags$li("Partitions items into strata based on discrimination parameters"),
tags$li("Uses lower-stratum items early in the test, reserving high-discrimination items for precise measurement"),
tags$li("Naturally controls exposure while maintaining reasonable efficiency")
)
),
div(class = "method-item",
p(tags$strong("Progressive Method"), " - Dynamic exposure control:"),
tags$ul(
tags$li("Continuously updates item selection probabilities based on usage history"),
tags$li("Automatically adapts to changing pool usage patterns"),
tags$li("Requires no pre-operational simulation but needs careful parameter setting")
)
)
),
h4("Content Balancing and Constraints"),
p("Professional CAT systems must maintain content validity while adapting to individual examinees:"),
div(class = "content-balancing",
div(class = "constraint-item",
p(tags$strong("Content Representation"), " - Ensuring domain coverage:"),
tags$ul(
tags$li("Content areas must be proportionally represented throughout the adaptive test"),
tags$li("Prevents content drift where certain domains are systematically under-sampled"),
tags$li("Maintains validity evidence and construct representation")
)
),
div(class = "constraint-item",
p(tags$strong("Enemy Items"), " - Controlling item combinations:"),
tags$ul(
tags$li("Prevents administration of items that might provide clues to each other"),
tags$li("Maintains local independence assumption and test security"),
tags$li("Essential for high-stakes testing environments")
)
),
div(class = "constraint-item",
p(tags$strong("Item Ordering Constraints"), " - Managing test presentation:"),
tags$ul(
tags$li("Controls sequencing of item types, formats, or cognitive demands"),
tags$li("Ensures standardized testing experience across examinees"),
tags$li("Prevents predictable patterns that could be exploited")
)
)
),
h4("Practical Implementation Considerations"),
p("Successful CAT deployment requires addressing several operational challenges:"),
div(class = "implementation-considerations",
div(class = "consideration-item",
p(tags$strong("Item Pool Calibration"), " - Foundation of measurement accuracy:"),
tags$ul(
tags$li("Large, representative samples needed for stable parameter estimation (typically 500-1000+ examinees per item)"),
tags$li("Regular item parameter drift monitoring and recalibration"),
tags$li("Differential item functioning analysis across subgroups")
)
),
div(class = "consideration-item",
p(tags$strong("Testing Termination Rules"), " - Balancing precision and practicality:"),
tags$ul(
tags$li("SEM-based stopping (as used in this simulator) for precision targets"),
tags$li("Maximum test length limits to prevent testing fatigue"),
tags$li("Confidence interval width criteria for classification decisions")
)
),
div(class = "consideration-item",
p(tags$strong("Administrative Requirements"), " - Operational realities:"),
tags$ul(
tags$li("Secure item delivery and response capture systems"),
tags$li("Robust ability estimation algorithms with real-time performance"),
tags$li("Comprehensive logging for psychometric analysis and security monitoring")
)
)
),
p("These practical considerations ensure that CAT systems deliver both statistical efficiency and operational robustness in real-world testing environments.")
)
),
# SECTION 8: ADAPTIVE TESTING ENGINE (renumbered)
div(class = "concept-section",
div(class = "section-header",
h2("8. The Adaptive Testing Engine in Action")
),
div(class = "section-content",
p("Now we integrate these sophisticated psychometric concepts into a dynamic, responsive testing system. The CAT algorithm represents a continuous learning process that adapts to each examinee through four interconnected operations, creating a personalized measurement experience:"),
div(class = "workflow-simple",
div(class = "workflow-step",
div(class = "step-number", "1"),
div(class = "step-content",
p(tags$strong("Estimate Current Ability")),
p("Compute \\(\\hat{\\theta}\\) using EAP estimation with all current responses, creating an updated understanding of the examinee's ability level after each item administration")
)
),
div(class = "workflow-step",
div(class = "step-number", "2"),
div(class = "step-content",
p(tags$strong("Select Optimal Item")),
p("Choose the item that maximizes information at the current ability estimate, ensuring each new item provides maximum measurement precision given our current knowledge")
)
),
div(class = "workflow-step",
div(class = "step-number", "3"),
div(class = "step-content",
p(tags$strong("Administer & Score Item")),
p("Present the selected item and record the response, gathering new evidence about the examinee's ability level")
)
),
div(class = "workflow-step",
div(class = "step-number", "4"),
div(class = "step-content",
p(tags$strong("Evaluate Measurement Precision")),
p("Check if \\(\\text{SEM} \\leq 0.30\\) precision threshold is met, determining whether sufficient measurement precision has been achieved for confident decision-making")
)
)
),
p("This sophisticated cycle repeats until the precision target is reached, creating a testing experience uniquely tailored to each examinee's ability level. The algorithm continuously learns from each response, refining its understanding of the examinee's ability while strategically selecting items that provide maximum information gain.")
)
),
# SECTION 9: STRATEGY COMPARISON (renumbered)
div(class = "concept-section",
div(class = "section-header",
h2("9. Adaptive Efficiency: MFI vs Traditional Testing")
),
div(class = "section-content",
p("The power of adaptive testing becomes clear when comparing measurement efficiency across different item selection strategies. ",
tags$strong("Maximum Fisher Information (MFI)"), " achieves equivalent precision with 60-75% fewer items by systematically targeting items that provide maximum information at each examinee's current ability level. This intelligent selection eliminates the measurement inefficiency of traditional tests, where many items provide little information because they're poorly matched to the examinee's ability."),
div(class = "strategy-comparison",
# MFI Strategy
div(class = "strategy-card mfi-strategy",
div(class = "strategy-header",
h3("Maximum Fisher Information (MFI)"),
div(class = "strategy-badge", "Adaptive")
),
div(class = "strategy-description",
p("Intelligently selects items with peak information at the current ability estimate, creating a personalized test for each examinee")
),
div(class = "strategy-stats",
div(class = "stat",
div(class = "stat-value", "5-15"),
div(class = "stat-label", "Items Needed")
),
div(class = "stat",
div(class = "stat-value", "50-75%"),
div(class = "stat-label", "Reduction")
)
),
div(class = "strategy-details",
tags$ul(
tags$li("Rapid convergence to precise measurement with minimal items through optimal targeting"),
tags$li("Eliminates wasted items that are too easy or too difficult for the examinee"),
tags$li("Dynamically adapts to each examinee's unique ability pattern and response history"),
tags$li("Maximizes information gain per item, creating exceptional measurement efficiency")
)
)
),
# Random Strategy
div(class = "strategy-card random-strategy",
div(class = "strategy-header",
h3("Fixed-form Equivalent"),
div(class = "strategy-badge", "Traditional")
),
div(class = "strategy-description",
p("Uniform random selection from entire item pool, representing conventional fixed-form testing approaches")
),
div(class = "strategy-stats",
div(class = "stat",
div(class = "stat-value", "20+"),
div(class = "stat-label", "Items Needed")
),
div(class = "stat",
div(class = "stat-value", "Baseline"),
div(class = "stat-label", "No reduction")
)
),
div(class = "strategy-details",
tags$ul(
tags$li("Simple to implement and understand, with straightforward administration"),
tags$li("Provides a clear baseline for comparing adaptive testing efficiency gains"),
tags$li("Represents standard testing practices used in many educational and psychological settings"),
tags$li("Consistent test content across examinees, facilitating certain types of comparisons")
)
)
)
),
p("The dramatic difference in efficiency between these approaches demonstrates why adaptive testing represents such a significant advancement in educational measurement. By respecting the fundamental psychometric principle that items provide different information at different ability levels, CAT achieves superior measurement precision with substantially reduced testing burden.")
)
),
# SECTION 10: CONCLUSION (renumbered)
div(class = "concept-section",
div(class = "section-header",
h2("10. Putting It All Together")
),
div(class = "section-content",
p("The CAT engine represents a sophisticated integration of IRT modeling, information theory, and Bayesian estimation—creating an intelligent testing system that learns about the examinee as it progresses. Each response informs the next item selection, creating a personalized measurement journey that achieves precision with remarkable efficiency."),
p("This integrated approach transforms standardized testing from a one-size-fits-all assessment into a dynamic, responsive measurement process. The system continuously balances what it has learned about the examinee with what it needs to learn, selecting each new item to maximize information gain while respecting content constraints and measurement goals."),
p("The result is testing that is not only more efficient but also more engaging and less frustrating for examinees. By avoiding items that are too easy or too difficult, CAT maintains appropriate challenge levels throughout the assessment, providing a better testing experience while gathering more precise measurement information."),
div(class = "conclusion-highlight",
p(tags$strong("Ultimately, computerized adaptive testing represents the practical realization of sophisticated psychometric theory—delivering personalized, precise measurement that respects both statistical efficiency and human testing experience."))
)
)
)
)
)
})
# Server-side toggle observers
observeEvent(input$toggle_faq_1, {
shinyjs::toggle("faq_answer_1", anim = TRUE, animType = "slide")
})
observeEvent(input$toggle_faq_2, {
shinyjs::toggle("faq_answer_2", anim = TRUE, animType = "slide")
})
observeEvent(input$toggle_faq_3, {
shinyjs::toggle("faq_answer_3", anim = TRUE, animType = "slide")
})
observeEvent(input$toggle_faq_4, {
shinyjs::toggle("faq_answer_4", anim = TRUE, animType = "slide")
})
observeEvent(input$toggle_faq_5, {
shinyjs::toggle("faq_answer_5", anim = TRUE, animType = "slide")
})
observeEvent(input$toggle_faq_6, {
shinyjs::toggle("faq_answer_6", anim = TRUE, animType = "slide")
})
observeEvent(input$toggle_faq_7, {
shinyjs::toggle("faq_answer_7", anim = TRUE, animType = "slide")
})
observeEvent(input$toggle_faq_8, {
shinyjs::toggle("faq_answer_8", anim = TRUE, animType = "slide")
})
# FAQ Content Renderers - ALL CONTENT PRESERVED
output$faq_content_1 <- renderUI({
div(
style = "background: #E8F4FD; border-left: 4px solid #4A90E2; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "Can SEM increase when a new item is added?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p(strong("Yes, SEM can increase when a new item is added"), ", and this is an important phenomenon in computerized adaptive testing (CAT)."),
p(strong("1. Mismatched Item Difficulty")),
tags$ul(
tags$li("A new item with difficulty far from the ability estimate has low information."),
tags$li("The information hole at the current theta becomes larger."),
tags$li("Total information at that point becomes relatively smaller.")
),
p(strong("2. Poor Item Quality")),
tags$ul(
tags$li("Low discrimination (a parameter)."),
tags$li("High guessing (c parameter)."),
tags$li("These items provide minimal information even when matched.")
),
p(strong("3. EAP Estimation Update")),
tags$ul(
tags$li("A new response shifts the EAP θ̂ estimate."),
tags$li("SEM is computed at the updated theta value."),
tags$li("If this region has lower TIF, SEM increases.")
),
h4(strong("Mathematical Foundation")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #4A90E2;",
HTML("\\[ SEM(\\theta) = \\frac{1}{\\sqrt{TIF(\\theta)}} \\] \\[ TIF(\\theta) = \\sum_i I_i(\\theta) \\]")
),
p(strong("When item k plus 1 is added:")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #4A90E2;",
HTML("\\[ TIF_{new}(\\theta) = TIF_{old}(\\theta) + I_{k+1}(\\theta) \\]")
),
p(strong("SEM increases when:")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #4A90E2;",
HTML("\\[ I_{k+1}(\\theta) \\approx 0 \\quad \\text{or} \\quad TIF_{new}(\\theta) < TIF_{old}(\\theta) \\]")
),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("In this simulator:"),
tags$ul(
tags$li("Maximum information selection with an unexpected response can shift theta substantially."),
tags$li("Random selection may produce badly matched items."),
tags$li("Low discrimination items contribute almost no information.")
)
),
div(
style = "background: #d1ecf1; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #0dcaf0;",
h5("Practical Implications"),
p(strong("CAT algorithms"), " avoid SEM spikes by selecting high information items."),
p(strong("Fixed form tests"), " cannot adapt to responses, so SEM may fluctuate as items are added."),
p("Measurement precision does not always improve monotonically with more items.")
),
p("This demonstrates the importance of ", strong("item selection strategy"), " in adaptive testing.")
)
)
)
)
})
output$faq_content_2 <- renderUI({
div(
style = "background: #F0F8FF; border-left: 4px solid #87CEEB; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "Do examinee responses factor into information computation?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p("No, examinee responses do ", strong("not"), " directly factor into item information computation in IRT."),
p("Item information depends only on ", strong("item parameters"), " and the current ", strong("theta"), "."),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #87CEEB;",
HTML("\\[ I_i(\\theta) = \\left[ \\frac{a_i^2 \\cdot \\big(1 - P_i(\\theta)\\big)}{P_i(\\theta)} \\right] \\cdot \\left[ \\frac{\\big(P_i(\\theta) - c_i\\big)^2}{(1 - c_i)^2} \\right] \\]")
),
p("where:"),
tags$ul(
tags$li(HTML("<strong>\\(a_i, b_i, c_i\\)</strong> are fixed item parameters.")),
tags$li(HTML("<strong>\\(\\theta\\)</strong> is the current ability estimate.")),
tags$li(HTML("<strong>\\(P_i(\\theta)\\)</strong> is the predicted probability of success at \\(\\theta\\)."))
),
h4(strong("Why Responses Do Not Affect Information")),
p(strong("1. Information is a property of the item")),
tags$ul(
tags$li("Information reflects the measurement precision provided by the item."),
tags$li("It depends on discrimination and the model based probability function."),
tags$li("The item information curve is fixed after calibration.")
),
p(strong("2. Responses affect ability estimation, not the curve itself")),
tags$ul(
tags$li("Responses shift the estimated ability value."),
tags$li("This changes where on the information curve we evaluate the item."),
tags$li("However, the shape and height of the curve remain unchanged.")
),
div(
style = "background: #e8f4fd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #0d6efd;",
strong("Example:"),
" A high discrimination item with a = 2 has high information at \\(\\theta = 0.5\\) whether the examinee answers correctly or not. The response changes the estimated ability, not the item information function."
),
h4(strong("What Happens in CAT")),
tags$ul(
tags$li(strong("Step 1:"), " Compute information for each candidate item at the current theta."),
tags$li(strong("Step 2:"), " Select the item with maximum information."),
tags$li(strong("Step 3:"), " Administer the item and record the response."),
tags$li(strong("Step 4:"), " Update the ability estimate using the response and the item parameters."),
tags$li(strong("Step 5:"), " Repeat with the new theta, recomputing information and selecting the next item.")
),
h4(strong("Indirect Effects Through Ability Updates")),
p("Responses do not change item information directly, but they ", strong("indirectly"), " influence which items are selected by shifting the ability estimate."),
tags$ul(
tags$li("Unexpected responses can cause large shifts in the estimated ability."),
tags$li("This moves the evaluation point to a different region of the item information curves."),
tags$li("Different items may now maximize information at the new theta.")
),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("In the simulator:"),
tags$ul(
tags$li("Information values for an item change only when theta changes."),
tags$li("The same item always has the same information at the same theta."),
tags$li("Information computation uses only item parameters and the current theta.")
)
),
h4(strong("Classical Test Theory versus IRT")),
p(strong("Classical Test Theory (CTT)")),
p("In CTT, responses indirectly affect information because item level statistics are computed from actual response data."),
tags$ul(
tags$li("Item discrimination, such as r point biserial or item total correlation, is computed from observed responses."),
tags$li("Item information indices, such as using \\(I = r^2\\) or contributions to reliability, are functions of these sample based statistics."),
tags$li("Therefore, item information changes if the response patterns in the sample change.")
),
p("CTT item information is empirical and depends on the specific response data set."),
p(strong("Item Response Theory (IRT)")),
p("In IRT, item information is a mathematical function of item parameters and ability."),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #87CEEB;",
HTML("\\[ I(\\theta) = a^2 \\cdot P(\\theta) \\cdot \\big(1 - P(\\theta)\\big) \\]")
),
tags$ul(
tags$li("It depends on item parameters such as \\(a, b, c, d\\) and the chosen IRT model."),
tags$li("These parameters are fixed once they are estimated during calibration."),
tags$li("Specific examinee responses do not change the item information function once parameters are set.")
),
p("IRT item information is model based and independent of any particular response pattern, given a calibrated item."),
h4(strong("Practical Implications")),
tags$ul(
tags$li("Item calibration must use sufficiently large samples to obtain stable parameters."),
tags$li("CAT efficiency depends strongly on accurate item parameters."),
tags$li("Response patterns influence measurement through updated ability estimates, not through changes to item information functions.")
)
)
)
)
)
})
output$faq_content_3 <- renderUI({
div(
style = "background: #F5F0FF; border-left: 4px solid #9370DB; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "Why does EAP θ̂ estimation stabilize around true theta even with random item selection?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p(strong("EAP θ̂ stabilization occurs due to the Bayesian nature of the estimator and the Law of Large Numbers, even when items are selected at random.")),
h4(strong("1. Bayesian Foundation of EAP")),
p("Expected a posteriori (EAP) θ̂ estimation combines the likelihood with a prior distribution."),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #9370DB;",
HTML("\\[ \\text{Posterior} \\propto \\text{Likelihood} \\times \\text{Prior} \\] \\[ \\hat{\\theta}_{EAP} = E[\\theta \\mid \\text{responses}] = \\int \\theta \\cdot \\pi(\\theta \\mid \\text{responses}) \\, d\\theta \\]")
),
p(strong("The prior as an anchor:")),
tags$ul(
tags$li("EAP starts from a prior, often \\(N(0, 1)\\)."),
tags$li("With few items, the prior prevents extreme or unstable estimates."),
tags$li("As more data accumulate, the likelihood dominates and the influence of the prior fades.")
),
h4(strong("2. How Random Items Provide Information")),
p("Even when items are sampled randomly from the pool, the pattern of responses still carries information about the true ability level."),
p(strong("For a high ability examinee, for example theta equal to 1.5:")),
tags$ul(
tags$li("Easy items tend to be answered correctly with very high probability."),
tags$li("Medium difficulty items tend to be answered correctly with moderately high probability."),
tags$li("Hard items have lower but still non zero probability of correct response.")
),
p("The overall pattern across many random items forms a response profile that is most compatible with the true theta."),
h4(strong("3. Law of Large Numbers in Action")),
p("With random item selection, each examinee receives a random sample of items from the pool. As the number of items increases, the observed response pattern converges to its expected pattern at the true theta."),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #9370DB;",
HTML("\\[ L(\\theta \\mid \\text{responses}) = \\prod_i P_i(\\theta)^{u_i} \\cdot \\big(1 - P_i(\\theta)\\big)^{1 - u_i} \\]")
),
p(strong("Convergence intuition:")),
tags$ul(
tags$li("At low theta values, the model predicts too many failures for a high ability examinee."),
tags$li("At high theta values, the model predicts too many successes."),
tags$li("At the true theta, the likelihood is largest because predicted probabilities best match the observed response pattern.")
),
h4(strong("4. Contrast with Maximum Information Selection")),
div(
style = "background: #d1ecf1; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #0dcaf0;",
p(strong("Random selection with EAP:")),
tags$ul(
tags$li("Stabilizes through consistency and large sample behavior."),
tags$li("Less efficient and usually requires more items."),
tags$li("Posterior credible intervals are wider for a given test length.")
),
p(strong("Maximum information selection with MLE or EAP:")),
tags$ul(
tags$li("Stabilizes more quickly by targeting the region of highest information."),
tags$li("More efficient and needs fewer items for similar precision."),
tags$li("Posterior intervals or standard errors are tighter.")
)
),
h4(strong("5. Mathematical Guarantees")),
p("EAP θ̂ is a consistent estimator under standard regularity conditions."),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #9370DB;",
HTML("\\[ \\lim_{n \\to \\infty} P\\big( \\big| \\hat{\\theta}_{EAP} - \\theta_{true} \\big| > \\varepsilon \\big) = 0 \\]")
),
p("This property holds regardless of the item selection method, although the ", strong("rate of convergence"), " depends strongly on how informative the items are."),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("In this simulator:"),
tags$ul(
tags$li("You can run multiple CAT sessions with random item selection."),
tags$li("Estimates eventually stabilize near the true theta, although more items are required compared to maximum information selection."),
tags$li("You can compare the speed of convergence and the resulting SEM under different selection rules.")
)
),
h4(strong("6. Practical Implications")),
tags$ul(
tags$li("Item selection strategy affects efficiency, not the theoretical consistency of EAP."),
tags$li("Random selection may be useful when item exposure control is critical."),
tags$li("EAP provides robustness against early poor item matches by combining prior and likelihood."),
tags$li("The trade off is between speed of convergence and control over item usage.")
),
p("This illustrates that any sufficiently large random sample of items from a calibrated pool can recover an examinee ability level, thanks to the combination of Bayesian estimation and large sample theory.")
)
)
)
)
})
output$faq_content_4 <- renderUI({
div(
style = "background: #F0FFF0; border-left: 4px solid #32CD32; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "What is the difference between SEM (precision) and bias (accuracy)?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p(strong("SEM and bias measure fundamentally different aspects of estimation quality."), " Understanding this distinction is crucial for interpreting CAT results."),
h4(strong("Precision versus Accuracy")),
tags$ul(
tags$li(strong("SEM (Standard Error of Measurement):"), " Measures ", em("precision"), " - how consistent or reproducible the estimates are across repeated measurements."),
tags$li(strong("Bias:"), " Measures ", em("accuracy"), " - how close the estimates are to the true value on average.")
),
h4(strong("The Archery Target Analogy")),
div(
style = "text-align: center; margin: 20px 0; padding: 15px; background: #f8f9fa; border-radius: 8px;",
p(em("Four scenarios of precision vs accuracy:"), style = "font-weight: 600; margin-bottom: 15px;"),
div(
style = "display: grid; grid-template-columns: 1fr 1fr; gap: 10px; text-align: left;",
div(style = "padding: 10px; background: #fff3cd; border-radius: 6px;", strong("High SEM, High Bias:"), " Arrows scattered far from bullseye - inconsistent and inaccurate"),
div(style = "padding: 10px; background: #f8d7da; border-radius: 6px;", strong("Low SEM, High Bias:"), " Arrows clustered tightly but off-target - precise but wrong"),
div(style = "padding: 10px; background: #d1ecf1; border-radius: 6px;", strong("High SEM, Low Bias:"), " Arrows scattered widely around bullseye - accurate on average but unreliable"),
div(style = "padding: 10px; background: #d4edda; border-radius: 6px;", strong("Low SEM, Low Bias:"), " Arrows clustered in bullseye - ideal measurement")
)
),
h4(strong("Why This Matters in CAT")),
p("A CAT can achieve low SEM by:"),
tags$ul(
tags$li("Selecting highly informative items at the current theta estimate"),
tags$li("Using items with high discrimination parameters"),
tags$li("Matching item difficulty to ability level")
),
p("But systematic bias can still occur due to:"),
tags$ul(
tags$li("Poorly calibrated item parameters"),
tags$li("Model misspecification"),
tags$li("Prior distribution influence in Bayesian estimation"),
tags$li("Item exposure control constraints")
),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("Key Insight:"),
p("Low SEM tells you the test is giving a ", strong("consistent"), " answer, but it doesn't guarantee that answer is ", strong("correct"), ". Always examine both precision and accuracy metrics.")
)
)
)
)
)
})
output$faq_content_5 <- renderUI({
div(
style = "background: #FFF8F0; border-left: 4px solid #FFA500; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "Why can bias persist even with long tests and low SEM?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p(strong("Bias often stems from systematic errors that don't diminish with more items,"), " while SEM reflects random error that decreases with test length."),
h4(strong("1. Model Misspecification")),
p("The 3PL model makes strong assumptions:"),
tags$ul(
tags$li("Specific logistic functional form"),
tags$li("Local independence"),
tags$li("Correct discrimination, difficulty, and guessing parameters")
),
p("If reality deviates from these assumptions, systematic bias persists regardless of test length."),
h4(strong("2. Item Parameter Estimation Error")),
p("In operational CAT, item parameters come from calibration samples:"),
tags$ul(
tags$li("Calibration errors become built-in systematic bias"),
tags$li("Giving more items to one examinee doesn't fix calibration errors"),
tags$li("SEM decreases with more items, but bias remains constant")
),
h4(strong("3. Prior Influence in EAP θ̂ Estimation")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #FFA500;",
HTML("\\[ \\text{Posterior} \\propto \\text{Likelihood} \\times \\text{Prior} \\]")
),
p("Even with many items, the prior distribution (often N(0,1)) can:"),
tags$ul(
tags$li("Pull extreme ability estimates toward the mean"),
tags$li("Create systematic bias at scale boundaries"),
tags$li("Prevent complete convergence to true values")
),
h4(strong("4. Boundary and Scale Effects")),
p("Practical implementations often impose limits:"),
div(
style = "background: #263238; color: #ECEFF1; padding: 12px; margin: 15px 0; border-radius: 6px; font-family: 'Courier New', monospace; font-size: 13px;",
"theta_hat <- pmin(4, pmax(-4, eap_estimate)) # Common bounds"
),
p("This creates systematic bias for examinees near the scale extremes."),
h4(strong("5. Mathematical Foundation: Bias-Variance Decomposition")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #FFA500;",
HTML("\\[ \\text{MSE} = \\text{Bias}^2 + \\text{Variance} \\] \\[ \\text{Variance} \\approx \\text{SEM}^2 \\]")
),
p("As test length increases:"),
tags$ul(
tags$li(strong("Variance"), " decreases (SEM gets smaller)"),
tags$li(strong("Bias²"), " remains constant if caused by systematic errors"),
tags$li("Thus, MSE is dominated by bias for long tests")
),
h4(strong("6. Guessing Parameter Asymmetry")),
p("The 3PL guessing parameter creates information asymmetry:"),
tags$ul(
tags$li("Low-ability examinees have probability floor at c-parameter"),
tags$li("Reduces information and creates bias patterns at lower end"),
tags$li("Effects persist regardless of test length")
),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("Theoretical Insight:"),
p("Under model misspecification, estimators converge to ", em("pseudo-true values"), " that minimize KL divergence, not necessarily the true theta values.")
),
h4(strong("Practical Implications")),
tags$ul(
tags$li("Bias monitoring requires separate procedures from precision monitoring"),
tags$li("Item pool design must address both precision and accuracy"),
tags$li("Post-hoc linking and equating often needed to correct systematic biases"),
tags$li("CAT termination should consider both SEM and bias thresholds in critical score regions")
),
p("This explains why sophisticated CAT systems implement ", strong("bias detection and correction procedures"), " alongside precision-based termination rules.")
)
)
)
)
})
output$faq_content_6 <- renderUI({
div(
style = "background: #FFF0F5; border-left: 4px solid #FF69B4; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "How does the prior distribution affect EAP θ̂ estimation, and what are the mathematical consequences?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p(strong("The prior in EAP θ̂ estimation serves as a regularization term that affects both bias and variance, with mathematical trade-offs.")),
h4(strong("EAP as a Shrinkage Estimator:")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #FF69B4;",
HTML("\\[ \\hat{\\theta}_{EAP} = \\displaystyle\\frac{\\displaystyle\\int \\theta \\cdot L(\\theta) \\cdot \\pi(\\theta) \\: d\\theta}{\\displaystyle\\int L(\\theta) \\cdot \\pi(\\theta) \\: d\\theta} \\]")
),
p("For normal prior N(μ_p, σ_p^2) and approximate normal likelihood N(μ_l, σ_l^2):"),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #FF69B4;",
HTML("\\[ \\hat{\\theta}_{EAP} \\approx \\frac{\\sigma_l^2}{\\sigma_p^2 + \\sigma_l^2} \\mu_p + \\frac{\\sigma_p^2}{\\sigma_p^2 + \\sigma_l^2} \\mu_l \\]")
),
h4(strong("Mathematical Effects:")),
p(strong("1. Bias-Variance Tradeoff")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #FF69B4;",
HTML("\\[ \\text{Bias} = E[\\hat{\\theta} - \\theta] \\approx \\displaystyle\\frac{\\sigma_l^2}{\\sigma_p^2 + \\sigma_l^2} (\\mu_p - \\theta) \\] \\[ \\text{Variance} \\approx \\displaystyle\\frac{\\sigma_p^2 \\cdot \\sigma_l^2}{\\sigma_p^2 + \\sigma_l^2} \\]")
),
p(strong("2. Small Sample Behavior")),
tags$ul(
tags$li("With few items: \\(\\sigma_l^2\\) large, EAP θ̂ ≈ μ_p (strong prior influence)"),
tags$li("With many items: \\(\\sigma_l^2\\) small, EAP θ̂ ≈ μ_l (likelihood dominates)"),
tags$li("The transition depends on relative precisions")
),
p(strong("3. Boundary Effects")),
p("With bounded integration (e.g., -4 to +4):"),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #FF69B4;",
HTML("\\[ \\hat{\\theta}_{EAP} = \\displaystyle\\frac{\\displaystyle\\int_{-4}^{4} \\theta \\cdot L(\\theta) \\cdot \\pi(\\theta) \\: d\\theta}{\\displaystyle\\int_{-4}^{4} L(\\theta) \\cdot \\pi(\\theta) \\: d\\theta} \\]")
),
p("This creates systematic bias when true θ is near the boundaries."),
h4(strong("Optimal Prior Selection:")),
p("The 'best' prior depends on the population:"),
tags$ul(
tags$li("N(0,1) works well for standardized populations"),
tags$li("Informative priors can reduce bias if population parameters are known"),
tags$li("Very diffuse priors approach MLE behavior but lose regularization benefits")
),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("Theoretical Insight:"),
p("EAP minimizes Bayes risk under squared error loss, but this comes with guaranteed bias when the prior mean differs from the true population mean.")
)
)
)
)
)
})
output$faq_content_7 <- renderUI({
div(
style = "background: #F0F8FF; border-left: 4px solid #4682B4; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "Does increasing the item pool size reduce bias in CAT or fixed-form tests?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p(strong("Increasing the pool size can reduce bias, but only under specific conditions."), " It helps when the original pool lacks good coverage around the true ability level, but it does not fix all sources of bias."),
h4(strong("1. When a Larger Pool Helps")),
p("Bias is often driven by poor matching between item difficulty and examinee ability."),
tags$ul(
tags$li("If the pool has too few items with difficulty near the true theta, the test is forced to use off-target items."),
tags$li("Off-target items provide less information and pull the estimate toward the prior or toward regions with better coverage."),
tags$li("Adding more well-calibrated items with b values around the target θ increases local test information and can reduce bias.")
),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #4682B4;",
HTML("\\[ TIF(\\theta) = \\sum_{i \\in \\text{pool}} I_i(\\theta) \\]")
),
p("A larger pool can increase ", strong("TIF(θ) in the region of interest"), " if the additional items are well targeted."),
h4(strong("2. When a Larger Pool Does Not Help")),
p("Simply adding more items does not guarantee lower bias."),
tags$ul(
tags$li("If the new items have the same poor difficulty distribution (e.g., all very easy or very hard), coverage around the true theta does not improve."),
tags$li("Bias from model misspecification, mis-calibrated item parameters, or a misspecified prior will persist even with a very large pool."),
tags$li("In random fixed-form selection, a larger pool with the same parameter distribution does not systematically reduce bias for a single examinee.")
),
h4(strong("3. Pool Size versus Pool Quality")),
tags$ul(
tags$li(strong("Pool size"), " controls how many items are available."),
tags$li(strong("Pool quality and coverage"), " control how well the test can represent different theta regions."),
tags$li("For bias reduction, increasing pool size is useful only when it increases the density of high-quality items near the ability levels of interest.")
),
div(
style = "background: #d1ecf1; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #0dcaf0;",
p(strong("Random selection:"), " A larger pool with the same parameter distribution mainly affects item exposure and content variety, not bias at the individual level."),
p(strong("Information-based CAT selection:"), " A larger, well-targeted pool gives the algorithm more options to choose high-information, well-matched items, which can reduce bias and SEM simultaneously.")
),
h4(strong("4. Practical Implications for This Simulator")),
tags$ul(
tags$li("Expanding the pool is most useful when you add items that fill gaps in the difficulty continuum around θ = 0, ±1, ±2, etc."),
tags$li("Monitoring bias as a function of true theta and pool design is as important as monitoring SEM."),
tags$li("Pool design should focus first on balanced coverage and realistic a/c parameters; pool size is helpful once those foundations are in place.")
),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("Key Takeaway:"),
p("Increasing item pool size can reduce bias ", strong("only when it improves difficulty coverage and item quality"), ". It does not automatically fix bias caused by model misspecification, poor priors, or calibration errors.")
)
)
)
)
)
})
output$faq_content_8 <- renderUI({
div(
style = "background: #E8F4FD; border-left: 4px solid #4A90E2; padding: 15px 20px; margin: 0; border-radius: 0 0 8px 8px;",
h4(style = "margin: 0 0 10px 0; color: #2c3e50;", "Why does Random (Fixed-form) stabilize while MFI (CAT) fluctuates?"),
div(
style = "background: white; padding: 20px; border-radius: 8px; margin-top: 10px; box-shadow: 0 2px 4px rgba(0,0,0,0.1);",
withMathJax(
tagList(
p(strong("This is expected behavior due to fundamental differences between fixed-form and adaptive testing methodologies.")),
p(strong("1. Fixed-form Testing (Random Selection)")),
tags$ul(
tags$li("All respondents receive the same predetermined set of items"),
tags$li("Measurement precision (SEM/TIF) remains constant throughout"),
tags$li("Once enough items are answered, estimates converge and stabilize"),
tags$li("No adaptation means no feedback loops causing fluctuations")
),
p(strong("2. Computerized Adaptive Testing (MFI Selection)")),
tags$ul(
tags$li("Each item is dynamically selected based on current ability estimate"),
tags$li("Creates a continuous feedback loop: θ → item → θ → item"),
tags$li("Maximum Fisher Information targeting constantly shifts optimal items"),
tags$li("Early items cause large θ jumps; later items cause fine-tuning oscillations")
),
h4(strong("Mathematical Differences")),
div(
style = "background: #f8f9fa; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #4A90E2;",
HTML("\\[ \\text{Fixed-form: } \\theta_{k+1} = f(\\theta_k, \\text{fixed items}) \\]"),
HTML("\\[ \\text{CAT (MFI): } \\theta_{k+1} = f(\\theta_k, I_{k+1}(\\theta_k)) \\]"),
HTML("\\[ \\text{where } I_{k+1}(\\theta_k) = \\max_b I(\\theta_k, b) \\]")
),
p(strong("Why MFI Naturally Fluctuates:")),
tags$ul(
tags$li(strong("Estimation Refinement:"), " Early rapid estimation followed by gradual fine-tuning"),
tags$li(strong("Boundary Effects:"), " Limited optimal items when θ approaches bank boundaries"),
tags$li(strong("Response Sensitivity:"), " Single unexpected response can significantly shift θ estimate"),
tags$li(strong("Information Targeting:"), " Different items become optimal as θ estimate changes")
),
div(
style = "background: #fff3cd; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #ffc107;",
strong("Visualization of the Process:"),
tags$ul(
tags$li("Fixed-form: θ → Items → θ → Items → θ → STABLE"),
tags$li("CAT: θ → Adapt → θ → Adapt → θ → FLUCTUATING"),
tags$li("The adaptation in CAT creates natural oscillation as it hones in on true ability")
)
),
div(
style = "background: #d1ecf1; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #0dcaf0;",
h5("This Fluctuation is Actually Desirable"),
p(strong("Early fluctuation"), " indicates rapid initial ability estimation"),
p(strong("Middle fluctuation"), " shows the refinement process working"),
p(strong("Late fluctuation"), " represents fine-tuning near true ability level"),
p("CAT achieves higher precision with fewer items by continuing to adapt, while fixed-form stabilizes earlier but may be less precise overall.")
),
div(
style = "background: #e8f5e8; padding: 15px; margin: 15px 0; border-radius: 8px; border-left: 4px solid #28a745;",
h5("In This Simulator:"),
tags$ul(
tags$li("Random selection shows how traditional tests behave"),
tags$li("MFI demonstrates real adaptive testing dynamics"),
tags$li("The fluctuations you see are characteristic of working CAT algorithms"),
tags$li("This is why bias detection waits until SEM target is met - to ensure meaningful stabilization patterns")
)
),
p("The difference highlights the trade-off between ", strong("estimation stability"), " in fixed-form tests and ", strong("measurement efficiency"), " in adaptive tests.")
)
)
)
)
})
output$code_content <- renderUI({
tagList(
# Add CSS styles
tags$style(HTML("
/* Main Grid Layout */
.algorithms-grid {
display: grid;
grid-template-columns: repeat(auto-fit, minmax(500px, 1fr));
gap: 1.5rem;
padding: 1rem;
}
/* Algorithm Panel Base */
.algorithm-panel {
background: white;
border-radius: 12px;
box-shadow: 0 4px 20px rgba(0, 0, 0, 0.08);
border: 1px solid #e1e5e9;
overflow: hidden;
transition: all 0.3s cubic-bezier(0.4, 0, 0.2, 1);
position: relative;
}
.algorithm-panel:hover {
transform: translateY(-4px);
box-shadow: 0 8px 30px rgba(0, 0, 0, 0.12);
}
/* Panel Header */
.panel-header {
display: flex;
align-items: center;
gap: 0.75rem;
padding: 1.25rem 1.5rem;
background: linear-gradient(135deg, #f8fafc 0%, #f1f5f9 100%);
border-bottom: 1px solid #e2e8f0;
}
.panel-icon {
font-size: 1.25rem;
color: #3b82f6;
width: 24px;
text-align: center;
}
.panel-header h3 {
margin: 0;
font-size: 1.1rem;
font-weight: 700;
color: #1e293b;
flex: 1;
}
.algorithm-badge {
background: linear-gradient(135deg, #3b82f6, #6366f1);
color: white;
padding: 0.25rem 0.75rem;
border-radius: 20px;
font-size: 0.75rem;
font-weight: 600;
text-transform: uppercase;
letter-spacing: 0.5px;
}
/* Pseudo Code Container */
.pseudo-code {
padding: 1.5rem;
background: #1a1b26;
border-radius: 0 0 12px 12px;
position: relative;
}
/* Method Tabs */
.method-tabs {
display: flex;
flex-direction: column;
gap: 0.5rem;
}
.method-tab {
background: #1a1b26;
border-radius: 8px;
overflow: hidden;
border: 1px solid #2a2b3a;
transition: all 0.2s ease;
}
.method-tab.active {
border-color: #3b82f6;
box-shadow: 0 0 0 1px #3b82f6;
}
.method-tab:not(.active):hover {
border-color: #4b5563;
}
.tab-header {
padding: 0.75rem 1rem;
background: #252631;
color: #e2e8f0;
font-weight: 600;
font-size: 0.9rem;
border-bottom: 1px solid #2a2b3a;
}
/* Panel-specific accent colors */
.eap-panel .panel-icon { color: #10b981; }
.eap-panel .algorithm-badge { background: linear-gradient(135deg, #10b981, #059669); }
.ipl-panel .panel-icon { color: #f59e0b; }
.ipl-panel .algorithm-badge { background: linear-gradient(135deg, #f59e0b, #d97706); }
.cat-panel .panel-icon { color: #ef4444; }
.cat-panel .algorithm-badge { background: linear-gradient(135deg, #ef4444, #dc2626); }
.selection-panel .panel-icon { color: #8b5cf6; }
.selection-panel .algorithm-badge { background: linear-gradient(135deg, #8b5cf6, #7c3aed); }
.response-panel .panel-icon { color: #06b6d4; }
.response-panel .algorithm-badge { background: linear-gradient(135deg, #06b6d4, #0891b2); }
.info-panel .panel-icon { color: #f97316; }
.info-panel .algorithm-badge { background: linear-gradient(135deg, #f97316, #ea580c); }
/* Code Block Improvements */
.code-block {
font-family: 'Fira Code', 'Monaco', 'Cascadia Code', monospace;
font-size: 0.85rem;
line-height: 1.5;
color: #c0caf5;
background: transparent !important;
border: none !important;
padding: 0 !important;
margin: 0 !important;
}
.code-block .keyword { color: #bb9af7; font-weight: 600; }
.code-block .function { color: #7dcfff; }
.code-block .string { color: #9ece6a; }
.code-block .comment { color: #565f89; font-style: italic; }
.code-block .number { color: #ff9e64; }
.code-block .operator { color: #89ddff; }
.code-block .type { color: #2ac3de; }
.code-block .variable { color: #c0caf5; }
/* Responsive Design */
@media (max-width: 768px) {
.algorithms-grid {
grid-template-columns: 1fr;
gap: 1rem;
padding: 0.5rem;
}
.panel-header {
padding: 1rem;
}
.pseudo-code {
padding: 1rem;
}
}
")),
# Main Container
div(
id = "cat-algorithms-container",
class = "algorithms-grid",
# Algorithm 1 - EAP Estimation
div(
class = "algorithm-panel eap-panel",
`data-algorithm` = "eap-estimation",
div(
class = "panel-header",
h3("EAP θ Estimation"),
span(class = "algorithm-badge", "Bayesian")
),
div(
class = "pseudo-code",
code_block("
PROCEDURE EstimateThetaEAP(items, responses, prior)
INPUT:
• items: list with {a, b, c} parameters
• responses: binary vector [0,1]
• prior: {mean, sd}
IF Empty(items) OR Empty(responses):
RETURN prior.mean
n ← Min(Length(items), Length(responses))
nodes ← GaussHermiteNodes()
weights ← GaussHermiteWeights()
theta_nodes ← prior.mean + prior.sd * √2 * nodes
FOR i ← 1 TO n:
p ← P_3PL(theta_nodes, items[i].a, items[i].b, items[i].c)
IF responses[i] = 1:
likelihood[,i] ← p
ELSE:
likelihood[,i] ← 1 - p
joint_likelihood ← Product(likelihood, axis=1)
posterior ← joint_likelihood * weights
posterior ← posterior / Sum(posterior)
theta_estimate ← Sum(posterior * theta_nodes)
RETURN Clamp(theta_estimate, -4, 4)
END PROCEDURE
")
)
),
# Algorithm 2 - 3PL Model
div(
class = "algorithm-panel ipl-panel",
`data-algorithm` = "three-pl-model",
div(
class = "panel-header",
h3("3PL IRT Model"),
span(class = "algorithm-badge", "Core")
),
div(
class = "pseudo-code",
code_block("
FUNCTION P_3PL(θ, a, b, c)
// Item Response Function
a ← Max(a, 0.1) // Min discrimination
c ← Clamp(c, 0.0, 0.3) // Guessing bounds
exponent ← -1.702 * a * (θ - b)
p ← c + (1 - c) / (1 + Exp(exponent))
RETURN Clamp(p, 1e-10, 1-1e-10)
END FUNCTION
FUNCTION I_3PL(θ, a, b, c)
// Fisher Information Function
P ← P_3PL(θ, a, b, c)
denominator ← Max(1 - c, 1e-10)
P_prime ← (1.702 * a / denominator) * (P - c) * (1 - P)
information ← (P_prime²) / Max(P * (1 - P), 1e-10)
RETURN IfFinite(information, 0)
END FUNCTION
")
)
),
# Algorithm 3 - CAT Engine
div(
class = "algorithm-panel cat-panel",
`data-algorithm` = "cat-engine",
div(
class = "panel-header",
icon("rocket", class = "panel-icon"), # Changed to more dynamic icon
h3("CAT Administration Engine"),
span(class = "algorithm-badge", "Main Loop")
),
div(
class = "pseudo-code",
code_block("
PROCEDURE RunCAT(pool, θ_true, config)
// Configuration: {se_target, max_items, method}
administered ← []
responses ← []
θ_current ← 0
se_current ← ∞
// Initial Item
item ← SelectInitialItem(pool)
response ← GenerateResponse(θ_true, item)
administered.Push(item)
responses.Push(response)
// Adaptive Loop
WHILE Length(responses) < config.max_items
AND se_current > config.se_target:
θ_current ← EstimateThetaEAP(administered, responses)
information ← ComputeTotalInformation(θ_current, administered)
se_current ← 1 / √information
IF se_current ≤ config.se_target: BREAK
item ← SelectItem(pool, config.method, θ_current, administered)
response ← GenerateResponse(θ_true, item)
administered.Push(item)
responses.Push(response)
RETURN {
theta: θ_current,
se: se_current,
length: Length(responses),
items: administered
}
END PROCEDURE
")
)
),
# Algorithm 4 - Selection Methods (Full Width)
div(
class = "algorithm-panel selection-panel",
style = "grid-column: 1 / -1;", # Make this span full width
`data-algorithm` = "selection-methods",
div(
class = "panel-header",
h3("Item Selection Methods"),
span(class = "algorithm-badge", "Multi-Method")
),
div(
class = "method-tabs",
# MFI Tab
div(
class = "method-tab active",
`data-method` = "mfi",
div(class = "tab-header", "Maximum Fisher Information"),
code_block("
FUNCTION SelectMFI(pool, θ, administered)
available ← pool - administered
best_info ← -∞
best_item ← null
FOR item IN available:
info ← I_3PL(θ, item.a, item.b, item.c)
IF info > best_info:
best_info ← info
best_item ← item
RETURN best_item
END FUNCTION
")
),
# Randomesque Tab
div(
class = "method-tab",
`data-method` = "randomesque",
div(class = "tab-header", "Randomesque (Top-K)"),
code_block("
FUNCTION SelectRandomesque(pool, θ, administered, k=5)
available ← pool - administered
info_scores ← []
FOR item IN available:
info ← I_3PL(θ, item.a, item.b, item.c)
info_scores.Append({item, info})
SortDescending(info_scores, by=info)
top_k ← First(k, info_scores)
RETURN RandomChoice(top_k).item
END FUNCTION
")
),
# Sympson-Hetter Tab
div(
class = "method-tab",
`data-method` = "sympson-hetter",
div(class = "tab-header", "Sympson-Hetter Control"),
code_block("
FUNCTION SelectSH(pool, θ, administered, exposure_counts)
available ← pool - administered
sorted_items ← SortByInformation(available, θ)
FOR item IN sorted_items:
exposure_rate ← exposure_counts[item.id] / total_tests
r ← RandomUniform()
IF r ≤ item.K_parameter:
RETURN item
RETURN sorted_items[0] // Fallback
END FUNCTION
PROCEDURE CalibrateSHParameters(pool, target_exposure=0.2)
FOR item IN pool: item.K ← 1.0
FOR sim ← 1 TO 1000:
θ ← RandomNormal()
test_items ← RunCAT(pool, θ, 'mfi')
UpdateExposureCounts(test_items)
FOR item IN pool:
exposure ← exposure_counts[item.id] / 1000
IF exposure > target_exposure:
item.K ← item.K * (target_exposure / exposure)
END PROCEDURE
")
)
)
),
# Algorithm 5 - Response System
div(
class = "algorithm-panel response-panel",
`data-algorithm` = "response-system",
div(
class = "panel-header",
h3("Response Generation"),
span(class = "algorithm-badge", "Simulation")
),
div(
class = "pseudo-code",
code_block("
FUNCTION GenerateResponse(θ_true, item)
p_correct ← P_3PL(θ_true, item.a, item.b, item.c)
u ← RandomUniform(0, 1)
RETURN IF u < p_correct THEN 1 ELSE 0
END FUNCTION
FUNCTION SimulateTestSession(θ_true, pool, config)
results ← RunCAT(pool, θ_true, config)
RETURN {
estimated_theta: results.theta,
true_theta: θ_true,
bias: results.theta - θ_true,
sem: results.se,
items_used: results.length
}
END FUNCTION
")
)
),
# Algorithm 6 - Information System
div(
class = "algorithm-panel info-panel",
`data-algorithm` = "information-system",
div(
class = "panel-header",
h3("Information & Precision"),
span(class = "algorithm-badge", "Metrics")
),
div(
class = "pseudo-code",
code_block("
FUNCTION ComputeTestInformation(θ, administered_items)
total_info ← 0
FOR item IN administered_items:
total_info ← total_info + I_3PL(θ, item.a, item.b, item.c)
RETURN total_info
END FUNCTION
FUNCTION ComputeStandardError(θ, administered_items)
total_info ← ComputeTestInformation(θ, administered_items)
IF total_info < 1e-12:
RETURN ∞
ELSE:
RETURN 1 / √total_info
END FUNCTION
FUNCTION ComputeTestReliability(θ, administered_items)
sem ← ComputeStandardError(θ, administered_items)
RETURN 1 - sem² // Assuming unit variance
END FUNCTION
")
)
)
)
)
})
# Helper function for code blocks
code_block <- function(text) {
div(
class = "code-container",
tags$pre(
class = "pseudo-code-block",
text
)
)
}
# ---------- Item pool quality metrics (reactive) ----------
pool_quality <- reactive({
pool <- item_pool()
if (is.null(pool))
return(NULL)
th_grid <- seq(-3, 3, by = 0.05)
# Pool-wide TIF (no administered subset)
tif_pool <- rowSums(sapply(seq_len(nrow(pool)), function(i) {
I_3pl(th_grid, pool$a[i], pool$b[i], pool$c[i])
}))
sem_pool <- ifelse(tif_pool > 0, 1 / sqrt(tif_pool), NA_real_)
# Quality bands for discrimination
qa <- c(
above_2_5 = sum(pool$a > 2.5),
very_high = sum(pool$a >= 2.0 & pool$a <= 2.5),
high = sum(pool$a >= 1.5 & pool$a < 2.0),
medium = sum(pool$a >= 1.0 & pool$a < 1.5),
low = sum(pool$a >= 0.5 & pool$a < 1.0),
very_low = sum(pool$a < 0.5)
)
# Coverage bands for difficulty
qb_center <- sum(abs(pool$b) <= 0.5)
qb_moder <- sum(abs(pool$b) > 0.5 & abs(pool$b) <= 1.5)
qb_outer <- sum(abs(pool$b) > 1.5)
# Information at theta = 0 (per item)
info_at0 <- mapply(I_3pl, 0, pool$a, pool$b, pool$c)
info_at0[!is.finite(info_at0)] <- 0
ord <- order(info_at0, decreasing = TRUE)
top10_mean <- mean(info_at0[head(ord, 10)])
info_at0_stats <- c(
median = unname(stats::median(info_at0)),
q25 = unname(stats::quantile(info_at0, 0.25)),
q75 = unname(stats::quantile(info_at0, 0.75)),
top10_mean = top10_mean,
cov_b1 = 100 * mean(abs(pool$b) <= 1),
cov_b2 = 100 * mean(abs(pool$b) <= 2)
)
list(
th_grid = th_grid,
tif_pool = tif_pool,
sem_pool = sem_pool,
qa = qa,
qb = c(
center = qb_center,
moderate = qb_moder,
outer = qb_outer
),
c_stats = c(
mean = mean(pool$c),
q50 = median(pool$c),
min = min(pool$c),
max = max(pool$c)
),
info_at0 = info_at0,
info_at0_stats = info_at0_stats
)
})
#==============================================
# ---- Pool Quality Metrics UI ----
#==============================================
output$pool_quality_metrics <- renderUI({
pq <- pool_quality()
req(pq)
# Administered items
admin_items <- items()
has_admin <- !is.null(admin_items) && nrow(admin_items) > 0
qa <- pq$qa
qb <- pq$qb
c_stats <- pq$c_stats
info_stats <- pq$info_at0_stats
# Pool-level means
avg_info_pool <- mean(pq$info_at0)
mean_difficulty_pool <- mean(item_pool()$b)
mean_discrimination_pool <- mean(item_pool()$a)
# Information at current theta
current_theta <- eap_theta()
pool_info_current <- mapply(
I_3pl,
current_theta,
item_pool()$a,
item_pool()$b,
item_pool()$c
)
pool_info_current[!is.finite(pool_info_current)] <- 0
avg_info_pool_current <- mean(pool_info_current)
if (has_admin) {
admin_info_current <- mapply(
I_3pl,
current_theta,
admin_items$a,
admin_items$b,
admin_items$c
)
admin_info_current[!is.finite(admin_info_current)] <- 0
avg_info_admin_current <- mean(admin_info_current)
admin_info_at0 <- mapply(
I_3pl,
0,
admin_items$a,
admin_items$b,
admin_items$c
)
admin_info_at0[!is.finite(admin_info_at0)] <- 0
avg_info_admin_at0 <- mean(admin_info_at0)
mean_difficulty_admin <- mean(admin_items$b)
mean_discrimination_admin <- mean(admin_items$a)
mean_guessing_admin <- mean(admin_items$c)
}
# HTML OUTPUT:
HTML(paste0('
<div class="metrics-container">
<!-- TOP SECTION: Pool Information Summary -->
<div class="top-section">
<div class="pool-summary">
<div class="summary-title">Pool Information Summary</div>
<div class="summary-content">
<div class="summary-item">
<span>Max TIF:</span>
<strong>', sprintf("%.2f", max(pq$tif_pool)), '</strong>
</div>
<div class="summary-item">
<span>Min SEM:</span>
<strong>', sprintf("%.3f", min(pq$sem_pool, na.rm=TRUE)), '</strong>
</div>
<div class="summary-item">
<span>Pool Items:</span>
<strong>', nrow(item_pool()), '</strong>
</div>
</div>
</div>
</div>
<!-- BOTTOM SECTION: All metrics in 2 columns -->
<div class="bottom-section">
<div class="left-column">
<!-- Discrimination Quality -->
<div class="metric-box">
<div class="metric-title">Discrimination (a) Quality</div>
<div class="metric-content">
<div class="metric-row">
<span>Excellent (>2.5):</span>
<strong>', qa["above_2_5"], '</strong>
</div>
<div class="metric-row">
<span>Very High (2.0–2.5):</span>
<strong>', qa["very_high"], '</strong>
</div>
<div class="metric-row">
<span>High (1.5–2.0):</span>
<strong>', qa["high"], '</strong>
</div>
<div class="metric-row">
<span>Medium (1.0–1.5):</span>
<strong>', qa["medium"], '</strong>
</div>
<div class="metric-row">
<span>Low (0.5–1.0):</span>
<strong>', qa["low"], '</strong>
</div>
<div class="metric-row">
<span>Very Low (<0.5):</span>
<strong>', qa["very_low"], '</strong>
</div>
</div>
</div>
<!-- Difficulty Coverage -->
<div class="metric-box">
<div class="metric-title">Difficulty (b) Coverage</div>
<div class="metric-content">
<div class="metric-row">
<span>Center (|b| ≤ 0.5):</span>
<strong>', qb["center"], '</strong>
</div>
<div class="metric-row">
<span>Moderate (0.5 < |b| ≤ 1.5):</span>
<strong>', qb["moderate"], '</strong>
</div>
<div class="metric-row">
<span>Outer (|b| > 1.5):</span>
<strong>', qb["outer"], '</strong>
</div>
<div class="metric-row">
<span>Coverage (|b| ≤ 1):</span>
<strong>', sprintf("%.1f%%", info_stats["cov_b1"]), '</strong>
</div>
<div class="metric-row">
<span>Coverage (|b| ≤ 2):</span>
<strong>', sprintf("%.1f%%", info_stats["cov_b2"]), '</strong>
</div>
</div>
</div>
<!-- Guessing Statistics -->
<div class="metric-box">
<div class="metric-title">Guessing (c) Statistics</div>
<div class="metric-content">
<div class="metric-row">
<span>Pool Mean:</span>
<strong>', sprintf("%.3f", c_stats["mean"]), '</strong>
</div>',
if (has_admin) {
paste0('
<div class="metric-row">
<span>Admin Mean:</span>
<strong>', sprintf("%.3f", mean_guessing_admin), '</strong>
</div>')
} else {
'
<div class="metric-row">
<span>Admin Mean:</span>
<strong>-</strong>
</div>'
}, '
<div class="metric-row">
<span>Minimum:</span>
<strong>', sprintf("%.3f", c_stats["min"]), '</strong>
</div>
<div class="metric-row">
<span>Maximum:</span>
<strong>', sprintf("%.3f", c_stats["max"]), '</strong>
</div>',
if (has_admin) {
paste0('
<div class="metric-row">
<span>Admin Min:</span>
<strong>', sprintf("%.3f", min(admin_items$c)), '</strong>
</div>
<div class="metric-row">
<span>Admin Max:</span>
<strong>', sprintf("%.3f", max(admin_items$c)), '</strong>
</div>')
} else {
''
}, '
</div>
</div>
</div>
<div class="right-column">
<!-- Discrimination Statistics -->
<div class="metric-box">
<div class="metric-title">Discrimination (a) Statistics</div>
<div class="metric-content">
<div class="metric-row">
<span>Pool Mean:</span>
<strong>', sprintf("%.2f", mean_discrimination_pool), '</strong>
</div>',
if (has_admin) {
paste0('
<div class="metric-row">
<span>Admin Mean:</span>
<strong>', sprintf("%.2f", mean_discrimination_admin), '</strong>
</div>')
} else {
'
<div class="metric-row">
<span>Admin Mean:</span>
<strong>-</strong>
</div>'
}, '
<div class="metric-row">
<span>Minimum:</span>
<strong>', sprintf("%.2f", min(item_pool()$a)), '</strong>
</div>
<div class="metric-row">
<span>Maximum:</span>
<strong>', sprintf("%.2f", max(item_pool()$a)), '</strong>
</div>',
if (has_admin) {
paste0('
<div class="metric-row">
<span>Admin Min:</span>
<strong>', sprintf("%.2f", min(admin_items$a)), '</strong>
</div>
<div class="metric-row">
<span>Admin Max:</span>
<strong>', sprintf("%.2f", max(admin_items$a)), '</strong>
</div>')
} else {
''
}, '
</div>
</div>
<!-- Difficulty Statistics -->
<div class="metric-box">
<div class="metric-title">Difficulty (b) Statistics</div>
<div class="metric-content">
<div class="metric-row">
<span>Pool Mean:</span>
<strong>', sprintf("%.2f", mean_difficulty_pool), '</strong>
</div>',
if (has_admin) {
paste0('
<div class="metric-row">
<span>Admin Mean:</span>
<strong>', sprintf("%.2f", mean_difficulty_admin), '</strong>
</div>')
} else {
'
<div class="metric-row">
<span>Admin Mean:</span>
<strong>-</strong>
</div>'
}, '
<div class="metric-row">
<span>Minimum:</span>
<strong>', sprintf("%.2f", min(item_pool()$b)), '</strong>
</div>
<div class="metric-row">
<span>Maximum:</span>
<strong>', sprintf("%.2f", max(item_pool()$b)), '</strong>
</div>',
if (has_admin) {
paste0('
<div class="metric-row">
<span>Admin Min:</span>
<strong>', sprintf("%.2f", min(admin_items$b)), '</strong>
</div>
<div class="metric-row">
<span>Admin Max:</span>
<strong>', sprintf("%.2f", max(admin_items$b)), '</strong>
</div>')
} else {
''
}, '
</div>
</div>
<!-- Average Item Information -->
<div class="metric-box">
<div class="metric-title">Average Item Information</div>
<div class="metric-content">
<div class="metric-row">
<span>Pool @ θ = 0:</span>
<strong>', sprintf("%.3f", avg_info_pool), '</strong>
</div>
<div class="metric-row">
<span>Pool @ current θ:</span>
<strong>', sprintf("%.3f", avg_info_pool_current), '</strong>
</div>',
if (has_admin) {
paste0('
<div class="metric-row">
<span>Admin @ θ = 0:</span>
<strong>', sprintf("%.3f", avg_info_admin_at0), '</strong>
</div>
<div class="metric-row">
<span>Admin @ current θ:</span>
<strong>', sprintf("%.3f", avg_info_admin_current), '</strong>
</div>')
} else {
'
<div class="metric-row">
<span>Admin @ θ = 0:</span>
<strong>-</strong>
</div>
<div class="metric-row">
<span>Admin @ current θ:</span>
<strong>-</strong>
</div>'
}, '
<div class="metric-row">
<span>Admin Items:</span>
<strong>', if(has_admin) nrow(admin_items) else "0", '</strong>
</div>
</div>
</div>
</div>
</div>
</div>
<style>
.metrics-container {
max-width: 1200px;
margin: 0 auto;
font-family: Arial, sans-serif;
display: flex;
flex-direction: column;
gap: 20px;
}
.top-section {
width: 100%;
}
.pool-summary {
background: #f8f9fa;
border: 1px solid #e9ecef;
border-radius: 8px;
padding: 16px;
width: 100%;
}
.summary-title {
font-weight: 600;
color: #1e3a8a;
margin-bottom: 12px;
font-size: 16px;
}
.summary-content {
display: grid;
grid-template-columns: repeat(3, 1fr);
gap: 12px;
}
.summary-item {
background: white;
padding: 12px;
border-radius: 6px;
display: flex;
justify-content: space-between;
align-items: center;
border: 1px solid #e9ecef;
}
.bottom-section {
display: grid;
grid-template-columns: 1fr 1fr;
gap: 20px;
width: 100%;
}
.left-column, .right-column {
display: flex;
flex-direction: column;
gap: 20px;
}
.metric-box {
background: white;
border: 1px solid #e9ecef;
border-radius: 8px;
padding: 16px;
box-shadow: 0 1px 3px rgba(0,0,0,0.1);
}
.metric-title {
font-weight: 600;
color: #1e3a8a;
margin-bottom: 12px;
font-size: 14px;
}
.metric-content {
display: flex;
flex-direction: column;
gap: 8px;
}
.metric-row {
display: flex;
justify-content: space-between;
align-items: center;
font-size: 13px;
color: #4b5563;
}
.metric-row strong {
color: #1e3a8a;
font-weight: 600;
}
</style>
'))
}) # <-- CLOSING BRACKET FOR renderUI
#==============================================
# ---- POOL METRICS ----
#==============================================
create_gradient_fill <- function(x, y_upper, y_lower, col, alpha = 0.3) {
polygon(c(x, rev(x)), c(y_upper, rev(y_lower)),
col = adjustcolor(col, alpha.f = alpha), border = NA)
}
output$pool_plot_a <- renderPlot({
pool <- item_pool()
req(pool, nrow(pool) > 0)
# Get administered items for comparison
admin_items <- items()
has_admin <- !is.null(admin_items) && nrow(admin_items) > 0
tryCatch({
# Increase top margin for title and legend space
par(mar = c(4, 4, 6, 4), mgp = c(2, 0.7, 0))
# Calculate common bin breaks for both datasets
all_a <- pool$a
if(has_admin) all_a <- c(all_a, admin_items$a)
breaks <- seq(min(all_a), max(all_a), length.out = 21) # 20 bins
# Plot pool distribution
h_pool <- hist(pool$a, breaks = breaks, plot = FALSE)
h_admin <- if(has_admin) hist(admin_items$a, breaks = breaks, plot = FALSE) else NULL
# Calculate ranges - secondary axis gets smaller range
ylim_primary <- c(0, max(h_pool$counts) * 1.05)
if(has_admin) {
# Scale secondary axis to be 0-50% of primary axis range
admin_max <- max(h_admin$counts)
scale_factor <- (max(h_pool$counts) * 0.5) / admin_max
ylim_secondary <- c(0, admin_max * scale_factor)
}
# Enhanced color scheme - BLUE for pool
pool_color <- "#3498db" # Vibrant blue
pool_fill <- "#3498db33" # Semi-transparent blue
pool_axis_color <- "#3498db" # Blue for pool axis
pool_mean_color <- "#2980b9" # Darker blue for pool mean line
admin_color <- "#e74c3c" # Vibrant red for admin
admin_fill <- "#e74c3c66" # Semi-transparent red
grid_color <- "#ecf0f1" # Light gray grid
# Plot pool histogram (primary axis) - BLUE theme
plot(h_pool, col = pool_fill, border = pool_color, lwd = 1.5,
main = "",
xlab = "Discrimination Parameter (a)",
ylab = "Pool Frequency",
ylim = ylim_primary,
cex.main = 1.0, cex.axis = 0.8, cex.lab = 0.9,
font.lab = 2, col.lab = pool_color, col.axis = pool_color, # BLUE axis labels
axes = FALSE) # Turn off default axes
# Add custom BLUE axes
axis(1, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
axis(2, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
# Add grid for better readability
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Add title with blue accent
title("Discrimination Parameter Distribution",
line = 3, cex.main = 1.1, font.main = 2, col.main = pool_color) # BLUE title
# Add administered items overlay (secondary axis)
if(has_admin) {
par(new = TRUE)
plot(h_admin, col = admin_fill, border = admin_color, lwd = 1.5,
axes = FALSE, xlab = "", ylab = "", main = "",
ylim = ylim_secondary)
axis(4, cex.axis = 0.8, col.axis = admin_color, col = admin_color, lwd = 2)
mtext("Administered Frequency", side = 4, line = 2.5,
cex = 0.85, col = admin_color, font = 2)
}
# Enhanced mean lines - BLUE for pool mean
abline(v = mean(pool$a), col = pool_mean_color, lwd = 3, lty = "solid")
# Enhanced legend with BLUE pool elements
legend_text <- c(
paste("Pool Mean: ", round(mean(pool$a), 3)),
paste("Pool Items: ", nrow(pool))
)
legend_colors <- c(pool_mean_color, NA) # BLUE for pool mean
legend_lty <- c("solid", NA)
legend_lwd <- c(3, NA)
if(has_admin) {
abline(v = mean(admin_items$a), col = admin_color, lwd = 3, lty = "solid")
legend_text <- c(
legend_text,
paste("Admin Mean: ", round(mean(admin_items$a), 3)),
paste("Admin Items: ", nrow(admin_items))
)
legend_colors <- c(legend_colors, admin_color, NA)
legend_lty <- c(legend_lty, "solid", NA)
legend_lwd <- c(legend_lwd, 3, NA)
}
# Add legend with BLUE pool styling
legend("top", legend = legend_text,
col = legend_colors,
lwd = legend_lwd,
lty = legend_lty,
bty = "n",
cex = 0.75,
horiz = TRUE,
xpd = TRUE,
text.col = c(pool_mean_color, pool_color, admin_color, admin_color), # BLUE text for pool
inset = c(0, -0.1), # More negative to push legend lower
x.intersp = 0.8,
seg.len = 1.5)
# Add subtle statistics in the plot area - BLUE for pool
text(x = max(all_a) * 0.7, y = max(ylim_primary) * 0.9,
labels = paste("Pool SD: ", round(sd(pool$a), 3)),
col = pool_color, cex = 0.7, font = 3, adj = 0) # BLUE text
if(has_admin) {
text(x = max(all_a) * 0.7, y = max(ylim_primary) * 0.8,
labels = paste("Admin SD: ", round(sd(admin_items$a), 3)),
col = admin_color, cex = 0.7, font = 3, adj = 0) # RED text for admin
}
}, error = function(e) {
# Enhanced error plot
par(mar = c(2, 2, 2, 2))
plot(1, 1, type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", main = "")
rect(0.2, 0.4, 0.8, 0.6, col = "#f8d7da", border = "#f5c6cb")
text(0.5, 0.5, "Data Not Available", col = "#721c24", cex = 1.2, font = 2)
text(0.5, 0.3, "Please check data source", col = "#856404", cex = 0.8)
})
}) # <-- CLOSING BRACKET FOR pool_plot_a
output$pool_plot_b <- renderPlot({
pool <- item_pool()
req(pool, nrow(pool) > 0)
# Get administered items for comparison
admin_items <- items()
has_admin <- !is.null(admin_items) && nrow(admin_items) > 0
tryCatch({
# Increase top margin for title and legend space
par(mar = c(4, 4, 6, 4), mgp = c(2, 0.7, 0))
# Calculate common bin breaks for both datasets
all_b <- pool$b
if(has_admin) all_b <- c(all_b, admin_items$b)
breaks <- seq(min(all_b), max(all_b), length.out = 21) # 20 bins
# Plot pool distribution
h_pool <- hist(pool$b, breaks = breaks, plot = FALSE)
h_admin <- if(has_admin) hist(admin_items$b, breaks = breaks, plot = FALSE) else NULL
# Calculate ranges - secondary axis gets smaller range
ylim_primary <- c(0, max(h_pool$counts) * 1.05)
if(has_admin) {
# Scale secondary axis to be 0-50% of primary axis range
admin_max <- max(h_admin$counts)
scale_factor <- (max(h_pool$counts) * 0.5) / admin_max
ylim_secondary <- c(0, admin_max * scale_factor)
}
# Enhanced color scheme - BLUE for pool
pool_color <- "#3498db" # Vibrant blue
pool_fill <- "#3498db33" # Semi-transparent blue
pool_axis_color <- "#3498db" # Blue for pool axis
pool_mean_color <- "#2980b9" # Darker blue for pool mean line
admin_color <- "#e74c3c" # Vibrant red for admin
admin_fill <- "#e74c3c66" # Semi-transparent red
grid_color <- "#ecf0f1" # Light gray grid
# Plot pool histogram (primary axis) - BLUE theme
plot(h_pool, col = pool_fill, border = pool_color, lwd = 1.5,
main = "",
xlab = "Difficulty Parameter (b)",
ylab = "Pool Frequency",
ylim = ylim_primary,
cex.main = 1.0, cex.axis = 0.8, cex.lab = 0.9,
font.lab = 2, col.lab = pool_color, col.axis = pool_color,
axes = FALSE)
# Add custom BLUE axes
axis(1, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
axis(2, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
# Add grid for better readability
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Add title with blue accent
title("Difficulty Parameter Distribution",
line = 3, cex.main = 1.1, font.main = 2, col.main = pool_color)
# Add administered items overlay (secondary axis)
if(has_admin) {
par(new = TRUE)
plot(h_admin, col = admin_fill, border = admin_color, lwd = 1.5,
axes = FALSE, xlab = "", ylab = "", main = "",
ylim = ylim_secondary)
axis(4, cex.axis = 0.8, col.axis = admin_color, col = admin_color, lwd = 2)
mtext("Administered Frequency", side = 4, line = 2.5,
cex = 0.85, col = admin_color, font = 2)
}
# Enhanced mean lines - BLUE for pool mean
abline(v = mean(pool$b), col = pool_mean_color, lwd = 3, lty = "solid")
# Enhanced legend with BLUE pool elements
legend_text <- c(
paste("Pool Mean: ", round(mean(pool$b), 3)),
paste("Pool Items: ", nrow(pool))
)
legend_colors <- c(pool_mean_color, NA)
legend_lty <- c("solid", NA)
legend_lwd <- c(3, NA)
if(has_admin) {
abline(v = mean(admin_items$b), col = admin_color, lwd = 3, lty = "solid")
legend_text <- c(
legend_text,
paste("Admin Mean: ", round(mean(admin_items$b), 3)),
paste("Admin Items: ", nrow(admin_items))
)
legend_colors <- c(legend_colors, admin_color, NA)
legend_lty <- c(legend_lty, "solid", NA)
legend_lwd <- c(legend_lwd, 3, NA)
}
# Add legend with BLUE pool styling
legend("top", legend = legend_text,
col = legend_colors,
lwd = legend_lwd,
lty = legend_lty,
bty = "n",
cex = 0.75,
horiz = TRUE,
xpd = TRUE,
text.col = c(pool_mean_color, pool_color, admin_color, admin_color),
inset = c(0, -0.1),
x.intersp = 0.8,
seg.len = 1.5)
# Add subtle statistics in the plot area - BLUE for pool
text(x = max(all_b) * 0.7, y = max(ylim_primary) * 0.9,
labels = paste("Pool SD: ", round(sd(pool$b), 3)),
col = pool_color, cex = 0.7, font = 3, adj = 0)
if(has_admin) {
text(x = max(all_b) * 0.7, y = max(ylim_primary) * 0.8,
labels = paste("Admin SD: ", round(sd(admin_items$b), 3)),
col = admin_color, cex = 0.7, font = 3, adj = 0)
}
}, error = function(e) {
par(mar = c(2, 2, 2, 2))
plot(1, 1, type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", main = "")
rect(0.2, 0.4, 0.8, 0.6, col = "#f8d7da", border = "#f5c6cb")
text(0.5, 0.5, "Data Not Available", col = "#721c24", cex = 1.2, font = 2)
text(0.5, 0.3, "Please check data source", col = "#856404", cex = 0.8)
})
}) # <-- CLOSING BRACKET FOR pool_plot_b
output$pool_plot_c <- renderPlot({
pool <- item_pool()
req(pool, nrow(pool) > 0)
# Get administered items for comparison
admin_items <- items()
has_admin <- !is.null(admin_items) && nrow(admin_items) > 0
tryCatch({
# Increase top margin for title and legend space
par(mar = c(4, 4, 6, 4), mgp = c(2, 0.7, 0))
# Calculate common bin breaks for both datasets
all_c <- pool$c
if(has_admin) all_c <- c(all_c, admin_items$c)
breaks <- seq(min(all_c), max(all_c), length.out = 16) # 15 bins
# Plot pool distribution
h_pool <- hist(pool$c, breaks = breaks, plot = FALSE)
h_admin <- if(has_admin) hist(admin_items$c, breaks = breaks, plot = FALSE) else NULL
# Calculate ranges - secondary axis gets smaller range
ylim_primary <- c(0, max(h_pool$counts) * 1.05)
if(has_admin) {
# Scale secondary axis to be 0-50% of primary axis range
admin_max <- max(h_admin$counts)
scale_factor <- (max(h_pool$counts) * 0.5) / admin_max
ylim_secondary <- c(0, admin_max * scale_factor)
}
# Enhanced color scheme - BLUE for pool
pool_color <- "#3498db" # Vibrant blue
pool_fill <- "#3498db33" # Semi-transparent blue
pool_axis_color <- "#3498db" # Blue for pool axis
pool_mean_color <- "#2980b9" # Darker blue for pool mean line
admin_color <- "#e74c3c" # Vibrant red for admin
admin_fill <- "#e74c3c66" # Semi-transparent red
grid_color <- "#ecf0f1" # Light gray grid
# Plot pool histogram (primary axis) - BLUE theme
plot(h_pool, col = pool_fill, border = pool_color, lwd = 1.5,
main = "",
xlab = "Guessing Parameter (c)",
ylab = "Pool Frequency",
ylim = ylim_primary,
cex.main = 1.0, cex.axis = 0.8, cex.lab = 0.9,
font.lab = 2, col.lab = pool_color, col.axis = pool_color,
axes = FALSE)
# Add custom BLUE axes
axis(1, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
axis(2, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
# Add grid for better readability
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Add title with blue accent
title("Guessing Parameter Distribution",
line = 3, cex.main = 1.1, font.main = 2, col.main = pool_color)
# Add administered items overlay (secondary axis)
if(has_admin) {
par(new = TRUE)
plot(h_admin, col = admin_fill, border = admin_color, lwd = 1.5,
axes = FALSE, xlab = "", ylab = "", main = "",
ylim = ylim_secondary)
axis(4, cex.axis = 0.8, col.axis = admin_color, col = admin_color, lwd = 2)
mtext("Administered Frequency", side = 4, line = 2.5,
cex = 0.85, col = admin_color, font = 2)
}
# Enhanced mean lines - BLUE for pool mean
abline(v = mean(pool$c), col = pool_mean_color, lwd = 3, lty = "solid")
# Enhanced legend with BLUE pool elements
legend_text <- c(
paste("Pool Mean: ", round(mean(pool$c), 3)),
paste("Pool Items: ", nrow(pool))
)
legend_colors <- c(pool_mean_color, NA)
legend_lty <- c("solid", NA)
legend_lwd <- c(3, NA)
if(has_admin) {
abline(v = mean(admin_items$c), col = admin_color, lwd = 3, lty = "solid")
legend_text <- c(
legend_text,
paste("Admin Mean: ", round(mean(admin_items$c), 3)),
paste("Admin Items: ", nrow(admin_items))
)
legend_colors <- c(legend_colors, admin_color, NA)
legend_lty <- c(legend_lty, "solid", NA)
legend_lwd <- c(legend_lwd, 3, NA)
}
# Add legend with BLUE pool styling
legend("top", legend = legend_text,
col = legend_colors,
lwd = legend_lwd,
lty = legend_lty,
bty = "n",
cex = 0.75,
horiz = TRUE,
xpd = TRUE,
text.col = c(pool_mean_color, pool_color, admin_color, admin_color),
inset = c(0, -0.1),
x.intersp = 0.8,
seg.len = 1.5)
# Add subtle statistics in the plot area - BLUE for pool
text(x = max(all_c) * 0.7, y = max(ylim_primary) * 0.9,
labels = paste("Pool SD: ", round(sd(pool$c), 3)),
col = pool_color, cex = 0.7, font = 3, adj = 0)
if(has_admin) {
text(x = max(all_c) * 0.7, y = max(ylim_primary) * 0.8,
labels = paste("Admin SD: ", round(sd(admin_items$c), 3)),
col = admin_color, cex = 0.7, font = 3, adj = 0)
}
}, error = function(e) {
par(mar = c(2, 2, 2, 2))
plot(1, 1, type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", main = "")
rect(0.2, 0.4, 0.8, 0.6, col = "#f8d7da", border = "#f5c6cb")
text(0.5, 0.5, "Data Not Available", col = "#721c24", cex = 1.2, font = 2)
text(0.5, 0.3, "Please check data source", col = "#856404", cex = 0.8)
})
}) # <-- CLOSING BRACKET FOR pool_plot_c
output$pool_plot_info0 <- renderPlot({
pool <- item_pool()
req(pool, nrow(pool) > 0)
# Get administered items for comparison
admin_items <- items()
has_admin <- !is.null(admin_items) && nrow(admin_items) > 0
tryCatch({
# Calculate information at theta = 0 for pool
info_at0_pool <- mapply(I_3pl, 0, pool$a, pool$b, pool$c)
info_at0_pool[!is.finite(info_at0_pool)] <- 0
# Calculate information at theta = 0 for administered items
if(has_admin) {
info_at0_admin <- mapply(I_3pl, 0, admin_items$a, admin_items$b, admin_items$c)
info_at0_admin[!is.finite(info_at0_admin)] <- 0
}
# Enhanced color scheme
pool_color <- "#3498db" # Vibrant blue
admin_color <- "#e74c3c" # Vibrant red
pool_fill <- "#3498db33" # Semi-transparent blue
admin_fill <- "#e74c3c66" # Semi-transparent red
grid_color <- "#ecf0f1" # Light gray grid
# SAME WIDTH as other plots - consistent margin
par(mar = c(4, 4, 6, 4), mgp = c(2, 0.7, 0))
if(has_admin) {
# Calculate appropriate y-axis ranges for each
pool_ylim <- c(0, max(info_at0_pool, na.rm = TRUE) * 1.05)
admin_ylim <- c(0, max(info_at0_admin, na.rm = TRUE) * 1.05)
# SAME WIDTH x-axis limits as other plots
xlim <- c(0.5, 2.5) # Consistent with other plots
# Plot Pool boxplot (left axis) - SAME WIDTH but EXTRA WIDE boxes
boxplot(info_at0_pool,
main = "",
ylab = "",
col = pool_fill,
border = pool_color,
lwd = 2,
cex.axis = 0.8, cex.lab = 0.9,
ylim = pool_ylim,
axes = FALSE,
at = 1, # Position at x=1
boxwex = 0.8, # EXTRA WIDE box width but same overall plot width
xlim = xlim) # Consistent x-axis limits
# Add custom BLUE axes
axis(1, at = 1:2, labels = c("Item Pool", "Administered"),
col = "black", col.axis = "black", col.ticks = "black", lwd = 2)
axis(2, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
# Add y-axis label for pool
mtext("Pool Information", side = 2, line = 2.5,
cex = 0.85, col = pool_color, font = 2)
# Add grid for better readability
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Add title with blue accent - SAME as other plots
title("Fisher Information Comparison @ θ = 0",
line = 3, cex.main = 1.1, font.main = 2, col.main = pool_color)
# Add Administered boxplot with secondary axis - SAME WIDTH but EXTRA WIDE boxes
par(new = TRUE)
boxplot(info_at0_admin,
main = "",
ylab = "",
col = admin_fill,
border = admin_color,
lwd = 2,
cex.axis = 0.8, cex.lab = 0.9,
ylim = admin_ylim,
axes = FALSE,
at = 2, # Position at x=2
boxwex = 0.8, # EXTRA WIDE box width but same overall plot width
xlim = xlim) # Consistent x-axis limits
# Add right axis (Admin - RED) with its own scale
axis(4, cex.axis = 0.8, col.axis = admin_color, col = admin_color, lwd = 2)
mtext("Administered Information", side = 4, line = 2.5,
cex = 0.85, col = admin_color, font = 2)
# Add mean points - larger for extra wide boxes
points(1, mean(info_at0_pool), pch = 23, bg = pool_color, col = "white", cex = 2.0, lwd = 2)
points(2, mean(info_at0_admin), pch = 23, bg = admin_color, col = "white", cex = 2.0, lwd = 2)
} else {
# Only pool data available - SAME WIDTH as other single plots but EXTRA WIDE box
xlim <- c(0.5, 1.5) # Consistent with other single plots
boxplot(info_at0_pool,
main = "",
ylab = "Fisher Information",
col = pool_fill,
border = pool_color,
lwd = 2,
cex.axis = 0.8, cex.lab = 0.9,
xlab = "Item Pool",
axes = FALSE,
xlim = xlim, # Consistent x-axis limits
boxwex = 0.8) # EXTRA WIDE box width but same overall plot width
# Add custom BLUE axes
axis(1, at = 1, labels = "Item Pool",
col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
axis(2, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
# Add grid for better readability
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Add title with blue accent - SAME as other plots
title("Fisher Information @ θ = 0",
line = 3, cex.main = 1.1, font.main = 2, col.main = pool_color)
points(1, mean(info_at0_pool), pch = 23, bg = pool_color, col = "white", cex = 2.0, lwd = 2)
}
# Enhanced legend with SD values included - SAME as other plots
legend_text <- c(
paste("Pool: μ=", round(mean(info_at0_pool), 3),
" σ=", round(sd(info_at0_pool), 3))
)
legend_colors <- c(pool_color)
legend_pch <- c(23)
if(has_admin) {
legend_text <- c(
legend_text,
paste("Admin: μ=", round(mean(info_at0_admin), 3),
" σ=", round(sd(info_at0_admin), 3))
)
legend_colors <- c(legend_colors, admin_color)
legend_pch <- c(legend_pch, 23)
}
# Add legend with matching positioning and styling - SAME as other plots
legend("top", legend = legend_text,
col = legend_colors,
pch = legend_pch,
pt.bg = legend_colors,
pt.cex = 1.5,
pt.lwd = 2,
bty = "n",
cex = 0.75,
horiz = TRUE,
xpd = TRUE,
text.col = legend_colors,
inset = c(0, -0.1),
x.intersp = 0.8)
}, error = function(e) {
# Error plot - SAME as other plots
par(mar = c(2, 2, 2, 2))
plot(1, 1, type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", main = "")
rect(0.2, 0.4, 0.8, 0.6, col = "#f8d7da", border = "#f5c6cb")
text(0.5, 0.5, "Data Not Available", col = "#721c24", cex = 1.2, font = 2)
text(0.5, 0.3, "Please check data source", col = "#856404", cex = 0.8)
})
})
#==============================================
# ---- Optimized TIF and SEM Calculations ----
#==============================================
tif_sem_data <- reactive({
pool <- item_pool()
req(pool, nrow(pool) > 0)
admin_items <- items()
has_admin <- !is.null(admin_items) && nrow(admin_items) > 0
theta_range <- seq(-3, 3, length.out = 50)
# CORRECTED: Vectorized TIF calculation for pool (with D.const)
pool_tif <- sapply(theta_range, function(theta) {
p <- pool$c + (1 - pool$c) / (1 + exp(-D.const * pool$a * (theta - pool$b))) # ← ADDED D.const
q <- 1 - p
sum(pool$a^2 * q * ((p - pool$c)^2 / (p * (1 - pool$c)^2)))
})
pool_sem <- 1 / sqrt(pool_tif)
pool_sem[!is.finite(pool_sem)] <- NA
# CORRECTED: Only calculate admin if needed (with D.const)
if(has_admin) {
admin_tif <- sapply(theta_range, function(theta) {
p <- admin_items$c + (1 - admin_items$c) / (1 + exp(-D.const * admin_items$a * (theta - admin_items$b))) # ← ADDED D.const
q <- 1 - p
sum(admin_items$a^2 * q * ((p - admin_items$c)^2 / (p * (1 - admin_items$c)^2)))
})
admin_sem <- 1 / sqrt(admin_tif)
admin_sem[!is.finite(admin_sem)] <- NA
} else {
admin_tif <- NULL
admin_sem <- NULL
}
list(
theta_range = theta_range,
pool_tif = pool_tif,
pool_sem = pool_sem,
admin_tif = admin_tif,
admin_sem = admin_sem,
has_admin = has_admin
)
})
#==============================================
# ---- TIF Plot with Clean Annotations ----
#==============================================
output$pool_plot_tif <- renderPlot({
data <- tif_sem_data()
req(data)
tryCatch({
theta_range <- data$theta_range
pool_tif <- data$pool_tif
admin_tif <- data$admin_tif
has_admin <- data$has_admin
# Color scheme matching pool_plot_c
pool_color <- "#3498db" # Vibrant blue
admin_color <- "#e74c3c" # Vibrant red
grid_color <- "#ecf0f1" # Light gray grid
current_theta_color <- "#2ecc71" # Green for current theta
# Matching margin and layout
par(mar = c(4, 4, 6, 4), mgp = c(2, 0.7, 0))
# Calculate y-axis ranges
pool_ylim <- c(0, max(pool_tif, na.rm = TRUE) * 1.05)
if(has_admin) {
admin_ylim <- c(0, max(admin_tif, na.rm = TRUE) * 1.05)
}
# Plot Pool TIF (left axis) - matching structure
plot(theta_range, pool_tif, type = "l", lwd = 3, col = pool_color,
main = "",
xlab = "Theta (θ)", ylab = "",
xlim = c(-3, 3), ylim = pool_ylim,
cex.main = 1.0, cex.axis = 0.8, cex.lab = 0.9,
font.lab = 2, col.lab = pool_color,
axes = FALSE)
# Add custom BLUE axes
axis(1, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
axis(2, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
# Add grid for better readability
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Add title with blue accent - matching format
title("Test Information Function (TIF)",
line = 3, cex.main = 1.1, font.main = 2, col.main = pool_color)
# Add y-axis label
mtext("Pool Information", side = 2, line = 2.5,
cex = 0.85, col = pool_color, font = 2)
# Add current theta line and pool point
current_theta <- eap_theta()
if(!is.null(current_theta) && is.finite(current_theta)) {
abline(v = current_theta, col = current_theta_color, lwd = 3, lty = "solid")
# Add pool point at current theta (on pool scale)
closest_idx <- which.min(abs(theta_range - current_theta))
pool_point_y <- pool_tif[closest_idx]
points(current_theta, pool_point_y, pch = 21, bg = pool_color,
cex = 2, col = "white", lwd = 2)
# Annotation next to pool point
text(current_theta + 0.3, pool_point_y,
labels = paste("Pool:", round(pool_point_y, 1)),
col = pool_color, cex = 0.8, font = 2, adj = 0)
}
# Add Administered TIF with its own scale
if(has_admin) {
par(new = TRUE)
plot(theta_range, admin_tif, type = "l", lwd = 3, col = admin_color,
axes = FALSE, xlab = "", ylab = "", main = "",
xlim = c(-3, 3), ylim = admin_ylim)
# Add right axis (Admin - RED) with its own scale
axis(4, cex.axis = 0.8, col.axis = admin_color, col = admin_color, lwd = 2)
mtext("Administered Information", side = 4, line = 2.5,
cex = 0.85, col = admin_color, font = 2)
# Add admin point at current theta (on admin scale)
if(!is.null(current_theta) && is.finite(current_theta)) {
admin_point_y <- admin_tif[closest_idx]
points(current_theta, admin_point_y, pch = 21, bg = admin_color,
cex = 2, col = "white", lwd = 2)
# Annotation next to admin point
text(current_theta - 0.3, admin_point_y,
labels = paste("Admin:", round(admin_point_y, 1)),
col = admin_color, cex = 0.8, font = 2, adj = 1)
}
}
# Enhanced legend - matching pool_plot_c format
legend_text <- c(
"Pool TIF",
"Current Theta"
)
legend_colors <- c(pool_color, current_theta_color)
legend_lty <- c("solid", "solid")
legend_lwd <- c(3, 3)
if(has_admin) {
legend_text <- c(legend_text, "Administered TIF")
legend_colors <- c(legend_colors, admin_color)
legend_lty <- c(legend_lty, "solid")
legend_lwd <- c(legend_lwd, 3)
}
# Add legend with matching positioning and styling
legend("top", legend = legend_text,
col = legend_colors,
lwd = legend_lwd,
lty = legend_lty,
bty = "n",
cex = 0.75,
horiz = TRUE,
xpd = TRUE,
text.col = legend_colors,
inset = c(0, -0.1),
x.intersp = 0.8,
seg.len = 1.5)
}, error = function(e) {
par(mar = c(2, 2, 2, 2))
plot(1, 1, type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", main = "")
rect(0.2, 0.4, 0.8, 0.6, col = "#f8d7da", border = "#f5c6cb")
text(0.5, 0.5, "Data Not Available", col = "#721c24", cex = 1.2, font = 2)
text(0.5, 0.3, "Please check data source", col = "#856404", cex = 0.8)
})
})
#==============================================
# ---- SEM Plot with Clean Annotations ----
#==============================================
output$pool_plot_sem <- renderPlot({
data <- tif_sem_data()
req(data)
tryCatch({
theta_range <- data$theta_range
pool_sem <- data$pool_sem
admin_sem <- data$admin_sem
has_admin <- data$has_admin
# Color scheme matching pool_plot_c
pool_color <- "#3498db" # Vibrant blue
admin_color <- "#e74c3c" # Vibrant red
grid_color <- "#ecf0f1" # Light gray grid
current_theta_color <- "#2ecc71" # Green for current theta
# Matching margin and layout
par(mar = c(4, 4, 6, 4), mgp = c(2, 0.7, 0))
# Calculate appropriate y-axis ranges for each
pool_ylim <- c(0, max(pool_sem, na.rm = TRUE) * 1.05)
if(has_admin) {
# Cap admin ylim at a reasonable maximum for better visualization
admin_max <- max(admin_sem, na.rm = TRUE)
# If admin range is too large, cap it for better visualization
if(admin_max > 100) {
admin_ylim <- c(0, min(admin_max, 1)) # Cap at 1 for readability
} else {
admin_ylim <- c(0, admin_max * 1.05)
}
}
# Plot Pool SEM (left axis) - matching structure
plot(theta_range, pool_sem, type = "l", lwd = 3, col = pool_color,
main = "",
xlab = "Theta (θ)", ylab = "",
xlim = c(-3, 3), ylim = pool_ylim,
cex.main = 1.0, cex.axis = 0.8, cex.lab = 0.9,
font.lab = 2, col.lab = pool_color,
axes = FALSE)
# Add custom BLUE axes
axis(1, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
axis(2, col = pool_color, col.axis = pool_color, col.ticks = pool_color, lwd = 2)
# Add grid for better readability
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Add title with blue accent - matching format
title("Standard Error of Measurement (SEM)",
line = 3, cex.main = 1.1, font.main = 2, col.main = pool_color)
# Add y-axis label
mtext("Pool Standard Error", side = 2, line = 2.5,
cex = 0.85, col = pool_color, font = 2)
# Add current theta line and pool point
current_theta <- eap_theta()
if(!is.null(current_theta) && is.finite(current_theta)) {
abline(v = current_theta, col = current_theta_color, lwd = 3, lty = "solid")
# Add pool point at current theta (on pool scale)
closest_idx <- which.min(abs(theta_range - current_theta))
pool_point_y <- pool_sem[closest_idx]
points(current_theta, pool_point_y, pch = 21, bg = pool_color,
cex = 2, col = "white", lwd = 2)
# Annotation next to pool point
text(current_theta + 0.3, pool_point_y,
labels = paste("Pool:", round(pool_point_y, 3)),
col = pool_color, cex = 0.8, font = 2, adj = 0)
}
# Add Administered SEM with its own scale
if(has_admin) {
par(new = TRUE)
plot(theta_range, admin_sem, type = "l", lwd = 3, col = admin_color,
axes = FALSE, xlab = "", ylab = "", main = "",
xlim = c(-3, 3), ylim = admin_ylim)
# Add right axis (Admin - RED) with its own scale
axis(4, cex.axis = 0.8, col.axis = admin_color, col = admin_color, lwd = 2)
mtext("Administered Standard Error", side = 4, line = 2.5,
cex = 0.85, col = admin_color, font = 2)
# Add admin point at current theta (on admin scale)
if(!is.null(current_theta) && is.finite(current_theta)) {
admin_point_y <- admin_sem[closest_idx]
points(current_theta, admin_point_y, pch = 21, bg = admin_color,
cex = 2, col = "white", lwd = 2)
# Annotation next to admin point
text(current_theta - 0.3, admin_point_y,
labels = paste("Admin:", round(admin_point_y, 3)),
col = admin_color, cex = 0.8, font = 2, adj = 1)
}
# Add note if admin values were capped
if(max(admin_sem, na.rm = TRUE) > admin_ylim[2]) {
legend("bottom", legend = "Note: Admin SEM values capped for visualization",
bty = "n", cex = 0.7, text.col = "darkgray")
}
}
# Enhanced legend - matching pool_plot_c format
legend_text <- c(
"Pool SEM",
"Current Theta"
)
legend_colors <- c(pool_color, current_theta_color)
legend_lty <- c("solid", "solid")
legend_lwd <- c(3, 3)
if(has_admin) {
legend_text <- c(legend_text, "Administered SEM")
legend_colors <- c(legend_colors, admin_color)
legend_lty <- c(legend_lty, "solid")
legend_lwd <- c(legend_lwd, 3)
}
# Add legend with matching positioning and styling
legend("top", legend = legend_text,
col = legend_colors,
lwd = legend_lwd,
lty = legend_lty,
bty = "n",
cex = 0.75,
horiz = TRUE,
xpd = TRUE,
text.col = legend_colors,
inset = c(0, -0.1),
x.intersp = 0.8,
seg.len = 1.5)
}, error = function(e) {
par(mar = c(2, 2, 2, 2))
plot(1, 1, type = "n", xlim = c(0, 1), ylim = c(0, 1),
axes = FALSE, xlab = "", ylab = "", main = "")
rect(0.2, 0.4, 0.8, 0.6, col = "#f8d7da", border = "#f5c6cb")
text(0.5, 0.5, "Data Not Available", col = "#721c24", cex = 1.2, font = 2)
text(0.5, 0.3, "Please check data source", col = "#856404", cex = 0.8)
})
})
#==========================================
#--------- TEST DIAGNOSTICS ---------------
#==========================================
# ------------------------------------------------------------
# 1) Enhanced Theta progression with CI
# ------------------------------------------------------------
output$theta_progression_plot <- renderPlot({
cm <- cumulative_metrics_cache()
req(cm, length(cm) > 0, cancelOutput = TRUE)
tryCatch({
true_theta_val <- true_theta()
n_items <- sapply(cm, `[[`, "items")
theta_est <- sapply(cm, `[[`, "estimated_theta")
sem <- sapply(cm, `[[`, "sem")
ci_up <- theta_est + 1.96 * sem
ci_low <- theta_est - 1.96 * sem
band_w <- 0.30
# Fixed y-axis limits from -3 to 3
ylim <- c(-3, 3)
xlim <- c(0.8, max(n_items) * 1.02)
# Color scheme
theta_color <- "#3498db" # Blue for theta estimate
true_theta_color <- "#e74c3c" # Red for true theta
ci_color <- "#3498db" # Blue for CI
band_color <- "#f39c12" # Orange for tolerance band
grid_color <- "#ecf0f1" # Light gray grid
par(mar = c(5, 4, 6, 2), mgp = c(2, 0.7, 0)) # Increased bottom margin for guide
# Create the main plot
plot(NA, type = "n", xlim = xlim, ylim = ylim,
xlab = "", ylab = "", main = "",
axes = FALSE, frame.plot = FALSE)
# Add axis labels
title(xlab = "Test Step (Items Administered)", col.lab = "black")
title(ylab = expression("Ability Estimate ("*theta*")"), col.lab = "#3498db")
# Add main title with centered legend
title("Theta Estimation Progression with 95% CI", line = 2.5)
legend("top", legend = c("EAP Estimate", "True θ", "95% CI", "±0.3 Band"),
col = c(theta_color, true_theta_color, ci_color, band_color),
lwd = c(2, 2, 8, 2), lty = c("solid", "solid", "solid", "dashed"),
pch = c(21, NA, NA, NA), pt.bg = c("white", NA, NA, NA),
bty = "n", cex = 0.8, ncol = 4, xpd = TRUE, inset = c(0, -0.12))
# Add custom axes
axis(1, col = "black", col.axis = "black", col.ticks = "black", lwd = 1.5)
axis(2, col = theta_color, col.axis = theta_color, col.ticks = theta_color, lwd = 1.5)
# Add grid
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Tolerance band background
band_low <- true_theta_val - band_w
band_high <- true_theta_val + band_w
rect(xlim[1], max(band_low, ylim[1]), xlim[2], min(band_high, ylim[2]),
col = adjustcolor(band_color, alpha.f = 0.15), border = NA)
# Confidence interval
ci_up_clipped <- pmin(ci_up, ylim[2])
ci_low_clipped <- pmax(ci_low, ylim[1])
polygon(c(n_items, rev(n_items)), c(ci_up_clipped, rev(ci_low_clipped)),
col = adjustcolor(ci_color, alpha.f = 0.3), border = NA)
# Reference lines
abline(h = true_theta_val, col = true_theta_color, lwd = 2.5, lty = "solid")
abline(h = true_theta_val + band_w, col = band_color, lwd = 2, lty = "dashed")
abline(h = true_theta_val - band_w, col = band_color, lwd = 2, lty = "dashed")
abline(h = 0, col = "gray50", lwd = 1, lty = "dotted")
# Main trajectory with enhanced points
lines(n_items, theta_est, type = "b", col = theta_color, lwd = 2.5,
pch = 21, bg = "white", cex = 1.2)
# Add final value annotation
if (length(theta_est) > 0) {
final_theta <- tail(theta_est, 1)
final_item <- tail(n_items, 1)
points(final_item, final_theta, pch = 21, bg = theta_color,
col = "white", cex = 2)
TeachingDemos::shadowtext(final_item - 0.25, final_theta + 0.35,
labels = paste("θ:", round(final_theta, 2)),
col = theta_color, bg = "white", cex = 0.8, font = 2, adj = 0)
}
# Add true theta annotation
TeachingDemos::shadowtext(1, true_theta_val + 0.25,
labels = paste("True θ:", round(true_theta_val, 2)),
col = true_theta_color, bg = "white", cex = 0.8, font = 2, adj = 0)
# Add reading guide
mtext("Guide: Track EAP convergence to true θ. CI shows precision. Band = acceptable error (±0.3).",
side = 1, line = 3.5, cex = 0.65, col = "gray40")
}, error = function(e) {
show_error_plot("Theta Plot Error", e$message)
})
})
# ------------------------------------------------------------
# 2) Enhanced Targeting Efficiency Plot
# ------------------------------------------------------------
output$targeting_efficiency_plot <- renderPlot({
cm <- cumulative_metrics_cache()
req(cm, length(cm) > 0, cancelOutput = TRUE)
tryCatch({
ib <- items()
n_items <- sapply(cm, `[[`, "items")
theta_est <- sapply(cm, `[[`, "estimated_theta")
# Calculate efficiency metrics
efficiency <- sapply(seq_along(cm), function(i) {
if (i == 0) return(0)
current_theta <- theta_est[i]
current_item <- ib[i, ]
current_iif <- I_3pl(current_theta, current_item$a, current_item$b, current_item$c)
max_possible_iif <- I_3pl(current_item$b, current_item$a, current_item$b, current_item$c)
if (max_possible_iif > 0) current_iif / max_possible_iif else 0
})
# Cumulative efficiency average
cumul_efficiency <- sapply(seq_along(efficiency), function(i) {
mean(efficiency[1:i])
})
# Color scheme
instant_color <- "#3498db" # Blue for instant efficiency
cumulative_color <- "#e74c3c" # Red for cumulative average
threshold_color <- "#27ae60" # Green for good efficiency
grid_color <- "#ecf0f1" # Light gray grid
xlim <- c(0.8, max(n_items) * 1.02)
ylim <- c(0, 1.1)
par(mar = c(5, 4, 6, 2), mgp = c(2, 0.7, 0))
# Create main plot
plot(NA, type = "n", xlim = xlim, ylim = ylim,
xlab = "", ylab = "", main = "",
axes = FALSE, frame.plot = FALSE)
# Add axis labels
title(xlab = "Test Step (Items Administered)", col.lab = "black")
title(ylab = "Targeting Efficiency Ratio", col.lab = instant_color)
# Add main title with centered legend
title("Item-Person Targeting Efficiency", line = 2.5)
legend("top", legend = c("≥0.8", "0.6-0.8", "<0.6", "Cumulative", "Instant"),
fill = c(adjustcolor(threshold_color, 0.6), adjustcolor("#f39c12", 0.6),
adjustcolor("#e74c3c", 0.6), NA, NA),
border = c(threshold_color, "#f39c12", "#e74c3c", NA, NA),
col = c(NA, NA, NA, cumulative_color, NA),
lwd = c(NA, NA, NA, 2, NA),
pch = c(NA, NA, NA, 21, 22),
pt.bg = c(NA, NA, NA, "white", "white"),
bty = "n", cex = 0.75, ncol = 5, xpd = TRUE, inset = c(0, -0.12))
# Add custom axes
axis(1, col = "black", col.axis = "black", col.ticks = "black", lwd = 1.5)
axis(2, col = instant_color, col.axis = instant_color, col.ticks = instant_color, lwd = 1.5)
# Add grid
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Efficiency thresholds
rect(xlim[1], 0.8, xlim[2], ylim[2], col = adjustcolor(threshold_color, alpha.f = 0.1), border = NA)
rect(xlim[1], 0.6, xlim[2], 0.8, col = adjustcolor("#f39c12", alpha.f = 0.08), border = NA)
abline(h = 0.8, col = threshold_color, lwd = 2, lty = "dashed")
abline(h = 0.6, col = "#f39c12", lwd = 2, lty = "dashed")
# Instant efficiency (bar plot)
for(i in seq_along(n_items)) {
col_eff <- if(efficiency[i] >= 0.8) threshold_color else
if(efficiency[i] >= 0.6) "#f39c12" else "#e74c3c"
rect(n_items[i] - 0.3, 0, n_items[i] + 0.3, efficiency[i],
col = adjustcolor(col_eff, alpha.f = 0.6), border = col_eff, lwd = 1)
}
# Cumulative efficiency line
lines(n_items, cumul_efficiency, type = "b", col = cumulative_color, lwd = 2.5,
pch = 21, bg = "white", cex = 1.1)
# Add final efficiency annotations
if (length(efficiency) > 0) {
final_instant <- tail(efficiency, 1)
final_cumul <- tail(cumul_efficiency, 1)
final_item <- tail(n_items, 1)
# Instant efficiency annotation
points(final_item, final_instant, pch = 22,
bg = if(final_instant >= 0.8) threshold_color else
if(final_instant >= 0.6) "#f39c12" else "#e74c3c",
col = "white", cex = 1.5)
# Cumulative efficiency annotation
points(final_item, final_cumul, pch = 21, bg = cumulative_color, col = "white", cex = 1.5)
}
# Add reading guide
mtext("Guide: Bars = per-item efficiency. Line = running average. Target: maintain >0.6 efficiency.",
side = 1, line = 3.5, cex = 0.65, col = "gray40")
}, error = function(e) {
show_error_plot("Efficiency Plot Error", e$message)
})
})
# ------------------------------------------------------------
# 3) Enhanced SEM + Reliability progression
# ------------------------------------------------------------
output$sem_progression_plot <- renderPlot({
cm <- cumulative_metrics_cache()
req(cm, length(cm) > 0, cancelOutput = TRUE)
tryCatch({
n_items <- sapply(cm, `[[`, "items")
sem_vals <- sapply(cm, `[[`, "sem")
rel_vals <- sapply(cm, `[[`, "reliability")
target_sem<- 0.30
hit_target<- which(sem_vals <= target_sem)[1]
# Color scheme
sem_color <- "#e74c3c" # Red for SEM
rel_color <- "#3498db" # Blue for reliability
target_color <- "#27ae60" # Green for target
grid_color <- "#ecf0f1" # Light gray grid
xlim <- c(0.8, max(n_items) * 1.02)
ylim_sem <- c(0, 1)
par(mar = c(5, 4, 6, 4), mgp = c(2, 0.7, 0))
# Create main plot
plot(NA, type = "n", xlim = xlim, ylim = ylim_sem,
xlab = "", ylab = "", main = "",
axes = FALSE, frame.plot = FALSE)
# Add axis labels
title(xlab = "Test Step (Items Administered)", col.lab = "black")
title(ylab = "Standard Error (SEM)", col.lab = sem_color)
# Add main title with centered legend
title("Measurement Precision and Reliability", line = 2.5)
legend("top", legend = c("SEM", "Target", "Reliability"),
col = c(sem_color, target_color, rel_color),
lwd = c(2.5, 2.5, 2.5),
lty = c("solid", "dashed", "solid"),
pch = c(21, NA, 21),
pt.bg = c("white", NA, "white"),
bty = "n", cex = 0.8, ncol = 3, xpd = TRUE, inset = c(0, -0.12))
# Add custom axes
axis(1, col = "black", col.axis = "black", col.ticks = "black", lwd = 1.5)
axis(2, col = sem_color, col.axis = sem_color, col.ticks = sem_color, lwd = 1.5)
# Add grid
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Target SEM band
rect(xlim[1], 0, xlim[2], target_sem, col = adjustcolor(target_color, alpha.f = 0.15), border = NA)
# SEM line with enhanced points
lines(n_items, sem_vals, type = "b", col = sem_color, lwd = 2.5,
pch = 21, bg = "white", cex = 1.2)
abline(h = target_sem, col = target_color, lwd = 2.5, lty = "dashed")
final_sem <- tail(sem_vals, 1)
final_item <- tail(n_items, 1)
final_rel <- tail(rel_vals, 1)
# Reliability on secondary axis
par(new = TRUE)
plot(n_items, rel_vals, type = "b", col = rel_color, lwd = 2.5, lty = "solid",
axes = FALSE, xlab = "", ylab = "", ylim = c(0, 1), main = "",
pch = 21, bg = "white", cex = 1.2)
axis(4, col = rel_color, col.axis = rel_color, col.ticks = rel_color, lwd = 1.5)
mtext("Reliability", side = 4, line = 2.5, col = rel_color, font = 2)
# Add reading guide
mtext("Guide: SEM should decrease below 0.3 target. Reliability should increase toward 1.0.",
side = 1, line = 3.5, cex = 0.65, col = "gray40")
}, error = function(e) {
show_error_plot("SEM Plot Error", e$message)
})
})
# ------------------------------------------------------------
# 4) Enhanced Information growth & efficiency
# ------------------------------------------------------------
output$information_growth_plot <- renderPlot({
cm <- cumulative_metrics_cache()
req(cm, length(cm) > 0, cancelOutput = TRUE)
tryCatch({
n_items <- sapply(cm, `[[`, "items")
tif <- sapply(cm, `[[`, "tif")
info_gain <- c(tif[1], diff(tif))
eff <- info_gain / n_items
target_tif <- 11.11
# Color scheme
tif_color <- "#3498db" # Blue for TIF
eff_color <- "#e74c3c" # Red for efficiency
ma_color <- "#f39c12" # Orange for moving average
target_color <- "#27ae60" # Green for target
grid_color <- "#ecf0f1" # Light gray grid
xlim <- c(0.8, max(n_items) * 1.02)
ylim_tif <- c(0, max(tif, na.rm = TRUE) * 1.1)
par(mar = c(5, 4, 6, 4), mgp = c(2, 0.7, 0))
# Create main plot
plot(NA, type = "n", xlim = xlim, ylim = ylim_tif,
xlab = "", ylab = "", main = "",
axes = FALSE, frame.plot = FALSE)
# Add axis labels
title(xlab = "Test Step (Items Administered)", col.lab = "black")
title(ylab = "Test Information (TIF)", col.lab = tif_color)
# Add main title with centered legend
title("Information Growth & Efficiency", line = 2.5)
legend("top", legend = c("TIF", "Efficiency", "3-pt MA", "Target"),
col = c(tif_color, eff_color, ma_color, target_color),
lwd = c(2.5, 2.5, 2.5, 2.5),
lty = c("solid", "solid", "dotdash", "dashed"),
pch = c(21, 21, NA, NA),
pt.bg = c("white", "white", NA, NA),
bty = "n", cex = 0.8, ncol = 4, xpd = TRUE, inset = c(0, -0.12))
# Add custom axes
axis(1, col = "black", col.axis = "black", col.ticks = "black", lwd = 1.5)
axis(2, col = tif_color, col.axis = tif_color, col.ticks = tif_color, lwd = 1.5)
# Add grid
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Target TIF band
rect(xlim[1], target_tif, xlim[2], par("usr")[4],
col = adjustcolor(target_color, alpha.f = 0.15), border = NA)
# TIF line with enhanced points
lines(n_items, tif, type = "b", col = tif_color, lwd = 2.5,
pch = 21, bg = "white", cex = 1.2)
abline(h = target_tif, col = target_color, lwd = 2.5, lty = "dashed")
# Efficiency on secondary axis
par(new = TRUE)
eff_lim <- c(0, max(eff, na.rm = TRUE) * 1.1)
plot(n_items, eff, type = "b", col = eff_color, lwd = 2.5, lty = "solid",
axes = FALSE, xlab = "", ylab = "", ylim = eff_lim, main = "",
pch = 21, bg = "white", cex = 1.2)
axis(4, col = eff_color, col.axis = eff_color, col.ticks = eff_color, lwd = 1.5)
mtext("Info per Item", side = 4, line = 2.5, col = eff_color, font = 2)
# Moving average
if (length(eff) > 3 && sum(!is.na(eff)) >= 3) {
ma <- stats::filter(eff, rep(1/3, 3), sides = 2)
lines(n_items, ma, col = ma_color, lwd = 2.5, lty = "dotdash")
}
# Add reading guide
mtext("Guide: TIF should reach 11.11 target. Efficiency shows information gain per item.",
side = 1, line = 3.5, cex = 0.65, col = "gray40")
}, error = function(e) {
show_error_plot("Information Plot Error", e$message)
})
})
# ------------------------------------------------------------
# 5) Enhanced Bias and |Z| analysis
# ------------------------------------------------------------
output$bias_analysis_plot <- renderPlot({
cm <- cumulative_metrics_cache()
req(cm, length(cm) > 0, cancelOutput = TRUE)
tryCatch({
n_items <- sapply(cm, `[[`, "items")
bias <- sapply(cm, `[[`, "bias")
sem <- sapply(cm, `[[`, "sem")
z_abs <- abs(bias / sem)
# Color scheme
bias_color <- "#3498db" # Blue for bias
z_color <- "#e74c3c" # Red for Z-scores
band_color1 <- "#27ae60" # Green for ±0.1 band
band_color2 <- "#f39c12" # Orange for ±0.3 band
grid_color <- "#ecf0f1" # Light gray grid
xlim <- c(0.8, max(n_items) * 1.02)
ylim <- range(bias, na.rm = TRUE)
if (diff(ylim) == 0) ylim <- ylim + c(-0.3, 0.3)
ylim <- ylim + diff(ylim) * c(-0.15, 0.15)
par(mar = c(5, 4, 6, 4), mgp = c(2, 0.7, 0))
# Create main plot
plot(NA, type = "n", xlim = xlim, ylim = ylim,
xlab = "", ylab = "", main = "",
axes = FALSE, frame.plot = FALSE)
# Add axis labels
title(xlab = "Test Step (Items Administered)", col.lab = "black")
title(ylab = expression("Bias ("*hat(theta)-theta[true]*")"), col.lab = bias_color)
# Add main title with centered legend
title("Bias & Standardized Bias Analysis", line = 2.5)
legend("top", legend = c("Bias", "|Z-score|", "±0.1 Band", "±0.3 Band"),
col = c(bias_color, z_color, band_color1, band_color2),
lwd = c(2.5, 2.5, 2, 2),
lty = c("solid", "solid", "dashed", "dashed"),
pch = c(21, 21, NA, NA),
pt.bg = c("white", "white", NA, NA),
bty = "n", cex = 0.8, ncol = 4, xpd = TRUE, inset = c(0, -0.12))
# Add custom axes
axis(1, col = "black", col.axis = "black", col.ticks = "black", lwd = 1.5)
axis(2, col = bias_color, col.axis = bias_color, col.ticks = bias_color, lwd = 1.5)
# Add grid
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Bias bands
rect(xlim[1], -0.30, xlim[2], 0.30, col = adjustcolor(band_color2, alpha.f = 0.1), border = NA)
rect(xlim[1], -0.10, xlim[2], 0.10, col = adjustcolor(band_color1, alpha.f = 0.15), border = NA)
# Bias line with enhanced points
lines(n_items, bias, type = "b", col = bias_color, lwd = 2.5,
pch = 21, bg = "white", cex = 1.2)
# Reference lines
abline(h = 0, col = "black", lwd = 2)
abline(h = c(-0.1, 0.1), col = band_color1, lwd = 2, lty = "dashed")
abline(h = c(-0.3, 0.3), col = band_color2, lwd = 2, lty = "dashed")
# Z-scores on secondary axis
par(new = TRUE)
z_lim <- c(0, max(z_abs, na.rm = TRUE) * 1.1)
plot(n_items, z_abs, type = "b", col = z_color, lwd = 2.5, lty = "solid",
axes = FALSE, xlab = "", ylab = "", ylim = z_lim, main = "",
pch = 21, bg = "white", cex = 1.2)
axis(4, col = z_color, col.axis = z_color, col.ticks = z_color, lwd = 1.5)
mtext("|Z-score|", side = 4, line = 2.5, col = z_color, font = 2)
# Add critical Z-value reference
abline(h = 1.96, col = adjustcolor(z_color, 0.6), lty = "dotted", lwd = 2)
# Add reading guide
mtext("Guide: Bias should stay within ±0.3 bands. |Z| > 1.96 indicates significant bias.",
side = 1, line = 3.5, cex = 0.65, col = "gray40")
}, error = function(e) {
show_error_plot("Bias Plot Error", e$message)
})
})
# ------------------------------------------------------------
# 6) Enhanced Item selection pattern
# ------------------------------------------------------------
output$item_selection_plot <- renderPlot({
ib <- items()
req(ib, nrow(ib) > 0, cancelOutput = TRUE)
tryCatch({
eap_theta <- eap_theta()
# Color scheme
diff_color <- "#3498db" # Blue for difficulty
theta_color <- "#e74c3c" # Red for current theta
info_color <- "#27ae60" # Green for information
disc_color <- "#f39c12" # Orange for discrimination
grid_color <- "#ecf0f1" # Light gray grid
xseq <- seq_len(nrow(ib))
ylim <- range(ib$b, na.rm = TRUE)
if (diff(ylim) == 0) ylim <- ylim + c(-1, 1)
ylim <- ylim + diff(ylim) * c(-0.15, 0.15)
par(mar = c(5, 4, 6, 4), mgp = c(2, 0.7, 0))
# Create main plot
plot(NA, type = "n", xlim = c(0.8, max(xseq) * 1.02), ylim = ylim,
xlab = "", ylab = "", main = "",
axes = FALSE, frame.plot = FALSE)
# Add axis labels
title(xlab = "Item Sequence", col.lab = "black")
title(ylab = "Item Difficulty (b)", col.lab = diff_color)
# Add main title with centered legend
title("Item Selection Pattern", line = 2.5)
legend("top", legend = c("Difficulty", "EAP θ", "Info at θ", "Discrimination"),
col = c(diff_color, theta_color, info_color, disc_color),
lwd = c(2.5, 2.5, 2.5, NA),
lty = c("solid", "solid", "solid", NA),
pch = c(21, NA, NA, 16),
pt.bg = c("white", NA, NA, NA),
pt.cex = c(1.2, NA, NA, 1.5),
bty = "n", cex = 0.8, ncol = 4, xpd = TRUE, inset = c(0, -0.12))
# Add custom axes
axis(1, col = "black", col.axis = "black", col.ticks = "black", lwd = 1.5)
axis(2, col = diff_color, col.axis = diff_color, col.ticks = diff_color, lwd = 1.5)
# Add grid
grid(col = grid_color, lty = "solid", lwd = 0.5)
# Reference lines
abline(h = 0, col = "gray40", lwd = 1.5, lty = "dotted")
abline(h = eap_theta, col = theta_color, lwd = 2.5)
# Difficulty line with enhanced points
lines(xseq, ib$b, type = "b", col = diff_color, lwd = 2.5,
pch = 21, bg = "white", cex = 1.2)
# Discrimination as point size and color
a_rescale <- scales::rescale(ib$a, to = c(1, 3))
a_cols <- colorRampPalette(c(diff_color, disc_color))(nrow(ib))
points(xseq, ib$b, pch = 16, cex = a_rescale, col = a_cols)
# Information at current theta
info_at_theta <- I_3pl(eap_theta, ib$a, ib$b, ib$c)
par(new = TRUE)
info_lim <- c(0, max(info_at_theta, na.rm = TRUE) * 1.1)
plot(xseq, info_at_theta, type = "l", col = info_color, lwd = 2.5, lty = "solid",
axes = FALSE, xlab = "", ylab = "", ylim = info_lim, main = "")
axis(4, col = info_color, col.axis = info_color, col.ticks = info_color, lwd = 1.5)
mtext("Information", side = 4, line = 2.5, col = info_color, font = 2)
# Add reading guide
mtext("Guide: Ideal pattern = items cluster around EAP θ. Larger/brighter points = higher discrimination.",
side = 1, line = 3.5, cex = 0.65, col = "gray40")
}, error = function(e) {
show_error_plot("Item Selection Plot Error", e$message)
})
})
# ------------------------------------------------------------
# Grid Diagnostics Plot (GH vs Uniform) - Single plot version
# ------------------------------------------------------------
output$grid_diagnostics_plot <- renderPlot({
tryCatch({
grid_gh_31 <- make_theta_grid(n = 31, scheme = "ghermite", prior_mean = 0, prior_sd = 1)
grid_unif_31 <- make_theta_grid(n = 31, scheme = "uniform", range = c(-4,4))
grid_gh_31_scaled <- scale_gh_grid(grid_gh_31, range = c(-4,4))
plot_spacing(grid_unif_31, grid_gh_31_scaled,
names = c("Uniform (31 nodes)", "Gauss-Hermite (31 nodes)"),
xlim_range = c(-4, 4))
}, error = function(e) {
ggplot() +
annotate("text", x = 0, y = 0, label = "Plot unavailable", size = 6) +
theme_void()
})
})
output$distribution_comparison_plot <- renderPlot({
tryCatch({
grid_gh_31 <- make_theta_grid(n = 31, scheme = "ghermite", prior_mean = 0, prior_sd = 1)
grid_unif_31 <- make_theta_grid(n = 31, scheme = "uniform", range = c(-4,4))
grid_gh_31_scaled <- scale_gh_grid(grid_gh_31, range = c(-4,4))
plot_density_comparison(grid_gh_31_scaled, grid_unif_31,
names = c("Gauss-Hermite (31 nodes)", "Uniform (31 nodes)"),
xlim_range = c(-4, 4))
}, error = function(e) {
ggplot() +
annotate("text", x = 0, y = 0, label = "Distribution plot unavailable", size = 6) +
theme_void()
})
})
# ------------------------------------------------------------
# Distribution Comparison Plot
# ------------------------------------------------------------
output$distribution_comparison_plot <- renderPlot({
tryCatch({
# Create grids for comparison
grid_gh_31 <- make_theta_grid(n = 31, scheme = "ghermite", prior_mean = 0, prior_sd = 1)
grid_unif_31 <- make_theta_grid(n = 31, scheme = "uniform", range = c(-4,4))
grid_gh_31_scaled <- scale_gh_grid(grid_gh_31, range = c(-4,4))
# Create normal distribution curve
x_seq <- seq(-4, 4, length.out = 200)
normal_density <- dnorm(x_seq)
normal_df <- data.frame(x = x_seq, y = normal_density, distribution = "Standard Normal")
# Create weighted density representations
gh_density <- data.frame(
x = grid_gh_31_scaled$theta,
y = grid_gh_31_scaled$w / diff(range(grid_gh_31_scaled$theta)) * length(grid_gh_31_scaled$theta),
distribution = "Gauss-Hermite Weights"
)
unif_density <- data.frame(
x = grid_unif_31$theta,
y = grid_unif_31$w / diff(range(grid_unif_31$theta)) * length(grid_unif_31$theta),
distribution = "Uniform Weights"
)
# Combine all data
plot_data <- rbind(
normal_df,
gh_density,
unif_density
)
# Create the plot
ggplot(plot_data, aes(x = x, y = y, color = distribution, linetype = distribution)) +
geom_line(data = subset(plot_data, distribution == "Standard Normal"), linewidth = 1.5) +
geom_point(data = subset(plot_data, distribution != "Standard Normal"), size = 2, alpha = 0.7) +
geom_line(data = subset(plot_data, distribution != "Standard Normal"), linewidth = 1, alpha = 0.7) +
labs(
x = expression(theta),
y = "Density / Scaled Weights",
title = "Distribution Comparison: Gauss-Hermite vs Uniform vs Normal"
) +
scale_color_manual(values = c(
"Standard Normal" = "#2ecc71", # Green for normal
"Uniform Weights" = "#3498db", # Blue for GH
"Gauss-Hermite Weights" = "#e74c3c" # Red for uniform
)) +
scale_linetype_manual(values = c(
"Standard Normal" = "solid",
"Gauss-Hermite Weights" = "solid",
"Uniform Weights" = "solid"
)) +
coord_cartesian(xlim = c(-4, 4)) +
theme_minimal(base_size = 14) +
theme(
legend.position = "top",
legend.title = element_blank(),
legend.text = element_text(size = 12),
plot.margin = margin(10, 10, 10, 10),
panel.grid.minor = element_blank(),
plot.title = element_text(hjust = 0.5, size = 14)
)
}, error = function(e) {
ggplot() +
annotate("text", x = 0, y = 0, label = "Distribution plot unavailable", size = 6) +
theme_void()
})
})
# Current Test Metrics UI
output$current_test_metrics <- renderUI({
cm <- cumulative_metrics_cache()
ib <- items()
req(cm, length(cm) > 0, ib, nrow(ib) > 0)
current_metrics <- cm[[length(cm)]]
true_theta_val <- true_theta()
bias <- current_metrics$estimated_theta - true_theta_val
abs_bias <- abs(bias)
efficiency <- if (current_metrics$sem <= 0.30) "Target Met" else "Below Target"
avg_admin_a <- mean(ib$a)
avg_admin_b <- mean(ib$b)
avg_admin_c <- mean(ib$c)
b_range <- sprintf("[%.2f, %.2f]", min(ib$b), max(ib$b))
items_to_target <- which(sapply(cm, function(x) x$sem <= 0.30))[1]
avg_info_gain <- current_metrics$tif / nrow(ib)
method <- if (!is.null(input$sel_method)) input$sel_method else "mfi"
# Pre-calculate all color values to avoid complex conditionals in paste0
bias_color <- if(abs_bias <= 0.2) "#059669" else if(abs_bias <= 0.5) "#d97706" else "#dc2626"
zscore <- abs(bias/current_metrics$sem)
zscore_color <- if(zscore <= 1) "#059669" else if(zscore <= 2) "#d97706" else "#dc2626"
sem_color <- if(current_metrics$sem <= 0.30) "#059669" else "#dc2626"
reliability_color <- if(current_metrics$reliability >= 0.8) "#059669" else if(current_metrics$reliability >= 0.7) "#d97706" else "#dc2626"
efficiency_color <- if(efficiency == "Target Met") "#059669" else "#dc2626"
HTML(paste0('
<div class="metrics-two-columns">
<!-- Left Column -->
<div class="column">
<!-- Estimation Accuracy -->
<div class="metric-box">
<div class="metric-title">Estimation Accuracy</div>
<div class="metric-content">
<div class="metric-row">
<span>True θ:</span>
<strong>', sprintf('%.2f', true_theta_val), '</strong>
</div>
<div class="metric-row">
<span>Est. θ:</span>
<strong>', sprintf('%.2f', current_metrics$estimated_theta), '</strong>
</div>
<div class="metric-row">
<span>Bias:</span>
<strong style="color:', bias_color, '">', sprintf('%.2f', bias), '</strong>
</div>
<div class="metric-row">
<span>|Z-score|:</span>
<strong style="color:', zscore_color, '">', sprintf('%.1f', zscore), '</strong>
</div>
</div>
</div>
<!-- Precision Metrics -->
<div class="metric-box">
<div class="metric-title">Precision Metrics</div>
<div class="metric-content">
<div class="metric-row">
<span>SEM:</span>
<strong style="color:', sem_color, '">', sprintf('%.3f', current_metrics$sem), '</strong>
</div>
<div class="metric-row">
<span>TIF:</span>
<strong>', sprintf('%.1f', current_metrics$tif), '</strong>
</div>
<div class="metric-row">
<span>Reliability:</span>
<strong style="color:', reliability_color, '">', sprintf('%.3f', current_metrics$reliability), '</strong>
</div>
<div class="metric-row">
<span>95% CI Width:</span>
<strong>±', sprintf('%.2f', 1.96 * current_metrics$sem), '</strong>
</div>
</div>
</div>
</div>
<!-- Right Column -->
<div class="column">
<!-- Test Status -->
<div class="metric-box">
<div class="metric-title">Test Status</div>
<div class="metric-content">
<div class="metric-row">
<span>Method:</span>
<strong>', toupper(method), '</strong>
</div>
<div class="metric-row">
<span>Efficiency:</span>
<strong style="color:', efficiency_color, '">', efficiency, '</strong>
</div>
<div class="metric-row">
<span>Items to Target:</span>
<strong>', ifelse(is.na(items_to_target), ">", items_to_target), '</strong>
</div>
<div class="metric-row">
<span>Avg Info/Item:</span>
<strong>', sprintf('%.2f', avg_info_gain), '</strong>
</div>
</div>
</div>
<!-- Administered Items -->
<div class="metric-box">
<div class="metric-title">Administered Items</div>
<div class="metric-content">
<div class="metric-row">
<span>Count:</span>
<strong>', nrow(ib), '</strong>
</div>
<div class="metric-row">
<span>Avg a:</span>
<strong>', sprintf('%.2f', avg_admin_a), '</strong>
</div>
<div class="metric-row">
<span>Avg b:</span>
<strong>', sprintf('%.2f', avg_admin_b), '</strong>
</div>
<div class="metric-row">
<span>b Range:</span>
<strong>', b_range, '</strong>
</div>
</div>
</div>
</div>
</div>
<style>
.metrics-two-columns {
display: grid;
grid-template-columns: 1fr 1fr;
gap: 20px;
max-width: 1200px;
margin: 0 auto;
font-family: Arial, sans-serif;
}
.column {
display: flex;
flex-direction: column;
gap: 20px;
}
.metric-box {
background: white;
border: 1px solid #e9ecef;
border-radius: 8px;
padding: 16px;
box-shadow: 0 1px 3px rgba(0,0,0,0.1);
}
.metric-title {
font-weight: 600;
color: #2c5282;
margin-bottom: 12px;
font-size: 14px;
}
.metric-content {
display: flex;
flex-direction: column;
gap: 8px;
}
.metric-row {
display: flex;
justify-content: space-between;
align-items: center;
font-size: 11px;
color: #64748b;
line-height: 1.4;
}
.metric-row strong {
color: #1e3a8a;
font-weight: 600;
}
/* Responsive design */
@media (max-width: 768px) {
.metrics-two-columns {
grid-template-columns: 1fr;
}
}
</style>
'))
})
output$summary_table <- renderUI({
ib <- items()
cm <- cumulative_metrics_cache()
true_th <- true_theta()
req(!is.null(ib), nrow(ib) > 0, !is.null(true_th))
if (is.null(cm) || length(cm) == 0) return(NULL)
n_rows <- length(cm)
ib <- ib[seq_len(n_rows), , drop = FALSE]
resp <- responses()
if (length(resp) < n_rows) {
resp <- c(resp, rep(NA_integer_, n_rows - length(resp)))
}
# Authoritative 3PL implementation with proper error handling
P_3pl <- function(theta, a, b, c) {
# Input validation and clamping - APPLY TO PARAMETERS, DON'T OVERWRITE
a_clamped <- max(a, 0.5)
c_clamped <- max(0, min(c, 0.2))
# Core 3PL calculation
exponent <- -1.702 * a_clamped * (theta - b)
p_correct <- c_clamped + (1 - c_clamped) / (1 + exp(exponent))
# Ensure numerical stability
pmin(pmax(p_correct, 1e-10), 1 - 1e-10)
}
# Create table header with equal width columns and centered titles
table_html <- paste0(
'<table id="summary_table" class="display compact" style="width:100%; font-size:10px; margin-top:15px; table-layout:fixed;">',
'<thead><tr style="background:linear-gradient(135deg,#f8fafc,#f1f5f9);">',
'<th style="width:7.69%; text-align:center;">Step</th>',
'<th style="width:7.69%; text-align:center;">Item</th>',
'<th style="width:7.69%; text-align:center;">a</th>',
'<th style="width:7.69%; text-align:center;">b</th>',
'<th style="width:7.69%; text-align:center;">c</th>',
'<th style="width:7.69%; text-align:center;">P(θ)</th>',
'<th style="width:7.69%; text-align:center;">Resp.</th>',
'<th style="width:7.69%; text-align:center;">EAP θ̂ </th>',
'<th style="width:7.69%; text-align:center;">Bias</th>',
'<th style="width:7.69%; text-align:center;">IIF</th>',
'<th style="width:7.69%; text-align:center;">TIF</th>',
'<th style="width:7.69%; text-align:center;">SEM</th>',
'<th style="width:7.69%; text-align:center;">ρ</th>',
'</tr></thead><tbody>'
)
# Create table rows (keeping your original cell alignment)
for (i in 1:n_rows) {
metrics <- cm[[i]]
current_iif <- metrics$iif_current_item
current_iif <- ifelse(is.finite(current_iif), current_iif, 0)
# Response symbol/color
current_response <- resp[i]
response_text <- if (!is.na(current_response) && current_response == 1) "✓" else "✗"
response_color <- if (!is.na(current_response) && current_response == 1) "green" else "red"
# Calculate p(true theta) using the true theta value
p_true_theta <- P_3pl(
theta = true_th, # Using the true theta from reactive
a = ib$a[i],
b = ib$b[i],
c = ib$c[i]
)
# Row HTML with 3 digits for numeric values
row_html <- paste0(
'<tr>',
'<td style="text-align:center;">', i, '</td>',
'<td style="text-align:center;">', ib$label[i], '</td>',
'<td style="text-align:right;">', sprintf('%.3f', ib$a[i]), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', ib$b[i]), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', ib$c[i]), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', p_true_theta), '</td>',
'<td style="text-align:center; color:', response_color, '; font-weight:bold;">', response_text, '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$estimated_theta), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$bias), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', current_iif), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$tif), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$sem), '</td>',
'<td style="text-align:right;">', sprintf('%.3f', metrics$reliability), '</td>',
'</tr>'
)
table_html <- paste0(table_html, row_html)
}
table_html <- paste0(table_html, '</tbody></table>')
tagList(
tags$div(HTML(table_html)),
tags$script(HTML("
$(document).on('shiny:value', function() {
setTimeout(function() {
if ($.fn.DataTable.isDataTable('#summary_table')) {
$('#summary_table').DataTable().destroy();
}
$('#summary_table').DataTable({
paging: false,
searching: false,
info: false,
ordering: false,
autoWidth: false,
columnDefs: [
{ width: '7.69%', targets: '_all' }
]
});
}, 50);
});
"))
)
})
# ---- Fixed Cumulative Metrics Calculation ----
observeEvent(list(items(), responses()), {
ib <- items()
resp <- responses()
if (is.null(ib) || nrow(ib) == 0) {
cumulative_metrics_cache(NULL)
return()
}
n_available <- min(nrow(ib), length(resp))
if (n_available == 0) {
cumulative_metrics_cache(list())
return()
}
true_th <- true_theta()
cm <- vector("list", n_available)
for (n in 1:n_available) {
current_subset_items <- ib[1:n, , drop = FALSE]
current_subset_responses <- resp[1:n]
# Calculate EAP for this subset
current_eap <- estimate_theta_eap(current_subset_items, current_subset_responses)
# CRITICAL FIX: Use DIRECT CALCULATION for both plot and table
# This ensures consistency between displayed values
current_tif <- calculate_tif_at_theta(current_eap, current_subset_items)
current_sem <- if (n == 1) NA_real_ else if (current_tif > 0) 1 / sqrt(current_tif) else NA_real_
current_reliability <- calculate_reliability(current_tif)
current_bias <- current_eap - true_th
# Calculate IIF for the most recent item at current EAP
if (n > 0) {
current_iif <- I_3pl(current_eap,
current_subset_items$a[n],
current_subset_items$b[n],
current_subset_items$c[n])
} else {
current_iif <- 0
}
cm[[n]] <- list(
items = n,
tif = current_tif,
sem = current_sem,
reliability = current_reliability,
estimated_theta = current_eap,
bias = current_bias,
iif_current_item = current_iif # Store for table use
)
}
cumulative_metrics_cache(cm)
# Update bias history
if (length(cm) > 0 && initial_modal_completed()) {
all_biases <- sapply(cm, `[[`, "bias")
bias_history(all_biases)
}
}, ignoreInit = FALSE)
# ---- Target SEM Modal ----
observe({
cm <- cumulative_metrics_cache()
req(cm, length(cm) > 0)
# Get current SEM
current_sem <- tail(cm, 1)[[1]]$sem
current_items <- tail(cm, 1)[[1]]$items
# Check if target is met and we haven't shown the modal yet
if (is.finite(current_sem) && current_sem <= 0.30 && !target_met()) {
target_met(TRUE)
final_sem_value(current_sem)
showModal(modalDialog(
title = NULL, # Remove title bar
easyClose = FALSE,
fade = TRUE,
size = "m",
footer = tagList(
actionButton("continue_testing", "Continue Testing", class = "btn-success"),
actionButton("view_summary", "View Summary", class = "btn-info")
),
tagList(
div(
style = "text-align: center; padding: 0;",
# Main achievement message
div(
style = "background: #f0fdf4; padding: 10px; border-radius: 6px; margin-bottom: 10px; border: 1px solid #bbf7d0;",
div(
style = "text-align: center; margin-bottom: 6px;",
span(style = "font-size: 13px; color: #065f46; font-weight: 600; text-transform: uppercase; letter-spacing: 0.5px;",
"Target SEM Reached")
),
div(
style = "text-align: center;",
span(style = "font-size: 14px; font-weight: bold; color: #065f46;",
textOutput("sem_header_display"))
)
),
# Precision and Efficiency side by side
div(
style = "display: grid; grid-template-columns: 1fr 1fr; gap: 10px; margin: 8px 0;",
# Left Column: Precision Metrics
div(
style = "background: #f0f9ff; border-radius: 5px; padding: 8px; border: 1px solid #bae6fd;",
h5(style = "color: #0369a1; margin-bottom: 6px; font-size: 12px; font-weight: 600;", "Precision Metrics"),
div(
style = "font-size: 11px; line-height: 1.2;",
div(style = "margin-bottom: 4px;",
strong("SEM Target:"), " ≤ 0.30"
),
div(style = "margin-bottom: 4px;",
strong("95% CI:"), textOutput("ci_display", inline = TRUE)
),
div(style = "margin-bottom: 0;",
strong("Reliability:"), textOutput("reliability_display", inline = TRUE)
)
)
),
# Right Column: Efficiency Gain
div(
style = "background: #f0fdf4; border-radius: 5px; padding: 8px; border: 1px solid #bbf7d0;",
h5(style = "color: #15803d; margin-bottom: 6px; font-size: 12px; font-weight: 600;",
textOutput("efficiency_header_display")),
div(
style = "font-size: 11px; line-height: 1.2;",
div(style = "margin-bottom: 4px;",
strong("Items used:"), textOutput("items_used_display", inline = TRUE)
),
div(style = "margin-bottom: 4px;",
strong("Fixed-form equivalent:"), textOutput("fixed_form_display", inline = TRUE)
),
div(style = "margin-bottom: 0;",
strong("Items saved:"), textOutput("items_saved_display", inline = TRUE)
)
)
)
),
# Confidence Interpretation
div(
style = "background: #fefce8; border-radius: 5px; padding: 8px; margin: 6px 0; border: 1px solid #fef08a;",
div(
style = "margin: 0; font-size: 11px; line-height: 1.2;",
HTML('<strong style="color: #854d0e;">Interpretation:</strong> '),
textOutput("confidence_interpretation_inline", inline = TRUE)
)
),
# Call to action
div(
style = "text-align: center; margin-top: 8px; padding-top: 6px; border-top: 1px solid #e2e8f0;",
p(style = "margin: 0; font-size: 11px; line-height: 1.2; color: #64748b;",
"You can continue testing for even greater precision, or view detailed results in the Test Diagnostics tab.")
)
)
)
))
}
})
# ---- Modal Button Handlers ----
observeEvent(input$continue_testing, {
removeModal()
})
observeEvent(input$view_summary, {
removeModal()
# Scroll to summary table
runjs("$('html, body').animate({ scrollTop: $(document).height() }, 1000);")
})
###############################
# ---- Main Plot ----
###############################
output$plot_all <- renderPlot({
# Show loading message if not initialized
if (!app_initialized()) {
par(mar = c(3, 3, 3, 3), bg = "white", family = "sans")
plot.new()
plot.window(xlim = c(0, 1), ylim = c(0, 1))
text(0.5, 0.7, "Initializing CAT System...",
col = "#666666", cex = 1.3, adj = c(0.5, 0.5), font = 2)
text(0.5, 0.5, "Please wait while the test is being set up",
col = "#999999", cex = 1.0, adj = c(0.5, 0.5))
return()
}
library(TeachingDemos)
ib <- items()
# DEFENSIVE: Check if items exist
if (is.null(ib) || nrow(ib) == 0) {
par(mar = c(3, 3, 3, 3), bg = "white", family = "sans")
plot.new()
plot.window(xlim = c(0, 1), ylim = c(0, 1))
text(0.5, 0.5, "No items available", col = "red", cex = 1.2, adj = c(0.5, 0.5))
return()
}
# DEFENSIVE: Initialize critical variables FIRST
labs <- ib$label
curves <- per_item_curves()
# Check if curves exist
if (is.null(curves) || length(curves) == 0) {
par(mar = c(3, 3, 3, 3), bg = "white", family = "sans")
plot.new()
plot.window(xlim = c(0, 1), ylim = c(0, 1))
text(0.5, 0.5, "No curve data available", col = "red", cex = 1.2, adj = c(0.5, 0.5))
return()
}
# Continue with existing logic...
pal <- setNames(ib$color, ib$label)
last_lab <- tail(labs, 1)
theta <- .THETA_GRID
tif_df <- tibble(theta = theta, TIF = tif_curve())
sem_df <- tibble(theta = theta,
SEM = ifelse(tif_df$TIF > 0, 1 / sqrt(tif_df$TIF), NA_real_))
max_tif <- max(tif_df$TIF, na.rm = TRUE)
if (!is.finite(max_tif) || max_tif <= 0) max_tif <- 1
max_iif <- max(vapply(curves[labs], function(df) {
if (!is.null(df) && nrow(df) > 0 && !all(is.na(df$I))) {
max(df$I, na.rm = TRUE)
} else {
0
}
}, 0), na.rm = TRUE)
if (!is.finite(max_iif) || max_iif <= 0) max_iif <- 1
y_top_left <- max(1, max_iif * 1.4)
scaling_factor <- if (max_tif > 0) min(1.0, (y_top_left * 0.85) / max_tif) else 1.0
scaling_factor <- max(0.05, min(1.0, scaling_factor))
y_top_left <- min(40, y_top_left)
th0 <- eap_theta()
true_th <- true_theta()
# CRITICAL FIX: Get values from CACHE (same as table)
# CRITICAL FIX: Plot points using EXACT SAME values as table
# Use the cached metrics which are calculated consistently
cm <- cumulative_metrics_cache()
if (!is.null(cm) && length(cm) > 0) {
current_metrics <- cm[[length(cm)]] # Use double bracket indexing for lists
TIF_th0 <- current_metrics$tif
SEM_th0 <- current_metrics$sem
I_last <- current_metrics$iif_current_item
} else {
# Fallback - should not happen if cache is working
TIF_th0 <- calculate_tif_at_theta(th0, ib)
SEM_th0 <- calculate_sem_at_theta(th0, ib)
I_last <- if (nrow(ib) > 0) {
I_3pl(th0, ib$a[nrow(ib)], ib$b[nrow(ib)], ib$c[nrow(ib)])
} else 0
}
par(mar = c(4.5, 4.5, 4, 4.5) + 0.1, mgp = c(2.8, 0.8, 0))
xpad <- 0.8
xlim <- c(min(theta) - xpad, max(theta) + xpad)
plot(NA, NA, xlim = xlim, ylim = c(0, y_top_left),
xlab = expression(bold("Ability (" * theta * ")")),
ylab = expression(bold("Item Information (IIF)")),
axes = FALSE, main = "")
grid(lwd = 0.7, col = "gray85", lty = "solid")
axis(1, col = "gray40", col.axis = "gray40", lwd = 1)
axis(2, col = "gray40", col.axis = "gray40", lwd = 1)
# Add TIF on right axis
right_ticks <- pretty(c(0, max_tif))
axis(4, at = right_ticks * scaling_factor, labels = right_ticks, lwd = 1)
mtext("Test Information (TIF) & Standard Error (SEM)", side = 4, line = 2.8, font = 2)
# Reference lines
abline(v = true_th, lwd = 2, col = "purple", lty = "solid")
abline(v = th0, lwd = 2, col = "purple", lty = "dotted")
# Plot ICC curves
icc_scale <- 0.7 * y_top_left
if (input$icc_layer_alpha > 0) {
for (lab in labs) {
df <- curves[[lab]]
if (!is.null(df) && nrow(df) > 0 && !all(is.na(df$P))) {
alpha_eff <- input$icc_layer_alpha
line_width <- if (lab == last_lab) 2.5 else 1.2
col_icc <- adjustcolor(pal[[lab]], alpha.f = alpha_eff)
lines(df$theta, df$P * icc_scale, col = col_icc, lwd = line_width)
}
}
}
# Plot IIF curves
if (input$iif_layer_alpha > 0) {
for (lab in labs) {
df <- curves[[lab]]
if (!is.null(df) && nrow(df) > 0 && !all(is.na(df$I))) {
alpha_eff <- input$iif_layer_alpha
line_width <- if (lab == last_lab) 3.5 else 1.8
col_iif <- adjustcolor(pal[[lab]], alpha.f = alpha_eff)
lines(df$theta, df$I, col = col_iif, lwd = line_width)
}
}
}
# Plot TIF
if (input$tif_alpha > 0 && max(tif_df$TIF, na.rm = TRUE) > 0) {
tif_scaled <- tif_df$TIF * scaling_factor
lines(theta, tif_scaled,
col = adjustcolor("#1D4ED8", alpha.f = input$tif_alpha),
lwd = 5, lend = "round")
}
# Plot SEM
if (input$sem_alpha > 0 && max(tif_df$TIF, na.rm = TRUE) > 0) {
sem_scaled <- sem_df$SEM * scaling_factor
lines(theta, sem_scaled,
col = adjustcolor("darkred", alpha.f = input$sem_alpha),
lwd = 3, lend = "round")
}
# Target SEM line
target_sem_line_y <- 0.30 * scaling_factor
abline(h = target_sem_line_y, col = "#EF4444", lwd = 2.5, lty = "dotted")
# CRITICAL FIX: Plot points using EXACT SAME values as table
# IIF point
if (is.finite(I_last) && I_last > 0) {
points(th0, I_last, pch = 21, bg = pal[[last_lab]],
col = "white", cex = 1.5, lwd = 2)
text_pos <- if (I_last > y_top_left * 0.7) 2 else 4
TeachingDemos::shadowtext(
th0, I_last, sprintf("IIF=%.2f", I_last),
pos = text_pos, cex = input$annotation_size,
font = 2, col = pal[[last_lab]], bg = "white", r = 0.3
)
}
# TIF point - use EXACT SAME value as table
if (is.finite(TIF_th0) && TIF_th0 > 0) {
tif_scaled_point <- TIF_th0 * scaling_factor
points(th0, tif_scaled_point, pch = 22, bg = "navy",
col = "white", cex = 1.8, lwd = 2)
TeachingDemos::shadowtext(
th0, tif_scaled_point, sprintf("TIF=%.1f", TIF_th0),
pos = 3, cex = input$annotation_size,
font = 2, col = "navy", bg = "white", r = 0.3
)
}
# SEM point - use EXACT SAME value as table
if (is.finite(SEM_th0) && SEM_th0 > 0) {
sem_scaled_point <- SEM_th0 * scaling_factor
points(th0, sem_scaled_point, pch = 23, bg = "darkred",
col = "white", cex = 1.6, lwd = 2)
TeachingDemos::shadowtext(
th0, sem_scaled_point, sprintf("SEM=%.3f", SEM_th0),
pos = 1, cex = input$annotation_size,
font = 2, col = "darkred", bg = "white", r = 0.3
)
}
# Legend
legend("topleft", legend = rev(labs), col = pal[rev(labs)],
lwd = 2, cex = input$annotation_size, bty = "o", bg = adjustcolor("white", alpha.f = 0.8),
title = "Items", title.col = "#1E293B")
legend("topright", legend = c("EAP θ", "True θ"),
lty = c("dotted", "solid"), lwd = 2, col = "purple",
cex = input$annotation_size, bty = "o", bg = adjustcolor("white", alpha.f = 0.8))
title("Test Information Function and Measurement Precision", line = 2, cex.main = 1.2)
box(col = "gray80", lwd = 0.5)
})
observeEvent(input$add_item, {
current_theta_est <- eap_theta()
pool <- item_pool()
existing <- items()
cur_resp <- responses()
palette <- color_palette()
# Determine if we should use Sympson-Hetter (MFI only)
use_sh <- input$use_sympson_hetter && input$sel_method == "mfi"
# Use enhanced selection with all three methods
next_item <- select_item_enhanced(
pool = pool,
method = input$sel_method,
current_theta = current_theta_est,
existing_items = existing,
m_top = if (!is.null(input$m_top)) input$m_top else 8,
tau = if (!is.null(input$tau)) input$tau else 0.08,
# Only use Sympson-Hetter with MFI
use_sympson_hetter = use_sh,
k_value = if (!is.null(input$k_value)) input$k_value else 0.5,
r_value = if (!is.null(input$r_value)) input$r_value else 0.5
)
# Function to update exposure probabilities
update_exposure_control <- function(pool, administered_items, k_value = 0.5) {
# Simple implementation - in practice, this would be more sophisticated
for (i in 1:nrow(pool)) {
item_id <- pool$id[i]
admin_count <- sum(administered_items$id == item_id)
# Simple decay function - reduce exposure probability based on usage
if (admin_count > 0) {
pool$exposure_prob[i] <- max(0.1, 1 / (1 + log(1 + admin_count * k_value)))
}
}
return(pool)
}
next_item$color <- palette[next_item$id]
new_response <- generate_responses(true_theta(), next_item)
# FIX: Define new_items BEFORE using it
new_items <- dplyr::bind_rows(existing, next_item)
new_responses <- c(cur_resp, new_response)
if (nrow(new_items) != length(new_responses)) {
n_min <- min(nrow(new_items), length(new_responses))
new_items <- new_items[1:n_min, , drop = FALSE]
new_responses <- new_responses[1:n_min]
}
# Only update exposure control when using MFI + Sympson-Hetter
if (use_sh) {
updated_pool <- update_exposure_control(pool, new_items,
if (!is.null(input$k_value)) input$k_value else 0.5)
item_pool(updated_pool)
}
items(new_items)
responses(new_responses)
# Calculate curves for new item
df_new <- tibble(
theta = .THETA_GRID,
P = P_3pl(.THETA_GRID, next_item$a, next_item$b, next_item$c),
I = I_3pl(.THETA_GRID, next_item$a, next_item$b, next_item$c)
)
cur <- per_item_curves()
# CRITICAL FIX: Initialize curves list if it's the first item
if (is.null(cur)) {
cur <- list()
}
cur[[next_item$label]] <- df_new
per_item_curves(cur)
# Recalculate TIF curve
theta_grid <- .THETA_GRID
new_tif_curve <- numeric(length(theta_grid))
for(i in 1:length(theta_grid)) {
total_info <- 0
for(j in 1:nrow(new_items)) {
item_info <- I_3pl(theta_grid[i], new_items$a[j], new_items$b[j], new_items$c[j])
if(is.finite(item_info)) {
total_info <- total_info + item_info
}
}
new_tif_curve[i] <- total_info
}
tif_curve(new_tif_curve)
})
}
# ===========================================
# ---- LAUNCH APPLICATION SECTION ----
# ===========================================
shinyApp(ui = ui, server = server)
