Nothing
inst/shiny/dendroAnalystApp/app.R
In dendRoAnalyst: A Tool for Processing and Analyzing Dendrometer Data
# dendRoAnalyst Shiny application
# Place this file in: inst/shiny/dendroAnalystApp/app.R
options(shiny.maxRequestSize = 500 * 1024^2)
required_pkgs <- c("shiny", "bslib", "DT", "ggplot2", "tools", "shinyFiles")
missing_pkgs <- required_pkgs[!vapply(required_pkgs, requireNamespace, logical(1), quietly = TRUE)]
if (length(missing_pkgs) > 0) {
stop("Please install required packages before running the app: ", paste(missing_pkgs, collapse = ", "), call. = FALSE)
}
suppressPackageStartupMessages({
library(shiny)
library(bslib)
library(DT)
library(ggplot2)
library(shinyFiles)
})
`%||%` <- function(x, y) if (is.null(x) || length(x) == 0) y else x
app_pkg <- "dendRoAnalyst"
pkg_fun <- function(name) {
if (exists(name, mode = "function", inherits = TRUE)) {
return(get(name, mode = "function", inherits = TRUE))
}
if (requireNamespace(app_pkg, quietly = TRUE) && exists(name, envir = asNamespace(app_pkg), mode = "function", inherits = FALSE)) {
return(get(name, envir = asNamespace(app_pkg), mode = "function", inherits = FALSE))
}
stop("Function '", name, "' was not found. Make sure ", app_pkg, " is loaded and the function is exported.", call. = FALSE)
}
has_fun <- function(name) {
exists(name, mode = "function", inherits = TRUE) ||
(requireNamespace(app_pkg, quietly = TRUE) && exists(name, envir = asNamespace(app_pkg), mode = "function", inherits = FALSE))
}
null_if_blank <- function(x) {
if (is.null(x)) return(NULL)
x <- trimws(as.character(x))
if (!length(x) || !nzchar(x) || identical(tolower(x), "null")) return(NULL)
x
}
parse_col <- function(x, default = NULL) {
x <- null_if_blank(x)
if (is.null(x)) return(default)
n <- suppressWarnings(as.integer(x))
if (!is.na(n) && grepl("^[0-9]+$", x)) return(n)
x
}
parse_num_vec <- function(x, default = NULL) {
x <- null_if_blank(x)
if (is.null(x)) return(default)
x <- gsub("c\\(|\\)", "", x)
x <- gsub(";", ",", x)
parts <- unlist(strsplit(x, "[,[:space:]]+"))
parts <- parts[nzchar(parts)]
out <- suppressWarnings(as.numeric(parts))
out <- out[!is.na(out)]
if (!length(out)) return(default)
out
}
parse_int <- function(x, default = NULL) {
out <- parse_num_vec(x, default = default)
if (is.null(out)) return(default)
as.integer(out[1])
}
parse_chr_vec <- function(x, default = NULL, allow_all = TRUE) {
x <- null_if_blank(x)
if (is.null(x)) return(default)
if (allow_all && identical(tolower(x), "all")) return("all")
x <- gsub("c\\(|\\)", "", x)
x <- gsub("['\"]", "", x)
parts <- unlist(strsplit(x, "[,;]+"))
parts <- trimws(parts)
parts <- parts[nzchar(parts)]
if (!length(parts)) return(default)
parts
}
parse_bool <- function(x) isTRUE(x)
parse_tree <- function(x) {
x <- null_if_blank(x)
if (is.null(x) || identical(tolower(x), "all")) return("all")
n <- suppressWarnings(as.numeric(unlist(strsplit(gsub(";", ",", x), "[,[:space:]]+"))))
n <- n[!is.na(n)]
if (length(n) > 0) return(as.integer(n))
parse_chr_vec(x, default = "all", allow_all = TRUE)
}
nice_name <- function(x) {
x <- gsub("[^A-Za-z0-9_]+", "_", x)
x <- gsub("_+", "_", x)
x <- gsub("^_|_$", "", x)
if (!nzchar(x)) x <- "result"
x
}
first_table <- function(x) {
if (is.data.frame(x)) return(x)
if (is.list(x)) {
preferred <- c(
"data", "detrended_data", "standardized_data", "results", "summary",
"daily_data", "ZG_phase", "ZG_cycle", "SC_phase", "SC_cycle",
"fitted_data", "fit_statistics", "evaluation", "detrended_long",
"parameters", "reconstructed_long", "reconstructed_wide",
"trajectory_summary", "id_summary", "period_info", "gap_info",
"assessment", "selected_ids", "phase_table", "long_data"
)
for (nm in preferred) {
if (!is.null(x[[nm]]) && is.data.frame(x[[nm]])) return(x[[nm]])
}
dfs <- Filter(is.data.frame, x)
if (length(dfs) > 0) return(dfs[[1]])
}
NULL
}
all_tables <- function(x) {
if (is.data.frame(x)) return(list(data = x))
if (!is.list(x)) return(list())
out <- Filter(is.data.frame, x)
if (length(out) == 0) {
ft <- first_table(x)
if (!is.null(ft)) out <- list(data = ft)
}
out
}
object_preview <- function(x, n = 5000) {
tab <- first_table(x)
if (is.null(tab)) return(NULL)
tab <- as.data.frame(tab)
if (nrow(tab) > n) tab <- tab[seq_len(n), , drop = FALSE]
tab
}
# Keep component paths visible; never flatten a model into a misleading table.
export_tables <- function(x) {
out <- list()
visit <- function(value, path = "data", depth = 0L) {
if (is.data.frame(value) || is.matrix(value)) {
out[[length(out) + 1L]] <<- as.data.frame(value)
names(out)[length(out)] <<- path
} else if (is.list(value) && depth < 20L &&
!inherits(value, c("ggplot", "lm", "glm", "nls"))) {
for (i in seq_along(value)) {
label <- names(value)[i]
if (is.null(label) || is.na(label) || !nzchar(label)) label <- paste0("[[", i, "]]")
visit(value[[i]], paste(path, label, sep = " / "), depth + 1L)
}
}
}
visit(x)
names(out) <- make.unique(names(out))
out
}
write_export_table <- function(tab, file, format) {
if (any(vapply(tab, is.list, logical(1)))) {
stop("This table contains list columns. Choose another component or save the complete result as RDS.", call. = FALSE)
}
if (format == "xlsx") {
if (!requireNamespace("writexl", quietly = TRUE)) stop("Install writexl to export Excel files.", call. = FALSE)
writexl::write_xlsx(tab, file)
} else if (format == "tsv") {
utils::write.table(tab, file, sep = "\t", row.names = FALSE, na = "")
} else safe_write_csv(tab, file)
}
safe_write_csv <- function(x, file) {
utils::write.csv(as.data.frame(x), file, row.names = FALSE, na = "")
}
save_plot <- function(expr, file, width = 10, height = 7, dpi = 160) {
grDevices::png(filename = file, width = width, height = height, units = "in", res = dpi)
on.exit(grDevices::dev.off(), add = TRUE)
p <- expr()
if (inherits(p, "ggplot")) {
print(p)
}
}
safe_call <- function(fun_name, args = list(), label = fun_name) {
fun <- pkg_fun(fun_name)
withCallingHandlers(
tryCatch(
do.call(fun, args),
error = function(e) {
stop("Error while running ", label, ": ", conditionMessage(e), call. = FALSE)
}
),
warning = function(w) {
invokeRestart("muffleWarning")
}
)
}
read_uploaded_table <- function(path, sheet = NULL, sep = NULL, dec = NULL) {
ext <- tolower(tools::file_ext(path))
sep <- sep %||% NULL
dec <- dec %||% "."
if (ext %in% c("xlsx", "xls")) {
if (!requireNamespace("readxl", quietly = TRUE)) stop("Package 'readxl' is required to read Excel files.")
return(as.data.frame(readxl::read_excel(path, sheet = sheet %||% 1)))
}
if (is.null(sep)) sep <- guess_sep(path, ext)
utils::read.table(path, header = TRUE, sep = sep, dec = dec, quote = "\"'", stringsAsFactors = FALSE,
check.names = FALSE, comment.char = "", na.strings = c("NA", ""))
}
# Detect the delimiter from the header line (comma, semicolon or tab; whitespace otherwise)
guess_sep <- function(path, ext = tolower(tools::file_ext(path))) {
if (ext == "tsv") return("\t")
first <- readLines(path, n = 1L, warn = FALSE)
if (!length(first)) return("")
counts <- vapply(c(",", ";", "\t"), function(s) lengths(regmatches(first, gregexpr(s, first, fixed = TRUE))), numeric(1))
if (max(counts) == 0) return("")
names(counts)[which.max(counts)]
}
call_read_dendrometer <- function(file, sep, dec, datetime_col, date_col, time_col, tz, sheet, range) {
if (has_fun("read.dendrometer")) {
out <- pkg_fun("read.dendrometer")(
file = file,
sep = null_if_blank(sep),
dec = null_if_blank(dec),
datetime_col = parse_col(datetime_col, 1),
date_col = parse_col(date_col, NULL),
time_col = parse_col(time_col, NULL),
tz = tz,
sheet = parse_col(sheet, NULL),
range = null_if_blank(range),
detect_resolution = TRUE,
return_report = FALSE,
quiet = TRUE
)
if (is.list(out) && !is.null(out$data)) return(out$data)
return(out)
}
read_uploaded_table(file, sheet = parse_col(sheet, NULL), sep = null_if_blank(sep), dec = null_if_blank(dec))
}
call_read_climate <- function(file, sep, dec, time_col, vars, tz, sheet) {
if (has_fun("read.climate")) {
out <- pkg_fun("read.climate")(
x = file,
time_col = parse_col(time_col, NULL),
vars = parse_chr_vec(vars, NULL),
sep = null_if_blank(sep),
dec = null_if_blank(dec),
sheet = parse_col(sheet, 1),
tz = tz,
detect_resolution = TRUE,
return_report = FALSE,
verbose = FALSE
)
if (is.list(out) && !is.null(out$data)) return(out$data)
return(out)
}
read_uploaded_table(file, sheet = parse_col(sheet, NULL), sep = null_if_blank(sep), dec = null_if_blank(dec))
}
# -------------------------------------------------------------------------
# Working-directory helpers
# -------------------------------------------------------------------------
app_supported_ext <- c("csv", "txt", "tsv", "xlsx", "xls", "rds", "rda", "rdata")
normalize_user_path <- function(path) {
path <- null_if_blank(path)
if (is.null(path)) return(NULL)
path <- path.expand(path)
normalizePath(path, winslash = "/", mustWork = FALSE)
}
wd_roots <- function() {
roots <- c(
Home = path.expand("~"),
Current = getwd(),
Temp = tempdir()
)
if (.Platform$OS.type == "windows") {
drive_paths <- paste0(LETTERS, ":/")
drive_paths <- drive_paths[dir.exists(drive_paths)]
if (length(drive_paths)) {
roots <- c(roots, stats::setNames(drive_paths, paste0("Drive ", substr(drive_paths, 1, 1))))
}
} else {
extra <- c(Root = "/")
for (d in c("/home", "/Users", "/mnt", "/media", "/Volumes")) {
if (dir.exists(d)) extra <- c(extra, stats::setNames(d, basename(d)))
}
roots <- c(roots, extra)
}
roots <- roots[!is.na(roots) & nzchar(roots)]
roots <- stats::setNames(normalizePath(roots, winslash = "/", mustWork = FALSE), names(roots))
roots <- roots[!duplicated(roots)]
roots[dir.exists(roots)]
}
wd_file_choices <- function(path) {
path <- normalize_user_path(path)
if (is.null(path) || !dir.exists(path)) return(c("Set working directory first" = ""))
files <- list.files(path, pattern = paste0("\\.(", paste(app_supported_ext, collapse = "|"), ")$"), ignore.case = TRUE, full.names = FALSE)
files <- sort(files)
results <- file.path(path, "dendroAnalyst_results")
if (dir.exists(results)) files <- c(files, file.path("dendroAnalyst_results",
list.files(results, pattern = "\\.(rds|csv|tsv|xlsx)$", ignore.case = TRUE)))
if (!length(files)) return(c("No supported files found" = ""))
c("Choose file" = "", stats::setNames(files, files))
}
initial_app_wd <- function() {
wd <- getOption("dendRoAnalyst.working_dir", getwd())
wd <- normalize_user_path(wd)
if (is.null(wd) || !dir.exists(wd)) wd <- normalize_user_path(getwd())
wd
}
load_r_object_file <- function(path) {
ext <- tolower(tools::file_ext(path))
if (ext == "rds") return(readRDS(path))
if (ext %in% c("rda", "rdata")) {
env <- new.env(parent = emptyenv())
nm <- load(path, envir = env)
if (!length(nm)) stop("No object found inside ", basename(path), call. = FALSE)
return(env[[nm[1]]])
}
stop("Not an R object file: ", basename(path), call. = FALSE)
}
ui <- bslib::page_navbar(
title = tags$div(class = "dendro-brand", tags$img(src = "dendroanalyst-logo-wood.png", alt = "", class = "dendro-brand-icon"), tags$span("dendRoAnalyst", class = "dendro-brand-name")),
theme = bslib::bs_theme(
version = 5,
bootswatch = "minty",
primary = "#795238",
secondary = "#8a6040",
success = "#795238",
base_font = "sans-serif",
heading_font = "sans-serif"
),
header = tags$head(tags$link(rel = "stylesheet", type = "text/css", href = "custom.css?v=5")),
bslib::nav_panel(
"0. Settings",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
h4("Working directory"),
helpText("* Required input for the selected operation. Some required inputs have defaults."),
tags$details(tags$summary("Plot size and text (all tabs)"),
numericInput("plot_width", "Width (inches) *", 10, min = 2, max = 30),
numericInput("plot_height", "Height (inches) *", 7, min = 2, max = 30),
numericInput("plot_dpi", "Export resolution (DPI) *", 160, min = 72, max = 600),
numericInput("plot_font", "Font size (points) *", 12, min = 6, max = 36),
helpText("Previews use 96 DPI. PNG downloads and saved plots use the export DPI.")),
shinyFiles::shinyDirButton(
id = "browse_wd",
label = "Browse folders...",
title = "Select working directory",
buttonType = "default",
class = "btn-outline-primary w-100"
),
tags$small(class = "text-muted", "The folder browser shows folders on the machine where the Shiny app is running."),
tags$hr(),
textInput("wd_path", "Selected folder path *", value = initial_app_wd(), width = "100%"),
checkboxInput("wd_create", "Create folder if it does not exist", TRUE),
checkboxInput("wd_set_session", "Also call setwd() for this R session", FALSE),
actionButton("set_wd", "Set as working directory", class = "btn-success w-100"),
tags$hr(),
actionButton("refresh_wd_files", "Refresh file list", class = "btn-outline-secondary w-100")
),
bslib::layout_columns(
col_widths = c(5, 7),
bslib::card(
class = "shadow-card",
bslib::card_header("Current working directory"),
verbatimTextOutput("wd_status"),
tags$hr(),
strong("Results folder"),
verbatimTextOutput("wd_results_dir")
),
bslib::card(
class = "shadow-card",
bslib::card_header("Files available in working directory"),
DTOutput("wd_files_table")
)
)
)
),
bslib::nav_panel(
"1. Data",
tags$div(class = "data-import-grid",
bslib::card(
class = "shadow-card data-import-card", fill = FALSE,
bslib::card_header("Dendrometer data *"),
fileInput("dm_file", "Upload dendrometer file", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
tags$div(class = "data-fields",
textInput("dm_sep", "Delimiter", value = "", placeholder = "auto"),
textInput("dm_dec", "Decimal mark", value = "", placeholder = "auto"),
textInput("dm_tz", "Time zone", value = "UTC")
),
tags$div(class = "data-fields",
textInput("dm_datetime_col", "Datetime column", value = "1"),
textInput("dm_date_col", "Date column", value = ""),
textInput("dm_time_col", "Time column", value = "")
),
tags$div(class = "data-fields",
textInput("dm_sheet", "Excel sheet", value = ""),
textInput("dm_range", "Excel range", value = "")
),
tags$hr(),
selectInput("wd_dm_file", "Or choose existing file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_dm", "Load selected dendrometer file", class = "btn-outline-success w-100"),
tags$hr(),
actionButton("read_dm", "Load uploaded dendrometer data", class = "btn-success w-100")
),
bslib::card(
class = "shadow-card data-import-card", fill = FALSE,
bslib::card_header("Climate data"),
fileInput("clim_file", "Upload climate file", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
tags$div(class = "data-fields",
textInput("clim_sep", "Delimiter", value = "", placeholder = "auto"),
textInput("clim_dec", "Decimal mark", value = "", placeholder = "auto"),
textInput("clim_tz", "Time zone", value = "UTC")
),
tags$div(class = "data-fields",
textInput("clim_time_col", "Time column", value = ""),
textInput("clim_vars", "Climate variables", value = "", placeholder = "temp,VPD,prec")
),
textInput("clim_sheet", "Excel sheet", value = "1"),
tags$hr(),
selectInput("wd_clim_file", "Or choose existing file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_clim", "Load selected climate file", class = "btn-outline-success w-100"),
tags$hr(),
actionButton("read_clim", "Load uploaded climate data", class = "btn-success w-100")
),
bslib::card(
class = "shadow-card data-import-card", fill = FALSE,
bslib::card_header("Reference network / metadata"),
fileInput("ref_file", "Reference dendrometer network *", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
selectInput("wd_ref_file", "Or choose reference file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_ref", "Load selected reference file", class = "btn-outline-success w-100"),
actionButton("read_ref", "Load uploaded reference network", class = "btn-outline-success w-100"),
tags$hr(),
fileInput("meta_file", "Tree metadata for grouping", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
selectInput("wd_meta_file", "Or choose metadata file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_meta", "Load selected metadata file", class = "btn-outline-success w-100"),
actionButton("read_meta", "Load uploaded metadata", class = "btn-outline-success w-100")
)
),
tags$div(class = "data-preview-grid",
bslib::card(bslib::card_header("Dendrometer preview"), DTOutput("dm_preview")),
bslib::card(bslib::card_header("Climate preview"), DTOutput("clim_preview"))
)
),
bslib::nav_panel(
"2. Preprocess",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("pre_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
actionButton("detect_resolution", "Detect resolution", class = "btn-outline-primary w-100"),
verbatimTextOutput("resolution_txt"),
tags$hr(),
h5("Truncate"),
textInput("truncate_year", "Calendar year(s)", value = "", placeholder = "2017 or 2017,2019"),
textInput("truncate_doy", "DOY window", value = "", placeholder = "120,300"),
actionButton("run_truncate", "Run truncation", class = "btn-success w-100"),
tags$hr(),
h5("Resample"),
textInput("resample_by", "Target resolution *", value = "D", placeholder = "30M, H, D, W, ME"),
selectInput("resample_value", "Aggregation", choices = c("mean", "max", "min", "sum", "count")),
selectInput("resample_method", "Method", choices = c("auto", "aggregate", "interpolate")),
actionButton("run_resample", "Run resampling", class = "btn-success w-100"),
tags$hr(),
h5("Missing values"),
numericInput("na_resolution", "Resolution in minutes *", value = 60, min = 1),
checkboxInput("na_fill", "Fill missing values", TRUE),
selectInput("na_method", "Interpolation method", choices = c("spline", "seasonal")),
checkboxInput("na_assess", "Assess interpolation", FALSE),
actionButton("run_na", "Detect/interpolate gaps", class = "btn-success w-100"),
tags$hr(),
h5("Network interpolation"),
helpText("Load a reference dendrometer network in 1. Data. The Input data selected above is the series to fill."),
selectInput("network_method", "Network method", choices = c("proportional", "linear")),
numericInput("network_boot", "Bootstrap samples", value = 100, min = 1, step = 1),
checkboxInput("network_pi", "Calculate prediction intervals", TRUE),
checkboxInput("network_assess", "Assess network interpolation", FALSE),
conditionalPanel("input.network_assess", textInput("network_lengths", "Assessment gap lengths (steps)", value = "1,2,4")),
checkboxInput("network_correct_jumps", "Correct jumps at filled gaps", FALSE),
conditionalPanel("input.network_correct_jumps", numericInput("network_jump_threshold", "Gap jump threshold", value = 0.05, min = 0.001, step = 0.01)),
actionButton("run_network", "Run network interpolation", class = "btn-success w-100"),
tags$hr(),
h5("Jump adjustment"),
selectInput("jump_detection", "Detection method", choices = c("manual", "auto")),
conditionalPanel("input.jump_detection === 'manual'", numericInput("jump_threshold", "Manual threshold", value = 1, min = 0, step = 0.01)),
conditionalPanel("input.jump_detection === 'auto'", numericInput("jump_penalty", "Auto penalty", value = 10, min = 0.01, step = 1)),
selectInput("jump_adjustment", "Adjustment method", choices = c("window_median", "point_diff")),
numericInput("jump_window", "Adjustment window", value = 5, min = 1, step = 1),
checkboxInput("jump_every_second", "Auto: keep every second changepoint", TRUE),
checkboxInput("jump_set_na", "Set exact jump point to NA", FALSE),
actionButton("run_jump_adjust", "Adjust jumps", class = "btn-success w-100"),
tags$hr(),
h5("Standardize"),
selectInput("std_season", "Season type", choices = c("NH", "SH", "CS")),
conditionalPanel("input.std_season === 'CS'", textInput("std_cs", "Custom season DOYs", value = "", placeholder = "100,280")),
selectInput("std_method", "Method", choices = c("center", "amplitude", "robust_amplitude", "minmax", "zscore", "robust_zscore", "percentile")),
actionButton("run_standardize", "Standardize", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_pre_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_pre_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_pre_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::card(
bslib::card_header("Preprocessing output"),
DTOutput("pre_table"),
tags$hr(),
plotOutput("pre_plot", height = 440),
downloadButton("download_pre_plot", "Download current plot")
)
)
),
bslib::nav_panel(
"3. Daily statistics",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("daily_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
textInput("daily_tree", "TreeNum *", value = "1", placeholder = "1, 1:3, or all"),
actionButton("run_daily", "Calculate daily.data()", class = "btn-success w-100"),
tags$hr(),
selectInput("daily_plot_type", "Plot type", choices = c("summary", "amplitude", "minmax_ribbon", "timing", "timing_violin", "lag", "change", "boxplot", "heatmap")),
conditionalPanel("['boxplot','heatmap'].includes(input.daily_plot_type)", selectInput("daily_stat", "Statistic", choices = c("amplitude", "Max_diff", "mean", "median", "Max", "Min", "lag_h", "Time_min_h", "Time_max_h"))),
conditionalPanel("input.daily_plot_type === 'boxplot'", selectInput("daily_by", "Boxplot grouping", choices = c("month", "month_of_year", "year"))),
conditionalPanel("input.daily_plot_type === 'boxplot'", selectInput("daily_box_style", "Box style", choices = c("boxplot", "violin", "both"))),
textInput("daily_year", "Year filter", value = ""),
textInput("daily_doy", "DOY filter", value = ""),
tags$hr(),
h5("Display and save"),
actionButton("show_daily_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_daily_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_daily_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Daily table"), DTOutput("daily_table")),
bslib::card(
bslib::card_header("Daily plot"),
plotOutput("daily_plot", height = 520),
downloadButton("download_daily_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"4. Phase analysis",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("phase_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
radioButtons("phase_method", "Method", choices = c("Zero-growth: phase.zg" = "zg", "Stem-cycle: phase.sc" = "sc"), inline = FALSE),
textInput("phase_tree", "TreeNum *", value = "1"),
numericInput("phase_smoothing", "Smoothing hours (blank/0 = none)", value = 0, min = 0),
conditionalPanel("input.phase_method === 'zg'", numericInput("phase_beta", "ZG beta for ABr", value = 1, min = 0, step = 0.05)),
actionButton("run_phase", "Run phase analysis", class = "btn-success w-100"),
tags$hr(),
uiOutput("phase_plot_controls"),
textInput("phase_year", "Year filter", value = ""),
textInput("phase_doy", "DOY filter", value = ""),
tags$hr(),
numericInput("twd_smoothing", "twd.maxima smoothing", value = 5, min = 1, max = 24),
actionButton("run_twd_maxima", "Run twd.maxima()", class = "btn-outline-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_phase_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_phase_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_phase_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Phase table"), DTOutput("phase_table")),
bslib::card(
bslib::card_header("Phase plot"),
plotOutput("phase_plot", height = 550),
tableOutput("phase_scatter_stats"),
downloadButton("download_phase_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"5. Growth models",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("growth_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
selectInput("growth_engine", "Task", choices = c("Single growth fit" = "single", "Double growth fit" = "double", "Compare methods" = "evaluate")),
textInput("growth_tree", "TreeNum *", value = "all"),
conditionalPanel("input.growth_engine === 'single'", selectInput("growth_method", "Single method", choices = c("gam", "gompertz", "logistic", "richards", "loess", "spline"))),
conditionalPanel("input.growth_engine === 'double'", selectInput("growth_double_method", "Double method", choices = c("gompertz", "richards"))),
conditionalPanel("input.growth_engine === 'evaluate'", checkboxGroupInput("growth_eval_methods", "Methods to compare", choices = c("gam", "gompertz", "logistic", "richards", "loess", "spline", "double_gompertz", "double_richards"), selected = c("gam", "gompertz", "loess", "spline"))),
selectInput("growth_year_mode", "Year mode", choices = c("yearly", "pooled")),
textInput("growth_years", "Vegetation seasons", value = "all"),
checkboxInput("growth_fit_gro", "Fit cumulative GRO", TRUE),
selectInput("growth_site_mode", "Season mode", choices = c("NH", "SH", "CS")),
conditionalPanel("input.growth_site_mode === 'CS'", textInput("growth_custom_season", "Custom season DOYs", value = "275,274")),
textInput("growth_fraction", "Growth fraction", value = "0.1,0.9"),
numericInput("growth_min_unique", "Minimum unique growth", value = 10, min = 3),
numericInput("growth_rate_threshold", "Rate threshold fraction", value = 0.1, min = 0, max = 1, step = 0.05),
checkboxInput("growth_fix_a", "Fix asymptote to observed maximum", FALSE),
actionButton("run_growth", "Run growth task", class = "btn-success w-100"),
tags$hr(),
selectInput("growth_plot_type", "Growth plot type", choices = c("fit", "season", "residuals", "timing", "overlay", "parameters", "boxplot", "mean", "heatmap")),
selectInput("growth_metric", "Evaluation metric", choices = c("rmse", "mae", "bias", "abs_bias", "r2", "correlation", "nrmse", "rss", "aic_approx", "bic_approx")),
selectInput("growth_x_axis", "X axis", choices = c("default", "season_day", "doy", "date")),
tags$hr(),
selectInput("detrend_object", "Growth-fit object to detrend", choices = c()),
actionButton("run_detrend", "Detrend selected fit", class = "btn-outline-success w-100"),
actionButton("run_mean_detrended", "Mean detrended series", class = "btn-outline-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_growth_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_growth_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_growth_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Growth result table"), DTOutput("growth_table")),
bslib::card(
bslib::card_header("Growth plot"),
plotOutput("growth_plot", height = 550),
downloadButton("download_growth_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"6. Climate",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
h5("Climate feature engineering"),
textInput("daily_mean_vars", "Daily mean vars", value = ""),
textInput("daily_min_vars", "Daily min vars", value = ""),
textInput("daily_max_vars", "Daily max vars", value = ""),
textInput("daily_sum_vars", "Daily sum vars", value = ""),
textInput("daily_median_vars", "Daily median vars", value = ""),
actionButton("run_daily_clim", "Create daily climate", class = "btn-success w-100"),
tags$hr(),
textInput("sub_mean_vars", "Subdaily mean vars", value = ""),
textInput("sub_sum_vars", "Subdaily sum vars", value = ""),
textInput("sub_lag_vars", "Subdaily lag vars", value = ""),
textInput("sub_roll_hours", "Rolling windows (h)", value = "3,6,24"),
actionButton("run_subdaily_clim", "Create subdaily climate", class = "btn-success w-100"),
tags$hr(),
h5("Attach climate"),
selectInput("clim_attach_object", "Dendrometer result object", choices = c()),
selectInput("clim_attach_scale", "Scale", choices = c("auto", "daily", "phase", "subdaily")),
actionButton("run_add_climate", "Attach climate", class = "btn-success w-100"),
tags$hr(),
h5("Adverse climate / TWD"),
selectInput("climtwd_source", "Dendrometer data *", choices = c("Upload dendrometer data first" = "__none__")),
selectInput("climtwd_daily_value", "Daily dendrometer value", choices = c("max", "mean", "min", "median")),
textInput("climtwd_var", "Climate variable *", value = "", placeholder = "e.g. prec (blank = first variable)"),
selectInput("climtwd_clim_fun", "Daily climate summary", choices = c("sum", "mean", "min", "max", "median")),
textInput("climtwd_threshold_clim", "Climate threshold *", value = "<10"),
textInput("climtwd_threshold_days", "Duration threshold *", value = ">5"),
actionButton("run_clim_twd", "Run clim.twd()", class = "btn-success w-100"),
selectInput("climtwd_stats_object", "clim.twd object *", choices = c()),
selectInput("climtwd_group", "Group by", choices = c("tree", "species", "site", "species_site")),
actionButton("run_climtwd_stats", "Summarize clim.twd", class = "btn-outline-success w-100"),
tags$hr(),
h5("Running correlation"),
selectInput("movcor_source", "Dendrometer data *", choices = c("Upload dendrometer data first" = "__none__")),
textInput("movcor_tree", "TreeNum *", value = "1"),
numericInput("movcor_win", "Window size", value = 21, min = 18),
selectInput("movcor_method", "Correlation", choices = c("pearson", "kendall", "spearman")),
textInput("movcor_vars", "Climate vars (blank = default)", value = ""),
actionButton("run_movcor", "Run mov.cor.dm()", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_climate_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_climate_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_climate_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(
bslib::card_header("Climate result table"),
DTOutput("climate_table")
),
bslib::card(
bslib::card_header("Climate plot"),
selectInput("climate_plot_object", "Object to plot *", choices = c()),
bslib::layout_columns(
textInput("climate_plot_var", "Climate variable", value = ""),
textInput("climate_metric_var", "Metric variable", value = "")
),
selectInput("climate_plot_type", "Plot type", choices = c("timeseries", "boxplot", "violin", "both", "relation", "cor_heatmap", "regression_heatmap")),
actionButton("refresh_climate_plot", "Refresh plot", class = "btn-outline-primary"),
plotOutput("climate_plot", height = 480),
downloadButton("download_climate_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"7. Wavelets",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
h5("Wavelet analysis"),
selectInput("wave_source", "Dendrometer source *", choices = c("Upload dendrometer data first" = "__none__")),
textInput("wave_tree", "TreeNum *", value = "all"),
selectInput("wave_input_source", "Series source", choices = c("auto", "raw", "detrended", "first_diff")),
selectInput("wave_na", "NA handling", choices = c("interpolate", "fail")),
numericInput("wave_loess", "LOESS span", value = 0, min = 0, max = 1, step = 0.05),
numericInput("wave_dj", "Frequency resolution dj", value = 1/20, min = 0.001, step = 0.001),
textInput("wave_lower", "Lower period (native units)", value = ""),
textInput("wave_upper", "Upper period (native units)", value = ""),
checkboxInput("wave_pval", "Monte Carlo significance", FALSE),
conditionalPanel("input.wave_pval", numericInput("wave_nsim", "Simulations", value = 10, min = 1)),
actionButton("run_wavelet", "Run dm_wavelet()", class = "btn-success w-100"),
tags$hr(),
selectInput("wave_object", "Wavelet object *", choices = c()),
selectInput("wave_plot_type", "Plot type", choices = c("power", "average", "series", "coherence", "cross_power", "average_coherence", "average_cross_power", "phase")),
actionButton("refresh_wave_plot", "Refresh plot", class = "btn-outline-primary w-100"),
tags$hr(),
h5("Reconstruct/remove cycles"),
selectInput("recon_mode", "Mode", choices = c("extract", "remove")),
textInput("recon_series", "Series", value = "", placeholder = "blank = all"),
textInput("recon_periods", "Exact period hours", value = "24", placeholder = "24,168"),
textInput("recon_lower", "Lower hours (with upper: replaces exact periods)", value = ""),
textInput("recon_upper", "Upper hours", value = ""),
actionButton("run_reconstruct", "Run reconstruction", class = "btn-success w-100"),
tags$hr(),
h5("Wavelet coherence"),
textInput("coh_clim_vars", "Climate vars *", value = "all"),
actionButton("run_coherence", "Run coherence", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_wave_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_wave_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_wave_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Wavelet result table"), DTOutput("wave_table")),
bslib::card(
bslib::card_header("Wavelet plot"),
plotOutput("wave_plot", height = 540),
downloadButton("download_wave_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"8. Advanced runner",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("adv_function", "Function *", choices = c(
"daily.data", "dendro.resample", "dendro.truncate", "dm.na.interpolation", "network.interpolation",
"phase.zg", "phase.sc", "twd.maxima", "dm.growth.fit", "dm.growth.fit.double", "dm.growth.evaluate",
"dm.detrend.fit", "mean_detrended.dm", "dm_standardize", "clim.twd", "clim.twd.stats",
"mov.cor.dm", "dm_wavelet", "dm_wavelet_reconstruct", "dm_wavelet_coherence", "dm_event_times",
"dm_event_climate", "dm_add_climate", "dm_plot_climate", "jump.locator", "smooth_dm", "reso_dm",
"dm_epoch_extract", "dm_epoch_test", "dm_event_climate_summary", "dm_event_climate_test",
"clim.twd.test", "dm.fit.gompertz", "dm_daily_clim", "dm_subdaily_clim",
"dm_join_daily_clim", "dm_join_subdaily_clim", "dm_join_phase_clim"
)),
selectInput("adv_source", "Primary input *", choices = c("Uploaded dendrometer data" = "__dm__")),
checkboxInput("adv_use_climate", "Pass uploaded climate data if argument exists", TRUE),
checkboxInput("adv_use_reference", "Pass reference network if argument exists", TRUE),
verbatimTextOutput("adv_required"),
tags$label("Extra arguments as R list items"),
tags$textarea(id = "adv_args", class = "form-control", rows = 10,
placeholder = "Example:\nTreeNum = 1, smoothing = 5\n\nDo not include list(...)."),
actionButton("run_advanced", "Run selected function", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_advanced_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_advanced_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_advanced_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::card(
bslib::card_header("Advanced result"),
DTOutput("advanced_table"),
tags$hr(),
plotOutput("advanced_plot", height = 480),
downloadButton("download_advanced_plot", "Download plot")
)
)
),
bslib::nav_panel(
"9. Results & export",
tags$div(class = "results-workspace",
tags$div(class = "results-controls",
bslib::card(fill = FALSE,
bslib::card_header("1. Load and select a result"),
selectInput("saved_result", "Saved RDS in working directory", choices = character()),
actionButton("reload_result", "Load saved result"),
selectInput("result_object", "Selected result *", choices = character()),
helpText("Choose a result from this session or load an RDS file. The same selection is used for object and table exports."),
actionButton("save_result", "Save complete result", class = "btn-success w-100"),
downloadButton("download_rds", "Download complete RDS"),
tags$details(tags$summary("Other exports and session controls"),
downloadButton("download_csv", "Download primary table CSV"),
downloadButton("download_xlsx", "Download all tables XLSX"),
downloadButton("download_all_zip", "Download all results ZIP"),
actionButton("clear_results", "Clear stored results", class = "btn-outline-danger w-100"))
),
bslib::card(fill = FALSE,
bslib::card_header("2. Export a table"),
selectInput("export_component", "Table within result *", choices = character()),
selectInput("export_format", "File format *", choices = c("CSV" = "csv", "Tab-separated" = "tsv", "Excel" = "xlsx")),
textInput("export_filename", "File name (without extension) *", "exported_table"),
downloadButton("download_selected_table", "Download selected table"),
actionButton("save_selected_table", "Save table to working directory", class = "btn-success w-100"),
helpText("Nested tables are listed by component path. Exports contain all rows; the preview shows up to 5,000. Files are saved under dendroAnalyst_results."),
verbatimTextOutput("export_status")
)
),
tags$div(class = "results-previews",
bslib::card(fill = FALSE, bslib::card_header("Selected table preview"), DTOutput("export_preview")),
bslib::card(fill = FALSE, bslib::card_header("Complete object structure"), verbatimTextOutput("object_summary")),
bslib::card(fill = FALSE, bslib::card_header("Activity log"), verbatimTextOutput("activity_log"))
)
)
)
)
server <- function(input, output, session) {
rv <- reactiveValues(
dm = NULL,
clim = NULL,
ref = NULL,
meta = NULL,
objects = list(),
current_pre = NULL,
current_daily = NULL,
current_phase = NULL,
current_growth = NULL,
current_climate = NULL,
current_wave = NULL,
current_advanced = NULL,
log = character(0),
files_version = 0L,
working_dir = initial_app_wd(),
results_dir = file.path(initial_app_wd(), "dendroAnalyst_results")
)
log_msg <- function(msg, type = "message") {
rv$log <- c(sprintf("[%s] %s", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), msg), rv$log)
showNotification(msg, type = type, duration = if (type == "error") 8 else 4)
}
export_components <- reactive({
req(input$result_object)
export_tables(rv$objects[[input$result_object]])
})
observe({
choices <- names(export_components())
updateSelectInput(session, "export_component", choices = choices)
})
export_table <- reactive({
tabs <- export_components()
validate(need(length(tabs) > 0, "This result contains no exportable tables."))
req(input$export_component)
validate(need(input$export_component %in% names(tabs), "Choose a table within the result."))
tabs[[input$export_component]]
})
output$export_status <- renderText({
tab <- export_table()
paste(nrow(tab), "rows x", ncol(tab), "columns")
})
output$export_preview <- renderDT({
datatable(utils::head(export_table(), 5000), options = list(scrollX = TRUE, pageLength = 10))
})
output$download_selected_table <- downloadHandler(
filename = function() paste0(nice_name(input$export_filename), ".", input$export_format),
content = function(file) write_export_table(export_table(), file, input$export_format)
)
observeEvent(input$save_selected_table, {
tryCatch({
tab <- export_table()
path <- tempfile(pattern = paste0(nice_name(input$export_filename), "_"),
tmpdir = ensure_results_dir(), fileext = paste0(".", input$export_format))
write_export_table(tab, path, input$export_format)
rv$files_version <- rv$files_version + 1L
log_msg(paste("Saved selected table:", path))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
plot_settings <- reactive({
values <- c(width = input$plot_width %||% 10, height = input$plot_height %||% 7,
dpi = input$plot_dpi %||% 160, font = input$plot_font %||% 12)
validate(need(all(is.finite(values)) && all(values >= c(2,2,72,6)) &&
all(values <= c(30,30,600,36)), "Choose plot settings within the displayed limits."))
validate(need(values[1]*values[2]*values[3]^2 <= 5e7, "Reduce dimensions or DPI: maximum 50 million pixels."))
values
})
draw_plot <- function(fun) {
size <- plot_settings()[["font"]]
old <- par(cex = size / 12)
on.exit(par(old), add = TRUE)
p <- fun()
if (inherits(p, "ggplot")) {
p <- p + theme(text = element_text(size = size),
axis.text = element_text(size = size), axis.title = element_text(size = size),
legend.text = element_text(size = size), legend.title = element_text(size = size),
strip.text = element_text(size = size), plot.title = element_text(size = size * 1.2),
plot.subtitle = element_text(size = size))
print(p)
}
invisible(p)
}
save_plot <- function(expr, file) {
cfg <- plot_settings()
png(file, width = cfg[["width"]], height = cfg[["height"]], units = "in", res = cfg[["dpi"]])
on.exit(dev.off(), add = TRUE)
draw_plot(expr)
}
root_paths <- wd_roots()
shinyFiles::shinyDirChoose(
input,
id = "browse_wd",
roots = root_paths,
session = session,
restrictions = system.file(package = "base")
)
observeEvent(input$browse_wd, {
path <- shinyFiles::parseDirPath(root_paths, input$browse_wd)
if (length(path) && nzchar(path)) {
updateTextInput(session, "wd_path", value = normalize_user_path(path))
}
}, ignoreInit = TRUE)
ensure_results_dir <- function() {
if (is.null(rv$working_dir) || !dir.exists(rv$working_dir)) {
stop("Set a valid working directory first.", call. = FALSE)
}
rv$results_dir <- file.path(rv$working_dir, "dendroAnalyst_results")
if (!dir.exists(rv$results_dir)) dir.create(rv$results_dir, recursive = TRUE, showWarnings = FALSE)
rv$results_dir
}
observeEvent(input$set_wd, {
tryCatch({
path <- normalize_user_path(input$wd_path)
if (is.null(path)) stop("Choose or type a folder path first.", call. = FALSE)
if (!dir.exists(path) && isTRUE(input$wd_create)) dir.create(path, recursive = TRUE, showWarnings = FALSE)
if (!dir.exists(path)) stop("Directory does not exist: ", path, call. = FALSE)
rv$working_dir <- normalizePath(path, winslash = "/", mustWork = TRUE)
rv$results_dir <- file.path(rv$working_dir, "dendroAnalyst_results")
dir.create(rv$results_dir, recursive = TRUE, showWarnings = FALSE)
if (isTRUE(input$wd_set_session)) setwd(rv$working_dir)
updateTextInput(session, "wd_path", value = rv$working_dir)
log_msg(paste("Working directory set to", rv$working_dir), "message")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$refresh_wd_files, {
log_msg("Working-directory file list refreshed.", "message")
})
output$wd_status <- renderText({
paste0(
"Current app working directory:\n", rv$working_dir %||% "Not set", "\n\n",
"R session getwd():\n", getwd()
)
})
output$wd_results_dir <- renderText({
ensure <- tryCatch(ensure_results_dir(), error = function(e) rv$results_dir %||% "Not set")
ensure
})
output$wd_files_table <- renderDT({
input$refresh_wd_files
path <- rv$working_dir
if (is.null(path) || !dir.exists(path)) return(datatable(data.frame(message = "Set a working directory first.")))
files <- list.files(path, pattern = paste0("\\.(", paste(app_supported_ext, collapse = "|"), ")$"), ignore.case = TRUE, full.names = TRUE)
if (!length(files)) return(datatable(data.frame(message = "No supported files found in the selected folder.")))
info <- file.info(files)
dat <- data.frame(
file = basename(files),
size_kb = round(info$size / 1024, 1),
modified = info$mtime,
stringsAsFactors = FALSE
)
datatable(dat, options = list(scrollX = TRUE, pageLength = 10))
})
observe({
input$refresh_wd_files
rv$files_version
choices <- wd_file_choices(rv$working_dir)
saved <- choices[grepl("\\.rds$", choices, ignore.case = TRUE)]
updateSelectInput(session, "saved_result", choices = saved)
for (id in c("wd_dm_file", "wd_clim_file", "wd_ref_file", "wd_meta_file")) {
updateSelectInput(session, id, choices = choices)
}
})
load_working_file <- function(file_name, kind = c("dm", "clim", "ref", "meta")) {
kind <- match.arg(kind)
if (is.null(rv$working_dir) || !dir.exists(rv$working_dir)) stop("Set the working directory first.", call. = FALSE)
file_name <- null_if_blank(file_name)
if (is.null(file_name)) stop("Choose a file from the working directory first.", call. = FALSE)
path <- normalizePath(file.path(rv$working_dir, file_name), winslash = "/", mustWork = TRUE)
ext <- tolower(tools::file_ext(path))
if (ext %in% c("rds", "rda", "rdata")) {
obj <- load_r_object_file(path)
} else if (identical(kind, "dm")) {
obj <- call_read_dendrometer(
file = path,
sep = input$dm_sep,
dec = input$dm_dec,
datetime_col = input$dm_datetime_col,
date_col = input$dm_date_col,
time_col = input$dm_time_col,
tz = input$dm_tz,
sheet = input$dm_sheet,
range = input$dm_range
)
} else if (identical(kind, "clim")) {
obj <- call_read_climate(
file = path,
sep = input$clim_sep,
dec = input$clim_dec,
time_col = input$clim_time_col,
vars = input$clim_vars,
tz = input$clim_tz,
sheet = input$clim_sheet
)
} else {
obj <- read_uploaded_table(path)
}
list(path = path, object = obj)
}
save_current_result <- function(current_name, plot_fun = NULL, prefix = "result") {
tryCatch({
if (is.null(current_name) || !nzchar(current_name)) stop("No result has been generated for this tab yet.", call. = FALSE)
obj <- rv$objects[[current_name]]
if (is.null(obj)) stop("Stored result was not found.", call. = FALSE)
resdir <- ensure_results_dir()
stamp <- format(Sys.time(), "%Y%m%d_%H%M%S")
base <- nice_name(paste(prefix, current_name, stamp, sep = "_"))
base <- basename(tempfile(pattern = paste0(base, "_"), tmpdir = resdir))
rds_path <- file.path(resdir, paste0(base, ".rds"))
saveRDS(obj, rds_path)
rv$files_version <- rv$files_version + 1L
log_msg(paste("Saved reusable RDS:", rds_path))
tabs <- all_tables(obj)
if (length(tabs)) {
for (tn in names(tabs)) {
safe_write_csv(tabs[[tn]], file.path(resdir, paste0(base, "__", nice_name(tn), ".csv")))
}
if (requireNamespace("writexl", quietly = TRUE)) {
xlsx_names <- substr(vapply(names(tabs), nice_name, character(1)), 1, 31)
names(tabs) <- make.unique(xlsx_names, sep = "_")
writexl::write_xlsx(tabs, path = file.path(resdir, paste0(base, "__tables.xlsx")))
}
}
if (!is.null(plot_fun)) {
try(save_plot(plot_fun, file.path(resdir, paste0(base, "__plot.png"))), silent = TRUE)
}
log_msg(paste("Saved result files to", resdir), "message")
}, error = function(e) log_msg(conditionMessage(e), "error"))
}
add_object <- function(name, obj) {
nm0 <- nice_name(name)
nm <- nm0
objs <- rv$objects
i <- 1L
while (nm %in% names(objs)) {
nm <- paste0(nm0, "_", i)
i <- i + 1L
}
objs[[nm]] <- obj
rv$objects <- objs
log_msg(paste("Stored result:", nm), "message")
nm
}
selected_source <- function(id) {
if (is.null(id) || id == "__none__") stop("Please select an input data source.", call. = FALSE)
if (id == "__dm__") {
if (is.null(rv$dm)) stop("Please upload dendrometer data first.", call. = FALSE)
return(rv$dm)
}
obj <- rv$objects[[id]]
if (is.null(obj)) stop("Selected object was not found.", call. = FALSE)
tab <- first_table(obj)
if (is.null(tab)) stop("Selected object does not contain a data-frame-like table.", call. = FALSE)
tab
}
selected_object <- function(id) {
if (is.null(id) || id == "__none__") stop("Please select an input object.", call. = FALSE)
if (id == "__dm__") {
if (is.null(rv$dm)) stop("Please upload dendrometer data first.", call. = FALSE)
return(rv$dm)
}
obj <- rv$objects[[id]]
if (is.null(obj)) stop("Selected object was not found.", call. = FALSE)
obj
}
data_source_choices <- reactive({
choices <- c()
if (!is.null(rv$dm)) choices <- c(choices, "Uploaded dendrometer" = "__dm__")
for (nm in names(rv$objects)) {
if (!is.null(first_table(rv$objects[[nm]]))) choices <- c(choices, setNames(nm, nm))
}
if (!length(choices)) choices <- c("Upload dendrometer data first" = "__none__")
choices
})
object_choices <- reactive({
choices <- names(rv$objects)
if (!length(choices)) choices <- character(0)
choices
})
growth_object_choices <- reactive({
nms <- names(rv$objects)
keep <- vapply(nms, function(nm) inherits(rv$objects[[nm]], "dm_growth_fit"), logical(1))
nms[keep]
})
clim_twd_object_choices <- reactive({
nms <- names(rv$objects)
keep <- vapply(nms, function(nm) inherits(rv$objects[[nm]], "clim_twd_output"), logical(1))
nms[keep]
})
wave_object_choices <- reactive({
nms <- names(rv$objects)
keep <- vapply(nms, function(nm) inherits(rv$objects[[nm]], "dm_wavelet") || inherits(rv$objects[[nm]], "dm_wavelet_reconstruct") || inherits(rv$objects[[nm]], "dm_wavelet_coherence"), logical(1))
nms[keep]
})
observe({
ds <- data_source_choices()
for (id in c("pre_source", "daily_source", "phase_source", "growth_source", "climtwd_source", "movcor_source", "wave_source")) {
updateSelectInput(session, id, choices = ds)
}
objs <- object_choices()
updateSelectInput(session, "adv_source", choices = c("Dendrometer data *" = "__dm__", stats::setNames(objs, objs)))
for (id in c("result_object", "clim_attach_object", "climate_plot_object")) {
updateSelectInput(session, id, choices = objs)
}
updateSelectInput(session, "detrend_object", choices = growth_object_choices())
updateSelectInput(session, "climtwd_stats_object", choices = clim_twd_object_choices())
updateSelectInput(session, "wave_object", choices = wave_object_choices())
})
output$activity_log <- renderText({
if (!length(rv$log)) return("No actions yet.")
paste(rv$log, collapse = "\n")
})
observeEvent(input$reload_result, {
tryCatch({
z <- load_working_file(input$saved_result, "dm")
nm <- add_object(tools::file_path_sans_ext(basename(z$path)), z$object)
updateSelectInput(session, "result_object", selected = nm)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$save_result, { save_current_result(input$result_object) })
observeEvent(input$load_wd_dm, {
tryCatch({
z <- load_working_file(input$wd_dm_file, "dm")
rv$dm <- z$object
add_object(paste0("wd_dendrometer_", tools::file_path_sans_ext(basename(z$path))), rv$dm)
log_msg(paste("Dendrometer data loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$load_wd_clim, {
tryCatch({
z <- load_working_file(input$wd_clim_file, "clim")
rv$clim <- z$object
add_object(paste0("wd_climate_", tools::file_path_sans_ext(basename(z$path))), rv$clim)
log_msg(paste("Climate data loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$load_wd_ref, {
tryCatch({
z <- load_working_file(input$wd_ref_file, "ref")
rv$ref <- z$object
add_object(paste0("wd_reference_", tools::file_path_sans_ext(basename(z$path))), rv$ref)
log_msg(paste("Reference network loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$load_wd_meta, {
tryCatch({
z <- load_working_file(input$wd_meta_file, "meta")
rv$meta <- z$object
add_object(paste0("wd_metadata_", tools::file_path_sans_ext(basename(z$path))), rv$meta)
log_msg(paste("Metadata loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_dm, {
req(input$dm_file)
tryCatch({
rv$dm <- call_read_dendrometer(
file = input$dm_file$datapath,
sep = input$dm_sep,
dec = input$dm_dec,
datetime_col = input$dm_datetime_col,
date_col = input$dm_date_col,
time_col = input$dm_time_col,
tz = input$dm_tz,
sheet = input$dm_sheet,
range = input$dm_range
)
add_object("uploaded_dendrometer", rv$dm)
log_msg("Dendrometer data loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_clim, {
req(input$clim_file)
tryCatch({
rv$clim <- call_read_climate(
file = input$clim_file$datapath,
sep = input$clim_sep,
dec = input$clim_dec,
time_col = input$clim_time_col,
vars = input$clim_vars,
tz = input$clim_tz,
sheet = input$clim_sheet
)
add_object("uploaded_climate", rv$clim)
log_msg("Climate data loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_ref, {
req(input$ref_file)
tryCatch({
rv$ref <- read_uploaded_table(input$ref_file$datapath)
add_object("reference_network", rv$ref)
log_msg("Reference network loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_meta, {
req(input$meta_file)
tryCatch({
rv$meta <- read_uploaded_table(input$meta_file$datapath)
add_object("tree_metadata", rv$meta)
log_msg("Tree metadata loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$dm_preview <- renderDT({
req(rv$dm)
datatable(object_preview(rv$dm), options = list(scrollX = TRUE, pageLength = 8))
})
output$clim_preview <- renderDT({
req(rv$clim)
datatable(object_preview(rv$clim), options = list(scrollX = TRUE, pageLength = 8))
})
observeEvent(input$detect_resolution, {
tryCatch({
df <- selected_source(input$pre_source)
res <- safe_call("reso_dm", list(input_time = df[[1]]), "reso_dm")
rv$current_pre <- add_object("temporal_resolution_minutes", data.frame(resolution_minutes = res))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$resolution_txt <- renderText({
obj <- rv$objects[[rv$current_pre %||% ""]]
if (is.null(obj) || !is.data.frame(obj) || !"resolution_minutes" %in% names(obj)) return("Resolution not detected yet.")
paste0("Estimated resolution: ", obj$resolution_minutes[1], " minutes")
})
observeEvent(input$run_truncate, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dendro.truncate", list(df = df, CalYear = parse_num_vec(input$truncate_year), DOY = parse_num_vec(input$truncate_doy)), "dendro.truncate")
rv$current_pre <- add_object("truncated_dendrometer", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_resample, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dendro.resample", list(df = df, by = input$resample_by, value = input$resample_value, method = input$resample_method), "dendro.resample")
rv$current_pre <- add_object(paste0("resampled_", input$resample_by), out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_na, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dm.na.interpolation", list(df = df, resolution = input$na_resolution, fill = input$na_fill, method = input$na_method, assess = input$na_assess, verbose = FALSE), "dm.na.interpolation")
rv$current_pre <- add_object("na_interpolation", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_network, {
tryCatch({
df <- selected_source(input$pre_source)
if (is.null(rv$ref)) stop("Load a reference dendrometer network in 1. Data first.", call. = FALSE)
lengths <- parse_num_vec(input$network_lengths)
if (isTRUE(input$network_assess) &&
(is.null(lengths) || any(lengths < 1 | lengths != floor(lengths)))) {
stop("Assessment gap lengths must be positive whole numbers.", call. = FALSE)
}
if (is.null(input$network_boot) || !is.finite(input$network_boot) ||
input$network_boot < 1 || input$network_boot != floor(input$network_boot)) {
stop("Bootstrap samples must be a positive whole number.", call. = FALSE)
}
out <- withProgress(message = "Interpolating with reference network", value = 0.5, {
safe_call("network.interpolation", list(
df = df, referenceDF = rv$ref, niMethod = input$network_method,
n_boot = input$network_boot, return_flags = TRUE,
return_pi = input$network_pi, assess = input$network_assess,
assess_lengths_steps = lengths %||% c(1, 2, 4), progress = FALSE,
correct_gap_jumps = input$network_correct_jumps,
jump_threshold = input$network_jump_threshold
))
})
rv$current_pre <- add_object("network_interpolation", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_jump_adjust, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("jump.locator", list(
df = df,
detection_method = input$jump_detection,
manual_threshold = if (identical(input$jump_detection, "manual")) input$jump_threshold else NULL,
auto_method_penalty = input$jump_penalty,
adjustment_method = input$jump_adjustment,
adjust_window = input$jump_window,
auto_every_second = input$jump_every_second,
set_jump_point_na = input$jump_set_na
), "jump.locator")
rv$current_pre <- add_object("jump_adjusted_dendrometer", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_standardize, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dm_standardize", list(df = df, season_type = input$std_season, CS_doys = parse_num_vec(input$std_cs), method = input$std_method), "dm_standardize")
rv$current_pre <- add_object("standardized_dendrometer", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$pre_table <- renderDT({
req(input$show_pre_data > 0)
req(rv$current_pre)
datatable(object_preview(rv$objects[[rv$current_pre]]), options = list(scrollX = TRUE, pageLength = 10))
})
make_pre_plot <- reactive({
req(rv$current_pre)
obj <- rv$objects[[rv$current_pre]]
force(obj)
function() {
if (inherits(obj, c("dm_na_interpolation", "dm_standardized", "network_interpolation"))) return(plot(obj))
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal() + ggplot2::labs(x = names(tab)[1], y = names(tab)[2])
}
})
output$pre_plot <- renderPlot({ req(input$show_pre_plot > 0); draw_plot(make_pre_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_pre_plot <- downloadHandler(
filename = function() paste0("preprocess_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_pre_plot(), file)
)
observeEvent(input$save_pre_tab, { save_current_result(rv$current_pre, make_pre_plot(), "preprocess") })
observeEvent(input$run_daily, {
tryCatch({
df <- selected_source(input$daily_source)
out <- safe_call("daily.data", list(df = df, TreeNum = parse_tree(input$daily_tree)), "daily.data")
rv$current_daily <- add_object("daily_statistics", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$daily_table <- renderDT({
req(input$show_daily_data > 0)
req(rv$current_daily)
datatable(object_preview(rv$objects[[rv$current_daily]]), options = list(scrollX = TRUE, pageLength = 12))
})
make_daily_plot <- reactive({
req(rv$current_daily)
obj <- rv$objects[[rv$current_daily]]
function() {
plot(
obj,
type = input$daily_plot_type,
stat = input$daily_stat,
by = input$daily_by,
box_style = input$daily_box_style,
Year = parse_num_vec(input$daily_year),
DOY = parse_num_vec(input$daily_doy)
)
}
})
output$daily_plot <- renderPlot({ req(input$show_daily_plot > 0); draw_plot(make_daily_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_daily_plot <- downloadHandler(
filename = function() paste0("daily_plot_", input$daily_plot_type, "_", Sys.Date(), ".png"),
content = function(file) save_plot(make_daily_plot(), file)
)
observeEvent(input$save_daily_tab, { save_current_result(rv$current_daily, make_daily_plot(), "daily") })
observeEvent(input$run_phase, {
tryCatch({
df <- selected_source(input$phase_source)
smooth <- if (is.null(input$phase_smoothing) || input$phase_smoothing <= 0) NULL else input$phase_smoothing
if (identical(input$phase_method, "zg")) {
out <- safe_call("phase.zg", list(df = df, TreeNum = parse_tree(input$phase_tree), smoothing = smooth, beta = input$phase_beta), "phase.zg")
nm <- "phase_zg"
} else {
out <- safe_call("phase.sc", list(df = df, TreeNum = parse_tree(input$phase_tree), smoothing = smooth), "phase.sc")
nm <- "phase_sc"
}
rv$current_phase <- add_object(nm, out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_twd_maxima, {
tryCatch({
df <- selected_source(input$phase_source)
out <- safe_call("twd.maxima", list(df = df, TreeNum = parse_tree(input$phase_tree), smoothing = input$twd_smoothing), "twd.maxima")
rv$current_phase <- add_object("twd_maxima", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$phase_table <- renderDT({
req(input$show_phase_data > 0)
req(rv$current_phase)
datatable(object_preview(rv$objects[[rv$current_phase]]), options = list(scrollX = TRUE, pageLength = 12))
})
phase_plot_kind <- reactive({
obj <- rv$objects[[rv$current_phase %||% ""]]
if (inherits(obj, "ZG_output")) "ZG_output" else if (inherits(obj, "SC_output")) "SC_output" else "table"
})
output$phase_plot_controls <- renderUI({
kind <- phase_plot_kind()
if (kind == "table") return(helpText("Run phase analysis to select its plot options."))
types <- eval(formals(pkg_fun(paste0("plot.", kind)))$type)
tagList(
helpText(paste("Plotting stored result:", rv$current_phase)),
selectInput("phase_plot_type", "Plot type *", choices = types),
if (kind == "ZG_output") tagList(
conditionalPanel("['gro_twd','twd','phase_ribbon','boxplot'].includes(input.phase_plot_type)",
selectInput("phase_temporal", "Temporal scale", choices = c("raw", "daily", "weekly", "monthly", "yearly"))),
conditionalPanel("['abr','slope_diagnostics','event_timeline','boxplot'].includes(input.phase_plot_type)",
selectInput("phase_metric", "Event metric *", choices = {
cycle <- rv$objects[[rv$current_phase]]$ZG_cycle
names(cycle)[vapply(cycle, is.numeric, logical(1))]
}, selected = "ABr.value")),
conditionalPanel("input.phase_plot_type === 'scatter'",
selectInput("phase_scatter_source", "Source table *", c("ZG_cycle", "ZG_drought")),
uiOutput("phase_scatter_variables"),
selectInput("phase_scatter_fit", "Fit relationship", c("None" = "none", "Linear" = "linear")))
),
if (kind == "SC_output") conditionalPanel("input.phase_plot_type === 'boxplot'",
selectInput("phase_stat", "Cycle statistic *", choices = {
cycle <- rv$objects[[rv$current_phase]]$SC_cycle
names(cycle)[vapply(cycle,is.numeric,logical(1))]
}, selected = "Magnitude"),
selectInput("phase_temporal", "Calendar grouping", choices=c("monthly","daily","weekly","yearly","raw"))),
conditionalPanel("['points','both','shrinkage','expansion','increment','slope_diagnostics','scatter'].includes(input.phase_plot_type)",
numericInput("phase_point_size", "Point size", 2.5, min = 0.1, max = 10, step = 0.1)),
conditionalPanel("['ribbon','both','phase_ribbon'].includes(input.phase_plot_type)",
sliderInput("phase_ribbon_alpha", "Ribbon opacity", min = 0, max = 1, value = 0.35))
)
})
output$phase_scatter_variables <- renderUI({
req(rv$current_phase)
dat <- rv$objects[[rv$current_phase]][[input$phase_scatter_source %||% "ZG_cycle"]]
if (!is.data.frame(dat)) return(helpText("This result has no selected table; run phase analysis again."))
choices <- names(dat)[vapply(dat, is.numeric, logical(1))]
tagList(selectInput("phase_scatter_x", "X parameter *", choices, selected = choices[1]),
selectInput("phase_scatter_y", "Y parameter *", choices, selected = if ("ABr.value" %in% choices) "ABr.value" else choices[2]))
})
make_phase_plot <- reactive({
req(rv$current_phase)
obj <- rv$objects[[rv$current_phase]]
kind <- phase_plot_kind()
function() {
if (kind != "table") {
fun <- pkg_fun(paste0("plot.", kind))
types <- eval(formals(fun)$type)
type <- input$phase_plot_type %||% types[1]
validate(need(type %in% types, "Select a plot type for the current result."))
args <- list(x = obj, type = type, Year = parse_num_vec(input$phase_year),
DOY = parse_num_vec(input$phase_doy),
point_size = input$phase_point_size %||% 2.5,
ribbon_alpha = input$phase_ribbon_alpha %||% 0.35)
if (kind == "SC_output" && type == "boxplot") {
args$stat <- input$phase_stat %||% "Magnitude"
args$temporal <- input$phase_temporal %||% "monthly"
}
if (kind == "ZG_output") {
args$temporal <- if (type %in% c("gro_twd", "twd", "phase_ribbon", "boxplot")) input$phase_temporal %||% "raw" else "raw"
args$metric <- input$phase_metric %||% "ABr.value"
if (type == "scatter") {
req(input$phase_scatter_x, input$phase_scatter_y)
args$source <- input$phase_scatter_source %||% "ZG_cycle"
args$xvar <- input$phase_scatter_x
args$yvar <- input$phase_scatter_y
args$fit <- input$phase_scatter_fit %||% "none"
}
}
do.call(fun, args)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic plot available."))
ggplot(tab, aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) + geom_line() + theme_minimal()
}
}
})
output$phase_plot <- renderPlot({ req(input$show_phase_plot > 0); draw_plot(make_phase_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$phase_scatter_stats <- renderTable({
req(input$show_phase_plot > 0, input$phase_plot_type == "scatter", phase_plot_kind() == "ZG_output")
attr(make_phase_plot()(), "scatter_stats")
}, digits = 5)
output$download_phase_plot <- downloadHandler(
filename = function() paste0("phase_plot_", input$phase_plot_type, "_", Sys.Date(), ".png"),
content = function(file) save_plot(make_phase_plot(), file)
)
observeEvent(input$save_phase_tab, { save_current_result(rv$current_phase, make_phase_plot(), "phase") })
observeEvent(input$run_growth, {
tryCatch({
df <- selected_source(input$growth_source)
common <- list(
df = df,
TreeNum = parse_tree(input$growth_tree),
years = parse_chr_vec(input$growth_years, default = "all"),
year_mode = input$growth_year_mode,
fit_GRO = input$growth_fit_gro,
site_mode = input$growth_site_mode,
custom_veg_season = parse_num_vec(input$growth_custom_season, default = c(275, 274)),
growth_fraction = parse_num_vec(input$growth_fraction, default = c(0.1, 0.9)),
min_unique_growth = input$growth_min_unique,
rate_threshold_fraction = input$growth_rate_threshold,
verbose = TRUE
)
if (identical(input$growth_engine, "single")) {
args <- c(common, list(method = input$growth_method, fix_a_to_observed_max = input$growth_fix_a))
out <- safe_call("dm.growth.fit", args, "dm.growth.fit")
nm <- paste0("growth_fit_", input$growth_method)
} else if (identical(input$growth_engine, "double")) {
args <- c(common, list(method = input$growth_double_method, fix_a_to_observed_max = input$growth_fix_a))
out <- safe_call("dm.growth.fit.double", args, "dm.growth.fit.double")
nm <- paste0("growth_fit_double_", input$growth_double_method)
} else {
args <- c(common, list(methods = input$growth_eval_methods))
out <- safe_call("dm.growth.evaluate", args, "dm.growth.evaluate")
nm <- "growth_method_evaluation"
}
rv$current_growth <- add_object(nm, out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_detrend, {
tryCatch({
req(input$detrend_object)
obj <- rv$objects[[input$detrend_object]]
out <- safe_call("dm.detrend.fit", list(x = obj), "dm.detrend.fit")
rv$current_growth <- add_object("detrended_growth_fit", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_mean_detrended, {
tryCatch({
req(rv$current_growth)
obj <- rv$objects[[rv$current_growth]]
out <- safe_call("mean_detrended.dm", list(detrended_dm = obj), "mean_detrended.dm")
rv$current_growth <- add_object("mean_detrended_series", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$growth_table <- renderDT({
req(input$show_growth_data > 0)
req(rv$current_growth)
datatable(object_preview(rv$objects[[rv$current_growth]]), options = list(scrollX = TRUE, pageLength = 12))
})
observe({
obj <- rv$objects[[rv$current_growth %||% ""]]
choices <- if (inherits(obj,"dm_growth_evaluation")) c("boxplot","mean","heatmap") else if (inherits(obj,"dm_detrended")) c("compare","boxplot") else if (inherits(obj,"mean_dm_detrended")) "default" else c("fit","season","residuals","timing","overlay","parameters")
updateSelectInput(session,"growth_plot_type",choices=choices)
})
observe({
name <- input$wave_object
if (is.null(name) || !nzchar(name)) name <- rv$current_wave
obj <- rv$objects[[name %||% ""]]
choices <- if (inherits(obj,"dm_wavelet_coherence")) c("coherence","cross_power","average_coherence","average_cross_power","phase","series") else if (inherits(obj,"dm_wavelet_reconstruct")) "compare" else c("power","average","series")
updateSelectInput(session,"wave_plot_type",choices=choices)
})
make_growth_plot <- reactive({
req(rv$current_growth)
obj <- rv$objects[[rv$current_growth]]
function() {
if (inherits(obj, "dm_growth_evaluation")) {
eval_type <- if (input$growth_plot_type %in% c("boxplot", "mean", "heatmap")) input$growth_plot_type else "boxplot"
plot(obj, metric = input$growth_metric, type = eval_type)
} else if (inherits(obj, "dm_growth_fit")) {
fit_type <- if (input$growth_plot_type %in% c("fit", "season", "residuals", "timing", "overlay", "parameters")) input$growth_plot_type else "fit"
plot(obj, type = fit_type, x_axis = input$growth_x_axis)
} else if (inherits(obj, "dm_detrended")) {
plot(obj, type = if (input$growth_plot_type %in% c("boxplot")) "boxplot" else "compare")
} else if (inherits(obj, "mean_dm_detrended")) {
plot(obj)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic growth plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
}
}
})
output$growth_plot <- renderPlot({ req(input$show_growth_plot > 0); draw_plot(make_growth_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_growth_plot <- downloadHandler(
filename = function() paste0("growth_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_growth_plot(), file)
)
observeEvent(input$save_growth_tab, { save_current_result(rv$current_growth, make_growth_plot(), "growth") })
observeEvent(input$run_daily_clim, {
tryCatch({
req(rv$clim)
out <- safe_call("dm_daily_clim", list(
clim_df = rv$clim,
mean_vars = parse_chr_vec(input$daily_mean_vars, NULL),
min_vars = parse_chr_vec(input$daily_min_vars, NULL),
max_vars = parse_chr_vec(input$daily_max_vars, NULL),
sum_vars = parse_chr_vec(input$daily_sum_vars, NULL),
median_vars = parse_chr_vec(input$daily_median_vars, NULL)
), "dm_daily_clim")
rv$current_climate <- add_object("daily_climate", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_subdaily_clim, {
tryCatch({
req(rv$clim)
out <- safe_call("dm_subdaily_clim", list(
clim_df = rv$clim,
mean_vars = parse_chr_vec(input$sub_mean_vars, NULL),
sum_vars = parse_chr_vec(input$sub_sum_vars, NULL),
lag_vars = parse_chr_vec(input$sub_lag_vars, NULL),
roll_hours = parse_num_vec(input$sub_roll_hours, c(3, 6, 24))
), "dm_subdaily_clim")
rv$current_climate <- add_object("subdaily_climate", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_add_climate, {
tryCatch({
req(input$clim_attach_object, rv$clim)
obj <- rv$objects[[input$clim_attach_object]]
out <- safe_call("dm_add_climate", list(
x = obj,
clim = rv$clim,
scale = input$clim_attach_scale,
mean_vars = parse_chr_vec(input$daily_mean_vars, NULL),
min_vars = parse_chr_vec(input$daily_min_vars, NULL),
max_vars = parse_chr_vec(input$daily_max_vars, NULL),
sum_vars = parse_chr_vec(input$daily_sum_vars, NULL),
median_vars = parse_chr_vec(input$daily_median_vars, NULL),
sub_mean_vars = parse_chr_vec(input$sub_mean_vars, NULL),
sub_sum_vars = parse_chr_vec(input$sub_sum_vars, NULL),
sub_lag_vars = parse_chr_vec(input$sub_lag_vars, NULL),
roll_hours = parse_num_vec(input$sub_roll_hours, c(3, 6, 24))
), "dm_add_climate")
rv$current_climate <- add_object("climate_attached", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_clim_twd, {
tryCatch({
if (is.null(rv$clim)) stop("Please load climate data first.", call. = FALSE)
df <- selected_source(input$climtwd_source)
# clim.twd() needs daily climate with a date column and one variable
clim <- as.data.frame(rv$clim)
num_vars <- names(clim)[-1][vapply(clim[-1], is.numeric, logical(1))]
if (!length(num_vars)) stop("The climate data contain no numeric variable.", call. = FALSE)
var <- null_if_blank(input$climtwd_var) %||% num_vars[1]
if (!var %in% num_vars) stop("Climate variable '", var, "' was not found. Available: ", paste(num_vars, collapse = ", "), call. = FALSE)
tm <- clim[[1]]
if (!inherits(tm, c("Date", "POSIXct"))) tm <- lubridate::parse_date_time(tm, c("Ymd HMS", "Ymd HM", "Ymd"))
date <- if (inherits(tm, "POSIXct")) as.Date(format(tm, "%Y-%m-%d")) else as.Date(tm)
fun <- match.fun(input$climtwd_clim_fun %||% "sum")
clim_day <- stats::aggregate(list(value = clim[[var]]), by = list(DATE = date),
FUN = function(v) if (all(is.na(v))) NA_real_ else fun(v, na.rm = TRUE))
names(clim_day)[2] <- var
out <- safe_call("clim.twd", list(
df = df,
Clim = clim_day,
dailyValue = input$climtwd_daily_value,
thresholdClim = input$climtwd_threshold_clim,
thresholdDays = input$climtwd_threshold_days,
showPlot = FALSE
), "clim.twd")
rv$current_climate <- add_object("climate_twd", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_climtwd_stats, {
tryCatch({
req(input$climtwd_stats_object)
obj <- rv$objects[[input$climtwd_stats_object]]
out <- safe_call("clim.twd.stats", list(x = obj, tree_info = rv$meta, group_by = input$climtwd_group), "clim.twd.stats")
rv$current_climate <- add_object("climate_twd_stats", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_movcor, {
tryCatch({
req(rv$clim)
df <- selected_source(input$movcor_source)
out <- safe_call("mov.cor.dm", list(
df = df,
Clim = rv$clim,
TreeNum = parse_int(input$movcor_tree, 1),
win_size = input$movcor_win,
cor_method = input$movcor_method,
clim_vars = parse_chr_vec(input$movcor_vars, NULL)
), "mov.cor.dm")
rv$current_climate <- add_object("moving_correlation", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$climate_table <- renderDT({
req(input$show_climate_data > 0)
req(rv$current_climate)
datatable(object_preview(rv$objects[[rv$current_climate]]), options = list(scrollX = TRUE, pageLength = 12))
})
# Climate variables attached to a daily, ZG or SC climate object
climate_var_choices <- function(obj) {
ns <- asNamespace(app_pkg)
if (inherits(obj, "daily_output_clim")) {
dat <- as.data.frame(obj)
num <- names(dat)[vapply(dat, is.numeric, logical(1))]
raw <- if (!is.null(rv$clim)) names(rv$clim)[-1] else character()
hit <- num[vapply(num, function(n) any(n == raw | startsWith(n, paste0(raw, "_"))), logical(1))]
return(if (length(hit)) hit else num)
}
kind <- if (inherits(obj, "ZG_output_clim")) "ZG" else "SC"
cyc <- as.data.frame(obj[[paste0(kind, "_cycle")]])
ph <- as.data.frame(obj[[paste0(kind, "_phase")]])
unique(c(ns$.dm_detect_cycle_climate_cols(cyc, kind = kind), ns$.dm_detect_point_climate_cols(ph, kind = kind)))
}
observe({
obj <- rv$objects[[input$climate_plot_object %||% ""]]
if (!inherits(obj, c("daily_output_clim", "ZG_output_clim", "SC_output_clim"))) return()
ch <- tryCatch(climate_var_choices(obj), error = function(e) character())
if (length(ch)) updateTextInput(session, "climate_plot_var", placeholder = paste("blank =", ch[1], "| available:", paste(head(ch, 6), collapse = ", ")))
})
make_climate_plot <- reactive({
input$refresh_climate_plot
obj_name <- input$climate_plot_object %||% rv$current_climate
req(obj_name)
obj <- rv$objects[[obj_name]]
function() {
if (inherits(obj, c("daily_output_clim", "ZG_output_clim", "SC_output_clim"))) {
if(input$climate_plot_type %in% c("cor_heatmap","regression_heatmap")) return(pkg_fun("dm_plot_climate_compare")(x=obj,type=input$climate_plot_type))
choices <- climate_var_choices(obj)
validate(need(length(choices) > 0, "No attached climate variables were found in this object."))
cvar <- null_if_blank(input$climate_plot_var) %||% choices[1]
validate(need(cvar %in% choices, paste0("Climate variable '", cvar, "' was not found. Available: ", paste(choices, collapse = ", "))))
pkg_fun("dm_plot_climate")(
x = obj,
climate_var = cvar,
metric_var = null_if_blank(input$climate_metric_var),
type = input$climate_plot_type
)
} else if (inherits(obj, "mov_cor_dm")) {
plot(obj)
} else if (inherits(obj, "clim_twd_stats")) {
plot(obj)
} else if (inherits(obj, "clim_twd_test")) {
plot(obj)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic climate plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
}
}
})
output$climate_plot <- renderPlot({ req(input$show_climate_plot > 0); draw_plot(make_climate_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_climate_plot <- downloadHandler(
filename = function() paste0("climate_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_climate_plot(), file)
)
observeEvent(input$save_climate_tab, { save_current_result(rv$current_climate, make_climate_plot(), "climate") })
observeEvent(input$run_wavelet, {
tryCatch({
obj <- selected_object(input$wave_source)
out <- safe_call("dm_wavelet", list(
x = obj,
TreeNum = parse_tree(input$wave_tree),
source = input$wave_input_source,
na_action = input$wave_na,
loess_span = input$wave_loess,
dj = input$wave_dj,
lowerPeriod = parse_num_vec(input$wave_lower, NULL),
upperPeriod = parse_num_vec(input$wave_upper, NULL),
make_pval = input$wave_pval,
n_sim = input$wave_nsim,
verbose = TRUE
), "dm_wavelet")
rv$current_wave <- add_object("wavelet", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_reconstruct, {
tryCatch({
req(input$wave_object)
obj <- rv$objects[[input$wave_object]]
lower <- parse_num_vec(input$recon_lower, NULL)
upper <- parse_num_vec(input$recon_upper, NULL)
use_band <- !is.null(lower) && !is.null(upper)
out <- safe_call("dm_wavelet_reconstruct", list(
x = obj,
series = parse_chr_vec(input$recon_series, NULL),
mode = input$recon_mode,
period_hours = if (use_band) NULL else parse_num_vec(input$recon_periods, NULL),
lower_hours = if (use_band) lower else NULL,
upper_hours = if (use_band) upper else NULL
), "dm_wavelet_reconstruct")
rv$current_wave <- add_object("wavelet_reconstruction", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_coherence, {
tryCatch({
req(rv$clim)
dm_obj <- selected_object(input$wave_source)
out <- safe_call("dm_wavelet_coherence", list(
dm = dm_obj,
clim = rv$clim,
TreeNum = parse_tree(input$wave_tree),
clim_vars = parse_chr_vec(input$coh_clim_vars, default = "all"),
source = input$wave_input_source,
na_action = input$wave_na,
loess_span = input$wave_loess,
dj = input$wave_dj,
make_pval = input$wave_pval,
n_sim = input$wave_nsim,
verbose = TRUE
), "dm_wavelet_coherence")
rv$current_wave <- add_object("wavelet_coherence", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$wave_table <- renderDT({
req(input$show_wave_data > 0)
req(rv$current_wave)
datatable(object_preview(rv$objects[[rv$current_wave]]), options = list(scrollX = TRUE, pageLength = 12))
})
make_wave_plot <- reactive({
input$refresh_wave_plot
obj_name <- input$wave_object %||% rv$current_wave
if (is.null(obj_name) || !nzchar(obj_name)) obj_name <- rv$current_wave
req(obj_name)
obj <- rv$objects[[obj_name]]
function() {
if (inherits(obj, "dm_wavelet")) {
wtype <- if (input$wave_plot_type %in% c("power", "average", "series")) input$wave_plot_type else "power"
plot(obj, type = wtype)
} else if (inherits(obj, "dm_wavelet_reconstruct")) {
plot(obj, type = "compare")
} else if (inherits(obj, "dm_wavelet_coherence")) {
ctype <- if (input$wave_plot_type %in% c("coherence", "cross_power", "average_coherence", "average_cross_power", "phase", "series")) input$wave_plot_type else "coherence"
plot(obj, type = ctype)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic wavelet plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
}
}
})
output$wave_plot <- renderPlot({ req(input$show_wave_plot > 0); draw_plot(make_wave_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_wave_plot <- downloadHandler(
filename = function() paste0("wavelet_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_wave_plot(), file)
)
observeEvent(input$save_wave_tab, { save_current_result(rv$current_wave, make_wave_plot(), "wavelet") })
output$adv_required <- renderText({
req(input$adv_function)
f <- formals(pkg_fun(input$adv_function))
required <- names(f)[vapply(f, function(x) identical(x, quote(expr = )), logical(1))]
paste("Required arguments (*):", paste(setdiff(required, "..."), collapse = ", "), "\nPrimary input and enabled climate/reference inputs are passed automatically when supported.")
})
parse_adv_args <- function(txt) {
txt <- null_if_blank(txt)
if (is.null(txt)) return(list())
eval(parse(text = paste0("list(", txt, ")")), envir = parent.frame())
}
observeEvent(input$run_advanced, {
tryCatch({
fun <- pkg_fun(input$adv_function)
fml <- names(formals(fun))
args <- parse_adv_args(input$adv_args)
primary <- selected_object(input$adv_source)
for (arg in intersect(c("daily_obj", "event_data"), fml)) {
if (is.null(args[[arg]])) args[[arg]] <- primary
}
if ("events" %in% fml && is.null(args$events)) args$events <- primary
if (identical(input$adv_function, "smooth_dm")) {
tab <- first_table(primary)
if (is.null(args$time)) args$time <- tab[[1]]
if (is.null(args$dm)) args$dm <- tab[[2]]
}
if (identical(input$adv_function, "dm_wavelet_coherence") && is.null(args$dm)) args$dm <- primary
if ("tree_info" %in% fml && is.null(args$tree_info) && !is.null(rv$meta)) args$tree_info <- rv$meta
if ("df" %in% fml && is.null(args$df)) args$df <- if (is.data.frame(primary)) primary else first_table(primary)
if ("x" %in% fml && is.null(args$x)) args$x <- primary
if ("detrended_dm" %in% fml && is.null(args$detrended_dm)) args$detrended_dm <- primary
if ("input_time" %in% fml && is.null(args$input_time)) args$input_time <- first_table(primary)[[1]]
if (isTRUE(input$adv_use_climate) && !is.null(rv$clim)) {
if ("Clim" %in% fml && is.null(args$Clim)) args$Clim <- rv$clim
if ("clim" %in% fml && is.null(args$clim)) args$clim <- rv$clim
if ("clim_df" %in% fml && is.null(args$clim_df)) args$clim_df <- rv$clim
if ("clim_daily" %in% fml && is.null(args$clim_daily)) args$clim_daily <- rv$clim
if ("clim_sub" %in% fml && is.null(args$clim_sub)) args$clim_sub <- rv$clim
}
if (isTRUE(input$adv_use_reference) && !is.null(rv$ref) && "referenceDF" %in% fml && is.null(args$referenceDF)) args$referenceDF <- rv$ref
out <- do.call(fun, args)
rv$current_advanced <- add_object(paste0("advanced_", input$adv_function), out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$advanced_table <- renderDT({
req(input$show_advanced_data > 0)
req(rv$current_advanced)
datatable(object_preview(rv$objects[[rv$current_advanced]]), options = list(scrollX = TRUE, pageLength = 12))
})
make_advanced_plot <- reactive({
req(rv$current_advanced)
obj <- rv$objects[[rv$current_advanced]]
function() {
tryCatch(plot(obj), error = function(e) {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic plot method available for this advanced result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
})
}
})
output$advanced_plot <- renderPlot({ req(input$show_advanced_plot > 0); draw_plot(make_advanced_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_advanced_plot <- downloadHandler(
filename = function() paste0("advanced_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_advanced_plot(), file)
)
observeEvent(input$save_advanced_tab, { save_current_result(rv$current_advanced, make_advanced_plot(), "advanced") })
output$object_summary <- renderPrint({
req(input$result_object)
str(rv$objects[[input$result_object]], max.level = 2, give.attr = FALSE)
})
output$result_table <- renderDT({
req(input$result_object)
datatable(object_preview(rv$objects[[input$result_object]]), options = list(scrollX = TRUE, pageLength = 15))
})
output$download_rds <- downloadHandler(
filename = function() paste0(input$result_object %||% "result", ".rds"),
content = function(file) {
req(input$result_object)
saveRDS(rv$objects[[input$result_object]], file)
}
)
output$download_csv <- downloadHandler(
filename = function() paste0(input$result_object %||% "result", ".csv"),
content = function(file) {
req(input$result_object)
tab <- first_table(rv$objects[[input$result_object]])
validate(need(!is.null(tab), "The selected object does not contain a table."))
safe_write_csv(tab, file)
}
)
output$download_xlsx <- downloadHandler(
filename = function() paste0(input$result_object %||% "result", "_tables.xlsx"),
content = function(file) {
req(input$result_object)
tabs <- all_tables(rv$objects[[input$result_object]])
validate(need(length(tabs) > 0, "The selected object does not contain tables."))
if (!requireNamespace("writexl", quietly = TRUE)) stop("Package 'writexl' is required for XLSX export.")
names(tabs) <- substr(vapply(names(tabs), nice_name, character(1)), 1, 31)
writexl::write_xlsx(tabs, path = file)
}
)
output$download_all_zip <- downloadHandler(
filename = function() paste0("dendroAnalyst_results_", Sys.Date(), ".zip"),
content = function(file) {
tmp <- tempfile("dendro_results_")
dir.create(tmp, recursive = TRUE)
dir.create(file.path(tmp, "objects"))
dir.create(file.path(tmp, "tables"))
for (nm in names(rv$objects)) {
saveRDS(rv$objects[[nm]], file.path(tmp, "objects", paste0(nice_name(nm), ".rds")))
tabs <- all_tables(rv$objects[[nm]])
if (length(tabs)) {
for (tn in names(tabs)) {
safe_write_csv(tabs[[tn]], file.path(tmp, "tables", paste0(nice_name(nm), "__", nice_name(tn), ".csv")))
}
}
}
writeLines(rv$log, file.path(tmp, "activity_log.txt"))
oldwd <- getwd()
on.exit(setwd(oldwd), add = TRUE)
setwd(tmp)
files <- list.files(".", recursive = TRUE, full.names = FALSE)
if (requireNamespace("zip", quietly = TRUE)) {
zip::zipr(zipfile = file, files = files)
} else {
utils::zip(zipfile = file, files = files)
}
}
)
observeEvent(input$clear_results, {
rv$objects <- list()
rv$current_pre <- rv$current_daily <- rv$current_phase <- rv$current_growth <- rv$current_climate <- rv$current_wave <- rv$current_advanced <- NULL
log_msg("Stored results cleared.", "warning")
})
}
shinyApp(ui, server)
Try the dendRoAnalyst package in your browser
Any scripts or data that you put into this service are public.
dendRoAnalyst documentation built on Oct. 2, 2026, 9:06 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.
# dendRoAnalyst Shiny application
# Place this file in: inst/shiny/dendroAnalystApp/app.R
options(shiny.maxRequestSize = 500 * 1024^2)
required_pkgs <- c("shiny", "bslib", "DT", "ggplot2", "tools", "shinyFiles")
missing_pkgs <- required_pkgs[!vapply(required_pkgs, requireNamespace, logical(1), quietly = TRUE)]
if (length(missing_pkgs) > 0) {
stop("Please install required packages before running the app: ", paste(missing_pkgs, collapse = ", "), call. = FALSE)
}
suppressPackageStartupMessages({
library(shiny)
library(bslib)
library(DT)
library(ggplot2)
library(shinyFiles)
})
`%||%` <- function(x, y) if (is.null(x) || length(x) == 0) y else x
app_pkg <- "dendRoAnalyst"
pkg_fun <- function(name) {
if (exists(name, mode = "function", inherits = TRUE)) {
return(get(name, mode = "function", inherits = TRUE))
}
if (requireNamespace(app_pkg, quietly = TRUE) && exists(name, envir = asNamespace(app_pkg), mode = "function", inherits = FALSE)) {
return(get(name, envir = asNamespace(app_pkg), mode = "function", inherits = FALSE))
}
stop("Function '", name, "' was not found. Make sure ", app_pkg, " is loaded and the function is exported.", call. = FALSE)
}
has_fun <- function(name) {
exists(name, mode = "function", inherits = TRUE) ||
(requireNamespace(app_pkg, quietly = TRUE) && exists(name, envir = asNamespace(app_pkg), mode = "function", inherits = FALSE))
}
null_if_blank <- function(x) {
if (is.null(x)) return(NULL)
x <- trimws(as.character(x))
if (!length(x) || !nzchar(x) || identical(tolower(x), "null")) return(NULL)
x
}
parse_col <- function(x, default = NULL) {
x <- null_if_blank(x)
if (is.null(x)) return(default)
n <- suppressWarnings(as.integer(x))
if (!is.na(n) && grepl("^[0-9]+$", x)) return(n)
x
}
parse_num_vec <- function(x, default = NULL) {
x <- null_if_blank(x)
if (is.null(x)) return(default)
x <- gsub("c\\(|\\)", "", x)
x <- gsub(";", ",", x)
parts <- unlist(strsplit(x, "[,[:space:]]+"))
parts <- parts[nzchar(parts)]
out <- suppressWarnings(as.numeric(parts))
out <- out[!is.na(out)]
if (!length(out)) return(default)
out
}
parse_int <- function(x, default = NULL) {
out <- parse_num_vec(x, default = default)
if (is.null(out)) return(default)
as.integer(out[1])
}
parse_chr_vec <- function(x, default = NULL, allow_all = TRUE) {
x <- null_if_blank(x)
if (is.null(x)) return(default)
if (allow_all && identical(tolower(x), "all")) return("all")
x <- gsub("c\\(|\\)", "", x)
x <- gsub("['\"]", "", x)
parts <- unlist(strsplit(x, "[,;]+"))
parts <- trimws(parts)
parts <- parts[nzchar(parts)]
if (!length(parts)) return(default)
parts
}
parse_bool <- function(x) isTRUE(x)
parse_tree <- function(x) {
x <- null_if_blank(x)
if (is.null(x) || identical(tolower(x), "all")) return("all")
n <- suppressWarnings(as.numeric(unlist(strsplit(gsub(";", ",", x), "[,[:space:]]+"))))
n <- n[!is.na(n)]
if (length(n) > 0) return(as.integer(n))
parse_chr_vec(x, default = "all", allow_all = TRUE)
}
nice_name <- function(x) {
x <- gsub("[^A-Za-z0-9_]+", "_", x)
x <- gsub("_+", "_", x)
x <- gsub("^_|_$", "", x)
if (!nzchar(x)) x <- "result"
x
}
first_table <- function(x) {
if (is.data.frame(x)) return(x)
if (is.list(x)) {
preferred <- c(
"data", "detrended_data", "standardized_data", "results", "summary",
"daily_data", "ZG_phase", "ZG_cycle", "SC_phase", "SC_cycle",
"fitted_data", "fit_statistics", "evaluation", "detrended_long",
"parameters", "reconstructed_long", "reconstructed_wide",
"trajectory_summary", "id_summary", "period_info", "gap_info",
"assessment", "selected_ids", "phase_table", "long_data"
)
for (nm in preferred) {
if (!is.null(x[[nm]]) && is.data.frame(x[[nm]])) return(x[[nm]])
}
dfs <- Filter(is.data.frame, x)
if (length(dfs) > 0) return(dfs[[1]])
}
NULL
}
all_tables <- function(x) {
if (is.data.frame(x)) return(list(data = x))
if (!is.list(x)) return(list())
out <- Filter(is.data.frame, x)
if (length(out) == 0) {
ft <- first_table(x)
if (!is.null(ft)) out <- list(data = ft)
}
out
}
object_preview <- function(x, n = 5000) {
tab <- first_table(x)
if (is.null(tab)) return(NULL)
tab <- as.data.frame(tab)
if (nrow(tab) > n) tab <- tab[seq_len(n), , drop = FALSE]
tab
}
# Keep component paths visible; never flatten a model into a misleading table.
export_tables <- function(x) {
out <- list()
visit <- function(value, path = "data", depth = 0L) {
if (is.data.frame(value) || is.matrix(value)) {
out[[length(out) + 1L]] <<- as.data.frame(value)
names(out)[length(out)] <<- path
} else if (is.list(value) && depth < 20L &&
!inherits(value, c("ggplot", "lm", "glm", "nls"))) {
for (i in seq_along(value)) {
label <- names(value)[i]
if (is.null(label) || is.na(label) || !nzchar(label)) label <- paste0("[[", i, "]]")
visit(value[[i]], paste(path, label, sep = " / "), depth + 1L)
}
}
}
visit(x)
names(out) <- make.unique(names(out))
out
}
write_export_table <- function(tab, file, format) {
if (any(vapply(tab, is.list, logical(1)))) {
stop("This table contains list columns. Choose another component or save the complete result as RDS.", call. = FALSE)
}
if (format == "xlsx") {
if (!requireNamespace("writexl", quietly = TRUE)) stop("Install writexl to export Excel files.", call. = FALSE)
writexl::write_xlsx(tab, file)
} else if (format == "tsv") {
utils::write.table(tab, file, sep = "\t", row.names = FALSE, na = "")
} else safe_write_csv(tab, file)
}
safe_write_csv <- function(x, file) {
utils::write.csv(as.data.frame(x), file, row.names = FALSE, na = "")
}
save_plot <- function(expr, file, width = 10, height = 7, dpi = 160) {
grDevices::png(filename = file, width = width, height = height, units = "in", res = dpi)
on.exit(grDevices::dev.off(), add = TRUE)
p <- expr()
if (inherits(p, "ggplot")) {
print(p)
}
}
safe_call <- function(fun_name, args = list(), label = fun_name) {
fun <- pkg_fun(fun_name)
withCallingHandlers(
tryCatch(
do.call(fun, args),
error = function(e) {
stop("Error while running ", label, ": ", conditionMessage(e), call. = FALSE)
}
),
warning = function(w) {
invokeRestart("muffleWarning")
}
)
}
read_uploaded_table <- function(path, sheet = NULL, sep = NULL, dec = NULL) {
ext <- tolower(tools::file_ext(path))
sep <- sep %||% NULL
dec <- dec %||% "."
if (ext %in% c("xlsx", "xls")) {
if (!requireNamespace("readxl", quietly = TRUE)) stop("Package 'readxl' is required to read Excel files.")
return(as.data.frame(readxl::read_excel(path, sheet = sheet %||% 1)))
}
if (is.null(sep)) sep <- guess_sep(path, ext)
utils::read.table(path, header = TRUE, sep = sep, dec = dec, quote = "\"'", stringsAsFactors = FALSE,
check.names = FALSE, comment.char = "", na.strings = c("NA", ""))
}
# Detect the delimiter from the header line (comma, semicolon or tab; whitespace otherwise)
guess_sep <- function(path, ext = tolower(tools::file_ext(path))) {
if (ext == "tsv") return("\t")
first <- readLines(path, n = 1L, warn = FALSE)
if (!length(first)) return("")
counts <- vapply(c(",", ";", "\t"), function(s) lengths(regmatches(first, gregexpr(s, first, fixed = TRUE))), numeric(1))
if (max(counts) == 0) return("")
names(counts)[which.max(counts)]
}
call_read_dendrometer <- function(file, sep, dec, datetime_col, date_col, time_col, tz, sheet, range) {
if (has_fun("read.dendrometer")) {
out <- pkg_fun("read.dendrometer")(
file = file,
sep = null_if_blank(sep),
dec = null_if_blank(dec),
datetime_col = parse_col(datetime_col, 1),
date_col = parse_col(date_col, NULL),
time_col = parse_col(time_col, NULL),
tz = tz,
sheet = parse_col(sheet, NULL),
range = null_if_blank(range),
detect_resolution = TRUE,
return_report = FALSE,
quiet = TRUE
)
if (is.list(out) && !is.null(out$data)) return(out$data)
return(out)
}
read_uploaded_table(file, sheet = parse_col(sheet, NULL), sep = null_if_blank(sep), dec = null_if_blank(dec))
}
call_read_climate <- function(file, sep, dec, time_col, vars, tz, sheet) {
if (has_fun("read.climate")) {
out <- pkg_fun("read.climate")(
x = file,
time_col = parse_col(time_col, NULL),
vars = parse_chr_vec(vars, NULL),
sep = null_if_blank(sep),
dec = null_if_blank(dec),
sheet = parse_col(sheet, 1),
tz = tz,
detect_resolution = TRUE,
return_report = FALSE,
verbose = FALSE
)
if (is.list(out) && !is.null(out$data)) return(out$data)
return(out)
}
read_uploaded_table(file, sheet = parse_col(sheet, NULL), sep = null_if_blank(sep), dec = null_if_blank(dec))
}
# -------------------------------------------------------------------------
# Working-directory helpers
# -------------------------------------------------------------------------
app_supported_ext <- c("csv", "txt", "tsv", "xlsx", "xls", "rds", "rda", "rdata")
normalize_user_path <- function(path) {
path <- null_if_blank(path)
if (is.null(path)) return(NULL)
path <- path.expand(path)
normalizePath(path, winslash = "/", mustWork = FALSE)
}
wd_roots <- function() {
roots <- c(
Home = path.expand("~"),
Current = getwd(),
Temp = tempdir()
)
if (.Platform$OS.type == "windows") {
drive_paths <- paste0(LETTERS, ":/")
drive_paths <- drive_paths[dir.exists(drive_paths)]
if (length(drive_paths)) {
roots <- c(roots, stats::setNames(drive_paths, paste0("Drive ", substr(drive_paths, 1, 1))))
}
} else {
extra <- c(Root = "/")
for (d in c("/home", "/Users", "/mnt", "/media", "/Volumes")) {
if (dir.exists(d)) extra <- c(extra, stats::setNames(d, basename(d)))
}
roots <- c(roots, extra)
}
roots <- roots[!is.na(roots) & nzchar(roots)]
roots <- stats::setNames(normalizePath(roots, winslash = "/", mustWork = FALSE), names(roots))
roots <- roots[!duplicated(roots)]
roots[dir.exists(roots)]
}
wd_file_choices <- function(path) {
path <- normalize_user_path(path)
if (is.null(path) || !dir.exists(path)) return(c("Set working directory first" = ""))
files <- list.files(path, pattern = paste0("\\.(", paste(app_supported_ext, collapse = "|"), ")$"), ignore.case = TRUE, full.names = FALSE)
files <- sort(files)
results <- file.path(path, "dendroAnalyst_results")
if (dir.exists(results)) files <- c(files, file.path("dendroAnalyst_results",
list.files(results, pattern = "\\.(rds|csv|tsv|xlsx)$", ignore.case = TRUE)))
if (!length(files)) return(c("No supported files found" = ""))
c("Choose file" = "", stats::setNames(files, files))
}
initial_app_wd <- function() {
wd <- getOption("dendRoAnalyst.working_dir", getwd())
wd <- normalize_user_path(wd)
if (is.null(wd) || !dir.exists(wd)) wd <- normalize_user_path(getwd())
wd
}
load_r_object_file <- function(path) {
ext <- tolower(tools::file_ext(path))
if (ext == "rds") return(readRDS(path))
if (ext %in% c("rda", "rdata")) {
env <- new.env(parent = emptyenv())
nm <- load(path, envir = env)
if (!length(nm)) stop("No object found inside ", basename(path), call. = FALSE)
return(env[[nm[1]]])
}
stop("Not an R object file: ", basename(path), call. = FALSE)
}
ui <- bslib::page_navbar(
title = tags$div(class = "dendro-brand", tags$img(src = "dendroanalyst-logo-wood.png", alt = "", class = "dendro-brand-icon"), tags$span("dendRoAnalyst", class = "dendro-brand-name")),
theme = bslib::bs_theme(
version = 5,
bootswatch = "minty",
primary = "#795238",
secondary = "#8a6040",
success = "#795238",
base_font = "sans-serif",
heading_font = "sans-serif"
),
header = tags$head(tags$link(rel = "stylesheet", type = "text/css", href = "custom.css?v=5")),
bslib::nav_panel(
"0. Settings",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
h4("Working directory"),
helpText("* Required input for the selected operation. Some required inputs have defaults."),
tags$details(tags$summary("Plot size and text (all tabs)"),
numericInput("plot_width", "Width (inches) *", 10, min = 2, max = 30),
numericInput("plot_height", "Height (inches) *", 7, min = 2, max = 30),
numericInput("plot_dpi", "Export resolution (DPI) *", 160, min = 72, max = 600),
numericInput("plot_font", "Font size (points) *", 12, min = 6, max = 36),
helpText("Previews use 96 DPI. PNG downloads and saved plots use the export DPI.")),
shinyFiles::shinyDirButton(
id = "browse_wd",
label = "Browse folders...",
title = "Select working directory",
buttonType = "default",
class = "btn-outline-primary w-100"
),
tags$small(class = "text-muted", "The folder browser shows folders on the machine where the Shiny app is running."),
tags$hr(),
textInput("wd_path", "Selected folder path *", value = initial_app_wd(), width = "100%"),
checkboxInput("wd_create", "Create folder if it does not exist", TRUE),
checkboxInput("wd_set_session", "Also call setwd() for this R session", FALSE),
actionButton("set_wd", "Set as working directory", class = "btn-success w-100"),
tags$hr(),
actionButton("refresh_wd_files", "Refresh file list", class = "btn-outline-secondary w-100")
),
bslib::layout_columns(
col_widths = c(5, 7),
bslib::card(
class = "shadow-card",
bslib::card_header("Current working directory"),
verbatimTextOutput("wd_status"),
tags$hr(),
strong("Results folder"),
verbatimTextOutput("wd_results_dir")
),
bslib::card(
class = "shadow-card",
bslib::card_header("Files available in working directory"),
DTOutput("wd_files_table")
)
)
)
),
bslib::nav_panel(
"1. Data",
tags$div(class = "data-import-grid",
bslib::card(
class = "shadow-card data-import-card", fill = FALSE,
bslib::card_header("Dendrometer data *"),
fileInput("dm_file", "Upload dendrometer file", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
tags$div(class = "data-fields",
textInput("dm_sep", "Delimiter", value = "", placeholder = "auto"),
textInput("dm_dec", "Decimal mark", value = "", placeholder = "auto"),
textInput("dm_tz", "Time zone", value = "UTC")
),
tags$div(class = "data-fields",
textInput("dm_datetime_col", "Datetime column", value = "1"),
textInput("dm_date_col", "Date column", value = ""),
textInput("dm_time_col", "Time column", value = "")
),
tags$div(class = "data-fields",
textInput("dm_sheet", "Excel sheet", value = ""),
textInput("dm_range", "Excel range", value = "")
),
tags$hr(),
selectInput("wd_dm_file", "Or choose existing file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_dm", "Load selected dendrometer file", class = "btn-outline-success w-100"),
tags$hr(),
actionButton("read_dm", "Load uploaded dendrometer data", class = "btn-success w-100")
),
bslib::card(
class = "shadow-card data-import-card", fill = FALSE,
bslib::card_header("Climate data"),
fileInput("clim_file", "Upload climate file", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
tags$div(class = "data-fields",
textInput("clim_sep", "Delimiter", value = "", placeholder = "auto"),
textInput("clim_dec", "Decimal mark", value = "", placeholder = "auto"),
textInput("clim_tz", "Time zone", value = "UTC")
),
tags$div(class = "data-fields",
textInput("clim_time_col", "Time column", value = ""),
textInput("clim_vars", "Climate variables", value = "", placeholder = "temp,VPD,prec")
),
textInput("clim_sheet", "Excel sheet", value = "1"),
tags$hr(),
selectInput("wd_clim_file", "Or choose existing file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_clim", "Load selected climate file", class = "btn-outline-success w-100"),
tags$hr(),
actionButton("read_clim", "Load uploaded climate data", class = "btn-success w-100")
),
bslib::card(
class = "shadow-card data-import-card", fill = FALSE,
bslib::card_header("Reference network / metadata"),
fileInput("ref_file", "Reference dendrometer network *", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
selectInput("wd_ref_file", "Or choose reference file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_ref", "Load selected reference file", class = "btn-outline-success w-100"),
actionButton("read_ref", "Load uploaded reference network", class = "btn-outline-success w-100"),
tags$hr(),
fileInput("meta_file", "Tree metadata for grouping", accept = c(".csv", ".txt", ".tsv", ".xlsx", ".xls")),
selectInput("wd_meta_file", "Or choose metadata file from working directory", choices = c("Set working directory first" = "")),
actionButton("load_wd_meta", "Load selected metadata file", class = "btn-outline-success w-100"),
actionButton("read_meta", "Load uploaded metadata", class = "btn-outline-success w-100")
)
),
tags$div(class = "data-preview-grid",
bslib::card(bslib::card_header("Dendrometer preview"), DTOutput("dm_preview")),
bslib::card(bslib::card_header("Climate preview"), DTOutput("clim_preview"))
)
),
bslib::nav_panel(
"2. Preprocess",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("pre_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
actionButton("detect_resolution", "Detect resolution", class = "btn-outline-primary w-100"),
verbatimTextOutput("resolution_txt"),
tags$hr(),
h5("Truncate"),
textInput("truncate_year", "Calendar year(s)", value = "", placeholder = "2017 or 2017,2019"),
textInput("truncate_doy", "DOY window", value = "", placeholder = "120,300"),
actionButton("run_truncate", "Run truncation", class = "btn-success w-100"),
tags$hr(),
h5("Resample"),
textInput("resample_by", "Target resolution *", value = "D", placeholder = "30M, H, D, W, ME"),
selectInput("resample_value", "Aggregation", choices = c("mean", "max", "min", "sum", "count")),
selectInput("resample_method", "Method", choices = c("auto", "aggregate", "interpolate")),
actionButton("run_resample", "Run resampling", class = "btn-success w-100"),
tags$hr(),
h5("Missing values"),
numericInput("na_resolution", "Resolution in minutes *", value = 60, min = 1),
checkboxInput("na_fill", "Fill missing values", TRUE),
selectInput("na_method", "Interpolation method", choices = c("spline", "seasonal")),
checkboxInput("na_assess", "Assess interpolation", FALSE),
actionButton("run_na", "Detect/interpolate gaps", class = "btn-success w-100"),
tags$hr(),
h5("Network interpolation"),
helpText("Load a reference dendrometer network in 1. Data. The Input data selected above is the series to fill."),
selectInput("network_method", "Network method", choices = c("proportional", "linear")),
numericInput("network_boot", "Bootstrap samples", value = 100, min = 1, step = 1),
checkboxInput("network_pi", "Calculate prediction intervals", TRUE),
checkboxInput("network_assess", "Assess network interpolation", FALSE),
conditionalPanel("input.network_assess", textInput("network_lengths", "Assessment gap lengths (steps)", value = "1,2,4")),
checkboxInput("network_correct_jumps", "Correct jumps at filled gaps", FALSE),
conditionalPanel("input.network_correct_jumps", numericInput("network_jump_threshold", "Gap jump threshold", value = 0.05, min = 0.001, step = 0.01)),
actionButton("run_network", "Run network interpolation", class = "btn-success w-100"),
tags$hr(),
h5("Jump adjustment"),
selectInput("jump_detection", "Detection method", choices = c("manual", "auto")),
conditionalPanel("input.jump_detection === 'manual'", numericInput("jump_threshold", "Manual threshold", value = 1, min = 0, step = 0.01)),
conditionalPanel("input.jump_detection === 'auto'", numericInput("jump_penalty", "Auto penalty", value = 10, min = 0.01, step = 1)),
selectInput("jump_adjustment", "Adjustment method", choices = c("window_median", "point_diff")),
numericInput("jump_window", "Adjustment window", value = 5, min = 1, step = 1),
checkboxInput("jump_every_second", "Auto: keep every second changepoint", TRUE),
checkboxInput("jump_set_na", "Set exact jump point to NA", FALSE),
actionButton("run_jump_adjust", "Adjust jumps", class = "btn-success w-100"),
tags$hr(),
h5("Standardize"),
selectInput("std_season", "Season type", choices = c("NH", "SH", "CS")),
conditionalPanel("input.std_season === 'CS'", textInput("std_cs", "Custom season DOYs", value = "", placeholder = "100,280")),
selectInput("std_method", "Method", choices = c("center", "amplitude", "robust_amplitude", "minmax", "zscore", "robust_zscore", "percentile")),
actionButton("run_standardize", "Standardize", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_pre_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_pre_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_pre_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::card(
bslib::card_header("Preprocessing output"),
DTOutput("pre_table"),
tags$hr(),
plotOutput("pre_plot", height = 440),
downloadButton("download_pre_plot", "Download current plot")
)
)
),
bslib::nav_panel(
"3. Daily statistics",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("daily_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
textInput("daily_tree", "TreeNum *", value = "1", placeholder = "1, 1:3, or all"),
actionButton("run_daily", "Calculate daily.data()", class = "btn-success w-100"),
tags$hr(),
selectInput("daily_plot_type", "Plot type", choices = c("summary", "amplitude", "minmax_ribbon", "timing", "timing_violin", "lag", "change", "boxplot", "heatmap")),
conditionalPanel("['boxplot','heatmap'].includes(input.daily_plot_type)", selectInput("daily_stat", "Statistic", choices = c("amplitude", "Max_diff", "mean", "median", "Max", "Min", "lag_h", "Time_min_h", "Time_max_h"))),
conditionalPanel("input.daily_plot_type === 'boxplot'", selectInput("daily_by", "Boxplot grouping", choices = c("month", "month_of_year", "year"))),
conditionalPanel("input.daily_plot_type === 'boxplot'", selectInput("daily_box_style", "Box style", choices = c("boxplot", "violin", "both"))),
textInput("daily_year", "Year filter", value = ""),
textInput("daily_doy", "DOY filter", value = ""),
tags$hr(),
h5("Display and save"),
actionButton("show_daily_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_daily_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_daily_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Daily table"), DTOutput("daily_table")),
bslib::card(
bslib::card_header("Daily plot"),
plotOutput("daily_plot", height = 520),
downloadButton("download_daily_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"4. Phase analysis",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("phase_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
radioButtons("phase_method", "Method", choices = c("Zero-growth: phase.zg" = "zg", "Stem-cycle: phase.sc" = "sc"), inline = FALSE),
textInput("phase_tree", "TreeNum *", value = "1"),
numericInput("phase_smoothing", "Smoothing hours (blank/0 = none)", value = 0, min = 0),
conditionalPanel("input.phase_method === 'zg'", numericInput("phase_beta", "ZG beta for ABr", value = 1, min = 0, step = 0.05)),
actionButton("run_phase", "Run phase analysis", class = "btn-success w-100"),
tags$hr(),
uiOutput("phase_plot_controls"),
textInput("phase_year", "Year filter", value = ""),
textInput("phase_doy", "DOY filter", value = ""),
tags$hr(),
numericInput("twd_smoothing", "twd.maxima smoothing", value = 5, min = 1, max = 24),
actionButton("run_twd_maxima", "Run twd.maxima()", class = "btn-outline-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_phase_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_phase_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_phase_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Phase table"), DTOutput("phase_table")),
bslib::card(
bslib::card_header("Phase plot"),
plotOutput("phase_plot", height = 550),
tableOutput("phase_scatter_stats"),
downloadButton("download_phase_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"5. Growth models",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("growth_source", "Input data *", choices = c("Upload dendrometer data first" = "__none__")),
selectInput("growth_engine", "Task", choices = c("Single growth fit" = "single", "Double growth fit" = "double", "Compare methods" = "evaluate")),
textInput("growth_tree", "TreeNum *", value = "all"),
conditionalPanel("input.growth_engine === 'single'", selectInput("growth_method", "Single method", choices = c("gam", "gompertz", "logistic", "richards", "loess", "spline"))),
conditionalPanel("input.growth_engine === 'double'", selectInput("growth_double_method", "Double method", choices = c("gompertz", "richards"))),
conditionalPanel("input.growth_engine === 'evaluate'", checkboxGroupInput("growth_eval_methods", "Methods to compare", choices = c("gam", "gompertz", "logistic", "richards", "loess", "spline", "double_gompertz", "double_richards"), selected = c("gam", "gompertz", "loess", "spline"))),
selectInput("growth_year_mode", "Year mode", choices = c("yearly", "pooled")),
textInput("growth_years", "Vegetation seasons", value = "all"),
checkboxInput("growth_fit_gro", "Fit cumulative GRO", TRUE),
selectInput("growth_site_mode", "Season mode", choices = c("NH", "SH", "CS")),
conditionalPanel("input.growth_site_mode === 'CS'", textInput("growth_custom_season", "Custom season DOYs", value = "275,274")),
textInput("growth_fraction", "Growth fraction", value = "0.1,0.9"),
numericInput("growth_min_unique", "Minimum unique growth", value = 10, min = 3),
numericInput("growth_rate_threshold", "Rate threshold fraction", value = 0.1, min = 0, max = 1, step = 0.05),
checkboxInput("growth_fix_a", "Fix asymptote to observed maximum", FALSE),
actionButton("run_growth", "Run growth task", class = "btn-success w-100"),
tags$hr(),
selectInput("growth_plot_type", "Growth plot type", choices = c("fit", "season", "residuals", "timing", "overlay", "parameters", "boxplot", "mean", "heatmap")),
selectInput("growth_metric", "Evaluation metric", choices = c("rmse", "mae", "bias", "abs_bias", "r2", "correlation", "nrmse", "rss", "aic_approx", "bic_approx")),
selectInput("growth_x_axis", "X axis", choices = c("default", "season_day", "doy", "date")),
tags$hr(),
selectInput("detrend_object", "Growth-fit object to detrend", choices = c()),
actionButton("run_detrend", "Detrend selected fit", class = "btn-outline-success w-100"),
actionButton("run_mean_detrended", "Mean detrended series", class = "btn-outline-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_growth_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_growth_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_growth_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Growth result table"), DTOutput("growth_table")),
bslib::card(
bslib::card_header("Growth plot"),
plotOutput("growth_plot", height = 550),
downloadButton("download_growth_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"6. Climate",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
h5("Climate feature engineering"),
textInput("daily_mean_vars", "Daily mean vars", value = ""),
textInput("daily_min_vars", "Daily min vars", value = ""),
textInput("daily_max_vars", "Daily max vars", value = ""),
textInput("daily_sum_vars", "Daily sum vars", value = ""),
textInput("daily_median_vars", "Daily median vars", value = ""),
actionButton("run_daily_clim", "Create daily climate", class = "btn-success w-100"),
tags$hr(),
textInput("sub_mean_vars", "Subdaily mean vars", value = ""),
textInput("sub_sum_vars", "Subdaily sum vars", value = ""),
textInput("sub_lag_vars", "Subdaily lag vars", value = ""),
textInput("sub_roll_hours", "Rolling windows (h)", value = "3,6,24"),
actionButton("run_subdaily_clim", "Create subdaily climate", class = "btn-success w-100"),
tags$hr(),
h5("Attach climate"),
selectInput("clim_attach_object", "Dendrometer result object", choices = c()),
selectInput("clim_attach_scale", "Scale", choices = c("auto", "daily", "phase", "subdaily")),
actionButton("run_add_climate", "Attach climate", class = "btn-success w-100"),
tags$hr(),
h5("Adverse climate / TWD"),
selectInput("climtwd_source", "Dendrometer data *", choices = c("Upload dendrometer data first" = "__none__")),
selectInput("climtwd_daily_value", "Daily dendrometer value", choices = c("max", "mean", "min", "median")),
textInput("climtwd_var", "Climate variable *", value = "", placeholder = "e.g. prec (blank = first variable)"),
selectInput("climtwd_clim_fun", "Daily climate summary", choices = c("sum", "mean", "min", "max", "median")),
textInput("climtwd_threshold_clim", "Climate threshold *", value = "<10"),
textInput("climtwd_threshold_days", "Duration threshold *", value = ">5"),
actionButton("run_clim_twd", "Run clim.twd()", class = "btn-success w-100"),
selectInput("climtwd_stats_object", "clim.twd object *", choices = c()),
selectInput("climtwd_group", "Group by", choices = c("tree", "species", "site", "species_site")),
actionButton("run_climtwd_stats", "Summarize clim.twd", class = "btn-outline-success w-100"),
tags$hr(),
h5("Running correlation"),
selectInput("movcor_source", "Dendrometer data *", choices = c("Upload dendrometer data first" = "__none__")),
textInput("movcor_tree", "TreeNum *", value = "1"),
numericInput("movcor_win", "Window size", value = 21, min = 18),
selectInput("movcor_method", "Correlation", choices = c("pearson", "kendall", "spearman")),
textInput("movcor_vars", "Climate vars (blank = default)", value = ""),
actionButton("run_movcor", "Run mov.cor.dm()", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_climate_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_climate_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_climate_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(
bslib::card_header("Climate result table"),
DTOutput("climate_table")
),
bslib::card(
bslib::card_header("Climate plot"),
selectInput("climate_plot_object", "Object to plot *", choices = c()),
bslib::layout_columns(
textInput("climate_plot_var", "Climate variable", value = ""),
textInput("climate_metric_var", "Metric variable", value = "")
),
selectInput("climate_plot_type", "Plot type", choices = c("timeseries", "boxplot", "violin", "both", "relation", "cor_heatmap", "regression_heatmap")),
actionButton("refresh_climate_plot", "Refresh plot", class = "btn-outline-primary"),
plotOutput("climate_plot", height = 480),
downloadButton("download_climate_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"7. Wavelets",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
h5("Wavelet analysis"),
selectInput("wave_source", "Dendrometer source *", choices = c("Upload dendrometer data first" = "__none__")),
textInput("wave_tree", "TreeNum *", value = "all"),
selectInput("wave_input_source", "Series source", choices = c("auto", "raw", "detrended", "first_diff")),
selectInput("wave_na", "NA handling", choices = c("interpolate", "fail")),
numericInput("wave_loess", "LOESS span", value = 0, min = 0, max = 1, step = 0.05),
numericInput("wave_dj", "Frequency resolution dj", value = 1/20, min = 0.001, step = 0.001),
textInput("wave_lower", "Lower period (native units)", value = ""),
textInput("wave_upper", "Upper period (native units)", value = ""),
checkboxInput("wave_pval", "Monte Carlo significance", FALSE),
conditionalPanel("input.wave_pval", numericInput("wave_nsim", "Simulations", value = 10, min = 1)),
actionButton("run_wavelet", "Run dm_wavelet()", class = "btn-success w-100"),
tags$hr(),
selectInput("wave_object", "Wavelet object *", choices = c()),
selectInput("wave_plot_type", "Plot type", choices = c("power", "average", "series", "coherence", "cross_power", "average_coherence", "average_cross_power", "phase")),
actionButton("refresh_wave_plot", "Refresh plot", class = "btn-outline-primary w-100"),
tags$hr(),
h5("Reconstruct/remove cycles"),
selectInput("recon_mode", "Mode", choices = c("extract", "remove")),
textInput("recon_series", "Series", value = "", placeholder = "blank = all"),
textInput("recon_periods", "Exact period hours", value = "24", placeholder = "24,168"),
textInput("recon_lower", "Lower hours (with upper: replaces exact periods)", value = ""),
textInput("recon_upper", "Upper hours", value = ""),
actionButton("run_reconstruct", "Run reconstruction", class = "btn-success w-100"),
tags$hr(),
h5("Wavelet coherence"),
textInput("coh_clim_vars", "Climate vars *", value = "all"),
actionButton("run_coherence", "Run coherence", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_wave_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_wave_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_wave_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::layout_columns(
col_widths = c(6, 6),
bslib::card(bslib::card_header("Wavelet result table"), DTOutput("wave_table")),
bslib::card(
bslib::card_header("Wavelet plot"),
plotOutput("wave_plot", height = 540),
downloadButton("download_wave_plot", "Download plot")
)
)
)
),
bslib::nav_panel(
"8. Advanced runner",
bslib::layout_sidebar(
sidebar = bslib::sidebar(
selectInput("adv_function", "Function *", choices = c(
"daily.data", "dendro.resample", "dendro.truncate", "dm.na.interpolation", "network.interpolation",
"phase.zg", "phase.sc", "twd.maxima", "dm.growth.fit", "dm.growth.fit.double", "dm.growth.evaluate",
"dm.detrend.fit", "mean_detrended.dm", "dm_standardize", "clim.twd", "clim.twd.stats",
"mov.cor.dm", "dm_wavelet", "dm_wavelet_reconstruct", "dm_wavelet_coherence", "dm_event_times",
"dm_event_climate", "dm_add_climate", "dm_plot_climate", "jump.locator", "smooth_dm", "reso_dm",
"dm_epoch_extract", "dm_epoch_test", "dm_event_climate_summary", "dm_event_climate_test",
"clim.twd.test", "dm.fit.gompertz", "dm_daily_clim", "dm_subdaily_clim",
"dm_join_daily_clim", "dm_join_subdaily_clim", "dm_join_phase_clim"
)),
selectInput("adv_source", "Primary input *", choices = c("Uploaded dendrometer data" = "__dm__")),
checkboxInput("adv_use_climate", "Pass uploaded climate data if argument exists", TRUE),
checkboxInput("adv_use_reference", "Pass reference network if argument exists", TRUE),
verbatimTextOutput("adv_required"),
tags$label("Extra arguments as R list items"),
tags$textarea(id = "adv_args", class = "form-control", rows = 10,
placeholder = "Example:\nTreeNum = 1, smoothing = 5\n\nDo not include list(...)."),
actionButton("run_advanced", "Run selected function", class = "btn-success w-100"),
tags$hr(),
h5("Display and save"),
actionButton("show_advanced_data", "Show data", class = "btn-outline-primary w-100"),
actionButton("show_advanced_plot", "Show plot", class = "btn-outline-primary w-100"),
actionButton("save_advanced_tab", "Save result to working directory", class = "btn-outline-success w-100")
),
bslib::card(
bslib::card_header("Advanced result"),
DTOutput("advanced_table"),
tags$hr(),
plotOutput("advanced_plot", height = 480),
downloadButton("download_advanced_plot", "Download plot")
)
)
),
bslib::nav_panel(
"9. Results & export",
tags$div(class = "results-workspace",
tags$div(class = "results-controls",
bslib::card(fill = FALSE,
bslib::card_header("1. Load and select a result"),
selectInput("saved_result", "Saved RDS in working directory", choices = character()),
actionButton("reload_result", "Load saved result"),
selectInput("result_object", "Selected result *", choices = character()),
helpText("Choose a result from this session or load an RDS file. The same selection is used for object and table exports."),
actionButton("save_result", "Save complete result", class = "btn-success w-100"),
downloadButton("download_rds", "Download complete RDS"),
tags$details(tags$summary("Other exports and session controls"),
downloadButton("download_csv", "Download primary table CSV"),
downloadButton("download_xlsx", "Download all tables XLSX"),
downloadButton("download_all_zip", "Download all results ZIP"),
actionButton("clear_results", "Clear stored results", class = "btn-outline-danger w-100"))
),
bslib::card(fill = FALSE,
bslib::card_header("2. Export a table"),
selectInput("export_component", "Table within result *", choices = character()),
selectInput("export_format", "File format *", choices = c("CSV" = "csv", "Tab-separated" = "tsv", "Excel" = "xlsx")),
textInput("export_filename", "File name (without extension) *", "exported_table"),
downloadButton("download_selected_table", "Download selected table"),
actionButton("save_selected_table", "Save table to working directory", class = "btn-success w-100"),
helpText("Nested tables are listed by component path. Exports contain all rows; the preview shows up to 5,000. Files are saved under dendroAnalyst_results."),
verbatimTextOutput("export_status")
)
),
tags$div(class = "results-previews",
bslib::card(fill = FALSE, bslib::card_header("Selected table preview"), DTOutput("export_preview")),
bslib::card(fill = FALSE, bslib::card_header("Complete object structure"), verbatimTextOutput("object_summary")),
bslib::card(fill = FALSE, bslib::card_header("Activity log"), verbatimTextOutput("activity_log"))
)
)
)
)
server <- function(input, output, session) {
rv <- reactiveValues(
dm = NULL,
clim = NULL,
ref = NULL,
meta = NULL,
objects = list(),
current_pre = NULL,
current_daily = NULL,
current_phase = NULL,
current_growth = NULL,
current_climate = NULL,
current_wave = NULL,
current_advanced = NULL,
log = character(0),
files_version = 0L,
working_dir = initial_app_wd(),
results_dir = file.path(initial_app_wd(), "dendroAnalyst_results")
)
log_msg <- function(msg, type = "message") {
rv$log <- c(sprintf("[%s] %s", format(Sys.time(), "%Y-%m-%d %H:%M:%S"), msg), rv$log)
showNotification(msg, type = type, duration = if (type == "error") 8 else 4)
}
export_components <- reactive({
req(input$result_object)
export_tables(rv$objects[[input$result_object]])
})
observe({
choices <- names(export_components())
updateSelectInput(session, "export_component", choices = choices)
})
export_table <- reactive({
tabs <- export_components()
validate(need(length(tabs) > 0, "This result contains no exportable tables."))
req(input$export_component)
validate(need(input$export_component %in% names(tabs), "Choose a table within the result."))
tabs[[input$export_component]]
})
output$export_status <- renderText({
tab <- export_table()
paste(nrow(tab), "rows x", ncol(tab), "columns")
})
output$export_preview <- renderDT({
datatable(utils::head(export_table(), 5000), options = list(scrollX = TRUE, pageLength = 10))
})
output$download_selected_table <- downloadHandler(
filename = function() paste0(nice_name(input$export_filename), ".", input$export_format),
content = function(file) write_export_table(export_table(), file, input$export_format)
)
observeEvent(input$save_selected_table, {
tryCatch({
tab <- export_table()
path <- tempfile(pattern = paste0(nice_name(input$export_filename), "_"),
tmpdir = ensure_results_dir(), fileext = paste0(".", input$export_format))
write_export_table(tab, path, input$export_format)
rv$files_version <- rv$files_version + 1L
log_msg(paste("Saved selected table:", path))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
plot_settings <- reactive({
values <- c(width = input$plot_width %||% 10, height = input$plot_height %||% 7,
dpi = input$plot_dpi %||% 160, font = input$plot_font %||% 12)
validate(need(all(is.finite(values)) && all(values >= c(2,2,72,6)) &&
all(values <= c(30,30,600,36)), "Choose plot settings within the displayed limits."))
validate(need(values[1]*values[2]*values[3]^2 <= 5e7, "Reduce dimensions or DPI: maximum 50 million pixels."))
values
})
draw_plot <- function(fun) {
size <- plot_settings()[["font"]]
old <- par(cex = size / 12)
on.exit(par(old), add = TRUE)
p <- fun()
if (inherits(p, "ggplot")) {
p <- p + theme(text = element_text(size = size),
axis.text = element_text(size = size), axis.title = element_text(size = size),
legend.text = element_text(size = size), legend.title = element_text(size = size),
strip.text = element_text(size = size), plot.title = element_text(size = size * 1.2),
plot.subtitle = element_text(size = size))
print(p)
}
invisible(p)
}
save_plot <- function(expr, file) {
cfg <- plot_settings()
png(file, width = cfg[["width"]], height = cfg[["height"]], units = "in", res = cfg[["dpi"]])
on.exit(dev.off(), add = TRUE)
draw_plot(expr)
}
root_paths <- wd_roots()
shinyFiles::shinyDirChoose(
input,
id = "browse_wd",
roots = root_paths,
session = session,
restrictions = system.file(package = "base")
)
observeEvent(input$browse_wd, {
path <- shinyFiles::parseDirPath(root_paths, input$browse_wd)
if (length(path) && nzchar(path)) {
updateTextInput(session, "wd_path", value = normalize_user_path(path))
}
}, ignoreInit = TRUE)
ensure_results_dir <- function() {
if (is.null(rv$working_dir) || !dir.exists(rv$working_dir)) {
stop("Set a valid working directory first.", call. = FALSE)
}
rv$results_dir <- file.path(rv$working_dir, "dendroAnalyst_results")
if (!dir.exists(rv$results_dir)) dir.create(rv$results_dir, recursive = TRUE, showWarnings = FALSE)
rv$results_dir
}
observeEvent(input$set_wd, {
tryCatch({
path <- normalize_user_path(input$wd_path)
if (is.null(path)) stop("Choose or type a folder path first.", call. = FALSE)
if (!dir.exists(path) && isTRUE(input$wd_create)) dir.create(path, recursive = TRUE, showWarnings = FALSE)
if (!dir.exists(path)) stop("Directory does not exist: ", path, call. = FALSE)
rv$working_dir <- normalizePath(path, winslash = "/", mustWork = TRUE)
rv$results_dir <- file.path(rv$working_dir, "dendroAnalyst_results")
dir.create(rv$results_dir, recursive = TRUE, showWarnings = FALSE)
if (isTRUE(input$wd_set_session)) setwd(rv$working_dir)
updateTextInput(session, "wd_path", value = rv$working_dir)
log_msg(paste("Working directory set to", rv$working_dir), "message")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$refresh_wd_files, {
log_msg("Working-directory file list refreshed.", "message")
})
output$wd_status <- renderText({
paste0(
"Current app working directory:\n", rv$working_dir %||% "Not set", "\n\n",
"R session getwd():\n", getwd()
)
})
output$wd_results_dir <- renderText({
ensure <- tryCatch(ensure_results_dir(), error = function(e) rv$results_dir %||% "Not set")
ensure
})
output$wd_files_table <- renderDT({
input$refresh_wd_files
path <- rv$working_dir
if (is.null(path) || !dir.exists(path)) return(datatable(data.frame(message = "Set a working directory first.")))
files <- list.files(path, pattern = paste0("\\.(", paste(app_supported_ext, collapse = "|"), ")$"), ignore.case = TRUE, full.names = TRUE)
if (!length(files)) return(datatable(data.frame(message = "No supported files found in the selected folder.")))
info <- file.info(files)
dat <- data.frame(
file = basename(files),
size_kb = round(info$size / 1024, 1),
modified = info$mtime,
stringsAsFactors = FALSE
)
datatable(dat, options = list(scrollX = TRUE, pageLength = 10))
})
observe({
input$refresh_wd_files
rv$files_version
choices <- wd_file_choices(rv$working_dir)
saved <- choices[grepl("\\.rds$", choices, ignore.case = TRUE)]
updateSelectInput(session, "saved_result", choices = saved)
for (id in c("wd_dm_file", "wd_clim_file", "wd_ref_file", "wd_meta_file")) {
updateSelectInput(session, id, choices = choices)
}
})
load_working_file <- function(file_name, kind = c("dm", "clim", "ref", "meta")) {
kind <- match.arg(kind)
if (is.null(rv$working_dir) || !dir.exists(rv$working_dir)) stop("Set the working directory first.", call. = FALSE)
file_name <- null_if_blank(file_name)
if (is.null(file_name)) stop("Choose a file from the working directory first.", call. = FALSE)
path <- normalizePath(file.path(rv$working_dir, file_name), winslash = "/", mustWork = TRUE)
ext <- tolower(tools::file_ext(path))
if (ext %in% c("rds", "rda", "rdata")) {
obj <- load_r_object_file(path)
} else if (identical(kind, "dm")) {
obj <- call_read_dendrometer(
file = path,
sep = input$dm_sep,
dec = input$dm_dec,
datetime_col = input$dm_datetime_col,
date_col = input$dm_date_col,
time_col = input$dm_time_col,
tz = input$dm_tz,
sheet = input$dm_sheet,
range = input$dm_range
)
} else if (identical(kind, "clim")) {
obj <- call_read_climate(
file = path,
sep = input$clim_sep,
dec = input$clim_dec,
time_col = input$clim_time_col,
vars = input$clim_vars,
tz = input$clim_tz,
sheet = input$clim_sheet
)
} else {
obj <- read_uploaded_table(path)
}
list(path = path, object = obj)
}
save_current_result <- function(current_name, plot_fun = NULL, prefix = "result") {
tryCatch({
if (is.null(current_name) || !nzchar(current_name)) stop("No result has been generated for this tab yet.", call. = FALSE)
obj <- rv$objects[[current_name]]
if (is.null(obj)) stop("Stored result was not found.", call. = FALSE)
resdir <- ensure_results_dir()
stamp <- format(Sys.time(), "%Y%m%d_%H%M%S")
base <- nice_name(paste(prefix, current_name, stamp, sep = "_"))
base <- basename(tempfile(pattern = paste0(base, "_"), tmpdir = resdir))
rds_path <- file.path(resdir, paste0(base, ".rds"))
saveRDS(obj, rds_path)
rv$files_version <- rv$files_version + 1L
log_msg(paste("Saved reusable RDS:", rds_path))
tabs <- all_tables(obj)
if (length(tabs)) {
for (tn in names(tabs)) {
safe_write_csv(tabs[[tn]], file.path(resdir, paste0(base, "__", nice_name(tn), ".csv")))
}
if (requireNamespace("writexl", quietly = TRUE)) {
xlsx_names <- substr(vapply(names(tabs), nice_name, character(1)), 1, 31)
names(tabs) <- make.unique(xlsx_names, sep = "_")
writexl::write_xlsx(tabs, path = file.path(resdir, paste0(base, "__tables.xlsx")))
}
}
if (!is.null(plot_fun)) {
try(save_plot(plot_fun, file.path(resdir, paste0(base, "__plot.png"))), silent = TRUE)
}
log_msg(paste("Saved result files to", resdir), "message")
}, error = function(e) log_msg(conditionMessage(e), "error"))
}
add_object <- function(name, obj) {
nm0 <- nice_name(name)
nm <- nm0
objs <- rv$objects
i <- 1L
while (nm %in% names(objs)) {
nm <- paste0(nm0, "_", i)
i <- i + 1L
}
objs[[nm]] <- obj
rv$objects <- objs
log_msg(paste("Stored result:", nm), "message")
nm
}
selected_source <- function(id) {
if (is.null(id) || id == "__none__") stop("Please select an input data source.", call. = FALSE)
if (id == "__dm__") {
if (is.null(rv$dm)) stop("Please upload dendrometer data first.", call. = FALSE)
return(rv$dm)
}
obj <- rv$objects[[id]]
if (is.null(obj)) stop("Selected object was not found.", call. = FALSE)
tab <- first_table(obj)
if (is.null(tab)) stop("Selected object does not contain a data-frame-like table.", call. = FALSE)
tab
}
selected_object <- function(id) {
if (is.null(id) || id == "__none__") stop("Please select an input object.", call. = FALSE)
if (id == "__dm__") {
if (is.null(rv$dm)) stop("Please upload dendrometer data first.", call. = FALSE)
return(rv$dm)
}
obj <- rv$objects[[id]]
if (is.null(obj)) stop("Selected object was not found.", call. = FALSE)
obj
}
data_source_choices <- reactive({
choices <- c()
if (!is.null(rv$dm)) choices <- c(choices, "Uploaded dendrometer" = "__dm__")
for (nm in names(rv$objects)) {
if (!is.null(first_table(rv$objects[[nm]]))) choices <- c(choices, setNames(nm, nm))
}
if (!length(choices)) choices <- c("Upload dendrometer data first" = "__none__")
choices
})
object_choices <- reactive({
choices <- names(rv$objects)
if (!length(choices)) choices <- character(0)
choices
})
growth_object_choices <- reactive({
nms <- names(rv$objects)
keep <- vapply(nms, function(nm) inherits(rv$objects[[nm]], "dm_growth_fit"), logical(1))
nms[keep]
})
clim_twd_object_choices <- reactive({
nms <- names(rv$objects)
keep <- vapply(nms, function(nm) inherits(rv$objects[[nm]], "clim_twd_output"), logical(1))
nms[keep]
})
wave_object_choices <- reactive({
nms <- names(rv$objects)
keep <- vapply(nms, function(nm) inherits(rv$objects[[nm]], "dm_wavelet") || inherits(rv$objects[[nm]], "dm_wavelet_reconstruct") || inherits(rv$objects[[nm]], "dm_wavelet_coherence"), logical(1))
nms[keep]
})
observe({
ds <- data_source_choices()
for (id in c("pre_source", "daily_source", "phase_source", "growth_source", "climtwd_source", "movcor_source", "wave_source")) {
updateSelectInput(session, id, choices = ds)
}
objs <- object_choices()
updateSelectInput(session, "adv_source", choices = c("Dendrometer data *" = "__dm__", stats::setNames(objs, objs)))
for (id in c("result_object", "clim_attach_object", "climate_plot_object")) {
updateSelectInput(session, id, choices = objs)
}
updateSelectInput(session, "detrend_object", choices = growth_object_choices())
updateSelectInput(session, "climtwd_stats_object", choices = clim_twd_object_choices())
updateSelectInput(session, "wave_object", choices = wave_object_choices())
})
output$activity_log <- renderText({
if (!length(rv$log)) return("No actions yet.")
paste(rv$log, collapse = "\n")
})
observeEvent(input$reload_result, {
tryCatch({
z <- load_working_file(input$saved_result, "dm")
nm <- add_object(tools::file_path_sans_ext(basename(z$path)), z$object)
updateSelectInput(session, "result_object", selected = nm)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$save_result, { save_current_result(input$result_object) })
observeEvent(input$load_wd_dm, {
tryCatch({
z <- load_working_file(input$wd_dm_file, "dm")
rv$dm <- z$object
add_object(paste0("wd_dendrometer_", tools::file_path_sans_ext(basename(z$path))), rv$dm)
log_msg(paste("Dendrometer data loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$load_wd_clim, {
tryCatch({
z <- load_working_file(input$wd_clim_file, "clim")
rv$clim <- z$object
add_object(paste0("wd_climate_", tools::file_path_sans_ext(basename(z$path))), rv$clim)
log_msg(paste("Climate data loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$load_wd_ref, {
tryCatch({
z <- load_working_file(input$wd_ref_file, "ref")
rv$ref <- z$object
add_object(paste0("wd_reference_", tools::file_path_sans_ext(basename(z$path))), rv$ref)
log_msg(paste("Reference network loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$load_wd_meta, {
tryCatch({
z <- load_working_file(input$wd_meta_file, "meta")
rv$meta <- z$object
add_object(paste0("wd_metadata_", tools::file_path_sans_ext(basename(z$path))), rv$meta)
log_msg(paste("Metadata loaded from", basename(z$path)))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_dm, {
req(input$dm_file)
tryCatch({
rv$dm <- call_read_dendrometer(
file = input$dm_file$datapath,
sep = input$dm_sep,
dec = input$dm_dec,
datetime_col = input$dm_datetime_col,
date_col = input$dm_date_col,
time_col = input$dm_time_col,
tz = input$dm_tz,
sheet = input$dm_sheet,
range = input$dm_range
)
add_object("uploaded_dendrometer", rv$dm)
log_msg("Dendrometer data loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_clim, {
req(input$clim_file)
tryCatch({
rv$clim <- call_read_climate(
file = input$clim_file$datapath,
sep = input$clim_sep,
dec = input$clim_dec,
time_col = input$clim_time_col,
vars = input$clim_vars,
tz = input$clim_tz,
sheet = input$clim_sheet
)
add_object("uploaded_climate", rv$clim)
log_msg("Climate data loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_ref, {
req(input$ref_file)
tryCatch({
rv$ref <- read_uploaded_table(input$ref_file$datapath)
add_object("reference_network", rv$ref)
log_msg("Reference network loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$read_meta, {
req(input$meta_file)
tryCatch({
rv$meta <- read_uploaded_table(input$meta_file$datapath)
add_object("tree_metadata", rv$meta)
log_msg("Tree metadata loaded.")
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$dm_preview <- renderDT({
req(rv$dm)
datatable(object_preview(rv$dm), options = list(scrollX = TRUE, pageLength = 8))
})
output$clim_preview <- renderDT({
req(rv$clim)
datatable(object_preview(rv$clim), options = list(scrollX = TRUE, pageLength = 8))
})
observeEvent(input$detect_resolution, {
tryCatch({
df <- selected_source(input$pre_source)
res <- safe_call("reso_dm", list(input_time = df[[1]]), "reso_dm")
rv$current_pre <- add_object("temporal_resolution_minutes", data.frame(resolution_minutes = res))
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$resolution_txt <- renderText({
obj <- rv$objects[[rv$current_pre %||% ""]]
if (is.null(obj) || !is.data.frame(obj) || !"resolution_minutes" %in% names(obj)) return("Resolution not detected yet.")
paste0("Estimated resolution: ", obj$resolution_minutes[1], " minutes")
})
observeEvent(input$run_truncate, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dendro.truncate", list(df = df, CalYear = parse_num_vec(input$truncate_year), DOY = parse_num_vec(input$truncate_doy)), "dendro.truncate")
rv$current_pre <- add_object("truncated_dendrometer", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_resample, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dendro.resample", list(df = df, by = input$resample_by, value = input$resample_value, method = input$resample_method), "dendro.resample")
rv$current_pre <- add_object(paste0("resampled_", input$resample_by), out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_na, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dm.na.interpolation", list(df = df, resolution = input$na_resolution, fill = input$na_fill, method = input$na_method, assess = input$na_assess, verbose = FALSE), "dm.na.interpolation")
rv$current_pre <- add_object("na_interpolation", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_network, {
tryCatch({
df <- selected_source(input$pre_source)
if (is.null(rv$ref)) stop("Load a reference dendrometer network in 1. Data first.", call. = FALSE)
lengths <- parse_num_vec(input$network_lengths)
if (isTRUE(input$network_assess) &&
(is.null(lengths) || any(lengths < 1 | lengths != floor(lengths)))) {
stop("Assessment gap lengths must be positive whole numbers.", call. = FALSE)
}
if (is.null(input$network_boot) || !is.finite(input$network_boot) ||
input$network_boot < 1 || input$network_boot != floor(input$network_boot)) {
stop("Bootstrap samples must be a positive whole number.", call. = FALSE)
}
out <- withProgress(message = "Interpolating with reference network", value = 0.5, {
safe_call("network.interpolation", list(
df = df, referenceDF = rv$ref, niMethod = input$network_method,
n_boot = input$network_boot, return_flags = TRUE,
return_pi = input$network_pi, assess = input$network_assess,
assess_lengths_steps = lengths %||% c(1, 2, 4), progress = FALSE,
correct_gap_jumps = input$network_correct_jumps,
jump_threshold = input$network_jump_threshold
))
})
rv$current_pre <- add_object("network_interpolation", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_jump_adjust, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("jump.locator", list(
df = df,
detection_method = input$jump_detection,
manual_threshold = if (identical(input$jump_detection, "manual")) input$jump_threshold else NULL,
auto_method_penalty = input$jump_penalty,
adjustment_method = input$jump_adjustment,
adjust_window = input$jump_window,
auto_every_second = input$jump_every_second,
set_jump_point_na = input$jump_set_na
), "jump.locator")
rv$current_pre <- add_object("jump_adjusted_dendrometer", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_standardize, {
tryCatch({
df <- selected_source(input$pre_source)
out <- safe_call("dm_standardize", list(df = df, season_type = input$std_season, CS_doys = parse_num_vec(input$std_cs), method = input$std_method), "dm_standardize")
rv$current_pre <- add_object("standardized_dendrometer", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$pre_table <- renderDT({
req(input$show_pre_data > 0)
req(rv$current_pre)
datatable(object_preview(rv$objects[[rv$current_pre]]), options = list(scrollX = TRUE, pageLength = 10))
})
make_pre_plot <- reactive({
req(rv$current_pre)
obj <- rv$objects[[rv$current_pre]]
force(obj)
function() {
if (inherits(obj, c("dm_na_interpolation", "dm_standardized", "network_interpolation"))) return(plot(obj))
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal() + ggplot2::labs(x = names(tab)[1], y = names(tab)[2])
}
})
output$pre_plot <- renderPlot({ req(input$show_pre_plot > 0); draw_plot(make_pre_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_pre_plot <- downloadHandler(
filename = function() paste0("preprocess_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_pre_plot(), file)
)
observeEvent(input$save_pre_tab, { save_current_result(rv$current_pre, make_pre_plot(), "preprocess") })
observeEvent(input$run_daily, {
tryCatch({
df <- selected_source(input$daily_source)
out <- safe_call("daily.data", list(df = df, TreeNum = parse_tree(input$daily_tree)), "daily.data")
rv$current_daily <- add_object("daily_statistics", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$daily_table <- renderDT({
req(input$show_daily_data > 0)
req(rv$current_daily)
datatable(object_preview(rv$objects[[rv$current_daily]]), options = list(scrollX = TRUE, pageLength = 12))
})
make_daily_plot <- reactive({
req(rv$current_daily)
obj <- rv$objects[[rv$current_daily]]
function() {
plot(
obj,
type = input$daily_plot_type,
stat = input$daily_stat,
by = input$daily_by,
box_style = input$daily_box_style,
Year = parse_num_vec(input$daily_year),
DOY = parse_num_vec(input$daily_doy)
)
}
})
output$daily_plot <- renderPlot({ req(input$show_daily_plot > 0); draw_plot(make_daily_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_daily_plot <- downloadHandler(
filename = function() paste0("daily_plot_", input$daily_plot_type, "_", Sys.Date(), ".png"),
content = function(file) save_plot(make_daily_plot(), file)
)
observeEvent(input$save_daily_tab, { save_current_result(rv$current_daily, make_daily_plot(), "daily") })
observeEvent(input$run_phase, {
tryCatch({
df <- selected_source(input$phase_source)
smooth <- if (is.null(input$phase_smoothing) || input$phase_smoothing <= 0) NULL else input$phase_smoothing
if (identical(input$phase_method, "zg")) {
out <- safe_call("phase.zg", list(df = df, TreeNum = parse_tree(input$phase_tree), smoothing = smooth, beta = input$phase_beta), "phase.zg")
nm <- "phase_zg"
} else {
out <- safe_call("phase.sc", list(df = df, TreeNum = parse_tree(input$phase_tree), smoothing = smooth), "phase.sc")
nm <- "phase_sc"
}
rv$current_phase <- add_object(nm, out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_twd_maxima, {
tryCatch({
df <- selected_source(input$phase_source)
out <- safe_call("twd.maxima", list(df = df, TreeNum = parse_tree(input$phase_tree), smoothing = input$twd_smoothing), "twd.maxima")
rv$current_phase <- add_object("twd_maxima", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$phase_table <- renderDT({
req(input$show_phase_data > 0)
req(rv$current_phase)
datatable(object_preview(rv$objects[[rv$current_phase]]), options = list(scrollX = TRUE, pageLength = 12))
})
phase_plot_kind <- reactive({
obj <- rv$objects[[rv$current_phase %||% ""]]
if (inherits(obj, "ZG_output")) "ZG_output" else if (inherits(obj, "SC_output")) "SC_output" else "table"
})
output$phase_plot_controls <- renderUI({
kind <- phase_plot_kind()
if (kind == "table") return(helpText("Run phase analysis to select its plot options."))
types <- eval(formals(pkg_fun(paste0("plot.", kind)))$type)
tagList(
helpText(paste("Plotting stored result:", rv$current_phase)),
selectInput("phase_plot_type", "Plot type *", choices = types),
if (kind == "ZG_output") tagList(
conditionalPanel("['gro_twd','twd','phase_ribbon','boxplot'].includes(input.phase_plot_type)",
selectInput("phase_temporal", "Temporal scale", choices = c("raw", "daily", "weekly", "monthly", "yearly"))),
conditionalPanel("['abr','slope_diagnostics','event_timeline','boxplot'].includes(input.phase_plot_type)",
selectInput("phase_metric", "Event metric *", choices = {
cycle <- rv$objects[[rv$current_phase]]$ZG_cycle
names(cycle)[vapply(cycle, is.numeric, logical(1))]
}, selected = "ABr.value")),
conditionalPanel("input.phase_plot_type === 'scatter'",
selectInput("phase_scatter_source", "Source table *", c("ZG_cycle", "ZG_drought")),
uiOutput("phase_scatter_variables"),
selectInput("phase_scatter_fit", "Fit relationship", c("None" = "none", "Linear" = "linear")))
),
if (kind == "SC_output") conditionalPanel("input.phase_plot_type === 'boxplot'",
selectInput("phase_stat", "Cycle statistic *", choices = {
cycle <- rv$objects[[rv$current_phase]]$SC_cycle
names(cycle)[vapply(cycle,is.numeric,logical(1))]
}, selected = "Magnitude"),
selectInput("phase_temporal", "Calendar grouping", choices=c("monthly","daily","weekly","yearly","raw"))),
conditionalPanel("['points','both','shrinkage','expansion','increment','slope_diagnostics','scatter'].includes(input.phase_plot_type)",
numericInput("phase_point_size", "Point size", 2.5, min = 0.1, max = 10, step = 0.1)),
conditionalPanel("['ribbon','both','phase_ribbon'].includes(input.phase_plot_type)",
sliderInput("phase_ribbon_alpha", "Ribbon opacity", min = 0, max = 1, value = 0.35))
)
})
output$phase_scatter_variables <- renderUI({
req(rv$current_phase)
dat <- rv$objects[[rv$current_phase]][[input$phase_scatter_source %||% "ZG_cycle"]]
if (!is.data.frame(dat)) return(helpText("This result has no selected table; run phase analysis again."))
choices <- names(dat)[vapply(dat, is.numeric, logical(1))]
tagList(selectInput("phase_scatter_x", "X parameter *", choices, selected = choices[1]),
selectInput("phase_scatter_y", "Y parameter *", choices, selected = if ("ABr.value" %in% choices) "ABr.value" else choices[2]))
})
make_phase_plot <- reactive({
req(rv$current_phase)
obj <- rv$objects[[rv$current_phase]]
kind <- phase_plot_kind()
function() {
if (kind != "table") {
fun <- pkg_fun(paste0("plot.", kind))
types <- eval(formals(fun)$type)
type <- input$phase_plot_type %||% types[1]
validate(need(type %in% types, "Select a plot type for the current result."))
args <- list(x = obj, type = type, Year = parse_num_vec(input$phase_year),
DOY = parse_num_vec(input$phase_doy),
point_size = input$phase_point_size %||% 2.5,
ribbon_alpha = input$phase_ribbon_alpha %||% 0.35)
if (kind == "SC_output" && type == "boxplot") {
args$stat <- input$phase_stat %||% "Magnitude"
args$temporal <- input$phase_temporal %||% "monthly"
}
if (kind == "ZG_output") {
args$temporal <- if (type %in% c("gro_twd", "twd", "phase_ribbon", "boxplot")) input$phase_temporal %||% "raw" else "raw"
args$metric <- input$phase_metric %||% "ABr.value"
if (type == "scatter") {
req(input$phase_scatter_x, input$phase_scatter_y)
args$source <- input$phase_scatter_source %||% "ZG_cycle"
args$xvar <- input$phase_scatter_x
args$yvar <- input$phase_scatter_y
args$fit <- input$phase_scatter_fit %||% "none"
}
}
do.call(fun, args)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic plot available."))
ggplot(tab, aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) + geom_line() + theme_minimal()
}
}
})
output$phase_plot <- renderPlot({ req(input$show_phase_plot > 0); draw_plot(make_phase_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$phase_scatter_stats <- renderTable({
req(input$show_phase_plot > 0, input$phase_plot_type == "scatter", phase_plot_kind() == "ZG_output")
attr(make_phase_plot()(), "scatter_stats")
}, digits = 5)
output$download_phase_plot <- downloadHandler(
filename = function() paste0("phase_plot_", input$phase_plot_type, "_", Sys.Date(), ".png"),
content = function(file) save_plot(make_phase_plot(), file)
)
observeEvent(input$save_phase_tab, { save_current_result(rv$current_phase, make_phase_plot(), "phase") })
observeEvent(input$run_growth, {
tryCatch({
df <- selected_source(input$growth_source)
common <- list(
df = df,
TreeNum = parse_tree(input$growth_tree),
years = parse_chr_vec(input$growth_years, default = "all"),
year_mode = input$growth_year_mode,
fit_GRO = input$growth_fit_gro,
site_mode = input$growth_site_mode,
custom_veg_season = parse_num_vec(input$growth_custom_season, default = c(275, 274)),
growth_fraction = parse_num_vec(input$growth_fraction, default = c(0.1, 0.9)),
min_unique_growth = input$growth_min_unique,
rate_threshold_fraction = input$growth_rate_threshold,
verbose = TRUE
)
if (identical(input$growth_engine, "single")) {
args <- c(common, list(method = input$growth_method, fix_a_to_observed_max = input$growth_fix_a))
out <- safe_call("dm.growth.fit", args, "dm.growth.fit")
nm <- paste0("growth_fit_", input$growth_method)
} else if (identical(input$growth_engine, "double")) {
args <- c(common, list(method = input$growth_double_method, fix_a_to_observed_max = input$growth_fix_a))
out <- safe_call("dm.growth.fit.double", args, "dm.growth.fit.double")
nm <- paste0("growth_fit_double_", input$growth_double_method)
} else {
args <- c(common, list(methods = input$growth_eval_methods))
out <- safe_call("dm.growth.evaluate", args, "dm.growth.evaluate")
nm <- "growth_method_evaluation"
}
rv$current_growth <- add_object(nm, out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_detrend, {
tryCatch({
req(input$detrend_object)
obj <- rv$objects[[input$detrend_object]]
out <- safe_call("dm.detrend.fit", list(x = obj), "dm.detrend.fit")
rv$current_growth <- add_object("detrended_growth_fit", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_mean_detrended, {
tryCatch({
req(rv$current_growth)
obj <- rv$objects[[rv$current_growth]]
out <- safe_call("mean_detrended.dm", list(detrended_dm = obj), "mean_detrended.dm")
rv$current_growth <- add_object("mean_detrended_series", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$growth_table <- renderDT({
req(input$show_growth_data > 0)
req(rv$current_growth)
datatable(object_preview(rv$objects[[rv$current_growth]]), options = list(scrollX = TRUE, pageLength = 12))
})
observe({
obj <- rv$objects[[rv$current_growth %||% ""]]
choices <- if (inherits(obj,"dm_growth_evaluation")) c("boxplot","mean","heatmap") else if (inherits(obj,"dm_detrended")) c("compare","boxplot") else if (inherits(obj,"mean_dm_detrended")) "default" else c("fit","season","residuals","timing","overlay","parameters")
updateSelectInput(session,"growth_plot_type",choices=choices)
})
observe({
name <- input$wave_object
if (is.null(name) || !nzchar(name)) name <- rv$current_wave
obj <- rv$objects[[name %||% ""]]
choices <- if (inherits(obj,"dm_wavelet_coherence")) c("coherence","cross_power","average_coherence","average_cross_power","phase","series") else if (inherits(obj,"dm_wavelet_reconstruct")) "compare" else c("power","average","series")
updateSelectInput(session,"wave_plot_type",choices=choices)
})
make_growth_plot <- reactive({
req(rv$current_growth)
obj <- rv$objects[[rv$current_growth]]
function() {
if (inherits(obj, "dm_growth_evaluation")) {
eval_type <- if (input$growth_plot_type %in% c("boxplot", "mean", "heatmap")) input$growth_plot_type else "boxplot"
plot(obj, metric = input$growth_metric, type = eval_type)
} else if (inherits(obj, "dm_growth_fit")) {
fit_type <- if (input$growth_plot_type %in% c("fit", "season", "residuals", "timing", "overlay", "parameters")) input$growth_plot_type else "fit"
plot(obj, type = fit_type, x_axis = input$growth_x_axis)
} else if (inherits(obj, "dm_detrended")) {
plot(obj, type = if (input$growth_plot_type %in% c("boxplot")) "boxplot" else "compare")
} else if (inherits(obj, "mean_dm_detrended")) {
plot(obj)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic growth plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
}
}
})
output$growth_plot <- renderPlot({ req(input$show_growth_plot > 0); draw_plot(make_growth_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_growth_plot <- downloadHandler(
filename = function() paste0("growth_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_growth_plot(), file)
)
observeEvent(input$save_growth_tab, { save_current_result(rv$current_growth, make_growth_plot(), "growth") })
observeEvent(input$run_daily_clim, {
tryCatch({
req(rv$clim)
out <- safe_call("dm_daily_clim", list(
clim_df = rv$clim,
mean_vars = parse_chr_vec(input$daily_mean_vars, NULL),
min_vars = parse_chr_vec(input$daily_min_vars, NULL),
max_vars = parse_chr_vec(input$daily_max_vars, NULL),
sum_vars = parse_chr_vec(input$daily_sum_vars, NULL),
median_vars = parse_chr_vec(input$daily_median_vars, NULL)
), "dm_daily_clim")
rv$current_climate <- add_object("daily_climate", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_subdaily_clim, {
tryCatch({
req(rv$clim)
out <- safe_call("dm_subdaily_clim", list(
clim_df = rv$clim,
mean_vars = parse_chr_vec(input$sub_mean_vars, NULL),
sum_vars = parse_chr_vec(input$sub_sum_vars, NULL),
lag_vars = parse_chr_vec(input$sub_lag_vars, NULL),
roll_hours = parse_num_vec(input$sub_roll_hours, c(3, 6, 24))
), "dm_subdaily_clim")
rv$current_climate <- add_object("subdaily_climate", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_add_climate, {
tryCatch({
req(input$clim_attach_object, rv$clim)
obj <- rv$objects[[input$clim_attach_object]]
out <- safe_call("dm_add_climate", list(
x = obj,
clim = rv$clim,
scale = input$clim_attach_scale,
mean_vars = parse_chr_vec(input$daily_mean_vars, NULL),
min_vars = parse_chr_vec(input$daily_min_vars, NULL),
max_vars = parse_chr_vec(input$daily_max_vars, NULL),
sum_vars = parse_chr_vec(input$daily_sum_vars, NULL),
median_vars = parse_chr_vec(input$daily_median_vars, NULL),
sub_mean_vars = parse_chr_vec(input$sub_mean_vars, NULL),
sub_sum_vars = parse_chr_vec(input$sub_sum_vars, NULL),
sub_lag_vars = parse_chr_vec(input$sub_lag_vars, NULL),
roll_hours = parse_num_vec(input$sub_roll_hours, c(3, 6, 24))
), "dm_add_climate")
rv$current_climate <- add_object("climate_attached", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_clim_twd, {
tryCatch({
if (is.null(rv$clim)) stop("Please load climate data first.", call. = FALSE)
df <- selected_source(input$climtwd_source)
# clim.twd() needs daily climate with a date column and one variable
clim <- as.data.frame(rv$clim)
num_vars <- names(clim)[-1][vapply(clim[-1], is.numeric, logical(1))]
if (!length(num_vars)) stop("The climate data contain no numeric variable.", call. = FALSE)
var <- null_if_blank(input$climtwd_var) %||% num_vars[1]
if (!var %in% num_vars) stop("Climate variable '", var, "' was not found. Available: ", paste(num_vars, collapse = ", "), call. = FALSE)
tm <- clim[[1]]
if (!inherits(tm, c("Date", "POSIXct"))) tm <- lubridate::parse_date_time(tm, c("Ymd HMS", "Ymd HM", "Ymd"))
date <- if (inherits(tm, "POSIXct")) as.Date(format(tm, "%Y-%m-%d")) else as.Date(tm)
fun <- match.fun(input$climtwd_clim_fun %||% "sum")
clim_day <- stats::aggregate(list(value = clim[[var]]), by = list(DATE = date),
FUN = function(v) if (all(is.na(v))) NA_real_ else fun(v, na.rm = TRUE))
names(clim_day)[2] <- var
out <- safe_call("clim.twd", list(
df = df,
Clim = clim_day,
dailyValue = input$climtwd_daily_value,
thresholdClim = input$climtwd_threshold_clim,
thresholdDays = input$climtwd_threshold_days,
showPlot = FALSE
), "clim.twd")
rv$current_climate <- add_object("climate_twd", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_climtwd_stats, {
tryCatch({
req(input$climtwd_stats_object)
obj <- rv$objects[[input$climtwd_stats_object]]
out <- safe_call("clim.twd.stats", list(x = obj, tree_info = rv$meta, group_by = input$climtwd_group), "clim.twd.stats")
rv$current_climate <- add_object("climate_twd_stats", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_movcor, {
tryCatch({
req(rv$clim)
df <- selected_source(input$movcor_source)
out <- safe_call("mov.cor.dm", list(
df = df,
Clim = rv$clim,
TreeNum = parse_int(input$movcor_tree, 1),
win_size = input$movcor_win,
cor_method = input$movcor_method,
clim_vars = parse_chr_vec(input$movcor_vars, NULL)
), "mov.cor.dm")
rv$current_climate <- add_object("moving_correlation", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$climate_table <- renderDT({
req(input$show_climate_data > 0)
req(rv$current_climate)
datatable(object_preview(rv$objects[[rv$current_climate]]), options = list(scrollX = TRUE, pageLength = 12))
})
# Climate variables attached to a daily, ZG or SC climate object
climate_var_choices <- function(obj) {
ns <- asNamespace(app_pkg)
if (inherits(obj, "daily_output_clim")) {
dat <- as.data.frame(obj)
num <- names(dat)[vapply(dat, is.numeric, logical(1))]
raw <- if (!is.null(rv$clim)) names(rv$clim)[-1] else character()
hit <- num[vapply(num, function(n) any(n == raw | startsWith(n, paste0(raw, "_"))), logical(1))]
return(if (length(hit)) hit else num)
}
kind <- if (inherits(obj, "ZG_output_clim")) "ZG" else "SC"
cyc <- as.data.frame(obj[[paste0(kind, "_cycle")]])
ph <- as.data.frame(obj[[paste0(kind, "_phase")]])
unique(c(ns$.dm_detect_cycle_climate_cols(cyc, kind = kind), ns$.dm_detect_point_climate_cols(ph, kind = kind)))
}
observe({
obj <- rv$objects[[input$climate_plot_object %||% ""]]
if (!inherits(obj, c("daily_output_clim", "ZG_output_clim", "SC_output_clim"))) return()
ch <- tryCatch(climate_var_choices(obj), error = function(e) character())
if (length(ch)) updateTextInput(session, "climate_plot_var", placeholder = paste("blank =", ch[1], "| available:", paste(head(ch, 6), collapse = ", ")))
})
make_climate_plot <- reactive({
input$refresh_climate_plot
obj_name <- input$climate_plot_object %||% rv$current_climate
req(obj_name)
obj <- rv$objects[[obj_name]]
function() {
if (inherits(obj, c("daily_output_clim", "ZG_output_clim", "SC_output_clim"))) {
if(input$climate_plot_type %in% c("cor_heatmap","regression_heatmap")) return(pkg_fun("dm_plot_climate_compare")(x=obj,type=input$climate_plot_type))
choices <- climate_var_choices(obj)
validate(need(length(choices) > 0, "No attached climate variables were found in this object."))
cvar <- null_if_blank(input$climate_plot_var) %||% choices[1]
validate(need(cvar %in% choices, paste0("Climate variable '", cvar, "' was not found. Available: ", paste(choices, collapse = ", "))))
pkg_fun("dm_plot_climate")(
x = obj,
climate_var = cvar,
metric_var = null_if_blank(input$climate_metric_var),
type = input$climate_plot_type
)
} else if (inherits(obj, "mov_cor_dm")) {
plot(obj)
} else if (inherits(obj, "clim_twd_stats")) {
plot(obj)
} else if (inherits(obj, "clim_twd_test")) {
plot(obj)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic climate plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
}
}
})
output$climate_plot <- renderPlot({ req(input$show_climate_plot > 0); draw_plot(make_climate_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_climate_plot <- downloadHandler(
filename = function() paste0("climate_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_climate_plot(), file)
)
observeEvent(input$save_climate_tab, { save_current_result(rv$current_climate, make_climate_plot(), "climate") })
observeEvent(input$run_wavelet, {
tryCatch({
obj <- selected_object(input$wave_source)
out <- safe_call("dm_wavelet", list(
x = obj,
TreeNum = parse_tree(input$wave_tree),
source = input$wave_input_source,
na_action = input$wave_na,
loess_span = input$wave_loess,
dj = input$wave_dj,
lowerPeriod = parse_num_vec(input$wave_lower, NULL),
upperPeriod = parse_num_vec(input$wave_upper, NULL),
make_pval = input$wave_pval,
n_sim = input$wave_nsim,
verbose = TRUE
), "dm_wavelet")
rv$current_wave <- add_object("wavelet", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_reconstruct, {
tryCatch({
req(input$wave_object)
obj <- rv$objects[[input$wave_object]]
lower <- parse_num_vec(input$recon_lower, NULL)
upper <- parse_num_vec(input$recon_upper, NULL)
use_band <- !is.null(lower) && !is.null(upper)
out <- safe_call("dm_wavelet_reconstruct", list(
x = obj,
series = parse_chr_vec(input$recon_series, NULL),
mode = input$recon_mode,
period_hours = if (use_band) NULL else parse_num_vec(input$recon_periods, NULL),
lower_hours = if (use_band) lower else NULL,
upper_hours = if (use_band) upper else NULL
), "dm_wavelet_reconstruct")
rv$current_wave <- add_object("wavelet_reconstruction", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
observeEvent(input$run_coherence, {
tryCatch({
req(rv$clim)
dm_obj <- selected_object(input$wave_source)
out <- safe_call("dm_wavelet_coherence", list(
dm = dm_obj,
clim = rv$clim,
TreeNum = parse_tree(input$wave_tree),
clim_vars = parse_chr_vec(input$coh_clim_vars, default = "all"),
source = input$wave_input_source,
na_action = input$wave_na,
loess_span = input$wave_loess,
dj = input$wave_dj,
make_pval = input$wave_pval,
n_sim = input$wave_nsim,
verbose = TRUE
), "dm_wavelet_coherence")
rv$current_wave <- add_object("wavelet_coherence", out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$wave_table <- renderDT({
req(input$show_wave_data > 0)
req(rv$current_wave)
datatable(object_preview(rv$objects[[rv$current_wave]]), options = list(scrollX = TRUE, pageLength = 12))
})
make_wave_plot <- reactive({
input$refresh_wave_plot
obj_name <- input$wave_object %||% rv$current_wave
if (is.null(obj_name) || !nzchar(obj_name)) obj_name <- rv$current_wave
req(obj_name)
obj <- rv$objects[[obj_name]]
function() {
if (inherits(obj, "dm_wavelet")) {
wtype <- if (input$wave_plot_type %in% c("power", "average", "series")) input$wave_plot_type else "power"
plot(obj, type = wtype)
} else if (inherits(obj, "dm_wavelet_reconstruct")) {
plot(obj, type = "compare")
} else if (inherits(obj, "dm_wavelet_coherence")) {
ctype <- if (input$wave_plot_type %in% c("coherence", "cross_power", "average_coherence", "average_cross_power", "phase", "series")) input$wave_plot_type else "coherence"
plot(obj, type = ctype)
} else {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic wavelet plot available for this result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
}
}
})
output$wave_plot <- renderPlot({ req(input$show_wave_plot > 0); draw_plot(make_wave_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_wave_plot <- downloadHandler(
filename = function() paste0("wavelet_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_wave_plot(), file)
)
observeEvent(input$save_wave_tab, { save_current_result(rv$current_wave, make_wave_plot(), "wavelet") })
output$adv_required <- renderText({
req(input$adv_function)
f <- formals(pkg_fun(input$adv_function))
required <- names(f)[vapply(f, function(x) identical(x, quote(expr = )), logical(1))]
paste("Required arguments (*):", paste(setdiff(required, "..."), collapse = ", "), "\nPrimary input and enabled climate/reference inputs are passed automatically when supported.")
})
parse_adv_args <- function(txt) {
txt <- null_if_blank(txt)
if (is.null(txt)) return(list())
eval(parse(text = paste0("list(", txt, ")")), envir = parent.frame())
}
observeEvent(input$run_advanced, {
tryCatch({
fun <- pkg_fun(input$adv_function)
fml <- names(formals(fun))
args <- parse_adv_args(input$adv_args)
primary <- selected_object(input$adv_source)
for (arg in intersect(c("daily_obj", "event_data"), fml)) {
if (is.null(args[[arg]])) args[[arg]] <- primary
}
if ("events" %in% fml && is.null(args$events)) args$events <- primary
if (identical(input$adv_function, "smooth_dm")) {
tab <- first_table(primary)
if (is.null(args$time)) args$time <- tab[[1]]
if (is.null(args$dm)) args$dm <- tab[[2]]
}
if (identical(input$adv_function, "dm_wavelet_coherence") && is.null(args$dm)) args$dm <- primary
if ("tree_info" %in% fml && is.null(args$tree_info) && !is.null(rv$meta)) args$tree_info <- rv$meta
if ("df" %in% fml && is.null(args$df)) args$df <- if (is.data.frame(primary)) primary else first_table(primary)
if ("x" %in% fml && is.null(args$x)) args$x <- primary
if ("detrended_dm" %in% fml && is.null(args$detrended_dm)) args$detrended_dm <- primary
if ("input_time" %in% fml && is.null(args$input_time)) args$input_time <- first_table(primary)[[1]]
if (isTRUE(input$adv_use_climate) && !is.null(rv$clim)) {
if ("Clim" %in% fml && is.null(args$Clim)) args$Clim <- rv$clim
if ("clim" %in% fml && is.null(args$clim)) args$clim <- rv$clim
if ("clim_df" %in% fml && is.null(args$clim_df)) args$clim_df <- rv$clim
if ("clim_daily" %in% fml && is.null(args$clim_daily)) args$clim_daily <- rv$clim
if ("clim_sub" %in% fml && is.null(args$clim_sub)) args$clim_sub <- rv$clim
}
if (isTRUE(input$adv_use_reference) && !is.null(rv$ref) && "referenceDF" %in% fml && is.null(args$referenceDF)) args$referenceDF <- rv$ref
out <- do.call(fun, args)
rv$current_advanced <- add_object(paste0("advanced_", input$adv_function), out)
}, error = function(e) log_msg(conditionMessage(e), "error"))
})
output$advanced_table <- renderDT({
req(input$show_advanced_data > 0)
req(rv$current_advanced)
datatable(object_preview(rv$objects[[rv$current_advanced]]), options = list(scrollX = TRUE, pageLength = 12))
})
make_advanced_plot <- reactive({
req(rv$current_advanced)
obj <- rv$objects[[rv$current_advanced]]
function() {
tryCatch(plot(obj), error = function(e) {
tab <- first_table(obj)
validate(need(!is.null(tab) && ncol(tab) >= 2, "No automatic plot method available for this advanced result."))
ggplot2::ggplot(as.data.frame(tab), ggplot2::aes(x = .data[[names(tab)[1]]], y = .data[[names(tab)[2]]])) +
ggplot2::geom_line() + ggplot2::theme_minimal()
})
}
})
output$advanced_plot <- renderPlot({ req(input$show_advanced_plot > 0); draw_plot(make_advanced_plot()) }, width = function() plot_settings()[["width"]] * 96, height = function() plot_settings()[["height"]] * 96, res = 96)
output$download_advanced_plot <- downloadHandler(
filename = function() paste0("advanced_plot_", Sys.Date(), ".png"),
content = function(file) save_plot(make_advanced_plot(), file)
)
observeEvent(input$save_advanced_tab, { save_current_result(rv$current_advanced, make_advanced_plot(), "advanced") })
output$object_summary <- renderPrint({
req(input$result_object)
str(rv$objects[[input$result_object]], max.level = 2, give.attr = FALSE)
})
output$result_table <- renderDT({
req(input$result_object)
datatable(object_preview(rv$objects[[input$result_object]]), options = list(scrollX = TRUE, pageLength = 15))
})
output$download_rds <- downloadHandler(
filename = function() paste0(input$result_object %||% "result", ".rds"),
content = function(file) {
req(input$result_object)
saveRDS(rv$objects[[input$result_object]], file)
}
)
output$download_csv <- downloadHandler(
filename = function() paste0(input$result_object %||% "result", ".csv"),
content = function(file) {
req(input$result_object)
tab <- first_table(rv$objects[[input$result_object]])
validate(need(!is.null(tab), "The selected object does not contain a table."))
safe_write_csv(tab, file)
}
)
output$download_xlsx <- downloadHandler(
filename = function() paste0(input$result_object %||% "result", "_tables.xlsx"),
content = function(file) {
req(input$result_object)
tabs <- all_tables(rv$objects[[input$result_object]])
validate(need(length(tabs) > 0, "The selected object does not contain tables."))
if (!requireNamespace("writexl", quietly = TRUE)) stop("Package 'writexl' is required for XLSX export.")
names(tabs) <- substr(vapply(names(tabs), nice_name, character(1)), 1, 31)
writexl::write_xlsx(tabs, path = file)
}
)
output$download_all_zip <- downloadHandler(
filename = function() paste0("dendroAnalyst_results_", Sys.Date(), ".zip"),
content = function(file) {
tmp <- tempfile("dendro_results_")
dir.create(tmp, recursive = TRUE)
dir.create(file.path(tmp, "objects"))
dir.create(file.path(tmp, "tables"))
for (nm in names(rv$objects)) {
saveRDS(rv$objects[[nm]], file.path(tmp, "objects", paste0(nice_name(nm), ".rds")))
tabs <- all_tables(rv$objects[[nm]])
if (length(tabs)) {
for (tn in names(tabs)) {
safe_write_csv(tabs[[tn]], file.path(tmp, "tables", paste0(nice_name(nm), "__", nice_name(tn), ".csv")))
}
}
}
writeLines(rv$log, file.path(tmp, "activity_log.txt"))
oldwd <- getwd()
on.exit(setwd(oldwd), add = TRUE)
setwd(tmp)
files <- list.files(".", recursive = TRUE, full.names = FALSE)
if (requireNamespace("zip", quietly = TRUE)) {
zip::zipr(zipfile = file, files = files)
} else {
utils::zip(zipfile = file, files = files)
}
}
)
observeEvent(input$clear_results, {
rv$objects <- list()
rv$current_pre <- rv$current_daily <- rv$current_phase <- rv$current_growth <- rv$current_climate <- rv$current_wave <- rv$current_advanced <- NULL
log_msg("Stored results cleared.", "warning")
})
}
shinyApp(ui, server)
Try the dendRoAnalyst 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.