## ----setup, include=FALSE-----------------------------------------------------
knitr::opts_chunk$set(collapse = TRUE, comment = "#>")
library(cdCAT)
set.seed(42)

## ----item-bank----------------------------------------------------------------
# Q-matrix: 12 items x 2 attributes
# Items 1-4:  domain "Algebra"   (attribute 1 only)
# Items 5-8:  domain "Geometry"  (attribute 2 only)
# Items 9-12: domain "Mixed"     (both attributes)
Q <- matrix(c(
  1, 0,   # item 1
  1, 0,   # item 2
  1, 0,   # item 3
  1, 0,   # item 4
  0, 1,   # item 5
  0, 1,   # item 6
  0, 1,   # item 7
  0, 1,   # item 8
  1, 1,   # item 9
  1, 1,   # item 10
  1, 1,   # item 11
  1, 1    # item 12
), nrow = 12, ncol = 2, byrow = TRUE)

slip  <- c(0.10, 0.12, 0.08, 0.11,   # Algebra
           0.10, 0.09, 0.12, 0.11,   # Geometry
           0.10, 0.11, 0.09, 0.12)   # Mixed

guess <- c(0.20, 0.18, 0.22, 0.19,   # Algebra
           0.20, 0.21, 0.18, 0.20,   # Geometry
           0.15, 0.17, 0.16, 0.18)   # Mixed

items <- cdcat_items(
  q_matrix = Q,
  model    = "DINA",
  slip     = slip,
  guess    = guess
)

# Content domain vector (one label per item)
content <- c(
  rep("Algebra",  4),
  rep("Geometry", 4),
  rep("Mixed",    4)
)

print(items)

## ----content-setup------------------------------------------------------------
# Target: 33% from each domain
content_prop <- c(
  Algebra  = 1/3,
  Geometry = 1/3,
  Mixed    = 1/3
)

## ----content-session----------------------------------------------------------
session_cb <- CdcatSession$new(
  items        = items,
  criterion    = "PWKL",
  method       = "MAP",
  min_items    = 9L,    # force all items to be administered for illustration
  max_items    = 9L,
  content      = content,
  content_prop = content_prop
)

print(session_cb)

# Simulate a respondent who masters both attributes
simulated_responses <- c(1, 1, 1, 1,   # Algebra items  (correct)
                         0, 0, 0, 0,   # Geometry items (incorrect)
                         1, 0, 1, 0)   # Mixed items    (mixed)

repeat {
  item <- session_cb$next_item()
  if (item == 0) break
  session_cb$update(item, simulated_responses[item])
}

res_cb <- session_cb$result()

## ----content-results----------------------------------------------------------
domain_counts <- table(content[res_cb$administered])
domain_prop   <- round(domain_counts / res_cb$n_items, 2)

cat("Items administered:", res_cb$administered, "\n")
cat("Domain counts     :\n")
print(domain_counts)
cat("Domain proportions:\n")
print(domain_prop)
cat("Target proportions:", round(content_prop, 2), "\n")

## ----content-direct-----------------------------------------------------------
# After administering items 1 and 2 (both Algebra),
# the gap favours Geometry or Mixed
candidates <- apply_content_balancing(
  candidate_items = 3:12,
  administered    = c(1L, 2L),
  content         = content,
  content_prop    = content_prop
)
cat("Filtered candidates:", candidates, "\n")
cat("Their domains      :", content[candidates], "\n")

## ----sh-session---------------------------------------------------------------
# Items 9-12 (Mixed) are very informative; limit their exposure to 60%
exposure_sh        <- rep(0.9, 12)
exposure_sh[9:12]  <- 0.8

session_sh <- CdcatSession$new(
  items    = items,
  criterion = "PWKL",
  method   = "MAP",
  min_items = 6L,
  max_items = 6L,
  exposure  = exposure_sh
)

print(session_sh)

