---
title: "Survey Research Report"
date: "`r format(Sys.Date(), '%B %d, %Y')`"
format:
  html:
    toc: true
    toc-depth: 3
    toc-location: left
    embed-resources: true
    theme: cosmo
    code-fold: true
    grid:
      sidebar-width: 280px
      body-width: 900px
      margin-width: 160px
params:
  instrument_path:     ""
  data_path:           ""
  include_codebook:    true
  include_quality:     true
  include_reliability: true
  include_analysis:    true
  include_missing:     true
  include_descriptives: true
  include_models:      true
  plot_palette:        "web"
  interpretations_path: ""
  instrument_hash:     ""
  analysis_seed:       ""
execute:
  echo:    false
  warning: false
  message: false
---

```{r setup}
library(surveyframe)
library(knitr)

`%||%` <- function(x, y) if (is.null(x)) y else x

instrument <- readRDS(params$instrument_path)
has_data   <- nzchar(params$data_path) && file.exists(params$data_path)
responses  <- if (has_data) readRDS(params$data_path) else NULL
# Written interpretations keyed by analysis-plan block id, supplied by
# render_report(interpretations = ...). Empty when none were given.
interps    <- if (nzchar(params$interpretations_path %||% "") &&
                  file.exists(params$interpretations_path)) {
  readRDS(params$interpretations_path)
} else {
  list()
}
```

```{=html}
<style>
/* Brand look shared with render_results() and the static survey: system font,
   navy headings, teal accent. */
body { font-family: system-ui, -apple-system, "Segoe UI", Roboto, sans-serif;
       color: #1a1a2e; }
h1, h2, h3, h4, h5, #title-block-header .title { color: #1a1a2e; }
a { color: #16B3B1; }
#TOC .active, .sidebar-item .active { color: #16B3B1; }

/* Academic (APA) tables: horizontal rules only, no shading, no vertical lines.
   Each table is its own horizontal-scroll container so wide tables stay within
   the content column. Overrides the theme's default table styling. */
table { display: block; overflow-x: auto; max-width: 100%;
        border-collapse: collapse; margin: 14px 0; }
th, td { padding: 7px 14px; vertical-align: top;
         border: none !important; background: none !important; }
thead th { border-top: 2px solid #1a1a2e !important;
           border-bottom: 1px solid #1a1a2e !important; font-weight: 700; }
tbody tr { background: none !important; }
tbody tr:last-child td { border-bottom: 2px solid #1a1a2e !important; }
.cell-output-display, .cell-output { overflow-x: auto; max-width: 100%; }

/* Shared footer */
.sf-foot { text-align: center; font-size: 12px; color: #94a3b8;
           margin-top: 48px; padding-top: 16px; border-top: 1px solid #eee; }
.sf-foot a { color: #16B3B1; font-weight: 600; text-decoration: none; }
</style>
```

---

