Nothing
inst/app/server.R
In earthUI: Interactive 'shiny' GUI for the 'earth' Package
function(input, output, session) {
# --- SQLite settings database ---
settings_con <- earthUI:::settings_db_connect_()
session$onSessionEnded(function() {
earthUI:::settings_db_disconnect_(settings_con)
})
# --- Nord theme switching ---
observe({
mode <- input$dark_mode
req(mode)
tryCatch(
session$setCurrentTheme(
if (mode == "dark") nord_dark else nord_light
),
error = function(e) {
message("Theme switch error (non-fatal): ", conditionMessage(e))
}
)
})
# --- Write fitting log to output folder ---
write_fit_log_ <- function(output_folder, lines, file_name) {
tryCatch({
folder <- if (is.null(output_folder) || !nzchar(output_folder)) {
path.expand("~/Downloads")
} else {
output_folder
}
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(file_name %||% "earthui")
log_path <- file.path(folder, paste0(base, "_earth_log_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".txt"))
writeLines(c(paste("earthUI fitting log:", Sys.time()), "", lines), log_path)
}, error = function(e) {
message("earthUI: failed to write log: ", e$message)
})
}
# --- Auto-export earth result for mgcvUI (degree <= 2) ---
auto_export_for_mgcv_ <- function(result, output_folder, file_name) {
tryCatch({
deg <- result$degree %||% 1L
if (deg > 2L) return(invisible(NULL))
folder <- if (is.null(output_folder) || !nzchar(output_folder)) {
path.expand("~/Downloads")
} else {
output_folder
}
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(file_name %||% "earth")
out_path <- file.path(folder, paste0(base, "_earthUI_result_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".rds"))
saveRDS(result, out_path)
message("earthUI: auto-exported result for mgcvUI to ", out_path)
}, error = function(e) {
message("earthUI: auto-export for mgcvUI failed: ", e$message)
})
}
# --- Reactive values ---
rv <- reactiveValues(
data = NULL,
categoricals = NULL,
col_types = NULL,
result = NULL,
file_name = NULL,
sheets = NULL,
file_path = NULL,
file_ext = NULL,
fitting = FALSE,
bg_proc = NULL,
trace_lines = character(0),
user_varmod = "lm", # user's explicit varmod.method choice
wp_weights = NULL, # per-target response weights (numeric vector or NULL)
subset_conditions = list(), # condition rows for subset filter builder
rca_df = NULL, # RCA export data for histogram plots
rca_targets = NULL, # target variable names for RCA plots
sg_recommended = NULL, # recommended comps for sales grid
sg_others = NULL # other comps for sales grid
)
# Track user's explicit varmod.method changes
observeEvent(input$varmod_method, {
# Only record if single target (multi-target forces "none" in the UI)
if (length(input$target) <= 1L) {
rv$user_varmod <- input$varmod_method
}
})
# When target count changes, update the varmod dropdown
observeEvent(input$target, {
if (length(input$target) > 1L) {
updateSelectInput(session, "varmod_method", selected = "none")
} else {
updateSelectInput(session, "varmod_method", selected = rv$user_varmod)
}
})
# --- Locale ---
# Load user's locale defaults from SQLite on startup
locale_defaults <- earthUI:::settings_db_read_(settings_con, "__locale_defaults__")
if (!is.null(locale_defaults) && length(locale_defaults$settings) > 0L) {
ld <- locale_defaults$settings
if (!is.null(ld$locale_country)) updateSelectInput(session, "locale_country", selected = ld$locale_country)
if (!is.null(ld$locale_paper)) updateSelectInput(session, "locale_paper", selected = ld$locale_paper)
if (!is.null(ld$locale_csv_sep)) updateSelectInput(session, "locale_csv_sep", selected = ld$locale_csv_sep)
if (!is.null(ld$locale_dec)) updateSelectInput(session, "locale_dec", selected = ld$locale_dec)
if (!is.null(ld$locale_date)) updateSelectInput(session, "locale_date", selected = ld$locale_date)
message("earthUI: restored locale defaults from SQLite")
}
# Save locale as user default
observeEvent(input$locale_save_default, {
locale_settings <- list(
locale_country = input$locale_country,
locale_paper = input$locale_paper,
locale_csv_sep = input$locale_csv_sep,
locale_dec = input$locale_dec,
locale_date = input$locale_date
)
earthUI:::settings_db_write_(
settings_con, "__locale_defaults__",
settings = jsonlite::toJSON(locale_settings, auto_unbox = TRUE)
)
showNotification("Locale saved as default for all new files.",
type = "message", duration = 4)
})
# When country changes, update override dropdowns to country defaults
observeEvent(input$locale_country, {
country <- input$locale_country %||% "us"
presets <- earthUI:::locale_country_presets_()
preset <- presets[[country]] %||% presets[["us"]]
updateSelectInput(session, "locale_csv_sep", selected = preset$csv_sep)
updateSelectInput(session, "locale_dec", selected = preset$csv_dec)
updateSelectInput(session, "locale_date", selected = preset$date_fmt)
updateSelectInput(session, "locale_paper", selected = preset$paper)
# Determine big_mark from decimal: if dec is "," use country's big_mark
earthUI:::set_locale_(country)
})
# When any override changes, update locale env directly
observe({
csv_sep <- input$locale_csv_sep %||% ","
csv_dec <- input$locale_dec %||% "."
date_fmt <- input$locale_date %||% "mdy"
paper <- input$locale_paper %||% "letter"
# Derive big_mark from decimal mark (they must differ)
country <- input$locale_country %||% "us"
presets <- earthUI:::locale_country_presets_()
preset <- presets[[country]] %||% presets[["us"]]
big_mark <- preset$big_mark
earthUI:::set_locale_(country, csv_sep = csv_sep, csv_dec = csv_dec,
big_mark = big_mark, dec_mark = csv_dec,
date_fmt = date_fmt, paper = paper)
})
# --- Data Import ---
observeEvent(input$file_input, {
req(input$file_input)
message("earthUI: file upload received: ", input$file_input$name)
message("earthUI: datapath = ", input$file_input$datapath)
message("earthUI: file exists = ", file.exists(input$file_input$datapath))
ext <- tolower(tools::file_ext(input$file_input$name))
rv$file_ext <- ext
rv$file_path <- input$file_input$datapath
rv$file_name <- input$file_input$name
# Restore saved settings from SQLite into localStorage
saved <- earthUI:::settings_db_read_(settings_con, rv$file_name)
if (!is.null(saved)) {
session$sendCustomMessage("restore_all_settings", list(
filename = rv$file_name,
settings = saved$settings,
variables = saved$variables,
interactions = saved$interactions
))
message("earthUI: restored settings from SQLite for: ", rv$file_name)
}
if (ext %in% c("xlsx", "xls")) {
rv$sheets <- readxl::excel_sheets(input$file_input$datapath)
} else {
rv$sheets <- NULL
}
tryCatch({
rv$data <- import_data(input$file_input$datapath, sheet = 1,
sep = earthUI:::locale_csv_sep_(),
dec = earthUI:::locale_csv_dec_())
rv$categoricals <- detect_categoricals(rv$data)
rv$col_types <- detect_types(rv$data)
rv$result <- NULL
message("earthUI: import OK, ", nrow(rv$data), " rows, ", ncol(rv$data), " cols")
}, error = function(e) {
message("earthUI: IMPORT ERROR: ", e$message)
showNotification(paste("Import error:", e$message),
type = "error", duration = 15)
})
})
output$sheet_selector <- renderUI({
req(rv$sheets)
selectInput("sheet", "Sheet", choices = rv$sheets, selected = rv$sheets[1])
})
observeEvent(input$sheet, {
req(rv$file_path, input$sheet)
rv$data <- import_data(rv$file_path, sheet = input$sheet,
sep = earthUI:::locale_csv_sep_(),
dec = earthUI:::locale_csv_dec_())
rv$categoricals <- detect_categoricals(rv$data)
rv$col_types <- detect_types(rv$data)
rv$result <- NULL
})
# Update weights dropdown with numeric column names when data loads
observe({
req(rv$data)
num_cols <- names(rv$data)[vapply(rv$data, is.numeric, logical(1))]
choices <- c("NULL (none)" = "null", stats::setNames(num_cols, num_cols))
updateSelectInput(session, "weights_col", choices = choices, selected = "null")
})
output$data_loaded <- reactive(!is.null(rv$data))
outputOptions(output, "data_loaded", suspendWhenHidden = FALSE)
output$model_fitted <- reactive(!is.null(rv$result))
outputOptions(output, "model_fitted", suspendWhenHidden = FALSE)
output$report_heading <- renderUI({
n <- if (identical(input$purpose, "appraisal")) "9" else "7"
h4(paste0(n, ". Download Report"))
})
output$download_heading <- renderUI({
label <- if (identical(input$purpose, "general")) {
"6. Download Estimated Target Variable(s) & Residuals"
} else {
"6. Download Estimated Sale Prices & Residuals"
}
h4(label)
})
# ── Subset Filter Builder Dialog ───────────────────────────────────
observeEvent(input$subset_builder_btn, {
req(rv$data)
rv$subset_conditions <- list(list(col = names(rv$data)[1], op = "==", val = ""))
show_subset_modal_()
})
show_subset_modal_ <- function() {
conds <- rv$subset_conditions
df <- rv$data
col_choices <- names(df)
cond_ui <- lapply(seq_along(conds), function(i) {
cond <- conds[[i]]
col_name <- cond$col
col_vals <- df[[col_name]]
col_class <- class(col_vals)[1]
# Type-aware value input
val_input <- if (inherits(col_vals, "Date")) {
dateInput(paste0("subset_val_", i), NULL,
value = if (nzchar(cond$val)) as.Date(cond$val) else Sys.Date())
} else if (inherits(col_vals, "POSIXct") || inherits(col_vals, "POSIXlt")) {
dateInput(paste0("subset_val_", i), NULL,
value = if (nzchar(cond$val)) as.Date(cond$val) else Sys.Date())
} else if (is.numeric(col_vals)) {
numericInput(paste0("subset_val_", i), NULL,
value = if (nzchar(cond$val)) as.numeric(cond$val) else NA)
} else {
# Character/factor: selectInput with unique values
uvals <- sort(unique(as.character(col_vals[!is.na(col_vals)])))
selectInput(paste0("subset_val_", i), NULL,
choices = uvals,
selected = if (nzchar(cond$val) && cond$val %in% uvals) cond$val else uvals[1])
}
connector <- NULL
if (i > 1) {
connector <- radioButtons(paste0("subset_conn_", i), NULL,
choices = c("AND" = "&", "OR" = "|"),
selected = if (!is.null(cond$conn)) cond$conn else "&",
inline = TRUE)
}
tagList(
if (!is.null(connector)) tags$div(style = "margin: 4px 0;", connector),
fluidRow(
column(4, selectInput(paste0("subset_col_", i), NULL,
choices = col_choices, selected = col_name)),
column(2, selectInput(paste0("subset_op_", i), NULL,
choices = c("<", ">", "<=", ">=", "==", "!="),
selected = cond$op)),
column(4, val_input),
column(2, tags$button("X", class = "btn btn-outline-danger btn-sm",
style = "margin-top: 25px;",
onclick = sprintf("Shiny.setInputValue('subset_remove_idx', %d, {priority: 'event'});", i)))
)
)
})
# Build preview expression
expr_text <- build_subset_expr_()
preview <- ""
if (nzchar(expr_text)) {
n_match <- tryCatch({
mask <- as.list(df)
mask[["TRUE"]] <- TRUE; mask[["FALSE"]] <- FALSE
mask$as.Date <- as.Date; mask$as.POSIXct <- as.POSIXct
rows <- eval(parse(text = expr_text), envir = mask, enclos = emptyenv())
if (is.logical(rows)) sum(rows & !is.na(rows)) else "?"
}, error = function(e) paste("Error:", e$message))
preview <- sprintf("%s of %d rows match", n_match, nrow(df))
}
# JS to detect column dropdown changes
n_conds <- length(conds)
col_change_js <- tags$script(HTML(sprintf("
$(function() {
for (var i = 1; i <= %d; i++) {
(function(idx) {
$('#subset_col_' + idx).off('change.subsetcol').on('change.subsetcol', function() {
Shiny.setInputValue('subset_col_changed',
{idx: idx, col: $(this).val(), t: Date.now()},
{priority: 'event'});
});
})(i);
}
});
", n_conds)))
showModal(modalDialog(
title = "Build Subset Filter",
size = "l",
tags$div(id = "subset_conditions_container", cond_ui),
col_change_js,
actionButton("subset_add_condition", "+ Add condition",
class = "btn-outline-primary btn-sm",
style = "margin-top: 8px;"),
hr(),
tags$div(
tags$strong("Expression: "),
tags$code(if (nzchar(expr_text)) expr_text else "(none)")
),
tags$div(
style = "margin-top: 4px; font-size: 0.9em;",
tags$strong("Preview: "), preview
),
footer = tagList(
actionButton("subset_apply", "Apply", class = "btn-success"),
modalButton("Cancel")
)
))
}
build_subset_expr_ <- function() {
conds <- rv$subset_conditions
if (length(conds) == 0) return("")
df <- rv$data
parts <- character(0)
for (i in seq_along(conds)) {
cond <- conds[[i]]
col_name <- cond$col
op <- cond$op
val <- cond$val
if (!nzchar(val) || is.na(val)) next
col_vals <- df[[col_name]]
# Format value based on column type
if (inherits(col_vals, "POSIXct") || inherits(col_vals, "POSIXlt")) {
val_str <- paste0('as.POSIXct("', val, '")')
} else if (inherits(col_vals, "Date")) {
val_str <- paste0('as.Date("', val, '")')
} else if (is.numeric(col_vals)) {
val_str <- val
} else {
val_str <- paste0('"', gsub('"', '\\\\"', val), '"')
}
expr_part <- paste0(col_name, " ", op, " ", val_str)
if (i > 1 && !is.null(cond$conn)) {
parts <- c(parts, cond$conn, expr_part)
} else {
parts <- c(parts, expr_part)
}
}
paste(parts, collapse = " ")
}
# Helper: read current condition values from modal inputs into rv
sync_subset_inputs_ <- function() {
conds <- rv$subset_conditions
for (i in seq_along(conds)) {
conds[[i]]$col <- input[[paste0("subset_col_", i)]] %||% conds[[i]]$col
conds[[i]]$op <- input[[paste0("subset_op_", i)]] %||% conds[[i]]$op
raw_val <- input[[paste0("subset_val_", i)]]
conds[[i]]$val <- if (is.null(raw_val) || identical(raw_val, "")) "" else as.character(raw_val)
if (i > 1) {
conds[[i]]$conn <- input[[paste0("subset_conn_", i)]] %||% "&"
}
}
rv$subset_conditions <- conds
}
# Add condition
observeEvent(input$subset_add_condition, {
sync_subset_inputs_()
conds <- rv$subset_conditions
conds[[length(conds) + 1]] <- list(col = names(rv$data)[1], op = "==", val = "", conn = "&")
rv$subset_conditions <- conds
removeModal()
show_subset_modal_()
})
# Remove condition buttons — use JS to send which index to remove
observeEvent(input$subset_remove_idx, {
idx <- input$subset_remove_idx
sync_subset_inputs_()
conds <- rv$subset_conditions
if (length(conds) > 1 && idx <= length(conds)) {
conds[[idx]] <- NULL
rv$subset_conditions <- conds
removeModal()
show_subset_modal_()
}
}, ignoreInit = TRUE)
# Column change — use JS to notify which index changed
observeEvent(input$subset_col_changed, {
idx <- input$subset_col_changed$idx
new_col <- input$subset_col_changed$col
conds <- rv$subset_conditions
if (idx <= length(conds) && !identical(conds[[idx]]$col, new_col)) {
sync_subset_inputs_()
conds <- rv$subset_conditions
conds[[idx]]$col <- new_col
conds[[idx]]$val <- ""
rv$subset_conditions <- conds
removeModal()
show_subset_modal_()
}
}, ignoreInit = TRUE)
# Apply subset filter
observeEvent(input$subset_apply, {
sync_subset_inputs_()
expr_text <- build_subset_expr_()
updateTextInput(session, "subset_arg", value = expr_text)
removeModal()
})
# ── Response Weights (wp) Dialog ───────────────────────────────────
# Reset wp when target changes to single
observeEvent(input$target, {
if (length(input$target) <= 1L) {
rv$wp_weights <- NULL
session$sendCustomMessage("update_wp_display",
list(text = "NULL (equal weights)"))
}
})
# Disable wp button when single target
observe({
if (length(input$target) > 1L) {
shinyjs_run <- function(code) {
session$sendCustomMessage("wp_btn_state", list(disabled = FALSE))
}
session$sendCustomMessage("wp_btn_state", list(disabled = FALSE))
} else {
session$sendCustomMessage("wp_btn_state", list(disabled = TRUE))
}
})
observeEvent(input$wp_set_btn, {
targets <- input$target
if (length(targets) <= 1L) {
showNotification("Response weights require multiple target variables.",
type = "warning", duration = 4)
return()
}
# Build one numericInput per target
weight_inputs <- lapply(seq_along(targets), function(i) {
current_val <- if (!is.null(rv$wp_weights) && i <= length(rv$wp_weights)) {
rv$wp_weights[i]
} else {
1
}
numericInput(paste0("wp_val_", i), targets[i],
value = current_val, min = 0, step = 0.1)
})
showModal(modalDialog(
title = "Response Weights (wp)",
tags$p("Set a numeric weight for each target variable.",
style = "font-size: 0.9em; color: #666;"),
weight_inputs,
footer = tagList(
actionButton("wp_apply", "Apply", class = "btn-success"),
modalButton("Cancel")
)
))
})
observeEvent(input$wp_apply, {
targets <- input$target
weights <- vapply(seq_along(targets), function(i) {
val <- input[[paste0("wp_val_", i)]]
if (is.null(val) || is.na(val)) 1 else as.numeric(val)
}, numeric(1))
rv$wp_weights <- weights
display <- paste0(targets, " = ", weights, collapse = ", ")
session$sendCustomMessage("update_wp_display", list(text = display))
# Persist to localStorage
fn <- rv$file_name %||% "default"
wp_data <- stats::setNames(as.list(weights), targets)
session$sendCustomMessage("save_wp_weights", list(filename = fn, weights = wp_data))
removeModal()
})
# Restore wp weights from localStorage when data/target changes
observeEvent(input$wp_weights_restored, {
restored <- input$wp_weights_restored
if (!is.null(restored) && length(restored) > 0) {
targets <- input$target
weights <- vapply(targets, function(t) {
val <- restored[[t]]
if (is.null(val)) 1 else as.numeric(val)
}, numeric(1))
rv$wp_weights <- weights
display <- paste0(targets, " = ", weights, collapse = ", ")
session$sendCustomMessage("update_wp_display", list(text = display))
}
}, ignoreInit = TRUE)
# --- Persist settings to SQLite (debounced from JS) ---
observeEvent(input$eui_save_trigger, {
payload <- input$eui_save_trigger
req(payload$filename)
tryCatch({
earthUI:::settings_db_write_(
settings_con,
filename = payload$filename,
settings = if (!is.null(payload$settings)) payload$settings else "{}",
variables = if (!is.null(payload$variables)) payload$variables else "{}",
interactions = if (!is.null(payload$interactions)) payload$interactions else "{}"
)
}, error = function(e) {
message("earthUI: SQLite save error: ", e$message)
})
}, ignoreInit = TRUE)
# --- Default settings (save/restore via SQLite with key "__defaults__") ---
# Radio: choose mode (last per-file settings vs saved defaults)
observeEvent(input$eui_defaults_action, {
action <- input$eui_defaults_action
message("earthUI: defaults radio changed to: '", action, "'")
req(rv$file_name)
if (action == "use_default") {
defaults <- earthUI:::settings_db_read_(settings_con, "__defaults__")
if (!is.null(defaults)) {
session$sendCustomMessage("restore_all_settings", list(
filename = rv$file_name,
settings = defaults$settings,
variables = defaults$variables,
interactions = defaults$interactions,
apply = TRUE
))
showNotification("Default settings applied.", type = "message",
duration = 3)
} else {
showNotification("No default settings saved yet. Use 'Save current as default' first.",
type = "warning", duration = 4)
updateRadioButtons(session, "eui_defaults_action", selected = "last")
}
} else if (action == "earth_defaults") {
session$sendCustomMessage("apply_earth_defaults", list())
showNotification("Earth default parameters applied.", type = "message",
duration = 3)
updateRadioButtons(session, "eui_defaults_action", selected = "last")
}
# "last" = do nothing, use whatever localStorage has
}, ignoreInit = TRUE)
# Button: save current settings as the default
observeEvent(input$eui_save_defaults, {
req(rv$file_name)
message("earthUI: saving current settings as defaults for: ", rv$file_name)
session$sendCustomMessage("collect_and_save_defaults", list(
filename = rv$file_name
))
showNotification("Current settings saved as defaults.", type = "message",
duration = 3)
})
output$data_preview_info <- renderUI({
req(rv$data)
tags$div(
class = "alert alert-info",
style = "font-size: 0.85em; padding: 8px;",
sprintf("%d rows, %d columns", nrow(rv$data), ncol(rv$data))
)
})
# Shared DataTable callback for click-to-popup on cells
cell_popup_js <- DT::JS("
table.on('click', 'td', function() {
var text = $(this).text();
if (text.length > 0) {
var $popup = $('#eui-cell-popup');
if (!$popup.length) {
$popup = $('<div id=\"eui-cell-popup\">' +
'<div class=\"eui-popup-backdrop\"></div>' +
'<div class=\"eui-popup-content\"><pre></pre>' +
'<button class=\"btn btn-sm btn-secondary eui-popup-close\">Close</button></div></div>');
$('body').append($popup);
$popup.on('click', '.eui-popup-backdrop, .eui-popup-close', function() {
$popup.hide();
});
}
$popup.find('pre').text(text);
$popup.show();
}
});
")
preview_data_ <- function() {
req(rv$data)
df <- rv$data
if (identical(input$purpose, "market") && isTRUE(input$skip_subject_row) && nrow(df) >= 2L) {
df <- df[2:nrow(df), , drop = FALSE]
}
df
}
output$data_preview <- DT::renderDataTable({
df <- preview_data_()
DT::datatable(df,
options = list(pageLength = 10, scrollX = TRUE),
rownames = FALSE,
class = "compact stripe",
callback = cell_popup_js)
})
output$data_preview_tab <- DT::renderDataTable({
df <- preview_data_()
DT::datatable(df,
options = list(pageLength = 10, scrollX = TRUE),
rownames = FALSE,
class = "compact stripe",
callback = cell_popup_js)
})
# --- Appraisal: subject (row 1) and comps (rows 2+) ---
render_subjects_ <- function() {
req(rv$data, input$purpose == "appraisal", nrow(rv$data) >= 1L)
tgt <- input$target
preds <- input$predictors
# Include display_only columns
display_cols <- character(0)
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "display_only") display_cols <- c(display_cols, nm)
}
}
show_cols <- unique(c(display_cols, tgt, preds))
show_cols <- intersect(show_cols, names(rv$data))
subj <- rv$data[1L, show_cols, drop = FALSE]
if (!is.null(tgt) && length(tgt) > 0L) {
for (t in tgt) {
if (t %in% names(subj)) subj[[t]] <- NA
}
}
subj <- cbind(data.frame(row = 1L, check.names = FALSE), subj)
DT::datatable(subj,
options = list(pageLength = 1, scrollX = TRUE, dom = "t"),
rownames = FALSE, class = "compact stripe",
callback = cell_popup_js)
}
render_comps_ <- function() {
req(rv$data, input$purpose == "appraisal", nrow(rv$data) >= 2L)
tgt <- input$target
preds <- input$predictors
display_cols <- character(0)
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "display_only") display_cols <- c(display_cols, nm)
}
}
show_cols <- unique(c(display_cols, tgt, preds))
show_cols <- intersect(show_cols, names(rv$data))
comps <- rv$data[2:nrow(rv$data), show_cols, drop = FALSE]
comps <- cbind(data.frame(row = seq_len(nrow(comps)), check.names = FALSE), comps)
low_rows <- integer(0)
if (!is.null(tgt) && length(tgt) > 0L && tgt[1L] %in% names(comps)) {
col <- comps[[tgt[1L]]]
if (is.numeric(col)) {
low_rows <- which(col <= 100 | is.na(col))
}
}
dt <- DT::datatable(comps,
options = list(pageLength = 10, scrollX = TRUE),
rownames = FALSE, class = "compact stripe",
callback = cell_popup_js)
if (length(low_rows) > 0L) {
dt <- DT::formatStyle(dt, columns = 0, target = "row",
backgroundColor = DT::styleRow(low_rows, "rgba(255,0,0,0.15)"))
}
dt
}
output$data_subjects <- DT::renderDataTable(render_subjects_())
output$data_comps <- DT::renderDataTable(render_comps_())
output$data_subjects_tab <- DT::renderDataTable(render_subjects_())
output$data_comps_tab <- DT::renderDataTable(render_comps_())
# --- Variable Configuration ---
output$target_selector <- renderUI({
req(rv$data)
storage_key <- if (is.null(rv$file_name)) "default" else rv$file_name
# JavaScript: persist target variable + advanced parameters in localStorage
js <- tags$script(HTML(sprintf("
(function() {
var storageKeyRaw = %s;
var storageKey = 'earthUI_settings_' + storageKeyRaw;
var selectIds = ['target', 'weights_col',
'degree', 'pmethod', 'glm_family', 'trace',
'varmod_method'];
var numericIds = ['nprune', 'thresh', 'penalty', 'minspan', 'endspan',
'fast_k', 'nfold_override', 'nk', 'newvar_penalty',
'fast_beta', 'ncross', 'varmod_exponent', 'varmod_conv',
'varmod_clamp', 'varmod_minspan', 'adjust_endspan',
'exhaustive_tol', 'output_folder', 'subset_arg'];
var checkboxIds = ['stratify', 'keepxy', 'scale_y', 'auto_linpreds',
'use_beta_cache', 'force_xtx_prune', 'get_leverages',
'force_weights', 'skip_subject_row'];
var radioIds = ['purpose'];
var dateIds = ['effective_date'];
var allIds = selectIds.concat(numericIds).concat(checkboxIds).concat(radioIds).concat(dateIds);
var saved = null;
try { saved = JSON.parse(localStorage.getItem(storageKey)); } catch(e) {}
function restoreSettings() {
if (!saved) return;
selectIds.forEach(function(id) {
if (saved[id] !== undefined && saved[id] !== null) {
var el = document.getElementById(id);
if (el && el.selectize) {
if (id === 'target') {
// target can be a single value or an array (multi-select)
var vals = Array.isArray(saved[id]) ? saved[id] : [saved[id]];
var valid = vals.filter(function(v) { return el.selectize.options[v]; });
if (valid.length > 0) el.selectize.setValue(valid);
} else {
el.selectize.setValue(saved[id]);
}
}
}
});
numericIds.forEach(function(id) {
if (saved[id] !== undefined) {
var $el = $('#' + id);
if ($el.length) { $el.val(saved[id]).trigger('change'); }
}
});
checkboxIds.forEach(function(id) {
if (saved[id] !== undefined) {
var $el = $('#' + id);
if ($el.length) {
$el.prop('checked', saved[id]);
$el.trigger('change');
}
}
});
radioIds.forEach(function(id) {
if (saved[id] !== undefined) {
$('input[name=' + id + '][value=' + saved[id] + ']').prop('checked', true).trigger('change');
}
});
dateIds.forEach(function(id) {
if (saved[id] !== undefined && saved[id] !== null) {
var $inp = $('#' + id + ' input');
if ($inp.length) {
$inp.val(saved[id]).trigger('change');
} else {
$('#' + id).val(saved[id]).trigger('change');
}
}
});
}
function saveSettings() {
var state = {};
selectIds.forEach(function(id) {
var el = document.getElementById(id);
if (el && el.selectize) { state[id] = el.selectize.getValue(); }
});
numericIds.forEach(function(id) {
state[id] = $('#' + id).val();
});
checkboxIds.forEach(function(id) {
state[id] = $('#' + id).is(':checked');
});
radioIds.forEach(function(id) {
state[id] = $('input[name=' + id + ']:checked').val();
});
dateIds.forEach(function(id) {
var $inp = $('#' + id + ' input');
state[id] = $inp.length ? $inp.val() : $('#' + id).val();
});
try { localStorage.setItem(storageKey, JSON.stringify(state)); } catch(e) {}
}
// Restore after selectize initializes (retry until target AND degree are ready)
// Block saving until restore is complete to prevent defaults overwriting saved values
var restoreComplete = false;
var attempts = 0;
function tryRestore() {
var targetEl = document.getElementById('target');
var degreeEl = document.getElementById('degree');
var targetReady = targetEl && targetEl.selectize && targetEl.selectize.isSetup;
var degreeReady = degreeEl && degreeEl.selectize && degreeEl.selectize.isSetup;
if (targetReady && degreeReady) {
restoreSettings();
// Restore wp weights from localStorage
window.euiCurrentFilename = storageKeyRaw;
setTimeout(function() {
try {
var wpSaved = JSON.parse(localStorage.getItem('earthUI_wp_' + storageKeyRaw));
if (wpSaved && Object.keys(wpSaved).length > 0) {
Shiny.setInputValue('wp_weights_restored', wpSaved, {priority: 'event'});
}
} catch(e) {}
}, 600);
restoreComplete = true;
} else if (attempts < 40) {
attempts++;
setTimeout(tryRestore, 250);
} else {
restoreComplete = true; // give up waiting, allow saves
}
}
tryRestore();
// Save on any tracked input change (only after restore is done)
$(document).off('shiny:inputchanged.euisettings')
.on('shiny:inputchanged.euisettings', function(event) {
if (restoreComplete && allIds.indexOf(event.name) >= 0) {
saveSettings();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(%s);
}
});
})();
", jsonlite::toJSON(storage_key, auto_unbox = TRUE),
jsonlite::toJSON(storage_key, auto_unbox = TRUE))))
tagList(
selectInput("target", "Target (response) variable(s)",
choices = names(rv$data), multiple = TRUE),
js
)
})
output$predictor_hint_text <- renderUI({
hint <- "Type = column data type, Inc = include as predictor, Factor = treat as categorical, Linear = linear-only (no hinges)"
if (input$purpose %in% c("appraisal", "market")) {
hint <- paste0(hint, ", Special = column role (e.g. contract_date)")
}
tags$p(class = "text-muted", style = "font-size: 0.8em; margin-bottom: 5px;", hint)
})
output$variable_table <- renderUI({
req(rv$data, input$target)
candidates <- setdiff(names(rv$data), input$target)
nrows <- nrow(rv$data)
# Storage key for remembering settings
storage_key <- if (is.null(rv$file_name)) "default" else rv$file_name
# Type options for dropdown
type_options <- c("numeric", "integer", "character", "logical",
"factor", "Date", "POSIXct", "unknown")
appraiser <- input$purpose %in% c("appraisal", "market")
# Special column options
special_options <- c("no", "actual_age", "area", "concessions",
"contract_date", "display_only", "dom",
"effective_age", "latitude", "listing_date",
"living_area", "longitude", "lot_size",
"site_dimensions")
# Header row
header_cols <- list(
tags$div(style = "flex: 1; min-width: 100px;", "Variable"),
tags$div(style = "width: 85px; text-align: center;", "Type"),
tags$div(style = "width: 45px; text-align: center;", "Inc?")
)
if (appraiser) {
header_cols <- c(header_cols, list(
tags$div(style = "width: 95px; text-align: center;", "Special")
))
}
header_cols <- c(header_cols, list(
tags$div(style = "width: 55px; text-align: center;", "Factor"),
tags$div(style = "width: 55px; text-align: center;", "Linear"),
tags$div(style = "width: 50px; text-align: right; padding-right: 4px;", "NAs")
))
header <- tags$div(
style = "display: flex; align-items: center; padding: 4px 0; border-bottom: 2px solid #ccc; font-weight: bold; font-size: 0.85em;",
header_cols
)
# Build rows using numeric index for IDs
rows <- lapply(seq_along(candidates), function(i) {
col <- candidates[i]
n_na <- sum(is.na(rv$data[[col]]))
pct_na <- n_na / nrows
na_style <- if (pct_na > 0.3) "color: red;" else ""
# Auto-detected type for this column
detected_type <- if (!is.null(rv$col_types) && col %in% names(rv$col_types)) {
rv$col_types[[col]]
} else {
"unknown"
}
# Build <option> tags with auto-detected type selected
option_tags <- lapply(type_options, function(opt) {
if (opt == detected_type) {
tags$option(value = opt, selected = "selected", opt)
} else {
tags$option(value = opt, opt)
}
})
# Build row cells
row_cells <- list(
tags$div(style = "flex: 1; min-width: 100px; font-size: 0.82em; overflow: hidden; text-overflow: ellipsis; white-space: nowrap;",
title = col, col,
tags$span(id = paste0("eui_special_badge_", i),
style = "font-size: 0.7em; color: #0d6efd; font-style: italic; margin-left: 4px;")),
tags$div(style = "width: 85px; text-align: center;",
tags$select(id = paste0("eui_type_", i),
class = "eui-type-select",
style = "width: 78px; font-size: 0.75em; padding: 1px 2px; border: 1px solid #ccc; border-radius: 3px; background: var(--bs-body-bg, #fff); color: var(--bs-body-color, #333);",
option_tags)),
tags$div(style = "width: 45px; text-align: center;",
tags$input(type = "checkbox", id = paste0("eui_inc_", i),
class = "eui-var-cb"))
)
if (appraiser) {
special_option_tags <- lapply(special_options, function(opt) {
tags$option(value = opt, opt)
})
row_cells <- c(row_cells, list(
tags$div(style = "width: 95px; text-align: center;",
tags$select(id = paste0("eui_special_", i),
class = "eui-special-select",
style = "width: 90px; font-size: 0.75em; padding: 1px 2px; border: 1px solid #ccc; border-radius: 3px; background: var(--bs-body-bg, #fff); color: var(--bs-body-color, #333);",
special_option_tags))
))
}
row_cells <- c(row_cells, list(
tags$div(style = "width: 55px; text-align: center;",
tags$input(type = "checkbox", id = paste0("eui_fac_", i),
class = "eui-var-cb")),
tags$div(style = "width: 55px; text-align: center;",
tags$input(type = "checkbox", id = paste0("eui_lin_", i),
class = "eui-var-cb")),
tags$div(style = paste0("width: 50px; text-align: right; font-size: 0.8em; padding-right: 4px;", na_style),
if (n_na > 0L) as.character(n_na) else "")
))
tags$div(
style = "display: flex; align-items: center; padding: 2px 0; border-bottom: 1px solid #eee;",
row_cells
)
})
# Detected types as JSON for JS (used to reset to defaults)
detected_types_list <- vapply(candidates, function(col) {
if (!is.null(rv$col_types) && col %in% names(rv$col_types)) {
rv$col_types[[col]]
} else {
"unknown"
}
}, character(1L))
detected_types_json <- jsonlite::toJSON(
as.list(stats::setNames(detected_types_list, candidates)),
auto_unbox = TRUE
)
# JavaScript: sync checkboxes + type dropdowns <-> Shiny inputs, with localStorage persistence
col_json <- jsonlite::toJSON(candidates, auto_unbox = FALSE)
n_cols <- length(candidates)
storage_key_json <- jsonlite::toJSON(storage_key, auto_unbox = TRUE)
appraiser_json <- if (appraiser) "true" else "false"
js <- tags$script(HTML(sprintf("
(function() {
var cols = %s;
var n = %d;
var storageKeyRaw = %s;
var storageKey = 'earthUI_vars_' + storageKeyRaw;
var detectedTypes = %s;
var appraiser = %s;
function gatherState() {
var inc = [], fac = [], lin = [];
var types = {};
var specials = {};
for (var i = 1; i <= n; i++) {
var sp = appraiser ? ($('#eui_special_' + i).val() || 'no') : 'no';
if (appraiser) specials[cols[i-1]] = sp;
if ($('#eui_inc_' + i).is(':checked') && sp !== 'display_only') inc.push(cols[i-1]);
if ($('#eui_fac_' + i).is(':checked')) fac.push(cols[i-1]);
if ($('#eui_lin_' + i).is(':checked')) lin.push(cols[i-1]);
types[cols[i-1]] = $('#eui_type_' + i).val();
}
Shiny.setInputValue('predictors', inc.length > 0 ? inc : null);
Shiny.setInputValue('categoricals', fac.length > 0 ? fac : null);
Shiny.setInputValue('linpreds', lin.length > 0 ? lin : null);
Shiny.setInputValue('col_types', types);
if (appraiser) {
Shiny.setInputValue('col_specials', specials);
}
}
function saveState() {
var state = {};
for (var i = 1; i <= n; i++) {
var entry = {
inc: $('#eui_inc_' + i).is(':checked'),
fac: $('#eui_fac_' + i).is(':checked'),
lin: $('#eui_lin_' + i).is(':checked'),
type: $('#eui_type_' + i).val()
};
if (appraiser) {
var sp = $('#eui_special_' + i).val();
if (sp) entry.special = sp;
}
state[cols[i-1]] = entry;
}
try { localStorage.setItem(storageKey, JSON.stringify(state)); } catch(e) {}
}
function restoreState() {
var saved = null;
try { saved = JSON.parse(localStorage.getItem(storageKey)); } catch(e) {}
if (saved) {
for (var i = 1; i <= n; i++) {
var s = saved[cols[i-1]];
if (s) {
$('#eui_inc_' + i).prop('checked', s.inc);
$('#eui_fac_' + i).prop('checked', s.fac);
$('#eui_lin_' + i).prop('checked', s.lin);
if (s.type) {
$('#eui_type_' + i).val(s.type);
}
if (appraiser && s.special) {
$('#eui_special_' + i).val(s.special);
}
}
}
}
}
// Restore saved state, then sync to Shiny
restoreState();
updateBadges();
setTimeout(gatherState, 200);
// On any checkbox change, save and sync
$(document).off('change.euivar').on('change.euivar', '.eui-var-cb', function() {
saveState();
gatherState();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(storageKeyRaw);
});
// On type dropdown change: auto-link Factor, save and sync
$(document).off('change.euitype').on('change.euitype', '.eui-type-select', function() {
var idx = this.id.replace('eui_type_', '');
var val = $(this).val();
if (val === 'character' || val === 'factor') {
$('#eui_fac_' + idx).prop('checked', true);
}
saveState();
gatherState();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(storageKeyRaw);
});
// Update special type badges next to variable names
function updateBadges() {
if (!appraiser) return;
for (var j = 1; j <= n; j++) {
var sp = $('#eui_special_' + j).val() || 'no';
var $badge = $('#eui_special_badge_' + j);
if ($badge.length) {
$badge.text(sp !== 'no' ? '[' + sp + ']' : '');
}
}
}
window.euiUpdateBadges = updateBadges;
// On special dropdown change: enforce single per special type, save and sync
$(document).off('change.euispecial').on('change.euispecial', '.eui-special-select', function() {
var idx = parseInt(this.id.replace('eui_special_', ''));
var val = $(this).val();
if (val !== 'no' && val !== 'display_only') {
// Only one column per special type (except display_only allows multiple)
for (var j = 1; j <= n; j++) {
if (j !== idx && $('#eui_special_' + j).val() === val) {
$('#eui_special_' + j).val('no');
}
}
}
updateBadges();
saveState();
gatherState();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(storageKeyRaw);
});
// Expose detectedTypes for earth defaults reset
window.euiDetectedTypes = detectedTypes;
window.euiCols = cols;
})();
", col_json, n_cols, storage_key_json, detected_types_json, appraiser_json)))
tagList(header, rows, js)
})
# --- Allowed Interaction Matrix ---
output$allowed_matrix_ui <- renderUI({
req(input$predictors)
preds <- input$predictors
if (length(preds) < 2) {
return(p("Need at least 2 predictors for interactions."))
}
n <- length(preds)
# Column headers: empty corner cell + variable names
header_cells <- list(tags$th(style = "padding: 2px;", ""))
for (j in seq_len(n)) {
header_cells <- c(header_cells, list(
tags$th(class = "eui-matrix-varlabel",
`data-var-idx` = j,
style = "padding: 2px 4px; font-size: 0.75em; text-align: center; writing-mode: vertical-lr; transform: rotate(180deg); max-height: 100px; overflow: hidden; cursor: pointer;",
title = preds[j], preds[j])
))
}
header_row <- tags$tr(class = "eui-matrix-header", header_cells)
# Build matrix rows
body_rows <- list()
for (i in seq_len(n)) {
cells <- list(
tags$td(class = "eui-matrix-rowlabel eui-matrix-varlabel",
`data-var-idx` = i,
style = "padding: 2px 4px; font-size: 0.75em; white-space: nowrap; overflow: hidden; text-overflow: ellipsis; max-width: 100px; cursor: pointer;",
title = preds[i], preds[i])
)
for (j in seq_len(n)) {
if (j > i) {
# Upper triangle: checkbox
id <- paste0("allowed_", i, "_", j)
cells <- c(cells, list(
tags$td(style = "text-align: center; padding: 2px;",
tags$input(type = "checkbox", id = id,
class = "eui-interaction-cb", checked = "checked",
style = "margin: 0;"))
))
} else {
# Diagonal and lower triangle: empty
cells <- c(cells, list(
tags$td(style = "padding: 2px;",
if (i == j) "\u00b7" else "")
))
}
}
body_rows <- c(body_rows, list(tags$tr(cells)))
}
# JavaScript to sync checkboxes with Shiny inputs + localStorage persistence
storage_key <- if (is.null(rv$file_name)) "default" else rv$file_name
js <- tags$script(HTML(sprintf("
(function() {
var n = %d;
var storageKey = 'earthUI_interactions_' + %s;
function saveState() {
var state = {};
for (var i = 1; i < n; i++) {
for (var j = i + 1; j <= n; j++) {
state[i + '_' + j] = $('#allowed_' + i + '_' + j).is(':checked');
}
}
try { localStorage.setItem(storageKey, JSON.stringify(state)); } catch(e) {}
}
function restoreState() {
var saved = null;
try { saved = JSON.parse(localStorage.getItem(storageKey)); } catch(e) {}
if (!saved) return;
for (var i = 1; i < n; i++) {
for (var j = i + 1; j <= n; j++) {
var key = i + '_' + j;
if (saved[key] !== undefined) {
$('#allowed_' + i + '_' + j).prop('checked', saved[key]);
}
}
}
}
function syncToShiny() {
for (var i = 1; i < n; i++) {
for (var j = i + 1; j <= n; j++) {
var id = 'allowed_' + i + '_' + j;
Shiny.setInputValue(id, $('#' + id).is(':checked'));
}
}
}
// Restore saved state, then sync
restoreState();
setTimeout(function() {
syncToShiny();
// Update Allow All / Clear All checkboxes
var all = $('.eui-interaction-cb').length;
var checked = $('.eui-interaction-cb:checked').length;
$('#eui_allow_all').prop('checked', checked === all);
$('#eui_clear_all').prop('checked', checked === 0);
}, 200);
// On any interaction checkbox change, save and sync
$(document).off('change.euimatrix').on('change.euimatrix', '.eui-interaction-cb', function() {
saveState();
syncToShiny();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(%s);
});
// Click variable name (row or column header) to toggle all its interactions
$(document).off('click.euivarlabel').on('click.euivarlabel', '.eui-matrix-varlabel', function() {
var k = parseInt($(this).attr('data-var-idx'));
if (isNaN(k)) return;
// Collect all checkboxes involving variable k
var cbs = [];
for (var i = 1; i <= n; i++) {
if (i === k) continue;
var lo = Math.min(i, k), hi = Math.max(i, k);
var $cb = $('#allowed_' + lo + '_' + hi);
if ($cb.length) cbs.push($cb);
}
// Toggle: if all checked, uncheck all; otherwise check all
var allChecked = cbs.every(function($cb) { return $cb.is(':checked'); });
cbs.forEach(function($cb) { $cb.prop('checked', !allChecked); });
// Trigger change to save and sync
if (cbs.length > 0) cbs[0].trigger('change');
});
})();
", n, jsonlite::toJSON(storage_key, auto_unbox = TRUE),
jsonlite::toJSON(storage_key, auto_unbox = TRUE))))
div(
style = "max-height: 300px; overflow: auto; border: 1px solid #ddd; padding: 4px; border-radius: 4px;",
tags$table(style = "border-collapse: collapse;",
tags$thead(header_row),
tags$tbody(body_rows)),
js
)
})
get_allowed_matrix <- reactive({
req(input$predictors)
preds <- input$predictors
mat <- build_allowed_matrix(preds)
if (length(preds) >= 2 && as.integer(input$degree) >= 2) {
n <- length(preds)
for (i in seq_len(n - 1)) {
for (j in (i + 1):n) {
id <- paste0("allowed_", i, "_", j)
val <- input[[id]]
if (!is.null(val) && !isTRUE(val)) {
mat[preds[i], preds[j]] <- FALSE
mat[preds[j], preds[i]] <- FALSE
}
}
}
}
mat
})
# --- Fit Model ---
build_fit_args_ <- function(df = rv$data) {
na_to_null <- function(x) if (is.na(x) || is.null(x)) NULL else x
# Evaluate subset expression (if any) to filter rows
subset_expr <- trimws(input$subset_arg %||% "")
if (nzchar(subset_expr)) {
subset_result <- tryCatch({
expr <- parse(text = subset_expr)
# Only allow column names from the data as variables
mask <- as.list(df)
mask[["TRUE"]] <- TRUE; mask[["FALSE"]] <- FALSE
mask$as.Date <- as.Date; mask$as.POSIXct <- as.POSIXct
rows <- eval(expr, envir = mask, enclos = emptyenv())
if (!is.logical(rows)) stop("Expression must evaluate to TRUE/FALSE")
rows[is.na(rows)] <- FALSE
rows
}, error = function(e) {
showNotification(paste("Subset error:", e$message),
type = "error", duration = 10)
NULL
})
if (!is.null(subset_result)) {
n_before <- nrow(df)
df <- df[subset_result, , drop = FALSE]
message("earthUI: subset filter: ", sum(subset_result), " of ", n_before, " rows selected")
}
}
degree <- as.integer(input$degree)
allowed_func <- NULL
allowed_matrix_arg <- NULL
if (degree >= 2) {
allowed_matrix_arg <- get_allowed_matrix()
allowed_func <- build_allowed_function(allowed_matrix_arg)
}
glm_arg <- NULL
if (input$glm_family != "none") {
glm_arg <- list(family = input$glm_family)
}
# Weights column → numeric vector (or NULL)
weights_arg <- NULL
if (!is.null(input$weights_col) && input$weights_col != "null" &&
input$weights_col %in% names(df)) {
weights_arg <- df[[input$weights_col]]
}
# wp (response weights) — per-target numeric vector from dialog
wp_arg <- rv$wp_weights
# Collect type_map from JS dropdown state
type_map_arg <- input$col_types # named list from gatherState()
list(
df = df,
target = input$target,
predictors = input$predictors,
categoricals = input$categoricals,
linpreds = input$linpreds,
type_map = type_map_arg,
degree = degree,
allowed_func = allowed_func,
allowed_matrix = allowed_matrix_arg,
nfold = na_to_null(input$nfold_override),
nprune = na_to_null(input$nprune),
thresh = na_to_null(input$thresh),
penalty = na_to_null(input$penalty),
minspan = na_to_null(input$minspan),
endspan = na_to_null(input$endspan),
fast.k = na_to_null(input$fast_k),
pmethod = input$pmethod,
glm = glm_arg,
trace = as.numeric(input$trace),
nk = na_to_null(input$nk),
newvar.penalty = na_to_null(input$newvar_penalty),
fast.beta = na_to_null(input$fast_beta),
ncross = na_to_null(input$ncross),
stratify = input$stratify,
varmod.method = if (length(input$target) > 1L) "none" else input$varmod_method,
varmod.exponent = na_to_null(input$varmod_exponent),
varmod.conv = na_to_null(input$varmod_conv),
varmod.clamp = na_to_null(input$varmod_clamp),
varmod.minspan = na_to_null(input$varmod_minspan),
keepxy = input$keepxy,
Scale.y = input$scale_y,
Adjust.endspan = na_to_null(input$adjust_endspan),
Auto.linpreds = input$auto_linpreds,
Force.weights = input$force_weights,
Use.beta.cache = input$use_beta_cache,
Force.xtx.prune = input$force_xtx_prune,
Get.leverages = input$get_leverages,
Exhaustive.tol = na_to_null(input$exhaustive_tol),
wp = wp_arg,
weights = weights_arg
)
}
observeEvent(input$run_model, {
req(rv$data, input$target, input$predictors)
# --- Appraiser: round latitude/longitude to 3 decimal places ---
if (input$purpose %in% c("appraisal", "market") && !is.null(input$col_specials)) {
for (nm in names(input$col_specials)) {
if (input$col_specials[[nm]] %in% c("latitude", "longitude") &&
nm %in% names(rv$data) && is.numeric(rv$data[[nm]])) {
rv$data[[nm]] <- round(rv$data[[nm]], 3L)
}
}
}
# --- Appraiser: add sale_age if contract_date is designated ---
if (input$purpose %in% c("appraisal", "market")) {
if (!("sale_age" %in% names(rv$data) && is.numeric(rv$data[["sale_age"]]))) {
# Find contract_date column
specials <- input$col_specials
contract_col <- NULL
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "contract_date") { contract_col <- nm; break }
}
}
if (is.null(contract_col)) {
showNotification(
"No 'contract_date' column designated — skipping sale_age calculation.",
type = "message", duration = 6
)
} else {
# Parse effective_date
eff_date <- as.POSIXct(as.character(input$effective_date))
# Parse contract date values
contract_vals <- rv$data[[contract_col]]
if (inherits(contract_vals, "POSIXct")) {
contract_posix <- contract_vals
} else if (inherits(contract_vals, "Date")) {
contract_posix <- as.POSIXct(contract_vals)
} else if (is.character(contract_vals)) {
contract_posix <- suppressWarnings(as.POSIXct(contract_vals))
if (all(is.na(contract_posix[!is.na(contract_vals)]))) {
showNotification(
paste0("Cannot parse '", contract_col, "' as dates for sale_age calculation."),
type = "error", duration = 10
)
return()
}
} else if (is.numeric(contract_vals)) {
# Excel serial date number -> Date -> POSIXct
contract_posix <- as.POSIXct(as.Date(contract_vals, origin = "1899-12-30"))
} else {
showNotification(
paste0("Column '", contract_col, "' cannot be interpreted as dates for sale_age."),
type = "error", duration = 10
)
return()
}
# Calculate sale_age in integer days
sale_age <- as.integer(difftime(eff_date, contract_posix, units = "days"))
rv$data[["sale_age"]] <- sale_age
rv$col_types[["sale_age"]] <- "integer"
# Pre-seed sale_age as included in localStorage so it appears checked
session$sendCustomMessage("sale_age_added", list(
filename = rv$file_name
))
showNotification(
paste0("Added 'sale_age' column (", sum(!is.na(sale_age)),
" values, integer days). Click Fit again to include it."),
type = "message", duration = 8
)
return()
}
}
}
# --- Skip subject row for Appraisal / Market Area Analysis ---
skip_first <- FALSE
if (input$purpose == "appraisal") {
skip_first <- TRUE
} else if (input$purpose == "market" && isTRUE(input$skip_subject_row)) {
skip_first <- TRUE
}
if (skip_first && nrow(rv$data) >= 2L) {
fit_data <- rv$data[2:nrow(rv$data), , drop = FALSE]
showNotification(
paste0("Skipping row 1 (subject). Fitting on ", nrow(fit_data), " rows."),
type = "message", duration = 4)
} else {
fit_data <- rv$data
}
fit_args <- build_fit_args_(df = fit_data)
# --- Type validation before fitting ---
if (!is.null(fit_args$type_map)) {
validation <- validate_types(fit_data, fit_args$type_map, fit_args$predictors)
if (length(validation$warnings) > 0L) {
showNotification(
paste("Type warnings:", paste(validation$warnings, collapse = "; ")),
type = "warning", duration = 8
)
}
if (!validation$ok) {
showNotification(
HTML(paste0("<strong>Type errors (fix before fitting):</strong><br>",
paste(validation$errors, collapse = "<br>"))),
type = "error", duration = 15
)
return()
}
if (length(validation$date_columns) > 0L) {
showNotification(
paste("Date columns converted to numeric (days since epoch):",
paste(validation$date_columns, collapse = ", ")),
type = "message", duration = 6
)
}
}
use_async <- requireNamespace("callr", quietly = TRUE)
if (use_async) {
# --- Async path: run earth in background process ---
fit_args$.capture_trace <- FALSE
# Ensure trace >= 1 so the user sees progress in the fitting log
if (is.null(fit_args$trace) || fit_args$trace < 1) {
fit_args$trace <- 1
}
rv$trace_lines <- character(0)
rv$result <- NULL
rv$rca_df <- NULL
rv$rca_targets <- NULL
rv$bg_proc <- callr::r_bg(
function(args) {
cat(sprintf("Dataset: %d obs, %d predictors, degree=%d\n",
nrow(args$df), length(args$predictors), args$degree))
if (!is.null(args$nfold) && args$nfold > 0)
cat(sprintf("Cross-validation: %d folds\n", args$nfold))
cat("Running forward pass...\n")
flush(stdout())
result <- do.call(earthUI::fit_earth, args)
cat(sprintf("Completed in %.1f seconds\n", result$elapsed))
flush(stdout())
result
},
args = list(args = fit_args),
stdout = "|", stderr = "|",
supervise = TRUE,
wd = tempdir()
)
rv$fitting <- TRUE
session$sendCustomMessage("fitting_start", list())
} else {
# --- Sync fallback (no callr) ---
session$sendCustomMessage("fitting_start", list())
withProgress(message = "Fitting Earth model...", value = 0.2, {
tryCatch({
setProgress(0.3, detail = "Running forward pass")
rv$result <- fit_earth(
df = fit_args$df,
target = fit_args$target,
predictors = fit_args$predictors,
categoricals = fit_args$categoricals,
linpreds = fit_args$linpreds,
degree = fit_args$degree,
allowed_func = fit_args$allowed_func,
allowed_matrix = fit_args$allowed_matrix,
nfold = fit_args$nfold,
nprune = fit_args$nprune,
thresh = fit_args$thresh,
penalty = fit_args$penalty,
minspan = fit_args$minspan,
endspan = fit_args$endspan,
fast.k = fit_args$fast.k,
pmethod = fit_args$pmethod,
glm = fit_args$glm,
trace = fit_args$trace,
nk = fit_args$nk,
newvar.penalty = fit_args$newvar.penalty,
fast.beta = fit_args$fast.beta,
ncross = fit_args$ncross,
stratify = fit_args$stratify,
varmod.method = fit_args$varmod.method,
varmod.exponent = fit_args$varmod.exponent,
varmod.conv = fit_args$varmod.conv,
varmod.clamp = fit_args$varmod.clamp,
varmod.minspan = fit_args$varmod.minspan,
keepxy = fit_args$keepxy,
Scale.y = fit_args$Scale.y,
Adjust.endspan = fit_args$Adjust.endspan,
Auto.linpreds = fit_args$Auto.linpreds,
Force.weights = fit_args$Force.weights,
Use.beta.cache = fit_args$Use.beta.cache,
Force.xtx.prune = fit_args$Force.xtx.prune,
Get.leverages = fit_args$Get.leverages,
Exhaustive.tol = fit_args$Exhaustive.tol,
wp = fit_args$wp,
weights = fit_args$weights
)
elapsed <- rv$result$elapsed
setProgress(1, detail = "Done")
session$sendCustomMessage("fitting_done",
list(text = sprintf("Done in %.1fs", elapsed)))
write_fit_log_(input$output_folder, rv$result$trace_output, rv$file_name)
# Auto-export for mgcvUI (degree <= 2)
auto_export_for_mgcv_(rv$result, input$output_folder, rv$file_name)
}, error = function(e) {
session$sendCustomMessage("fitting_done",
list(text = "Error"))
showNotification(paste("Model error:", e$message),
type = "error", duration = 10)
write_fit_log_(input$output_folder, c(paste("ERROR:", e$message)), rv$file_name)
})
})
}
})
# --- Background process polling observer ---
send_trace_lines_ <- function(lines, truncate_at = 0L) {
for (line in lines) {
if (nzchar(trimws(line))) {
display <- if (truncate_at > 0L && nchar(line) > truncate_at) {
paste0(substr(line, 1L, truncate_at), "...")
} else {
line
}
session$sendCustomMessage("trace_line", list(text = display))
}
}
}
observe({
req(rv$fitting)
invalidateLater(300)
isolate({
proc <- rv$bg_proc
if (is.null(proc)) return()
# stdout = earth trace output
new_out <- tryCatch(proc$read_output_lines(), error = function(e) character(0))
# stderr = messages, warnings, errors
new_err <- tryCatch(proc$read_error_lines(), error = function(e) character(0))
if (length(new_out) > 0L) {
rv$trace_lines <- c(rv$trace_lines, new_out)
send_trace_lines_(new_out)
}
if (length(new_err) > 0L) {
rv$trace_lines <- c(rv$trace_lines, new_err)
send_trace_lines_(new_err)
}
# Check if process has finished
if (!proc$is_alive()) {
# Read any remaining output
final_out <- tryCatch(proc$read_output_lines(), error = function(e) character(0))
final_err <- tryCatch(proc$read_error_lines(), error = function(e) character(0))
if (length(final_out) > 0L) {
rv$trace_lines <- c(rv$trace_lines, final_out)
send_trace_lines_(final_out)
}
if (length(final_err) > 0L) {
rv$trace_lines <- c(rv$trace_lines, final_err)
send_trace_lines_(final_err)
}
tryCatch({
result <- proc$get_result()
# Store captured trace lines from polling
result$trace_output <- rv$trace_lines
rv$result <- result
session$sendCustomMessage("fitting_done",
list(text = sprintf("Done in %.1fs", result$elapsed)))
# Write log file on success
write_fit_log_(input$output_folder, rv$trace_lines, rv$file_name)
# Auto-export for mgcvUI (degree <= 2)
auto_export_for_mgcv_(result, input$output_folder, rv$file_name)
}, error = function(e) {
# Extract the real error from callr's wrapper
err_msg <- e$message
if (!is.null(e$parent)) {
err_msg <- e$parent$message
} else {
# Also check stderr for error details
err_lines <- rv$trace_lines[grepl("^Error", rv$trace_lines)]
if (length(err_lines) > 0L) {
err_msg <- sub("^Error *:? *", "", err_lines[length(err_lines)])
}
}
session$sendCustomMessage("fitting_done", list(text = "Error"))
showNotification(paste("Model error:", err_msg),
type = "error", duration = 15)
# Write log file on error
log_lines <- c(rv$trace_lines, paste("ERROR:", err_msg))
write_fit_log_(input$output_folder, log_lines, rv$file_name)
})
rv$fitting <- FALSE
rv$bg_proc <- NULL
}
})
})
# --- Parameter Info Modal ---
observeEvent(input$param_info, {
showModal(modalDialog(
title = "Earth Model Parameters",
size = "l",
easyClose = TRUE,
div(style = "max-height: 70vh; overflow-y: auto; font-size: 0.9em;",
h5("Forward Pass"),
tags$dl(
tags$dt("degree"), tags$dd("Maximum degree of interaction. Default 1 (additive, no interactions)."),
tags$dt("nk"), tags$dd("Maximum number of model terms before pruning (includes intercept). Default is semi-automatically calculated."),
tags$dt("thresh"), tags$dd("Forward stepping threshold (default 0.001). Forward pass terminates if adding a term changes RSq by less than thresh."),
tags$dt("penalty"), tags$dd("GCV penalty per knot. Default is 3 if degree>1, else 2. Values of 0 or -1 have special meaning. Typical range: 2-4."),
tags$dt("minspan"), tags$dd("Minimum observations between knots. Default 0 (auto-calculated). Use 1 with endspan=1 to consider all x values. Negative values specify max knots per predictor (e.g., -3 = three evenly spaced knots)."),
tags$dt("endspan"), tags$dd("Minimum observations before first and after last knot. Default 0 (auto-calculated). Be wary of reducing this, especially for predictions near data limits."),
tags$dt("newvar.penalty"), tags$dd("Penalty for adding a new variable (Friedman's gamma). Default 0. Non-zero values (0.01-0.2) make the model prefer reusing existing variables."),
tags$dt("fast.k"), tags$dd("Max parent terms considered per forward step (Fast MARS). Default 20. Set 0 to disable Fast MARS. Lower = faster, higher = potentially better model."),
tags$dt("fast.beta"), tags$dd("Fast MARS ageing coefficient. Default 1. A value of 0 sometimes gives better results."),
tags$dt("Auto.linpreds"), tags$dd("Default TRUE. If the best knot is at the predictor minimum, add the predictor linearly (no hinge). Only affects predictions outside training data range."),
tags$dt("linpreds"), tags$dd("Predictors that enter linearly (no hinge functions), set via the 'Linear' checkbox in Variable Configuration.")
),
h5("Pruning"),
tags$dl(
tags$dt("pmethod"), tags$dd("Pruning method: backward (default), none, exhaustive, forward, seqrep, cv. Use 'cv' with nfold to select terms by cross-validation."),
tags$dt("nprune"), tags$dd("Maximum terms (including intercept) in pruned model. Default NULL (all terms from forward pass, after pruning).")
),
h5("Cross Validation"),
tags$dl(
tags$dt("nfold"), tags$dd("Number of CV folds. Default 0 (no CV). Auto-set to 10 when degree >= 2. Use trace=0.5 to trace CV."),
tags$dt("ncross"), tags$dd("Number of cross-validations (each has nfold folds). Default 1. Use higher values (e.g., 30) with variance models."),
tags$dt("stratify"), tags$dd("Default TRUE. Stratify CV samples so each fold has approximately equal response distribution.")
),
h5("Variance Model"),
tags$dl(
tags$dt("varmod.method"), tags$dd("none (default), const, lm, rlm, earth, gam, power, power0, x.lm, x.rlm, x.earth, x.gam. Requires nfold and ncross. Use trace=0.3 to trace. See 'Variance models in earth' by Stephen Milborrow."),
tags$dt("varmod.exponent"), tags$dd("Power transform for residual regression. Default 1. Use 0.5 if std dev increases with square root of response."),
tags$dt("varmod.conv"), tags$dd("Convergence criterion (percent) for IRLS in variance model. Default 1. Negative values force that many iterations."),
tags$dt("varmod.clamp"), tags$dd("Minimum estimated std dev = varmod.clamp * mean(sd(residuals)). Default 0.1. Prevents negative or tiny std dev estimates."),
tags$dt("varmod.minspan"), tags$dd("minspan for internal earth call in variance model. Default -3 (three evenly spaced knots per predictor).")
),
h5("GLM"),
tags$dl(
tags$dt("glm family"), tags$dd("Optional GLM family applied to earth basis functions. Choices: none, gaussian, binomial, poisson. Example use: binomial for binary outcomes.")
),
h5("Other"),
tags$dl(
tags$dt("trace"), tags$dd("Trace level: 0=none, 0.3=variance model, 0.5=CV, 1=overview, 2=forward pass, 3=pruning, 4=model mats/pruning details, 5=full details."),
tags$dt("keepxy"), tags$dd("Default FALSE. Set TRUE to retain x, y, subset, weights in the model object. Required for some cv. statistics. Makes CV slower."),
tags$dt("Scale.y"), tags$dd("Default TRUE. Scale response internally (subtract mean, divide by sd). Provides better numeric stability."),
tags$dt("Adjust.endspan"), tags$dd("In interaction terms, endspan is multiplied by this value. Default 2. Reduces overfitting at data boundaries."),
tags$dt("Exhaustive.tol"), tags$dd("Default 1e-10. If reciprocal condition number of bx < this, forces pmethod='backward'. Only applies with pmethod='exhaustive'."),
tags$dt("Use.beta.cache"), tags$dd("Default TRUE. Caches regression coefficients in forward pass for speed (20%+ faster). Uses more memory."),
tags$dt("Force.xtx.prune"), tags$dd("Default FALSE. Force use of X'X-based subset evaluation in pruning (instead of QR-based leaps). Only for advanced use."),
tags$dt("Get.leverages"), tags$dd("Default TRUE (unless >100k cases). Calculate diagonal hat values for linear regression of y on bx. Needed for some diagnostics."),
tags$dt("Force.weights"), tags$dd("Default FALSE. For testing: force weighted code path even without weights.")
)
)
))
})
# --- Results: Summary ---
output$summary_metrics <- renderUI({
req(rv$result)
s <- format_summary(rv$result)
if (isTRUE(s$multi)) {
# Per-response metrics cards
targets <- rv$result$target
resp_cards <- lapply(seq_along(targets), function(i) {
tgt <- targets[i]
tagList(
tags$h6(tgt, style = "margin-top: 10px; font-weight: bold;"),
tags$div(
class = "row", style = "margin-bottom: 10px;",
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("R\u00b2"),
tags$h4(sprintf("%.4f", s$r_squared[i])))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("GRSq"),
tags$h4(sprintf("%.4f", s$grsq[i])))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("CV R\u00b2"),
tags$h4(if (!is.na(s$cv_rsq[i])) sprintf("%.4f", s$cv_rsq[i]) else "N/A"))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("Terms"),
tags$h4(s$n_terms)))
)
)
})
metrics <- tagList(resp_cards)
# CV info (per-response)
if (rv$result$cv_enabled && !all(is.na(s$cv_rsq))) {
cv_lines <- vapply(seq_along(targets), function(i) {
if (!is.na(s$cv_rsq[i])) {
sprintf("%s: CV R\u00b2 = %.4f | Training R\u00b2 = %.4f",
targets[i], s$cv_rsq[i], s$r_squared[i])
} else {
""
}
}, character(1))
cv_lines <- cv_lines[nzchar(cv_lines)]
if (length(cv_lines) > 0L) {
metrics <- tagList(
metrics,
tags$div(
class = "alert alert-info",
style = "font-size: 0.9em;",
HTML(paste(cv_lines, collapse = "<br>"))
)
)
}
}
} else {
# Single-response metrics
metrics <- tagList(
tags$div(
class = "row",
style = "margin-bottom: 15px;",
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("R\u00b2"), tags$h4(sprintf("%.4f", s$r_squared)))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("GRSq"), tags$h4(sprintf("%.4f", s$grsq)))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("CV R\u00b2"), tags$h4(if (!is.na(s$cv_rsq)) sprintf("%.4f", s$cv_rsq) else "N/A"))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("Terms"), tags$h4(s$n_terms)))
)
)
if (rv$result$cv_enabled && !is.na(s$cv_rsq)) {
metrics <- tagList(
metrics,
tags$div(
class = "alert alert-info",
style = "font-size: 0.9em;",
sprintf("Cross-validated R\u00b2: %.4f | Training R\u00b2: %.4f",
s$cv_rsq, s$r_squared),
if (s$r_squared - s$cv_rsq > 0.1) {
tags$span(style = "color: red; font-weight: bold;",
" \u26a0 Possible overfitting detected")
}
)
)
}
}
metrics
})
# --- Results: Model Equation ---
output$model_equation <- renderUI({
req(rv$result)
eq <- format_model_equation(rv$result)
if (inherits(eq, "earthUI_equation_multi")) {
# Show one equation per response with a heading
eq_blocks <- lapply(seq_along(eq$targets), function(i) {
sub_eq <- eq$equations[[i]]
tagList(
tags$h5(eq$targets[i], style = "margin-top: 16px;"),
withMathJax(HTML(sub_eq$latex_inline))
)
})
do.call(tagList, eq_blocks)
} else {
withMathJax(HTML(eq$latex_inline))
}
})
output$summary_table <- DT::renderDataTable({
req(rv$result)
s <- format_summary(rv$result)
dt <- DT::datatable(s$coefficients, options = list(pageLength = 20),
rownames = FALSE, class = "compact stripe")
numeric_cols <- names(s$coefficients)[vapply(s$coefficients, is.numeric, logical(1))]
if (length(numeric_cols) > 0) dt <- DT::formatRound(dt, numeric_cols, digits = 6)
dt
})
# --- Response selector for multivariate models ---
output$response_selector_diag <- renderUI({
req(rv$result)
targets <- rv$result$target
if (length(targets) <= 1L) return(NULL)
choices <- stats::setNames(seq_along(targets), targets)
selectInput("diag_response", "Response variable",
choices = choices, selected = 1L)
})
output$response_selector_contrib <- renderUI({
req(rv$result)
targets <- rv$result$target
if (length(targets) <= 1L) return(NULL)
choices <- stats::setNames(seq_along(targets), targets)
selectInput("contrib_response", "Response variable",
choices = choices, selected = 1L)
})
# --- Results: Variable Importance ---
output$importance_plot <- renderPlot({
req(rv$result)
plot_variable_importance(rv$result)
})
output$importance_table <- DT::renderDataTable({
req(rv$result)
imp_df <- format_variable_importance(rv$result)
dt <- DT::datatable(imp_df, options = list(pageLength = 20),
rownames = FALSE, class = "compact stripe")
numeric_cols <- names(imp_df)[vapply(imp_df, is.numeric, logical(1))]
if (length(numeric_cols) > 0) dt <- DT::formatRound(dt, numeric_cols, digits = 6)
dt
})
# --- Results: Contribution (g-function plots) ---
output$contrib_g_selector <- renderUI({
req(rv$result)
gf <- list_g_functions(rv$result)
if (nrow(gf) == 0L) return(p("No g-functions in model."))
# Build display labels: "1: sq_ft_total" or "6: sq_ft_total x beds [3D]"
display_label <- ifelse(
gf$d >= 2L,
gsub(" ", " \u00d7 ", gf$label),
gf$label
)
labels <- paste0(gf$index, ": ", display_label,
ifelse(gf$d >= 2L, " [3D]", ""))
choices <- stats::setNames(gf$index, labels)
selectInput("contrib_g_index", "Select g-function", choices = choices)
})
output$contrib_plot_container <- renderUI({
req(rv$result, input$contrib_g_index)
gf <- list_g_functions(rv$result)
idx <- as.integer(input$contrib_g_index)
if (idx < 1L || idx > nrow(gf)) return(NULL)
if (gf$d[idx] >= 2L && requireNamespace("plotly", quietly = TRUE)) {
plotly::plotlyOutput("contrib_plot_3d", height = "500px")
} else {
plotOutput("contrib_plot_2d", height = "400px")
}
})
output$contrib_plot_2d <- renderPlot({
req(rv$result, input$contrib_g_index)
ri <- if (length(rv$result$target) > 1L && !is.null(input$contrib_response)) {
as.integer(input$contrib_response)
} else {
NULL
}
tryCatch(
plot_g_function(rv$result, as.integer(input$contrib_g_index),
response_idx = ri),
error = function(e) {
message("earthUI: g-function 2D plot error: ", e$message)
plot.new()
text(0.5, 0.5, paste("Error:", e$message), cex = 1.2)
}
)
})
if (requireNamespace("plotly", quietly = TRUE)) {
output$contrib_plot_3d <- plotly::renderPlotly({
req(rv$result, input$contrib_g_index)
ri <- if (length(rv$result$target) > 1L && !is.null(input$contrib_response)) {
as.integer(input$contrib_response)
} else {
NULL
}
tryCatch(
plot_g_function(rv$result, as.integer(input$contrib_g_index),
response_idx = ri),
error = function(e) {
message("earthUI: g-function 3D plot error: ", e$message)
plotly::plot_ly() |>
plotly::layout(title = paste("Error:", e$message))
}
)
})
}
# --- Results: Correlation Matrix ---
output$correlation_plot_ui <- renderUI({
req(rv$result)
plotOutput("correlation_plot", height = "800px", width = "800px")
})
output$correlation_plot <- renderPlot({
req(rv$result)
tryCatch(
plot_correlation_matrix(rv$result),
error = function(e) {
message("earthUI: correlation plot error: ", e$message)
plot.new()
text(0.5, 0.5, paste("Error:", e$message), cex = 1.2)
}
)
}, res = 120)
# --- Results: Diagnostics ---
output$residuals_plot <- renderPlot({
req(rv$result)
ri <- if (length(rv$result$target) > 1L && !is.null(input$diag_response)) {
as.integer(input$diag_response)
} else {
NULL
}
plot_residuals(rv$result, response_idx = ri)
})
output$qq_plot <- renderPlot({
req(rv$result)
ri <- if (length(rv$result$target) > 1L && !is.null(input$diag_response)) {
as.integer(input$diag_response)
} else {
NULL
}
plot_qq(rv$result, response_idx = ri)
})
output$actual_vs_predicted_plot <- renderPlot({
req(rv$result)
ri <- if (length(rv$result$target) > 1L && !is.null(input$diag_response)) {
as.integer(input$diag_response)
} else {
NULL
}
plot_actual_vs_predicted(rv$result, response_idx = ri)
})
# --- Results: ANOVA ---
output$anova_table <- DT::renderDataTable({
req(rv$result)
anova_df <- format_anova(rv$result)
dt <- DT::datatable(anova_df, options = list(pageLength = 20),
rownames = FALSE, class = "compact stripe")
numeric_cols <- names(anova_df)[vapply(anova_df, is.numeric, logical(1))]
if (length(numeric_cols) > 0) dt <- DT::formatRound(dt, numeric_cols, digits = 6)
dt
})
# --- Results: RCA Adjustment Percentage Histograms ---
output$rca_plots_ui <- renderUI({
req(rv$rca_df, rv$rca_targets)
df <- rv$rca_df
targets <- rv$rca_targets
# Build plot outputs for each target
plot_tags <- list()
for (ti in seq_along(targets)) {
tgt <- targets[ti]
if (ti == 1L) {
pct_cols <- list(
list(col = "residual_pct", label = "Residual Adj %"),
list(col = "net_adj_pct", label = "Net Adj %"),
list(col = "gross_adj_pct", label = "Gross Adj %")
)
} else {
pct_cols <- list(
list(col = paste0(tgt, "_residual_pct"), label = paste0(tgt, " Residual Adj %")),
list(col = paste0(tgt, "_net_adj_pct"), label = paste0(tgt, " Net Adj %")),
list(col = paste0(tgt, "_gross_adj_pct"), label = paste0(tgt, " Gross Adj %"))
)
}
for (pc in pct_cols) {
plot_id <- paste0("rca_hist_", gsub("[^a-zA-Z0-9]", "_", pc$col))
local({
col_name <- pc$col
plot_label <- pc$label
output[[plot_id]] <- renderPlot({
vals <- rv$rca_df[[col_name]]
vals <- vals[!is.na(vals) & is.finite(vals)]
if (length(vals) == 0L) return(NULL)
pct_vals <- vals * 100
avg_val <- mean(pct_vals)
med_val <- stats::median(pct_vals)
sd_val <- stats::sd(pct_vals)
bin_width <- 5
rng <- range(pct_vals)
brks <- seq(floor(rng[1] / bin_width) * bin_width,
ceiling(rng[2] / bin_width) * bin_width,
by = bin_width)
if (length(brks) < 2L) brks <- c(brks[1], brks[1] + bin_width)
hist_data <- graphics::hist(pct_vals, breaks = brks, plot = FALSE)
y_max <- max(hist_data$counts) * 1.25
graphics::par(mar = c(5, 4, 4, 2) + 0.1)
graphics::hist(pct_vals, breaks = brks, col = "#4A90D9", border = "white",
main = plot_label,
xlab = "Percentage (%)", ylab = "Frequency",
las = 1, ylim = c(0, y_max))
graphics::abline(v = avg_val, col = "#E74C3C", lwd = 2, lty = 2)
graphics::abline(v = med_val, col = "#2ECC71", lwd = 2, lty = 2)
graphics::legend("topright",
legend = c(
sprintf("Mean: %.2f%%", avg_val),
sprintf("Median: %.2f%%", med_val),
sprintf("Std Dev: %.2f%%", sd_val)
),
col = c("#E74C3C", "#2ECC71", NA),
lwd = c(2, 2, NA), lty = c(2, 2, NA),
bty = "n", cex = 1.1)
}, res = 120)
})
plot_tags <- c(plot_tags, list(
plotOutput(plot_id, height = "350px"),
tags$br()
))
}
if (ti < length(targets)) {
plot_tags <- c(plot_tags, list(tags$hr()))
}
}
do.call(tagList, plot_tags)
})
# --- Results: Earth Output ---
output$earth_output <- renderPrint({
req(rv$result)
model <- rv$result$model
cat(sprintf("== Timing: %.2f seconds ==\n\n", rv$result$elapsed))
cat("== Model ==\n\n")
print(model)
cat("\n\n== Summary ==\n\n")
print(summary(model))
if (!is.null(model$varmod)) {
cat("\n\n== Variance Model ==\n\n")
print(model$varmod)
}
if (length(rv$result$trace_output) > 0L) {
trace_lines <- rv$result$trace_output
trace_lines <- trace_lines[!grepl("^Removed .* rows with miss", trace_lines)]
trace_lines <- trace_lines[!grepl("^CV fold ", trace_lines)]
if (length(trace_lines) > 0L) {
cat("\n\n== Trace Log ==\n\n")
for (line in trace_lines) {
if (nchar(line) > 25L) {
cat(substr(line, 1L, 25L), "...\n")
} else {
cat(line, "\n")
}
}
}
}
})
# --- Export Report (saves to output folder) ---
observeEvent(input$export_report_btn, {
req(rv$result)
fmt <- input$export_format
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) {
folder <- path.expand("~/Downloads")
}
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(rv$file_name %||% "earth")
out_name <- paste0(base, "_report_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".", fmt)
out_path <- file.path(folder, out_name)
withProgress(message = "Rendering report...", value = 0.3, {
tryCatch({
render_report(rv$result,
output_format = fmt,
output_file = out_path,
paper_size = earthUI:::locale_paper_())
setProgress(1, detail = "Done")
session$sendCustomMessage("download_check",
list(id = "export_report_btn"))
showNotification(
paste0("Report saved to: ", out_path),
type = "message", duration = 8)
message("earthUI: report saved to ", out_path)
}, error = function(e) {
message("earthUI export error: ", e$message)
showNotification(paste("Export error:", e$message),
type = "error", duration = 15)
})
})
})
# --- 8. Generate Sales Grid & Download ---
# Step 1: Button click shows modal with recommended comps
observeEvent(input$sales_grid_btn, {
req(rv$rca_df)
rca <- rv$rca_df
n_total <- nrow(rca)
if (n_total < 2) {
showNotification("Need at least 2 rows (subject + 1 comp).",
type = "error", duration = 8)
return()
}
# Compute gross_adj_pct for all weight > 0 rows (exclude subject row 1)
has_gross_pct <- "gross_adjustments" %in% colnames(rca) &&
"sale_price" %in% colnames(rca)
wt_col <- if ("weight" %in% colnames(rca)) rca[["weight"]] else rep(1, n_total)
# Build comp info table (rows 2..n_total with weight > 0)
comp_info <- data.frame(
row = 2:n_total,
id = if ("id" %in% colnames(rca)) rca[["id"]][2:n_total] else 2:n_total,
address = if ("street_address" %in% colnames(rca)) {
rca[["street_address"]][2:n_total]
} else rep("", n_total - 1),
sale_price = if ("sale_price" %in% colnames(rca)) {
rca[["sale_price"]][2:n_total]
} else rep(NA, n_total - 1),
sale_age = if ("sale_age" %in% colnames(rca)) {
rca[["sale_age"]][2:n_total]
} else rep(NA, n_total - 1),
weight = wt_col[2:n_total],
gross_adj = if ("gross_adjustments" %in% colnames(rca)) {
rca[["gross_adjustments"]][2:n_total]
} else rep(0, n_total - 1),
stringsAsFactors = FALSE
)
# Compute gross_adj_pct
comp_info$gross_adj_pct <- ifelse(
!is.na(comp_info$sale_price) & comp_info$sale_price != 0,
abs(comp_info$gross_adj / comp_info$sale_price),
NA
)
# Filter: weight > 0 only
eligible <- comp_info[!is.na(comp_info$weight) & comp_info$weight > 0, ]
# Sort all eligible by gross_adj_pct ascending
eligible <- eligible[order(eligible$gross_adj_pct, na.last = TRUE), ]
# Recommended: gross_adj_pct < 0.25, then sort by sale_age ascending
recommended <- eligible[!is.na(eligible$gross_adj_pct) &
eligible$gross_adj_pct < 0.25, ]
recommended <- recommended[order(recommended$sale_age, na.last = TRUE), ]
# Cap at 30
if (nrow(recommended) > 30) recommended <- recommended[1:30, ]
# Others not recommended (for "add more" section)
others <- eligible[is.na(eligible$gross_adj_pct) |
eligible$gross_adj_pct >= 0.25, ]
others <- others[order(others$gross_adj_pct, na.last = TRUE), ]
# Store for the confirm handler
rv$sg_recommended <- recommended
rv$sg_others <- others
# Build modal UI
rec_checks <- if (nrow(recommended) > 0) {
lapply(seq_len(nrow(recommended)), function(i) {
r <- recommended[i, ]
lbl <- sprintf("Row %d | %s | SP: $%s | Age: %s | Gross: %.1f%%",
r$row,
substr(as.character(r$address), 1, 30),
formatC(r$sale_price, format = "f", digits = 0,
big.mark = ","),
as.character(r$sale_age),
r$gross_adj_pct * 100)
tags$div(
checkboxInput(paste0("sg_rec_", r$row), lbl, value = TRUE),
style = "margin-bottom: 0px;"
)
})
} else {
tags$p("No comps with gross adjustment < 25% found.",
style = "color: var(--bs-secondary-color);")
}
other_checks <- if (nrow(others) > 0) {
lapply(seq_len(min(nrow(others), 50)), function(i) {
r <- others[i, ]
pct_str <- if (!is.na(r$gross_adj_pct)) {
sprintf("%.1f%%", r$gross_adj_pct * 100)
} else "N/A"
lbl <- sprintf("Row %d | %s | SP: $%s | Age: %s | Gross: %s",
r$row,
substr(as.character(r$address), 1, 30),
formatC(r$sale_price, format = "f", digits = 0,
big.mark = ","),
as.character(r$sale_age),
pct_str)
tags$div(
checkboxInput(paste0("sg_rec_", r$row), lbl, value = FALSE),
style = "margin-bottom: 0px;"
)
})
} else NULL
showModal(modalDialog(
title = "Sales Grid — Select Comparables (max 30)",
size = "l",
tags$div(
style = "max-height: 500px; overflow-y: auto;",
tags$h5(paste0("Recommended Comps (gross adj < 25%, ",
"sorted by sale age) — ",
nrow(recommended), " found")),
rec_checks,
if (!is.null(other_checks)) {
tagList(
hr(),
tags$h5("Additional Comps (gross adj >= 25%)"),
other_checks
)
}
),
footer = tagList(
modalButton("Cancel"),
actionButton("sg_confirm", "Generate Sales Grid",
class = "btn-success")
)
))
})
# Step 2: Confirm button in modal — generate the grid
observeEvent(input$sg_confirm, {
req(rv$rca_df)
removeModal()
# Collect checked rows from both recommended and others
all_candidate_rows <- c(
if (!is.null(rv$sg_recommended) && nrow(rv$sg_recommended) > 0)
rv$sg_recommended$row else integer(0),
if (!is.null(rv$sg_others) && nrow(rv$sg_others) > 0)
rv$sg_others$row[seq_len(min(nrow(rv$sg_others), 50))] else integer(0)
)
comp_rows <- integer(0)
for (r in all_candidate_rows) {
cb_val <- input[[paste0("sg_rec_", r)]]
if (!is.null(cb_val) && isTRUE(cb_val)) {
comp_rows <- c(comp_rows, r)
}
}
if (length(comp_rows) == 0) {
showNotification("No comps selected.", type = "warning", duration = 8)
return()
}
if (length(comp_rows) > 30) {
comp_rows <- comp_rows[1:30]
showNotification("Capped at 30 comps.", type = "warning", duration = 5)
}
# Sort selected comps by gross_adj_pct ascending
rca <- rv$rca_df
sp <- if ("sale_price" %in% colnames(rca)) rca[["sale_price"]][comp_rows] else rep(NA, length(comp_rows))
gross <- if ("gross_adjustments" %in% colnames(rca)) rca[["gross_adjustments"]][comp_rows] else rep(0, length(comp_rows))
gap <- ifelse(!is.na(sp) & sp != 0, abs(gross / sp), NA)
comp_rows <- comp_rows[order(gap, na.last = TRUE)]
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
out_path <- file.path(folder, paste0("SalesGrid_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"))
message("earthUI: Sales grid with ", length(comp_rows),
" comps (rows: ", paste(comp_rows, collapse = ","), ")")
tryCatch({
tmp_adj <- tempfile(fileext = ".xlsx")
writexl::write_xlsx(rv$rca_df, tmp_adj)
grid_script <- system.file("app", "sales_grid.R", package = "earthUI")
if (!nzchar(grid_script)) {
showNotification("Sales grid script not found in package.",
type = "error", duration = 10)
return()
}
source(grid_script, local = TRUE)
# Build specials named list from designations
sg_specials_map <- list()
sg_input <- input$col_specials
if (!is.null(sg_input)) {
for (nm in names(sg_input)) {
sp_type <- sg_input[[nm]]
if (sp_type != "no") sg_specials_map[[sp_type]] <- nm
}
}
n_comp <- length(comp_rows)
n_sheet <- ceiling(n_comp / 3)
withProgress(
message = "Generating Sales Grid",
detail = sprintf("0 of %d comps processed", n_comp),
value = 0, {
generate_sales_grid(
adjusted_file = tmp_adj,
comp_rows = comp_rows,
output_file = out_path,
specials = sg_specials_map,
progress_fn = function(sheet, total_sheets, comps_done, total_comps) {
setProgress(
value = comps_done / total_comps,
detail = sprintf("Sheet %d of %d — %d of %d comps processed",
sheet, total_sheets, comps_done, total_comps))
}
)
})
unlink(tmp_adj)
showNotification(paste0("Sales grid saved to: ", out_path,
" (", length(comp_rows), " comps, ",
ceiling(length(comp_rows) / 3), " sheets)"),
type = "message", duration = 10)
session$sendCustomMessage("download_check",
list(id = "sales_grid_btn"))
}, error = function(e) {
showNotification(paste("Sales grid error:", e$message),
type = "error", duration = 10)
})
})
# --- Export Data (Excel) ---
export_data_filename_ <- function() {
base <- tools::file_path_sans_ext(rv$file_name %||% "data")
paste0(base, "_modified_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx")
}
observeEvent(input$export_data, {
req(rv$data)
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
out_path <- file.path(folder, export_data_filename_())
export_data_content_(out_path, "export_data")
showNotification(paste0("Output saved to: ", out_path),
type = "message", duration = 8)
})
observeEvent(input$export_data_nonadj, {
req(rv$data)
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
out_path <- file.path(folder, export_data_filename_())
export_data_content_(out_path, "export_data_nonadj")
showNotification(paste0("Output saved to: ", out_path),
type = "message", duration = 8)
})
export_data_content_ <- function(file, btn_id = "export_data") {
tryCatch({
req(rv$data)
if (!requireNamespace("writexl", quietly = TRUE)) {
showNotification(
"Package 'writexl' required. Install with: install.packages('writexl')",
type = "error", duration = 10)
return()
}
export_df <- rv$data
# --- Append model columns if a model is fitted ---
if (!is.null(rv$result)) {
model <- rv$result$model
targets <- rv$result$target
eq <- format_model_equation(rv$result)
# Find living_area column from specials
la_col <- NULL
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "living_area" && nm %in% names(export_df)) {
la_col <- nm
break
}
}
}
multi <- length(targets) > 1L
# Align factor levels in export_df with training data so predict() works
# for rows with unseen levels, predictions will be NA
train_df <- rv$result$data
pred_df <- export_df
for (col in names(train_df)) {
if (is.factor(train_df[[col]]) && col %in% names(pred_df)) {
pred_df[[col]] <- factor(pred_df[[col]],
levels = levels(train_df[[col]]))
}
}
pred_mat <- stats::predict(model, newdata = pred_df)
for (ri in seq_along(targets)) {
tgt <- targets[ri]
suffix <- if (multi) paste0("_", ri) else ""
# Get equation groups for this response
if (multi) {
eq_ri <- eq$equations[[ri]]
} else {
eq_ri <- eq
}
groups <- eq_ri$groups
# --- est_<target> from predict() ---
actual <- export_df[[tgt]]
# In appraisal mode, subject (row 1) has no real sale price
if (input$purpose == "appraisal" && nrow(export_df) >= 1L) {
actual[1L] <- NA_real_
}
predicted <- if (multi) as.numeric(pred_mat[, ri]) else as.numeric(pred_mat)
est_col <- paste0("est_", tgt)
export_df[[est_col]] <- round(predicted, 1)
# residual = actual - predicted (from model)
resid_col <- paste0("residual", suffix)
export_df[[resid_col]] <- round(actual - predicted, 1)
# CQA: % of comps with smaller signed residual / 10
# Large positive residual = high CQA (~10), large negative = low CQA (~0)
resid_vals <- export_df[[resid_col]]
n_valid <- sum(!is.na(resid_vals))
cqa_col <- paste0("cqa", suffix)
cqa_vals <- vapply(resid_vals, function(r) {
if (is.na(r)) return(NA_real_)
sum(resid_vals < r, na.rm = TRUE) / n_valid * 10
}, numeric(1))
export_df[[cqa_col]] <- round(cqa_vals, 2)
# residual_sf = residual / living_area
if (!is.null(la_col)) {
la <- export_df[[la_col]]
resid_sf_col <- paste0("residual_sf", suffix)
export_df[[resid_sf_col]] <- round(export_df[[resid_col]] / la, 1)
# CQA_SF: % of comps with smaller signed residual_sf / 10
resid_sf_vals <- export_df[[resid_sf_col]]
n_valid_sf <- sum(!is.na(resid_sf_vals))
cqa_sf_col <- paste0("cqa_sf", suffix)
cqa_sf_vals <- vapply(resid_sf_vals, function(r) {
if (is.na(r)) return(NA_real_)
sum(resid_sf_vals < r, na.rm = TRUE) / n_valid_sf * 10
}, numeric(1))
export_df[[cqa_sf_col]] <- round(cqa_sf_vals, 2)
}
# --- Per-g-function contributions ---
intercept_group <- NULL
contrib_groups <- list()
for (grp in groups) {
if (grp$degree == 0L) {
intercept_group <- grp
} else {
contrib_groups <- c(contrib_groups, list(grp))
}
}
# Basis (intercept) contribution — constant for all rows
basis_val <- if (!is.null(intercept_group)) {
intercept_group$terms[[1]]$coefficient
} else {
0
}
contrib_total <- rep(basis_val, nrow(export_df))
for (grp in contrib_groups) {
col_label <- gsub(" ", "_", grp$label)
col_name <- paste0(col_label, "_contribution", suffix)
contrib <- earthUI:::eval_g_function_(model, grp, pred_df,
response_idx = if (multi) ri else NULL)
export_df[[col_name]] <- round(contrib, 1)
contrib_total <- contrib_total + contrib
}
export_df[[paste0("basis", suffix)]] <- round(basis_val, 1)
# calc_residual = actual - (basis + all contributions)
calc_resid_col <- paste0("calc_residual", suffix)
export_df[[calc_resid_col]] <- round(actual - contrib_total, 1)
}
}
# Sort by residual_sf (or residual) descending for appraisal/market
if (input$purpose %in% c("appraisal", "market") && !is.null(rv$result)) {
has_subject <- (input$purpose == "appraisal") ||
(input$purpose == "market" && isTRUE(input$skip_subject_row))
sort_col <- if ("residual_sf" %in% names(export_df)) "residual_sf" else "residual"
if (sort_col %in% names(export_df)) {
if (has_subject && nrow(export_df) >= 2L) {
comps <- export_df[2:nrow(export_df), , drop = FALSE]
comps <- comps[order(comps[[sort_col]], decreasing = TRUE, na.last = TRUE), , drop = FALSE]
export_df <- rbind(export_df[1L, , drop = FALSE], comps)
} else {
export_df <- export_df[order(export_df[[sort_col]], decreasing = TRUE, na.last = TRUE), , drop = FALSE]
}
}
}
# Move ranking columns to the left: residual_sf, cqa_sf, residual, cqa
rank_cols <- c("residual_sf", "cqa_sf", "residual", "cqa")
rank_cols <- rank_cols[rank_cols %in% names(export_df)]
if (length(rank_cols) > 0L) {
other_cols <- setdiff(names(export_df), rank_cols)
export_df <- export_df[, c(rank_cols, other_cols), drop = FALSE]
}
# Write with openxlsx for cell formatting
wb <- openxlsx::createWorkbook()
openxlsx::addWorksheet(wb, "Data")
openxlsx::writeData(wb, "Data", export_df)
# Apply number formats to specific columns
col_names <- names(export_df)
fmt_map <- list(
residual_sf = "#,##0.00",
cqa_sf = "0.00",
residual = "#,##0",
cqa = "0.00"
)
for (cn in names(fmt_map)) {
ci <- match(cn, col_names)
if (!is.na(ci)) {
openxlsx::addStyle(wb, "Data",
style = openxlsx::createStyle(numFmt = fmt_map[[cn]]),
rows = 2:(nrow(export_df) + 1L), cols = ci,
gridExpand = TRUE, stack = TRUE)
}
}
openxlsx::saveWorkbook(wb, file, overwrite = TRUE)
session$sendCustomMessage("download_check", list(id = btn_id))
}, error = function(e) {
msg <- paste("Download error:", conditionMessage(e))
message(msg) # to R console
showNotification(msg, type = "error", duration = 15)
})
}
# --- RCA Raw Output ---
# Show modal when button is clicked
observeEvent(input$rca_output_btn, {
req(rv$result, input$purpose == "appraisal")
# Check if living_area is designated (for CQA_SF option)
has_la <- FALSE
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "living_area" && nm %in% names(rv$data)) {
has_la <- TRUE
break
}
}
}
cqa_choices <- c("CQA" = "cqa")
if (has_la) cqa_choices <- c(cqa_choices, "CQA per SF" = "cqa_sf")
showModal(modalDialog(
title = "RCA Raw Output — Subject CQA Score",
radioButtons("rca_cqa_type", "Score type:",
choices = cqa_choices, selected = "cqa", inline = TRUE),
numericInput("rca_cqa_value", "CQA score for subject (0.00–9.99):",
value = 5.00, min = 0, max = 9.99, step = 0.01),
footer = tagList(
modalButton("Cancel"),
actionButton("export_rca", "Generate", class = "btn-success")
),
size = "s"
))
})
# RCA download handler
observeEvent(input$export_rca, {
req(rv$data, rv$result, input$purpose == "appraisal", nrow(rv$data) >= 2L)
removeModal()
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(rv$file_name %||% "data")
file <- file.path(folder, paste0(base, "_adjusted_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"))
if (!requireNamespace("writexl", quietly = TRUE)) {
showNotification("Package 'writexl' required.", type = "error", duration = 10)
return()
}
tryCatch({
model <- rv$result$model
targets <- rv$result$target
tgt <- targets[1L]
eq <- format_model_equation(rv$result)
eq_ri <- if (length(targets) > 1L) eq$equations[[1L]] else eq
groups <- eq_ri$groups
multi <- length(targets) > 1L
ri <- 1L
# Find living_area column
la_col <- NULL
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "living_area" && nm %in% names(rv$data)) {
la_col <- nm
break
}
}
}
export_df <- rv$data
# Align factor levels with training data
train_df <- rv$result$data
pred_df <- export_df
for (col in names(train_df)) {
if (is.factor(train_df[[col]]) && col %in% names(pred_df)) {
pred_df[[col]] <- factor(pred_df[[col]],
levels = levels(train_df[[col]]))
}
}
# --- Predict on all rows ---
pred_mat <- stats::predict(model, newdata = pred_df)
predicted <- if (multi) as.numeric(pred_mat[, ri]) else as.numeric(pred_mat)
export_df[[paste0("est_", tgt)]] <- round(predicted, 1)
# Actual sale prices (subject = NA)
actual <- export_df[[tgt]]
actual[1L] <- NA_real_
# Residuals for comps
residuals_val <- actual - predicted
export_df[["residual"]] <- round(residuals_val, 1)
# Per-SF residuals
if (!is.null(la_col)) {
la <- export_df[[la_col]]
export_df[["residual_sf"]] <- round(residuals_val / la, 1)
}
# CQA scores (comps only, subject = NA)
comp_resid <- residuals_val[-1L]
n_comps <- sum(!is.na(comp_resid))
cqa_all <- vapply(residuals_val, function(r) {
if (is.na(r)) return(NA_real_)
sum(comp_resid < r, na.rm = TRUE) / n_comps * 10
}, numeric(1))
export_df[["cqa"]] <- round(cqa_all, 2)
if (!is.null(la_col)) {
resid_sf_vals <- export_df[["residual_sf"]]
comp_resid_sf <- resid_sf_vals[-1L]
n_comps_sf <- sum(!is.na(comp_resid_sf))
cqa_sf_all <- vapply(resid_sf_vals, function(r) {
if (is.na(r)) return(NA_real_)
sum(comp_resid_sf < r, na.rm = TRUE) / n_comps_sf * 10
}, numeric(1))
export_df[["cqa_sf"]] <- round(cqa_sf_all, 2)
}
# --- Step A: Interpolate subject residual from user CQA ---
use_sf <- (input$rca_cqa_type == "cqa_sf" && !is.null(la_col))
user_cqa <- input$rca_cqa_value
if (use_sf) {
comp_cqa_vals <- export_df[["cqa_sf"]][-1L]
comp_resid_for_interp <- export_df[["residual_sf"]][-1L]
} else {
comp_cqa_vals <- export_df[["cqa"]][-1L]
comp_resid_for_interp <- export_df[["residual"]][-1L]
}
# Remove NAs, sort by CQA ascending for interpolation
valid <- !is.na(comp_cqa_vals) & !is.na(comp_resid_for_interp)
cqa_sorted <- comp_cqa_vals[valid]
resid_sorted <- comp_resid_for_interp[valid]
ord <- order(cqa_sorted)
cqa_sorted <- cqa_sorted[ord]
resid_sorted <- resid_sorted[ord]
# Linear interpolation
subject_resid <- stats::approx(cqa_sorted, resid_sorted,
xout = user_cqa, rule = 2)$y
if (use_sf) {
# Convert per-SF residual back to total residual
subject_la <- export_df[[la_col]][1L]
subject_resid_total <- subject_resid * subject_la
} else {
subject_resid_total <- subject_resid
}
subject_est <- predicted[1L] + subject_resid_total
actual[1L] <- subject_est
residuals_val[1L] <- subject_resid_total
export_df[["residual"]][1L] <- round(subject_resid_total, 1)
export_df[[paste0("est_", tgt)]][1L] <- round(predicted[1L], 1)
export_df[["subject_value"]] <- NA_real_
export_df[["subject_value"]][1L] <- round(subject_est, 1)
export_df[["subject_cqa"]] <- NA_real_
export_df[["subject_cqa"]][1L] <- user_cqa
if (use_sf && !is.null(la_col)) {
export_df[["residual_sf"]][1L] <- round(subject_resid, 1)
}
# For weight-0 rows (rows 2+): use subject_value (est + subject residual)
# so the last 4 RCA columns can be computed.
# Sale price is left as-is; subject_value holds the conclusion.
zero_wt <- integer(0)
if (!is.null(input$weights_col) && input$weights_col != "null" &&
input$weights_col %in% names(export_df)) {
wvals <- export_df[[input$weights_col]]
message("earthUI RCA: weight col class=", class(wvals),
", unique vals=", paste(head(sort(unique(wvals)), 10), collapse=","),
", n_zero=", sum(wvals == 0, na.rm = TRUE),
", n_na=", sum(is.na(wvals)))
zero_wt <- which(wvals == 0)
}
if (length(zero_wt) > 0L) {
sv <- predicted[zero_wt] + subject_resid_total
export_df[["subject_value"]][zero_wt] <- round(sv, 1)
actual[zero_wt] <- sv
residuals_val <- actual - predicted
export_df[["residual"]][zero_wt] <- round(residuals_val[zero_wt], 1)
if (!is.null(la_col)) {
la <- export_df[[la_col]]
export_df[["residual_sf"]][zero_wt] <- round(residuals_val[zero_wt] / la[zero_wt], 1)
}
}
# --- Step B: Per-g-function contributions and adjustments ---
intercept_group <- NULL
contrib_groups <- list()
for (grp in groups) {
if (grp$degree == 0L) {
intercept_group <- grp
} else {
contrib_groups <- c(contrib_groups, list(grp))
}
}
basis_val <- if (!is.null(intercept_group)) {
intercept_group$terms[[1]]$coefficient
} else {
0
}
export_df[["basis"]] <- round(basis_val, 1)
# Compute contributions for all rows, then adjustments = subject - comp
adj_sum <- rep(0, nrow(export_df))
gross_sum <- rep(0, nrow(export_df))
contrib_labels <- character(0)
for (grp in contrib_groups) {
col_label <- gsub(" ", "_", grp$label)
contrib_col <- paste0(col_label, "_contribution")
adj_col <- paste0(col_label, "_adjustment")
contrib <- earthUI:::eval_g_function_(model, grp, pred_df,
response_idx = if (multi) ri else NULL)
export_df[[contrib_col]] <- round(contrib, 1)
# Adjustment = subject contribution - comp contribution
subject_contrib <- contrib[1L]
adjustment <- subject_contrib - contrib
export_df[[adj_col]] <- round(adjustment, 1)
adj_sum <- adj_sum + adjustment
gross_sum <- gross_sum + abs(adjustment)
contrib_labels <- c(contrib_labels, col_label)
}
# residual_adjustment = subject residual - comp residual
resid_adj <- subject_resid_total - residuals_val
export_df[["residual_adjustment"]] <- round(resid_adj, 1)
adj_sum <- adj_sum + resid_adj
gross_sum <- gross_sum + abs(resid_adj)
# adjusted_sale_price = sale_price + net_adjustments
# Use 'actual' which has imputed prices for weight-0 rows
export_df[["net_adjustments"]] <- round(adj_sum, 1)
export_df[["gross_adjustments"]] <- round(gross_sum, 1)
# Percentage columns (adjustment / comparable sale price)
export_df[["residual_pct"]] <- round(resid_adj / actual, 4)
export_df[["net_adj_pct"]] <- round(adj_sum / actual, 4)
export_df[["gross_adj_pct"]] <- round(gross_sum / actual, 4)
export_df[["adjusted_sale_price"]] <- round(actual + adj_sum, 1)
# --- Additional targets (e.g., rent) for weight-0 rows only ---
message("earthUI RCA: multi=", multi, ", length(targets)=", length(targets),
", length(zero_wt)=", length(zero_wt),
", weights_col=", input$weights_col %||% "NULL")
if (multi && length(zero_wt) > 0L) {
for (ri2 in 2:length(targets)) {
tgt2 <- targets[ri2]
eq_ri2 <- eq$equations[[ri2]]
groups2 <- eq_ri2$groups
# Column name prefix for this target (e.g., "rent")
tp <- tgt2
# Predictions for this target (all rows)
predicted2 <- as.numeric(pred_mat[, ri2])
export_df[[paste0("est_", tp)]] <- round(predicted2, 1)
# Residuals for comps with weight > 0 (for CQA interpolation)
actual2 <- export_df[[tgt2]]
actual2[1L] <- NA_real_
resid2 <- actual2 - predicted2
# CQA on this target (comps with weight > 0 only)
comp_resid2 <- resid2[-1L]
comp_resid2_valid <- comp_resid2[!is.na(comp_resid2)]
n_comps2 <- length(comp_resid2_valid)
cqa2 <- vapply(resid2, function(r) {
if (is.na(r)) return(NA_real_)
sum(comp_resid2_valid < r, na.rm = TRUE) / n_comps2 * 10
}, numeric(1))
# Interpolate subject residual for this target using same CQA score
if (use_sf) {
resid2_sf <- resid2 / la
comp_cqa2 <- cqa2[-1L]
comp_resid2_interp <- resid2_sf[-1L]
} else {
comp_cqa2 <- cqa2[-1L]
comp_resid2_interp <- resid2[-1L]
}
valid2 <- !is.na(comp_cqa2) & !is.na(comp_resid2_interp)
cqa2_sorted <- comp_cqa2[valid2]
resid2_sorted <- comp_resid2_interp[valid2]
ord2 <- order(cqa2_sorted)
cqa2_sorted <- cqa2_sorted[ord2]
resid2_sorted <- resid2_sorted[ord2]
subj_resid2 <- stats::approx(cqa2_sorted, resid2_sorted,
xout = user_cqa, rule = 2)$y
if (use_sf) {
subj_resid2_total <- subj_resid2 * export_df[[la_col]][1L]
} else {
subj_resid2_total <- subj_resid2
}
# Subject value for this target
subj_est2 <- predicted2[1L] + subj_resid2_total
sv_col <- paste0("subject_", tp, "_value")
export_df[[sv_col]] <- NA_real_
export_df[[sv_col]][1L] <- round(subj_est2, 1)
# Weight-0 rows: impute actual from est + subject residual
sv2 <- predicted2[zero_wt] + subj_resid2_total
export_df[[sv_col]][zero_wt] <- round(sv2, 1)
actual2[1L] <- subj_est2
actual2[zero_wt] <- sv2
resid2 <- actual2 - predicted2
export_df[[paste0(tp, "_residual")]] <- round(resid2, 1)
# Per-g-function contributions and adjustments for this target
intercept2 <- NULL
contrib_groups2 <- list()
for (grp in groups2) {
if (grp$degree == 0L) {
intercept2 <- grp
} else {
contrib_groups2 <- c(contrib_groups2, list(grp))
}
}
basis2 <- if (!is.null(intercept2)) intercept2$terms[[1]]$coefficient else 0
export_df[[paste0(tp, "_basis")]] <- round(basis2, 1)
adj_sum2 <- rep(0, nrow(export_df))
gross_sum2 <- rep(0, nrow(export_df))
for (grp in contrib_groups2) {
col_label <- gsub(" ", "_", grp$label)
contrib_col2 <- paste0(tp, "_", col_label, "_contribution")
adj_col2 <- paste0(tp, "_", col_label, "_adjustment")
contrib2 <- earthUI:::eval_g_function_(model, grp, pred_df,
response_idx = ri2)
export_df[[contrib_col2]] <- round(contrib2, 1)
subj_contrib2 <- contrib2[1L]
adj2 <- subj_contrib2 - contrib2
export_df[[adj_col2]] <- round(adj2, 1)
adj_sum2 <- adj_sum2 + adj2
gross_sum2 <- gross_sum2 + abs(adj2)
}
resid_adj2 <- subj_resid2_total - resid2
export_df[[paste0(tp, "_residual_adjustment")]] <- round(resid_adj2, 1)
adj_sum2 <- adj_sum2 + resid_adj2
gross_sum2 <- gross_sum2 + abs(resid_adj2)
export_df[[paste0(tp, "_net_adjustments")]] <- round(adj_sum2, 1)
export_df[[paste0(tp, "_gross_adjustments")]] <- round(gross_sum2, 1)
# Percentage columns for additional targets
export_df[[paste0(tp, "_residual_pct")]] <- round(resid_adj2 / actual2, 4)
export_df[[paste0(tp, "_net_adj_pct")]] <- round(adj_sum2 / actual2, 4)
export_df[[paste0(tp, "_gross_adj_pct")]] <- round(gross_sum2 / actual2, 4)
export_df[[paste0("adjusted_", tp)]] <- round(actual2 + adj_sum2, 1)
}
}
writexl::write_xlsx(export_df, file)
rv$rca_df <- export_df
rv$rca_targets <- targets
session$sendCustomMessage("download_check", list(id = "rca_output_btn"))
showNotification(paste0("RCA output saved to: ", file),
type = "message", duration = 8)
}, error = function(e) {
msg <- paste("RCA export error:", conditionMessage(e))
message(msg)
showNotification(msg, type = "error", duration = 15)
})
})
}
Try the earthUI package in your browser
Any scripts or data that you put into this service are public.
earthUI documentation built on March 26, 2026, 1:07 a.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.
function(input, output, session) {
# --- SQLite settings database ---
settings_con <- earthUI:::settings_db_connect_()
session$onSessionEnded(function() {
earthUI:::settings_db_disconnect_(settings_con)
})
# --- Nord theme switching ---
observe({
mode <- input$dark_mode
req(mode)
tryCatch(
session$setCurrentTheme(
if (mode == "dark") nord_dark else nord_light
),
error = function(e) {
message("Theme switch error (non-fatal): ", conditionMessage(e))
}
)
})
# --- Write fitting log to output folder ---
write_fit_log_ <- function(output_folder, lines, file_name) {
tryCatch({
folder <- if (is.null(output_folder) || !nzchar(output_folder)) {
path.expand("~/Downloads")
} else {
output_folder
}
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(file_name %||% "earthui")
log_path <- file.path(folder, paste0(base, "_earth_log_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".txt"))
writeLines(c(paste("earthUI fitting log:", Sys.time()), "", lines), log_path)
}, error = function(e) {
message("earthUI: failed to write log: ", e$message)
})
}
# --- Auto-export earth result for mgcvUI (degree <= 2) ---
auto_export_for_mgcv_ <- function(result, output_folder, file_name) {
tryCatch({
deg <- result$degree %||% 1L
if (deg > 2L) return(invisible(NULL))
folder <- if (is.null(output_folder) || !nzchar(output_folder)) {
path.expand("~/Downloads")
} else {
output_folder
}
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(file_name %||% "earth")
out_path <- file.path(folder, paste0(base, "_earthUI_result_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".rds"))
saveRDS(result, out_path)
message("earthUI: auto-exported result for mgcvUI to ", out_path)
}, error = function(e) {
message("earthUI: auto-export for mgcvUI failed: ", e$message)
})
}
# --- Reactive values ---
rv <- reactiveValues(
data = NULL,
categoricals = NULL,
col_types = NULL,
result = NULL,
file_name = NULL,
sheets = NULL,
file_path = NULL,
file_ext = NULL,
fitting = FALSE,
bg_proc = NULL,
trace_lines = character(0),
user_varmod = "lm", # user's explicit varmod.method choice
wp_weights = NULL, # per-target response weights (numeric vector or NULL)
subset_conditions = list(), # condition rows for subset filter builder
rca_df = NULL, # RCA export data for histogram plots
rca_targets = NULL, # target variable names for RCA plots
sg_recommended = NULL, # recommended comps for sales grid
sg_others = NULL # other comps for sales grid
)
# Track user's explicit varmod.method changes
observeEvent(input$varmod_method, {
# Only record if single target (multi-target forces "none" in the UI)
if (length(input$target) <= 1L) {
rv$user_varmod <- input$varmod_method
}
})
# When target count changes, update the varmod dropdown
observeEvent(input$target, {
if (length(input$target) > 1L) {
updateSelectInput(session, "varmod_method", selected = "none")
} else {
updateSelectInput(session, "varmod_method", selected = rv$user_varmod)
}
})
# --- Locale ---
# Load user's locale defaults from SQLite on startup
locale_defaults <- earthUI:::settings_db_read_(settings_con, "__locale_defaults__")
if (!is.null(locale_defaults) && length(locale_defaults$settings) > 0L) {
ld <- locale_defaults$settings
if (!is.null(ld$locale_country)) updateSelectInput(session, "locale_country", selected = ld$locale_country)
if (!is.null(ld$locale_paper)) updateSelectInput(session, "locale_paper", selected = ld$locale_paper)
if (!is.null(ld$locale_csv_sep)) updateSelectInput(session, "locale_csv_sep", selected = ld$locale_csv_sep)
if (!is.null(ld$locale_dec)) updateSelectInput(session, "locale_dec", selected = ld$locale_dec)
if (!is.null(ld$locale_date)) updateSelectInput(session, "locale_date", selected = ld$locale_date)
message("earthUI: restored locale defaults from SQLite")
}
# Save locale as user default
observeEvent(input$locale_save_default, {
locale_settings <- list(
locale_country = input$locale_country,
locale_paper = input$locale_paper,
locale_csv_sep = input$locale_csv_sep,
locale_dec = input$locale_dec,
locale_date = input$locale_date
)
earthUI:::settings_db_write_(
settings_con, "__locale_defaults__",
settings = jsonlite::toJSON(locale_settings, auto_unbox = TRUE)
)
showNotification("Locale saved as default for all new files.",
type = "message", duration = 4)
})
# When country changes, update override dropdowns to country defaults
observeEvent(input$locale_country, {
country <- input$locale_country %||% "us"
presets <- earthUI:::locale_country_presets_()
preset <- presets[[country]] %||% presets[["us"]]
updateSelectInput(session, "locale_csv_sep", selected = preset$csv_sep)
updateSelectInput(session, "locale_dec", selected = preset$csv_dec)
updateSelectInput(session, "locale_date", selected = preset$date_fmt)
updateSelectInput(session, "locale_paper", selected = preset$paper)
# Determine big_mark from decimal: if dec is "," use country's big_mark
earthUI:::set_locale_(country)
})
# When any override changes, update locale env directly
observe({
csv_sep <- input$locale_csv_sep %||% ","
csv_dec <- input$locale_dec %||% "."
date_fmt <- input$locale_date %||% "mdy"
paper <- input$locale_paper %||% "letter"
# Derive big_mark from decimal mark (they must differ)
country <- input$locale_country %||% "us"
presets <- earthUI:::locale_country_presets_()
preset <- presets[[country]] %||% presets[["us"]]
big_mark <- preset$big_mark
earthUI:::set_locale_(country, csv_sep = csv_sep, csv_dec = csv_dec,
big_mark = big_mark, dec_mark = csv_dec,
date_fmt = date_fmt, paper = paper)
})
# --- Data Import ---
observeEvent(input$file_input, {
req(input$file_input)
message("earthUI: file upload received: ", input$file_input$name)
message("earthUI: datapath = ", input$file_input$datapath)
message("earthUI: file exists = ", file.exists(input$file_input$datapath))
ext <- tolower(tools::file_ext(input$file_input$name))
rv$file_ext <- ext
rv$file_path <- input$file_input$datapath
rv$file_name <- input$file_input$name
# Restore saved settings from SQLite into localStorage
saved <- earthUI:::settings_db_read_(settings_con, rv$file_name)
if (!is.null(saved)) {
session$sendCustomMessage("restore_all_settings", list(
filename = rv$file_name,
settings = saved$settings,
variables = saved$variables,
interactions = saved$interactions
))
message("earthUI: restored settings from SQLite for: ", rv$file_name)
}
if (ext %in% c("xlsx", "xls")) {
rv$sheets <- readxl::excel_sheets(input$file_input$datapath)
} else {
rv$sheets <- NULL
}
tryCatch({
rv$data <- import_data(input$file_input$datapath, sheet = 1,
sep = earthUI:::locale_csv_sep_(),
dec = earthUI:::locale_csv_dec_())
rv$categoricals <- detect_categoricals(rv$data)
rv$col_types <- detect_types(rv$data)
rv$result <- NULL
message("earthUI: import OK, ", nrow(rv$data), " rows, ", ncol(rv$data), " cols")
}, error = function(e) {
message("earthUI: IMPORT ERROR: ", e$message)
showNotification(paste("Import error:", e$message),
type = "error", duration = 15)
})
})
output$sheet_selector <- renderUI({
req(rv$sheets)
selectInput("sheet", "Sheet", choices = rv$sheets, selected = rv$sheets[1])
})
observeEvent(input$sheet, {
req(rv$file_path, input$sheet)
rv$data <- import_data(rv$file_path, sheet = input$sheet,
sep = earthUI:::locale_csv_sep_(),
dec = earthUI:::locale_csv_dec_())
rv$categoricals <- detect_categoricals(rv$data)
rv$col_types <- detect_types(rv$data)
rv$result <- NULL
})
# Update weights dropdown with numeric column names when data loads
observe({
req(rv$data)
num_cols <- names(rv$data)[vapply(rv$data, is.numeric, logical(1))]
choices <- c("NULL (none)" = "null", stats::setNames(num_cols, num_cols))
updateSelectInput(session, "weights_col", choices = choices, selected = "null")
})
output$data_loaded <- reactive(!is.null(rv$data))
outputOptions(output, "data_loaded", suspendWhenHidden = FALSE)
output$model_fitted <- reactive(!is.null(rv$result))
outputOptions(output, "model_fitted", suspendWhenHidden = FALSE)
output$report_heading <- renderUI({
n <- if (identical(input$purpose, "appraisal")) "9" else "7"
h4(paste0(n, ". Download Report"))
})
output$download_heading <- renderUI({
label <- if (identical(input$purpose, "general")) {
"6. Download Estimated Target Variable(s) & Residuals"
} else {
"6. Download Estimated Sale Prices & Residuals"
}
h4(label)
})
# ── Subset Filter Builder Dialog ───────────────────────────────────
observeEvent(input$subset_builder_btn, {
req(rv$data)
rv$subset_conditions <- list(list(col = names(rv$data)[1], op = "==", val = ""))
show_subset_modal_()
})
show_subset_modal_ <- function() {
conds <- rv$subset_conditions
df <- rv$data
col_choices <- names(df)
cond_ui <- lapply(seq_along(conds), function(i) {
cond <- conds[[i]]
col_name <- cond$col
col_vals <- df[[col_name]]
col_class <- class(col_vals)[1]
# Type-aware value input
val_input <- if (inherits(col_vals, "Date")) {
dateInput(paste0("subset_val_", i), NULL,
value = if (nzchar(cond$val)) as.Date(cond$val) else Sys.Date())
} else if (inherits(col_vals, "POSIXct") || inherits(col_vals, "POSIXlt")) {
dateInput(paste0("subset_val_", i), NULL,
value = if (nzchar(cond$val)) as.Date(cond$val) else Sys.Date())
} else if (is.numeric(col_vals)) {
numericInput(paste0("subset_val_", i), NULL,
value = if (nzchar(cond$val)) as.numeric(cond$val) else NA)
} else {
# Character/factor: selectInput with unique values
uvals <- sort(unique(as.character(col_vals[!is.na(col_vals)])))
selectInput(paste0("subset_val_", i), NULL,
choices = uvals,
selected = if (nzchar(cond$val) && cond$val %in% uvals) cond$val else uvals[1])
}
connector <- NULL
if (i > 1) {
connector <- radioButtons(paste0("subset_conn_", i), NULL,
choices = c("AND" = "&", "OR" = "|"),
selected = if (!is.null(cond$conn)) cond$conn else "&",
inline = TRUE)
}
tagList(
if (!is.null(connector)) tags$div(style = "margin: 4px 0;", connector),
fluidRow(
column(4, selectInput(paste0("subset_col_", i), NULL,
choices = col_choices, selected = col_name)),
column(2, selectInput(paste0("subset_op_", i), NULL,
choices = c("<", ">", "<=", ">=", "==", "!="),
selected = cond$op)),
column(4, val_input),
column(2, tags$button("X", class = "btn btn-outline-danger btn-sm",
style = "margin-top: 25px;",
onclick = sprintf("Shiny.setInputValue('subset_remove_idx', %d, {priority: 'event'});", i)))
)
)
})
# Build preview expression
expr_text <- build_subset_expr_()
preview <- ""
if (nzchar(expr_text)) {
n_match <- tryCatch({
mask <- as.list(df)
mask[["TRUE"]] <- TRUE; mask[["FALSE"]] <- FALSE
mask$as.Date <- as.Date; mask$as.POSIXct <- as.POSIXct
rows <- eval(parse(text = expr_text), envir = mask, enclos = emptyenv())
if (is.logical(rows)) sum(rows & !is.na(rows)) else "?"
}, error = function(e) paste("Error:", e$message))
preview <- sprintf("%s of %d rows match", n_match, nrow(df))
}
# JS to detect column dropdown changes
n_conds <- length(conds)
col_change_js <- tags$script(HTML(sprintf("
$(function() {
for (var i = 1; i <= %d; i++) {
(function(idx) {
$('#subset_col_' + idx).off('change.subsetcol').on('change.subsetcol', function() {
Shiny.setInputValue('subset_col_changed',
{idx: idx, col: $(this).val(), t: Date.now()},
{priority: 'event'});
});
})(i);
}
});
", n_conds)))
showModal(modalDialog(
title = "Build Subset Filter",
size = "l",
tags$div(id = "subset_conditions_container", cond_ui),
col_change_js,
actionButton("subset_add_condition", "+ Add condition",
class = "btn-outline-primary btn-sm",
style = "margin-top: 8px;"),
hr(),
tags$div(
tags$strong("Expression: "),
tags$code(if (nzchar(expr_text)) expr_text else "(none)")
),
tags$div(
style = "margin-top: 4px; font-size: 0.9em;",
tags$strong("Preview: "), preview
),
footer = tagList(
actionButton("subset_apply", "Apply", class = "btn-success"),
modalButton("Cancel")
)
))
}
build_subset_expr_ <- function() {
conds <- rv$subset_conditions
if (length(conds) == 0) return("")
df <- rv$data
parts <- character(0)
for (i in seq_along(conds)) {
cond <- conds[[i]]
col_name <- cond$col
op <- cond$op
val <- cond$val
if (!nzchar(val) || is.na(val)) next
col_vals <- df[[col_name]]
# Format value based on column type
if (inherits(col_vals, "POSIXct") || inherits(col_vals, "POSIXlt")) {
val_str <- paste0('as.POSIXct("', val, '")')
} else if (inherits(col_vals, "Date")) {
val_str <- paste0('as.Date("', val, '")')
} else if (is.numeric(col_vals)) {
val_str <- val
} else {
val_str <- paste0('"', gsub('"', '\\\\"', val), '"')
}
expr_part <- paste0(col_name, " ", op, " ", val_str)
if (i > 1 && !is.null(cond$conn)) {
parts <- c(parts, cond$conn, expr_part)
} else {
parts <- c(parts, expr_part)
}
}
paste(parts, collapse = " ")
}
# Helper: read current condition values from modal inputs into rv
sync_subset_inputs_ <- function() {
conds <- rv$subset_conditions
for (i in seq_along(conds)) {
conds[[i]]$col <- input[[paste0("subset_col_", i)]] %||% conds[[i]]$col
conds[[i]]$op <- input[[paste0("subset_op_", i)]] %||% conds[[i]]$op
raw_val <- input[[paste0("subset_val_", i)]]
conds[[i]]$val <- if (is.null(raw_val) || identical(raw_val, "")) "" else as.character(raw_val)
if (i > 1) {
conds[[i]]$conn <- input[[paste0("subset_conn_", i)]] %||% "&"
}
}
rv$subset_conditions <- conds
}
# Add condition
observeEvent(input$subset_add_condition, {
sync_subset_inputs_()
conds <- rv$subset_conditions
conds[[length(conds) + 1]] <- list(col = names(rv$data)[1], op = "==", val = "", conn = "&")
rv$subset_conditions <- conds
removeModal()
show_subset_modal_()
})
# Remove condition buttons — use JS to send which index to remove
observeEvent(input$subset_remove_idx, {
idx <- input$subset_remove_idx
sync_subset_inputs_()
conds <- rv$subset_conditions
if (length(conds) > 1 && idx <= length(conds)) {
conds[[idx]] <- NULL
rv$subset_conditions <- conds
removeModal()
show_subset_modal_()
}
}, ignoreInit = TRUE)
# Column change — use JS to notify which index changed
observeEvent(input$subset_col_changed, {
idx <- input$subset_col_changed$idx
new_col <- input$subset_col_changed$col
conds <- rv$subset_conditions
if (idx <= length(conds) && !identical(conds[[idx]]$col, new_col)) {
sync_subset_inputs_()
conds <- rv$subset_conditions
conds[[idx]]$col <- new_col
conds[[idx]]$val <- ""
rv$subset_conditions <- conds
removeModal()
show_subset_modal_()
}
}, ignoreInit = TRUE)
# Apply subset filter
observeEvent(input$subset_apply, {
sync_subset_inputs_()
expr_text <- build_subset_expr_()
updateTextInput(session, "subset_arg", value = expr_text)
removeModal()
})
# ── Response Weights (wp) Dialog ───────────────────────────────────
# Reset wp when target changes to single
observeEvent(input$target, {
if (length(input$target) <= 1L) {
rv$wp_weights <- NULL
session$sendCustomMessage("update_wp_display",
list(text = "NULL (equal weights)"))
}
})
# Disable wp button when single target
observe({
if (length(input$target) > 1L) {
shinyjs_run <- function(code) {
session$sendCustomMessage("wp_btn_state", list(disabled = FALSE))
}
session$sendCustomMessage("wp_btn_state", list(disabled = FALSE))
} else {
session$sendCustomMessage("wp_btn_state", list(disabled = TRUE))
}
})
observeEvent(input$wp_set_btn, {
targets <- input$target
if (length(targets) <= 1L) {
showNotification("Response weights require multiple target variables.",
type = "warning", duration = 4)
return()
}
# Build one numericInput per target
weight_inputs <- lapply(seq_along(targets), function(i) {
current_val <- if (!is.null(rv$wp_weights) && i <= length(rv$wp_weights)) {
rv$wp_weights[i]
} else {
1
}
numericInput(paste0("wp_val_", i), targets[i],
value = current_val, min = 0, step = 0.1)
})
showModal(modalDialog(
title = "Response Weights (wp)",
tags$p("Set a numeric weight for each target variable.",
style = "font-size: 0.9em; color: #666;"),
weight_inputs,
footer = tagList(
actionButton("wp_apply", "Apply", class = "btn-success"),
modalButton("Cancel")
)
))
})
observeEvent(input$wp_apply, {
targets <- input$target
weights <- vapply(seq_along(targets), function(i) {
val <- input[[paste0("wp_val_", i)]]
if (is.null(val) || is.na(val)) 1 else as.numeric(val)
}, numeric(1))
rv$wp_weights <- weights
display <- paste0(targets, " = ", weights, collapse = ", ")
session$sendCustomMessage("update_wp_display", list(text = display))
# Persist to localStorage
fn <- rv$file_name %||% "default"
wp_data <- stats::setNames(as.list(weights), targets)
session$sendCustomMessage("save_wp_weights", list(filename = fn, weights = wp_data))
removeModal()
})
# Restore wp weights from localStorage when data/target changes
observeEvent(input$wp_weights_restored, {
restored <- input$wp_weights_restored
if (!is.null(restored) && length(restored) > 0) {
targets <- input$target
weights <- vapply(targets, function(t) {
val <- restored[[t]]
if (is.null(val)) 1 else as.numeric(val)
}, numeric(1))
rv$wp_weights <- weights
display <- paste0(targets, " = ", weights, collapse = ", ")
session$sendCustomMessage("update_wp_display", list(text = display))
}
}, ignoreInit = TRUE)
# --- Persist settings to SQLite (debounced from JS) ---
observeEvent(input$eui_save_trigger, {
payload <- input$eui_save_trigger
req(payload$filename)
tryCatch({
earthUI:::settings_db_write_(
settings_con,
filename = payload$filename,
settings = if (!is.null(payload$settings)) payload$settings else "{}",
variables = if (!is.null(payload$variables)) payload$variables else "{}",
interactions = if (!is.null(payload$interactions)) payload$interactions else "{}"
)
}, error = function(e) {
message("earthUI: SQLite save error: ", e$message)
})
}, ignoreInit = TRUE)
# --- Default settings (save/restore via SQLite with key "__defaults__") ---
# Radio: choose mode (last per-file settings vs saved defaults)
observeEvent(input$eui_defaults_action, {
action <- input$eui_defaults_action
message("earthUI: defaults radio changed to: '", action, "'")
req(rv$file_name)
if (action == "use_default") {
defaults <- earthUI:::settings_db_read_(settings_con, "__defaults__")
if (!is.null(defaults)) {
session$sendCustomMessage("restore_all_settings", list(
filename = rv$file_name,
settings = defaults$settings,
variables = defaults$variables,
interactions = defaults$interactions,
apply = TRUE
))
showNotification("Default settings applied.", type = "message",
duration = 3)
} else {
showNotification("No default settings saved yet. Use 'Save current as default' first.",
type = "warning", duration = 4)
updateRadioButtons(session, "eui_defaults_action", selected = "last")
}
} else if (action == "earth_defaults") {
session$sendCustomMessage("apply_earth_defaults", list())
showNotification("Earth default parameters applied.", type = "message",
duration = 3)
updateRadioButtons(session, "eui_defaults_action", selected = "last")
}
# "last" = do nothing, use whatever localStorage has
}, ignoreInit = TRUE)
# Button: save current settings as the default
observeEvent(input$eui_save_defaults, {
req(rv$file_name)
message("earthUI: saving current settings as defaults for: ", rv$file_name)
session$sendCustomMessage("collect_and_save_defaults", list(
filename = rv$file_name
))
showNotification("Current settings saved as defaults.", type = "message",
duration = 3)
})
output$data_preview_info <- renderUI({
req(rv$data)
tags$div(
class = "alert alert-info",
style = "font-size: 0.85em; padding: 8px;",
sprintf("%d rows, %d columns", nrow(rv$data), ncol(rv$data))
)
})
# Shared DataTable callback for click-to-popup on cells
cell_popup_js <- DT::JS("
table.on('click', 'td', function() {
var text = $(this).text();
if (text.length > 0) {
var $popup = $('#eui-cell-popup');
if (!$popup.length) {
$popup = $('<div id=\"eui-cell-popup\">' +
'<div class=\"eui-popup-backdrop\"></div>' +
'<div class=\"eui-popup-content\"><pre></pre>' +
'<button class=\"btn btn-sm btn-secondary eui-popup-close\">Close</button></div></div>');
$('body').append($popup);
$popup.on('click', '.eui-popup-backdrop, .eui-popup-close', function() {
$popup.hide();
});
}
$popup.find('pre').text(text);
$popup.show();
}
});
")
preview_data_ <- function() {
req(rv$data)
df <- rv$data
if (identical(input$purpose, "market") && isTRUE(input$skip_subject_row) && nrow(df) >= 2L) {
df <- df[2:nrow(df), , drop = FALSE]
}
df
}
output$data_preview <- DT::renderDataTable({
df <- preview_data_()
DT::datatable(df,
options = list(pageLength = 10, scrollX = TRUE),
rownames = FALSE,
class = "compact stripe",
callback = cell_popup_js)
})
output$data_preview_tab <- DT::renderDataTable({
df <- preview_data_()
DT::datatable(df,
options = list(pageLength = 10, scrollX = TRUE),
rownames = FALSE,
class = "compact stripe",
callback = cell_popup_js)
})
# --- Appraisal: subject (row 1) and comps (rows 2+) ---
render_subjects_ <- function() {
req(rv$data, input$purpose == "appraisal", nrow(rv$data) >= 1L)
tgt <- input$target
preds <- input$predictors
# Include display_only columns
display_cols <- character(0)
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "display_only") display_cols <- c(display_cols, nm)
}
}
show_cols <- unique(c(display_cols, tgt, preds))
show_cols <- intersect(show_cols, names(rv$data))
subj <- rv$data[1L, show_cols, drop = FALSE]
if (!is.null(tgt) && length(tgt) > 0L) {
for (t in tgt) {
if (t %in% names(subj)) subj[[t]] <- NA
}
}
subj <- cbind(data.frame(row = 1L, check.names = FALSE), subj)
DT::datatable(subj,
options = list(pageLength = 1, scrollX = TRUE, dom = "t"),
rownames = FALSE, class = "compact stripe",
callback = cell_popup_js)
}
render_comps_ <- function() {
req(rv$data, input$purpose == "appraisal", nrow(rv$data) >= 2L)
tgt <- input$target
preds <- input$predictors
display_cols <- character(0)
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "display_only") display_cols <- c(display_cols, nm)
}
}
show_cols <- unique(c(display_cols, tgt, preds))
show_cols <- intersect(show_cols, names(rv$data))
comps <- rv$data[2:nrow(rv$data), show_cols, drop = FALSE]
comps <- cbind(data.frame(row = seq_len(nrow(comps)), check.names = FALSE), comps)
low_rows <- integer(0)
if (!is.null(tgt) && length(tgt) > 0L && tgt[1L] %in% names(comps)) {
col <- comps[[tgt[1L]]]
if (is.numeric(col)) {
low_rows <- which(col <= 100 | is.na(col))
}
}
dt <- DT::datatable(comps,
options = list(pageLength = 10, scrollX = TRUE),
rownames = FALSE, class = "compact stripe",
callback = cell_popup_js)
if (length(low_rows) > 0L) {
dt <- DT::formatStyle(dt, columns = 0, target = "row",
backgroundColor = DT::styleRow(low_rows, "rgba(255,0,0,0.15)"))
}
dt
}
output$data_subjects <- DT::renderDataTable(render_subjects_())
output$data_comps <- DT::renderDataTable(render_comps_())
output$data_subjects_tab <- DT::renderDataTable(render_subjects_())
output$data_comps_tab <- DT::renderDataTable(render_comps_())
# --- Variable Configuration ---
output$target_selector <- renderUI({
req(rv$data)
storage_key <- if (is.null(rv$file_name)) "default" else rv$file_name
# JavaScript: persist target variable + advanced parameters in localStorage
js <- tags$script(HTML(sprintf("
(function() {
var storageKeyRaw = %s;
var storageKey = 'earthUI_settings_' + storageKeyRaw;
var selectIds = ['target', 'weights_col',
'degree', 'pmethod', 'glm_family', 'trace',
'varmod_method'];
var numericIds = ['nprune', 'thresh', 'penalty', 'minspan', 'endspan',
'fast_k', 'nfold_override', 'nk', 'newvar_penalty',
'fast_beta', 'ncross', 'varmod_exponent', 'varmod_conv',
'varmod_clamp', 'varmod_minspan', 'adjust_endspan',
'exhaustive_tol', 'output_folder', 'subset_arg'];
var checkboxIds = ['stratify', 'keepxy', 'scale_y', 'auto_linpreds',
'use_beta_cache', 'force_xtx_prune', 'get_leverages',
'force_weights', 'skip_subject_row'];
var radioIds = ['purpose'];
var dateIds = ['effective_date'];
var allIds = selectIds.concat(numericIds).concat(checkboxIds).concat(radioIds).concat(dateIds);
var saved = null;
try { saved = JSON.parse(localStorage.getItem(storageKey)); } catch(e) {}
function restoreSettings() {
if (!saved) return;
selectIds.forEach(function(id) {
if (saved[id] !== undefined && saved[id] !== null) {
var el = document.getElementById(id);
if (el && el.selectize) {
if (id === 'target') {
// target can be a single value or an array (multi-select)
var vals = Array.isArray(saved[id]) ? saved[id] : [saved[id]];
var valid = vals.filter(function(v) { return el.selectize.options[v]; });
if (valid.length > 0) el.selectize.setValue(valid);
} else {
el.selectize.setValue(saved[id]);
}
}
}
});
numericIds.forEach(function(id) {
if (saved[id] !== undefined) {
var $el = $('#' + id);
if ($el.length) { $el.val(saved[id]).trigger('change'); }
}
});
checkboxIds.forEach(function(id) {
if (saved[id] !== undefined) {
var $el = $('#' + id);
if ($el.length) {
$el.prop('checked', saved[id]);
$el.trigger('change');
}
}
});
radioIds.forEach(function(id) {
if (saved[id] !== undefined) {
$('input[name=' + id + '][value=' + saved[id] + ']').prop('checked', true).trigger('change');
}
});
dateIds.forEach(function(id) {
if (saved[id] !== undefined && saved[id] !== null) {
var $inp = $('#' + id + ' input');
if ($inp.length) {
$inp.val(saved[id]).trigger('change');
} else {
$('#' + id).val(saved[id]).trigger('change');
}
}
});
}
function saveSettings() {
var state = {};
selectIds.forEach(function(id) {
var el = document.getElementById(id);
if (el && el.selectize) { state[id] = el.selectize.getValue(); }
});
numericIds.forEach(function(id) {
state[id] = $('#' + id).val();
});
checkboxIds.forEach(function(id) {
state[id] = $('#' + id).is(':checked');
});
radioIds.forEach(function(id) {
state[id] = $('input[name=' + id + ']:checked').val();
});
dateIds.forEach(function(id) {
var $inp = $('#' + id + ' input');
state[id] = $inp.length ? $inp.val() : $('#' + id).val();
});
try { localStorage.setItem(storageKey, JSON.stringify(state)); } catch(e) {}
}
// Restore after selectize initializes (retry until target AND degree are ready)
// Block saving until restore is complete to prevent defaults overwriting saved values
var restoreComplete = false;
var attempts = 0;
function tryRestore() {
var targetEl = document.getElementById('target');
var degreeEl = document.getElementById('degree');
var targetReady = targetEl && targetEl.selectize && targetEl.selectize.isSetup;
var degreeReady = degreeEl && degreeEl.selectize && degreeEl.selectize.isSetup;
if (targetReady && degreeReady) {
restoreSettings();
// Restore wp weights from localStorage
window.euiCurrentFilename = storageKeyRaw;
setTimeout(function() {
try {
var wpSaved = JSON.parse(localStorage.getItem('earthUI_wp_' + storageKeyRaw));
if (wpSaved && Object.keys(wpSaved).length > 0) {
Shiny.setInputValue('wp_weights_restored', wpSaved, {priority: 'event'});
}
} catch(e) {}
}, 600);
restoreComplete = true;
} else if (attempts < 40) {
attempts++;
setTimeout(tryRestore, 250);
} else {
restoreComplete = true; // give up waiting, allow saves
}
}
tryRestore();
// Save on any tracked input change (only after restore is done)
$(document).off('shiny:inputchanged.euisettings')
.on('shiny:inputchanged.euisettings', function(event) {
if (restoreComplete && allIds.indexOf(event.name) >= 0) {
saveSettings();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(%s);
}
});
})();
", jsonlite::toJSON(storage_key, auto_unbox = TRUE),
jsonlite::toJSON(storage_key, auto_unbox = TRUE))))
tagList(
selectInput("target", "Target (response) variable(s)",
choices = names(rv$data), multiple = TRUE),
js
)
})
output$predictor_hint_text <- renderUI({
hint <- "Type = column data type, Inc = include as predictor, Factor = treat as categorical, Linear = linear-only (no hinges)"
if (input$purpose %in% c("appraisal", "market")) {
hint <- paste0(hint, ", Special = column role (e.g. contract_date)")
}
tags$p(class = "text-muted", style = "font-size: 0.8em; margin-bottom: 5px;", hint)
})
output$variable_table <- renderUI({
req(rv$data, input$target)
candidates <- setdiff(names(rv$data), input$target)
nrows <- nrow(rv$data)
# Storage key for remembering settings
storage_key <- if (is.null(rv$file_name)) "default" else rv$file_name
# Type options for dropdown
type_options <- c("numeric", "integer", "character", "logical",
"factor", "Date", "POSIXct", "unknown")
appraiser <- input$purpose %in% c("appraisal", "market")
# Special column options
special_options <- c("no", "actual_age", "area", "concessions",
"contract_date", "display_only", "dom",
"effective_age", "latitude", "listing_date",
"living_area", "longitude", "lot_size",
"site_dimensions")
# Header row
header_cols <- list(
tags$div(style = "flex: 1; min-width: 100px;", "Variable"),
tags$div(style = "width: 85px; text-align: center;", "Type"),
tags$div(style = "width: 45px; text-align: center;", "Inc?")
)
if (appraiser) {
header_cols <- c(header_cols, list(
tags$div(style = "width: 95px; text-align: center;", "Special")
))
}
header_cols <- c(header_cols, list(
tags$div(style = "width: 55px; text-align: center;", "Factor"),
tags$div(style = "width: 55px; text-align: center;", "Linear"),
tags$div(style = "width: 50px; text-align: right; padding-right: 4px;", "NAs")
))
header <- tags$div(
style = "display: flex; align-items: center; padding: 4px 0; border-bottom: 2px solid #ccc; font-weight: bold; font-size: 0.85em;",
header_cols
)
# Build rows using numeric index for IDs
rows <- lapply(seq_along(candidates), function(i) {
col <- candidates[i]
n_na <- sum(is.na(rv$data[[col]]))
pct_na <- n_na / nrows
na_style <- if (pct_na > 0.3) "color: red;" else ""
# Auto-detected type for this column
detected_type <- if (!is.null(rv$col_types) && col %in% names(rv$col_types)) {
rv$col_types[[col]]
} else {
"unknown"
}
# Build <option> tags with auto-detected type selected
option_tags <- lapply(type_options, function(opt) {
if (opt == detected_type) {
tags$option(value = opt, selected = "selected", opt)
} else {
tags$option(value = opt, opt)
}
})
# Build row cells
row_cells <- list(
tags$div(style = "flex: 1; min-width: 100px; font-size: 0.82em; overflow: hidden; text-overflow: ellipsis; white-space: nowrap;",
title = col, col,
tags$span(id = paste0("eui_special_badge_", i),
style = "font-size: 0.7em; color: #0d6efd; font-style: italic; margin-left: 4px;")),
tags$div(style = "width: 85px; text-align: center;",
tags$select(id = paste0("eui_type_", i),
class = "eui-type-select",
style = "width: 78px; font-size: 0.75em; padding: 1px 2px; border: 1px solid #ccc; border-radius: 3px; background: var(--bs-body-bg, #fff); color: var(--bs-body-color, #333);",
option_tags)),
tags$div(style = "width: 45px; text-align: center;",
tags$input(type = "checkbox", id = paste0("eui_inc_", i),
class = "eui-var-cb"))
)
if (appraiser) {
special_option_tags <- lapply(special_options, function(opt) {
tags$option(value = opt, opt)
})
row_cells <- c(row_cells, list(
tags$div(style = "width: 95px; text-align: center;",
tags$select(id = paste0("eui_special_", i),
class = "eui-special-select",
style = "width: 90px; font-size: 0.75em; padding: 1px 2px; border: 1px solid #ccc; border-radius: 3px; background: var(--bs-body-bg, #fff); color: var(--bs-body-color, #333);",
special_option_tags))
))
}
row_cells <- c(row_cells, list(
tags$div(style = "width: 55px; text-align: center;",
tags$input(type = "checkbox", id = paste0("eui_fac_", i),
class = "eui-var-cb")),
tags$div(style = "width: 55px; text-align: center;",
tags$input(type = "checkbox", id = paste0("eui_lin_", i),
class = "eui-var-cb")),
tags$div(style = paste0("width: 50px; text-align: right; font-size: 0.8em; padding-right: 4px;", na_style),
if (n_na > 0L) as.character(n_na) else "")
))
tags$div(
style = "display: flex; align-items: center; padding: 2px 0; border-bottom: 1px solid #eee;",
row_cells
)
})
# Detected types as JSON for JS (used to reset to defaults)
detected_types_list <- vapply(candidates, function(col) {
if (!is.null(rv$col_types) && col %in% names(rv$col_types)) {
rv$col_types[[col]]
} else {
"unknown"
}
}, character(1L))
detected_types_json <- jsonlite::toJSON(
as.list(stats::setNames(detected_types_list, candidates)),
auto_unbox = TRUE
)
# JavaScript: sync checkboxes + type dropdowns <-> Shiny inputs, with localStorage persistence
col_json <- jsonlite::toJSON(candidates, auto_unbox = FALSE)
n_cols <- length(candidates)
storage_key_json <- jsonlite::toJSON(storage_key, auto_unbox = TRUE)
appraiser_json <- if (appraiser) "true" else "false"
js <- tags$script(HTML(sprintf("
(function() {
var cols = %s;
var n = %d;
var storageKeyRaw = %s;
var storageKey = 'earthUI_vars_' + storageKeyRaw;
var detectedTypes = %s;
var appraiser = %s;
function gatherState() {
var inc = [], fac = [], lin = [];
var types = {};
var specials = {};
for (var i = 1; i <= n; i++) {
var sp = appraiser ? ($('#eui_special_' + i).val() || 'no') : 'no';
if (appraiser) specials[cols[i-1]] = sp;
if ($('#eui_inc_' + i).is(':checked') && sp !== 'display_only') inc.push(cols[i-1]);
if ($('#eui_fac_' + i).is(':checked')) fac.push(cols[i-1]);
if ($('#eui_lin_' + i).is(':checked')) lin.push(cols[i-1]);
types[cols[i-1]] = $('#eui_type_' + i).val();
}
Shiny.setInputValue('predictors', inc.length > 0 ? inc : null);
Shiny.setInputValue('categoricals', fac.length > 0 ? fac : null);
Shiny.setInputValue('linpreds', lin.length > 0 ? lin : null);
Shiny.setInputValue('col_types', types);
if (appraiser) {
Shiny.setInputValue('col_specials', specials);
}
}
function saveState() {
var state = {};
for (var i = 1; i <= n; i++) {
var entry = {
inc: $('#eui_inc_' + i).is(':checked'),
fac: $('#eui_fac_' + i).is(':checked'),
lin: $('#eui_lin_' + i).is(':checked'),
type: $('#eui_type_' + i).val()
};
if (appraiser) {
var sp = $('#eui_special_' + i).val();
if (sp) entry.special = sp;
}
state[cols[i-1]] = entry;
}
try { localStorage.setItem(storageKey, JSON.stringify(state)); } catch(e) {}
}
function restoreState() {
var saved = null;
try { saved = JSON.parse(localStorage.getItem(storageKey)); } catch(e) {}
if (saved) {
for (var i = 1; i <= n; i++) {
var s = saved[cols[i-1]];
if (s) {
$('#eui_inc_' + i).prop('checked', s.inc);
$('#eui_fac_' + i).prop('checked', s.fac);
$('#eui_lin_' + i).prop('checked', s.lin);
if (s.type) {
$('#eui_type_' + i).val(s.type);
}
if (appraiser && s.special) {
$('#eui_special_' + i).val(s.special);
}
}
}
}
}
// Restore saved state, then sync to Shiny
restoreState();
updateBadges();
setTimeout(gatherState, 200);
// On any checkbox change, save and sync
$(document).off('change.euivar').on('change.euivar', '.eui-var-cb', function() {
saveState();
gatherState();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(storageKeyRaw);
});
// On type dropdown change: auto-link Factor, save and sync
$(document).off('change.euitype').on('change.euitype', '.eui-type-select', function() {
var idx = this.id.replace('eui_type_', '');
var val = $(this).val();
if (val === 'character' || val === 'factor') {
$('#eui_fac_' + idx).prop('checked', true);
}
saveState();
gatherState();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(storageKeyRaw);
});
// Update special type badges next to variable names
function updateBadges() {
if (!appraiser) return;
for (var j = 1; j <= n; j++) {
var sp = $('#eui_special_' + j).val() || 'no';
var $badge = $('#eui_special_badge_' + j);
if ($badge.length) {
$badge.text(sp !== 'no' ? '[' + sp + ']' : '');
}
}
}
window.euiUpdateBadges = updateBadges;
// On special dropdown change: enforce single per special type, save and sync
$(document).off('change.euispecial').on('change.euispecial', '.eui-special-select', function() {
var idx = parseInt(this.id.replace('eui_special_', ''));
var val = $(this).val();
if (val !== 'no' && val !== 'display_only') {
// Only one column per special type (except display_only allows multiple)
for (var j = 1; j <= n; j++) {
if (j !== idx && $('#eui_special_' + j).val() === val) {
$('#eui_special_' + j).val('no');
}
}
}
updateBadges();
saveState();
gatherState();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(storageKeyRaw);
});
// Expose detectedTypes for earth defaults reset
window.euiDetectedTypes = detectedTypes;
window.euiCols = cols;
})();
", col_json, n_cols, storage_key_json, detected_types_json, appraiser_json)))
tagList(header, rows, js)
})
# --- Allowed Interaction Matrix ---
output$allowed_matrix_ui <- renderUI({
req(input$predictors)
preds <- input$predictors
if (length(preds) < 2) {
return(p("Need at least 2 predictors for interactions."))
}
n <- length(preds)
# Column headers: empty corner cell + variable names
header_cells <- list(tags$th(style = "padding: 2px;", ""))
for (j in seq_len(n)) {
header_cells <- c(header_cells, list(
tags$th(class = "eui-matrix-varlabel",
`data-var-idx` = j,
style = "padding: 2px 4px; font-size: 0.75em; text-align: center; writing-mode: vertical-lr; transform: rotate(180deg); max-height: 100px; overflow: hidden; cursor: pointer;",
title = preds[j], preds[j])
))
}
header_row <- tags$tr(class = "eui-matrix-header", header_cells)
# Build matrix rows
body_rows <- list()
for (i in seq_len(n)) {
cells <- list(
tags$td(class = "eui-matrix-rowlabel eui-matrix-varlabel",
`data-var-idx` = i,
style = "padding: 2px 4px; font-size: 0.75em; white-space: nowrap; overflow: hidden; text-overflow: ellipsis; max-width: 100px; cursor: pointer;",
title = preds[i], preds[i])
)
for (j in seq_len(n)) {
if (j > i) {
# Upper triangle: checkbox
id <- paste0("allowed_", i, "_", j)
cells <- c(cells, list(
tags$td(style = "text-align: center; padding: 2px;",
tags$input(type = "checkbox", id = id,
class = "eui-interaction-cb", checked = "checked",
style = "margin: 0;"))
))
} else {
# Diagonal and lower triangle: empty
cells <- c(cells, list(
tags$td(style = "padding: 2px;",
if (i == j) "\u00b7" else "")
))
}
}
body_rows <- c(body_rows, list(tags$tr(cells)))
}
# JavaScript to sync checkboxes with Shiny inputs + localStorage persistence
storage_key <- if (is.null(rv$file_name)) "default" else rv$file_name
js <- tags$script(HTML(sprintf("
(function() {
var n = %d;
var storageKey = 'earthUI_interactions_' + %s;
function saveState() {
var state = {};
for (var i = 1; i < n; i++) {
for (var j = i + 1; j <= n; j++) {
state[i + '_' + j] = $('#allowed_' + i + '_' + j).is(':checked');
}
}
try { localStorage.setItem(storageKey, JSON.stringify(state)); } catch(e) {}
}
function restoreState() {
var saved = null;
try { saved = JSON.parse(localStorage.getItem(storageKey)); } catch(e) {}
if (!saved) return;
for (var i = 1; i < n; i++) {
for (var j = i + 1; j <= n; j++) {
var key = i + '_' + j;
if (saved[key] !== undefined) {
$('#allowed_' + i + '_' + j).prop('checked', saved[key]);
}
}
}
}
function syncToShiny() {
for (var i = 1; i < n; i++) {
for (var j = i + 1; j <= n; j++) {
var id = 'allowed_' + i + '_' + j;
Shiny.setInputValue(id, $('#' + id).is(':checked'));
}
}
}
// Restore saved state, then sync
restoreState();
setTimeout(function() {
syncToShiny();
// Update Allow All / Clear All checkboxes
var all = $('.eui-interaction-cb').length;
var checked = $('.eui-interaction-cb:checked').length;
$('#eui_allow_all').prop('checked', checked === all);
$('#eui_clear_all').prop('checked', checked === 0);
}, 200);
// On any interaction checkbox change, save and sync
$(document).off('change.euimatrix').on('change.euimatrix', '.eui-interaction-cb', function() {
saveState();
syncToShiny();
if (typeof window.euiSaveToServer === 'function') window.euiSaveToServer(%s);
});
// Click variable name (row or column header) to toggle all its interactions
$(document).off('click.euivarlabel').on('click.euivarlabel', '.eui-matrix-varlabel', function() {
var k = parseInt($(this).attr('data-var-idx'));
if (isNaN(k)) return;
// Collect all checkboxes involving variable k
var cbs = [];
for (var i = 1; i <= n; i++) {
if (i === k) continue;
var lo = Math.min(i, k), hi = Math.max(i, k);
var $cb = $('#allowed_' + lo + '_' + hi);
if ($cb.length) cbs.push($cb);
}
// Toggle: if all checked, uncheck all; otherwise check all
var allChecked = cbs.every(function($cb) { return $cb.is(':checked'); });
cbs.forEach(function($cb) { $cb.prop('checked', !allChecked); });
// Trigger change to save and sync
if (cbs.length > 0) cbs[0].trigger('change');
});
})();
", n, jsonlite::toJSON(storage_key, auto_unbox = TRUE),
jsonlite::toJSON(storage_key, auto_unbox = TRUE))))
div(
style = "max-height: 300px; overflow: auto; border: 1px solid #ddd; padding: 4px; border-radius: 4px;",
tags$table(style = "border-collapse: collapse;",
tags$thead(header_row),
tags$tbody(body_rows)),
js
)
})
get_allowed_matrix <- reactive({
req(input$predictors)
preds <- input$predictors
mat <- build_allowed_matrix(preds)
if (length(preds) >= 2 && as.integer(input$degree) >= 2) {
n <- length(preds)
for (i in seq_len(n - 1)) {
for (j in (i + 1):n) {
id <- paste0("allowed_", i, "_", j)
val <- input[[id]]
if (!is.null(val) && !isTRUE(val)) {
mat[preds[i], preds[j]] <- FALSE
mat[preds[j], preds[i]] <- FALSE
}
}
}
}
mat
})
# --- Fit Model ---
build_fit_args_ <- function(df = rv$data) {
na_to_null <- function(x) if (is.na(x) || is.null(x)) NULL else x
# Evaluate subset expression (if any) to filter rows
subset_expr <- trimws(input$subset_arg %||% "")
if (nzchar(subset_expr)) {
subset_result <- tryCatch({
expr <- parse(text = subset_expr)
# Only allow column names from the data as variables
mask <- as.list(df)
mask[["TRUE"]] <- TRUE; mask[["FALSE"]] <- FALSE
mask$as.Date <- as.Date; mask$as.POSIXct <- as.POSIXct
rows <- eval(expr, envir = mask, enclos = emptyenv())
if (!is.logical(rows)) stop("Expression must evaluate to TRUE/FALSE")
rows[is.na(rows)] <- FALSE
rows
}, error = function(e) {
showNotification(paste("Subset error:", e$message),
type = "error", duration = 10)
NULL
})
if (!is.null(subset_result)) {
n_before <- nrow(df)
df <- df[subset_result, , drop = FALSE]
message("earthUI: subset filter: ", sum(subset_result), " of ", n_before, " rows selected")
}
}
degree <- as.integer(input$degree)
allowed_func <- NULL
allowed_matrix_arg <- NULL
if (degree >= 2) {
allowed_matrix_arg <- get_allowed_matrix()
allowed_func <- build_allowed_function(allowed_matrix_arg)
}
glm_arg <- NULL
if (input$glm_family != "none") {
glm_arg <- list(family = input$glm_family)
}
# Weights column → numeric vector (or NULL)
weights_arg <- NULL
if (!is.null(input$weights_col) && input$weights_col != "null" &&
input$weights_col %in% names(df)) {
weights_arg <- df[[input$weights_col]]
}
# wp (response weights) — per-target numeric vector from dialog
wp_arg <- rv$wp_weights
# Collect type_map from JS dropdown state
type_map_arg <- input$col_types # named list from gatherState()
list(
df = df,
target = input$target,
predictors = input$predictors,
categoricals = input$categoricals,
linpreds = input$linpreds,
type_map = type_map_arg,
degree = degree,
allowed_func = allowed_func,
allowed_matrix = allowed_matrix_arg,
nfold = na_to_null(input$nfold_override),
nprune = na_to_null(input$nprune),
thresh = na_to_null(input$thresh),
penalty = na_to_null(input$penalty),
minspan = na_to_null(input$minspan),
endspan = na_to_null(input$endspan),
fast.k = na_to_null(input$fast_k),
pmethod = input$pmethod,
glm = glm_arg,
trace = as.numeric(input$trace),
nk = na_to_null(input$nk),
newvar.penalty = na_to_null(input$newvar_penalty),
fast.beta = na_to_null(input$fast_beta),
ncross = na_to_null(input$ncross),
stratify = input$stratify,
varmod.method = if (length(input$target) > 1L) "none" else input$varmod_method,
varmod.exponent = na_to_null(input$varmod_exponent),
varmod.conv = na_to_null(input$varmod_conv),
varmod.clamp = na_to_null(input$varmod_clamp),
varmod.minspan = na_to_null(input$varmod_minspan),
keepxy = input$keepxy,
Scale.y = input$scale_y,
Adjust.endspan = na_to_null(input$adjust_endspan),
Auto.linpreds = input$auto_linpreds,
Force.weights = input$force_weights,
Use.beta.cache = input$use_beta_cache,
Force.xtx.prune = input$force_xtx_prune,
Get.leverages = input$get_leverages,
Exhaustive.tol = na_to_null(input$exhaustive_tol),
wp = wp_arg,
weights = weights_arg
)
}
observeEvent(input$run_model, {
req(rv$data, input$target, input$predictors)
# --- Appraiser: round latitude/longitude to 3 decimal places ---
if (input$purpose %in% c("appraisal", "market") && !is.null(input$col_specials)) {
for (nm in names(input$col_specials)) {
if (input$col_specials[[nm]] %in% c("latitude", "longitude") &&
nm %in% names(rv$data) && is.numeric(rv$data[[nm]])) {
rv$data[[nm]] <- round(rv$data[[nm]], 3L)
}
}
}
# --- Appraiser: add sale_age if contract_date is designated ---
if (input$purpose %in% c("appraisal", "market")) {
if (!("sale_age" %in% names(rv$data) && is.numeric(rv$data[["sale_age"]]))) {
# Find contract_date column
specials <- input$col_specials
contract_col <- NULL
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "contract_date") { contract_col <- nm; break }
}
}
if (is.null(contract_col)) {
showNotification(
"No 'contract_date' column designated — skipping sale_age calculation.",
type = "message", duration = 6
)
} else {
# Parse effective_date
eff_date <- as.POSIXct(as.character(input$effective_date))
# Parse contract date values
contract_vals <- rv$data[[contract_col]]
if (inherits(contract_vals, "POSIXct")) {
contract_posix <- contract_vals
} else if (inherits(contract_vals, "Date")) {
contract_posix <- as.POSIXct(contract_vals)
} else if (is.character(contract_vals)) {
contract_posix <- suppressWarnings(as.POSIXct(contract_vals))
if (all(is.na(contract_posix[!is.na(contract_vals)]))) {
showNotification(
paste0("Cannot parse '", contract_col, "' as dates for sale_age calculation."),
type = "error", duration = 10
)
return()
}
} else if (is.numeric(contract_vals)) {
# Excel serial date number -> Date -> POSIXct
contract_posix <- as.POSIXct(as.Date(contract_vals, origin = "1899-12-30"))
} else {
showNotification(
paste0("Column '", contract_col, "' cannot be interpreted as dates for sale_age."),
type = "error", duration = 10
)
return()
}
# Calculate sale_age in integer days
sale_age <- as.integer(difftime(eff_date, contract_posix, units = "days"))
rv$data[["sale_age"]] <- sale_age
rv$col_types[["sale_age"]] <- "integer"
# Pre-seed sale_age as included in localStorage so it appears checked
session$sendCustomMessage("sale_age_added", list(
filename = rv$file_name
))
showNotification(
paste0("Added 'sale_age' column (", sum(!is.na(sale_age)),
" values, integer days). Click Fit again to include it."),
type = "message", duration = 8
)
return()
}
}
}
# --- Skip subject row for Appraisal / Market Area Analysis ---
skip_first <- FALSE
if (input$purpose == "appraisal") {
skip_first <- TRUE
} else if (input$purpose == "market" && isTRUE(input$skip_subject_row)) {
skip_first <- TRUE
}
if (skip_first && nrow(rv$data) >= 2L) {
fit_data <- rv$data[2:nrow(rv$data), , drop = FALSE]
showNotification(
paste0("Skipping row 1 (subject). Fitting on ", nrow(fit_data), " rows."),
type = "message", duration = 4)
} else {
fit_data <- rv$data
}
fit_args <- build_fit_args_(df = fit_data)
# --- Type validation before fitting ---
if (!is.null(fit_args$type_map)) {
validation <- validate_types(fit_data, fit_args$type_map, fit_args$predictors)
if (length(validation$warnings) > 0L) {
showNotification(
paste("Type warnings:", paste(validation$warnings, collapse = "; ")),
type = "warning", duration = 8
)
}
if (!validation$ok) {
showNotification(
HTML(paste0("<strong>Type errors (fix before fitting):</strong><br>",
paste(validation$errors, collapse = "<br>"))),
type = "error", duration = 15
)
return()
}
if (length(validation$date_columns) > 0L) {
showNotification(
paste("Date columns converted to numeric (days since epoch):",
paste(validation$date_columns, collapse = ", ")),
type = "message", duration = 6
)
}
}
use_async <- requireNamespace("callr", quietly = TRUE)
if (use_async) {
# --- Async path: run earth in background process ---
fit_args$.capture_trace <- FALSE
# Ensure trace >= 1 so the user sees progress in the fitting log
if (is.null(fit_args$trace) || fit_args$trace < 1) {
fit_args$trace <- 1
}
rv$trace_lines <- character(0)
rv$result <- NULL
rv$rca_df <- NULL
rv$rca_targets <- NULL
rv$bg_proc <- callr::r_bg(
function(args) {
cat(sprintf("Dataset: %d obs, %d predictors, degree=%d\n",
nrow(args$df), length(args$predictors), args$degree))
if (!is.null(args$nfold) && args$nfold > 0)
cat(sprintf("Cross-validation: %d folds\n", args$nfold))
cat("Running forward pass...\n")
flush(stdout())
result <- do.call(earthUI::fit_earth, args)
cat(sprintf("Completed in %.1f seconds\n", result$elapsed))
flush(stdout())
result
},
args = list(args = fit_args),
stdout = "|", stderr = "|",
supervise = TRUE,
wd = tempdir()
)
rv$fitting <- TRUE
session$sendCustomMessage("fitting_start", list())
} else {
# --- Sync fallback (no callr) ---
session$sendCustomMessage("fitting_start", list())
withProgress(message = "Fitting Earth model...", value = 0.2, {
tryCatch({
setProgress(0.3, detail = "Running forward pass")
rv$result <- fit_earth(
df = fit_args$df,
target = fit_args$target,
predictors = fit_args$predictors,
categoricals = fit_args$categoricals,
linpreds = fit_args$linpreds,
degree = fit_args$degree,
allowed_func = fit_args$allowed_func,
allowed_matrix = fit_args$allowed_matrix,
nfold = fit_args$nfold,
nprune = fit_args$nprune,
thresh = fit_args$thresh,
penalty = fit_args$penalty,
minspan = fit_args$minspan,
endspan = fit_args$endspan,
fast.k = fit_args$fast.k,
pmethod = fit_args$pmethod,
glm = fit_args$glm,
trace = fit_args$trace,
nk = fit_args$nk,
newvar.penalty = fit_args$newvar.penalty,
fast.beta = fit_args$fast.beta,
ncross = fit_args$ncross,
stratify = fit_args$stratify,
varmod.method = fit_args$varmod.method,
varmod.exponent = fit_args$varmod.exponent,
varmod.conv = fit_args$varmod.conv,
varmod.clamp = fit_args$varmod.clamp,
varmod.minspan = fit_args$varmod.minspan,
keepxy = fit_args$keepxy,
Scale.y = fit_args$Scale.y,
Adjust.endspan = fit_args$Adjust.endspan,
Auto.linpreds = fit_args$Auto.linpreds,
Force.weights = fit_args$Force.weights,
Use.beta.cache = fit_args$Use.beta.cache,
Force.xtx.prune = fit_args$Force.xtx.prune,
Get.leverages = fit_args$Get.leverages,
Exhaustive.tol = fit_args$Exhaustive.tol,
wp = fit_args$wp,
weights = fit_args$weights
)
elapsed <- rv$result$elapsed
setProgress(1, detail = "Done")
session$sendCustomMessage("fitting_done",
list(text = sprintf("Done in %.1fs", elapsed)))
write_fit_log_(input$output_folder, rv$result$trace_output, rv$file_name)
# Auto-export for mgcvUI (degree <= 2)
auto_export_for_mgcv_(rv$result, input$output_folder, rv$file_name)
}, error = function(e) {
session$sendCustomMessage("fitting_done",
list(text = "Error"))
showNotification(paste("Model error:", e$message),
type = "error", duration = 10)
write_fit_log_(input$output_folder, c(paste("ERROR:", e$message)), rv$file_name)
})
})
}
})
# --- Background process polling observer ---
send_trace_lines_ <- function(lines, truncate_at = 0L) {
for (line in lines) {
if (nzchar(trimws(line))) {
display <- if (truncate_at > 0L && nchar(line) > truncate_at) {
paste0(substr(line, 1L, truncate_at), "...")
} else {
line
}
session$sendCustomMessage("trace_line", list(text = display))
}
}
}
observe({
req(rv$fitting)
invalidateLater(300)
isolate({
proc <- rv$bg_proc
if (is.null(proc)) return()
# stdout = earth trace output
new_out <- tryCatch(proc$read_output_lines(), error = function(e) character(0))
# stderr = messages, warnings, errors
new_err <- tryCatch(proc$read_error_lines(), error = function(e) character(0))
if (length(new_out) > 0L) {
rv$trace_lines <- c(rv$trace_lines, new_out)
send_trace_lines_(new_out)
}
if (length(new_err) > 0L) {
rv$trace_lines <- c(rv$trace_lines, new_err)
send_trace_lines_(new_err)
}
# Check if process has finished
if (!proc$is_alive()) {
# Read any remaining output
final_out <- tryCatch(proc$read_output_lines(), error = function(e) character(0))
final_err <- tryCatch(proc$read_error_lines(), error = function(e) character(0))
if (length(final_out) > 0L) {
rv$trace_lines <- c(rv$trace_lines, final_out)
send_trace_lines_(final_out)
}
if (length(final_err) > 0L) {
rv$trace_lines <- c(rv$trace_lines, final_err)
send_trace_lines_(final_err)
}
tryCatch({
result <- proc$get_result()
# Store captured trace lines from polling
result$trace_output <- rv$trace_lines
rv$result <- result
session$sendCustomMessage("fitting_done",
list(text = sprintf("Done in %.1fs", result$elapsed)))
# Write log file on success
write_fit_log_(input$output_folder, rv$trace_lines, rv$file_name)
# Auto-export for mgcvUI (degree <= 2)
auto_export_for_mgcv_(result, input$output_folder, rv$file_name)
}, error = function(e) {
# Extract the real error from callr's wrapper
err_msg <- e$message
if (!is.null(e$parent)) {
err_msg <- e$parent$message
} else {
# Also check stderr for error details
err_lines <- rv$trace_lines[grepl("^Error", rv$trace_lines)]
if (length(err_lines) > 0L) {
err_msg <- sub("^Error *:? *", "", err_lines[length(err_lines)])
}
}
session$sendCustomMessage("fitting_done", list(text = "Error"))
showNotification(paste("Model error:", err_msg),
type = "error", duration = 15)
# Write log file on error
log_lines <- c(rv$trace_lines, paste("ERROR:", err_msg))
write_fit_log_(input$output_folder, log_lines, rv$file_name)
})
rv$fitting <- FALSE
rv$bg_proc <- NULL
}
})
})
# --- Parameter Info Modal ---
observeEvent(input$param_info, {
showModal(modalDialog(
title = "Earth Model Parameters",
size = "l",
easyClose = TRUE,
div(style = "max-height: 70vh; overflow-y: auto; font-size: 0.9em;",
h5("Forward Pass"),
tags$dl(
tags$dt("degree"), tags$dd("Maximum degree of interaction. Default 1 (additive, no interactions)."),
tags$dt("nk"), tags$dd("Maximum number of model terms before pruning (includes intercept). Default is semi-automatically calculated."),
tags$dt("thresh"), tags$dd("Forward stepping threshold (default 0.001). Forward pass terminates if adding a term changes RSq by less than thresh."),
tags$dt("penalty"), tags$dd("GCV penalty per knot. Default is 3 if degree>1, else 2. Values of 0 or -1 have special meaning. Typical range: 2-4."),
tags$dt("minspan"), tags$dd("Minimum observations between knots. Default 0 (auto-calculated). Use 1 with endspan=1 to consider all x values. Negative values specify max knots per predictor (e.g., -3 = three evenly spaced knots)."),
tags$dt("endspan"), tags$dd("Minimum observations before first and after last knot. Default 0 (auto-calculated). Be wary of reducing this, especially for predictions near data limits."),
tags$dt("newvar.penalty"), tags$dd("Penalty for adding a new variable (Friedman's gamma). Default 0. Non-zero values (0.01-0.2) make the model prefer reusing existing variables."),
tags$dt("fast.k"), tags$dd("Max parent terms considered per forward step (Fast MARS). Default 20. Set 0 to disable Fast MARS. Lower = faster, higher = potentially better model."),
tags$dt("fast.beta"), tags$dd("Fast MARS ageing coefficient. Default 1. A value of 0 sometimes gives better results."),
tags$dt("Auto.linpreds"), tags$dd("Default TRUE. If the best knot is at the predictor minimum, add the predictor linearly (no hinge). Only affects predictions outside training data range."),
tags$dt("linpreds"), tags$dd("Predictors that enter linearly (no hinge functions), set via the 'Linear' checkbox in Variable Configuration.")
),
h5("Pruning"),
tags$dl(
tags$dt("pmethod"), tags$dd("Pruning method: backward (default), none, exhaustive, forward, seqrep, cv. Use 'cv' with nfold to select terms by cross-validation."),
tags$dt("nprune"), tags$dd("Maximum terms (including intercept) in pruned model. Default NULL (all terms from forward pass, after pruning).")
),
h5("Cross Validation"),
tags$dl(
tags$dt("nfold"), tags$dd("Number of CV folds. Default 0 (no CV). Auto-set to 10 when degree >= 2. Use trace=0.5 to trace CV."),
tags$dt("ncross"), tags$dd("Number of cross-validations (each has nfold folds). Default 1. Use higher values (e.g., 30) with variance models."),
tags$dt("stratify"), tags$dd("Default TRUE. Stratify CV samples so each fold has approximately equal response distribution.")
),
h5("Variance Model"),
tags$dl(
tags$dt("varmod.method"), tags$dd("none (default), const, lm, rlm, earth, gam, power, power0, x.lm, x.rlm, x.earth, x.gam. Requires nfold and ncross. Use trace=0.3 to trace. See 'Variance models in earth' by Stephen Milborrow."),
tags$dt("varmod.exponent"), tags$dd("Power transform for residual regression. Default 1. Use 0.5 if std dev increases with square root of response."),
tags$dt("varmod.conv"), tags$dd("Convergence criterion (percent) for IRLS in variance model. Default 1. Negative values force that many iterations."),
tags$dt("varmod.clamp"), tags$dd("Minimum estimated std dev = varmod.clamp * mean(sd(residuals)). Default 0.1. Prevents negative or tiny std dev estimates."),
tags$dt("varmod.minspan"), tags$dd("minspan for internal earth call in variance model. Default -3 (three evenly spaced knots per predictor).")
),
h5("GLM"),
tags$dl(
tags$dt("glm family"), tags$dd("Optional GLM family applied to earth basis functions. Choices: none, gaussian, binomial, poisson. Example use: binomial for binary outcomes.")
),
h5("Other"),
tags$dl(
tags$dt("trace"), tags$dd("Trace level: 0=none, 0.3=variance model, 0.5=CV, 1=overview, 2=forward pass, 3=pruning, 4=model mats/pruning details, 5=full details."),
tags$dt("keepxy"), tags$dd("Default FALSE. Set TRUE to retain x, y, subset, weights in the model object. Required for some cv. statistics. Makes CV slower."),
tags$dt("Scale.y"), tags$dd("Default TRUE. Scale response internally (subtract mean, divide by sd). Provides better numeric stability."),
tags$dt("Adjust.endspan"), tags$dd("In interaction terms, endspan is multiplied by this value. Default 2. Reduces overfitting at data boundaries."),
tags$dt("Exhaustive.tol"), tags$dd("Default 1e-10. If reciprocal condition number of bx < this, forces pmethod='backward'. Only applies with pmethod='exhaustive'."),
tags$dt("Use.beta.cache"), tags$dd("Default TRUE. Caches regression coefficients in forward pass for speed (20%+ faster). Uses more memory."),
tags$dt("Force.xtx.prune"), tags$dd("Default FALSE. Force use of X'X-based subset evaluation in pruning (instead of QR-based leaps). Only for advanced use."),
tags$dt("Get.leverages"), tags$dd("Default TRUE (unless >100k cases). Calculate diagonal hat values for linear regression of y on bx. Needed for some diagnostics."),
tags$dt("Force.weights"), tags$dd("Default FALSE. For testing: force weighted code path even without weights.")
)
)
))
})
# --- Results: Summary ---
output$summary_metrics <- renderUI({
req(rv$result)
s <- format_summary(rv$result)
if (isTRUE(s$multi)) {
# Per-response metrics cards
targets <- rv$result$target
resp_cards <- lapply(seq_along(targets), function(i) {
tgt <- targets[i]
tagList(
tags$h6(tgt, style = "margin-top: 10px; font-weight: bold;"),
tags$div(
class = "row", style = "margin-bottom: 10px;",
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("R\u00b2"),
tags$h4(sprintf("%.4f", s$r_squared[i])))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("GRSq"),
tags$h4(sprintf("%.4f", s$grsq[i])))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("CV R\u00b2"),
tags$h4(if (!is.na(s$cv_rsq[i])) sprintf("%.4f", s$cv_rsq[i]) else "N/A"))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 8px;",
tags$h6("Terms"),
tags$h4(s$n_terms)))
)
)
})
metrics <- tagList(resp_cards)
# CV info (per-response)
if (rv$result$cv_enabled && !all(is.na(s$cv_rsq))) {
cv_lines <- vapply(seq_along(targets), function(i) {
if (!is.na(s$cv_rsq[i])) {
sprintf("%s: CV R\u00b2 = %.4f | Training R\u00b2 = %.4f",
targets[i], s$cv_rsq[i], s$r_squared[i])
} else {
""
}
}, character(1))
cv_lines <- cv_lines[nzchar(cv_lines)]
if (length(cv_lines) > 0L) {
metrics <- tagList(
metrics,
tags$div(
class = "alert alert-info",
style = "font-size: 0.9em;",
HTML(paste(cv_lines, collapse = "<br>"))
)
)
}
}
} else {
# Single-response metrics
metrics <- tagList(
tags$div(
class = "row",
style = "margin-bottom: 15px;",
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("R\u00b2"), tags$h4(sprintf("%.4f", s$r_squared)))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("GRSq"), tags$h4(sprintf("%.4f", s$grsq)))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("CV R\u00b2"), tags$h4(if (!is.na(s$cv_rsq)) sprintf("%.4f", s$cv_rsq) else "N/A"))),
tags$div(class = "col-md-3",
tags$div(class = "card text-center",
style = "padding: 10px;",
tags$h6("Terms"), tags$h4(s$n_terms)))
)
)
if (rv$result$cv_enabled && !is.na(s$cv_rsq)) {
metrics <- tagList(
metrics,
tags$div(
class = "alert alert-info",
style = "font-size: 0.9em;",
sprintf("Cross-validated R\u00b2: %.4f | Training R\u00b2: %.4f",
s$cv_rsq, s$r_squared),
if (s$r_squared - s$cv_rsq > 0.1) {
tags$span(style = "color: red; font-weight: bold;",
" \u26a0 Possible overfitting detected")
}
)
)
}
}
metrics
})
# --- Results: Model Equation ---
output$model_equation <- renderUI({
req(rv$result)
eq <- format_model_equation(rv$result)
if (inherits(eq, "earthUI_equation_multi")) {
# Show one equation per response with a heading
eq_blocks <- lapply(seq_along(eq$targets), function(i) {
sub_eq <- eq$equations[[i]]
tagList(
tags$h5(eq$targets[i], style = "margin-top: 16px;"),
withMathJax(HTML(sub_eq$latex_inline))
)
})
do.call(tagList, eq_blocks)
} else {
withMathJax(HTML(eq$latex_inline))
}
})
output$summary_table <- DT::renderDataTable({
req(rv$result)
s <- format_summary(rv$result)
dt <- DT::datatable(s$coefficients, options = list(pageLength = 20),
rownames = FALSE, class = "compact stripe")
numeric_cols <- names(s$coefficients)[vapply(s$coefficients, is.numeric, logical(1))]
if (length(numeric_cols) > 0) dt <- DT::formatRound(dt, numeric_cols, digits = 6)
dt
})
# --- Response selector for multivariate models ---
output$response_selector_diag <- renderUI({
req(rv$result)
targets <- rv$result$target
if (length(targets) <= 1L) return(NULL)
choices <- stats::setNames(seq_along(targets), targets)
selectInput("diag_response", "Response variable",
choices = choices, selected = 1L)
})
output$response_selector_contrib <- renderUI({
req(rv$result)
targets <- rv$result$target
if (length(targets) <= 1L) return(NULL)
choices <- stats::setNames(seq_along(targets), targets)
selectInput("contrib_response", "Response variable",
choices = choices, selected = 1L)
})
# --- Results: Variable Importance ---
output$importance_plot <- renderPlot({
req(rv$result)
plot_variable_importance(rv$result)
})
output$importance_table <- DT::renderDataTable({
req(rv$result)
imp_df <- format_variable_importance(rv$result)
dt <- DT::datatable(imp_df, options = list(pageLength = 20),
rownames = FALSE, class = "compact stripe")
numeric_cols <- names(imp_df)[vapply(imp_df, is.numeric, logical(1))]
if (length(numeric_cols) > 0) dt <- DT::formatRound(dt, numeric_cols, digits = 6)
dt
})
# --- Results: Contribution (g-function plots) ---
output$contrib_g_selector <- renderUI({
req(rv$result)
gf <- list_g_functions(rv$result)
if (nrow(gf) == 0L) return(p("No g-functions in model."))
# Build display labels: "1: sq_ft_total" or "6: sq_ft_total x beds [3D]"
display_label <- ifelse(
gf$d >= 2L,
gsub(" ", " \u00d7 ", gf$label),
gf$label
)
labels <- paste0(gf$index, ": ", display_label,
ifelse(gf$d >= 2L, " [3D]", ""))
choices <- stats::setNames(gf$index, labels)
selectInput("contrib_g_index", "Select g-function", choices = choices)
})
output$contrib_plot_container <- renderUI({
req(rv$result, input$contrib_g_index)
gf <- list_g_functions(rv$result)
idx <- as.integer(input$contrib_g_index)
if (idx < 1L || idx > nrow(gf)) return(NULL)
if (gf$d[idx] >= 2L && requireNamespace("plotly", quietly = TRUE)) {
plotly::plotlyOutput("contrib_plot_3d", height = "500px")
} else {
plotOutput("contrib_plot_2d", height = "400px")
}
})
output$contrib_plot_2d <- renderPlot({
req(rv$result, input$contrib_g_index)
ri <- if (length(rv$result$target) > 1L && !is.null(input$contrib_response)) {
as.integer(input$contrib_response)
} else {
NULL
}
tryCatch(
plot_g_function(rv$result, as.integer(input$contrib_g_index),
response_idx = ri),
error = function(e) {
message("earthUI: g-function 2D plot error: ", e$message)
plot.new()
text(0.5, 0.5, paste("Error:", e$message), cex = 1.2)
}
)
})
if (requireNamespace("plotly", quietly = TRUE)) {
output$contrib_plot_3d <- plotly::renderPlotly({
req(rv$result, input$contrib_g_index)
ri <- if (length(rv$result$target) > 1L && !is.null(input$contrib_response)) {
as.integer(input$contrib_response)
} else {
NULL
}
tryCatch(
plot_g_function(rv$result, as.integer(input$contrib_g_index),
response_idx = ri),
error = function(e) {
message("earthUI: g-function 3D plot error: ", e$message)
plotly::plot_ly() |>
plotly::layout(title = paste("Error:", e$message))
}
)
})
}
# --- Results: Correlation Matrix ---
output$correlation_plot_ui <- renderUI({
req(rv$result)
plotOutput("correlation_plot", height = "800px", width = "800px")
})
output$correlation_plot <- renderPlot({
req(rv$result)
tryCatch(
plot_correlation_matrix(rv$result),
error = function(e) {
message("earthUI: correlation plot error: ", e$message)
plot.new()
text(0.5, 0.5, paste("Error:", e$message), cex = 1.2)
}
)
}, res = 120)
# --- Results: Diagnostics ---
output$residuals_plot <- renderPlot({
req(rv$result)
ri <- if (length(rv$result$target) > 1L && !is.null(input$diag_response)) {
as.integer(input$diag_response)
} else {
NULL
}
plot_residuals(rv$result, response_idx = ri)
})
output$qq_plot <- renderPlot({
req(rv$result)
ri <- if (length(rv$result$target) > 1L && !is.null(input$diag_response)) {
as.integer(input$diag_response)
} else {
NULL
}
plot_qq(rv$result, response_idx = ri)
})
output$actual_vs_predicted_plot <- renderPlot({
req(rv$result)
ri <- if (length(rv$result$target) > 1L && !is.null(input$diag_response)) {
as.integer(input$diag_response)
} else {
NULL
}
plot_actual_vs_predicted(rv$result, response_idx = ri)
})
# --- Results: ANOVA ---
output$anova_table <- DT::renderDataTable({
req(rv$result)
anova_df <- format_anova(rv$result)
dt <- DT::datatable(anova_df, options = list(pageLength = 20),
rownames = FALSE, class = "compact stripe")
numeric_cols <- names(anova_df)[vapply(anova_df, is.numeric, logical(1))]
if (length(numeric_cols) > 0) dt <- DT::formatRound(dt, numeric_cols, digits = 6)
dt
})
# --- Results: RCA Adjustment Percentage Histograms ---
output$rca_plots_ui <- renderUI({
req(rv$rca_df, rv$rca_targets)
df <- rv$rca_df
targets <- rv$rca_targets
# Build plot outputs for each target
plot_tags <- list()
for (ti in seq_along(targets)) {
tgt <- targets[ti]
if (ti == 1L) {
pct_cols <- list(
list(col = "residual_pct", label = "Residual Adj %"),
list(col = "net_adj_pct", label = "Net Adj %"),
list(col = "gross_adj_pct", label = "Gross Adj %")
)
} else {
pct_cols <- list(
list(col = paste0(tgt, "_residual_pct"), label = paste0(tgt, " Residual Adj %")),
list(col = paste0(tgt, "_net_adj_pct"), label = paste0(tgt, " Net Adj %")),
list(col = paste0(tgt, "_gross_adj_pct"), label = paste0(tgt, " Gross Adj %"))
)
}
for (pc in pct_cols) {
plot_id <- paste0("rca_hist_", gsub("[^a-zA-Z0-9]", "_", pc$col))
local({
col_name <- pc$col
plot_label <- pc$label
output[[plot_id]] <- renderPlot({
vals <- rv$rca_df[[col_name]]
vals <- vals[!is.na(vals) & is.finite(vals)]
if (length(vals) == 0L) return(NULL)
pct_vals <- vals * 100
avg_val <- mean(pct_vals)
med_val <- stats::median(pct_vals)
sd_val <- stats::sd(pct_vals)
bin_width <- 5
rng <- range(pct_vals)
brks <- seq(floor(rng[1] / bin_width) * bin_width,
ceiling(rng[2] / bin_width) * bin_width,
by = bin_width)
if (length(brks) < 2L) brks <- c(brks[1], brks[1] + bin_width)
hist_data <- graphics::hist(pct_vals, breaks = brks, plot = FALSE)
y_max <- max(hist_data$counts) * 1.25
graphics::par(mar = c(5, 4, 4, 2) + 0.1)
graphics::hist(pct_vals, breaks = brks, col = "#4A90D9", border = "white",
main = plot_label,
xlab = "Percentage (%)", ylab = "Frequency",
las = 1, ylim = c(0, y_max))
graphics::abline(v = avg_val, col = "#E74C3C", lwd = 2, lty = 2)
graphics::abline(v = med_val, col = "#2ECC71", lwd = 2, lty = 2)
graphics::legend("topright",
legend = c(
sprintf("Mean: %.2f%%", avg_val),
sprintf("Median: %.2f%%", med_val),
sprintf("Std Dev: %.2f%%", sd_val)
),
col = c("#E74C3C", "#2ECC71", NA),
lwd = c(2, 2, NA), lty = c(2, 2, NA),
bty = "n", cex = 1.1)
}, res = 120)
})
plot_tags <- c(plot_tags, list(
plotOutput(plot_id, height = "350px"),
tags$br()
))
}
if (ti < length(targets)) {
plot_tags <- c(plot_tags, list(tags$hr()))
}
}
do.call(tagList, plot_tags)
})
# --- Results: Earth Output ---
output$earth_output <- renderPrint({
req(rv$result)
model <- rv$result$model
cat(sprintf("== Timing: %.2f seconds ==\n\n", rv$result$elapsed))
cat("== Model ==\n\n")
print(model)
cat("\n\n== Summary ==\n\n")
print(summary(model))
if (!is.null(model$varmod)) {
cat("\n\n== Variance Model ==\n\n")
print(model$varmod)
}
if (length(rv$result$trace_output) > 0L) {
trace_lines <- rv$result$trace_output
trace_lines <- trace_lines[!grepl("^Removed .* rows with miss", trace_lines)]
trace_lines <- trace_lines[!grepl("^CV fold ", trace_lines)]
if (length(trace_lines) > 0L) {
cat("\n\n== Trace Log ==\n\n")
for (line in trace_lines) {
if (nchar(line) > 25L) {
cat(substr(line, 1L, 25L), "...\n")
} else {
cat(line, "\n")
}
}
}
}
})
# --- Export Report (saves to output folder) ---
observeEvent(input$export_report_btn, {
req(rv$result)
fmt <- input$export_format
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) {
folder <- path.expand("~/Downloads")
}
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(rv$file_name %||% "earth")
out_name <- paste0(base, "_report_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".", fmt)
out_path <- file.path(folder, out_name)
withProgress(message = "Rendering report...", value = 0.3, {
tryCatch({
render_report(rv$result,
output_format = fmt,
output_file = out_path,
paper_size = earthUI:::locale_paper_())
setProgress(1, detail = "Done")
session$sendCustomMessage("download_check",
list(id = "export_report_btn"))
showNotification(
paste0("Report saved to: ", out_path),
type = "message", duration = 8)
message("earthUI: report saved to ", out_path)
}, error = function(e) {
message("earthUI export error: ", e$message)
showNotification(paste("Export error:", e$message),
type = "error", duration = 15)
})
})
})
# --- 8. Generate Sales Grid & Download ---
# Step 1: Button click shows modal with recommended comps
observeEvent(input$sales_grid_btn, {
req(rv$rca_df)
rca <- rv$rca_df
n_total <- nrow(rca)
if (n_total < 2) {
showNotification("Need at least 2 rows (subject + 1 comp).",
type = "error", duration = 8)
return()
}
# Compute gross_adj_pct for all weight > 0 rows (exclude subject row 1)
has_gross_pct <- "gross_adjustments" %in% colnames(rca) &&
"sale_price" %in% colnames(rca)
wt_col <- if ("weight" %in% colnames(rca)) rca[["weight"]] else rep(1, n_total)
# Build comp info table (rows 2..n_total with weight > 0)
comp_info <- data.frame(
row = 2:n_total,
id = if ("id" %in% colnames(rca)) rca[["id"]][2:n_total] else 2:n_total,
address = if ("street_address" %in% colnames(rca)) {
rca[["street_address"]][2:n_total]
} else rep("", n_total - 1),
sale_price = if ("sale_price" %in% colnames(rca)) {
rca[["sale_price"]][2:n_total]
} else rep(NA, n_total - 1),
sale_age = if ("sale_age" %in% colnames(rca)) {
rca[["sale_age"]][2:n_total]
} else rep(NA, n_total - 1),
weight = wt_col[2:n_total],
gross_adj = if ("gross_adjustments" %in% colnames(rca)) {
rca[["gross_adjustments"]][2:n_total]
} else rep(0, n_total - 1),
stringsAsFactors = FALSE
)
# Compute gross_adj_pct
comp_info$gross_adj_pct <- ifelse(
!is.na(comp_info$sale_price) & comp_info$sale_price != 0,
abs(comp_info$gross_adj / comp_info$sale_price),
NA
)
# Filter: weight > 0 only
eligible <- comp_info[!is.na(comp_info$weight) & comp_info$weight > 0, ]
# Sort all eligible by gross_adj_pct ascending
eligible <- eligible[order(eligible$gross_adj_pct, na.last = TRUE), ]
# Recommended: gross_adj_pct < 0.25, then sort by sale_age ascending
recommended <- eligible[!is.na(eligible$gross_adj_pct) &
eligible$gross_adj_pct < 0.25, ]
recommended <- recommended[order(recommended$sale_age, na.last = TRUE), ]
# Cap at 30
if (nrow(recommended) > 30) recommended <- recommended[1:30, ]
# Others not recommended (for "add more" section)
others <- eligible[is.na(eligible$gross_adj_pct) |
eligible$gross_adj_pct >= 0.25, ]
others <- others[order(others$gross_adj_pct, na.last = TRUE), ]
# Store for the confirm handler
rv$sg_recommended <- recommended
rv$sg_others <- others
# Build modal UI
rec_checks <- if (nrow(recommended) > 0) {
lapply(seq_len(nrow(recommended)), function(i) {
r <- recommended[i, ]
lbl <- sprintf("Row %d | %s | SP: $%s | Age: %s | Gross: %.1f%%",
r$row,
substr(as.character(r$address), 1, 30),
formatC(r$sale_price, format = "f", digits = 0,
big.mark = ","),
as.character(r$sale_age),
r$gross_adj_pct * 100)
tags$div(
checkboxInput(paste0("sg_rec_", r$row), lbl, value = TRUE),
style = "margin-bottom: 0px;"
)
})
} else {
tags$p("No comps with gross adjustment < 25% found.",
style = "color: var(--bs-secondary-color);")
}
other_checks <- if (nrow(others) > 0) {
lapply(seq_len(min(nrow(others), 50)), function(i) {
r <- others[i, ]
pct_str <- if (!is.na(r$gross_adj_pct)) {
sprintf("%.1f%%", r$gross_adj_pct * 100)
} else "N/A"
lbl <- sprintf("Row %d | %s | SP: $%s | Age: %s | Gross: %s",
r$row,
substr(as.character(r$address), 1, 30),
formatC(r$sale_price, format = "f", digits = 0,
big.mark = ","),
as.character(r$sale_age),
pct_str)
tags$div(
checkboxInput(paste0("sg_rec_", r$row), lbl, value = FALSE),
style = "margin-bottom: 0px;"
)
})
} else NULL
showModal(modalDialog(
title = "Sales Grid — Select Comparables (max 30)",
size = "l",
tags$div(
style = "max-height: 500px; overflow-y: auto;",
tags$h5(paste0("Recommended Comps (gross adj < 25%, ",
"sorted by sale age) — ",
nrow(recommended), " found")),
rec_checks,
if (!is.null(other_checks)) {
tagList(
hr(),
tags$h5("Additional Comps (gross adj >= 25%)"),
other_checks
)
}
),
footer = tagList(
modalButton("Cancel"),
actionButton("sg_confirm", "Generate Sales Grid",
class = "btn-success")
)
))
})
# Step 2: Confirm button in modal — generate the grid
observeEvent(input$sg_confirm, {
req(rv$rca_df)
removeModal()
# Collect checked rows from both recommended and others
all_candidate_rows <- c(
if (!is.null(rv$sg_recommended) && nrow(rv$sg_recommended) > 0)
rv$sg_recommended$row else integer(0),
if (!is.null(rv$sg_others) && nrow(rv$sg_others) > 0)
rv$sg_others$row[seq_len(min(nrow(rv$sg_others), 50))] else integer(0)
)
comp_rows <- integer(0)
for (r in all_candidate_rows) {
cb_val <- input[[paste0("sg_rec_", r)]]
if (!is.null(cb_val) && isTRUE(cb_val)) {
comp_rows <- c(comp_rows, r)
}
}
if (length(comp_rows) == 0) {
showNotification("No comps selected.", type = "warning", duration = 8)
return()
}
if (length(comp_rows) > 30) {
comp_rows <- comp_rows[1:30]
showNotification("Capped at 30 comps.", type = "warning", duration = 5)
}
# Sort selected comps by gross_adj_pct ascending
rca <- rv$rca_df
sp <- if ("sale_price" %in% colnames(rca)) rca[["sale_price"]][comp_rows] else rep(NA, length(comp_rows))
gross <- if ("gross_adjustments" %in% colnames(rca)) rca[["gross_adjustments"]][comp_rows] else rep(0, length(comp_rows))
gap <- ifelse(!is.na(sp) & sp != 0, abs(gross / sp), NA)
comp_rows <- comp_rows[order(gap, na.last = TRUE)]
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
out_path <- file.path(folder, paste0("SalesGrid_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"))
message("earthUI: Sales grid with ", length(comp_rows),
" comps (rows: ", paste(comp_rows, collapse = ","), ")")
tryCatch({
tmp_adj <- tempfile(fileext = ".xlsx")
writexl::write_xlsx(rv$rca_df, tmp_adj)
grid_script <- system.file("app", "sales_grid.R", package = "earthUI")
if (!nzchar(grid_script)) {
showNotification("Sales grid script not found in package.",
type = "error", duration = 10)
return()
}
source(grid_script, local = TRUE)
# Build specials named list from designations
sg_specials_map <- list()
sg_input <- input$col_specials
if (!is.null(sg_input)) {
for (nm in names(sg_input)) {
sp_type <- sg_input[[nm]]
if (sp_type != "no") sg_specials_map[[sp_type]] <- nm
}
}
n_comp <- length(comp_rows)
n_sheet <- ceiling(n_comp / 3)
withProgress(
message = "Generating Sales Grid",
detail = sprintf("0 of %d comps processed", n_comp),
value = 0, {
generate_sales_grid(
adjusted_file = tmp_adj,
comp_rows = comp_rows,
output_file = out_path,
specials = sg_specials_map,
progress_fn = function(sheet, total_sheets, comps_done, total_comps) {
setProgress(
value = comps_done / total_comps,
detail = sprintf("Sheet %d of %d — %d of %d comps processed",
sheet, total_sheets, comps_done, total_comps))
}
)
})
unlink(tmp_adj)
showNotification(paste0("Sales grid saved to: ", out_path,
" (", length(comp_rows), " comps, ",
ceiling(length(comp_rows) / 3), " sheets)"),
type = "message", duration = 10)
session$sendCustomMessage("download_check",
list(id = "sales_grid_btn"))
}, error = function(e) {
showNotification(paste("Sales grid error:", e$message),
type = "error", duration = 10)
})
})
# --- Export Data (Excel) ---
export_data_filename_ <- function() {
base <- tools::file_path_sans_ext(rv$file_name %||% "data")
paste0(base, "_modified_", format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx")
}
observeEvent(input$export_data, {
req(rv$data)
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
out_path <- file.path(folder, export_data_filename_())
export_data_content_(out_path, "export_data")
showNotification(paste0("Output saved to: ", out_path),
type = "message", duration = 8)
})
observeEvent(input$export_data_nonadj, {
req(rv$data)
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
out_path <- file.path(folder, export_data_filename_())
export_data_content_(out_path, "export_data_nonadj")
showNotification(paste0("Output saved to: ", out_path),
type = "message", duration = 8)
})
export_data_content_ <- function(file, btn_id = "export_data") {
tryCatch({
req(rv$data)
if (!requireNamespace("writexl", quietly = TRUE)) {
showNotification(
"Package 'writexl' required. Install with: install.packages('writexl')",
type = "error", duration = 10)
return()
}
export_df <- rv$data
# --- Append model columns if a model is fitted ---
if (!is.null(rv$result)) {
model <- rv$result$model
targets <- rv$result$target
eq <- format_model_equation(rv$result)
# Find living_area column from specials
la_col <- NULL
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "living_area" && nm %in% names(export_df)) {
la_col <- nm
break
}
}
}
multi <- length(targets) > 1L
# Align factor levels in export_df with training data so predict() works
# for rows with unseen levels, predictions will be NA
train_df <- rv$result$data
pred_df <- export_df
for (col in names(train_df)) {
if (is.factor(train_df[[col]]) && col %in% names(pred_df)) {
pred_df[[col]] <- factor(pred_df[[col]],
levels = levels(train_df[[col]]))
}
}
pred_mat <- stats::predict(model, newdata = pred_df)
for (ri in seq_along(targets)) {
tgt <- targets[ri]
suffix <- if (multi) paste0("_", ri) else ""
# Get equation groups for this response
if (multi) {
eq_ri <- eq$equations[[ri]]
} else {
eq_ri <- eq
}
groups <- eq_ri$groups
# --- est_<target> from predict() ---
actual <- export_df[[tgt]]
# In appraisal mode, subject (row 1) has no real sale price
if (input$purpose == "appraisal" && nrow(export_df) >= 1L) {
actual[1L] <- NA_real_
}
predicted <- if (multi) as.numeric(pred_mat[, ri]) else as.numeric(pred_mat)
est_col <- paste0("est_", tgt)
export_df[[est_col]] <- round(predicted, 1)
# residual = actual - predicted (from model)
resid_col <- paste0("residual", suffix)
export_df[[resid_col]] <- round(actual - predicted, 1)
# CQA: % of comps with smaller signed residual / 10
# Large positive residual = high CQA (~10), large negative = low CQA (~0)
resid_vals <- export_df[[resid_col]]
n_valid <- sum(!is.na(resid_vals))
cqa_col <- paste0("cqa", suffix)
cqa_vals <- vapply(resid_vals, function(r) {
if (is.na(r)) return(NA_real_)
sum(resid_vals < r, na.rm = TRUE) / n_valid * 10
}, numeric(1))
export_df[[cqa_col]] <- round(cqa_vals, 2)
# residual_sf = residual / living_area
if (!is.null(la_col)) {
la <- export_df[[la_col]]
resid_sf_col <- paste0("residual_sf", suffix)
export_df[[resid_sf_col]] <- round(export_df[[resid_col]] / la, 1)
# CQA_SF: % of comps with smaller signed residual_sf / 10
resid_sf_vals <- export_df[[resid_sf_col]]
n_valid_sf <- sum(!is.na(resid_sf_vals))
cqa_sf_col <- paste0("cqa_sf", suffix)
cqa_sf_vals <- vapply(resid_sf_vals, function(r) {
if (is.na(r)) return(NA_real_)
sum(resid_sf_vals < r, na.rm = TRUE) / n_valid_sf * 10
}, numeric(1))
export_df[[cqa_sf_col]] <- round(cqa_sf_vals, 2)
}
# --- Per-g-function contributions ---
intercept_group <- NULL
contrib_groups <- list()
for (grp in groups) {
if (grp$degree == 0L) {
intercept_group <- grp
} else {
contrib_groups <- c(contrib_groups, list(grp))
}
}
# Basis (intercept) contribution — constant for all rows
basis_val <- if (!is.null(intercept_group)) {
intercept_group$terms[[1]]$coefficient
} else {
0
}
contrib_total <- rep(basis_val, nrow(export_df))
for (grp in contrib_groups) {
col_label <- gsub(" ", "_", grp$label)
col_name <- paste0(col_label, "_contribution", suffix)
contrib <- earthUI:::eval_g_function_(model, grp, pred_df,
response_idx = if (multi) ri else NULL)
export_df[[col_name]] <- round(contrib, 1)
contrib_total <- contrib_total + contrib
}
export_df[[paste0("basis", suffix)]] <- round(basis_val, 1)
# calc_residual = actual - (basis + all contributions)
calc_resid_col <- paste0("calc_residual", suffix)
export_df[[calc_resid_col]] <- round(actual - contrib_total, 1)
}
}
# Sort by residual_sf (or residual) descending for appraisal/market
if (input$purpose %in% c("appraisal", "market") && !is.null(rv$result)) {
has_subject <- (input$purpose == "appraisal") ||
(input$purpose == "market" && isTRUE(input$skip_subject_row))
sort_col <- if ("residual_sf" %in% names(export_df)) "residual_sf" else "residual"
if (sort_col %in% names(export_df)) {
if (has_subject && nrow(export_df) >= 2L) {
comps <- export_df[2:nrow(export_df), , drop = FALSE]
comps <- comps[order(comps[[sort_col]], decreasing = TRUE, na.last = TRUE), , drop = FALSE]
export_df <- rbind(export_df[1L, , drop = FALSE], comps)
} else {
export_df <- export_df[order(export_df[[sort_col]], decreasing = TRUE, na.last = TRUE), , drop = FALSE]
}
}
}
# Move ranking columns to the left: residual_sf, cqa_sf, residual, cqa
rank_cols <- c("residual_sf", "cqa_sf", "residual", "cqa")
rank_cols <- rank_cols[rank_cols %in% names(export_df)]
if (length(rank_cols) > 0L) {
other_cols <- setdiff(names(export_df), rank_cols)
export_df <- export_df[, c(rank_cols, other_cols), drop = FALSE]
}
# Write with openxlsx for cell formatting
wb <- openxlsx::createWorkbook()
openxlsx::addWorksheet(wb, "Data")
openxlsx::writeData(wb, "Data", export_df)
# Apply number formats to specific columns
col_names <- names(export_df)
fmt_map <- list(
residual_sf = "#,##0.00",
cqa_sf = "0.00",
residual = "#,##0",
cqa = "0.00"
)
for (cn in names(fmt_map)) {
ci <- match(cn, col_names)
if (!is.na(ci)) {
openxlsx::addStyle(wb, "Data",
style = openxlsx::createStyle(numFmt = fmt_map[[cn]]),
rows = 2:(nrow(export_df) + 1L), cols = ci,
gridExpand = TRUE, stack = TRUE)
}
}
openxlsx::saveWorkbook(wb, file, overwrite = TRUE)
session$sendCustomMessage("download_check", list(id = btn_id))
}, error = function(e) {
msg <- paste("Download error:", conditionMessage(e))
message(msg) # to R console
showNotification(msg, type = "error", duration = 15)
})
}
# --- RCA Raw Output ---
# Show modal when button is clicked
observeEvent(input$rca_output_btn, {
req(rv$result, input$purpose == "appraisal")
# Check if living_area is designated (for CQA_SF option)
has_la <- FALSE
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "living_area" && nm %in% names(rv$data)) {
has_la <- TRUE
break
}
}
}
cqa_choices <- c("CQA" = "cqa")
if (has_la) cqa_choices <- c(cqa_choices, "CQA per SF" = "cqa_sf")
showModal(modalDialog(
title = "RCA Raw Output — Subject CQA Score",
radioButtons("rca_cqa_type", "Score type:",
choices = cqa_choices, selected = "cqa", inline = TRUE),
numericInput("rca_cqa_value", "CQA score for subject (0.00–9.99):",
value = 5.00, min = 0, max = 9.99, step = 0.01),
footer = tagList(
modalButton("Cancel"),
actionButton("export_rca", "Generate", class = "btn-success")
),
size = "s"
))
})
# RCA download handler
observeEvent(input$export_rca, {
req(rv$data, rv$result, input$purpose == "appraisal", nrow(rv$data) >= 2L)
removeModal()
folder <- input$output_folder
if (is.null(folder) || !nzchar(folder)) folder <- path.expand("~/Downloads")
if (!dir.exists(folder)) dir.create(folder, recursive = TRUE)
base <- tools::file_path_sans_ext(rv$file_name %||% "data")
file <- file.path(folder, paste0(base, "_adjusted_",
format(Sys.time(), "%Y%m%d_%H%M%S"), ".xlsx"))
if (!requireNamespace("writexl", quietly = TRUE)) {
showNotification("Package 'writexl' required.", type = "error", duration = 10)
return()
}
tryCatch({
model <- rv$result$model
targets <- rv$result$target
tgt <- targets[1L]
eq <- format_model_equation(rv$result)
eq_ri <- if (length(targets) > 1L) eq$equations[[1L]] else eq
groups <- eq_ri$groups
multi <- length(targets) > 1L
ri <- 1L
# Find living_area column
la_col <- NULL
specials <- input$col_specials
if (!is.null(specials)) {
for (nm in names(specials)) {
if (specials[[nm]] == "living_area" && nm %in% names(rv$data)) {
la_col <- nm
break
}
}
}
export_df <- rv$data
# Align factor levels with training data
train_df <- rv$result$data
pred_df <- export_df
for (col in names(train_df)) {
if (is.factor(train_df[[col]]) && col %in% names(pred_df)) {
pred_df[[col]] <- factor(pred_df[[col]],
levels = levels(train_df[[col]]))
}
}
# --- Predict on all rows ---
pred_mat <- stats::predict(model, newdata = pred_df)
predicted <- if (multi) as.numeric(pred_mat[, ri]) else as.numeric(pred_mat)
export_df[[paste0("est_", tgt)]] <- round(predicted, 1)
# Actual sale prices (subject = NA)
actual <- export_df[[tgt]]
actual[1L] <- NA_real_
# Residuals for comps
residuals_val <- actual - predicted
export_df[["residual"]] <- round(residuals_val, 1)
# Per-SF residuals
if (!is.null(la_col)) {
la <- export_df[[la_col]]
export_df[["residual_sf"]] <- round(residuals_val / la, 1)
}
# CQA scores (comps only, subject = NA)
comp_resid <- residuals_val[-1L]
n_comps <- sum(!is.na(comp_resid))
cqa_all <- vapply(residuals_val, function(r) {
if (is.na(r)) return(NA_real_)
sum(comp_resid < r, na.rm = TRUE) / n_comps * 10
}, numeric(1))
export_df[["cqa"]] <- round(cqa_all, 2)
if (!is.null(la_col)) {
resid_sf_vals <- export_df[["residual_sf"]]
comp_resid_sf <- resid_sf_vals[-1L]
n_comps_sf <- sum(!is.na(comp_resid_sf))
cqa_sf_all <- vapply(resid_sf_vals, function(r) {
if (is.na(r)) return(NA_real_)
sum(comp_resid_sf < r, na.rm = TRUE) / n_comps_sf * 10
}, numeric(1))
export_df[["cqa_sf"]] <- round(cqa_sf_all, 2)
}
# --- Step A: Interpolate subject residual from user CQA ---
use_sf <- (input$rca_cqa_type == "cqa_sf" && !is.null(la_col))
user_cqa <- input$rca_cqa_value
if (use_sf) {
comp_cqa_vals <- export_df[["cqa_sf"]][-1L]
comp_resid_for_interp <- export_df[["residual_sf"]][-1L]
} else {
comp_cqa_vals <- export_df[["cqa"]][-1L]
comp_resid_for_interp <- export_df[["residual"]][-1L]
}
# Remove NAs, sort by CQA ascending for interpolation
valid <- !is.na(comp_cqa_vals) & !is.na(comp_resid_for_interp)
cqa_sorted <- comp_cqa_vals[valid]
resid_sorted <- comp_resid_for_interp[valid]
ord <- order(cqa_sorted)
cqa_sorted <- cqa_sorted[ord]
resid_sorted <- resid_sorted[ord]
# Linear interpolation
subject_resid <- stats::approx(cqa_sorted, resid_sorted,
xout = user_cqa, rule = 2)$y
if (use_sf) {
# Convert per-SF residual back to total residual
subject_la <- export_df[[la_col]][1L]
subject_resid_total <- subject_resid * subject_la
} else {
subject_resid_total <- subject_resid
}
subject_est <- predicted[1L] + subject_resid_total
actual[1L] <- subject_est
residuals_val[1L] <- subject_resid_total
export_df[["residual"]][1L] <- round(subject_resid_total, 1)
export_df[[paste0("est_", tgt)]][1L] <- round(predicted[1L], 1)
export_df[["subject_value"]] <- NA_real_
export_df[["subject_value"]][1L] <- round(subject_est, 1)
export_df[["subject_cqa"]] <- NA_real_
export_df[["subject_cqa"]][1L] <- user_cqa
if (use_sf && !is.null(la_col)) {
export_df[["residual_sf"]][1L] <- round(subject_resid, 1)
}
# For weight-0 rows (rows 2+): use subject_value (est + subject residual)
# so the last 4 RCA columns can be computed.
# Sale price is left as-is; subject_value holds the conclusion.
zero_wt <- integer(0)
if (!is.null(input$weights_col) && input$weights_col != "null" &&
input$weights_col %in% names(export_df)) {
wvals <- export_df[[input$weights_col]]
message("earthUI RCA: weight col class=", class(wvals),
", unique vals=", paste(head(sort(unique(wvals)), 10), collapse=","),
", n_zero=", sum(wvals == 0, na.rm = TRUE),
", n_na=", sum(is.na(wvals)))
zero_wt <- which(wvals == 0)
}
if (length(zero_wt) > 0L) {
sv <- predicted[zero_wt] + subject_resid_total
export_df[["subject_value"]][zero_wt] <- round(sv, 1)
actual[zero_wt] <- sv
residuals_val <- actual - predicted
export_df[["residual"]][zero_wt] <- round(residuals_val[zero_wt], 1)
if (!is.null(la_col)) {
la <- export_df[[la_col]]
export_df[["residual_sf"]][zero_wt] <- round(residuals_val[zero_wt] / la[zero_wt], 1)
}
}
# --- Step B: Per-g-function contributions and adjustments ---
intercept_group <- NULL
contrib_groups <- list()
for (grp in groups) {
if (grp$degree == 0L) {
intercept_group <- grp
} else {
contrib_groups <- c(contrib_groups, list(grp))
}
}
basis_val <- if (!is.null(intercept_group)) {
intercept_group$terms[[1]]$coefficient
} else {
0
}
export_df[["basis"]] <- round(basis_val, 1)
# Compute contributions for all rows, then adjustments = subject - comp
adj_sum <- rep(0, nrow(export_df))
gross_sum <- rep(0, nrow(export_df))
contrib_labels <- character(0)
for (grp in contrib_groups) {
col_label <- gsub(" ", "_", grp$label)
contrib_col <- paste0(col_label, "_contribution")
adj_col <- paste0(col_label, "_adjustment")
contrib <- earthUI:::eval_g_function_(model, grp, pred_df,
response_idx = if (multi) ri else NULL)
export_df[[contrib_col]] <- round(contrib, 1)
# Adjustment = subject contribution - comp contribution
subject_contrib <- contrib[1L]
adjustment <- subject_contrib - contrib
export_df[[adj_col]] <- round(adjustment, 1)
adj_sum <- adj_sum + adjustment
gross_sum <- gross_sum + abs(adjustment)
contrib_labels <- c(contrib_labels, col_label)
}
# residual_adjustment = subject residual - comp residual
resid_adj <- subject_resid_total - residuals_val
export_df[["residual_adjustment"]] <- round(resid_adj, 1)
adj_sum <- adj_sum + resid_adj
gross_sum <- gross_sum + abs(resid_adj)
# adjusted_sale_price = sale_price + net_adjustments
# Use 'actual' which has imputed prices for weight-0 rows
export_df[["net_adjustments"]] <- round(adj_sum, 1)
export_df[["gross_adjustments"]] <- round(gross_sum, 1)
# Percentage columns (adjustment / comparable sale price)
export_df[["residual_pct"]] <- round(resid_adj / actual, 4)
export_df[["net_adj_pct"]] <- round(adj_sum / actual, 4)
export_df[["gross_adj_pct"]] <- round(gross_sum / actual, 4)
export_df[["adjusted_sale_price"]] <- round(actual + adj_sum, 1)
# --- Additional targets (e.g., rent) for weight-0 rows only ---
message("earthUI RCA: multi=", multi, ", length(targets)=", length(targets),
", length(zero_wt)=", length(zero_wt),
", weights_col=", input$weights_col %||% "NULL")
if (multi && length(zero_wt) > 0L) {
for (ri2 in 2:length(targets)) {
tgt2 <- targets[ri2]
eq_ri2 <- eq$equations[[ri2]]
groups2 <- eq_ri2$groups
# Column name prefix for this target (e.g., "rent")
tp <- tgt2
# Predictions for this target (all rows)
predicted2 <- as.numeric(pred_mat[, ri2])
export_df[[paste0("est_", tp)]] <- round(predicted2, 1)
# Residuals for comps with weight > 0 (for CQA interpolation)
actual2 <- export_df[[tgt2]]
actual2[1L] <- NA_real_
resid2 <- actual2 - predicted2
# CQA on this target (comps with weight > 0 only)
comp_resid2 <- resid2[-1L]
comp_resid2_valid <- comp_resid2[!is.na(comp_resid2)]
n_comps2 <- length(comp_resid2_valid)
cqa2 <- vapply(resid2, function(r) {
if (is.na(r)) return(NA_real_)
sum(comp_resid2_valid < r, na.rm = TRUE) / n_comps2 * 10
}, numeric(1))
# Interpolate subject residual for this target using same CQA score
if (use_sf) {
resid2_sf <- resid2 / la
comp_cqa2 <- cqa2[-1L]
comp_resid2_interp <- resid2_sf[-1L]
} else {
comp_cqa2 <- cqa2[-1L]
comp_resid2_interp <- resid2[-1L]
}
valid2 <- !is.na(comp_cqa2) & !is.na(comp_resid2_interp)
cqa2_sorted <- comp_cqa2[valid2]
resid2_sorted <- comp_resid2_interp[valid2]
ord2 <- order(cqa2_sorted)
cqa2_sorted <- cqa2_sorted[ord2]
resid2_sorted <- resid2_sorted[ord2]
subj_resid2 <- stats::approx(cqa2_sorted, resid2_sorted,
xout = user_cqa, rule = 2)$y
if (use_sf) {
subj_resid2_total <- subj_resid2 * export_df[[la_col]][1L]
} else {
subj_resid2_total <- subj_resid2
}
# Subject value for this target
subj_est2 <- predicted2[1L] + subj_resid2_total
sv_col <- paste0("subject_", tp, "_value")
export_df[[sv_col]] <- NA_real_
export_df[[sv_col]][1L] <- round(subj_est2, 1)
# Weight-0 rows: impute actual from est + subject residual
sv2 <- predicted2[zero_wt] + subj_resid2_total
export_df[[sv_col]][zero_wt] <- round(sv2, 1)
actual2[1L] <- subj_est2
actual2[zero_wt] <- sv2
resid2 <- actual2 - predicted2
export_df[[paste0(tp, "_residual")]] <- round(resid2, 1)
# Per-g-function contributions and adjustments for this target
intercept2 <- NULL
contrib_groups2 <- list()
for (grp in groups2) {
if (grp$degree == 0L) {
intercept2 <- grp
} else {
contrib_groups2 <- c(contrib_groups2, list(grp))
}
}
basis2 <- if (!is.null(intercept2)) intercept2$terms[[1]]$coefficient else 0
export_df[[paste0(tp, "_basis")]] <- round(basis2, 1)
adj_sum2 <- rep(0, nrow(export_df))
gross_sum2 <- rep(0, nrow(export_df))
for (grp in contrib_groups2) {
col_label <- gsub(" ", "_", grp$label)
contrib_col2 <- paste0(tp, "_", col_label, "_contribution")
adj_col2 <- paste0(tp, "_", col_label, "_adjustment")
contrib2 <- earthUI:::eval_g_function_(model, grp, pred_df,
response_idx = ri2)
export_df[[contrib_col2]] <- round(contrib2, 1)
subj_contrib2 <- contrib2[1L]
adj2 <- subj_contrib2 - contrib2
export_df[[adj_col2]] <- round(adj2, 1)
adj_sum2 <- adj_sum2 + adj2
gross_sum2 <- gross_sum2 + abs(adj2)
}
resid_adj2 <- subj_resid2_total - resid2
export_df[[paste0(tp, "_residual_adjustment")]] <- round(resid_adj2, 1)
adj_sum2 <- adj_sum2 + resid_adj2
gross_sum2 <- gross_sum2 + abs(resid_adj2)
export_df[[paste0(tp, "_net_adjustments")]] <- round(adj_sum2, 1)
export_df[[paste0(tp, "_gross_adjustments")]] <- round(gross_sum2, 1)
# Percentage columns for additional targets
export_df[[paste0(tp, "_residual_pct")]] <- round(resid_adj2 / actual2, 4)
export_df[[paste0(tp, "_net_adj_pct")]] <- round(adj_sum2 / actual2, 4)
export_df[[paste0(tp, "_gross_adj_pct")]] <- round(gross_sum2 / actual2, 4)
export_df[[paste0("adjusted_", tp)]] <- round(actual2 + adj_sum2, 1)
}
}
writexl::write_xlsx(export_df, file)
rv$rca_df <- export_df
rv$rca_targets <- targets
session$sendCustomMessage("download_check", list(id = "rca_output_btn"))
showNotification(paste0("RCA output saved to: ", file),
type = "message", duration = 8)
}, error = function(e) {
msg <- paste("RCA export error:", conditionMessage(e))
message(msg)
showNotification(msg, type = "error", duration = 15)
})
})
}
Try the earthUI 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.