inst/app/R/server_wizard.R

# 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
}

Try the dqcheckrGUI package in your browser

Any scripts or data that you put into this service are public.

dqcheckrGUI documentation built on July 25, 2026, 9:06 a.m.