repeat {
  item <- session_sh$next_item()
  if (item == 0) break
  session_sh$update(item, simulated_responses[item])
}

res_sh <- session_sh$result()
cat("Items administered:", res_sh$administered, "\n")
cat("Estimated profile :", res_sh$alpha_hat, "\n")

## ----rq-session---------------------------------------------------------------
# At positions 1-3 draw from top-3; positions 4-6 draw from top-2
exposure_rq      <- rep(1L, 12)
exposure_rq[1:3] <- 3L
exposure_rq[4:6] <- 2L

session_rq <- CdcatSession$new(
  items     = items,
  criterion = "PWKL",
  method    = "MAP",
  min_items = 6L,
  max_items = 6L,
  exposure  = exposure_rq
)

print(session_rq)

repeat {
  item <- session_rq$next_item()
  if (item == 0) break
  session_rq$update(item, simulated_responses[item])
}

res_rq <- session_rq$result()
cat("Items administered:", res_rq$administered, "\n")
cat("Estimated profile :", res_rq$alpha_hat, "\n")

## ----exposure-direct----------------------------------------------------------
# Sympson-Hetter: item 10 has score 0.9 but only 20% acceptance probability
scores    <- c(0.4, 0.6, 0.7, 0.9, 0.3, 0.5)
available <- 7:12

# Global exposure vector (length = total items in bank)
p_sh <- rep(0.9, 12)
p_sh[10] <- 0.2   # item with score 0.9

set.seed(123)
selected <- apply_sympson_hetter(scores, available, p_sh)
cat("Selected item (Sympson-Hetter):", selected, "\n")

# Randomesque: draw from top-2
selected_rq <- apply_randomesque(scores, available, n = 2L)
cat("Selected item (Randomesque)   :", selected_rq, "\n")

## ----shadow-greedy------------------------------------------------------------
greedy_shadow <- function(scores, items, administered) {
  scores[administered] <- -Inf
  which.max(scores)
}

session_shadow_greedy <- CdcatSession$new(
  items      = items,
  criterion  = "PWKL",
  method     = "MAP",
  min_items  = 6L,
  max_items  = 6L,
  constr_fun = greedy_shadow
)

print(session_shadow_greedy)

## ----shadow-custom------------------------------------------------------------
make_constrained_shadow <- function(content, enemy_pairs) {

  function(scores, items, administered) {

    J         <- items$n_items
    available <- setdiff(seq_len(J), administered)

    if (length(available) == 0)
      return(NA_integer_)

    # --- Enemy item constraint
    for (pair in enemy_pairs) {
      if (pair[1] %in% administered)
        available <- setdiff(available, pair[2])
      if (pair[2] %in% administered)
        available <- setdiff(available, pair[1])
    }

    if (length(available) == 0)
      available <- setdiff(seq_len(J), administered)  # fallback

    # --- Domain cap: at most 2 items per domain in any window of 4
    if (length(administered) > 0) {
      domain_counts <- table(content[administered])
      capped_domains <- names(domain_counts[domain_counts >= 2])
      if (length(capped_domains) > 0 && length(available) > 1) {
        filtered <- available[!content[available] %in% capped_domains]
        if (length(filtered) > 0)
          available <- filtered
      }
    }

    # --- Select highest-scoring item from filtered pool
    available[which.max(scores[available])]
  }
}

constr_fn <- make_constrained_shadow(
  content     = content,
  enemy_pairs = list(c(3L, 7L))  # items 3 and 7 cannot coexist
)

session_shadow <- CdcatSession$new(
  items      = items,
  criterion  = "PWKL",
  method     = "MAP",
  min_items  = 8L,
  max_items  = 8L,
  constr_fun = constr_fn
)

repeat {
  item <- session_shadow$next_item()
  if (item == 0) break
  session_shadow$update(item, simulated_responses[item])
}

