R/plot_growth_boundaries.R

In dendRoAnalyst: A Tool for Processing and Analyzing Dendrometer Data

# Draw existing timing estimates without changing their calculation.
dmgp_draw_boundary_marks <- function(p, marks, dat, x_var, fit_call) {
  fraction <- tryCatch(eval(fit_call$growth_fraction, baseenv()), error = function(e) NULL)
  labels <- if (is.numeric(fraction) && length(fraction) == 2L) {
    paste0(format(100 * fraction, trim = TRUE), "% growth")
  } else if (is.null(fit_call$growth_fraction)) c("10% growth", "90% growth") else {
    c("Lower growth threshold", "Upper growth threshold")
  }
  rate <- tryCatch(eval(fit_call$rate_threshold_fraction, baseenv()), error = function(e) NULL)
  rate_label <- if (is.numeric(rate) && length(rate) == 1L) {
    paste0("Active growth (", 100 * rate, "% peak rate)")
  } else if (is.null(fit_call$rate_threshold_fraction)) "Active growth (10% peak rate)" else "Active growth"
  points <- bars <- list()
  panels <- unique(dat$facet_var)
  for (panel in panels) {
    panel_dat <- dat[dat$facet_var == panel, , drop = FALSE]
    limits <- range(c(panel_dat$observed_plot, panel_dat$fitted_plot), finite = TRUE)
    if (any(!is.finite(limits))) next
    span <- max(diff(limits), abs(limits[2]) * 0.1, 1e-6)
    groups <- unique(as.character(panel_dat$colour_group))
    for (i in seq_along(groups)) {
      group <- groups[i]
      curve <- panel_dat[as.character(panel_dat$colour_group) == group, , drop = FALSE]
      curve <- curve[is.finite(curve$fitted_plot) & !is.na(curve[[x_var]]), , drop = FALSE]
      if (!nrow(curve)) next
      boundary <- marks$cumulative
      if (nrow(boundary)) {
        boundary <- boundary[boundary$facet_var == panel & boundary$curve_group == group, , drop = FALSE]
        if (nrow(boundary)) {
          boundary$y <- vapply(as.numeric(boundary$x), function(xx) {
            curve$fitted_plot[which.min(abs(as.numeric(curve[[x_var]]) - xx))]
          }, numeric(1))
          boundary$ymin <- boundary$y - 0.12 * span
          boundary$label <- labels[ifelse(boundary$boundary == "cumulative_start", 1, 2)]
          points[[length(points) + 1L]] <- boundary
        }
      }
      active <- marks$rate
      if (nrow(active)) {
        active <- active[active$facet_var == panel & active$curve_group == group, , drop = FALSE]
        if (nrow(active) == 2L) {
          bar <- active[1, , drop = FALSE]
          bar$xend <- active$x[2]
          bar$y <- limits[1] - (0.16 + 0.14 * (i - 1)) * span
          bar$label <- rate_label
          bars[[length(bars) + 1L]] <- bar
        }
      }
    }
  }
  pts <- dplyr::bind_rows(points)
  intervals <- dplyr::bind_rows(bars)
  if (nrow(pts)) {
    p <- p + ggplot2::geom_segment(data = pts, ggplot2::aes(x = .data$x, xend = .data$x,
      y = .data$ymin, yend = .data$y, colour = .data$curve_group), linetype = "dashed", show.legend = FALSE) +
      ggplot2::geom_point(data = pts, ggplot2::aes(x = .data$x, y = .data$y, colour = .data$curve_group),
        shape = 21, fill = "white", size = 2.8, stroke = 1, show.legend = FALSE) +
      ggplot2::geom_text(data = pts, ggplot2::aes(x = .data$x, y = .data$y, label = .data$label,
        colour = .data$curve_group), vjust = -1, size = 3, show.legend = FALSE)
  }
  if (nrow(intervals)) {
    p <- p + ggplot2::geom_segment(data = intervals, ggplot2::aes(x = .data$x, xend = .data$xend,
      y = .data$y, yend = .data$y, colour = .data$curve_group), linewidth = 2, show.legend = FALSE) +
      ggplot2::geom_text(data = intervals, ggplot2::aes(x = .data$x, y = .data$y,
        label = .data$label, colour = .data$curve_group), hjust = 0, vjust = 1.8, size = 3, show.legend = FALSE)
  }
  p + ggplot2::labs(caption = "Open circles: cumulative-growth boundaries on the fitted curve. Lower bars: active-growth windows.\nDates are unchanged; bars are annotations, not negative growth.") +
    ggplot2::scale_y_continuous(expand = ggplot2::expansion(mult = c(0.10, 0.15)))
}