R/design-report.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

.r4vn_formula_text <- function(x) {
  if (is.null(x) || !length(x) || !nzchar(x)) return("")
  x <- gsub("\\\\times", " \u00d7 ", x)
  x <- gsub("\\\\cdot", " \u00b7 ", x)
  x <- gsub("\\\\leq", " <= ", x)
  x <- gsub("\\\\geq", " >= ", x)
  x <- gsub("\\\\alpha", "alpha", x)
  x <- gsub("\\\\beta", "beta", x)
  x <- gsub("\\\\rho", "rho", x)
  x <- gsub("\\\\mu", "mu", x)
  x <- gsub("\\\\sigma", "sigma", x)
  x <- gsub("\\\\text\\{([^}]*)\\}", "\\1", x, perl = TRUE)
  for (i in 1:20) {
    y <- gsub("\\\\frac\\{([^{}]+)\\}\\{([^{}]+)\\}", "(\\1)/(\\2)", x, perl = TRUE)
    if (identical(y, x)) break
    x <- y
  }
  x <- gsub("\\$", "", x)
  x <- gsub("[{}]", "", x)
  x <- gsub("\\\\", "", x)
  x <- gsub("_", " ", x)
  x <- gsub(" +", " ", x)
  trimws(x)
}

.r4vn_design_report_lines <- function(project, sections = c("study_design","sample_size","sampling","randomization")) {
  lines <- character()
  add <- function(...) lines <<- c(lines, ...)
  add("R4VN STUDY DESIGN STUDIO", paste0("Project: ", project$name), "")

  if("study_design" %in% sections && !is.null(project$study_design)) {
    x <- project$study_design
    add("STUDY DESIGN", paste0("Recommended design: ", x$design), "", "Why this design?")
    add(paste0("- ", x$why))
    if(length(x$alternatives)) { add("", "Alternatives considered"); add(paste0("- ",x$alternatives)) }
    if(length(x$best_for)) add("", paste0("Best suited for: ",paste(x$best_for,collapse=", ")))
    if(length(x$considerations)) add(paste0("Important considerations: ",paste(x$considerations,collapse=", ")))
    if(!is.null(x$guideline)) add(paste0("Reporting guidance: ",x$guideline))
    add("")
  }

  if("sample_size" %in% sections && !is.null(project$sample_size)) {
    x <- project$sample_size
    add("SAMPLE SIZE",paste0("Method: ",x$method_name),"")
    add("Formula",paste0("$$",x$formula,"$$"),"","Numerical substitution",paste0("$$",x$substitution,"$$"),"")
    add("Calculation")
    add(x$steps)
    if(length(x$adjustment_formula)) {
      add("", "Adjustments")
      for(i in seq_along(x$adjustment_formula)) add(paste0("$$",x$adjustment_formula[i],"$$"), paste0("$$",x$adjustment_substitution[i],"$$"))
      add(x$adjustment_steps)
    }
    add("")
    if(length(x$final_group_n)>1) add(paste0("Final group sample sizes: ",paste(x$final_group_n,collapse=" + ")))
    add(paste0("Final target sample size: ",x$final_n))
    add(paste0("Design effect: ",x$design_effect))
    add(paste0("Loss/non-response: ",.r4vn_design_pct(x$loss,1)))
    if(isTRUE(x$fpc_applied)) add(paste0("Finite population correction: applied; N=",x$population))
    add("", "Methods statement", .r4vn_ss_method_paragraph(x), "", "Reference", x$reference, "")
  }

  if("sampling" %in% sections && !is.null(project$sampling)) {
    x <- project$sampling
    add("SAMPLING",paste0("Method: ",x$method_label %||% x$method),paste0("Run ID: ",x$run_id),paste0("Seed: ",x$seed),paste0("Frame hash: ",x$frame_hash),paste0("Selected records: ",x$n_selected),"")
    if(!is.null(x$summary_text)) add(x$summary_text,"")
    add("### Methods", "", .r4vn_sampling_method_paragraph(x), "")
  }

  if("randomization" %in% sections && !is.null(project$randomization)) {
    x <- project$randomization
    add("RANDOMIZATION",paste0("Method: ",x$method_label %||% x$method),paste0("Run ID: ",x$run_id),paste0("Seed: ",x$seed),paste0("Participant-source hash: ",x$frame_hash),paste0("Randomized participants: ",x$n_selected),"")
    if(!is.null(x$details$block_sizes)) add(paste0("Block sizes used: ", paste(x$details$block_sizes, collapse=", ")))
    if(!is.null(x$summary_text)) add(x$summary_text,"")
    add("### Methods", "", .r4vn_randomization_method_paragraph(x), "")
  }
  lines
}