res_shadow <- session_shadow$result()
cat("Items administered:", res_shadow$administered, "\n")
cat("Domains           :", content[res_shadow$administered], "\n")

# Verify enemy constraint: items 3 and 7 do not coexist
has_3 <- 3L %in% res_shadow$administered
has_7 <- 7L %in% res_shadow$administered
cat("Enemy pair (3, 7) both present:", has_3 & has_7, "\n")

## ----shadow-lp, eval=FALSE----------------------------------------------------
# # This example requires: install.packages("lpSolve")
# 
# make_lp_shadow <- function(content, content_prop, n_items_total) {
# 
#   function(scores, items, administered) {
# 
#     J    <- items$n_items
#     resp <- integer(J)
#     resp[administered] <- 1L
# 
#     # Build constraint matrix
#     # Row 1: total items == n_items_total
#     # Rows 2-4: domain proportions (each domain gets floor(n_items_total/3) items)
#     n_per_domain <- floor(n_items_total / length(content_prop))
#     domains      <- names(content_prop)
#     n_constr     <- 1L + length(domains)
# 
#     lhs  <- matrix(0, nrow = n_constr, ncol = J)
#     dirs <- character(n_constr)
#     rhs  <- numeric(n_constr)
# 
#     # Already-administered items must stay
#     lhs  <- rbind(lhs, resp)
#     dirs <- c(dirs, "==")
#     rhs  <- c(rhs, sum(resp))
# 
#     # Row 1: total items
#     lhs[1, ]  <- 1
#     dirs[1]   <- "=="
#     rhs[1]    <- n_items_total
# 
#     # Rows 2+: per-domain counts
#     for (i in seq_along(domains)) {
#       lhs[i + 1L, content == domains[i]] <- 1
#       dirs[i + 1L] <- ">="
#       rhs[i + 1L]  <- n_per_domain
#     }
# 
#     obj <- scores
#     obj[administered] <- obj[administered] * resp[administered]
# 
#     out <- lpSolve::lp(
#       direction  = "max",
#       objective.in  = obj,
#       const.mat  = lhs,
#       const.dir  = dirs,
#       const.rhs  = rhs,
#       all.bin    = TRUE
#     )
# 
#     if (out$status != 0L)
#       stop("lpSolve could not find a feasible solution.")
# 
#     solution <- out$solution
#     solution[administered] <- 0
#     if (sum(solution) == 0L) return(NA_integer_)
#     as.integer(which.max(solution * scores))
#   }
# }
# 
# session_lp <- CdcatSession$new(
#   items      = items,
#   criterion  = "PWKL",
#   method     = "MAP",
#   min_items  = 9L,
#   max_items  = 9L,
#   constr_fun = make_lp_shadow(content, content_prop, n_items_total = 9L)
# )
# 
# repeat {
#   item <- session_lp$next_item()
#   if (item == 0) break
#   session_lp$update(item, simulated_responses[item])
# }
# 
# res_lp <- session_lp$result()
# cat("Items administered:", res_lp$administered, "\n")
# cat("Domains           :", content[res_lp$administered], "\n")

## ----combined-----------------------------------------------------------------
# Content balancing + Sympson-Hetter exposure
exposure_combined        <- rep(0.9, 12)
exposure_combined[9:12]  <- 0.5   # limit Mixed items

session_combined <- CdcatSession$new(
  items        = items,
  criterion    = "PWKL",
  method       = "MAP",
  min_items    = 6L,
  max_items    = 6L,
  content      = content,
  content_prop = content_prop,
  exposure     = exposure_combined
)

print(session_combined)

repeat {
  item <- session_combined$next_item()
  if (item == 0) break
  session_combined$update(item, simulated_responses[item])
}

res_combined <- session_combined$result()
cat("Items administered:", res_combined$administered, "\n")
cat("Domains           :", content[res_combined$administered], "\n")
cat("Estimated profile :", res_combined$alpha_hat, "\n")