Nothing
# Config wizard server logic — state management, navigation, steps 1-2, 4-8
# Step 3 CSV/FWF split into server_step3_csv.R
# Positional wizard input id, namespaced by the wizard-open sequence number.
# Inputs are never destroyed when the wizard closes, so without the sequence
# component a collector firing for dataset B could read checkbox/select state
# left over from dataset A at the same position (G-03).
wiz_input_id <- function(prefix, seq, i) paste0(prefix, "_", seq, "_", i)
server_wizard <- function(input, output, session, rv, config_dir, gcfg_rv) {
# ── Wizard state ─────────────────────────────────────────────────────
# Single source of truth for defaults — used to seed reactiveValues and to
# reset state when the wizard is opened for a new dataset.
.wiz_defaults <- list(
mode="new", dataset_name="", description="",
original_name="", # edit mode: the name the config was opened under
open_seq=0L, # bumped on every open; namespaces positional inputs
file_mode="folder", folder="", current_file="", previous_file="",
format="csv", encoding="UTF-8", delimiter=",", quote_char='"',
has_header=TRUE, csv_skip=0L,
col_names=character(0), col_types_inferred=character(0),
raw_header_names=character(0), col_name_reasons=character(0),
col_types_override=list(),
key_columns=character(0), expected_columns=character(0),
fwf_widths=integer(0), fwf_col_names=character(0), fwf_skip=0L,
column_rules=list(), rule_overrides=list(),
custom_checks_file="", snapshot_db="", report_output_dir="",
extra_keys=list(),
sniff_conflicts=list(),
current_step=1L,
step_valid=rep(FALSE, 8L),
raw_lines=character(0),
ruler_string=make_ruler_string(80),
current_preview_path="",
encoding_choices=c("UTF-8","ISO-8859-1","Windows-1252","UTF-16LE","CP1250"),
sniff_col_names=character(0), sniff_col_types=character(0),
csv_preview_df=NULL, csv_col_names_detected=character(0),
fwf_preview_df=NULL, fwf_starts=integer(0), fwf_line_len=80L
)
wiz <- do.call(reactiveValues, .wiz_defaults)
open_wizard <- function(mode, dataset_name=NULL) {
# Always reset to defaults first — edit mode previously overlaid the
# config on top of whatever the last wizard session left behind, leaking
# every wiz field read_config() doesn't produce (raw_header_names,
# inferred types, previews, sniff conflicts, ...) across opens (G-03).
seq_next <- isolate(wiz$open_seq) + 1L
for (nm in names(.wiz_defaults)) wiz[[nm]] <- .wiz_defaults[[nm]]
wiz$open_seq <- seq_next
if (mode == "edit" && !is.null(dataset_name)) {
path <- file.path(config_dir(), paste0(dataset_name, ".yml"))
cfg <- if (safe_file_exists(path))
tryCatch(read_config(path), error = function(e) NULL) else NULL
# A missing or unparseable config must NOT fall through to a blank step-1
# wizard: with mode left at the default "new", a subsequent Save would
# overwrite the unreadable config with an empty one. Tell the user and
# keep the wizard closed, leaving the file untouched (B-11).
if (is.null(cfg)) {
showNotification(
sprintf("Could not load config for '%s' — the file is missing or could not be parsed. It was left unchanged.",
dataset_name),
type = "error", duration = 10)
return(invisible(NULL))
}
k <- cfg$known
for (nm in names(k)) wiz[[nm]] <- k[[nm]]
wiz$extra_keys <- cfg$extra
wiz$mode <- "edit"
wiz$original_name <- dataset_name
wiz$current_step <- 1L
# Trigger file preview
preview_path <- if (nchar(k$folder %||%"") > 0) {
files <- list_files_only(k$folder)
if (length(files) > 0) files[order(file.mtime(files), decreasing=TRUE)[1]] else ""
} else k$current_file %||% ""
if (nchar(preview_path) > 0) {
wiz$current_preview_path <- preview_path
load_raw_preview(session, preview_path, wiz)
}
}
rv$wizard_open <- TRUE
rv$active_section <- "wizard"
}
# Watch for wizard open requests from parent (rv$wizard_request)
observeEvent(rv$wizard_request, {
req(!is.null(rv$wizard_request))
open_wizard(rv$wizard_request$mode, rv$wizard_request$dataset)
})
# ── Breadcrumb ────────────────────────────────────────────────────────
output$wizard_breadcrumb <- renderUI({
wizard_breadcrumb(wiz$current_step, wiz$step_valid)
})
# ── Step content ─────────────────────────────────────────────────────
# Only react to step navigation (wiz$current_step); isolate all wiz field
# reads so that typing in a text input doesn't re-render the whole step
# and steal keyboard focus from the active field.
output$wizard_step_content <- renderUI({
s <- wiz$current_step # reactive: re-render on step change only
isolate({ # isolate: wiz field reads don't subscribe
gcfg <- gcfg_rv()
if (s == 1) wizard_step1_ui(wiz)
else if (s == 2) wizard_step2_ui(wiz)
else if (s == 3) wizard_step3_ui(wiz)
else if (s == 4) wizard_step4_ui()
else if (s == 5) wizard_step5_ui()
else if (s == 6) wizard_step6_ui(wiz, gcfg)
else if (s == 7) wizard_step7_ui(wiz)
else if (s == 8) wizard_step8_ui()
})
})
# ── Step validation ───────────────────────────────────────────────────
step_valid <- reactive({
valid <- rep(FALSE, 8L)
# Step 1
nm <- input$wiz_dataset_name %||% ""
valid[1] <- nchar(nm) > 0 && is_valid_r_name(nm)
# Step 2
path <- wiz$current_preview_path
valid[2] <- nchar(path %||% "") > 0
# Step 3
if (isTRUE(input$wiz_format == "fwf")) {
# FWF valid when: widths sum <= line len, at least 1 col, all names valid
total <- sum(wiz$fwf_widths)
line_len <- wiz$fwf_line_len %||% 80L
valid[3] <- total > 0 && total <= line_len &&
length(wiz$fwf_col_names) > 0 &&
all(nchar(wiz$fwf_col_names) > 0) &&
all(is_valid_r_name(wiz$fwf_col_names)) &&
!any(duplicated(wiz$fwf_col_names))
} else {
valid[3] <- length(wiz$col_names) > 0 &&
all(nchar(wiz$col_names) > 0) &&
all(is_valid_r_name(wiz$col_names)) &&
!any(duplicated(wiz$col_names))
}
# Steps 4-8 are unlocked once step 3 is complete (col_names populated)
step3_done <- isTRUE(valid[3])
valid[4] <- step3_done
valid[5] <- step3_done
valid[6] <- step3_done
valid[7] <- step3_done
valid[8] <- step3_done
valid
})
observe({ wiz$step_valid <- step_valid() })
# ── Navigation ────────────────────────────────────────────────────────
output$wizard_back_btn <- renderUI({
if (wiz$current_step > 1)
actionButton("wizard_back", "◄ Back", class="btn btn-outline-secondary btn-sm")
})
output$wizard_next_btn <- renderUI({
if (wiz$current_step < 8) {
disabled <- !isTRUE(wiz$step_valid[wiz$current_step])
btn <- actionButton("wizard_next", "Next ►", class="btn btn-primary btn-sm")
if (disabled) tagAppendAttributes(btn, disabled=NA) else btn
}
})
# (Re-)activate the FWF ruler whenever step 3 becomes the visible step.
# `output$wizard_step_content` (above) rebuilds the entire step UI — and
# with it a fresh, empty `#fwf-ruler-wrap` / SVG overlay — on every step
# change, including backward navigation. So the JS-side ruler must be
# told to reattach (and redraw any previously-placed boundaries) every
# time we land on step 3, not just when advancing into it from step 2.
enter_fwf_step3 <- function() {
positions <- if (length(wiz$fwf_starts) > 0)
as.list(as.integer(wiz$fwf_starts) - 1L) else list()
session$sendCustomMessage("fwf_reinit", list(positions = positions))
}
observeEvent(input$wizard_back, {
if (wiz$current_step > 1) {
wiz$current_step <- wiz$current_step - 1L
if (wiz$current_step == 3L) enter_fwf_step3()
}
})
observeEvent(input$wizard_next, {
sv <- step_valid()
if (isTRUE(sv[wiz$current_step])) {
collect_step_inputs(input, wiz, gcfg_rv())
wiz$current_step <- wiz$current_step + 1L
if (wiz$current_step == 3L) enter_fwf_step3()
}
})
# ── Step 1 inputs ────────────────────────────────────────────────────
observeEvent(input$wiz_dataset_name, { wiz$dataset_name <- input$wiz_dataset_name %||% "" })
observeEvent(input$wiz_description, { wiz$description <- input$wiz_description %||% "" })
# Step 1 validation
iv_step1 <- shinyvalidate::InputValidator$new()
iv_step1$add_rule("wiz_dataset_name", function(v) {
# Empty on first open: no error — Next button gate handles the required check
if (is.null(v) || nchar(v) == 0) return(NULL)
if (!is_valid_r_name(v))
return("Must start with a letter; only letters, numbers, and underscores.")
existing <- list_dataset_configs(config_dir())
# In edit mode the dataset's own (original) name is legitimate; renaming
# onto any OTHER existing dataset would silently overwrite it (G-07).
clash <- v %in% existing &&
!(wiz$mode == "edit" && identical(v, wiz$original_name))
if (clash)
return(sprintf("A dataset named '%s' already exists.", v))
})
iv_step1$enable()
# ── Step 2: File location ────────────────────────────────────────────
# Roots for file/folder pickers: project root first (most useful), then
# home, then system volumes (gives drive letters on Windows).
# shinyFiles 0.9.3 bug: sendDirectoryData does `roots[name]` directly (not
# `roots()`), so roots must be a plain named vector, not a reactive/function.
# config_dir() is static for the session (reads from env var), so this is safe.
file_roots <- c(
Project = deployment_root(isolate(config_dir())),
Home = path.expand("~"),
shinyFiles::getVolumes()()
)
shinyFiles::shinyDirChoose(input, "wiz_folder_browse",
roots=file_roots, session=session)
shinyFiles::shinyFileChoose(input, "wiz_current_file_browse",
roots=file_roots, session=session)
shinyFiles::shinyFileChoose(input, "wiz_prev_file_browse",
roots=file_roots, session=session)
# ── shinyFiles browse callbacks ─────────────────────────────────────
# These fire when the Browse dialog is used successfully.
# Direct text input is the primary path entry (see observers below).
observeEvent(input$wiz_folder_browse, {
req(is.list(input$wiz_folder_browse))
p <- shinyFiles::parseDirPath(file_roots, input$wiz_folder_browse)
if (length(p) > 0) {
path <- as.character(p[1])
updateTextInput(session, "wiz_folder_display", value=path)
activate_folder(path)
}
})
observeEvent(input$wiz_current_file_browse, {
req(is.list(input$wiz_current_file_browse))
p <- shinyFiles::parseFilePaths(file_roots, input$wiz_current_file_browse)
if (nrow(p) > 0) {
path <- as.character(p$datapath[1])
updateTextInput(session, "wiz_current_file_display", value=path)
activate_file(path)
}
})
observeEvent(input$wiz_prev_file_browse, {
req(is.list(input$wiz_prev_file_browse))
p <- shinyFiles::parseFilePaths(file_roots, input$wiz_prev_file_browse)
if (nrow(p) > 0) {
path <- as.character(p$datapath[1])
updateTextInput(session, "wiz_prev_file_display", value=path)
wiz$previous_file <- path
}
})
# ── Helpers: activate a folder/file path from any source ────────────
activate_folder <- function(path) {
path <- trimws(path)
if (!safe_dir_exists(path)) return()
wiz$folder <- path
files <- list_files_only(path)
if (length(files) > 0) {
preview <- files[order(file.mtime(files), decreasing=TRUE)[1]]
wiz$current_preview_path <- preview
load_raw_preview(session, preview, wiz)
}
}
activate_file <- function(path) {
path <- trimws(path)
if (!safe_file_exists(path)) return()
wiz$current_file <- path
wiz$current_preview_path <- path
load_raw_preview(session, path, wiz)
}
# ── Direct text input observers (primary path entry method) ─────────
# Debounce the folder text input so we only react after the user pauses typing.
folder_input_r <- reactive({ input$wiz_folder_display })
folder_input_d <- shiny::debounce(folder_input_r, 600)
observe({
path <- folder_input_d() %||% ""
if (nchar(trimws(path)) > 0) activate_folder(path)
})
observeEvent(input$wiz_current_file_display, {
path <- trimws(input$wiz_current_file_display %||% "")
if (nchar(path) > 0 && safe_file_exists(path)) activate_file(path)
else if (nchar(path) > 0) wiz$current_file <- path # store even if not yet valid
}, ignoreInit=TRUE)
observeEvent(input$wiz_prev_file_display, {
path <- trimws(input$wiz_prev_file_display %||% "")
wiz$previous_file <- path
}, ignoreInit=TRUE)
# Sync file_mode radio to wiz state so build_config_list uses the correct branch
observeEvent(input$wiz_file_mode, {
wiz$file_mode <- input$wiz_file_mode %||% "folder"
}, ignoreInit=TRUE)
# ── Render Step 2 file inputs ────────────────────────────────────────
output$wiz_file_inputs <- renderUI({
mode <- input$wiz_file_mode %||% "folder"
if (mode == "folder") {
tagList(
p(class="text-muted mb-1", style="font-size:12px;",
"Type or paste the full folder path, or use Browse."),
div(class="d-flex gap-2 align-items-end",
div(style="flex:1;",
textInput("wiz_folder_display", "Folder path",
value=wiz$folder %||% "", width="100%",
placeholder="/path/to/data/folder/")
),
shinyFiles::shinyDirButton("wiz_folder_browse", "Browse",
"Select data folder", style="height:38px;white-space:nowrap;")
),
uiOutput("wiz_folder_path_status"),
uiOutput("wiz_folder_preview_info")
)
} else {
tagList(
p(class="text-muted mb-1", style="font-size:12px;",
"Type or paste the full file path, or use Browse."),
div(class="d-flex gap-2 align-items-end",
div(style="flex:1;",
textInput("wiz_current_file_display", "Current file *",
value=wiz$current_file %||% "", width="100%",
placeholder="/path/to/data/delivery_2026.csv")
),
shinyFiles::shinyFilesButton("wiz_current_file_browse", "Browse",
"Select current file", FALSE, style="height:38px;white-space:nowrap;")
),
uiOutput("wiz_current_file_status"),
div(class="d-flex gap-2 align-items-end mt-3",
div(style="flex:1;",
textInput("wiz_prev_file_display", "Previous file (optional)",
value=wiz$previous_file %||% "", width="100%",
placeholder="/path/to/data/delivery_2026_prev.csv")
),
shinyFiles::shinyFilesButton("wiz_prev_file_browse", "Browse",
"Select previous file", FALSE, style="height:38px;white-space:nowrap;")
),
uiOutput("wiz_prev_file_status")
)
}
})
# ── Path status badges ───────────────────────────────────────────────
output$wiz_folder_path_status <- renderUI({
path <- trimws(input$wiz_folder_display %||% "")
if (nchar(path) == 0) return(NULL)
if (safe_dir_exists(path)) {
n <- length(list_files_only(path))
div(class="text-success mt-1", style="font-size:12px;",
sprintf("✓ Folder found (%d files)", n))
} else {
div(class="text-danger mt-1", style="font-size:12px;",
"✗ Folder not found — check the path")
}
})
output$wiz_current_file_status <- renderUI({
path <- trimws(input$wiz_current_file_display %||% "")
if (nchar(path) == 0) return(NULL)
if (safe_file_exists(path)) {
sz <- format(file.size(path), big.mark=",")
div(class="text-success mt-1", style="font-size:12px;",
sprintf("✓ File found (%s bytes)", sz))
} else {
div(class="text-danger mt-1", style="font-size:12px;",
"✗ File not found — check the path")
}
})
output$wiz_prev_file_status <- renderUI({
path <- trimws(input$wiz_prev_file_display %||% "")
if (nchar(path) == 0) return(NULL)
if (safe_file_exists(path)) {
div(class="text-success mt-1", style="font-size:12px;", "✓ File found")
} else {
div(class="text-warning mt-1", style="font-size:12px;",
"⚠ File not found — leave blank to skip comparison checks")
}
})
output$wiz_folder_preview_info <- renderUI({
path <- wiz$folder %||% ""
if (nchar(path) == 0) return(NULL)
files <- list_files_only(path)
if (length(files) == 0) return(p(class="text-warning", "Folder is empty."))
files_sorted <- files[order(file.mtime(files), decreasing=TRUE)]
info <- lapply(seq_len(min(2, length(files_sorted))), function(i) {
lbl <- if (i==1) "Current" else "Previous"
sz <- format(file.size(files_sorted[i]), big.mark=",")
sprintf("%s: %s (%s bytes)", lbl, basename(files_sorted[i]), sz)
})
p(class="text-muted", style="font-size:12px;", paste(info, collapse=" | "))
})
# ── Step 4: Column Classification ────────────────────────────────────
# Reactive dependency only on wiz$col_names (set once in step 3).
# All other wiz fields (key_columns, expected_columns, col_types_override)
# are isolated so that ticking a checkbox doesn't rebuild the whole table
# and scroll the user back to row 1.
output$step4_column_table <- renderUI({
cols <- wiz$col_names # reactive: rebuild only when column list changes
req(length(cols) > 0)
isolate({ # isolate: checkbox/select state reads don't subscribe
seq_no <- wiz$open_seq
types <- wiz$col_types_inferred
overrides <- wiz$col_types_override
key_cols <- wiz$key_columns
exp_cols <- wiz$expected_columns
rows <- lapply(seq_along(cols), function(i) {
col <- cols[i]
inf_type <- if (i <= length(types)) types[i] else "character"
ovr_type <- overrides[[col]] %||% "auto"
is_key <- col %in% key_cols
is_exp <- length(exp_cols) == 0 || col %in% exp_cols
fluidRow(class="mb-1 border-bottom pb-1 align-items-center",
column(3, tags$strong(col, style="font-size:13px;")),
column(2, span(class="badge bg-light text-dark border", inf_type)),
column(2,
selectInput(wiz_input_id("s4_type", seq_no, i), NULL, width="100%",
choices=c("auto","character","numeric","date"), selected=ovr_type)
),
column(2,
checkboxInput(wiz_input_id("s4_key", seq_no, i), "Key col", value=is_key)
),
column(3,
checkboxInput(wiz_input_id("s4_exp", seq_no, i), "Expected", value=is_exp)
)
)
})
div(
fluidRow(class="mb-2 fw-semibold text-muted",
column(3, "Column"), column(2, "Inferred type"),
column(2, "Override"), column(2, "Key col"), column(3, "Expected")
),
div(style="max-height:500px;overflow-y:auto;", rows)
)
})
})
# Collect step 4 inputs
observe({
cols <- wiz$col_names
seq_no <- wiz$open_seq
if (length(cols) == 0) return()
# Bail out until THIS open's step-4 UI has rendered. The id carries the
# open sequence, so inputs surviving from a previously opened dataset can
# neither satisfy this guard nor be read positionally below (G-03).
if (is.null(input[[wiz_input_id("s4_type", seq_no, 1)]])) return()
n <- length(cols)
is_key <- logical(n)
is_exp <- logical(n)
overrides <- list()
for (i in seq_along(cols)) {
col <- cols[i]
type_val <- input[[wiz_input_id("s4_type", seq_no, i)]] %||% "auto"
if (type_val != "auto") overrides[[col]] <- type_val
is_key[i] <- isTRUE(input[[wiz_input_id("s4_key", seq_no, i)]])
is_exp[i] <- isTRUE(input[[wiz_input_id("s4_exp", seq_no, i)]])
}
wiz$col_types_override <- overrides
wiz$key_columns <- cols[is_key]
wiz$expected_columns <- cols[is_exp]
})
observeEvent(input$step4_select_all_expected, {
cols <- wiz$col_names
seq_no <- wiz$open_seq
for (i in seq_along(cols))
updateCheckboxInput(session, wiz_input_id("s4_exp", seq_no, i), value=TRUE)
wiz$expected_columns <- cols
})
observeEvent(input$step4_select_none_expected, {
cols <- wiz$col_names
seq_no <- wiz$open_seq
for (i in seq_along(cols))
updateCheckboxInput(session, wiz_input_id("s4_exp", seq_no, i), value=FALSE)
wiz$expected_columns <- character(0)
})
# ── Step 5: Column Rules ────────────────────────────────────────────
# Isolate wiz field reads so accordion doesn't collapse/scroll on every
# regex test result or allowed-value addition.
output$step5_column_rules <- renderUI({
cols <- wiz$col_names # reactive dependency: col list only
if (length(cols) == 0)
return(p(class="text-muted fst-italic", "No columns defined yet. Complete Step 3 first."))
isolate({
seq_no <- wiz$open_seq
types <- if (length(wiz$col_types_inferred) > 0) wiz$col_types_inferred else rep("character", length(cols))
panels <- lapply(seq_along(cols), function(i) {
col <- cols[i]
ctype <- if (!is.null(wiz$col_types_override[[col]])) wiz$col_types_override[[col]] else types[i]
rules <- wiz$column_rules[[col]] %||% list()
has_rule <- any(c(!is.null(rules$allowed_values), !is.null(rules$min_value),
!is.null(rules$max_value), !is.null(rules$pattern)))
standard_fields <- tagList(
if (ctype == "character" || ctype == "unknown") {
existing_vals <- rules$allowed_values %||% character(0)
div(class="mt-1",
tags$label(paste0("Allowed values (QC-09)"), class="form-label form-label-sm"),
selectizeInput(wiz_input_id("s5_allowed", seq_no, i), NULL,
choices = existing_vals,
selected = existing_vals,
multiple = TRUE,
options = list(
create = TRUE,
placeholder = "Type a value, press Enter or Tab to add",
plugins = list("remove_button")
),
width = "100%"
)
)
},
if (ctype == "numeric") {
fluidRow(
column(4, numericInput(wiz_input_id("s5_min", seq_no, i), "Min value (QC-10)",
value=rules$min_value, min=NA, max=NA)),
column(4, numericInput(wiz_input_id("s5_max", seq_no, i), "Max value (QC-10)",
value=rules$max_value, min=NA, max=NA))
)
}
)
adv_fields <- tagList(
div(class="mt-2",
tags$label("Regex pattern (QC-13)", class="form-label form-label-sm"),
div(class="d-flex gap-2",
textInput(wiz_input_id("s5_pattern", seq_no, i), NULL,
value=rules$pattern %||% "", placeholder="e.g. ^[A-Z]{2}$", width="300px"),
# Delegated: ONE observer handles every Test button (the previous
# per-column observeEvent factory re-registered observers on each
# col_names change without destroying old ones — G-04).
tags$button("Test", type="button",
class="btn btn-outline-secondary btn-sm", style="height:38px;",
onclick=sprintf(
"Shiny.setInputValue('s5_test_regex_click', {i:%d, seq:%d, t:Date.now()}, {priority:'event'});",
i, seq_no))
),
uiOutput(wiz_input_id("s5_regex_result", seq_no, i))
),
fluidRow(
column(4, numericInput(wiz_input_id("s5_maxmiss", seq_no, i), "Max missing rate",
value=rules$max_missing_rate, min=0, max=1, step=0.01)),
if (ctype == "numeric") {
column(4, numericInput(wiz_input_id("s5_maxmeanshift", seq_no, i), "Max mean shift (%)",
# Stored as a fraction; the field is a percent and
# merge_column_rule() divides the input by 100, so display *100.
# Keep NULL (empty) when no rule is saved for this column.
value=if (length(rules$max_numeric_mean_shift_pct) &&
!is.na(rules$max_numeric_mean_shift_pct))
round(rules$max_numeric_mean_shift_pct * 100, 2) else NULL,
min=0, max=100, step=1))
}
)
)
bslib::accordion_panel(
title=col,
value=paste0("col_", i),
tagList(
span(class="badge bg-light text-dark border me-2", style="font-size:10px;", ctype),
if (has_rule) span(class="badge bg-success text-white", style="font-size:10px;", "rules set"),
div(class="mt-2", standard_fields),
bslib::accordion(
bslib::accordion_panel("Advanced ▼",
value=paste0("adv_", i), adv_fields
),
open=FALSE
)
)
)
})
bslib::accordion(!!!panels, open=FALSE)
}) # end isolate
})
# Regex test — one delegated observer for every column's Test button. The
# button's onclick carries {i, seq}, so no per-column observers exist to
# accumulate across col_names changes (G-04), and a click from a stale
# wizard session (old seq) writes to an output nothing displays.
observeEvent(input$s5_test_regex_click, {
click <- input$s5_test_regex_click
# Client-settable payload: a missing/non-scalar/non-numeric i or seq would
# make as.integer() return integer(0) and turn the guard below into a
# length-zero `if`, erroring the observer (B-17). Require well-formed
# scalars first.
req(is.list(click), length(click$i) == 1, length(click$seq) == 1)
ii <- suppressWarnings(as.integer(click$i))
seq_no <- suppressWarnings(as.integer(click$seq))
cols <- wiz$col_names
if (is.na(ii) || is.na(seq_no) || ii < 1 || ii > length(cols)) return()
col <- cols[ii]
pattern <- input[[wiz_input_id("s5_pattern", seq_no, ii)]] %||% ""
if (nchar(pattern) == 0) return()
# Test against sample
sample_vals <- if (!is.null(wiz$csv_preview_df)) {
v <- wiz$csv_preview_df[[col]]
v[!is.na(v) & nchar(as.character(v)) > 0]
} else character(0)
result <- tryCatch({
err_msg <- tryCatch({ suppressWarnings(grepl(pattern, "test", perl=TRUE)); NULL },
error=function(e) e$message)
if (!is.null(err_msg)) {
list(type="error", msg=paste("Invalid regex:", err_msg))
} else if (length(sample_vals) == 0) {
list(type="info", msg="No sample data to test against.")
} else {
matches <- grepl(pattern, sample_vals, perl=TRUE)
n_fail <- sum(!matches)
if (n_fail == 0) {
list(type="success", msg=sprintf("Pattern matches all %d non-empty values.", length(sample_vals)))
} else {
fail_examples <- paste(head(sample_vals[!matches], 5), collapse="', '")
list(type="warning", msg=sprintf("Pattern does not match %d value(s): '%s'", n_fail, fail_examples))
}
}
}, error=function(e) list(type="error", msg=e$message))
output[[wiz_input_id("s5_regex_result", seq_no, ii)]] <- renderUI({
cls <- switch(result$type, success="alert-success", warning="alert-warning",
error="alert-danger", info="alert-info", "alert-info")
div(class=paste("alert p-1 mt-1", cls), style="font-size:11px;", result$msg)
})
})
# Collect step 5 inputs
observe({
cols <- wiz$col_names
seq_no <- wiz$open_seq
if (length(cols) == 0) return()
# Bail out until THIS open's step-5 UI has rendered (same G-03 guard as
# the step-4 collector — the id carries the open sequence).
if (is.null(input[[wiz_input_id("s5_maxmiss", seq_no, 1)]])) return()
types <- wiz$col_types_inferred
col_rules <- list()
for (i in seq_along(cols)) {
col <- cols[i]
ctype <- if (!is.null(wiz$col_types_override[[col]])) wiz$col_types_override[[col]]
else if (i <= length(types)) types[i] else "character"
# merge_column_rule() carries forward a previously-saved type-gated rule
# (allowed_values / min / max / mean-shift) when this session re-inferred a
# different type, so its input never rendered -- otherwise Save would
# silently drop a rule the user never touched (B-04). isolate() reads the
# saved rule without making this writer depend on its own output.
rules <- merge_column_rule(
ctype, isolate(wiz$column_rules[[col]]),
allowed_in = input[[wiz_input_id("s5_allowed", seq_no, i)]],
min_in = input[[wiz_input_id("s5_min", seq_no, i)]],
max_in = input[[wiz_input_id("s5_max", seq_no, i)]],
pattern_in = input[[wiz_input_id("s5_pattern", seq_no, i)]],
maxmiss_in = input[[wiz_input_id("s5_maxmiss", seq_no, i)]],
meanshift_in = input[[wiz_input_id("s5_maxmeanshift", seq_no, i)]])
if (length(rules) > 0) col_rules[[col]] <- rules
}
wiz$column_rules <- col_rules
})
# ── Step 7: Custom checks ────────────────────────────────────────────
shinyFiles::shinyFileChoose(input, "wiz_custom_browse",
roots=file_roots, session=session)
observeEvent(input$wiz_custom_browse, {
req(is.list(input$wiz_custom_browse))
p <- shinyFiles::parseFilePaths(file_roots, input$wiz_custom_browse)
if (nrow(p) > 0) {
updateTextInput(session, "wiz_custom_file", value=as.character(p$datapath[1]))
wiz$custom_checks_file <- as.character(p$datapath[1])
}
})
observeEvent(input$wiz_custom_file, { wiz$custom_checks_file <- input$wiz_custom_file %||% "" })
# Debounce the custom-checks path before validating it — validation below
# parses *and sources* the file (to confirm it defines `custom_checks`),
# which executes the user's script. Without debouncing, that source() call
# — and any top-level side effects in the script (package loads, file/
# network I/O, global state changes) — would re-fire on every keystroke,
# including for every transient partial path typed along the way. Mirrors
# the folder_input_r/folder_input_d pattern used for the folder path above.
custom_file_r <- reactive({ input$wiz_custom_file })
custom_file_d <- shiny::debounce(custom_file_r, 600)
output$step7_validation_badge <- renderUI({
path <- custom_file_d() %||% ""
if (nchar(path) == 0) return(NULL)
if (!safe_file_exists(path))
return(div(class="alert alert-danger p-1 mt-1", style="font-size:12px;",
"✗ File not found."))
parse_err <- tryCatch({ parse(file=path); NULL }, error=function(e) e$message)
if (!is.null(parse_err))
return(div(class="alert alert-danger p-1 mt-1", style="font-size:12px;",
paste("✗ R syntax error:", parse_err)))
env <- new.env(parent=baseenv())
src_err <- tryCatch({ source(path, local=env); NULL }, error=function(e) e)
if (!is.null(src_err))
return(div(class="alert alert-danger p-1 mt-1", style="font-size:12px;",
paste("✗ Error sourcing file:", conditionMessage(src_err))))
fn <- tryCatch(get("custom_checks", envir=env), error=function(e) NULL)
if (is.null(fn) || !is.function(fn))
return(div(class="alert alert-danger p-1 mt-1", style="font-size:12px;",
"✗ File must define a function named 'custom_checks'."))
sig <- paste(names(formals(fn)), collapse=", ")
div(class="alert alert-success p-1 mt-1", style="font-size:12px;",
sprintf("✓ Valid — custom_checks(%s)", sig))
})
# ── Step 8: Review and Save ──────────────────────────────────────────
output$step8_summary <- renderUI({
bslib::card(bslib::card_body(
fluidRow(
column(6, tags$dl(
tags$dt("Dataset"), tags$dd(wiz$dataset_name),
tags$dt("Format"), tags$dd(toupper(wiz$format)),
tags$dt("Location"),tags$dd(if(nchar(wiz$folder%||%"")>0) wiz$folder else wiz$current_file)
)),
column(6, tags$dl(
tags$dt("Columns"), tags$dd(sprintf("%d total, %d expected, %d key",
length(wiz$col_names),
length(wiz$expected_columns),
length(wiz$key_columns))),
tags$dt("Column rules"), tags$dd(sprintf("%d configured", length(wiz$column_rules))),
tags$dt("Custom checks"),tags$dd(if(nchar(wiz$custom_checks_file%||%"")>0) basename(wiz$custom_checks_file) else "none")
))
)
))
})
output$yaml_preview <- renderText({
yaml_preview_text(wiz, wiz$extra_keys)
})
observeEvent(input$wizard_save, {
nm <- wiz$dataset_name
cd <- config_dir()
path <- file.path(cd, paste0(nm, ".yml"))
dir.create(cd, showWarnings=FALSE, recursive=TRUE)
# Serialise the clash-check-and-write against concurrent same-machine saves
# (two tabs / two app instances on one config dir). Without this, both pass
# the clash check below and both write, silently clobbering. Released on exit.
lock <- acquire_config_lock(cd, nm)
if (is.null(lock)) {
showModal(modalDialog(
title="Save in progress",
sprintf("Another save for '%s' is already in progress. Wait a moment and try again.", nm),
easyClose=TRUE
))
return()
}
on.exit(unlink(lock, recursive=TRUE), add=TRUE)
# Backstop for G-07: the step-1 validator shows the clash message, but
# nothing stops navigation past it — block the overwrite at save time.
existing <- list_dataset_configs(cd)
clash <- nm %in% existing &&
!(wiz$mode == "edit" && identical(nm, wiz$original_name))
if (clash) {
showModal(modalDialog(
title="Name already in use",
sprintf("A dataset named '%s' already exists. Choose a different name in Step 1.", nm),
easyClose=TRUE
))
return()
}
renamed <- wiz$mode == "edit" && nchar(wiz$original_name) > 0 &&
!identical(nm, wiz$original_name)
tryCatch({
write_config(wiz, wiz$extra_keys, path)
if (renamed) {
# A rename must not leave the old config behind as a zombie sidebar
# entry. Snapshot history stays keyed to the old name by design.
old_path <- file.path(cd, paste0(wiz$original_name, ".yml"))
if (file.exists(old_path)) file.remove(old_path)
showNotification(
sprintf("Renamed '%s' to '%s'. Existing run history remains recorded under the old name.",
wiz$original_name, nm),
type="warning", duration=8)
}
showNotification(sprintf("Saved: %s", path), type="message", duration=4)
register_all_report_paths(cd, gcfg_rv())
rv$wizard_open <- FALSE
rv$active_section <- "datasets"
rv$active_dataset <- nm
rv$dataset_refresh <- Sys.time()
}, error=function(e) {
showModal(modalDialog(
title="Save failed",
paste("Could not write config:", e$message),
easyClose=TRUE
))
})
})
wiz
}
# Helper to collect inputs from various steps
collect_step_inputs <- function(input, wiz, gcfg) {
# Bail if step 6 UI hasn't rendered — prevents wiping config-loaded rule_overrides
# when Next is clicked on steps 1-5 (same guard pattern as step 4/5 collectors).
if (is.null(input$wiz_ro_max_missing)) return()
# Rule overrides from step 6
dr <- gcfg$default_rules %||% list()
overrides <- list()
# Numeric-tolerant equality: numericInput returns a double, but YAML defaults
# may be integer (e.g. min_row_count: 0), and identical(0, 0L) is FALSE —
# which used to write a spurious override for every untouched field.
num_equal <- function(a, b) isTRUE(all.equal(as.numeric(a), as.numeric(b)))
# Returns the input value if it is set and differs from the default, else NULL.
# Assigning NULL to an absent list key is a no-op, so only changed keys persist
# (a pure helper — avoids the `<<-` an accumulating closure would need).
chk_num <- function(input_id, dflt) {
v <- input[[input_id]]
if (!is.null(v) && !is.na(v) && !num_equal(v, dflt)) v else NULL
}
overrides[["max_missing_rate"]] <- chk_num("wiz_ro_max_missing", dr$max_missing_rate %||% 0.05)
overrides[["max_non_numeric_rate"]] <- chk_num("wiz_ro_max_nonnumeric", dr$max_non_numeric_rate %||% 0.01)
overrides[["min_row_count"]] <- chk_num("wiz_ro_min_rows", dr$min_row_count %||% 0)
v <- input$wiz_ro_max_rowchg; dflt <- round((dr$max_row_count_change_pct %||% 0.10)*100,2)
if (!is.null(v) && !is.na(v) && !num_equal(v, dflt)) overrides$max_row_count_change_pct <- v/100
v <- input$wiz_ro_max_meanshift; dflt <- round((dr$max_numeric_mean_shift_pct %||% 0.20)*100,2)
if (!is.null(v) && !is.na(v) && !num_equal(v, dflt)) overrides$max_numeric_mean_shift_pct <- v/100
overrides[["max_missing_rate_change_pp"]] <- chk_num("wiz_ro_max_misschg", dr$max_missing_rate_change_pp %||% 2.0)
overrides[["max_non_numeric_rate_change_pp"]] <- chk_num("wiz_ro_max_nonnumchg", dr$max_non_numeric_rate_change_pp %||% 1.0)
overrides[["type_inference_threshold"]] <- chk_num("wiz_ro_type_inf", dr$type_inference_threshold %||% 0.90)
for (pair in list(
list("flag_new_columns","wiz_ro_flag_new",TRUE),
list("flag_dropped_columns","wiz_ro_flag_drop",TRUE),
list("flag_type_changes","wiz_ro_flag_type",TRUE),
list("flag_column_order_change","wiz_ro_flag_order",TRUE)
)) {
v <- input[[pair[[2]]]]; dflt <- pair[[3]]
if (!is.null(v) && !identical(isTRUE(v), dflt)) overrides[[pair[[1]]]] <- isTRUE(v)
}
wiz$rule_overrides <- overrides
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.