## ----setup, include = FALSE--------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>", fig.width = 7, fig.height = 5, warning = FALSE, message = FALSE ) ## ----load_data---------------------------------------------------------------- library(r4lineups) lineup_data <- as.data.frame(simulate_lineup_data( n_tp = 300, n_ta = 300, d_prime = 1.5, c_criterion = 0.9, # see the note below: 0 would be far too liberal lineup_size = 6, conf_levels = 5, foil_bias = c(0.4, 0.2, 0.0, -0.4, -1.0), seed = 2024 )) head(lineup_data) ## ----criterion_warning-------------------------------------------------------- too_liberal <- as.data.frame(simulate_lineup_data( n_tp = 300, n_ta = 300, d_prime = 1.5, c_criterion = 0, lineup_size = 6, conf_levels = 5, seed = 2024 )) knitr::kable( data.frame( `c_criterion` = c(0, 0.9), `Rejection rate (%)` = round(100 * c( mean(too_liberal$identification == "reject"), mean(lineup_data$identification == "reject") ), 1), check.names = FALSE ), row.names = FALSE, caption = "Rejection rate under two decision criteria, simulated data (300 target-present and 300 target-absent lineups)." ) ## ----compare_all_models------------------------------------------------------- # Fit all three models comparison <- compare_models( lineup_data, models = c("2ht", "eig", "fullroc"), lineup_size = 6, prior_guilt = 0.5 ) # View comparison table print(comparison) ## ----detailed_summary--------------------------------------------------------- # More detailed output summary(comparison) ## ----visualize_models, fig.width=10, fig.height=4.5--------------------------- # Side-by-side plots plot(comparison, ncol = 3) ## ----model_2ht---------------------------------------------------------------- # Access 2-HT model model_2ht <- comparison$fitted_models$`2ht` knitr::kable( data.frame(Parameter = names(model_2ht$parameters), Estimate = round(unname(model_2ht$parameters), 3), SE = round(unname(model_2ht$se), 3)), row.names = FALSE, caption = "2-HT parameter estimates with standard errors, simulated data." ) cat("AIC:", round(model_2ht$aic, 2), " BIC:", round(model_2ht$bic, 2), " log-likelihood:", round(model_2ht$loglik, 2), "\n") ## ----model_eig---------------------------------------------------------------- # Access EIG model model_eig <- comparison$fitted_models$eig # View EIG value cat("Expected Information Gain:", round(model_eig$eig, 4), "bits\n") cat("Information Efficiency:", round(model_eig$eig / model_eig$prior_entropy * 100, 1), "%\n") # Most informative responses cat("\nTop 5 most informative response categories:\n") print(head(model_eig$response_data[, c("response", "information_gain", "posterior_guilty")], 5)) ## ----model_fullroc------------------------------------------------------------ # Access Full ROC model model_fullroc <- comparison$fitted_models$fullroc # View AUC cat("Full ROC AUC:", round(model_fullroc$auc, 4), "\n") cat("Operating Points:", model_fullroc$summary$n_operating_points, "\n") # View diagnosticity table (top 10 points) cat("\nTop 10 most diagnostic evidence categories:\n") print(head(model_fullroc$diagnosticity_table[, c("evidence_label", "diagnosticity_ratio")], 10)) ## ----model_selection---------------------------------------------------------- cat("2-HT Model Fit:\n") cat(" AIC:", round(comparison$fitted_models$`2ht`$aic, 2), "\n") cat(" BIC:", round(comparison$fitted_models$`2ht`$bic, 2), "\n") cat("\nAIC and BIC compare likelihood-based models fitted to the same data.\n") cat("EIG and full-ROC AUC are not likelihoods, so they cannot be ranked\n") cat("against the 2-HT model by information criteria.\n") ## ----specific_models---------------------------------------------------------- # Fit only 2-HT and EIG (skip Full ROC) comparison_subset <- compare_models( lineup_data, models = c("2ht", "eig"), lineup_size = 6, prior_guilt = 0.5 ) print(comparison_subset) ## ----confidence_bins---------------------------------------------------------- # Bin confidence for EIG and Full ROC comparison_binned <- compare_models( lineup_data, models = c("eig", "fullroc"), lineup_size = 6, confidence_bins = c(0, 40, 70, 100) # Low, medium, high ) cat("Binned confidence results:\n") print(comparison_binned) ## ----custom_prior------------------------------------------------------------- # Use different prior probability for EIG comparison_prior <- compare_models( lineup_data, models = "eig", prior_guilt = 0.3 # Assume 30% base rate ) cat("EIG with prior = 0.3:\n") print(comparison_prior$fitted_models$eig$eig) ## ----simulation_example------------------------------------------------------- sim_data <- as.data.frame(simulate_lineup_data( n_tp = 300, n_ta = 300, d_prime = 1.5, c_criterion = 0.9, lineup_size = 6, conf_levels = 5, foil_bias = c(0.4, 0.2, 0.0, -0.4, -1.0), seed = 2026 )) sim_comparison <- compare_models( sim_data, models = c("2ht", "eig", "fullroc"), lineup_size = 6 ) print(sim_comparison) ## ----parameter_recovery------------------------------------------------------- recovery <- do.call(rbind, lapply(c(0.5, 1.0, 1.5, 2.0, 2.5), function(dp) { d <- as.data.frame(simulate_lineup_data( n_tp = 400, n_ta = 400, d_prime = dp, c_criterion = 0.9, lineup_size = 6, conf_levels = 5, foil_bias = c(0.4, 0.2, 0.0, -0.4, -1.0), seed = 500 + round(10 * dp) )) fit <- fit_winter_2ht(d, lineup_size = 6, target_present = "target_present", identification = "identification") data.frame(`True d'` = dp, `Fitted dP` = round(fit$parameters[["dP"]], 3), `Fitted dA` = round(fit$parameters[["dA"]], 3), check.names = FALSE) })) knitr::kable( recovery, row.names = FALSE, caption = "2-HT detection parameters fitted to data simulated from a signal detection model at known d', 400 lineups per arm." ) ## ----example_procedure-------------------------------------------------------- # Fit all models to assess procedure procedure_eval <- compare_models( lineup_data, models = c("2ht", "eig", "fullroc") ) fm <- procedure_eval$fitted_models knitr::kable( data.frame( Measure = c("2-HT dP (SE)", "EIG, bits (share of prior entropy)", "Full ROC AUC (diagnosticity ordering)"), Estimate = c(sprintf("%.3f (%.3f)", fm$`2ht`$parameters[["dP"]], fm$`2ht`$se[["dP"]]), sprintf("%.3f (%.0f%%)", fm$eig$eig, 100 * fm$eig$eig / fm$eig$prior_entropy), sprintf("%.3f", fm$fullroc$auc)) ), row.names = FALSE, caption = "Three summaries of the same simulated procedure, prior guilt .5." ) ## ----example_bias------------------------------------------------------------- params <- comparison$fitted_models$`2ht`$parameters model_2ht <- comparison$fitted_models$`2ht` knitr::kable( data.frame(Parameter = "b (biased suspect selection)", Estimate = round(params[["b"]], 3), `95% Wald interval` = sprintf("[%.3f, %.3f]", max(0, params[["b"]] - 1.96 * model_2ht$se[["b"]]), min(1, params[["b"]] + 1.96 * model_2ht$se[["b"]])), check.names = FALSE), row.names = FALSE, caption = "2-HT bias parameter, simulated data (300 target-present and 300 target-absent lineups)." ) ## ----example_detection-------------------------------------------------------- knitr::kable( data.frame( Parameter = c("dP (detect culprit present)", "dA (detect culprit absent)", "g (guessing-based selection)"), Estimate = round(c(params[["dP"]], params[["dA"]], params[["g"]]), 3) ), row.names = FALSE, caption = "2-HT detection and guessing parameters, simulated data." ) ## ----table_console------------------------------------------------------------ # Console-friendly table table_console <- format_comparison_table(comparison, format = "console") print(table_console) ## ----table_markdown, results='asis'------------------------------------------- table_md <- format_comparison_table(comparison, format = "markdown") # One element per line, so sep = "\n" is required. Plain cat(table_md) joins # the lines with spaces and the table collapses into a single paragraph. cat(table_md, sep = "\n") ## ----pitfall_sample_size------------------------------------------------------ # Small sample may lead to unreliable estimates small_data <- simulate_lineup_data(n_tp = 30, n_ta = 30, d_prime = 1.5, conf_levels = 5) small_comparison <- compare_models( small_data, models = c("2ht", "eig"), show_warnings = FALSE ) cat("Warning: Small samples (n=60) may produce unstable parameter estimates\n") cat("Recommend: n ≥ 100 per condition for reliable model fitting\n") ## ----pitfall_comparison------------------------------------------------------- cat("Important: Don't directly compare across models!\n\n") cat("✗ Wrong: 'dP = 0.6 is better than EIG = 0.4'\n") cat(" → These are different scales and constructs\n\n") cat("✓ Right: 'dP rose from 0.45 to 0.60 between conditions, and EIG\n") cat(" (prior .5) rose from 0.30 to 0.40 bits'\n") cat(" → Compare each measure with itself across conditions\n") ## ----best_practice_multiple--------------------------------------------------- # Always fit at least 2-3 models comprehensive <- compare_models( lineup_data, models = c("2ht", "eig", "fullroc") ) cat("Fitting multiple models provides:\n") cat(" • Process-level understanding (2-HT)\n") cat(" • Overall diagnosticity (EIG)\n") cat(" • Threshold-free performance (Full ROC)\n") ## ----best_practice_reporting-------------------------------------------------- cat("In your paper, report:\n") cat(" • 2-HT: Parameters with SE, AIC/BIC, convergence\n") cat(" • EIG: Value in bits, efficiency percentage\n") cat(" • Full ROC: AUC, number of operating points\n") cat(" • What each model's estimates say about the procedure\n") ## ----best_practice_assumptions------------------------------------------------ summary(comparison$fitted_models$`2ht`)