*Generated by [surveyframe](https://github.com/MohammedAliSharafuddin/surveyframe). Reproduce this report by calling `render_report()` with the same instrument and data.*

---

```{r meta}
#| output: asis
m <- instrument$meta
cat(sprintf("**Instrument:** %s\n\n", m$title %||% "Untitled"))
cat(sprintf("**Version:** %s\n\n", m$version %||% ""))
if (!is.null(m$description) && nzchar(m$description))
  cat(sprintf("**Description:** %s\n\n", m$description))
if (!is.null(m$authors) && length(m$authors) > 0)
  cat(sprintf("**Authors:** %s\n\n", paste(m$authors, collapse = ", ")))
cat(sprintf("**Validation status:** %s\n\n",
  if (isTRUE(m$validated)) "Valid" else "Not validated"))
```

---

## Codebook {#sec-codebook .unnumbered}

```{r codebook, eval=params$include_codebook}
#| tbl-cap: "Survey items"
cb <- codebook_report(instrument)
items_d <- sframe_codebook_items_display(cb)
items_d$reverse  <- ifelse(items_d$reverse,  "Yes", "")
items_d$required <- ifelse(items_d$required, "Yes", "")
kable(format = "html", items_d,
  col.names = c("ID","Label","Type","Response options","Scale","Reverse","Required"),
  align = c("l","l","l","l","l","c","c"))
```

```{r codebook-scales, eval=params$include_codebook && nrow(cb$scales_table) > 0}
#| tbl-cap: "Scale definitions"
kable(format = "html", cb$scales_table,
  col.names = c("ID","Label","Method","Items (n)","Item IDs"),
  align = c("l","l","l","c","l"))
```

```{r codebook-plan, eval=params$include_codebook && !is.null(cb$plan_table) && nrow(cb$plan_table) > 0}
#| tbl-cap: "Pre-declared analysis plan"
kable(format = "html", cb$plan_table,
  col.names = c("ID","Research question","Method","Variables","Decision rule"),
  align = c("l","l","l","l","l"))
```

```{r codebook-models, eval=params$include_codebook && !is.null(cb$models_table) && nrow(cb$models_table) > 0}
#| tbl-cap: "Measurement and structural models"
kable(format = "html", cb$models_table,
  col.names = c("ID","Label","Type","Engine","Constructs","Paths"),
  align = c("l","l","l","l","c","c"))
```

---

## Data Quality {#sec-quality .unnumbered}

```{r quality-check, eval=params$include_quality && has_data}
qr <- quality_report(responses, instrument)
```

```{r quality-summary, eval=params$include_quality && has_data}
#| output: asis
cat(sprintf("**Respondents:** %d | **Items:** %d | **Flagged:** %d (%.1f%%)\n\n",
  qr$summary$n_respondents, qr$summary$n_items,
  qr$summary$n_flagged, qr$summary$flag_rate * 100))
```

```{r quality-attention, eval=params$include_quality && has_data && length(qr$attention) > 0}
#| tbl-cap: "Attention check results"
attn_df <- do.call(rbind, lapply(qr$attention, function(a)
  data.frame(Check=a$check_id, Type=a$type,
    Pass_rate=sprintf("%.1f%%", a$pass_rate*100),
    Failures=a$n_fail, Action=a$fail_action,
    stringsAsFactors=FALSE)))
kable(format = "html", attn_df, align=c("l","l","r","r","l"))
```

```{r quality-missing, eval=params$include_quality && has_data}
#| output: asis
miss_pct <- mean(qr$missing$respondent_miss > qr$missing$flagged_threshold, na.rm=TRUE)*100
cat(sprintf("**Respondent missingness:** %.1f%% exceed the %.0f%% threshold.\n\n",
  miss_pct, qr$missing$flagged_threshold*100))
high_miss <- qr$missing$item_miss_rate[qr$missing$item_miss_rate > 0.10]
if (length(high_miss) > 0) {
  cat("Items with >10% missing:\n\n")
  print(kable(format = "html", data.frame(Item=names(high_miss),
    Missing=sprintf("%.1f%%", high_miss*100), stringsAsFactors=FALSE),
    align=c("l","r")))
} else { cat("No items exceed 10% missing values.\n\n") }
```

```{r quality-sl, eval=params$include_quality && has_data && length(qr$straightline) > 0}
#| tbl-cap: "Straight-lining by scale"
sl_df <- do.call(rbind, lapply(qr$straightline, function(s)
  data.frame(Scale=s$scale_id, Items=s$n_items,
    Flagged=sprintf("%.1f%%", s$flag_rate*100), stringsAsFactors=FALSE)))
kable(format = "html", sl_df, align=c("l","c","r"))
```

---

## Missing Data {#sec-missing .unnumbered}

```{r missing-data, eval=params$include_missing && has_data}
#| output: asis
mr <- tryCatch(missing_data_report(responses, instrument), error = function(e) NULL)
if (is.null(mr)) {
  cat("Missing-data diagnostics could not be computed from the supplied data.\n\n")
} else {
  print(kable(format = "html", mr$item_missing, digits = 2, caption = "Item-wise missingness"))
  patterns_display <- mr$patterns[, intersect(c("description", "n", "percent"), names(mr$patterns)), drop = FALSE]
  print(kable(format = "html", patterns_display, digits = 2, caption = "Missing-data patterns",
              col.names = c("Pattern", "n", "Percent")))
  if (!is.null(mr$scale_missing_rules) && nrow(mr$scale_missing_rules) > 0)
    print(kable(format = "html", mr$scale_missing_rules, digits = 2, caption = "Scale missing rules"))
}
```

---

## Descriptives {#sec-descriptives .unnumbered}

```{r descriptives, eval=params$include_descriptives && has_data}
#| output: asis
dr <- tryCatch(descriptives_report(responses), error = function(e) NULL)
if (is.null(dr)) {
  cat("Descriptive statistics could not be computed from the supplied data.\n\n")
} else {
  print(kable(format = "html", dr$table, digits = 2, caption = "Descriptive statistics"))
}
```

---

## Response distributions {#sec-distributions .unnumbered}

```{r distributions, eval=params$include_descriptives && has_data, fig.width=7, fig.height=3.2, fig.align='left'}
#| output: asis
THEME <- instrument$render$theme %||% "#16B3B1"
if (!grepl("^#[0-9A-Fa-f]{3,6}$", THEME)) THEME <- "#16B3B1"

choice_by <- function(id) {
  for (c in instrument$choices %||% list()) if (identical(c$id, id)) return(c)
  NULL
}
q_items <- Filter(function(i) !(i$type %in% c("section_break", "text_block")),
                  instrument$items %||% list())

has_ggplot <- requireNamespace("ggplot2", quietly = TRUE)
plot_palette <- params$plot_palette %||% "web"

# A scale's separate Likert items get one grouped diverging chart, the same
# way a matrix question's rows do, instead of scattering a related batch of
# items across several single-item charts.
scale_groups <- sframe_likert_scale_groups(instrument)
group_of <- character(0)
for (g in scale_groups) {
  ids <- vapply(g$items, function(i) i$id, character(1))
  group_of[ids] <- g$scale_id
}
rendered_groups <- character(0)

# One bar chart per categorical item, one histogram per numeric item. Every
# chart here shares the ggplot2 theme_surveyframe() (theme_classic()-based)
# look used everywhere else in the report, so this section reads as one
# consistent chart family rather than a mix of base-R and ggplot styling.
for (item in q_items) {
  t <- item$type
  if (item$id %in% names(group_of)) {
    gid <- group_of[[item$id]]
    if (gid %in% rendered_groups || !has_ggplot) next
    rendered_groups <- c(rendered_groups, gid)
    g <- scale_groups[[gid]]
    gg <- sframe_plot_likert_scale(g$items, responses, g$choice_set, g$title,
                                   palette = plot_palette)
    if (is.null(gg)) next
    cat(sprintf("\n**%s**\n\n", g$title))
    print(gg)
    cat("\n\n")
    next
  }
  if (identical(t, "matrix")) {
    # A matrix question has no base response column of its own, only one
    # expanded <id>__<row> column per row, so it needs its own existence
    # check and its own chart: every row plotted together, grouped, rather
    # than as separate single-item charts that lose the question's grouping.
    if (!has_ggplot) next
    cs <- choice_by(item$choice_set %||% "")
    gg <- sframe_plot_likert_matrix(item, responses, cs, palette = plot_palette)
    if (is.null(gg)) next
    cat(sprintf("\n**%s**\n\n", item$label %||% item$id))
    print(gg)
    cat("\n\n")
    next
  }
  if (!item$id %in% names(responses)) next
  col <- responses[[item$id]]
  if (t %in% c("likert", "single_choice", "multiple_choice")) {
    cs <- choice_by(item$choice_set %||% "")
    if (!is.null(cs)) {
      freq <- table(factor(col, levels = as.character(cs$values)))
      names(freq) <- cs$labels
    } else freq <- table(col)
    if (!sum(freq)) next
    cat(sprintf("\n**%s**\n\n", item$label %||% item$id))
    if (identical(t, "likert") && length(freq) >= 2) {
      # A Likert item is an ordered agree/disagree scale: a diverging bar
      # shows which way opinion leans in one glance, unlike a plain
      # frequency bar that does not distinguish "agree" from "disagree".
      sframe_draw_likert_diverging(freq, THEME)
    } else if (has_ggplot) {
      print(sframe_plot_item_chart(item, col, cs, palette = plot_palette))
    } else {
      op <- par(mar = c(4, 11, 1, 1)); barplot(freq, horiz = TRUE, las = 1,
        col = THEME, border = NA, xlab = "Frequency", cex.names = .8); par(op)
    }
    cat("\n\n")
  } else if (t %in% c("numeric", "slider", "rating")) {
    num <- suppressWarnings(as.numeric(col)); num <- num[!is.na(num)]
    if (!length(num)) next
    cat(sprintf("\n**%s**\n\n", item$label %||% item$id))
    if (has_ggplot) {
      print(sframe_plot_item_chart(item, col, NULL, palette = plot_palette))
    } else {
      op <- par(mar = c(4, 4, 1, 1)); hist(num, col = THEME, border = "white",
        main = NULL, xlab = item$label, ylab = "Count", las = 1); par(op)
    }
    cat("\n\n")
  }
}

# One histogram per scale score
for (sc in instrument$scales %||% list()) {
  cols <- intersect(sc$items, names(responses))
  if (!length(cols)) next
  nums <- lapply(responses[cols], function(x) suppressWarnings(as.numeric(x)))
  scores <- rowMeans(do.call(cbind, nums), na.rm = TRUE); scores <- scores[!is.na(scores)]
  if (!length(scores)) next
  cat(sprintf("\n**%s (scale score)**\n\n", sc$label %||% sc$id))
  if (has_ggplot) {
    print(sframe_plot_scale_chart(scores, sc$label %||% sc$id, palette = plot_palette))
  } else {
    op <- par(mar = c(4, 4, 1, 1)); hist(scores, col = THEME, border = "white",
      main = NULL, xlab = paste0(sc$label %||% sc$id, " score"), ylab = "Count", las = 1)
    abline(v = mean(scores), col = "#dc2626", lwd = 2, lty = 2); par(op)
  }
  cat("\n\n")
}
```

---

## Reliability {#sec-reliability .unnumbered}

```{r reliability, eval=params$include_reliability && has_data}
#| output: asis
rr <- tryCatch(reliability_report(responses, instrument), error = function(e) NULL)
if (is.null(rr)) {
  cat("Reliability statistics could not be computed from the supplied data.\n\n")
} else if (length(rr) == 0) {
  cat("No scales with two or more matching response columns found.\n\n")
} else {
  rel_df <- do.call(rbind, lapply(rr, function(s)
    data.frame(Scale=paste0(s$label," (",s$scale_id,")"),
      N_items=s$n_items, N=s$n,
      Alpha   = if (!is.null(s$alpha))   sprintf("%.2f", s$alpha)   else "n/a",
      Omega_h = if (!is.null(s$omega_h)) sprintf("%.2f", s$omega_h) else "n/a",
      Omega_t = if (!is.null(s$omega_t)) sprintf("%.2f", s$omega_t) else "n/a",
      stringsAsFactors=FALSE)))
  print(kable(format = "html", rel_df,
    col.names=c("Scale","Items","N","Alpha","Omega h","Omega total"),
    align=c("l","c","c","r","r","r"),
    caption="Scale reliability statistics"))
}
```

---

## Analysis Plan {#sec-analysis .unnumbered}

```{r analysis, eval=params$include_analysis && length(instrument$analysis_plan) > 0}
#| output: asis
if (!has_data) {
  for (i in seq_along(instrument$analysis_plan)) {
    rq <- instrument$analysis_plan[[i]]
    cat(sprintf("### RQ %d: %s\n\n", i, rq$research_question %||% "(untitled)"))
    cat(sprintf("**Planned test:** %s\n\n", rq$test %||% ""))
    if (length(rq$variables %||% character(0)) > 0)
      cat(sprintf("**Variables:** %s\n\n", paste(rq$variables, collapse = ", ")))
    if (nzchar(rq$interpretation %||% ""))
      cat(sprintf("**Interpretation prompt:** %s\n\n", rq$interpretation))
    override <- interps[[rq$id %||% ""]] %||% ""
    if (nzchar(override))
      cat(sprintf("**Interpretation:** %s\n\n", override))
  }
} else {
  results <- tryCatch(
    run_analysis_plan(responses, instrument,
                      plots = requireNamespace("ggplot2", quietly = TRUE),
                      plot_palette = params$plot_palette %||% "web"),
    error=function(e) NULL)
  if (is.null(results)) {
    cat("Analysis plan could not be executed. Check that variable names match response columns.\n\n")
  } else {
    for (i in seq_along(results)) {
      r <- results[[i]]
      cat(sprintf("### RQ %d: %s\n\n", i, r$research_question %||% "(untitled)"))
      if (!is.null(r$error)) {
        cat(sprintf("> **Error:** %s\n\n", r$error))
      } else {
        scale_entries <- Filter(function(e) is.list(e) && !is.null(e$scale_id), r)
        if (!is.null(r$apa)) {
          cat(sprintf("**Result:** %s\n\n", r$apa))
        } else if (length(scale_entries) == 0) {
          cat("**Result:** see the matching section of this report above.\n\n")
        }
        if (!is.null(r$syntax)) {
          cat("````\n")
          cat(r$syntax)
          cat("\n````\n\n")
        }
        if (is.null(r$apa) && length(scale_entries) > 0) {
          rel_tab <- do.call(rbind, lapply(scale_entries, function(s)
            data.frame(
              Scale = paste0(s$label %||% s$scale_id, " (", s$scale_id, ")"),
              Items = s$n_items %||% NA,
              Alpha = if (!is.null(s$alpha)) sprintf("%.2f", s$alpha) else "n/a",
              stringsAsFactors = FALSE)))
          print(kable(format = "html", rel_tab, align = c("l", "c", "r"), row.names = FALSE))
          cat("\n")
        }
        if (!is.null(r$effect_label))
          cat(sprintf("**Effect size:** %s\n\n", r$effect_label))
        if (!is.null(r$table) && is.data.frame(r$table))
          print(kable(format = "html", r$table, digits = 2))
        # The chart for this result sits directly under its table, as one
        # unit per research question, rather than in a separate section.
        if (!is.null(r$plot)) {
          cat("\n")
          print(r$plot)
          cat("\n")
        }
        override <- interps[[r$block_id %||% r$id %||% ""]] %||% ""
        if (nzchar(override)) {
          # A written interpretation renders alongside the pre-declared
          # decision rule, so the prospective contract stays visible.
          if (nzchar(r$decision_rule %||% ""))
            cat(sprintf("\n**Planned decision rule:** %s\n\n", r$decision_rule))
          cat(sprintf("\n**Interpretation:** %s\n\n", override))
        } else if (nzchar(r$interpretation %||% "")) {
          cat(sprintf("\n**Interpretation:** %s\n\n", r$interpretation))
        }
        if (length(r$citations) > 0) {
          cat("**References:**\n\n")
          lapply(r$citations, function(cit) cat(sprintf("- %s\n", cit)))
          cat("\n")
        }
      }
    }
  }
}
```

---

## Model Appendix {#sec-models .unnumbered}

```{r models, eval=params$include_models && length(instrument$models %||% list()) > 0}
#| output: asis
for (model in instrument$models) {
  cat(sprintf("### %s\n\n", model$label %||% model$id))
  cat(sprintf("**Type:** %s  \n**Engine:** %s\n\n", model$type %||% "", model$engine %||% ""))
  syntax <- tryCatch(
    switch(model$type,
      cfa = cfa_lavaan_syntax(instrument = instrument, model = model),
      cb_sem = sem_lavaan_syntax(model, instrument = instrument),
      pls_sem = seminr_syntax(model),
      efa = efa_syntax(unlist(lapply(model$measurement$constructs, function(con) con$items))),
      ""
    ),
    error = function(e) paste("Model syntax could not be generated:", conditionMessage(e))
  )
  cat("```r\n")
  cat(syntax)
  cat("\n```\n\n")
  cat("```json\n")
  cat(model_json(model, pretty = TRUE))
  cat("\n```\n\n")
}
```

---

## Reproducibility {#sec-repro .unnumbered}

```{r repro}
#| output: asis
hash_val <- params$instrument_hash
if (is.null(hash_val) || !nzchar(hash_val)) hash_val <- "see .sframe file"
cat(sprintf("**Instrument hash:** `%s`\n\n", hash_val))
# The engine and the seed belong next to the hash: the hash says which
# instrument this describes, the engine says which of surveyframe's 2
# renderers produced it, and the seed says what reproducing the numbers takes.
cat("**Rendering engine:** Quarto\n\n")
seed_val <- params$analysis_seed
if (is.null(seed_val) || !nzchar(seed_val)) seed_val <- "not recorded"
cat(sprintf("**Analysis seed:** `%s`\n\n", seed_val))
cat(sprintf("**Report generated:** %s\n\n", format(Sys.time(), "%Y-%m-%d %H:%M %Z")))
cat("**To reproduce:**\n\n")
cat("```r\nlibrary(surveyframe)\n")
cat("instr     <- read_sframe(\"your_instrument.sframe\")\n")
cat("responses <- read_responses(\"your_responses.csv\", instr)\n")
cat("render_report(instr, data = responses, output_file = \"report.html\")\n```\n\n")
```

```{=html}
<div class="sf-foot">Built with <a href="https://cran.r-project.org/package=surveyframe" target="_blank" rel="noopener">surveyframe</a></div>
```
