Scale Reliability (Cronbach's Alpha)

The code that produced every figure in this report, exactly as it ran. Fingerprint 2548d10fa9604485. The same code on the same data gives the same report.

`standard_reliability_v2` <- function(pf) {
  `%||%` <- function(a, b) if (!is.null(a)) a else b
  #' Readable figures (LAT-3180, LAT-3181): whole numbers from a thousand up, one decimal from a hundred, two from
  #' one, three significant figures below one. A cell carries what the value needs, not what R prints.
  tidy <- function(x) {
    x <- as.numeric(x)
    ifelse(is.na(x), NA_real_,
      ifelse(abs(x) >= 1000, round(x, 0),
        ifelse(abs(x) >= 100, round(x, 1),
          ifelse(abs(x) >= 1, round(x, 2), signif(x, 3)))))
  }
  p_text <- function(p) if (is.na(p)) "" else if (p < 1e-4) "<0.0001" else format(signif(p, 3))
  inputs <- pf$taskList$inputs
  question <- (inputs$userContext %||% list())$objective %||%
    "Are these items consistent enough to be summed into one scale, and which item, if any, should be cut?"

  #' ## Column mapping
  #' Three or more numeric `item_N` columns (a series, any number) answered by the same respondents, and an optional
  #' `respondent_id`. Semantic names inside; the customer's own headers live in `col_map`.
  col_map <- inputs$column_mapping %||% list()
  df <- renderObject.taskFunction.init(inputs, col_map)   # df has SEMANTIC names
  human <- function(sem) {
    v <- col_map[[sem]]
    if (is.null(v) || !nzchar(as.character(v))) sem else as.character(v)
  }
  item_cols <- grep("^item_[0-9]+$", names(df), value = TRUE)
  item_cols <- item_cols[order(as.integer(sub("^item_", "", item_cols)))]
  if (length(item_cols) < 3) stop("column_mapping must map at least three numeric columns to item_1, item_2, item_3, ... (the items of one scale).")
  has_id <- "respondent_id" %in% names(df)
  n_in <- nrow(df)

  #' ## The columns this tool did not look at, read from the raw rows (init narrows `df` to the mapped columns)
  raw_names <- local({
    ds <- inputs$dataset %||% inputs$df
    if (is.data.frame(ds)) return(names(ds))
    if (is.list(ds) && length(ds) > 0) {
      rows <- ds[seq_len(min(length(ds), 50))]
      nm <- unique(unlist(lapply(rows, function(r) if (is.list(r)) names(r) else NULL)))
      if (length(nm)) return(nm)
      if (!is.null(names(ds)) && all(nzchar(names(ds)))) return(names(ds))
    }
    character(0)
  })
  mapped_actual <- unique(as.character(unlist(col_map)))
  ignored_cols <- setdiff(raw_names, unique(c(mapped_actual, make.names(mapped_actual))))

  #' ## Data preparation
  #' Each item is coerced to numeric (95% rule); an item that is not numeric or has no spread is excluded and named. A
  #' respondent missing any usable item is excluded and counted (listwise). At least three usable items and 10 complete
  #' responses are required.
  excluded_items <- character(0); why <- character(0)
  usable <- character(0)
  for (ic in item_cols) {
    v <- suppressWarnings(as.numeric(as.character(df[[ic]])))
    ok <- !is.na(v); raw_ok <- !is.na(df[[ic]]) & nzchar(trimws(as.character(df[[ic]])))
    if (sum(raw_ok) == 0 || sum(ok) / max(1, sum(raw_ok)) < 0.95) { excluded_items <- c(excluded_items, human(ic)); why <- c(why, "not numeric"); next }
    if (stats::sd(v, na.rm = TRUE) %in% c(NA, 0)) { excluded_items <- c(excluded_items, human(ic)); why <- c(why, "no spread"); next }
    df[[ic]] <- v; usable <- c(usable, ic)
  }
  k <- length(usable)
  if (k < 3) stop(sprintf("Only %d usable numeric item%s after exclusions (%s); alpha needs at least three.", k, if (k == 1) "" else "s",
                          if (length(excluded_items)) paste(paste(excluded_items, why, sep = ": "), collapse = "; ") else "none excluded"))
  complete <- stats::complete.cases(df[, usable, drop = FALSE])
  n_missing <- sum(!complete)
  X <- as.matrix(df[complete, usable, drop = FALSE])
  n <- nrow(X)
  if (n < 10) stop(sprintf("Only %d complete responses across the %d items; alpha needs at least 10.", n, k))
  hn <- vapply(usable, human, character(1))
  colnames(X) <- hn

  #' ## Alpha, standardized alpha, the Feldt interval, omega
  alpha_of <- function(M) { kk <- ncol(M); (kk / (kk - 1)) * (1 - sum(apply(M, 2, stats::var)) / stats::var(rowSums(M))) }
  var_total <- stats::var(rowSums(X))
  if (!is.finite(var_total) || var_total <= 0) stop("The summed scale score has no variance; reliability cannot be estimated.")
  alpha <- alpha_of(X)
  C <- suppressWarnings(stats::cor(X))
  off <- C[upper.tri(C)]; off <- off[is.finite(off)]
  rbar <- mean(off); r_min <- min(off); r_max <- max(off)
  alpha_std <- (k * rbar) / (1 + (k - 1) * rbar)
  feldt <- function(a, n, k, level = 0.95) {
    df1 <- n - 1; df2 <- (n - 1) * (k - 1); a2 <- 1 - level
    c(1 - (1 - a) * stats::qf(1 - a2 / 2, df1, df2), 1 - (1 - a) * stats::qf(a2 / 2, df1, df2))
  }
  aci <- feldt(alpha, n, k); sci <- feldt(alpha_std, n, k)
  fa <- tryCatch(suppressWarnings(stats::factanal(X, factors = 1)), error = function(e) NULL)
  omega <- if (!is.null(fa)) { l <- fa$loadings[, 1]; sum(l)^2 / (sum(l)^2 + sum(fa$uniquenesses)) } else NA_real_
  fa_p <- if (!is.null(fa) && !is.null(fa$PVAL)) as.numeric(fa$PVAL) else NA_real_
  ev <- eigen(C, symmetric = TRUE, only.values = TRUE)$values
  first_share <- ev[1] / sum(ev); ev_ratio <- ev[1] / ev[2]

  #' ## Per item: corrected item-total correlation and alpha-if-deleted
  itc <- numeric(k); aid <- numeric(k)
  for (i in seq_len(k)) {
    others <- rowSums(X[, -i, drop = FALSE])
    itc[i] <- if (stats::var(others) > 0) suppressWarnings(stats::cor(X[, i], others)) else NA_real_
    aid[i] <- if (k - 1 >= 2) alpha_of(X[, -i, drop = FALSE]) else NA_real_
  }
  verdict <- ifelse(is.na(itc), "not estimable", ifelse(itc < 0, "reverse-coded", ifelse(itc < 0.30, "weak", "keep")))
  reverse_items <- hn[!is.na(itc) & itc < 0]; weak_items <- hn[!is.na(itc) & itc >= 0 & itc < 0.30]
  raise <- !is.na(aid) & aid > alpha
  best_i <- if (any(!is.na(aid))) which.max(ifelse(is.na(aid), -Inf, aid)) else NA_integer_
  band <- function(a) if (is.na(a)) "not estimable" else if (a < 0.5) "unacceptable" else if (a < 0.6) "poor" else
    if (a < 0.7) "questionable" else if (a < 0.8) "acceptable" else if (a < 0.9) "good" else "excellent"
  pairs <- which(upper.tri(C) & C > 0.90, arr.ind = TRUE)
  n_redundant <- nrow(pairs)

  #' ## The frames for the places
  interval_df <- data.frame(form = c("Cronbach's alpha", "Standardized alpha", "McDonald's omega"),
                            estimate = round(c(alpha, alpha_std, omega), 3),
                            low = round(c(aci[1], sci[1], NA), 3), high = round(c(aci[2], sci[2], NA), 3), stringsAsFactors = FALSE)
  itc_df <- data.frame(item = hn, item_total_correlation = round(itc, 3), stringsAsFactors = FALSE)
  aid_df <- data.frame(item = c(hn, "Full scale"), alpha_if_deleted = round(c(aid, alpha), 3), stringsAsFactors = FALSE)
  stats_df <- data.frame(item = hn, mean = round(colMeans(X), 2), sd = round(apply(X, 2, stats::sd), 2),
                         item_total_correlation = round(itc, 3), alpha_if_deleted = round(aid, 3), verdict = verdict, stringsAsFactors = FALSE)
  mat_df <- data.frame(item_1 = rep(hn, times = k), item_2 = rep(hn, each = k), r = round(as.vector(C), 3), stringsAsFactors = FALSE)
  long <- data.frame(score = as.vector(X), item = rep(hn, each = n), stringsAsFactors = FALSE)
  if (nrow(long) > 1000) { set.seed(20260917); long <- long[sort(sample.int(nrow(long), 1000)), , drop = FALSE] }
  best_row <- if (!is.na(best_i)) data.frame(statistic = sprintf("Alpha without %s (best single deletion)", hn[best_i]),
    estimate = round(aid[best_i], 3), low = NA, high = NA, band = band(aid[best_i]),
    reading = if (raise[best_i]) "the scale is more consistent without this item; if it is reverse-coded, re-score it instead" else "no single deletion raises alpha; the scale holds together as it stands",
    stringsAsFactors = FALSE) else NULL
  table_df <- rbind(data.frame(
    statistic = c("Cronbach's alpha", "Standardized alpha", "McDonald's omega (one factor)", "Mean inter-item correlation", "Lowest inter-item correlation", "Highest inter-item correlation"),
    estimate = round(c(alpha, alpha_std, omega, rbar, r_min, r_max), 3),
    low = round(c(aci[1], sci[1], NA, NA, NA, NA), 3), high = round(c(aci[2], sci[2], NA, NA, NA, NA), 3),
    band = c(band(alpha), band(alpha_std), band(omega), "", "", ""),
    reading = c("consistency of the scale summed as it is, from the item variances and the total", "the same for items first put on one spread, from the mean inter-item correlation",
                "the share of the total score variance the one common factor explains; agrees with alpha when the items load equally",
                "how much any two items agree on average; 0.15 to 0.50 is the usual range for one scale", "the pair that agrees least", "the pair that agrees most; above 0.90 the two items are redundant"),
    stringsAsFactors = FALSE), best_row)

  #' ## Assumption checks (LAT-3138)
  miss_share <- n_missing / n_in
  checks_df <- data.frame(
    check = c("Enough items", "Enough complete responses", "One underlying dimension", "No reverse-coded item", "No redundant pair", "Few missing responses"),
    statistic = c(sprintf("%d items", k), sprintf("%d complete of %d rows", n, n_in),
                  sprintf("first eigenvalue %.1f%% of the total, %.1f times the second%s", 100 * first_share, ev_ratio,
                          if (is.na(fa_p)) "" else sprintf("; one-factor fit p = %s", p_text(fa_p))),
                  sprintf("%d item%s with a negative item-total correlation", length(reverse_items), if (length(reverse_items) == 1) "" else "s"),
                  sprintf("%d pair%s above r = 0.90", n_redundant, if (n_redundant == 1) "" else "s"),
                  sprintf("%d of %d rows missing an item", n_missing, n_in)),
    p_value = c("", "", if (is.na(fa_p)) "" else p_text(fa_p), "", "", ""),
    verdict = c(if (k >= 5) "holds" else if (k >= 3) "strained" else "violated",
                if (n >= 100) "holds" else if (n >= 30) "strained" else "violated",
                if (ev_ratio >= 3) "holds" else if (ev_ratio >= 2) "strained" else "violated",
                if (length(reverse_items) == 0) "holds" else "violated",
                if (n_redundant == 0) "holds" else "strained",
                if (miss_share <= 0.05) "holds" else if (miss_share <= 0.15) "strained" else "violated"),
    note = c("alpha rises with the number of items; a short scale reads low even when its items agree",
             "few responses widen the interval",
             "alpha assumes the items measure one thing; with two dimensions it is a floor on the wrong quantity",
             "an item scored in the opposite direction deflates alpha until it is re-scored",
             "two near-identical items inflate alpha without adding information",
             "rows missing any item are left out; if they are the disengaged respondents, consistency is overstated"),
    stringsAsFactors = FALSE)

  #' ## Method, assumptions, answer
  excluded <- c(if (length(excluded_items)) sprintf("%d item%s excluded (%s)", length(excluded_items), if (length(excluded_items) == 1) "" else "s", paste(paste(excluded_items, why, sep = ": "), collapse = "; ")),
                if (n_missing > 0) sprintf("%d row%s missing an item", n_missing, if (n_missing == 1) "" else "s"))
  method <- paste0(
    "Cronbach's alpha over ", k, " items (", paste(hn, collapse = ", "), ") and ", n, " complete responses of ", n_in,
    ", from the item variances and the variance of the summed score; 95% interval by Feldt's F method; standardized alpha from the mean inter-item Pearson correlation; ",
    "McDonald's omega total from a one-factor maximum-likelihood model", if (is.na(omega)) " (did not converge, not reported)" else "",
    "; corrected item-total correlations against the sum of the other items; alpha-if-deleted by recomputing alpha without each item; bands after George and Mallery",
    if (length(excluded)) paste0("; excluded: ", paste(excluded, collapse = "; ")) else "",
    if (length(ignored_cols)) paste0("; not used: ", paste(utils::head(ignored_cols, 12), collapse = ", "), " (not mapped)") else "", ".")
  assumptions <- list(
    "The items measure one underlying construct; alpha for a multidimensional set is not a reliability.",
    "Every item is scored in the same direction; a reverse-worded item must be re-scored before summing.",
    "Alpha grows with the number of items, so a long scale of weakly related items can still read high.",
    "The Feldt interval assumes the items are parallel measures with normal errors; treat it as approximate.",
    "A high alpha does not show the scale measures what it is meant to; that is validity, not reliability.")
  answer <- list(alpha = round(alpha, 3), alpha_low = round(aci[1], 3), alpha_high = round(aci[2], 3), band = band(alpha),
                 alpha_std = round(alpha_std, 3), omega = round(omega, 3), mean_inter_item_r = round(rbar, 3),
                 items = k, responses = n, weak_items = as.list(unname(weak_items)), reverse_items = as.list(unname(reverse_items)),
                 best_deletion = if (!is.na(best_i)) unname(hn[best_i]) else NULL, alpha_without_best = if (!is.na(best_i)) round(aid[best_i], 3) else NULL)

  results <- list()
  #' The verdict and the headline are NOT places of a library tool (LAT-3130): the last mile writes them.
  results$summary_metrics <- place_metric(list(alpha = round(alpha, 3), alpha_low = round(aci[1], 3), alpha_high = round(aci[2], 3),
    alpha_std = round(alpha_std, 3), omega = round(omega, 3), mean_inter_item_r = round(rbar, 3), items = k, responses = n),
    lead = "alpha", place = "summary_metrics")
  results$alpha_interval <- place_interval(interval_df, term = "form", value = "estimate", low = "low", high = "high", place = "alpha_interval")
  results$item_total <- place_comparison(itc_df, category = "item", value = "item_total_correlation", place = "item_total")
  results$alpha_if_deleted <- place_comparison(aid_df, category = "item", value = "alpha_if_deleted", place = "alpha_if_deleted")
  results$item_statistics <- place_table(stats_df, place = "item_statistics")
  results$inter_item_matrix <- place_matrix(mat_df, x = "item_2", y = "item_1", z = "r", place = "inter_item_matrix")
  results$item_distributions <- place_distribution(long, x = "score", series = "item", place = "item_distributions")
  results$reliability_table <- place_table(table_df, place = "reliability_table")
  results$assumption_checks <- place_table(checks_df, place = "assumption_checks")
  results$reliability_method <- place_method(method = method, n_in = n_in, n_used = n, assumptions = assumptions,
                                             excluded = as.list(excluded), place = "reliability_method")

  objects <- list()   # filled by the object layer, not here
  list(answer = answer, method = method, n = n, results = results, objects = objects,
       json_output = list(answer = answer, method = method, n = n))
}