.r4vn_design_export_word <- function(project, file, sections=c("study_design","sample_size","sampling","randomization"), plot_file=NULL) {
  .r4vn_design_require("rmarkdown","Word export with formatted equations")
  .r4vn_design_require("knitr","Word export with formatted equations")
  esc <- function(x) gsub("\\|","\\\\|",as.character(x))
  lines <- c(
    "---",
    "title: \"R4VN Study Design Studio\"",
    paste0("subtitle: \"Project: ", gsub('"','\\\\"',project$name), "\""),
    "output:",
    "  word_document:",
    "    toc: false",
    "---",
    "",
    paste0("Generated: ",format(Sys.time(),"%Y-%m-%d %H:%M:%S")),
    ""
  )
  add <- function(...) lines <<- c(lines, ...)

  if("study_design" %in% sections && !is.null(project$study_design)) {
    x <- project$study_design
    add("# Study Design", "", paste0("## ",x$design), "", "### Why this design?")
    add(paste0("- ",x$why))
    if(length(x$alternatives)) { add("", "### Alternative designs"); add(paste0("- ",x$alternatives)) }
    if(length(x$considerations)) { add("", "### Important considerations"); add(paste0("- ",x$considerations)) }
    if(!is.null(x$guideline)) add("",paste0("**Reporting guidance:** ",x$guideline))
    add("")
  }

  if("sample_size" %in% sections && !is.null(project$sample_size)) {
    x <- project$sample_size
    meth <- tryCatch(.r4vn_ss_get_method(x$method_id),error=function(e) NULL)
    ids <- names(x$inputs)
    if(is.null(meth)) {
      plab <- ids; phelp <- rep("",length(ids))
    } else {
      mp <- setNames(meth$inputs,vapply(meth$inputs,`[[`,character(1),"id"))
      plab <- vapply(ids,function(id) if(id %in% names(mp)) mp[[id]]$label else id,character(1))
      phelp <- vapply(ids,function(id) if(id %in% names(mp)) .r4vn_ss_parameter_guidance(mp[[id]]) else "",character(1))
    }
    vals <- vapply(x$inputs,function(z) paste(z,collapse=", "),character(1))
    add("# Sample Size", "", paste0("## ",x$method_name), "")
    add("### Planning parameters", "", "| Parameter | Value |", "|---|---:|")
    for(i in seq_along(ids)) add(paste0("| ",esc(plab[i])," | ",esc(vals[i])," |"))
    if(any(nzchar(phelp))) {
      add("", "### Parameter notes", "")
      for(i in seq_along(ids)) if(nzchar(phelp[i])) add(paste0("**",plab[i],".** ",phelp[i]),"")
    }
    add("### Formula", "", paste0("$$",x$formula,"$$"), "", "### Numerical substitution", "", paste0("$$",x$substitution,"$$"), "", "### Calculation", "")
    add(paste0(seq_along(x$steps),". ",x$steps))
    if(length(x$adjustment_formula)) {
      add("", "### Adjustments", "")
      for(i in seq_along(x$adjustment_formula)) add(paste0("$$",x$adjustment_formula[i],"$$"),"",paste0("$$",x$adjustment_substitution[i],"$$"),"")
      if(length(x$adjustment_steps)) add(paste0("- ",x$adjustment_steps))
    }
    add("",paste0("### Final target sample size: ",x$final_n),"")
    if(!is.null(plot_file) && file.exists(plot_file)) add("![](plot.png){width=85%}","")
    add("### Methods statement", "", .r4vn_ss_method_paragraph(x), "", "### Reference", "", x$reference, "")
  }

  if("sampling" %in% sections && !is.null(project$sampling)) {
    x <- project$sampling
    add("# Sampling","",paste0("**Method:** ",x$method_label %||% x$method),paste0("**Seed:** ",x$seed),paste0("**Selected records:** ",x$n_selected),paste0("**Reproducibility ID:** ",x$run_id),"")
    if(!is.null(x$summary_text)) add(x$summary_text,"")
    add("### Methods", "", .r4vn_sampling_method_paragraph(x), "")
  }

  if("randomization" %in% sections && !is.null(project$randomization)) {
    x <- project$randomization
    add("# Randomization","",paste0("**Method:** ",x$method_label %||% x$method),paste0("**Seed:** ",x$seed),paste0("**Randomized participants:** ",x$n_selected))
    if(!is.null(x$details$block_sizes)) add(paste0("**Block sizes used:** ",paste(x$details$block_sizes,collapse=", ")))
    add("", "### Methods", "", .r4vn_randomization_method_paragraph(x), "")
  }

  rmd <- tempfile(fileext=".Rmd")
  on.exit(unlink(rmd),add=TRUE)
  wd <- dirname(rmd)
  if(!is.null(plot_file) && file.exists(plot_file)) file.copy(plot_file,file.path(wd,"plot.png"),overwrite=TRUE)
  writeLines(lines,rmd,useBytes=TRUE)
  out <- rmarkdown::render(rmd, output_format="word_document", output_file=basename(file), output_dir=dirname(file), quiet=TRUE, envir=new.env(parent=globalenv()))
  invisible(out)
}

