mirtCAT Shiny session randomization and UI persistence issues (multi-form bifactor mirtCAT)
Kristoffer Berlin
Hi Phil,
I’m running into a persistent issue with my mirtCAT Shiny deployment that seems related to session initialization and UI persistence. I reviewed the 2019 thread with Daniel Sommerhoff about sessionName scoping and re-sourcing, and I’ve implemented the createSessionName() logic as recommended, but the problem seems a bit different.
Here’s the short version:
Context
I’m hosting a 130-item bifactor CAT (one general + seven specific factors) for pediatric diabetes behavioral health screening. Each test randomly assigns examinees to one of three pre-defined forms (F1–F3) and a random block order within that form for the seven specific factors.
Each session generates a unique sessionName:
mysession <- paste0(createSessionName(), "_", format(Sys.time(), "%Y%m%d%H%M%S"))
This works nearly perfectly locally. Form and block randomization occur on every refresh. However, when deployed to shinyapps.io, one persistent issue appears.
1) Randomization and UI interaction problem
- If I define the UI statically (no renderUI), the interface is full-screen and looks correct, but the randomization does not trigger on browser refresh. It reuses the same form and block order.
- If I move the randomization inside server() to force per-session variation (as in the code below), the randomization works, but the resulting UI behaves as if it is nested inside another fluidPage. On mobile browsers it clips vertically, leaving a white or gray box and forcing scroll within scroll.
- I have confirmed this happens even when using a minimal tagList wrapper instead of fluidPage. You can see it live here: https://sugarscreener.shinyapps.io/sugarPMD/
- I’ve confirmed this happens even when using a minimal tagList wrapper instead of fluidPage.
What I’ve tried
- output$main_ui <- renderUI({ createShinyGUI(sugar) }) → fixes randomization but breaks layout with the nested box effect.
- A static createShinyGUI(sugar) call in the top-level UI → layout is perfect but randomization only changes on full app restart, not per refresh.
- Initializing person$state$block_order per examinee and skipping completed blocks in nextItemFunc. This works locally but not reliably on shinyapps.io.
- Confirmed all environments for nextItemFunc and the last page are bound within server().
- Using unique sessionName with a timestamp per the 2019 recommendation.
Questions
- Is there a clean way to force re-randomization per browser refresh without nesting a second Shiny container that breaks the mobile layout?
- Could the session persistence changes in newer mirtCAT versions help here on shinyapps.io?
- Would you recommend initializing the form and block assignment inside mirtCAT_preamble() or outside via a wrapper to avoid reactivity issues that lead to the nested UI effect?
Representative code
I can share the full app if helpful, but here is the core logic.
mysession <- paste0(createSessionName(), "_", format(Sys.time(), "%Y%m%d%H%M%S"))
form_id <- sample(c("F1", "F2", "F3"), 1)
assigned_form <- form_id
block_manifest <- switch(form_id, F1 = block_manifest_F1, F2 = block_manifest_F2, F3 = block_manifest_F3)
sess <- initializeBlockOrder(block_manifest)
block_order <- sess$block_order
start_item <- as.integer(sess$start_val)
environment(nextItemFunc) <- list2env(list(block_manifest = block_manifest, block_order = block_order))
environment(lastpage) <- list2env(list(assigned_form = assigned_form, token = token, gmail_creds = gmail_creds, GMAIL_USER = GMAIL_USER))
sugar <- mirtCAT_preamble(
mo = mo, df = df, criteria = "APrule", start_item = start_item,
shinyGUI = make_shinyGUI_list(selected_logo, friendly_name),
design = list(customNextItem = nextItemFunc, max_items = 2, min_SEM = 0),
sessionName = mysession
)
createShinyGUI(sugar)
---
Any insights or a design pattern you would suggest would be hugely appreciated. I have reached the limits of trial and error on balancing per-refresh re-randomization with a stable Shiny layout on mobile.
Best regards,
Kristoffer S. Berlin, PhD
complete code:
# ============================================================
# SUGARPMD - Three Form (UI boxed)
# ============================================================
# ----------------------------
# 1. Libraries and setup
# ----------------------------
library(mirtCAT)
library(dplyr)
library(ggplot2)
library(tibble)
library(base64enc)
library(rdrop2)
library(blastula)
library(glue)
library(shiny)
# If config.R exists it should define:
# DROPBOX_TOKEN_PATH
# GMAIL_USER
# any other secrets
if (file.exists("config.R")) {
source("config.R")
} else {
message("config.R not found. Will use fallbacks for Dropbox and email.")
DROPBOX_TOKEN_PATH <- "dropbox_token.rds"
GMAIL_USER <- NULL
}
# ============================================================
# 2. Secure credentials and model loading
# ============================================================
# --- Load config file that defines GMAIL_USER, GMAIL_CREDS_FILE, DROPBOX_TOKEN_PATH ---
if (file.exists("config.R")) {
source("config.R")
message("✅ Loaded config.R (sugarscreener credentials).")
} else {
message("⚠️ config.R not found; will use fallbacks for Gmail and Dropbox.")
GMAIL_USER <- "X...@gmail.com"
GMAIL_CREDS_FILE <- "gmail_creds"
DROPBOX_TOKEN_PATH <- "dropbox_token.rds"
}
# --- 2.1 Gmail credentials ---
if (file.exists(GMAIL_CREDS_FILE)) {
message("✅ Using secure Blastula Gmail credentials file.")
gmail_creds <- blastula::creds_file(GMAIL_CREDS_FILE)
} else {
message("⚠️ Gmail credentials file not found; email will be skipped.")
gmail_creds <- NULL
}
# --- 2.2 Dropbox token ---
if (exists("DROPBOX_TOKEN_PATH") && file.exists(DROPBOX_TOKEN_PATH)) {
message("✅ Loaded Dropbox token.")
token <- readRDS(DROPBOX_TOKEN_PATH)
} else {
message("⚠️ Dropbox token not found; uploads will be skipped.")
token <- NULL
}
# --- 2.3 Load model and item data ---
mo <- readRDS("EGA130MO.rds")
df <- read.csv("EGA130qs.csv", stringsAsFactors = FALSE, na.strings = "NA")
factor_names <- c("G", "WEBS", "DISTRESS", "PAID", "DFC", "HYPER", "HYPO", "INT")
factor_to_theta <- setNames(seq_along(factor_names), factor_names)
# ============================================================
# 3. Helper functions
# ============================================================
`%||%` <- function(x, y) if (!is.null(x)) x else y
getDynamicCutoff <- function(block_name, manifest, level = "P80") {
b <- manifest[[block_name]]
m <- b$min %||% NA_integer_
if (is.na(m) || m == 0 || m > 3) {
if (!is.null(b$DCU)) return(as.numeric(b$DCU))
fallback_key <- paste0("MIN3", level)
return(as.numeric(b[[fallback_key]] %||% NA_real_))
}
key <- paste0("MIN", m, level)
val <- b[[key]] %||% b$DCU %||% b[[paste0("MIN3", level)]] %||% NA_real_
as.numeric(val)
}
# ============================================================
# 4. Embedded three form manifests
# ============================================================
form_labels <- list(
F1 = "Calico",
F2 = "Tabby",
F3 = "Orange"
)
logo_map <- list(
F1 = "cat_calico.png",
F2 = "cat_tabby.png",
F3 = "cat_orange.png"
)
# ----------------------------
# FORM F1
# ----------------------------
block_manifest_F1 <- list(
G = list(items = 1:130, min = 0, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 130, sitem = "APrule", DCU = 0.523,
MIN1P80 = 0.2377, MIN2P80 = 0.1093, MIN3P80 = 0.1182,
MIN1P90 = 0.3023, MIN2P90 = 0.6299, MIN3P90 = 0.7083),
WEBS = list(items = c(1, 2, 5, 6, 7, 8, 10, 12, 13),
min = 9, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 9, sitem = 13, DCU = 0.563,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
DISTRESS = list(items = c(15, 16, 17, 20, 21, 22, 23, 24, 25, 26,
28, 29, 33, 34, 35, 36, 37, 38, 39,
42, 43, 44, 46, 47),
min = 24, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 24, sitem = 35, DCU = 0.543,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
PAID = list(items = c(48, 49, 50, 51, 52, 54, 55, 56, 59, 60, 62, 65, 66),
min = 13, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 13, sitem = 48, DCU = 0.427,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
DFC = list(items = c(67, 69, 70, 71, 72, 74, 75, 76, 78, 80, 81, 83, 84, 85),
min = 14, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 14, sitem = 71, DCU = 0.557,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
HYPER = list(items = c(86, 87, 88, 89, 90, 94, 95, 96, 97, 98, 99, 102),
min = 12, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 12, sitem = 94, DCU = 0.517,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
HYPO = list(items = c(103, 104, 105, 107, 108, 109, 110, 113, 115),
min = 9, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 9, sitem = 104, DCU = 0.518,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
INT = list(items = c(117, 118, 120, 121, 122, 124, 125, 126, 127, 128, 130),
min = 11, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 11, sitem = 125, DCU = 0.47,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280)
)
# ----------------------------
# FORM F2
# ----------------------------
block_manifest_F2 <- list(
G = list(items = 1:130, min = 0, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 130, sitem = "APrule", DCU = 0.523,
MIN1P80 = 0.2377, MIN2P80 = 0.1093, MIN3P80 = 0.1182,
MIN1P90 = 0.3023, MIN2P90 = 0.6299, MIN3P90 = 0.7083),
WEBS = list(items = c(2, 3, 4, 8, 9, 10, 11, 12, 13),
min = 9, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 9, sitem = 13, DCU = 0.563,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
DISTRESS = list(items = c(14, 15, 16, 17, 18, 19, 26, 27, 29, 30, 31, 32,
34, 35, 36, 38, 39, 40, 41, 42, 43, 44, 45, 46),
min = 24, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 24, sitem = 35, DCU = 0.543,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
PAID = list(items = c(48, 49, 51, 52, 53, 55, 56, 57, 58, 61, 63, 64, 65, 66),
min = 14, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 14, sitem = 48, DCU = 0.427,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
DFC = list(items = c(67, 68, 69, 70, 71, 72, 73, 75, 77, 79, 80, 82, 84),
min = 13, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 13, sitem = 71, DCU = 0.557,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
HYPER = list(items = c(86, 88, 89, 91, 92, 93, 94, 95, 99, 100, 101, 102),
min = 12, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 12, sitem = 94, DCU = 0.517,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
HYPO = list(items = c(103, 104, 106, 107, 111, 112, 113, 114, 115),
min = 9, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 9, sitem = 104, DCU = 0.518,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
INT = list(items = c(116, 118, 119, 120, 121, 123, 124, 125, 126, 127, 129),
min = 11, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 11, sitem = 125, DCU = 0.47,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280)
)
# ----------------------------
# FORM F3
# ----------------------------
block_manifest_F3 <- list(
G = list(items = 1:130, min = 0, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 130, sitem = "APrule", DCU = 0.523,
MIN1P80 = 0.2377, MIN2P80 = 0.1093, MIN3P80 = 0.1182,
MIN1P90 = 0.3023, MIN2P90 = 0.6299, MIN3P90 = 0.7083),
WEBS = list(items = c(1, 2, 3, 4, 5, 6, 7, 9, 11, 13),
min = 10, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 10, sitem = 13, DCU = 0.563,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
DISTRESS = list(items = c(14, 15, 18, 19, 20, 21, 22, 23, 24, 25,
26, 27, 28, 30, 31, 32, 33, 35, 37, 40,
41, 45, 47),
min = 23, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 23, sitem = 35, DCU = 0.543,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
PAID = list(items = c(48, 49, 50, 51, 53, 54, 57, 58, 59, 60, 61, 62, 63, 64),
min = 14, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 14, sitem = 48, DCU = 0.427,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
DFC = list(items = c(67, 68, 71, 73, 74, 76, 77, 78, 79, 81, 82, 83, 85),
min = 13, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 13, sitem = 71, DCU = 0.557,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
HYPER = list(items = c(86, 87, 90, 91, 92, 93, 94, 96, 97, 98, 100, 101),
min = 12, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 12, sitem = 94, DCU = 0.517,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
HYPO = list(items = c(103, 104, 105, 106, 108, 109, 110, 111, 112, 114),
min = 10, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 10, sitem = 104, DCU = 0.518,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280),
INT = list(items = c(116, 117, 119, 122, 123, 125, 126, 128, 129, 130),
min = 10, cap = 0, target_SE = 0.447, theta_z = 0,
max_items = 10, sitem = 125, DCU = 0.47,
MIN1P80 = 0.1398, MIN2P80 = 0.2845, MIN3P80 = 0.2623,
MIN1P90 = 0.4439, MIN2P90 = 0.3521, MIN3P90 = 0.5280)
)
# ============================================================
# 5. Stateless random assignment to one of the forms
# ============================================================
# MOVED to SECTION 10
# ============================================================
# 6. Forward only adaptive logic
# ============================================================
get_completed_blocks <- function(person, block_manifest, verbose = FALSE) {
if (is.null(person$state$done_blocks)) {
person$state$done_blocks <- character(0)
}
done <- person$state$done_blocks
ans <- person$items_answered
have_hist <- !is.null(person$thetas_history) && nrow(person$thetas_history) >= 1
have_se <- !is.null(person$thetas_SE_history) && nrow(person$thetas_SE_history) >= 1
for (bn in names(block_manifest)) {
b <- block_manifest[[bn]]
if ((b$min %||% 0) <= 0) next
if (bn %in% done) next
n_in_block <- sum(ans %in% b$items)
min_needed <- b$min %||% 0
cap_allow <- b$cap %||% 0
allowed_max <- min(min_needed + cap_allow, b$max_items %||% Inf)
if (n_in_block < min_needed) next
fi <- match(bn, names(block_manifest))
theta_now <- if (have_hist) tail(person$thetas_history[, fi], 1) else NA_real_
se_now <- if (have_se) tail(person$thetas_SE_history[, fi], 1) else NA_real_
p80 <- getDynamicCutoff(bn, block_manifest, "P80")
target_se <- b$target_SE %||% 0.447
if (is.na(theta_now) || is.na(se_now)) next
if (n_in_block == min_needed) {
if (!is.na(p80) && theta_now <= p80) {
if (verbose)
message(sprintf("[DONE] %s at min=%d and theta <= P80, moving on.", bn, min_needed))
done <- unique(c(done, bn))
next
} else {
if (verbose)
message(sprintf("[REFINE] %s needs refinement after min=%d.", bn, min_needed))
}
}
stop_by_SE <- se_now <= target_se
stop_by_items <- n_in_block >= allowed_max
if (stop_by_SE) {
if (verbose)
message(sprintf("[DONE] %s SE %.3f <= target %.3f.", bn, se_now, target_se))
done <- unique(c(done, bn))
next
}
if (stop_by_items) {
if (verbose)
message(sprintf("[DONE] %s reached item cap (%d/%d).", bn, n_in_block, allowed_max))
done <- unique(c(done, bn))
next
}
}
person$state$done_blocks <- unique(done)
unique(done)
}
first_block_needing_item <- function(person, block_manifest, block_order) {
done <- get_completed_blocks(person, block_manifest)
if (length(done) == length(block_manifest)) return(NULL)
for (i in seq_along(block_order)) {
bname <- block_order[i]
if (!(bname %in% done)) {
return(i)
}
}
NULL
}
nextItemFunc <- function(design, person, test, verbose = FALSE) {
bi <- first_block_needing_item(person, block_manifest, block_order)
if (is.null(bi)) return(NA)
bname <- block_order[bi]
block <- block_manifest[[bname]]
answered <- person$items_answered
completed_blocks <- get_completed_blocks(person, block_manifest, verbose = verbose)
ineligible_items <- unlist(lapply(block_manifest[completed_blocks], `[[`, "items"))
eligible_items <- setdiff(block$items, union(answered, ineligible_items))
n_in_block <- sum(answered %in% block$items)
min_needed <- block$min %||% 0
cap_allow <- block$cap %||% 0
allowed_max <- min(min_needed + cap_allow, block$max_items %||% Inf)
if (n_in_block >= allowed_max) {
if (verbose)
message(sprintf("[BLOCK FULL] %s reached cap (%d/%d).", bname, n_in_block, allowed_max))
return(NA)
}
if (length(eligible_items) == 0L) {
bi2 <- bi + 1L
if (bi2 > length(block_order)) return(NA)
next_block <- block_manifest[[block_order[bi2]]]
eligible_items <- setdiff(next_block$items, union(answered, ineligible_items))
if (length(eligible_items) == 0L) return(NA)
block <- next_block
bname <- block_order[bi2]
if (verbose)
message(sprintf("[ADVANCE] Moving to next block: %s", bname))
}
next_it <- findNextItem(
person = person,
design = design,
test = test,
subset = eligible_items,
criteria = "APrule"
)
if (length(next_it) != 1L)
stop("customNextItem must return a single item index")
if (verbose)
message(sprintf("[SELECTED] Item %d from %s (%d answered in block)", next_it, bname, n_in_block))
as.integer(next_it)
}
# ============================================================
# 7. Shiny last page, email, and Dropbox
# ============================================================
# ============================================================
# 7. Shiny last page, email, and Dropbox (U13b final version)
# ============================================================
lastpage <- function(person) {
# --- safely retrieve per-session injected variables ---
assigned_form <- get0("assigned_form", ifnotfound = "Unknown")
token <- get0("token", ifnotfound = NULL)
gmail_creds <- get0("gmail_creds", ifnotfound = NULL)
GMAIL_USER <- get0("GMAIL_USER", ifnotfound = NULL)
ID <- if (!is.null(person$demographics$ID)) person$demographics$ID else "NoID"
timestamp <- format(Sys.time(), "%Y%m%d-%H%M%S")
# --- extract scores and SEs ---
thetas <- as.numeric(person$thetas)
ses <- as.numeric(person$thetas_SE_history[nrow(person$thetas_SE_history), ])
if (length(thetas) < 8 || length(ses) < 8) {
stop(sprintf(
"Expected at least 8 thetas/SEs for plotting but found theta length = %d, SE length = %d.",
length(thetas), length(ses)
))
}
# --- build plotting dataframe ---
df_plot <- data.frame(
Label = c(
"Overall Distress",
"Weight, Eating, and Body Concerns",
"Diabetes Distress",
"Diabetes Problem Areas",
"Diabetes Family Conflict",
"Hyperglycemia Worry",
"Hypoglycemia Worry",
"Sadness and Worry"
),
P5 = c(-1.836, -1.142, -1.290, -1.344, -1.118, -1.235, -1.287, -1.155),
P10 = c(-1.461, -0.985, -1.015, -1.020, -0.857, -1.025, -0.977, -0.975),
P15 = c(-1.195, -0.841, -0.821, -0.842, -0.727, -0.850, -0.746, -0.849),
P20 = c(-0.992, -0.730, -0.641, -0.690, -0.615, -0.656, -0.627, -0.691),
P50 = c(-0.238, -0.131, -0.050, -0.085, -0.053, -0.062, -0.049, -0.136),
P80 = c(0.541, 0.642, 0.587, 0.532, 0.512, 0.446, 0.563, 0.570),
P85 = c(0.701, 0.762, 0.717, 0.661, 0.646, 0.617, 0.692, 0.725),
P90 = c(1.011, 0.963, 0.916, 0.883, 0.862, 0.811, 0.940, 0.905),
P95 = c(1.334, 1.178, 1.213, 1.092, 1.715, 1.155, 1.352, 1.234),
theta = thetas[1:8],
SE = ses[1:8],
stringsAsFactors = FALSE
) %>%
dplyr::mutate(
Tier = dplyr::case_when(
theta >= P90 ~ 3,
theta >= P80 ~ 2,
TRUE ~ 1
),
TierLabel = dplyr::case_when(
Tier == 3 ~ "Tier 3 – Behavioral Health Supports Recommended",
Tier == 2 ~ "Tier 2 – Focused Supports Recommended",
Tier == 1 ~ "Tier 1 – Universal Supports Recommended"
),
Reliability = pmax(0, pmin(1, 1 - SE^2)),
ConfidenceLabel = sprintf("%d%% Certain", round(Reliability * 100))
) %>%
dplyr::arrange(desc(ifelse(Label == "Overall Distress", Inf, theta))) %>%
dplyr::mutate(Label = factor(Label, levels = rev(Label)))
# --- determine x-axis range ---
p20_min <- min(df_plot$P20, na.rm = TRUE)
p90_max <- max(df_plot$P90, na.rm = TRUE)
x_min <- p20_min - 0.1 * abs(p20_min)
x_max <- p90_max + 0.1 * abs(p90_max)
theta_min <- min(df_plot$theta - df_plot$SE, na.rm = TRUE)
theta_max <- max(df_plot$theta + df_plot$SE, na.rm = TRUE)
x_min <- min(x_min, theta_min)
x_max <- max(x_max, theta_max)
# --- filenames ---
if (!dir.exists("www")) dir.create("www")
img_filename <- sprintf("www/final_scores_%s_%s_%s.png", assigned_form, ID, timestamp)
rds_filename <- sprintf("www/mirtCAT_person_%s_%s_%s.rds", assigned_form, ID, timestamp)
# --- plot results ---
p <- ggplot2::ggplot(df_plot) +
ggplot2::geom_rect(aes(ymin = as.numeric(Label) - 0.4,
ymax = as.numeric(Label) + 0.4,
xmin = x_min, xmax = P20),
fill = "darkseagreen3", alpha = 0.9) +
ggplot2::geom_rect(aes(ymin = as.numeric(Label) - 0.4,
ymax = as.numeric(Label) + 0.4,
xmin = P20, xmax = P80,
fill = "Tier 1 – Universal Supports"), alpha = 0.9) +
ggplot2::geom_rect(aes(ymin = as.numeric(Label) - 0.4,
ymax = as.numeric(Label) + 0.4,
xmin = P80, xmax = P90,
fill = "Tier 2 – Focused Supports"), alpha = 0.9) +
ggplot2::geom_rect(aes(ymin = as.numeric(Label) - 0.4,
ymax = as.numeric(Label) + 0.4,
xmin = P90, xmax = x_max,
fill = "Tier 3 – Behavioral Health Supports"), alpha = 0.9) +
ggplot2::geom_errorbarh(aes(y = Label, xmin = theta - SE, xmax = theta + SE),
height = 0.2, color = "black") +
ggplot2::geom_point(aes(x = theta, y = Label), size = 5, shape = 21,
fill = "white", color = "black") +
ggplot2::scale_fill_manual(
name = "Support Recommendations",
values = c(
"Tier 1 – Universal Supports" = "darkseagreen2",
"Tier 2 – Focused Supports" = "orange",
"Tier 3 – Behavioral Health Supports" = "red3"
)
) +
ggplot2::labs(x = NULL, y = "", title = "Your Behavioral Health Scores (with Standard Error Bars)") +
ggplot2::theme_minimal(base_size = 18) +
ggplot2::theme(
axis.text.y = ggplot2::element_text(size = 16),
axis.text.x = ggplot2::element_text(size = 16),
plot.title = ggplot2::element_text(size = 20, face = "bold"),
legend.title = ggplot2::element_text(size = 16, face = "bold"),
legend.text = ggplot2::element_text(size = 14),
legend.position = "bottom",
legend.justification = "center"
) +
ggplot2::guides(fill = ggplot2::guide_legend(title.position = "top")) +
ggplot2::coord_cartesian(xlim = c(x_min, x_max))
ggplot2::ggsave(img_filename, plot = p, width = 12, height = 6)
# --- Attach all metadata safely before saving ---
if (is.null(person$state)) person$state <- list()
# Save the form, ID, timestamp
person$state$assigned_form <- assigned_form
person$state$timestamp <- timestamp
person$state$ID <- ID
# Save all demographics (including illness duration and others)
if (!is.null(person$demographics)) {
person$state$demographics_full <- person$demographics
}
# Optional: print to console for sanity check
message("✅ Saved demographics and form info to person$state:")
message(paste(names(person$state$demographics_full), collapse = ", "))
saveRDS(person, rds_filename)
# --- upload results to Dropbox (if available) ---
if (!is.null(token)) {
tryCatch({
dirs <- rdrop2::drop_dir(dtoken = token)$name
if (!any(grepl("^mirtCAT_results$", dirs))) {
rdrop2::drop_create("mirtCAT_results", dtoken = token)
}
rdrop2::drop_upload(img_filename, path = "mirtCAT_results", dtoken = token)
rdrop2::drop_upload(rds_filename, path = "mirtCAT_results", dtoken = token)
}, error = function(e) {
message("Dropbox upload failed: ", e$message)
})
}
# --- email results if email + creds available ---
raw_email <- person$demographics$email %||% ""
email_vec <- strsplit(raw_email, "\\s*[,;]\\s*")[[1]]
email_vec <- email_vec[nzchar(email_vec)]
if (length(email_vec) > 0 && !is.null(gmail_creds) && !is.null(GMAIL_USER)) {
img_data <- base64enc::dataURI(file = img_filename, mime = "image/png")
results_text <- paste0(
apply(df_plot, 1, function(r) {
sprintf("- %s:\n Score = %.2f, Certainty = %d%%\n %s\n",
r["Label"],
as.numeric(r["theta"]),
round(pmax(0, pmin(1, 1 - (as.numeric(r["SE"])^2))) * 100),
r["TierLabel"])
}),
collapse = "\n"
)
email_body <- glue::glue("
**Thank you for completing the Behavioral Health Screener!**
**Participant ID:** {ID}
**Date Completed:** {timestamp}
Below is your personalized summary of behavioral health scores:
**Results Summary (Higher Scores Indicate Greater Concern):**
{results_text}
**Understanding the Tiers:**
- **Tier 1 – Universal Supports:** Below 80th percentile; minimal concern, continue routine wellness support.
- **Tier 2 – Focused Supports:** 80th–90th percentile; some concern, additional follow-up or skill-building may help.
- **Tier 3 – Behavioral Health Supports:** Above 90th percentile; strong concern, behavioral health consultation recommended.
Average scores are near zero (range from -3 to 3 and have a standard deviation of 1). Please talk to the Diabetes Team if you have questions or concerns.
")
email <- blastula::compose_email(
body = blastula::md(email_body),
footer = NULL
)
tryCatch({
blastula::smtp_send(
email,
to = email_vec,
bcc = "xx...@gmail.com",
from = GMAIL_USER,
subject = "Your Behavioral Health Screener Results",
credentials = gmail_creds
)
}, error = function(e) {
message("Email send failed: ", e$message)
})
}
# --- final on-screen display ---
list(
h4("Thank you for completing the Behavioral Health Screener."),
img(
src = base64enc::dataURI(file = img_filename, mime = "image/png"),
style = "width:100%; height:auto; max-height:80vh;"
),
h4("Your Behavioral Health Scores:"),
tags$ul(
lapply(1:nrow(df_plot), function(i) {
tags$li(sprintf(
"%s: %.3f (%s, %s)",
as.character(df_plot$Label[i]),
df_plot$theta[i],
df_plot$ConfidenceLabel[i],
df_plot$TierLabel[i]
))
})
),
br(),
h4("Understanding the Tiers:"),
tags$ul(
tags$li(HTML("<b>Tier 1 – Universal Supports:</b> Below 80th percentile; minimal concern, continue routine wellness support.")),
tags$li(HTML("<b>Tier 2 – Focused Supports:</b> 80th–90th percentile; some concern, additional follow-up, supports, and skill-building may help.")),
tags$li(HTML("<b>Tier 3 – Behavioral Health Supports:</b> Above 90th percentile; strong concern, behavioral health consultation recommended."))
),
p("Average scores are near zero (have a standard deviation of 1, and range about –3 to 3). Please talk to the Diabetes Team if you have questions or concerns."),
br(),
h5("Please let the Diabetes Team know you have finished.")
)
}
# ============================================================
# 8. Shiny GUI and demographics
# ============================================================
make_shinyGUI_list <- function(selected_logo, friendly_name) {
demographics <- list(
textInput("ID", "Participant ID:", ""),
selectInput(
"gender", "Gender:",
choices = c(
"", "Girl/Woman", "Boy/Man", "Nonbinary",
"Another Term Not Listed Here", "Prefer not to say"
)
),
textInput("race", "Race (for example, Black, White, Asian):", ""),
textInput("ethnicity", "Ethnicity (for example, Hispanic/Latine, Non-Hispanic, Middle Eastern or North African, or N/A):", ""),
numericInput("age", "Age (years):", value = NA, min = 1, max = 25),
# ✅ Restored illness duration question
numericInput("illness_duration", "Time Since Diabetes Diagnosis (years):", value = NA, min = 0, max = 25, step = 0.1),
numericInput("hba1c", "Most Recent HbA1c (%):", value = NA, min = 4, max = 20, step = 0.1),
textInput("email", "Provide an email address to receive results (separate multiple emails with a comma):", "")
)
list(
title = "Screening to Uplift Growth And Resilience (SUGAR)",
authors = "Le Bonheur Children's Hospital & University of Memphis Pediatric Diabetes Behavioral Health Service",
instructions = c(
"Please read the following questions and select the option that is best for you.",
"Next"
),
begin_message = "Please read the following questions and select the option that is best for you. Click 'Next' to begin.",
demographics = demographics,
# ✅ Added illness_duration to the tracked input IDs
demographics_inputIDs = c(
"ID", "gender", "race", "ethnicity", "age",
"illness_duration", "hba1c", "email"
),
response_msg = "Please pick the best option for you to move on to the next question",
firstpage = list(
tags$div(
style = "text-align:center; margin-top:10px; margin-bottom:15px;",
h3(HTML("<b>Pediatric Diabetes Behavioral Health Screening</b>")),
tags$img(
src = file.path("www", selected_logo),
style = "max-height:140px; margin:15px 0;"
),
tags$h4(
HTML(sprintf("<b>SUGARCAT Form:</b> %s", friendly_name)),
style = "margin:5px 0 10px 0;"
),
tags$p(
"Instructions for clinician: The next screen will include demographic questions and options for patient IDs and emailing results. Review patient’s responses and determine if additional supports or follow-up are needed.",
style = "color:#666; font-size:90%; font-style:italic; margin-top:10px;"
)
)
),
lastpage = lastpage
)
}
# ============================================================
# 9. Block order initialization
# ============================================================
initializeBlockOrder <- function(block_manifest) {
# Remove G from randomization if it exists
all_blocks <- setdiff(names(block_manifest), "G")
# Randomize non-G blocks
block_order <- sample(all_blocks)
# Determine first block and start item
first_block <- block_order[1]
first_sitem <- block_manifest[[first_block]]$sitem
start_val <- if (is.numeric(first_sitem)) {
first_sitem
} else {
as.integer(block_manifest[[first_block]]$items[1])
}
list(
block_order = block_order,
first_block = first_block,
start_val = start_val
)
}
# ============================================================
# 10. mirtCAT run (stateless randomization, works on shinyapps.io)
# ============================================================
# Ensure Shinyapps.io can access local assets
shiny::addResourcePath("www", "www")
shiny::shinyApp(
ui = fluidPage(
shiny::tags$div(style = "padding:20px;", shiny::uiOutput("main_ui"))
),
server = function(input, output, session) {
# --- Unique session environment (per user) ---
mysession <- paste0(createSessionName(), "_", format(Sys.time(), "%Y%m%d%H%M%S"))
# --- Randomize form for this session (per user) ---
form_id <- sample(c("F1", "F2", "F3"), 1)
assigned_form <- form_id
block_manifest <- switch(
form_id,
F1 = block_manifest_F1,
F2 = block_manifest_F2,
F3 = block_manifest_F3
)
friendly_name <- form_labels[[form_id]]
selected_logo <- logo_map[[form_id]]
# --- Randomize block order ---
sess <- initializeBlockOrder(block_manifest)
block_order <- sess$block_order
first_block <- sess$first_block
start_val <- sess$start_val
start_item <- if (is.numeric(start_val)) {
as.integer(start_val)
} else {
as.integer(block_manifest[[first_block]]$items[1])
}
message(sprintf("🎲 Session: %s | Form: %s (%s) | Block order: %s | Start item: %s",
mysession, form_id, friendly_name,
paste(block_order, collapse = ' → '), start_item))
# --- Build GUI ---
shinyGUI_list <- make_shinyGUI_list(selected_logo, friendly_name)
# --- Bind these into the environment for customNextItem ---
environment(nextItemFunc) <- list2env(list(
block_manifest = block_manifest,
block_order = block_order
), parent = environment(nextItemFunc))
# --- Run CAT for this session ---
sugar <- mirtCAT_preamble(
mo = mo,
df = df,
criteria = "APrule",
start_item = start_item,
shinyGUI = shinyGUI_list,
design = list(
customNextItem = nextItemFunc,
max_items = 92,
min_SEM = 0
),
sessionName = mysession
)
# --- Launch CAT UI inside this session ---
output$main_ui <- renderUI({
createShinyGUI(sugar)
})
}
)