Nothing
R/design.R
In R4VN: Health Data Analysis and Publication-Ready Reporting
Defines functions
design
Documented in
design
#' R4VN Study Design Studio
#'
#' Launch an interactive Shiny Studio for study-design guidance, sample-size
#' planning, probability sampling, and random allocation. The working areas are
#' independent: users may open any area directly and may optionally reuse or
#' save results in one R4VN design project.
#'
#' @param data Optional data.frame used as the initial sampling/participant list.
#' @param project_name Initial project name shown in the Studio.
#' @param launch.browser Passed to [shiny::runApp()].
#' @param port Optional port passed to [shiny::runApp()].
#' @param host Host passed to [shiny::runApp()].
#'
#' @return Invisibly returns the Shiny app result when the app exits.
#'
#' @details
#' `design()` contains four independent working areas:
#' \describe{
#' \item{Study Design}{A guided cascade that recommends a design and explains why.}
#' \item{Sample Size}{A searchable registry of formula-, precision-, power-,
#' and model-based sample-size methods. Results include a formula or method
#' rule, numerical substitution when available, calculation steps,
#' adjustments, sensitivity analyses, references, and a Methods statement.}
#' \item{Sampling}{Simple, systematic, stratified, PPS, cluster, and
#' multistage sampling from an uploaded frame or, for methods that do not
#' require frame variables, directly from generated IDs 1...N.}
#' \item{Randomization}{Simple, complete, permuted-block, and stratified-block
#' random allocation from a participant list or from generated participant
#' numbers, with reproducibility metadata and printable allocation lists.}
#' }
#'
#' Word export uses `rmarkdown`/Pandoc so mathematical formulas are exported as
#' formatted Word equations. PDF export prefers `pagedown` with Chrome and uses
#' a LaTeX fallback when necessary. Excel templates/workbooks use `openxlsx`.
#'
#' Advanced sample-size methods use method-specific packages when available,
#' including `presize`, `WebPower`, `statpsych`, `TrialSize`, and `pmsampsize`.
#' The Studio reports the method/reference used rather than silently replacing
#' an unavailable advanced method with an unrelated approximation.
#'
#' @examples
#' if (interactive()) {
#' design()
#' }
#'
#' @export
design <- function(data = NULL, project_name = "Untitled Study",
launch.browser = interactive(), port = NULL,
host = "127.0.0.1") {
.r4vn_design_require("shiny", "R4VN Study Design Studio")
.r4vn_design_require("DT", "sortable Sampling tables")
if(!is.null(data) && !is.data.frame(data)) stop("data must be a data.frame or NULL.", call.=FALSE)
initial_seed <- as.integer((as.numeric(Sys.time()) * 1000) %% (.Machine$integer.max - 1)) + 1L
registry_table <- .r4vn_ss_registry_table()
categories <- unique(registry_table$category)
ss_choices <- function(category = "All methods") {
z <- registry_table
if(!is.null(category) && category != "All methods") z <- z[z$category == category,,drop=FALSE]
setNames(z$id, z$name)
}
sampling_methods_frame <- c(
"Simple random sampling"="simple",
"Systematic random sampling"="systematic",
"Stratified random sampling"="stratified",
"Systematic PPS without replacement"="pps_systematic",
"Brewer PPS without replacement"="pps_brewer",
"Sampford PPS without replacement"="pps_sampford",
"Till\u00e9 PPS without replacement"="pps_tille",
"Pivotal PPS without replacement"="pps_pivotal",
"Maximum-entropy PPS without replacement"="pps_maxentropy",
"PPS with replacement"="pps_wr",
"One-stage cluster sampling"="cluster",
"Multistage PPS + within-cluster SRS"="multistage_pps"
)
sampling_methods_generated <- c(
"Simple random sampling"="simple",
"Systematic random sampling"="systematic"
)
randomization_methods_frame <- c(
"Simple random assignment (exact ratio)"="rct_simple",
"Complete randomization (fixed group totals)"="rct_complete",
"Permuted-block randomization"="rct_block",
"Stratified permuted-block randomization"="rct_stratified_block"
)
randomization_methods_generated <- randomization_methods_frame[names(randomization_methods_frame) != "Stratified permuted-block randomization"]
method_label <- function(value, choices) {
hit <- names(choices)[match(value, unname(choices))]
if(!length(hit) || is.na(hit)) value else hit
}
css <- "
:root { --r4vn:#17324d; --r4vn2:#24567a; --soft:#f5f7fa; --line:#dce3ea; --muted:#66727c; }
body { background:#f5f7fa; }
.navbar { box-shadow:0 1px 8px rgba(0,0,0,.08); }
.r4vn-brand { font-weight:800; letter-spacing:.4px; }
.r4vn-card { background:white; border:1px solid var(--line); border-radius:10px;
padding:18px; margin-bottom:16px; box-shadow:0 2px 8px rgba(0,0,0,.035); }
.r4vn-home-card { min-height:230px; height:100%; display:flex; flex-direction:column; }
.r4vn-home-card .r4vn-step-title { margin-bottom:10px; }
.r4vn-home-card ul { margin-top:6px; }
.r4vn-project-grid { display:grid; grid-template-columns:1fr 1fr; gap:18px; align-items:start; }
.r4vn-title { font-size:26px; font-weight:800; color:var(--r4vn); margin-bottom:4px; }
.r4vn-subtitle { color:#5f6b76; margin-bottom:16px; }
.r4vn-kpi { border-left:4px solid var(--r4vn2); padding:10px 14px; background:#f8fbfd; margin:8px 0; }
.r4vn-result { font-size:34px; font-weight:800; color:var(--r4vn); }
.formula-box { background:#fbfcfd; border:1px solid #e4e9ee; border-radius:8px;
padding:14px; overflow-x:auto; margin:8px 0 14px 0; min-height:54px; }
.small-note { color:#68747f; font-size:12px; }
.r4vn-step-title { font-size:18px; font-weight:800; color:var(--r4vn); margin-top:0; }
.r4vn-step-number { display:inline-block; width:28px; height:28px; line-height:28px; text-align:center;
border-radius:50%; background:var(--r4vn); color:white; margin-right:7px; font-weight:800; }
.r4vn-help-tip { position:relative; display:inline-block; margin-left:6px; width:18px; height:18px;
line-height:17px; text-align:center; border-radius:50%; background:#e8eef4;
color:var(--r4vn); font-size:12px; font-weight:800; cursor:help; vertical-align:middle; }
.r4vn-help-popup { visibility:hidden; opacity:0; transition:opacity .12s; position:absolute; z-index:9999;
left:24px; top:-8px; width:330px; background:#17324d; color:white; padding:10px 12px;
border-radius:7px; font-size:12px; font-weight:400; line-height:1.45;
box-shadow:0 4px 16px rgba(0,0,0,.2); text-align:left; }
.r4vn-help-tip:hover .r4vn-help-popup, .r4vn-help-tip:focus .r4vn-help-popup { visibility:visible; opacity:1; }
.r4vn-method-meta { color:#66727c; font-size:13px; margin-top:4px; }
.r4vn-source-box { padding:10px 12px; background:#f8fbfd; border:1px solid #e2eaf0; border-radius:8px; margin-bottom:12px; }
.btn-r4vn { font-weight:600; }
table.dataTable { background:white; }
div.dataTables_scrollHead table.dataTable, div.dataTables_scrollBody table.dataTable { margin-left:0 !important; }
.dataTables_wrapper .dataTables_scroll { width:100%; }
"
mathjax_js <- "
$(document).on('shiny:value shiny:connected', function(event) {
setTimeout(function() {
if (window.MathJax) {
if (MathJax.typesetPromise) {
MathJax.typesetPromise();
} else if (MathJax.Hub) {
MathJax.Hub.Queue(['Typeset', MathJax.Hub]);
}
}
}, 40);
});
"
help_tip <- function(text) {
shiny::tags$span(
class="r4vn-help-tip", tabindex="0", "?",
shiny::tags$span(class="r4vn-help-popup", text)
)
}
label_with_help <- function(label, text) shiny::tags$span(label, help_tip(text))
step_title <- function(n, text) shiny::tags$h3(class="r4vn-step-title", shiny::tags$span(class="r4vn-step-number",n), text)
math_box <- function(tex) {
shiny::withMathJax(shiny::div(class="formula-box mathjax-dynamic", shiny::HTML(paste0("$$", tex, "$$"))))
}
sp_source_default <- if(is.null(data)) "generated" else "frame"
rd_source_default <- if(is.null(data)) "generated" else "frame"
home_ui <- shiny::fluidPage(
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "R4VN Study Design Studio"),
shiny::div(class="r4vn-subtitle", "Study design \u2022 Sample size \u2022 Sampling \u2022 Randomization"),
shiny::p("Each area can be used on its own. Results may also be saved together in one R4VN project when you want a reproducible study-planning record."),
shiny::fluidRow(
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("1", "Study Design"),
shiny::p("A guided cascade starts from the study purpose rather than assuming that the user already knows the design name."),
shiny::tags$ul(
shiny::tags$li("Observational, intervention, diagnostic, prediction, scale, and prognosis pathways."),
shiny::tags$li("Explains why the recommended design fits the answers and why common alternatives may fit less well."),
shiny::tags$li("Exports a concise design summary for protocol development.")
)
)),
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("2", "Sample Size"),
shiny::p(paste0(nrow(registry_table), " registered methods are searchable by name and topic, from prevalence and trials to reliability, CFA/SEM, regression, and prediction models.")),
shiny::tags$ul(
shiny::tags$li("Shows the formula/calculation rule immediately after method selection."),
shiny::tags$li("Explains each planning parameter with a practical example."),
shiny::tags$li("Provides numerical substitution, adjustments, sensitivity analysis, references, and Word/PDF reports.")
)
))
),
shiny::fluidRow(
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("3", "Sampling"),
shiny::p("Select a probability sample either from an uploaded sampling frame or directly from generated numbers 1...N when no frame variables are needed."),
shiny::tags$ul(
shiny::tags$li("SRS, systematic, stratified, PPS, cluster, and multistage sampling."),
shiny::tags$li("Excel templates, inclusion probabilities/weights where applicable, and exportable selected lists."),
shiny::tags$li("Seed, RNG information, parameters, and a frame fingerprint support exact checking/reproduction.")
)
)),
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("4", "Randomization"),
shiny::p("Randomly allocate participants to two or more groups using a participant list or simply a specified number of participants."),
shiny::tags$ul(
shiny::tags$li("Simple, complete, permuted-block, and stratified block allocation with flexible ratios."),
shiny::tags$li("Produces allocation order and group assignment in Excel/CSV and print-ready Word/PDF lists."),
shiny::tags$li("Stores seed and reproducibility metadata without embedding the full participant data table by default.")
)
))
)
),
shiny::div(class="r4vn-card",
shiny::h4("Project"),
shiny::fluidRow(
shiny::column(6,
shiny::textInput("project_name", "Project name", value=project_name),
shiny::uiOutput("project_status")
),
shiny::column(6,
shiny::br(),
shiny::downloadButton("save_project", "Save R4VN project", class="btn-primary btn-r4vn"),
shiny::fileInput("open_project", NULL, accept=c(".r4vndesign", ".rds"), buttonLabel="Open project", placeholder="No project selected", width="100%"),
shiny::p(class="small-note", "Save project stores your choices and calculation settings. For sampling/randomization, R4VN also stores the seed and a frame fingerprint so the random result can be checked or reproduced later; the full research data table is not embedded by default."),
shiny::downloadButton("project_export_word","Export complete Word report"),
shiny::downloadButton("project_export_pdf","Export complete PDF report")
)
)
)
)
study_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(5,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Study Design"),
shiny::p("Answer simple questions. R4VN recommends a design and explains the decision."),
shiny::selectInput("sd_purpose", "Primary purpose",
choices=c(
"Describe a population / estimate frequency"="describe",
"Examine an association or risk factor"="association",
"Evaluate an intervention"="intervention",
"Evaluate a diagnostic test"="diagnostic",
"Develop / validate a prediction model"="prediction",
"Develop / validate a scale"="scale",
"Study prognosis or time-to-event"="prognosis"
)),
shiny::conditionalPanel("input.sd_purpose == 'describe'",
shiny::selectInput("sd_describe_target", "What do you primarily want to estimate?",
c("A prevalence / proportion"="proportion", "A mean"="mean", "A distribution"="distribution", "An incidence / rate"="incidence"))
),
shiny::conditionalPanel("input.sd_purpose == 'association'",
shiny::radioButtons("sd_selection_basis", "How are participants primarily identified?",
c("From outcome status"="outcome", "From exposure status"="exposure", "From a population without selecting by exposure/outcome"="population")),
shiny::conditionalPanel("input.sd_selection_basis == 'exposure'",
shiny::radioButtons("sd_cohort_timing", "Timing of follow-up / data source",
c("Prospective"="prospective", "Retrospective records"="retrospective", "Both directions"="ambidirectional"))
)
),
shiny::conditionalPanel("input.sd_purpose == 'intervention'",
shiny::checkboxInput("sd_randomized", "Allocation is randomized", TRUE),
shiny::conditionalPanel("input.sd_randomized == true",
shiny::radioButtons("sd_randomization_unit", "What is randomized?", c("Individual participants"="individual", "Groups / clusters"="cluster")),
shiny::radioButtons("sd_trial_sequence", "Treatment structure", c("Parallel"="parallel", "Crossover"="crossover", "Stepped rollout"="stepped"))
),
shiny::conditionalPanel("input.sd_randomized == false",
shiny::selectInput("sd_quasi_type", "Non-randomized structure",
c("Before-after"="before_after", "Controlled before-after"="controlled_before_after", "Interrupted time series"="its", "Difference-in-differences"="did", "Regression discontinuity"="rd"))
)
),
shiny::conditionalPanel("input.sd_purpose == 'prediction'",
shiny::radioButtons("sd_prediction_stage", "Prediction-model stage", c("Development"="development", "External validation"="validation", "Updating / recalibration"="updating"))
),
shiny::conditionalPanel("input.sd_purpose == 'scale'",
shiny::radioButtons("sd_scale_stage", "Measurement-instrument stage", c("New scale development"="development", "Cross-cultural adaptation"="adaptation", "Validation"="validation"))
),
shiny::actionButton("sd_run", "Recommend study design", class="btn-primary btn-r4vn")
)
),
shiny::column(7,
shiny::uiOutput("sd_result"),
shiny::div(class="r4vn-card",shiny::h4("Export"),shiny::downloadButton("sd_export_word","Word"),shiny::downloadButton("sd_export_pdf","PDF"))
)
)
)
ss_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(4,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Sample Size"),
shiny::p(class="r4vn-subtitle", "Choose a method, enter the planning assumptions, and explore how the required sample changes across plausible values."),
step_title("1", "Choose a sample-size method"),
shiny::selectInput("ss_category", "Category", choices=c("All methods", categories)),
shiny::selectizeInput(
"ss_method", "Search or choose a method",
choices=character(0), selected=NULL,
options=list(
placeholder="Start typing: prevalence, Cronbach, AUC, regression, cluster...",
openOnFocus=TRUE, maxOptions=50, create=FALSE
)
),
shiny::uiOutput("ss_method_description")
),
shiny::div(class="r4vn-card",
step_title("2", "Enter planning parameters"),
shiny::uiOutput("ss_step2_body")
),
shiny::div(class="r4vn-card",
step_title("3", "Sensitivity analysis"),
shiny::uiOutput("ss_step3_body")
)
),
shiny::column(8,
shiny::uiOutput("ss_formula_preview"),
shiny::uiOutput("ss_result"),
shiny::uiOutput("ss_sensitivity_card"),
shiny::uiOutput("ss_export_card")
)
)
)
sampling_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(4,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Sampling"),
step_title("1", "Choose the population source"),
shiny::radioButtons("sp_source", NULL, choices=c(
"From an uploaded list / sampling frame"="frame",
"From generated numbers 1...N"="generated"
), selected=sp_source_default),
shiny::conditionalPanel("input.sp_source == 'frame'",
shiny::div(class="r4vn-source-box", "Use the data supplied to design(), or upload an Excel/CSV list. R4VN will sample actual IDs from that list."),
shiny::fileInput("sp_file", "Upload sampling frame", accept=c(".xlsx", ".xls", ".csv")),
shiny::uiOutput("sp_data_status"),
shiny::uiOutput("sp_id_ui"),
shiny::hr(),
shiny::h5("Need a template?"),
shiny::selectInput("sp_template_type", "Excel template", c("Simple / stratified"="simple", "PPS"="pps", "Multistage"="multistage")),
shiny::downloadButton("sp_template", "Download R4VN Excel template")
),
shiny::conditionalPanel("input.sp_source == 'generated'",
shiny::div(class="r4vn-source-box", "R4VN creates a temporary list 1, 2, ..., N. Example: N = 500 and n = 100 randomly selects 100 numbers from 1 to 500 and lets you export the selected numbers."),
shiny::numericInput("sp_population_n", "Population size (N)", 500, min=1, step=1)
)
),
shiny::div(class="r4vn-card",
step_title("2", "Choose a sampling method"),
shiny::selectInput("sp_method", "Method", choices=if(sp_source_default=="frame") sampling_methods_frame else sampling_methods_generated),
shiny::uiOutput("sp_params_ui")
),
shiny::div(class="r4vn-card",
step_title("3", "Set reproducibility and run"),
shiny::numericInput("sp_seed", "Random seed", initial_seed, min=1, max=.Machine$integer.max, step=1),
shiny::actionButton("sp_new_seed", "Generate seed"),
shiny::p(class="small-note", "R4VN saves the seed, RNG information, sampling parameters, and a fingerprint of the generated/uploaded frame."),
shiny::actionButton("sp_run", "Select sample", class="btn-primary btn-r4vn")
)
),
shiny::column(8,
shiny::uiOutput("sp_result"),
shiny::uiOutput("sp_method_paragraph"),
shiny::div(class="r4vn-card",
shiny::h4("Selected records"),
shiny::p(class="small-note", "The default list is sorted by ID in ascending order, and Sampling order is assigned from that ID-sorted list (1, 2, 3, ...). Clicking another column only changes the displayed/exported order; it does not draw a new sample."),
DT::DTOutput("sp_selected_preview"),
shiny::downloadButton("sp_export_xlsx", "Export Excel workbook"),
shiny::downloadButton("sp_export_csv", "Export selected CSV"),
shiny::actionButton("sp_reproduce", "Check / reproduce current run"),
shiny::p(class="small-note", "Use this button to check whether the currently uploaded/generated source still matches the original source. If it matches, R4VN reruns the same seed and parameters to confirm the same selected sample.")
),
shiny::div(class="r4vn-card",
shiny::h4("Report"),
shiny::downloadButton("sp_export_word", "Word"),
shiny::downloadButton("sp_export_pdf", "PDF")
)
)
)
)
randomization_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(4,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Randomization"),
step_title("1", "Choose the participant source"),
shiny::radioButtons("rd_source", NULL, choices=c(
"From an uploaded participant list"="frame",
"From generated participant numbers 1...N"="generated"
), selected=rd_source_default),
shiny::conditionalPanel("input.rd_source == 'frame'",
shiny::div(class="r4vn-source-box", "Use the data supplied to design(), or upload a participant list. Group assignments will be linked to the selected participant ID column."),
shiny::fileInput("rd_file", "Upload participant list", accept=c(".xlsx", ".xls", ".csv")),
shiny::uiOutput("rd_data_status"),
shiny::uiOutput("rd_id_ui"),
shiny::hr(),
shiny::downloadButton("rd_template", "Download R4VN randomization template")
),
shiny::conditionalPanel("input.rd_source == 'generated'",
shiny::div(class="r4vn-source-box", "R4VN creates participant numbers 1...N and assigns each number to a group. This is useful when you need an allocation list before the participant names/IDs are available."),
shiny::numericInput("rd_n_participants", "Number of participants", 100, min=2, step=1)
)
),
shiny::div(class="r4vn-card",
step_title("2", "Choose the allocation method"),
shiny::selectInput("rd_method", "Method", choices=if(rd_source_default=="frame") randomization_methods_frame else randomization_methods_generated),
shiny::uiOutput("rd_params_ui")
),
shiny::div(class="r4vn-card",
step_title("3", "Set reproducibility and randomize"),
shiny::numericInput("rd_seed", "Random seed", initial_seed, min=1, max=.Machine$integer.max, step=1),
shiny::actionButton("rd_new_seed", "Generate seed"),
shiny::p(class="small-note", "The saved randomization manifest includes the seed, RNG information, allocation settings, and participant-frame fingerprint."),
shiny::actionButton("rd_run", "Randomize", class="btn-primary btn-r4vn")
)
),
shiny::column(8,
shiny::uiOutput("rd_result"),
shiny::uiOutput("rd_method_paragraph"),
shiny::div(class="r4vn-card",
shiny::h4("Allocation list"),
shiny::p(class="small-note", "The list includes the sequence number and assigned group. Block, block-size, and stratum information are added when relevant."),
shiny::tableOutput("rd_preview"),
shiny::downloadButton("rd_export_xlsx", "Excel allocation list"),
shiny::downloadButton("rd_export_csv", "CSV allocation list"),
shiny::actionButton("rd_reproduce", "Check / reproduce current run")
),
shiny::div(class="r4vn-card",
shiny::h4("Quick print / study file"),
shiny::downloadButton("rd_print_word", "Print-ready Word"),
shiny::downloadButton("rd_print_pdf", "Print-ready PDF"),
shiny::br(), shiny::br(),
shiny::downloadButton("rd_report_word", "Randomization report (Word)"),
shiny::downloadButton("rd_report_pdf", "Randomization report (PDF)"),
shiny::p(class="small-note", "For trials requiring allocation concealment, control who can view future assignments; generating a list does not by itself guarantee concealment. The print-ready list is designed for field implementation and quick printing.")
)
)
)
)
ui <- shiny::navbarPage(
title=shiny::span(class="r4vn-brand", "R4VN \u2022 Study Design Studio"),
id="main_nav",
header=shiny::tagList(
shiny::tags$head(
shiny::tags$style(shiny::HTML(css)),
shiny::tags$script(shiny::HTML(mathjax_js))
),
shiny::withMathJax()
),
shiny::tabPanel("Home", home_ui),
shiny::tabPanel("Study Design", study_ui),
shiny::tabPanel("Sample Size", ss_ui),
shiny::tabPanel("Sampling", sampling_ui),
shiny::tabPanel("Randomization", randomization_ui)
)
server <- function(input, output, session) {
project <- shiny::reactiveVal(.r4vn_design_project_new(project_name))
ss_result_r <- shiny::reactiveVal(NULL)
ss_sensitivity_r <- shiny::reactiveVal(NULL)
sampling_run_r <- shiny::reactiveVal(NULL)
randomization_run_r <- shiny::reactiveVal(NULL)
frame_r <- shiny::reactiveVal(data)
random_frame_r <- shiny::reactiveVal(data)
read_uploaded_frame <- function(f) {
shiny::req(f$datapath)
ext <- tolower(tools::file_ext(f$name))
if(ext == "csv") return(utils::read.csv(f$datapath, check.names=FALSE, stringsAsFactors=FALSE))
if(requireNamespace("readxl",quietly=TRUE)) {
sheets <- readxl::excel_sheets(f$datapath)
sheet <- if("Sampling_Frame" %in% sheets) "Sampling_Frame" else sheets[1]
return(as.data.frame(readxl::read_excel(f$datapath, sheet=sheet), check.names=FALSE))
}
.r4vn_design_require("openxlsx", "Excel sampling-frame import")
sheets <- openxlsx::getSheetNames(f$datapath)
sheet <- if("Sampling_Frame" %in% sheets) "Sampling_Frame" else sheets[1]
openxlsx::read.xlsx(f$datapath, sheet=sheet, check.names=FALSE)
}
verify_exact_run <- function(run, d) {
rep <- .r4vn_sampling_reproduce(run, d)
rep$method_label <- run$method_label %||% run$method
original_ids <- if(!is.null(run$selected)) as.character(run$selected[[run$idvar]]) else run$selected_ids
same <- !is.null(original_ids) && identical(as.character(rep$selected[[run$idvar]]), as.character(original_ids))
original_alloc <- if(!is.null(run$full) && "random_group" %in% names(run$full)) {
keep0 <- c(run$idvar,"random_group","random_order","random_block","random_block_size")
if(!is.null(run$params$strata)) keep0 <- c(keep0, run$params$strata)
keep <- intersect(unique(keep0),names(run$full))
z <- run$full[,keep,drop=FALSE]; z[[run$idvar]] <- as.character(z[[run$idvar]]); z
} else run$randomization_fingerprint
if(!is.null(original_alloc)) {
keep <- names(original_alloc)
current_alloc <- rep$full[,keep,drop=FALSE]
current_alloc[[run$idvar]] <- as.character(current_alloc[[run$idvar]])
same <- same && identical(current_alloc, original_alloc)
}
list(run=rep, same=isTRUE(same))
}
shiny::observeEvent(input$project_name, {
p <- project(); p$name <- input$project_name %||% "Untitled Study"; p$modified <- as.character(Sys.time()); project(p)
}, ignoreInit=TRUE)
output$project_status <- shiny::renderUI({
p <- project()
shiny::div(class="r4vn-kpi",
shiny::strong(p$name), shiny::br(),
paste("Project ID:", p$project_id), shiny::br(),
paste("Study Design:", if(is.null(p$study_design)) "not saved" else p$study_design$design), shiny::br(),
paste("Sample Size:", if(is.null(p$sample_size)) "not saved" else paste0(p$sample_size$method_name, " (n=", p$sample_size$final_n, ")")), shiny::br(),
paste("Sampling:", if(is.null(p$sampling)) "not saved" else paste0(p$sampling$method_label %||% p$sampling$method, " / ", p$sampling$run_id)), shiny::br(),
paste("Randomization:", if(is.null(p$randomization)) "not saved" else paste0(p$randomization$method_label %||% p$randomization$method, " / ", p$randomization$run_id))
)
})
output$save_project <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name), ".r4vndesign"),
content=function(file) .r4vn_design_project_save(project(), file)
)
shiny::observeEvent(input$open_project, {
shiny::req(input$open_project$datapath)
p <- tryCatch(.r4vn_design_project_load(input$open_project$datapath), error=function(e) e)
if(inherits(p,"error")) { shiny::showNotification(conditionMessage(p), type="error"); return() }
if(is.null(p$randomization)) p$randomization <- NULL
project(p)
shiny::updateTextInput(session,"project_name",value=p$name)
if(!is.null(p$sample_size)) ss_result_r(p$sample_size)
if(!is.null(p$sampling) && inherits(p$sampling,"r4vn_sampling")) sampling_run_r(p$sampling)
if(!is.null(p$randomization) && inherits(p$randomization,"r4vn_sampling")) randomization_run_r(p$randomization)
shiny::showNotification("R4VN design project opened.", type="message")
})
# STUDY DESIGN ----------------------------------------------------------
shiny::observeEvent(input$sd_run, {
ans <- list(
describe_target=input$sd_describe_target,
selection_basis=input$sd_selection_basis,
cohort_timing=input$sd_cohort_timing,
randomized=isTRUE(input$sd_randomized),
randomization_unit=input$sd_randomization_unit,
trial_sequence=input$sd_trial_sequence,
quasi_type=input$sd_quasi_type,
prediction_stage=input$sd_prediction_stage,
scale_stage=input$sd_scale_stage
)
x <- .r4vn_design_recommend_study(input$sd_purpose, ans)
p <- project(); p$study_design <- x; p$modified <- as.character(Sys.time()); project(p)
})
output$sd_result <- shiny::renderUI({
x <- project()$study_design
if(is.null(x)) return(shiny::div(class="r4vn-card", shiny::h4("Recommended design will appear here"), shiny::p("The cascade is guidance, not a substitute for investigator/statistician judgment when a study has multiple objectives or unusual constraints.")))
shiny::div(class="r4vn-card",
shiny::h5("Recommended study design"),
shiny::h2(x$design),
shiny::h4("Why this design?"), shiny::tags$ul(lapply(x$why, shiny::tags$li)),
if(length(x$alternatives)) shiny::tagList(shiny::h4("Why not common alternatives?"), shiny::tags$ul(lapply(x$alternatives, shiny::tags$li))),
if(length(x$best_for)) shiny::tagList(shiny::h4("Best suited for"), shiny::tags$ul(lapply(x$best_for, shiny::tags$li))),
if(length(x$considerations)) shiny::tagList(shiny::h4("Important considerations"), shiny::tags$ul(lapply(x$considerations, shiny::tags$li))),
if(!is.null(x$guideline)) shiny::p(shiny::strong("Reporting guidance: "), x$guideline),
shiny::p(class="small-note", paste("Decision ID:", x$id))
)
})
output$sd_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_study_design.docx"),
content=function(file) { shiny::req(project()$study_design); .r4vn_design_export_word(project(),file,sections="study_design") }
)
output$sd_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_study_design.pdf"),
content=function(file) { shiny::req(project()$study_design); .r4vn_design_export_pdf(project(),file,sections="study_design") }
)
output$project_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_R4VN_design_report.docx"),
content=function(file) .r4vn_design_export_word(project(),file)
)
output$project_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_R4VN_design_report.pdf"),
content=function(file) .r4vn_design_export_pdf(project(),file)
)
# SAMPLE SIZE -----------------------------------------------------------
shiny::observeEvent(input$ss_category, {
choices <- ss_choices(input$ss_category %||% "All methods")
current <- input$ss_method
selected <- if(!is.null(current) && nzchar(current) && current %in% unname(choices)) current else ""
shiny::updateSelectizeInput(session, "ss_method", choices=choices, selected=selected, server=FALSE)
}, ignoreInit=FALSE)
current_method <- shiny::reactive({
if(is.null(input$ss_method) || !nzchar(input$ss_method)) return(NULL)
.r4vn_ss_get_method(input$ss_method)
})
shiny::observeEvent(input$ss_method, {
ss_result_r(NULL)
ss_sensitivity_r(NULL)
}, ignoreInit=TRUE)
output$ss_method_description <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(shiny::p(class="small-note","Start typing or choose a method to continue."))
shiny::div(
shiny::p(class="r4vn-method-meta", paste(m$category, "\u2022", m$description)),
if(!is.null(m$package)) shiny::p(class="small-note", paste("Calculation engine:", m$package))
)
})
make_ss_control <- function(z) {
id <- paste0("ssv_", z$id)
label <- label_with_help(z$label, .r4vn_ss_parameter_guidance(z))
if(identical(z$type,"select")) {
shiny::selectInput(id, label, choices=z$choices, selected=z$default)
} else {
args <- list(inputId=id,label=label,value=z$default)
if(is.finite(z$min)) args$min <- z$min
if(is.finite(z$max)) args$max <- z$max
if(!is.null(z$step)) args$step <- z$step
do.call(shiny::numericInput,args)
}
}
output$ss_inputs <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
lapply(m$inputs, make_ss_control)
})
collect_ss_values <- function(m) {
vals <- list()
if(is.null(m)) return(vals)
for(z in m$inputs) vals[[z$id]] <- input[[paste0("ssv_",z$id)]] %||% z$default
vals
}
output$ss_step2_body <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
shiny::tagList(
shiny::p(class="small-note", "Move the pointer over or focus the ? beside a parameter to see a plain-language explanation and example."),
shiny::uiOutput("ss_inputs"),
shiny::h5("Optional adjustments"),
shiny::numericInput("ss_deff", label_with_help("Design effect", "Use 1 for simple random sampling. Enter a value above 1 when the planned sampling design inflates variance, for example 1.5 for a 50% inflation."), 1, min=1, step=0.01),
shiny::numericInput("ss_loss", label_with_help("Loss / non-response (%)", "The expected percentage of selected participants who will not contribute analyzable data. Example: enter 10 for a 10% expected loss or non-response rate."), 0, min=0, max=99.9, step=0.1),
shiny::checkboxInput("ss_use_fpc", "Apply finite population correction", FALSE),
shiny::conditionalPanel("input.ss_use_fpc == true",
shiny::numericInput("ss_population", label_with_help("Finite population size (N)", "Enter the total number of eligible units in the source population when the sampling fraction is not negligible. Example: if only 1,200 eligible workers exist, enter 1200."), 1000, min=1, step=1)
),
shiny::actionButton("ss_calculate", "Calculate sample size", class="btn-primary btn-r4vn")
)
})
output$ss_step3_body <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
shiny::tagList(
shiny::uiOutput("ss_sens_parameter_ui"),
shiny::numericInput("ss_sens_from", "From", 0.10, step=0.01),
shiny::numericInput("ss_sens_to", "To", 0.50, step=0.01),
shiny::numericInput("ss_sens_step", "Step", 0.05, step=0.01),
shiny::checkboxInput("ss_plot_points", "Show points on plot", TRUE),
shiny::selectInput("ss_plot_result", "Plot result", choices=c("Final recruitment target"="final_n", "Base required sample size"="base_n", "Both"="both"), selected="final_n"),
shiny::actionButton("ss_run_sensitivity", "Run sensitivity analysis", class="btn-primary btn-r4vn")
)
})
output$ss_formula_preview <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
xr <- ss_result_r()
if(!is.null(xr) && identical(xr$method_id,m$id)) return(NULL)
vals <- collect_ss_values(m)
pr <- .r4vn_ss_formula_preview(m, vals)
shiny::div(class="r4vn-card",
shiny::h3(m$name),
shiny::p(class="r4vn-method-meta", m$description),
shiny::h4(pr$label),
if(isTRUE(pr$math)) math_box(pr$formula) else shiny::div(class="formula-box", pr$formula),
if(!is.null(pr$substitution)) shiny::tagList(
shiny::h4("Numerical substitution"),
math_box(pr$substitution),
shiny::p(class="small-note", "This preview updates from the current parameter values. Click Calculate sample size for the rounded result, adjustments, Methods statement, and reference output.")
) else shiny::p(class="small-note", "This method is solved numerically or by a method-specific engine; the selected calculation approach is shown above. Numerical results appear after calculation.")
)
})
shiny::observeEvent(input$ss_calculate, {
m <- current_method(); shiny::req(m); vals <- collect_ss_values(m)
pop <- if(isTRUE(input$ss_use_fpc)) input$ss_population else NA_real_
res <- tryCatch(.r4vn_ss_calculate(m, vals, loss=(input$ss_loss %||% 0)/100, design_effect=input$ss_deff %||% 1, population=pop), error=function(e) e)
if(inherits(res,"error")) { shiny::showNotification(conditionMessage(res), type="error", duration=8); return() }
ss_result_r(res)
p <- project(); p$sample_size <- res; p$modified <- as.character(Sys.time()); project(p)
})
output$ss_result <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
x <- ss_result_r()
if(is.null(x) || !identical(x$method_id, m$id)) return(NULL)
adj_lines <- c(
if(isTRUE(x$fpc_applied)) paste0("Finite population correction applied (N = ", x$population, ")."),
if(x$design_effect != 1) paste0("Design effect = ", .r4vn_design_fmt(x$design_effect,3), "."),
if(x$loss > 0) paste0("Loss/non-response adjustment = ", .r4vn_design_pct(x$loss,1), ".")
)
shiny::div(class="r4vn-card",
shiny::h3("Calculated result"),
shiny::div(class="r4vn-kpi", shiny::div("Final target sample size"), shiny::div(class="r4vn-result", x$final_n),
if(length(x$final_group_n)>1) shiny::div(paste("By group:", paste(x$final_group_n, collapse=" + ")))),
if(length(adj_lines)) shiny::tags$ul(lapply(adj_lines, shiny::tags$li)),
shiny::h4("Formula"), math_box(x$formula),
shiny::h4("Numerical substitution"), math_box(x$substitution),
shiny::h4("Calculation steps"), shiny::tags$ol(lapply(x$steps, shiny::tags$li)),
if(length(x$adjustment_formula)) shiny::tagList(
shiny::h4("Adjustments"),
lapply(seq_along(x$adjustment_formula), function(i) shiny::tagList(
math_box(x$adjustment_formula[i]),
math_box(x$adjustment_substitution[i])
)),
shiny::tags$ol(lapply(x$adjustment_steps,shiny::tags$li))
),
shiny::h4("Methods statement"), shiny::p(.r4vn_ss_method_paragraph(x)),
shiny::h4("Reference"), shiny::p(x$reference),
shiny::p(class="small-note", paste("Calculation ID:", x$calculation_id, "\u2022 R:", x$r_version, "\u2022 R4VN:", x$r4vn_version))
)
})
output$ss_sens_parameter_ui <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
if(!length(m$explore)) return(shiny::helpText("This method does not currently expose a sensitivity parameter in the registry."))
labels <- vapply(m$inputs,function(z) z$label,character(1)); names(labels) <- vapply(m$inputs,function(z) z$id,character(1))
ids <- intersect(m$explore,names(labels))
shiny::selectInput("ss_sens_parameter","Parameter to vary",choices=setNames(ids,labels[ids]))
})
shiny::observeEvent(input$ss_run_sensitivity, {
m <- current_method(); shiny::req(m)
if(!length(m$explore)) { shiny::showNotification("No sensitivity parameter is registered for this method.",type="warning"); return() }
shiny::req(input$ss_sens_parameter)
vals <- collect_ss_values(m)
from <- input$ss_sens_from; to <- input$ss_sens_to; step <- input$ss_sens_step
if(!is.finite(from)||!is.finite(to)||!is.finite(step)||step<=0||to<from) { shiny::showNotification("Sensitivity range is invalid.",type="error"); return() }
grid <- seq(from,to,by=step)
if(length(grid)>500) { shiny::showNotification("Sensitivity grid is limited to 500 values.",type="error"); return() }
pop <- if(isTRUE(input$ss_use_fpc)) input$ss_population else NA_real_
tab <- .r4vn_ss_sensitivity(m,vals,input$ss_sens_parameter,grid,loss=(input$ss_loss %||% 0)/100,design_effect=input$ss_deff %||% 1,population=pop)
labs <- setNames(vapply(m$inputs,`[[`,character(1),"label"),vapply(m$inputs,`[[`,character(1),"id"))
attr(tab,"parameter") <- input$ss_sens_parameter
lbl <- unname(labs[input$ss_sens_parameter])
if(!length(lbl) || is.na(lbl) || !nzchar(lbl)) lbl <- input$ss_sens_parameter
attr(tab,"parameter_label") <- lbl
ss_sensitivity_r(tab)
})
output$ss_sensitivity_card <- shiny::renderUI({
x <- ss_sensitivity_r()
if(is.null(x)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Sensitivity results"),
shiny::tableOutput("ss_sensitivity_table"),
shiny::plotOutput("ss_sensitivity_plot", height="320px")
)
})
output$ss_export_card <- shiny::renderUI({
m <- current_method(); x <- ss_result_r()
if(is.null(m) || is.null(x) || !identical(x$method_id,m$id)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Export"),
shiny::downloadButton("ss_export_word", "Word"),
shiny::downloadButton("ss_export_pdf", "PDF"),
shiny::span(class="small-note", " PDF export uses Chrome through pagedown when available, with a LaTeX fallback.")
)
})
output$ss_sensitivity_table <- shiny::renderTable({
x <- ss_sensitivity_r(); shiny::req(x)
lbl <- attr(x,"parameter_label") %||% "Parameter value"
z <- data.frame(
x$value,
x$base_n,
x$final_n,
check.names=FALSE,
stringsAsFactors=FALSE
)
names(z) <- c(lbl, "Base required sample size", "Final recruitment target")
note <- ifelse(nzchar(x$error), x$error, "")
if(any(nzchar(note))) z$Notes <- note
utils::head(z,100)
}, digits=2, striped=TRUE, bordered=TRUE, spacing="xs")
output$ss_sensitivity_plot <- shiny::renderPlot({
x <- ss_sensitivity_r(); shiny::req(x)
par_label <- attr(x,"parameter_label") %||% "Parameter value"
good <- is.finite(x$final_n)
if(!any(good)) { plot.new(); text(.5,.5,"No valid sensitivity results"); return() }
x <- x[good,,drop=FALSE]
mode <- input$ss_plot_result %||% "final_n"
if(mode=="both") {
yr <- range(c(x$base_n,x$final_n),na.rm=TRUE)
plot(x$value,x$base_n,type=if(isTRUE(input$ss_plot_points)) "o" else "l",xlab=par_label,ylab="Required sample size",ylim=yr)
lines(x$value,x$final_n,type=if(isTRUE(input$ss_plot_points)) "o" else "l",lty=2)
legend("topright",legend=c("Base required sample size","Final recruitment target"),lty=c(1,2),pch=if(isTRUE(input$ss_plot_points)) c(1,1) else c(NA,NA),bty="n")
} else {
y <- x[[mode]]
plot(x$value,y,type=if(isTRUE(input$ss_plot_points)) "o" else "l",xlab=par_label,ylab=if(mode=="final_n") "Final recruitment target" else "Base required sample size")
}
})
ss_plot_file <- function() {
x <- ss_sensitivity_r(); if(is.null(x)) return(NULL)
f <- tempfile(fileext=".png")
grDevices::png(f,width=1600,height=1000,res=180)
on.exit(grDevices::dev.off(),add=TRUE)
good <- is.finite(x$final_n); xx<-x[good,,drop=FALSE]
if(nrow(xx)) plot(xx$value,xx$final_n,type="o",xlab=attr(x,"parameter_label") %||% "Parameter value",ylab="Final recruitment target") else { plot.new(); text(.5,.5,"No valid results") }
f
}
output$ss_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sample_size.docx"),
content=function(file) { shiny::req(project()$sample_size); pf<-ss_plot_file(); .r4vn_design_export_word(project(),file,sections="sample_size",plot_file=pf) }
)
output$ss_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sample_size.pdf"),
content=function(file) { shiny::req(project()$sample_size); pf<-ss_plot_file(); .r4vn_design_export_pdf(project(),file,sections="sample_size",plot_file=pf) }
)
# SAMPLING --------------------------------------------------------------
shiny::observeEvent(input$sp_source, {
ch <- if(identical(input$sp_source,"generated")) sampling_methods_generated else sampling_methods_frame
shiny::updateSelectInput(session,"sp_method",choices=ch,selected=unname(ch)[1])
}, ignoreInit=FALSE)
shiny::observeEvent(input$sp_file, {
z <- tryCatch(read_uploaded_frame(input$sp_file),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=8); return() }
frame_r(z); shiny::showNotification(sprintf("Loaded %d rows and %d variables.",nrow(z),ncol(z)),type="message")
})
sampling_data <- shiny::reactive({
if(identical(input$sp_source,"generated")) .r4vn_sampling_generated_frame(input$sp_population_n %||% 500, "ID") else frame_r()
})
output$sp_data_status <- shiny::renderUI({
d <- frame_r()
if(is.null(d)) return(shiny::div(class="small-note","No sampling frame loaded yet."))
shiny::div(class="r4vn-kpi", paste0(nrow(d), " records \u2022 ", ncol(d), " variables"))
})
output$sp_id_ui <- shiny::renderUI({
if(!identical(input$sp_source,"frame")) return(NULL)
d<-frame_r(); if(is.null(d)) return(NULL)
shiny::selectInput("sp_id","Unique ID variable",choices=names(d),selected=names(d)[1])
})
output$sp_params_ui <- shiny::renderUI({
d<-sampling_data(); nms<-if(is.null(d)) character() else names(d); m<-input$sp_method
n_default <- if(is.null(d)) 100 else min(100,nrow(d))
if(m %in% c("simple","systematic")) return(shiny::numericInput("sp_n","Sample size (n)",n_default,min=1,step=1))
if(m=="stratified") return(shiny::tagList(
shiny::numericInput("sp_n","Total sample size (n)",n_default,min=1,step=1),
shiny::selectInput("sp_strata","Stratification variable",choices=nms),
shiny::selectInput("sp_allocation","Allocation",c("Proportional"="proportional","Equal"="equal","Custom"="custom")),
shiny::conditionalPanel("input.sp_allocation == 'custom'",shiny::textInput("sp_custom_counts","Custom counts","A=50,B=50"))
))
if(m %in% c("pps_systematic","pps_brewer","pps_sampford","pps_tille","pps_pivotal","pps_maxentropy","pps_wr")) return(shiny::tagList(
shiny::numericInput("sp_n","Number of units / draws",if(is.null(d))30 else min(30,nrow(d)),min=1,step=1),
shiny::selectInput("sp_mos","Measure of size (MOS)",choices=nms)
))
if(m=="cluster") return(shiny::tagList(
shiny::selectInput("sp_cluster","Cluster variable",choices=nms),
shiny::numericInput("sp_n_clusters","Number of clusters",10,min=1,step=1)
))
if(m=="multistage_pps") return(shiny::tagList(
shiny::selectInput("sp_cluster","Cluster / PSU variable",choices=nms),
shiny::selectInput("sp_mos","PSU measure of size (constant within PSU)",choices=nms),
shiny::numericInput("sp_n_clusters","PSUs to select",10,min=1,step=1),
shiny::numericInput("sp_n_within","Units per selected PSU",10,min=1,step=1)
))
NULL
})
shiny::observeEvent(input$sp_new_seed, shiny::updateNumericInput(session,"sp_seed",value=sample.int(.Machine$integer.max,1)))
collect_sp_params <- function(m) {
z <- switch(m,
simple=list(n=input$sp_n), systematic=list(n=input$sp_n),
stratified=list(n=input$sp_n,strata=input$sp_strata,allocation=input$sp_allocation,custom_counts=input$sp_custom_counts),
pps_systematic=list(n=input$sp_n,mos=input$sp_mos),
pps_brewer=list(n=input$sp_n,mos=input$sp_mos),
pps_sampford=list(n=input$sp_n,mos=input$sp_mos),
pps_tille=list(n=input$sp_n,mos=input$sp_mos),
pps_pivotal=list(n=input$sp_n,mos=input$sp_mos),
pps_maxentropy=list(n=input$sp_n,mos=input$sp_mos),
pps_wr=list(n=input$sp_n,mos=input$sp_mos),
cluster=list(cluster=input$sp_cluster,n_clusters=input$sp_n_clusters),
multistage_pps=list(cluster=input$sp_cluster,mos=input$sp_mos,n_clusters=input$sp_n_clusters,n_within=input$sp_n_within),
list()
)
z$source_mode <- input$sp_source
if(identical(input$sp_source,"generated")) z$generated_population_n <- input$sp_population_n
z
}
shiny::observeEvent(
list(input$sp_source, input$sp_population_n, input$sp_method, input$sp_n,
input$sp_strata, input$sp_allocation, input$sp_mos, input$sp_cluster,
input$sp_n_clusters, input$sp_n_within),
{
if(!is.null(sampling_run_r())) sampling_run_r(NULL)
p <- project(); if(!is.null(p$sampling)) { p$sampling <- NULL; p$modified <- as.character(Sys.time()); project(p) }
},
ignoreInit=TRUE
)
shiny::observeEvent(input$sp_run, {
d<-sampling_data(); shiny::req(d,input$sp_method)
idvar <- if(identical(input$sp_source,"generated")) "ID" else input$sp_id
shiny::req(idvar)
run <- tryCatch(.r4vn_sampling_run(d,input$sp_method,idvar,input$sp_seed,collect_sp_params(input$sp_method)),error=function(e)e)
if(inherits(run,"error")) { shiny::showNotification(conditionMessage(run),type="error",duration=10); return() }
run$method_label <- method_label(input$sp_method, sampling_methods_frame)
sampling_run_r(run)
p<-project(); p$sampling<-.r4vn_sampling_manifest(run); p$modified<-as.character(Sys.time()); project(p)
})
sanitize_sampling_selected <- function(d, idvar=NULL) {
if(is.null(d)) return(d)
drop <- intersect(c("sample_selected","sample_order","sampling_run","rng_state_before","rng_state_after"), names(d))
d <- d[, setdiff(names(d), drop), drop=FALSE]
if(!is.null(idvar) && idvar %in% names(d)) d <- d[, c(idvar, setdiff(names(d),idvar)), drop=FALSE]
friendly <- c(
sampling_probability="Sampling probability",
sampling_weight="Sampling weight",
selection_count="Selection count",
draw_probability="Draw probability",
psu_inclusion_probability="PSU inclusion probability",
within_cluster_probability="Within-cluster probability"
)
hit <- intersect(names(friendly), names(d))
if(length(hit)) names(d)[match(hit,names(d))] <- unname(friendly[hit])
d
}
sampling_selected_display <- shiny::reactive({
x <- sampling_run_r(); shiny::req(x, x$selected)
d <- sanitize_sampling_selected(x$selected, x$idvar)
if(x$idvar %in% names(d)) {
ord <- order(d[[x$idvar]], na.last=TRUE)
d <- d[ord,,drop=FALSE]
}
rownames(d) <- NULL
data.frame(`Sampling order`=seq_len(nrow(d)), d, check.names=FALSE, stringsAsFactors=FALSE)
})
sorted_sampling_selected <- shiny::reactive({
d <- sampling_selected_display(); shiny::req(d)
idx <- input$sp_selected_preview_rows_all
if(!is.null(idx) && length(idx)) d <- d[idx,,drop=FALSE]
# Sampling order is intentionally NOT recomputed after a user sort.
# It remains the rank from the default ascending-ID list, so sorting
# another column never looks like a new random sample was generated.
rownames(d) <- NULL
d
})
output$sp_result <- shiny::renderUI({
x<-sampling_run_r()
if(is.null(x)) return(shiny::div(class="r4vn-card",shiny::h4("Sampling result"),shiny::p("Choose whether you have a sampling frame or only a population size, select a method, then run. R4VN records reproducibility information for every random sample.")))
shiny::div(class="r4vn-card",
shiny::h3("R4VN Sampling Result"),
shiny::div(class="r4vn-kpi",shiny::strong(paste(x$n_selected,"selected records"))),
shiny::p(shiny::strong("Method: "),x$method_label %||% x$method),
shiny::p(shiny::strong("Seed: "),x$seed),
shiny::p(shiny::strong("Frame size: "),x$n_frame),
shiny::p(class="small-note", shiny::strong("Reproducibility ID: "), x$run_id, " ", help_tip("A unique ID for this random sampling run. Together with the seed, parameters, and source fingerprint, it helps verify or reproduce the same sample later.")),
shiny::p(class="small-note", shiny::strong("Source fingerprint: "),x$frame_hash, " ", help_tip("A fingerprint summarizes the sampling source without showing the full data. R4VN uses it to check that the source used for reproduction is the same as the original one."))
)
})
output$sp_method_paragraph <- shiny::renderUI({
x <- sampling_run_r()
if(is.null(x)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Methods"),
shiny::p(.r4vn_sampling_method_paragraph(x))
)
})
output$sp_selected_preview <- DT::renderDT({
d <- sampling_selected_display(); shiny::req(d)
DT::datatable(
d,
rownames=FALSE,
filter="none",
selection="none",
options=list(
pageLength=25,
lengthMenu=c(10,25,50,100),
autoWidth=TRUE,
order=list(list(1,"asc")),
columnDefs=list(
list(targets=0, orderable=FALSE, searchable=FALSE, width="105px")
),
scrollX=TRUE
),
class="compact stripe hover"
)
}, server=FALSE)
shiny::observeEvent(input$sp_reproduce, {
run<-sampling_run_r(); d<-sampling_data(); shiny::req(run,d)
z <- tryCatch(verify_exact_run(run,d),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=10); return() }
if(isTRUE(z$same)) {
sampling_run_r(z$run)
shiny::showNotification("Frame verified and the sample was reproduced exactly.",type="message",duration=7)
} else shiny::showNotification("Frame hash matched but the reproduced sample differed. Check R/R4VN method versions.",type="warning",duration=10)
})
output$sp_template <- shiny::downloadHandler(
filename=function() paste0("R4VN_sampling_template_",input$sp_template_type,".xlsx"),
content=function(file) .r4vn_sampling_write_template(file,input$sp_template_type)
)
output$sp_export_csv <- shiny::downloadHandler(
filename=function() paste0("R4VN_",sampling_run_r()$run_id,"_selected.csv"),
content=function(file) { d<-sorted_sampling_selected(); shiny::req(d); utils::write.csv(d,file,row.names=FALSE,na="") }
)
output$sp_export_xlsx <- shiny::downloadHandler(
filename=function() paste0("R4VN_",sampling_run_r()$run_id,"_sampling.xlsx"),
content=function(file) {
.r4vn_design_require("openxlsx","sampling workbook export")
x<-sampling_run_r(); shiny::req(x,x$selected,x$full)
dsel <- sorted_sampling_selected(); shiny::req(dsel)
wb<-openxlsx::createWorkbook()
openxlsx::addWorksheet(wb,"Selected_Sample"); openxlsx::writeData(wb,"Selected_Sample",dsel)
full_export <- x$full[, setdiff(names(x$full), "sampling_run"), drop=FALSE]
openxlsx::addWorksheet(wb,"Full_Frame"); openxlsx::writeData(wb,"Full_Frame",full_export)
man<-data.frame(Field=c("Run ID","Method","Seed","Frame hash","Frame N","Selected N","R version","R4VN version"),Value=c(x$run_id,x$method,x$seed,x$frame_hash,x$n_frame,x$n_selected,x$r_version,x$r4vn_version),stringsAsFactors=FALSE)
openxlsx::addWorksheet(wb,"Audit_Trail"); openxlsx::writeData(wb,"Audit_Trail",man)
if(x$method %in% c("pps_systematic","pps_brewer","pps_sampford","pps_tille","pps_pivotal","pps_maxentropy","pps_wr","multistage_pps")) {
keep<-intersect(c(x$idvar,"sample_selected","sample_order","sampling_probability","sampling_weight","selection_count","draw_probability","psu_inclusion_probability","within_cluster_probability"),names(x$full))
openxlsx::addWorksheet(wb,"PPS_Details"); openxlsx::writeData(wb,"PPS_Details",x$full[,keep,drop=FALSE])
}
openxlsx::saveWorkbook(wb,file,overwrite=TRUE)
}
)
output$sp_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sampling.docx"),
content=function(file) { shiny::req(project()$sampling); .r4vn_design_export_word(project(),file,sections="sampling") }
)
output$sp_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sampling.pdf"),
content=function(file) { shiny::req(project()$sampling); .r4vn_design_export_pdf(project(),file,sections="sampling") }
)
# RANDOMIZATION ---------------------------------------------------------
shiny::observeEvent(input$rd_source, {
ch <- if(identical(input$rd_source,"generated")) randomization_methods_generated else randomization_methods_frame
shiny::updateSelectInput(session,"rd_method",choices=ch,selected=unname(ch)[1])
}, ignoreInit=FALSE)
shiny::observeEvent(input$rd_file, {
z <- tryCatch(read_uploaded_frame(input$rd_file),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=8); return() }
random_frame_r(z); shiny::showNotification(sprintf("Loaded %d participants and %d variables.",nrow(z),ncol(z)),type="message")
})
randomization_data <- shiny::reactive({
if(identical(input$rd_source,"generated")) .r4vn_sampling_generated_frame(input$rd_n_participants %||% 100, "ID") else random_frame_r()
})
output$rd_data_status <- shiny::renderUI({
d <- random_frame_r()
if(is.null(d)) return(shiny::div(class="small-note","No participant list loaded yet."))
shiny::div(class="r4vn-kpi", paste0(nrow(d), " participants \u2022 ", ncol(d), " variables"))
})
output$rd_id_ui <- shiny::renderUI({
if(!identical(input$rd_source,"frame")) return(NULL)
d<-random_frame_r(); if(is.null(d)) return(NULL)
shiny::selectInput("rd_id","Participant ID variable",choices=names(d),selected=names(d)[1])
})
output$rd_params_ui <- shiny::renderUI({
d<-randomization_data(); nms<-if(is.null(d)) character() else names(d); m<-input$rd_method
shiny::tagList(
shiny::textInput("rd_groups","Group names","Control,Intervention"),
shiny::textInput("rd_ratio","Allocation ratio","1,1"),
shiny::p(class="small-note", "R4VN enforces the requested final allocation ratio exactly. For example, 100 participants with a 1:1 ratio will always produce 50 and 50. The participant count (and each stratum for stratified block randomization) must be compatible with the ratio."),
if(m %in% c("rct_block","rct_stratified_block")) shiny::tagList(
shiny::textInput("rd_block_sizes","Permuted block sizes","2,4,6"),
shiny::p(class="small-note", "Each block is complete and follows the requested allocation ratio exactly. For a 1:1 ratio, the default block sizes are 2, 4, and 6.")
),
if(m=="rct_stratified_block") shiny::selectInput("rd_strata","Stratification variable",choices=nms)
)
})
shiny::observeEvent(input$rd_new_seed, shiny::updateNumericInput(session,"rd_seed",value=sample.int(.Machine$integer.max,1)))
collect_rd_params <- function(m) {
z <- switch(m,
rct_simple=list(groups=input$rd_groups,ratio=input$rd_ratio),
rct_complete=list(groups=input$rd_groups,ratio=input$rd_ratio),
rct_block=list(groups=input$rd_groups,ratio=input$rd_ratio,block_sizes=input$rd_block_sizes),
rct_stratified_block=list(groups=input$rd_groups,ratio=input$rd_ratio,block_sizes=input$rd_block_sizes,strata=input$rd_strata),
list()
)
z$source_mode <- input$rd_source
if(identical(input$rd_source,"generated")) z$generated_participant_n <- input$rd_n_participants
z
}
shiny::observeEvent(
list(input$rd_source, input$rd_n_participants, input$rd_method, input$rd_groups,
input$rd_ratio, input$rd_block_sizes, input$rd_strata),
{
if(!is.null(randomization_run_r())) randomization_run_r(NULL)
p <- project(); if(!is.null(p$randomization)) { p$randomization <- NULL; p$modified <- as.character(Sys.time()); project(p) }
},
ignoreInit=TRUE
)
shiny::observeEvent(input$rd_run, {
d<-randomization_data(); shiny::req(d,input$rd_method)
idvar <- if(identical(input$rd_source,"generated")) "ID" else input$rd_id
shiny::req(idvar)
run <- tryCatch(.r4vn_sampling_run(d,input$rd_method,idvar,input$rd_seed,collect_rd_params(input$rd_method)),error=function(e)e)
if(inherits(run,"error")) { shiny::showNotification(conditionMessage(run),type="error",duration=10); return() }
run$method_label <- method_label(input$rd_method, randomization_methods_frame)
randomization_run_r(run)
p<-project(); p$randomization<-.r4vn_sampling_manifest(run); p$modified<-as.character(Sys.time()); project(p)
})
output$rd_result <- shiny::renderUI({
x<-randomization_run_r()
if(is.null(x)) return(shiny::div(class="r4vn-card",shiny::h4("Randomization result"),shiny::p("Use a participant list or generate participant numbers, specify groups and allocation method, then randomize.")))
alloc <- tryCatch(.r4vn_randomization_print_table(x),error=function(e) NULL)
counts <- if(is.null(alloc)) NULL else table(alloc$Group)
shiny::div(class="r4vn-card",
shiny::h3("R4VN Randomization Result"),
shiny::div(class="r4vn-kpi",shiny::strong(paste(x$n_selected,"randomized participants"))),
if(length(counts)) shiny::p(shiny::strong("Groups: "),paste(paste(names(counts),as.integer(counts),sep=" = "),collapse="; ")),
shiny::p(shiny::strong("Method: "),x$method_label %||% x$method),
if(!is.null(x$details$block_sizes)) shiny::p(shiny::strong("Block sizes used: "), paste(x$details$block_sizes, collapse=", ")),
shiny::p(shiny::strong("Run ID: "),x$run_id),
shiny::p(shiny::strong("Seed: "),x$seed),
shiny::p(class="small-note",paste("Participant-source fingerprint:",x$frame_hash))
)
})
output$rd_method_paragraph <- shiny::renderUI({
x <- randomization_run_r()
if(is.null(x)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Methods"),
shiny::p(.r4vn_randomization_method_paragraph(x))
)
})
output$rd_preview <- shiny::renderTable({
x<-randomization_run_r(); shiny::req(x)
utils::head(.r4vn_randomization_print_table(x),30)
}, striped=TRUE, bordered=TRUE, spacing="xs")
shiny::observeEvent(input$rd_reproduce, {
run<-randomization_run_r(); d<-randomization_data(); shiny::req(run,d)
z <- tryCatch(verify_exact_run(run,d),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=10); return() }
if(isTRUE(z$same)) {
randomization_run_r(z$run)
shiny::showNotification("Participant frame verified and the allocation was reproduced exactly.",type="message",duration=7)
} else shiny::showNotification("Frame hash matched but the reproduced allocation differed. Check R/R4VN method versions.",type="warning",duration=10)
})
output$rd_template <- shiny::downloadHandler(
filename=function() "R4VN_randomization_template.xlsx",
content=function(file) .r4vn_sampling_write_template(file,"rct")
)
output$rd_export_csv <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_allocation.csv"),
content=function(file) { x<-randomization_run_r(); shiny::req(x); utils::write.csv(.r4vn_randomization_print_table(x),file,row.names=FALSE,na="") }
)
output$rd_export_xlsx <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_allocation.xlsx"),
content=function(file) {
.r4vn_design_require("openxlsx","randomization workbook export")
x<-randomization_run_r(); shiny::req(x)
wb<-openxlsx::createWorkbook()
openxlsx::addWorksheet(wb,"Randomization_List"); openxlsx::writeData(wb,"Randomization_List",.r4vn_randomization_print_table(x))
if(!is.null(x$full)) { full_export <- x$full[, setdiff(names(x$full), "sampling_run"), drop=FALSE]
openxlsx::addWorksheet(wb,"Full_Frame"); openxlsx::writeData(wb,"Full_Frame",full_export) }
man<-data.frame(Field=c("Run ID","Method","Seed","Frame hash","Participants","R version","R4VN version"),Value=c(x$run_id,x$method,x$seed,x$frame_hash,x$n_selected,x$r_version,x$r4vn_version),stringsAsFactors=FALSE)
openxlsx::addWorksheet(wb,"Audit_Trail"); openxlsx::writeData(wb,"Audit_Trail",man)
openxlsx::saveWorkbook(wb,file,overwrite=TRUE)
}
)
output$rd_print_word <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_print_list.docx"),
content=function(file) { x<-randomization_run_r(); shiny::req(x); .r4vn_randomization_export_word(x,file) }
)
output$rd_print_pdf <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_print_list.pdf"),
content=function(file) { x<-randomization_run_r(); shiny::req(x); .r4vn_randomization_export_pdf(x,file) }
)
output$rd_report_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_randomization.docx"),
content=function(file) { shiny::req(project()$randomization); .r4vn_design_export_word(project(),file,sections="randomization") }
)
output$rd_report_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_randomization.pdf"),
content=function(file) { shiny::req(project()$randomization); .r4vn_design_export_pdf(project(),file,sections="randomization") }
)
}
app <- shiny::shinyApp(ui, server, options=list(launch.browser=launch.browser))
invisible(shiny::runApp(app, launch.browser=launch.browser, port=port, host=host))
}
Try the R4VN package in your browser
Any scripts or data that you put into this service are public.
R4VN documentation built on Sept. 30, 2026, 5:13 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions design
Documented in design
#' R4VN Study Design Studio
#'
#' Launch an interactive Shiny Studio for study-design guidance, sample-size
#' planning, probability sampling, and random allocation. The working areas are
#' independent: users may open any area directly and may optionally reuse or
#' save results in one R4VN design project.
#'
#' @param data Optional data.frame used as the initial sampling/participant list.
#' @param project_name Initial project name shown in the Studio.
#' @param launch.browser Passed to [shiny::runApp()].
#' @param port Optional port passed to [shiny::runApp()].
#' @param host Host passed to [shiny::runApp()].
#'
#' @return Invisibly returns the Shiny app result when the app exits.
#'
#' @details
#' `design()` contains four independent working areas:
#' \describe{
#' \item{Study Design}{A guided cascade that recommends a design and explains why.}
#' \item{Sample Size}{A searchable registry of formula-, precision-, power-,
#' and model-based sample-size methods. Results include a formula or method
#' rule, numerical substitution when available, calculation steps,
#' adjustments, sensitivity analyses, references, and a Methods statement.}
#' \item{Sampling}{Simple, systematic, stratified, PPS, cluster, and
#' multistage sampling from an uploaded frame or, for methods that do not
#' require frame variables, directly from generated IDs 1...N.}
#' \item{Randomization}{Simple, complete, permuted-block, and stratified-block
#' random allocation from a participant list or from generated participant
#' numbers, with reproducibility metadata and printable allocation lists.}
#' }
#'
#' Word export uses `rmarkdown`/Pandoc so mathematical formulas are exported as
#' formatted Word equations. PDF export prefers `pagedown` with Chrome and uses
#' a LaTeX fallback when necessary. Excel templates/workbooks use `openxlsx`.
#'
#' Advanced sample-size methods use method-specific packages when available,
#' including `presize`, `WebPower`, `statpsych`, `TrialSize`, and `pmsampsize`.
#' The Studio reports the method/reference used rather than silently replacing
#' an unavailable advanced method with an unrelated approximation.
#'
#' @examples
#' if (interactive()) {
#' design()
#' }
#'
#' @export
design <- function(data = NULL, project_name = "Untitled Study",
launch.browser = interactive(), port = NULL,
host = "127.0.0.1") {
.r4vn_design_require("shiny", "R4VN Study Design Studio")
.r4vn_design_require("DT", "sortable Sampling tables")
if(!is.null(data) && !is.data.frame(data)) stop("data must be a data.frame or NULL.", call.=FALSE)
initial_seed <- as.integer((as.numeric(Sys.time()) * 1000) %% (.Machine$integer.max - 1)) + 1L
registry_table <- .r4vn_ss_registry_table()
categories <- unique(registry_table$category)
ss_choices <- function(category = "All methods") {
z <- registry_table
if(!is.null(category) && category != "All methods") z <- z[z$category == category,,drop=FALSE]
setNames(z$id, z$name)
}
sampling_methods_frame <- c(
"Simple random sampling"="simple",
"Systematic random sampling"="systematic",
"Stratified random sampling"="stratified",
"Systematic PPS without replacement"="pps_systematic",
"Brewer PPS without replacement"="pps_brewer",
"Sampford PPS without replacement"="pps_sampford",
"Till\u00e9 PPS without replacement"="pps_tille",
"Pivotal PPS without replacement"="pps_pivotal",
"Maximum-entropy PPS without replacement"="pps_maxentropy",
"PPS with replacement"="pps_wr",
"One-stage cluster sampling"="cluster",
"Multistage PPS + within-cluster SRS"="multistage_pps"
)
sampling_methods_generated <- c(
"Simple random sampling"="simple",
"Systematic random sampling"="systematic"
)
randomization_methods_frame <- c(
"Simple random assignment (exact ratio)"="rct_simple",
"Complete randomization (fixed group totals)"="rct_complete",
"Permuted-block randomization"="rct_block",
"Stratified permuted-block randomization"="rct_stratified_block"
)
randomization_methods_generated <- randomization_methods_frame[names(randomization_methods_frame) != "Stratified permuted-block randomization"]
method_label <- function(value, choices) {
hit <- names(choices)[match(value, unname(choices))]
if(!length(hit) || is.na(hit)) value else hit
}
css <- "
:root { --r4vn:#17324d; --r4vn2:#24567a; --soft:#f5f7fa; --line:#dce3ea; --muted:#66727c; }
body { background:#f5f7fa; }
.navbar { box-shadow:0 1px 8px rgba(0,0,0,.08); }
.r4vn-brand { font-weight:800; letter-spacing:.4px; }
.r4vn-card { background:white; border:1px solid var(--line); border-radius:10px;
padding:18px; margin-bottom:16px; box-shadow:0 2px 8px rgba(0,0,0,.035); }
.r4vn-home-card { min-height:230px; height:100%; display:flex; flex-direction:column; }
.r4vn-home-card .r4vn-step-title { margin-bottom:10px; }
.r4vn-home-card ul { margin-top:6px; }
.r4vn-project-grid { display:grid; grid-template-columns:1fr 1fr; gap:18px; align-items:start; }
.r4vn-title { font-size:26px; font-weight:800; color:var(--r4vn); margin-bottom:4px; }
.r4vn-subtitle { color:#5f6b76; margin-bottom:16px; }
.r4vn-kpi { border-left:4px solid var(--r4vn2); padding:10px 14px; background:#f8fbfd; margin:8px 0; }
.r4vn-result { font-size:34px; font-weight:800; color:var(--r4vn); }
.formula-box { background:#fbfcfd; border:1px solid #e4e9ee; border-radius:8px;
padding:14px; overflow-x:auto; margin:8px 0 14px 0; min-height:54px; }
.small-note { color:#68747f; font-size:12px; }
.r4vn-step-title { font-size:18px; font-weight:800; color:var(--r4vn); margin-top:0; }
.r4vn-step-number { display:inline-block; width:28px; height:28px; line-height:28px; text-align:center;
border-radius:50%; background:var(--r4vn); color:white; margin-right:7px; font-weight:800; }
.r4vn-help-tip { position:relative; display:inline-block; margin-left:6px; width:18px; height:18px;
line-height:17px; text-align:center; border-radius:50%; background:#e8eef4;
color:var(--r4vn); font-size:12px; font-weight:800; cursor:help; vertical-align:middle; }
.r4vn-help-popup { visibility:hidden; opacity:0; transition:opacity .12s; position:absolute; z-index:9999;
left:24px; top:-8px; width:330px; background:#17324d; color:white; padding:10px 12px;
border-radius:7px; font-size:12px; font-weight:400; line-height:1.45;
box-shadow:0 4px 16px rgba(0,0,0,.2); text-align:left; }
.r4vn-help-tip:hover .r4vn-help-popup, .r4vn-help-tip:focus .r4vn-help-popup { visibility:visible; opacity:1; }
.r4vn-method-meta { color:#66727c; font-size:13px; margin-top:4px; }
.r4vn-source-box { padding:10px 12px; background:#f8fbfd; border:1px solid #e2eaf0; border-radius:8px; margin-bottom:12px; }
.btn-r4vn { font-weight:600; }
table.dataTable { background:white; }
div.dataTables_scrollHead table.dataTable, div.dataTables_scrollBody table.dataTable { margin-left:0 !important; }
.dataTables_wrapper .dataTables_scroll { width:100%; }
"
mathjax_js <- "
$(document).on('shiny:value shiny:connected', function(event) {
setTimeout(function() {
if (window.MathJax) {
if (MathJax.typesetPromise) {
MathJax.typesetPromise();
} else if (MathJax.Hub) {
MathJax.Hub.Queue(['Typeset', MathJax.Hub]);
}
}
}, 40);
});
"
help_tip <- function(text) {
shiny::tags$span(
class="r4vn-help-tip", tabindex="0", "?",
shiny::tags$span(class="r4vn-help-popup", text)
)
}
label_with_help <- function(label, text) shiny::tags$span(label, help_tip(text))
step_title <- function(n, text) shiny::tags$h3(class="r4vn-step-title", shiny::tags$span(class="r4vn-step-number",n), text)
math_box <- function(tex) {
shiny::withMathJax(shiny::div(class="formula-box mathjax-dynamic", shiny::HTML(paste0("$$", tex, "$$"))))
}
sp_source_default <- if(is.null(data)) "generated" else "frame"
rd_source_default <- if(is.null(data)) "generated" else "frame"
home_ui <- shiny::fluidPage(
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "R4VN Study Design Studio"),
shiny::div(class="r4vn-subtitle", "Study design \u2022 Sample size \u2022 Sampling \u2022 Randomization"),
shiny::p("Each area can be used on its own. Results may also be saved together in one R4VN project when you want a reproducible study-planning record."),
shiny::fluidRow(
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("1", "Study Design"),
shiny::p("A guided cascade starts from the study purpose rather than assuming that the user already knows the design name."),
shiny::tags$ul(
shiny::tags$li("Observational, intervention, diagnostic, prediction, scale, and prognosis pathways."),
shiny::tags$li("Explains why the recommended design fits the answers and why common alternatives may fit less well."),
shiny::tags$li("Exports a concise design summary for protocol development.")
)
)),
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("2", "Sample Size"),
shiny::p(paste0(nrow(registry_table), " registered methods are searchable by name and topic, from prevalence and trials to reliability, CFA/SEM, regression, and prediction models.")),
shiny::tags$ul(
shiny::tags$li("Shows the formula/calculation rule immediately after method selection."),
shiny::tags$li("Explains each planning parameter with a practical example."),
shiny::tags$li("Provides numerical substitution, adjustments, sensitivity analysis, references, and Word/PDF reports.")
)
))
),
shiny::fluidRow(
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("3", "Sampling"),
shiny::p("Select a probability sample either from an uploaded sampling frame or directly from generated numbers 1...N when no frame variables are needed."),
shiny::tags$ul(
shiny::tags$li("SRS, systematic, stratified, PPS, cluster, and multistage sampling."),
shiny::tags$li("Excel templates, inclusion probabilities/weights where applicable, and exportable selected lists."),
shiny::tags$li("Seed, RNG information, parameters, and a frame fingerprint support exact checking/reproduction.")
)
)),
shiny::column(6, shiny::div(class="r4vn-card r4vn-home-card",
step_title("4", "Randomization"),
shiny::p("Randomly allocate participants to two or more groups using a participant list or simply a specified number of participants."),
shiny::tags$ul(
shiny::tags$li("Simple, complete, permuted-block, and stratified block allocation with flexible ratios."),
shiny::tags$li("Produces allocation order and group assignment in Excel/CSV and print-ready Word/PDF lists."),
shiny::tags$li("Stores seed and reproducibility metadata without embedding the full participant data table by default.")
)
))
)
),
shiny::div(class="r4vn-card",
shiny::h4("Project"),
shiny::fluidRow(
shiny::column(6,
shiny::textInput("project_name", "Project name", value=project_name),
shiny::uiOutput("project_status")
),
shiny::column(6,
shiny::br(),
shiny::downloadButton("save_project", "Save R4VN project", class="btn-primary btn-r4vn"),
shiny::fileInput("open_project", NULL, accept=c(".r4vndesign", ".rds"), buttonLabel="Open project", placeholder="No project selected", width="100%"),
shiny::p(class="small-note", "Save project stores your choices and calculation settings. For sampling/randomization, R4VN also stores the seed and a frame fingerprint so the random result can be checked or reproduced later; the full research data table is not embedded by default."),
shiny::downloadButton("project_export_word","Export complete Word report"),
shiny::downloadButton("project_export_pdf","Export complete PDF report")
)
)
)
)
study_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(5,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Study Design"),
shiny::p("Answer simple questions. R4VN recommends a design and explains the decision."),
shiny::selectInput("sd_purpose", "Primary purpose",
choices=c(
"Describe a population / estimate frequency"="describe",
"Examine an association or risk factor"="association",
"Evaluate an intervention"="intervention",
"Evaluate a diagnostic test"="diagnostic",
"Develop / validate a prediction model"="prediction",
"Develop / validate a scale"="scale",
"Study prognosis or time-to-event"="prognosis"
)),
shiny::conditionalPanel("input.sd_purpose == 'describe'",
shiny::selectInput("sd_describe_target", "What do you primarily want to estimate?",
c("A prevalence / proportion"="proportion", "A mean"="mean", "A distribution"="distribution", "An incidence / rate"="incidence"))
),
shiny::conditionalPanel("input.sd_purpose == 'association'",
shiny::radioButtons("sd_selection_basis", "How are participants primarily identified?",
c("From outcome status"="outcome", "From exposure status"="exposure", "From a population without selecting by exposure/outcome"="population")),
shiny::conditionalPanel("input.sd_selection_basis == 'exposure'",
shiny::radioButtons("sd_cohort_timing", "Timing of follow-up / data source",
c("Prospective"="prospective", "Retrospective records"="retrospective", "Both directions"="ambidirectional"))
)
),
shiny::conditionalPanel("input.sd_purpose == 'intervention'",
shiny::checkboxInput("sd_randomized", "Allocation is randomized", TRUE),
shiny::conditionalPanel("input.sd_randomized == true",
shiny::radioButtons("sd_randomization_unit", "What is randomized?", c("Individual participants"="individual", "Groups / clusters"="cluster")),
shiny::radioButtons("sd_trial_sequence", "Treatment structure", c("Parallel"="parallel", "Crossover"="crossover", "Stepped rollout"="stepped"))
),
shiny::conditionalPanel("input.sd_randomized == false",
shiny::selectInput("sd_quasi_type", "Non-randomized structure",
c("Before-after"="before_after", "Controlled before-after"="controlled_before_after", "Interrupted time series"="its", "Difference-in-differences"="did", "Regression discontinuity"="rd"))
)
),
shiny::conditionalPanel("input.sd_purpose == 'prediction'",
shiny::radioButtons("sd_prediction_stage", "Prediction-model stage", c("Development"="development", "External validation"="validation", "Updating / recalibration"="updating"))
),
shiny::conditionalPanel("input.sd_purpose == 'scale'",
shiny::radioButtons("sd_scale_stage", "Measurement-instrument stage", c("New scale development"="development", "Cross-cultural adaptation"="adaptation", "Validation"="validation"))
),
shiny::actionButton("sd_run", "Recommend study design", class="btn-primary btn-r4vn")
)
),
shiny::column(7,
shiny::uiOutput("sd_result"),
shiny::div(class="r4vn-card",shiny::h4("Export"),shiny::downloadButton("sd_export_word","Word"),shiny::downloadButton("sd_export_pdf","PDF"))
)
)
)
ss_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(4,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Sample Size"),
shiny::p(class="r4vn-subtitle", "Choose a method, enter the planning assumptions, and explore how the required sample changes across plausible values."),
step_title("1", "Choose a sample-size method"),
shiny::selectInput("ss_category", "Category", choices=c("All methods", categories)),
shiny::selectizeInput(
"ss_method", "Search or choose a method",
choices=character(0), selected=NULL,
options=list(
placeholder="Start typing: prevalence, Cronbach, AUC, regression, cluster...",
openOnFocus=TRUE, maxOptions=50, create=FALSE
)
),
shiny::uiOutput("ss_method_description")
),
shiny::div(class="r4vn-card",
step_title("2", "Enter planning parameters"),
shiny::uiOutput("ss_step2_body")
),
shiny::div(class="r4vn-card",
step_title("3", "Sensitivity analysis"),
shiny::uiOutput("ss_step3_body")
)
),
shiny::column(8,
shiny::uiOutput("ss_formula_preview"),
shiny::uiOutput("ss_result"),
shiny::uiOutput("ss_sensitivity_card"),
shiny::uiOutput("ss_export_card")
)
)
)
sampling_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(4,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Sampling"),
step_title("1", "Choose the population source"),
shiny::radioButtons("sp_source", NULL, choices=c(
"From an uploaded list / sampling frame"="frame",
"From generated numbers 1...N"="generated"
), selected=sp_source_default),
shiny::conditionalPanel("input.sp_source == 'frame'",
shiny::div(class="r4vn-source-box", "Use the data supplied to design(), or upload an Excel/CSV list. R4VN will sample actual IDs from that list."),
shiny::fileInput("sp_file", "Upload sampling frame", accept=c(".xlsx", ".xls", ".csv")),
shiny::uiOutput("sp_data_status"),
shiny::uiOutput("sp_id_ui"),
shiny::hr(),
shiny::h5("Need a template?"),
shiny::selectInput("sp_template_type", "Excel template", c("Simple / stratified"="simple", "PPS"="pps", "Multistage"="multistage")),
shiny::downloadButton("sp_template", "Download R4VN Excel template")
),
shiny::conditionalPanel("input.sp_source == 'generated'",
shiny::div(class="r4vn-source-box", "R4VN creates a temporary list 1, 2, ..., N. Example: N = 500 and n = 100 randomly selects 100 numbers from 1 to 500 and lets you export the selected numbers."),
shiny::numericInput("sp_population_n", "Population size (N)", 500, min=1, step=1)
)
),
shiny::div(class="r4vn-card",
step_title("2", "Choose a sampling method"),
shiny::selectInput("sp_method", "Method", choices=if(sp_source_default=="frame") sampling_methods_frame else sampling_methods_generated),
shiny::uiOutput("sp_params_ui")
),
shiny::div(class="r4vn-card",
step_title("3", "Set reproducibility and run"),
shiny::numericInput("sp_seed", "Random seed", initial_seed, min=1, max=.Machine$integer.max, step=1),
shiny::actionButton("sp_new_seed", "Generate seed"),
shiny::p(class="small-note", "R4VN saves the seed, RNG information, sampling parameters, and a fingerprint of the generated/uploaded frame."),
shiny::actionButton("sp_run", "Select sample", class="btn-primary btn-r4vn")
)
),
shiny::column(8,
shiny::uiOutput("sp_result"),
shiny::uiOutput("sp_method_paragraph"),
shiny::div(class="r4vn-card",
shiny::h4("Selected records"),
shiny::p(class="small-note", "The default list is sorted by ID in ascending order, and Sampling order is assigned from that ID-sorted list (1, 2, 3, ...). Clicking another column only changes the displayed/exported order; it does not draw a new sample."),
DT::DTOutput("sp_selected_preview"),
shiny::downloadButton("sp_export_xlsx", "Export Excel workbook"),
shiny::downloadButton("sp_export_csv", "Export selected CSV"),
shiny::actionButton("sp_reproduce", "Check / reproduce current run"),
shiny::p(class="small-note", "Use this button to check whether the currently uploaded/generated source still matches the original source. If it matches, R4VN reruns the same seed and parameters to confirm the same selected sample.")
),
shiny::div(class="r4vn-card",
shiny::h4("Report"),
shiny::downloadButton("sp_export_word", "Word"),
shiny::downloadButton("sp_export_pdf", "PDF")
)
)
)
)
randomization_ui <- shiny::fluidPage(
shiny::fluidRow(
shiny::column(4,
shiny::div(class="r4vn-card",
shiny::div(class="r4vn-title", "Randomization"),
step_title("1", "Choose the participant source"),
shiny::radioButtons("rd_source", NULL, choices=c(
"From an uploaded participant list"="frame",
"From generated participant numbers 1...N"="generated"
), selected=rd_source_default),
shiny::conditionalPanel("input.rd_source == 'frame'",
shiny::div(class="r4vn-source-box", "Use the data supplied to design(), or upload a participant list. Group assignments will be linked to the selected participant ID column."),
shiny::fileInput("rd_file", "Upload participant list", accept=c(".xlsx", ".xls", ".csv")),
shiny::uiOutput("rd_data_status"),
shiny::uiOutput("rd_id_ui"),
shiny::hr(),
shiny::downloadButton("rd_template", "Download R4VN randomization template")
),
shiny::conditionalPanel("input.rd_source == 'generated'",
shiny::div(class="r4vn-source-box", "R4VN creates participant numbers 1...N and assigns each number to a group. This is useful when you need an allocation list before the participant names/IDs are available."),
shiny::numericInput("rd_n_participants", "Number of participants", 100, min=2, step=1)
)
),
shiny::div(class="r4vn-card",
step_title("2", "Choose the allocation method"),
shiny::selectInput("rd_method", "Method", choices=if(rd_source_default=="frame") randomization_methods_frame else randomization_methods_generated),
shiny::uiOutput("rd_params_ui")
),
shiny::div(class="r4vn-card",
step_title("3", "Set reproducibility and randomize"),
shiny::numericInput("rd_seed", "Random seed", initial_seed, min=1, max=.Machine$integer.max, step=1),
shiny::actionButton("rd_new_seed", "Generate seed"),
shiny::p(class="small-note", "The saved randomization manifest includes the seed, RNG information, allocation settings, and participant-frame fingerprint."),
shiny::actionButton("rd_run", "Randomize", class="btn-primary btn-r4vn")
)
),
shiny::column(8,
shiny::uiOutput("rd_result"),
shiny::uiOutput("rd_method_paragraph"),
shiny::div(class="r4vn-card",
shiny::h4("Allocation list"),
shiny::p(class="small-note", "The list includes the sequence number and assigned group. Block, block-size, and stratum information are added when relevant."),
shiny::tableOutput("rd_preview"),
shiny::downloadButton("rd_export_xlsx", "Excel allocation list"),
shiny::downloadButton("rd_export_csv", "CSV allocation list"),
shiny::actionButton("rd_reproduce", "Check / reproduce current run")
),
shiny::div(class="r4vn-card",
shiny::h4("Quick print / study file"),
shiny::downloadButton("rd_print_word", "Print-ready Word"),
shiny::downloadButton("rd_print_pdf", "Print-ready PDF"),
shiny::br(), shiny::br(),
shiny::downloadButton("rd_report_word", "Randomization report (Word)"),
shiny::downloadButton("rd_report_pdf", "Randomization report (PDF)"),
shiny::p(class="small-note", "For trials requiring allocation concealment, control who can view future assignments; generating a list does not by itself guarantee concealment. The print-ready list is designed for field implementation and quick printing.")
)
)
)
)
ui <- shiny::navbarPage(
title=shiny::span(class="r4vn-brand", "R4VN \u2022 Study Design Studio"),
id="main_nav",
header=shiny::tagList(
shiny::tags$head(
shiny::tags$style(shiny::HTML(css)),
shiny::tags$script(shiny::HTML(mathjax_js))
),
shiny::withMathJax()
),
shiny::tabPanel("Home", home_ui),
shiny::tabPanel("Study Design", study_ui),
shiny::tabPanel("Sample Size", ss_ui),
shiny::tabPanel("Sampling", sampling_ui),
shiny::tabPanel("Randomization", randomization_ui)
)
server <- function(input, output, session) {
project <- shiny::reactiveVal(.r4vn_design_project_new(project_name))
ss_result_r <- shiny::reactiveVal(NULL)
ss_sensitivity_r <- shiny::reactiveVal(NULL)
sampling_run_r <- shiny::reactiveVal(NULL)
randomization_run_r <- shiny::reactiveVal(NULL)
frame_r <- shiny::reactiveVal(data)
random_frame_r <- shiny::reactiveVal(data)
read_uploaded_frame <- function(f) {
shiny::req(f$datapath)
ext <- tolower(tools::file_ext(f$name))
if(ext == "csv") return(utils::read.csv(f$datapath, check.names=FALSE, stringsAsFactors=FALSE))
if(requireNamespace("readxl",quietly=TRUE)) {
sheets <- readxl::excel_sheets(f$datapath)
sheet <- if("Sampling_Frame" %in% sheets) "Sampling_Frame" else sheets[1]
return(as.data.frame(readxl::read_excel(f$datapath, sheet=sheet), check.names=FALSE))
}
.r4vn_design_require("openxlsx", "Excel sampling-frame import")
sheets <- openxlsx::getSheetNames(f$datapath)
sheet <- if("Sampling_Frame" %in% sheets) "Sampling_Frame" else sheets[1]
openxlsx::read.xlsx(f$datapath, sheet=sheet, check.names=FALSE)
}
verify_exact_run <- function(run, d) {
rep <- .r4vn_sampling_reproduce(run, d)
rep$method_label <- run$method_label %||% run$method
original_ids <- if(!is.null(run$selected)) as.character(run$selected[[run$idvar]]) else run$selected_ids
same <- !is.null(original_ids) && identical(as.character(rep$selected[[run$idvar]]), as.character(original_ids))
original_alloc <- if(!is.null(run$full) && "random_group" %in% names(run$full)) {
keep0 <- c(run$idvar,"random_group","random_order","random_block","random_block_size")
if(!is.null(run$params$strata)) keep0 <- c(keep0, run$params$strata)
keep <- intersect(unique(keep0),names(run$full))
z <- run$full[,keep,drop=FALSE]; z[[run$idvar]] <- as.character(z[[run$idvar]]); z
} else run$randomization_fingerprint
if(!is.null(original_alloc)) {
keep <- names(original_alloc)
current_alloc <- rep$full[,keep,drop=FALSE]
current_alloc[[run$idvar]] <- as.character(current_alloc[[run$idvar]])
same <- same && identical(current_alloc, original_alloc)
}
list(run=rep, same=isTRUE(same))
}
shiny::observeEvent(input$project_name, {
p <- project(); p$name <- input$project_name %||% "Untitled Study"; p$modified <- as.character(Sys.time()); project(p)
}, ignoreInit=TRUE)
output$project_status <- shiny::renderUI({
p <- project()
shiny::div(class="r4vn-kpi",
shiny::strong(p$name), shiny::br(),
paste("Project ID:", p$project_id), shiny::br(),
paste("Study Design:", if(is.null(p$study_design)) "not saved" else p$study_design$design), shiny::br(),
paste("Sample Size:", if(is.null(p$sample_size)) "not saved" else paste0(p$sample_size$method_name, " (n=", p$sample_size$final_n, ")")), shiny::br(),
paste("Sampling:", if(is.null(p$sampling)) "not saved" else paste0(p$sampling$method_label %||% p$sampling$method, " / ", p$sampling$run_id)), shiny::br(),
paste("Randomization:", if(is.null(p$randomization)) "not saved" else paste0(p$randomization$method_label %||% p$randomization$method, " / ", p$randomization$run_id))
)
})
output$save_project <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name), ".r4vndesign"),
content=function(file) .r4vn_design_project_save(project(), file)
)
shiny::observeEvent(input$open_project, {
shiny::req(input$open_project$datapath)
p <- tryCatch(.r4vn_design_project_load(input$open_project$datapath), error=function(e) e)
if(inherits(p,"error")) { shiny::showNotification(conditionMessage(p), type="error"); return() }
if(is.null(p$randomization)) p$randomization <- NULL
project(p)
shiny::updateTextInput(session,"project_name",value=p$name)
if(!is.null(p$sample_size)) ss_result_r(p$sample_size)
if(!is.null(p$sampling) && inherits(p$sampling,"r4vn_sampling")) sampling_run_r(p$sampling)
if(!is.null(p$randomization) && inherits(p$randomization,"r4vn_sampling")) randomization_run_r(p$randomization)
shiny::showNotification("R4VN design project opened.", type="message")
})
# STUDY DESIGN ----------------------------------------------------------
shiny::observeEvent(input$sd_run, {
ans <- list(
describe_target=input$sd_describe_target,
selection_basis=input$sd_selection_basis,
cohort_timing=input$sd_cohort_timing,
randomized=isTRUE(input$sd_randomized),
randomization_unit=input$sd_randomization_unit,
trial_sequence=input$sd_trial_sequence,
quasi_type=input$sd_quasi_type,
prediction_stage=input$sd_prediction_stage,
scale_stage=input$sd_scale_stage
)
x <- .r4vn_design_recommend_study(input$sd_purpose, ans)
p <- project(); p$study_design <- x; p$modified <- as.character(Sys.time()); project(p)
})
output$sd_result <- shiny::renderUI({
x <- project()$study_design
if(is.null(x)) return(shiny::div(class="r4vn-card", shiny::h4("Recommended design will appear here"), shiny::p("The cascade is guidance, not a substitute for investigator/statistician judgment when a study has multiple objectives or unusual constraints.")))
shiny::div(class="r4vn-card",
shiny::h5("Recommended study design"),
shiny::h2(x$design),
shiny::h4("Why this design?"), shiny::tags$ul(lapply(x$why, shiny::tags$li)),
if(length(x$alternatives)) shiny::tagList(shiny::h4("Why not common alternatives?"), shiny::tags$ul(lapply(x$alternatives, shiny::tags$li))),
if(length(x$best_for)) shiny::tagList(shiny::h4("Best suited for"), shiny::tags$ul(lapply(x$best_for, shiny::tags$li))),
if(length(x$considerations)) shiny::tagList(shiny::h4("Important considerations"), shiny::tags$ul(lapply(x$considerations, shiny::tags$li))),
if(!is.null(x$guideline)) shiny::p(shiny::strong("Reporting guidance: "), x$guideline),
shiny::p(class="small-note", paste("Decision ID:", x$id))
)
})
output$sd_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_study_design.docx"),
content=function(file) { shiny::req(project()$study_design); .r4vn_design_export_word(project(),file,sections="study_design") }
)
output$sd_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_study_design.pdf"),
content=function(file) { shiny::req(project()$study_design); .r4vn_design_export_pdf(project(),file,sections="study_design") }
)
output$project_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_R4VN_design_report.docx"),
content=function(file) .r4vn_design_export_word(project(),file)
)
output$project_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_R4VN_design_report.pdf"),
content=function(file) .r4vn_design_export_pdf(project(),file)
)
# SAMPLE SIZE -----------------------------------------------------------
shiny::observeEvent(input$ss_category, {
choices <- ss_choices(input$ss_category %||% "All methods")
current <- input$ss_method
selected <- if(!is.null(current) && nzchar(current) && current %in% unname(choices)) current else ""
shiny::updateSelectizeInput(session, "ss_method", choices=choices, selected=selected, server=FALSE)
}, ignoreInit=FALSE)
current_method <- shiny::reactive({
if(is.null(input$ss_method) || !nzchar(input$ss_method)) return(NULL)
.r4vn_ss_get_method(input$ss_method)
})
shiny::observeEvent(input$ss_method, {
ss_result_r(NULL)
ss_sensitivity_r(NULL)
}, ignoreInit=TRUE)
output$ss_method_description <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(shiny::p(class="small-note","Start typing or choose a method to continue."))
shiny::div(
shiny::p(class="r4vn-method-meta", paste(m$category, "\u2022", m$description)),
if(!is.null(m$package)) shiny::p(class="small-note", paste("Calculation engine:", m$package))
)
})
make_ss_control <- function(z) {
id <- paste0("ssv_", z$id)
label <- label_with_help(z$label, .r4vn_ss_parameter_guidance(z))
if(identical(z$type,"select")) {
shiny::selectInput(id, label, choices=z$choices, selected=z$default)
} else {
args <- list(inputId=id,label=label,value=z$default)
if(is.finite(z$min)) args$min <- z$min
if(is.finite(z$max)) args$max <- z$max
if(!is.null(z$step)) args$step <- z$step
do.call(shiny::numericInput,args)
}
}
output$ss_inputs <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
lapply(m$inputs, make_ss_control)
})
collect_ss_values <- function(m) {
vals <- list()
if(is.null(m)) return(vals)
for(z in m$inputs) vals[[z$id]] <- input[[paste0("ssv_",z$id)]] %||% z$default
vals
}
output$ss_step2_body <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
shiny::tagList(
shiny::p(class="small-note", "Move the pointer over or focus the ? beside a parameter to see a plain-language explanation and example."),
shiny::uiOutput("ss_inputs"),
shiny::h5("Optional adjustments"),
shiny::numericInput("ss_deff", label_with_help("Design effect", "Use 1 for simple random sampling. Enter a value above 1 when the planned sampling design inflates variance, for example 1.5 for a 50% inflation."), 1, min=1, step=0.01),
shiny::numericInput("ss_loss", label_with_help("Loss / non-response (%)", "The expected percentage of selected participants who will not contribute analyzable data. Example: enter 10 for a 10% expected loss or non-response rate."), 0, min=0, max=99.9, step=0.1),
shiny::checkboxInput("ss_use_fpc", "Apply finite population correction", FALSE),
shiny::conditionalPanel("input.ss_use_fpc == true",
shiny::numericInput("ss_population", label_with_help("Finite population size (N)", "Enter the total number of eligible units in the source population when the sampling fraction is not negligible. Example: if only 1,200 eligible workers exist, enter 1200."), 1000, min=1, step=1)
),
shiny::actionButton("ss_calculate", "Calculate sample size", class="btn-primary btn-r4vn")
)
})
output$ss_step3_body <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
shiny::tagList(
shiny::uiOutput("ss_sens_parameter_ui"),
shiny::numericInput("ss_sens_from", "From", 0.10, step=0.01),
shiny::numericInput("ss_sens_to", "To", 0.50, step=0.01),
shiny::numericInput("ss_sens_step", "Step", 0.05, step=0.01),
shiny::checkboxInput("ss_plot_points", "Show points on plot", TRUE),
shiny::selectInput("ss_plot_result", "Plot result", choices=c("Final recruitment target"="final_n", "Base required sample size"="base_n", "Both"="both"), selected="final_n"),
shiny::actionButton("ss_run_sensitivity", "Run sensitivity analysis", class="btn-primary btn-r4vn")
)
})
output$ss_formula_preview <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
xr <- ss_result_r()
if(!is.null(xr) && identical(xr$method_id,m$id)) return(NULL)
vals <- collect_ss_values(m)
pr <- .r4vn_ss_formula_preview(m, vals)
shiny::div(class="r4vn-card",
shiny::h3(m$name),
shiny::p(class="r4vn-method-meta", m$description),
shiny::h4(pr$label),
if(isTRUE(pr$math)) math_box(pr$formula) else shiny::div(class="formula-box", pr$formula),
if(!is.null(pr$substitution)) shiny::tagList(
shiny::h4("Numerical substitution"),
math_box(pr$substitution),
shiny::p(class="small-note", "This preview updates from the current parameter values. Click Calculate sample size for the rounded result, adjustments, Methods statement, and reference output.")
) else shiny::p(class="small-note", "This method is solved numerically or by a method-specific engine; the selected calculation approach is shown above. Numerical results appear after calculation.")
)
})
shiny::observeEvent(input$ss_calculate, {
m <- current_method(); shiny::req(m); vals <- collect_ss_values(m)
pop <- if(isTRUE(input$ss_use_fpc)) input$ss_population else NA_real_
res <- tryCatch(.r4vn_ss_calculate(m, vals, loss=(input$ss_loss %||% 0)/100, design_effect=input$ss_deff %||% 1, population=pop), error=function(e) e)
if(inherits(res,"error")) { shiny::showNotification(conditionMessage(res), type="error", duration=8); return() }
ss_result_r(res)
p <- project(); p$sample_size <- res; p$modified <- as.character(Sys.time()); project(p)
})
output$ss_result <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
x <- ss_result_r()
if(is.null(x) || !identical(x$method_id, m$id)) return(NULL)
adj_lines <- c(
if(isTRUE(x$fpc_applied)) paste0("Finite population correction applied (N = ", x$population, ")."),
if(x$design_effect != 1) paste0("Design effect = ", .r4vn_design_fmt(x$design_effect,3), "."),
if(x$loss > 0) paste0("Loss/non-response adjustment = ", .r4vn_design_pct(x$loss,1), ".")
)
shiny::div(class="r4vn-card",
shiny::h3("Calculated result"),
shiny::div(class="r4vn-kpi", shiny::div("Final target sample size"), shiny::div(class="r4vn-result", x$final_n),
if(length(x$final_group_n)>1) shiny::div(paste("By group:", paste(x$final_group_n, collapse=" + ")))),
if(length(adj_lines)) shiny::tags$ul(lapply(adj_lines, shiny::tags$li)),
shiny::h4("Formula"), math_box(x$formula),
shiny::h4("Numerical substitution"), math_box(x$substitution),
shiny::h4("Calculation steps"), shiny::tags$ol(lapply(x$steps, shiny::tags$li)),
if(length(x$adjustment_formula)) shiny::tagList(
shiny::h4("Adjustments"),
lapply(seq_along(x$adjustment_formula), function(i) shiny::tagList(
math_box(x$adjustment_formula[i]),
math_box(x$adjustment_substitution[i])
)),
shiny::tags$ol(lapply(x$adjustment_steps,shiny::tags$li))
),
shiny::h4("Methods statement"), shiny::p(.r4vn_ss_method_paragraph(x)),
shiny::h4("Reference"), shiny::p(x$reference),
shiny::p(class="small-note", paste("Calculation ID:", x$calculation_id, "\u2022 R:", x$r_version, "\u2022 R4VN:", x$r4vn_version))
)
})
output$ss_sens_parameter_ui <- shiny::renderUI({
m <- current_method()
if(is.null(m)) return(NULL)
if(!length(m$explore)) return(shiny::helpText("This method does not currently expose a sensitivity parameter in the registry."))
labels <- vapply(m$inputs,function(z) z$label,character(1)); names(labels) <- vapply(m$inputs,function(z) z$id,character(1))
ids <- intersect(m$explore,names(labels))
shiny::selectInput("ss_sens_parameter","Parameter to vary",choices=setNames(ids,labels[ids]))
})
shiny::observeEvent(input$ss_run_sensitivity, {
m <- current_method(); shiny::req(m)
if(!length(m$explore)) { shiny::showNotification("No sensitivity parameter is registered for this method.",type="warning"); return() }
shiny::req(input$ss_sens_parameter)
vals <- collect_ss_values(m)
from <- input$ss_sens_from; to <- input$ss_sens_to; step <- input$ss_sens_step
if(!is.finite(from)||!is.finite(to)||!is.finite(step)||step<=0||to<from) { shiny::showNotification("Sensitivity range is invalid.",type="error"); return() }
grid <- seq(from,to,by=step)
if(length(grid)>500) { shiny::showNotification("Sensitivity grid is limited to 500 values.",type="error"); return() }
pop <- if(isTRUE(input$ss_use_fpc)) input$ss_population else NA_real_
tab <- .r4vn_ss_sensitivity(m,vals,input$ss_sens_parameter,grid,loss=(input$ss_loss %||% 0)/100,design_effect=input$ss_deff %||% 1,population=pop)
labs <- setNames(vapply(m$inputs,`[[`,character(1),"label"),vapply(m$inputs,`[[`,character(1),"id"))
attr(tab,"parameter") <- input$ss_sens_parameter
lbl <- unname(labs[input$ss_sens_parameter])
if(!length(lbl) || is.na(lbl) || !nzchar(lbl)) lbl <- input$ss_sens_parameter
attr(tab,"parameter_label") <- lbl
ss_sensitivity_r(tab)
})
output$ss_sensitivity_card <- shiny::renderUI({
x <- ss_sensitivity_r()
if(is.null(x)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Sensitivity results"),
shiny::tableOutput("ss_sensitivity_table"),
shiny::plotOutput("ss_sensitivity_plot", height="320px")
)
})
output$ss_export_card <- shiny::renderUI({
m <- current_method(); x <- ss_result_r()
if(is.null(m) || is.null(x) || !identical(x$method_id,m$id)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Export"),
shiny::downloadButton("ss_export_word", "Word"),
shiny::downloadButton("ss_export_pdf", "PDF"),
shiny::span(class="small-note", " PDF export uses Chrome through pagedown when available, with a LaTeX fallback.")
)
})
output$ss_sensitivity_table <- shiny::renderTable({
x <- ss_sensitivity_r(); shiny::req(x)
lbl <- attr(x,"parameter_label") %||% "Parameter value"
z <- data.frame(
x$value,
x$base_n,
x$final_n,
check.names=FALSE,
stringsAsFactors=FALSE
)
names(z) <- c(lbl, "Base required sample size", "Final recruitment target")
note <- ifelse(nzchar(x$error), x$error, "")
if(any(nzchar(note))) z$Notes <- note
utils::head(z,100)
}, digits=2, striped=TRUE, bordered=TRUE, spacing="xs")
output$ss_sensitivity_plot <- shiny::renderPlot({
x <- ss_sensitivity_r(); shiny::req(x)
par_label <- attr(x,"parameter_label") %||% "Parameter value"
good <- is.finite(x$final_n)
if(!any(good)) { plot.new(); text(.5,.5,"No valid sensitivity results"); return() }
x <- x[good,,drop=FALSE]
mode <- input$ss_plot_result %||% "final_n"
if(mode=="both") {
yr <- range(c(x$base_n,x$final_n),na.rm=TRUE)
plot(x$value,x$base_n,type=if(isTRUE(input$ss_plot_points)) "o" else "l",xlab=par_label,ylab="Required sample size",ylim=yr)
lines(x$value,x$final_n,type=if(isTRUE(input$ss_plot_points)) "o" else "l",lty=2)
legend("topright",legend=c("Base required sample size","Final recruitment target"),lty=c(1,2),pch=if(isTRUE(input$ss_plot_points)) c(1,1) else c(NA,NA),bty="n")
} else {
y <- x[[mode]]
plot(x$value,y,type=if(isTRUE(input$ss_plot_points)) "o" else "l",xlab=par_label,ylab=if(mode=="final_n") "Final recruitment target" else "Base required sample size")
}
})
ss_plot_file <- function() {
x <- ss_sensitivity_r(); if(is.null(x)) return(NULL)
f <- tempfile(fileext=".png")
grDevices::png(f,width=1600,height=1000,res=180)
on.exit(grDevices::dev.off(),add=TRUE)
good <- is.finite(x$final_n); xx<-x[good,,drop=FALSE]
if(nrow(xx)) plot(xx$value,xx$final_n,type="o",xlab=attr(x,"parameter_label") %||% "Parameter value",ylab="Final recruitment target") else { plot.new(); text(.5,.5,"No valid results") }
f
}
output$ss_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sample_size.docx"),
content=function(file) { shiny::req(project()$sample_size); pf<-ss_plot_file(); .r4vn_design_export_word(project(),file,sections="sample_size",plot_file=pf) }
)
output$ss_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sample_size.pdf"),
content=function(file) { shiny::req(project()$sample_size); pf<-ss_plot_file(); .r4vn_design_export_pdf(project(),file,sections="sample_size",plot_file=pf) }
)
# SAMPLING --------------------------------------------------------------
shiny::observeEvent(input$sp_source, {
ch <- if(identical(input$sp_source,"generated")) sampling_methods_generated else sampling_methods_frame
shiny::updateSelectInput(session,"sp_method",choices=ch,selected=unname(ch)[1])
}, ignoreInit=FALSE)
shiny::observeEvent(input$sp_file, {
z <- tryCatch(read_uploaded_frame(input$sp_file),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=8); return() }
frame_r(z); shiny::showNotification(sprintf("Loaded %d rows and %d variables.",nrow(z),ncol(z)),type="message")
})
sampling_data <- shiny::reactive({
if(identical(input$sp_source,"generated")) .r4vn_sampling_generated_frame(input$sp_population_n %||% 500, "ID") else frame_r()
})
output$sp_data_status <- shiny::renderUI({
d <- frame_r()
if(is.null(d)) return(shiny::div(class="small-note","No sampling frame loaded yet."))
shiny::div(class="r4vn-kpi", paste0(nrow(d), " records \u2022 ", ncol(d), " variables"))
})
output$sp_id_ui <- shiny::renderUI({
if(!identical(input$sp_source,"frame")) return(NULL)
d<-frame_r(); if(is.null(d)) return(NULL)
shiny::selectInput("sp_id","Unique ID variable",choices=names(d),selected=names(d)[1])
})
output$sp_params_ui <- shiny::renderUI({
d<-sampling_data(); nms<-if(is.null(d)) character() else names(d); m<-input$sp_method
n_default <- if(is.null(d)) 100 else min(100,nrow(d))
if(m %in% c("simple","systematic")) return(shiny::numericInput("sp_n","Sample size (n)",n_default,min=1,step=1))
if(m=="stratified") return(shiny::tagList(
shiny::numericInput("sp_n","Total sample size (n)",n_default,min=1,step=1),
shiny::selectInput("sp_strata","Stratification variable",choices=nms),
shiny::selectInput("sp_allocation","Allocation",c("Proportional"="proportional","Equal"="equal","Custom"="custom")),
shiny::conditionalPanel("input.sp_allocation == 'custom'",shiny::textInput("sp_custom_counts","Custom counts","A=50,B=50"))
))
if(m %in% c("pps_systematic","pps_brewer","pps_sampford","pps_tille","pps_pivotal","pps_maxentropy","pps_wr")) return(shiny::tagList(
shiny::numericInput("sp_n","Number of units / draws",if(is.null(d))30 else min(30,nrow(d)),min=1,step=1),
shiny::selectInput("sp_mos","Measure of size (MOS)",choices=nms)
))
if(m=="cluster") return(shiny::tagList(
shiny::selectInput("sp_cluster","Cluster variable",choices=nms),
shiny::numericInput("sp_n_clusters","Number of clusters",10,min=1,step=1)
))
if(m=="multistage_pps") return(shiny::tagList(
shiny::selectInput("sp_cluster","Cluster / PSU variable",choices=nms),
shiny::selectInput("sp_mos","PSU measure of size (constant within PSU)",choices=nms),
shiny::numericInput("sp_n_clusters","PSUs to select",10,min=1,step=1),
shiny::numericInput("sp_n_within","Units per selected PSU",10,min=1,step=1)
))
NULL
})
shiny::observeEvent(input$sp_new_seed, shiny::updateNumericInput(session,"sp_seed",value=sample.int(.Machine$integer.max,1)))
collect_sp_params <- function(m) {
z <- switch(m,
simple=list(n=input$sp_n), systematic=list(n=input$sp_n),
stratified=list(n=input$sp_n,strata=input$sp_strata,allocation=input$sp_allocation,custom_counts=input$sp_custom_counts),
pps_systematic=list(n=input$sp_n,mos=input$sp_mos),
pps_brewer=list(n=input$sp_n,mos=input$sp_mos),
pps_sampford=list(n=input$sp_n,mos=input$sp_mos),
pps_tille=list(n=input$sp_n,mos=input$sp_mos),
pps_pivotal=list(n=input$sp_n,mos=input$sp_mos),
pps_maxentropy=list(n=input$sp_n,mos=input$sp_mos),
pps_wr=list(n=input$sp_n,mos=input$sp_mos),
cluster=list(cluster=input$sp_cluster,n_clusters=input$sp_n_clusters),
multistage_pps=list(cluster=input$sp_cluster,mos=input$sp_mos,n_clusters=input$sp_n_clusters,n_within=input$sp_n_within),
list()
)
z$source_mode <- input$sp_source
if(identical(input$sp_source,"generated")) z$generated_population_n <- input$sp_population_n
z
}
shiny::observeEvent(
list(input$sp_source, input$sp_population_n, input$sp_method, input$sp_n,
input$sp_strata, input$sp_allocation, input$sp_mos, input$sp_cluster,
input$sp_n_clusters, input$sp_n_within),
{
if(!is.null(sampling_run_r())) sampling_run_r(NULL)
p <- project(); if(!is.null(p$sampling)) { p$sampling <- NULL; p$modified <- as.character(Sys.time()); project(p) }
},
ignoreInit=TRUE
)
shiny::observeEvent(input$sp_run, {
d<-sampling_data(); shiny::req(d,input$sp_method)
idvar <- if(identical(input$sp_source,"generated")) "ID" else input$sp_id
shiny::req(idvar)
run <- tryCatch(.r4vn_sampling_run(d,input$sp_method,idvar,input$sp_seed,collect_sp_params(input$sp_method)),error=function(e)e)
if(inherits(run,"error")) { shiny::showNotification(conditionMessage(run),type="error",duration=10); return() }
run$method_label <- method_label(input$sp_method, sampling_methods_frame)
sampling_run_r(run)
p<-project(); p$sampling<-.r4vn_sampling_manifest(run); p$modified<-as.character(Sys.time()); project(p)
})
sanitize_sampling_selected <- function(d, idvar=NULL) {
if(is.null(d)) return(d)
drop <- intersect(c("sample_selected","sample_order","sampling_run","rng_state_before","rng_state_after"), names(d))
d <- d[, setdiff(names(d), drop), drop=FALSE]
if(!is.null(idvar) && idvar %in% names(d)) d <- d[, c(idvar, setdiff(names(d),idvar)), drop=FALSE]
friendly <- c(
sampling_probability="Sampling probability",
sampling_weight="Sampling weight",
selection_count="Selection count",
draw_probability="Draw probability",
psu_inclusion_probability="PSU inclusion probability",
within_cluster_probability="Within-cluster probability"
)
hit <- intersect(names(friendly), names(d))
if(length(hit)) names(d)[match(hit,names(d))] <- unname(friendly[hit])
d
}
sampling_selected_display <- shiny::reactive({
x <- sampling_run_r(); shiny::req(x, x$selected)
d <- sanitize_sampling_selected(x$selected, x$idvar)
if(x$idvar %in% names(d)) {
ord <- order(d[[x$idvar]], na.last=TRUE)
d <- d[ord,,drop=FALSE]
}
rownames(d) <- NULL
data.frame(`Sampling order`=seq_len(nrow(d)), d, check.names=FALSE, stringsAsFactors=FALSE)
})
sorted_sampling_selected <- shiny::reactive({
d <- sampling_selected_display(); shiny::req(d)
idx <- input$sp_selected_preview_rows_all
if(!is.null(idx) && length(idx)) d <- d[idx,,drop=FALSE]
# Sampling order is intentionally NOT recomputed after a user sort.
# It remains the rank from the default ascending-ID list, so sorting
# another column never looks like a new random sample was generated.
rownames(d) <- NULL
d
})
output$sp_result <- shiny::renderUI({
x<-sampling_run_r()
if(is.null(x)) return(shiny::div(class="r4vn-card",shiny::h4("Sampling result"),shiny::p("Choose whether you have a sampling frame or only a population size, select a method, then run. R4VN records reproducibility information for every random sample.")))
shiny::div(class="r4vn-card",
shiny::h3("R4VN Sampling Result"),
shiny::div(class="r4vn-kpi",shiny::strong(paste(x$n_selected,"selected records"))),
shiny::p(shiny::strong("Method: "),x$method_label %||% x$method),
shiny::p(shiny::strong("Seed: "),x$seed),
shiny::p(shiny::strong("Frame size: "),x$n_frame),
shiny::p(class="small-note", shiny::strong("Reproducibility ID: "), x$run_id, " ", help_tip("A unique ID for this random sampling run. Together with the seed, parameters, and source fingerprint, it helps verify or reproduce the same sample later.")),
shiny::p(class="small-note", shiny::strong("Source fingerprint: "),x$frame_hash, " ", help_tip("A fingerprint summarizes the sampling source without showing the full data. R4VN uses it to check that the source used for reproduction is the same as the original one."))
)
})
output$sp_method_paragraph <- shiny::renderUI({
x <- sampling_run_r()
if(is.null(x)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Methods"),
shiny::p(.r4vn_sampling_method_paragraph(x))
)
})
output$sp_selected_preview <- DT::renderDT({
d <- sampling_selected_display(); shiny::req(d)
DT::datatable(
d,
rownames=FALSE,
filter="none",
selection="none",
options=list(
pageLength=25,
lengthMenu=c(10,25,50,100),
autoWidth=TRUE,
order=list(list(1,"asc")),
columnDefs=list(
list(targets=0, orderable=FALSE, searchable=FALSE, width="105px")
),
scrollX=TRUE
),
class="compact stripe hover"
)
}, server=FALSE)
shiny::observeEvent(input$sp_reproduce, {
run<-sampling_run_r(); d<-sampling_data(); shiny::req(run,d)
z <- tryCatch(verify_exact_run(run,d),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=10); return() }
if(isTRUE(z$same)) {
sampling_run_r(z$run)
shiny::showNotification("Frame verified and the sample was reproduced exactly.",type="message",duration=7)
} else shiny::showNotification("Frame hash matched but the reproduced sample differed. Check R/R4VN method versions.",type="warning",duration=10)
})
output$sp_template <- shiny::downloadHandler(
filename=function() paste0("R4VN_sampling_template_",input$sp_template_type,".xlsx"),
content=function(file) .r4vn_sampling_write_template(file,input$sp_template_type)
)
output$sp_export_csv <- shiny::downloadHandler(
filename=function() paste0("R4VN_",sampling_run_r()$run_id,"_selected.csv"),
content=function(file) { d<-sorted_sampling_selected(); shiny::req(d); utils::write.csv(d,file,row.names=FALSE,na="") }
)
output$sp_export_xlsx <- shiny::downloadHandler(
filename=function() paste0("R4VN_",sampling_run_r()$run_id,"_sampling.xlsx"),
content=function(file) {
.r4vn_design_require("openxlsx","sampling workbook export")
x<-sampling_run_r(); shiny::req(x,x$selected,x$full)
dsel <- sorted_sampling_selected(); shiny::req(dsel)
wb<-openxlsx::createWorkbook()
openxlsx::addWorksheet(wb,"Selected_Sample"); openxlsx::writeData(wb,"Selected_Sample",dsel)
full_export <- x$full[, setdiff(names(x$full), "sampling_run"), drop=FALSE]
openxlsx::addWorksheet(wb,"Full_Frame"); openxlsx::writeData(wb,"Full_Frame",full_export)
man<-data.frame(Field=c("Run ID","Method","Seed","Frame hash","Frame N","Selected N","R version","R4VN version"),Value=c(x$run_id,x$method,x$seed,x$frame_hash,x$n_frame,x$n_selected,x$r_version,x$r4vn_version),stringsAsFactors=FALSE)
openxlsx::addWorksheet(wb,"Audit_Trail"); openxlsx::writeData(wb,"Audit_Trail",man)
if(x$method %in% c("pps_systematic","pps_brewer","pps_sampford","pps_tille","pps_pivotal","pps_maxentropy","pps_wr","multistage_pps")) {
keep<-intersect(c(x$idvar,"sample_selected","sample_order","sampling_probability","sampling_weight","selection_count","draw_probability","psu_inclusion_probability","within_cluster_probability"),names(x$full))
openxlsx::addWorksheet(wb,"PPS_Details"); openxlsx::writeData(wb,"PPS_Details",x$full[,keep,drop=FALSE])
}
openxlsx::saveWorkbook(wb,file,overwrite=TRUE)
}
)
output$sp_export_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sampling.docx"),
content=function(file) { shiny::req(project()$sampling); .r4vn_design_export_word(project(),file,sections="sampling") }
)
output$sp_export_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_sampling.pdf"),
content=function(file) { shiny::req(project()$sampling); .r4vn_design_export_pdf(project(),file,sections="sampling") }
)
# RANDOMIZATION ---------------------------------------------------------
shiny::observeEvent(input$rd_source, {
ch <- if(identical(input$rd_source,"generated")) randomization_methods_generated else randomization_methods_frame
shiny::updateSelectInput(session,"rd_method",choices=ch,selected=unname(ch)[1])
}, ignoreInit=FALSE)
shiny::observeEvent(input$rd_file, {
z <- tryCatch(read_uploaded_frame(input$rd_file),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=8); return() }
random_frame_r(z); shiny::showNotification(sprintf("Loaded %d participants and %d variables.",nrow(z),ncol(z)),type="message")
})
randomization_data <- shiny::reactive({
if(identical(input$rd_source,"generated")) .r4vn_sampling_generated_frame(input$rd_n_participants %||% 100, "ID") else random_frame_r()
})
output$rd_data_status <- shiny::renderUI({
d <- random_frame_r()
if(is.null(d)) return(shiny::div(class="small-note","No participant list loaded yet."))
shiny::div(class="r4vn-kpi", paste0(nrow(d), " participants \u2022 ", ncol(d), " variables"))
})
output$rd_id_ui <- shiny::renderUI({
if(!identical(input$rd_source,"frame")) return(NULL)
d<-random_frame_r(); if(is.null(d)) return(NULL)
shiny::selectInput("rd_id","Participant ID variable",choices=names(d),selected=names(d)[1])
})
output$rd_params_ui <- shiny::renderUI({
d<-randomization_data(); nms<-if(is.null(d)) character() else names(d); m<-input$rd_method
shiny::tagList(
shiny::textInput("rd_groups","Group names","Control,Intervention"),
shiny::textInput("rd_ratio","Allocation ratio","1,1"),
shiny::p(class="small-note", "R4VN enforces the requested final allocation ratio exactly. For example, 100 participants with a 1:1 ratio will always produce 50 and 50. The participant count (and each stratum for stratified block randomization) must be compatible with the ratio."),
if(m %in% c("rct_block","rct_stratified_block")) shiny::tagList(
shiny::textInput("rd_block_sizes","Permuted block sizes","2,4,6"),
shiny::p(class="small-note", "Each block is complete and follows the requested allocation ratio exactly. For a 1:1 ratio, the default block sizes are 2, 4, and 6.")
),
if(m=="rct_stratified_block") shiny::selectInput("rd_strata","Stratification variable",choices=nms)
)
})
shiny::observeEvent(input$rd_new_seed, shiny::updateNumericInput(session,"rd_seed",value=sample.int(.Machine$integer.max,1)))
collect_rd_params <- function(m) {
z <- switch(m,
rct_simple=list(groups=input$rd_groups,ratio=input$rd_ratio),
rct_complete=list(groups=input$rd_groups,ratio=input$rd_ratio),
rct_block=list(groups=input$rd_groups,ratio=input$rd_ratio,block_sizes=input$rd_block_sizes),
rct_stratified_block=list(groups=input$rd_groups,ratio=input$rd_ratio,block_sizes=input$rd_block_sizes,strata=input$rd_strata),
list()
)
z$source_mode <- input$rd_source
if(identical(input$rd_source,"generated")) z$generated_participant_n <- input$rd_n_participants
z
}
shiny::observeEvent(
list(input$rd_source, input$rd_n_participants, input$rd_method, input$rd_groups,
input$rd_ratio, input$rd_block_sizes, input$rd_strata),
{
if(!is.null(randomization_run_r())) randomization_run_r(NULL)
p <- project(); if(!is.null(p$randomization)) { p$randomization <- NULL; p$modified <- as.character(Sys.time()); project(p) }
},
ignoreInit=TRUE
)
shiny::observeEvent(input$rd_run, {
d<-randomization_data(); shiny::req(d,input$rd_method)
idvar <- if(identical(input$rd_source,"generated")) "ID" else input$rd_id
shiny::req(idvar)
run <- tryCatch(.r4vn_sampling_run(d,input$rd_method,idvar,input$rd_seed,collect_rd_params(input$rd_method)),error=function(e)e)
if(inherits(run,"error")) { shiny::showNotification(conditionMessage(run),type="error",duration=10); return() }
run$method_label <- method_label(input$rd_method, randomization_methods_frame)
randomization_run_r(run)
p<-project(); p$randomization<-.r4vn_sampling_manifest(run); p$modified<-as.character(Sys.time()); project(p)
})
output$rd_result <- shiny::renderUI({
x<-randomization_run_r()
if(is.null(x)) return(shiny::div(class="r4vn-card",shiny::h4("Randomization result"),shiny::p("Use a participant list or generate participant numbers, specify groups and allocation method, then randomize.")))
alloc <- tryCatch(.r4vn_randomization_print_table(x),error=function(e) NULL)
counts <- if(is.null(alloc)) NULL else table(alloc$Group)
shiny::div(class="r4vn-card",
shiny::h3("R4VN Randomization Result"),
shiny::div(class="r4vn-kpi",shiny::strong(paste(x$n_selected,"randomized participants"))),
if(length(counts)) shiny::p(shiny::strong("Groups: "),paste(paste(names(counts),as.integer(counts),sep=" = "),collapse="; ")),
shiny::p(shiny::strong("Method: "),x$method_label %||% x$method),
if(!is.null(x$details$block_sizes)) shiny::p(shiny::strong("Block sizes used: "), paste(x$details$block_sizes, collapse=", ")),
shiny::p(shiny::strong("Run ID: "),x$run_id),
shiny::p(shiny::strong("Seed: "),x$seed),
shiny::p(class="small-note",paste("Participant-source fingerprint:",x$frame_hash))
)
})
output$rd_method_paragraph <- shiny::renderUI({
x <- randomization_run_r()
if(is.null(x)) return(NULL)
shiny::div(class="r4vn-card",
shiny::h4("Methods"),
shiny::p(.r4vn_randomization_method_paragraph(x))
)
})
output$rd_preview <- shiny::renderTable({
x<-randomization_run_r(); shiny::req(x)
utils::head(.r4vn_randomization_print_table(x),30)
}, striped=TRUE, bordered=TRUE, spacing="xs")
shiny::observeEvent(input$rd_reproduce, {
run<-randomization_run_r(); d<-randomization_data(); shiny::req(run,d)
z <- tryCatch(verify_exact_run(run,d),error=function(e)e)
if(inherits(z,"error")) { shiny::showNotification(conditionMessage(z),type="error",duration=10); return() }
if(isTRUE(z$same)) {
randomization_run_r(z$run)
shiny::showNotification("Participant frame verified and the allocation was reproduced exactly.",type="message",duration=7)
} else shiny::showNotification("Frame hash matched but the reproduced allocation differed. Check R/R4VN method versions.",type="warning",duration=10)
})
output$rd_template <- shiny::downloadHandler(
filename=function() "R4VN_randomization_template.xlsx",
content=function(file) .r4vn_sampling_write_template(file,"rct")
)
output$rd_export_csv <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_allocation.csv"),
content=function(file) { x<-randomization_run_r(); shiny::req(x); utils::write.csv(.r4vn_randomization_print_table(x),file,row.names=FALSE,na="") }
)
output$rd_export_xlsx <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_allocation.xlsx"),
content=function(file) {
.r4vn_design_require("openxlsx","randomization workbook export")
x<-randomization_run_r(); shiny::req(x)
wb<-openxlsx::createWorkbook()
openxlsx::addWorksheet(wb,"Randomization_List"); openxlsx::writeData(wb,"Randomization_List",.r4vn_randomization_print_table(x))
if(!is.null(x$full)) { full_export <- x$full[, setdiff(names(x$full), "sampling_run"), drop=FALSE]
openxlsx::addWorksheet(wb,"Full_Frame"); openxlsx::writeData(wb,"Full_Frame",full_export) }
man<-data.frame(Field=c("Run ID","Method","Seed","Frame hash","Participants","R version","R4VN version"),Value=c(x$run_id,x$method,x$seed,x$frame_hash,x$n_selected,x$r_version,x$r4vn_version),stringsAsFactors=FALSE)
openxlsx::addWorksheet(wb,"Audit_Trail"); openxlsx::writeData(wb,"Audit_Trail",man)
openxlsx::saveWorkbook(wb,file,overwrite=TRUE)
}
)
output$rd_print_word <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_print_list.docx"),
content=function(file) { x<-randomization_run_r(); shiny::req(x); .r4vn_randomization_export_word(x,file) }
)
output$rd_print_pdf <- shiny::downloadHandler(
filename=function() paste0("R4VN_",randomization_run_r()$run_id,"_print_list.pdf"),
content=function(file) { x<-randomization_run_r(); shiny::req(x); .r4vn_randomization_export_pdf(x,file) }
)
output$rd_report_word <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_randomization.docx"),
content=function(file) { shiny::req(project()$randomization); .r4vn_design_export_word(project(),file,sections="randomization") }
)
output$rd_report_pdf <- shiny::downloadHandler(
filename=function() paste0(.r4vn_design_safe_filename(project()$name),"_randomization.pdf"),
content=function(file) { shiny::req(project()$randomization); .r4vn_design_export_pdf(project(),file,sections="randomization") }
)
}
app <- shiny::shinyApp(ui, server, options=list(launch.browser=launch.browser))
invisible(shiny::runApp(app, launch.browser=launch.browser, port=port, host=host))
}
Try the R4VN package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.