.r4vn_design_export_pdf <- function(project,file,sections=c("study_design","sample_size","sampling","randomization"),plot_file=NULL) {
  .r4vn_design_require("rmarkdown","PDF export")
  .r4vn_design_require("knitr","PDF export")
  lines <- .r4vn_design_report_lines(project,sections)
  rmd <- tempfile(fileext=".Rmd")
  on.exit(unlink(rmd),add=TRUE)
  wd<-dirname(rmd)
  if(!is.null(plot_file) && file.exists(plot_file)) file.copy(plot_file,file.path(wd,"plot.png"),overwrite=TRUE)

  html_txt <- c(
    "---",
    "title: \"R4VN Study Design Studio\"",
    paste0("subtitle: \"",gsub('"','\\\\"',project$name),"\""),
    "output: html_document",
    "---",
    "",
    paste(lines,collapse="\n\n")
  )
  if(!is.null(plot_file) && file.exists(plot_file)) html_txt<-c(html_txt,"","![](plot.png){width=90%}")
  writeLines(html_txt,rmd,useBytes=TRUE)
  html_file <- rmarkdown::render(rmd, output_file="report.html", output_dir=wd, quiet=TRUE, envir=new.env(parent=globalenv()))
  if(requireNamespace("pagedown", quietly=TRUE)) {
    pagedown::chrome_print(input = html_file, output = file, wait = 2)
    return(invisible(file))
  }

  txt2 <- c(
    "---",
    "title: \"R4VN Study Design Studio\"",
    paste0("subtitle: \"",gsub('"','\\\\"',project$name),"\""),
    "output: pdf_document",
    "geometry: margin=1in",
    "---",
    "",
    paste(lines,collapse="\n\n")
  )
  if(!is.null(plot_file) && file.exists(plot_file)) txt2<-c(txt2,"","![](plot.png){width=90%}")
  writeLines(txt2,rmd,useBytes=TRUE)
  out<-rmarkdown::render(rmd,output_file=basename(file),output_dir=dirname(file),quiet=TRUE,envir=new.env(parent=globalenv()))
  invisible(out)
}

.r4vn_randomization_export_word <- function(run, file, title = "R4VN Randomization List") {
  .r4vn_design_require("officer", "print-ready randomization Word export")
  .r4vn_design_require("flextable", "print-ready randomization Word export")
  tab <- .r4vn_randomization_print_table(run)
  doc <- officer::read_docx()
  doc <- officer::body_add_par(doc, title, style = "heading 1")
  doc <- officer::body_add_par(doc, paste0("R4VN Study Design Studio | Seed: ", run$seed), style = "Normal")
  if(!is.null(run$details$block_sizes)) doc <- officer::body_add_par(doc, paste0("Permuted block sizes specified: ", paste(run$details$block_sizes, collapse=", ")), style = "Normal")
  doc <- officer::body_add_par(doc, "Print and store this allocation list according to the study's allocation-concealment procedure.", style = "Normal")

  for(i in seq_len(nrow(tab))) {
    fields <- c("Sequence","Group")
    if("Stratum" %in% names(tab)) fields <- c(fields,"Stratum")
    if("Block" %in% names(tab)) fields <- c(fields,"Block")
    if("Block size" %in% names(tab)) fields <- c(fields,"Block size")
    vals <- vapply(fields,function(nm) as.character(tab[[nm]][i]),character(1))
    card <- data.frame(Item=fields,Value=vals,stringsAsFactors=FALSE)
    ft <- flextable::flextable(card)
    ft <- flextable::delete_part(ft, part="header")
    ft <- flextable::bold(ft, j=1, bold=TRUE, part="body")
    ft <- flextable::fontsize(ft, size=12, part="all")
    ft <- flextable::width(ft, j=1, width=1.5)
    ft <- flextable::width(ft, j=2, width=4.6)
    ft <- flextable::padding(ft, padding=5, part="all")
    doc <- flextable::body_add_flextable(doc,ft)
    doc <- officer::body_add_par(doc,"",style="Normal")
    if(i %% 7L == 0L && i < nrow(tab)) doc <- officer::body_add_break(doc)
  }
  print(doc, target = file)
  invisible(file)
}

.r4vn_randomization_export_pdf <- function(run, file, title = "R4VN Randomization List") {
  .r4vn_design_require("rmarkdown", "print-ready randomization PDF export")
  .r4vn_design_require("knitr", "print-ready randomization PDF export")
  tab <- .r4vn_randomization_print_table(run)
  rmd <- tempfile(fileext = ".Rmd")
  on.exit(unlink(rmd), add = TRUE)
  env <- new.env(parent = globalenv())
  env$allocation_table <- tab
  env$seed <- run$seed
  env$block_sizes <- if(is.null(run$details$block_sizes)) "" else paste(run$details$block_sizes, collapse=", ")
  wd <- dirname(rmd)
  html_txt <- c(
    "---",
    paste0("title: \"", gsub('"','\\\\"',title), "\""),
    "output: html_document",
    "---",
    "",
    "<style>",
    "body{font-family:Arial,sans-serif;font-size:12pt;margin:18mm;}",
    ".meta{margin-bottom:14px;color:#444;}",
    ".alloc-card{border:1px solid #666;border-radius:5px;padding:8px 12px;margin:0 0 8px 0;page-break-inside:avoid;}",
    ".alloc-grid{display:grid;grid-template-columns:120px 1fr;row-gap:4px;}",
    ".lab{font-weight:700;}.val{font-size:14pt;}",
    ".page-break{page-break-after:always;}",
    "</style>",
    "",
    "<div class='meta'>",
    "**R4VN Study Design Studio**  ",
    "`r paste0('Seed: ', seed)`  ",
    "`r if(nzchar(block_sizes)) paste0('Permuted block sizes specified: ', block_sizes) else ''`",
    "</div>",
    "",
    "```{r echo=FALSE, results='asis'}",
    "for(i in seq_len(nrow(allocation_table))){",
    "  fields <- c('Sequence','Group')",
    "  if('Stratum' %in% names(allocation_table)) fields <- c(fields,'Stratum')",
    "  if('Block' %in% names(allocation_table)) fields <- c(fields,'Block')",
    "  if('Block size' %in% names(allocation_table)) fields <- c(fields,'Block size')",
    "  cat(\"<div class='alloc-card'><div class='alloc-grid'>\")",
    "  for(nm in fields) cat(sprintf(\"<div class='lab'>%s</div><div class='val'>%s</div>\",nm,allocation_table[[nm]][i]))",
    "  cat(\"</div></div>\")",
    "  if(i %% 7 == 0 && i < nrow(allocation_table)) cat(\"<div class='page-break'></div>\")",
    "}",
    "```"
  )
  writeLines(html_txt, rmd, useBytes = TRUE)
  html_file <- rmarkdown::render(rmd, output_file = "allocation.html", output_dir = wd, quiet = TRUE, envir = env)
  if(requireNamespace("pagedown", quietly=TRUE)) {
    pagedown::chrome_print(input = html_file, output = file, wait = 2)
    return(invisible(file))
  }

  # LaTeX fallback: compact table when Chrome/pagedown is unavailable.
  txt2 <- c(
    "---",
    paste0("title: \"", gsub('"','\\\\"',title), "\""),
    "output: pdf_document",
    "geometry: margin=0.65in",
    "header-includes:",
    "  - \\usepackage{longtable}",
    "---",
    "",
    "**R4VN Study Design Studio**  ",
    "`r paste0('Seed: ', seed)`",
    "",
    "```{r echo=FALSE, results='asis'}",
    "knitr::kable(allocation_table, format='latex', longtable=TRUE, booktabs=TRUE, row.names=FALSE)",
    "```"
  )
  writeLines(txt2, rmd, useBytes = TRUE)
  rmarkdown::render(rmd, output_file = basename(file), output_dir = dirname(file), quiet = TRUE, envir = env)
  invisible(file)
}