Timon
1da5c0d0a7
- Implemented `weather_api_comparison.py` to compare daily precipitation from multiple weather APIs for Arnhem, Netherlands and Angata, Kenya. - Integrated fetching functions for various weather data sources including Open-Meteo, NASA POWER, OpenWeatherMap, and WeatherAPI.com. - Added plotting functions to visualize archive and forecast data, including cumulative precipitation and comparison against ERA5 reference. - Created `90_rainfall_utils.R` for R to fetch rainfall data and overlay it on CI plots, supporting multiple providers with a generic fetch wrapper. - Included spatial helpers for efficient API calls based on unique geographical tiles.
1441 lines
58 KiB
R
1441 lines
58 KiB
R
# 90_REPORT_UTILS.R
|
||
# =============
|
||
# Utility functions for generating SmartCane reports with visualizations.
|
||
# These functions support the creation of maps, charts and report elements
|
||
# for the CI_report_dashboard_planet.Rmd document.
|
||
|
||
#' Creates a sub-chunk for use within RMarkdown documents
|
||
#'
|
||
#' @param g A ggplot object to render in the sub-chunk
|
||
#' @param fig_height Height of the figure in inches
|
||
#' @param fig_width Width of the figure in inches
|
||
#' @return NULL (writes chunk directly to output)
|
||
#'
|
||
subchunkify <- function(g, fig_height=7, fig_width=5) {
|
||
g_deparsed <- paste0(deparse(
|
||
function() {
|
||
if (inherits(g, c("gtable", "grob", "gTree"))) {
|
||
grid::grid.newpage()
|
||
grid::grid.draw(g)
|
||
} else {
|
||
print(g)
|
||
}
|
||
}
|
||
), collapse = '\n')
|
||
|
||
sub_chunk <- paste0("
|
||
`","``{r sub_chunk_", floor(runif(1) * 10000), ", fig.height=", fig_height, ", fig.width=", fig_width, ", dpi=300, dev='png', out.width='100%', echo=FALSE}",
|
||
"\n(",
|
||
g_deparsed
|
||
, ")()",
|
||
"\n`","``
|
||
")
|
||
|
||
cat(knitr::knit(text = knitr::knit_expand(text = sub_chunk), quiet = TRUE))
|
||
}
|
||
|
||
#' Translate a key using the global `tr` vector, with an optional fallback.
|
||
#' Unified replacement for the Rmd's tr_key() — covers both markdown text and
|
||
#' plot/map labels. Supports {variable} placeholders resolved from the caller.
|
||
#' Falls back to `fallback` (if provided) or the key string itself when missing.
|
||
tr_key <- function(key, fallback = NULL) {
|
||
tr_exists <- exists("tr", envir = globalenv(), inherits = FALSE)
|
||
|
||
if (tr_exists && !is.na(key) && key %in% names(get("tr", envir = globalenv()))) {
|
||
raw <- get("tr", envir = globalenv())[[key]]
|
||
} else if (!is.null(fallback)) {
|
||
raw <- as.character(fallback)
|
||
} else if (is.na(key)) {
|
||
return(tr_key("NA"))
|
||
} else if (identical(key, "")) {
|
||
return("")
|
||
} else {
|
||
return(enc2utf8(as.character(key)))
|
||
}
|
||
|
||
result <- tryCatch(
|
||
as.character(glue::glue(raw, .envir = parent.frame())),
|
||
error = function(e) as.character(raw)
|
||
)
|
||
# Convert literal \n (as stored in Excel cells) to real newlines
|
||
enc2utf8(gsub("\\n", "\n", result, fixed = TRUE))
|
||
}
|
||
|
||
#' Creates a Chlorophyll Index map for a pivot
|
||
#'
|
||
#' @param pivot_raster The raster data containing CI values
|
||
#' @param pivot_shape The shape of the pivot field
|
||
#' @param pivot_spans Additional boundary data for the field
|
||
#' @param show_legend Whether to show the legend (default: FALSE)
|
||
#' @param legend_is_portrait Whether to show the legend in portrait orientation (default: FALSE)
|
||
#' @param legend_position Position for the legend when shown: "left", "right", "top", "bottom" (default: "bottom")
|
||
#' @param week Week number to display in the title
|
||
#' @param age Age of the crop in weeks
|
||
#' @param borders Whether to display field borders (default: FALSE)
|
||
#' @return A tmap object with the CI map
|
||
#'
|
||
create_CI_map <- function(pivot_raster, pivot_shape, pivot_spans, show_legend = F, legend_is_portrait = F, legend_position = "bottom", week, age, borders = FALSE, colorblind = FALSE){
|
||
# Input validation
|
||
if (missing(pivot_raster) || is.null(pivot_raster)) {
|
||
stop("pivot_raster is required")
|
||
}
|
||
if (missing(pivot_shape) || is.null(pivot_shape)) {
|
||
stop("pivot_shape is required")
|
||
}
|
||
if (missing(pivot_spans) || is.null(pivot_spans)) {
|
||
stop("pivot_spans is required")
|
||
}
|
||
if (missing(week) || is.null(week)) {
|
||
stop("week parameter is required")
|
||
}
|
||
if (missing(age) || is.null(age)) {
|
||
stop("age parameter is required")
|
||
}
|
||
|
||
# Choose palette based on colorblind flag
|
||
palette <- if (colorblind) "viridis" else "brewer.rd_yl_gn"
|
||
|
||
# Create the base map
|
||
map <- tm_shape(pivot_raster, unit = "m")
|
||
|
||
# Add raster with continuous spectrum (fixed scale 8-1 for consistent comparison, reversed)
|
||
map <- map + tm_raster(
|
||
"CI",
|
||
col.scale = tm_scale_continuous(
|
||
values = palette,
|
||
limits = c(1, 8),
|
||
ticks = seq(1, 8, by = 1),
|
||
outliers.trunc = c(TRUE, TRUE)
|
||
),
|
||
col.legend = tm_legend(
|
||
title = tr_key("map_legend_ci_title", "CI"),
|
||
orientation = if (legend_is_portrait) "portrait" else "landscape",
|
||
show = show_legend,
|
||
position = if (show_legend) tm_pos_out(legend_position, "center") else c("left", "bottom"),
|
||
reverse = TRUE
|
||
)
|
||
)
|
||
# Add layout elements
|
||
age_days <- age * 7
|
||
map <- map + tm_layout(
|
||
main.title = tr_key("map_title_max_ci", "Max CI week {week}\n{age} weeks ({age_days} days) old"),
|
||
main.title.size = 0.7,
|
||
#legend.height = 0.85, # Constrain vertical legend height to not exceed map
|
||
asp = 1 # Fixed aspect ratio
|
||
)
|
||
|
||
# Add borders if requested
|
||
if (borders) {
|
||
map <- map +
|
||
tm_shape(pivot_shape) +
|
||
tm_borders(lwd = 3) +
|
||
tm_text("sub_field", size = 1/2) +
|
||
tm_shape(pivot_spans) +
|
||
tm_borders(lwd = 0.5, alpha = 0.5)
|
||
}
|
||
|
||
return(map)
|
||
}
|
||
|
||
#' Creates a Chlorophyll Index difference map between two weeks
|
||
#'
|
||
#' @param pivot_raster The raster data containing CI difference values
|
||
#' @param pivot_shape The shape of the pivot field
|
||
#' @param pivot_spans Additional boundary data for the field
|
||
#' @param show_legend Whether to show the legend (default: FALSE)
|
||
#' @param legend_is_portrait Whether to show the legend in portrait orientation (default: FALSE)
|
||
#' @param legend_position Position for the legend when shown: "left", "right", "top", "bottom" (default: "bottom")
|
||
#' @param week_1 First week number for comparison
|
||
#' @param week_2 Second week number for comparison
|
||
#' @param age Age of the crop in weeks
|
||
#' @param borders Whether to display field borders (default: TRUE)
|
||
#' @return A tmap object with the CI difference map
|
||
#'
|
||
create_CI_diff_map <- function(pivot_raster, pivot_shape, pivot_spans, show_legend = F, legend_is_portrait = F, legend_position = "bottom", week_1, week_2, age, borders = TRUE, colorblind = FALSE){
|
||
# Input validation
|
||
if (missing(pivot_raster) || is.null(pivot_raster)) {
|
||
stop("pivot_raster is required")
|
||
}
|
||
if (missing(pivot_shape) || is.null(pivot_shape)) {
|
||
stop("pivot_shape is required")
|
||
}
|
||
if (missing(pivot_spans) || is.null(pivot_spans)) {
|
||
stop("pivot_spans is required")
|
||
}
|
||
if (missing(week_1) || is.null(week_1) || missing(week_2) || is.null(week_2)) {
|
||
stop("week_1 and week_2 parameters are required")
|
||
}
|
||
if (missing(age) || is.null(age)) {
|
||
stop("age parameter is required")
|
||
}
|
||
|
||
# Choose palette based on colorblind flag
|
||
palette <- if (colorblind) "plasma" else "brewer.rd_yl_gn"
|
||
|
||
# Create the base map
|
||
map <- tm_shape(pivot_raster, unit = "m")
|
||
|
||
# Add raster with continuous spectrum (centered at 0 for difference maps, fixed scale, reversed)
|
||
map <- map + tm_raster(
|
||
"CI",
|
||
col.scale = tm_scale_continuous(
|
||
values = palette,
|
||
limits = c(-3, 3),
|
||
ticks = seq(-3, 3, by = 1),
|
||
midpoint = 0,
|
||
outliers.trunc = c(TRUE, TRUE)
|
||
),
|
||
col.legend = tm_legend(
|
||
title = tr_key("map_legend_ci_diff", "CI diff."),
|
||
orientation = if (legend_is_portrait) "portrait" else "landscape",
|
||
show = show_legend,
|
||
position = if (show_legend) tm_pos_out(legend_position, "center") else c("left", "bottom"),
|
||
reverse = TRUE
|
||
)
|
||
)
|
||
# Add layout elements
|
||
age_days <- age * 7
|
||
map <- map + tm_layout(
|
||
main.title = tr_key("map_title_ci_change", "CI change week {week_1} - week {week_2}\n{age} weeks ({age_days} days) old"),
|
||
main.title.size = 0.7,
|
||
#legend.height = 0.85, # Constrain vertical legend height to not exceed map
|
||
asp = 1 # Fixed aspect ratio
|
||
)
|
||
|
||
# Add borders if requested
|
||
if (borders) {
|
||
map <- map +
|
||
tm_shape(pivot_shape) +
|
||
tm_borders(lwd = 3) +
|
||
tm_text("sub_field", size = 1/2) +
|
||
tm_shape(pivot_spans) +
|
||
tm_borders(lwd = 0.5, alpha = 0.5)
|
||
}
|
||
|
||
return(map)
|
||
}
|
||
|
||
#' Creates a visualization of CI data for a specific pivot field
|
||
#'
|
||
#' @param pivotName The name or ID of the pivot field to visualize
|
||
#' @param field_boundaries Field boundaries spatial data (sf object)
|
||
#' @param current_ci Current week's Chlorophyll Index raster
|
||
#' @param ci_minus_1 Previous week's Chlorophyll Index raster
|
||
#' @param ci_minus_2 Two weeks ago Chlorophyll Index raster
|
||
#' @param last_week_diff Difference raster between current and last week
|
||
#' @param three_week_diff Difference raster between current and three weeks ago
|
||
#' @param harvesting_data Data frame containing field harvesting/planting information
|
||
#' @param week Current week number
|
||
#' @param week_minus_1 Previous week number
|
||
#' @param week_minus_2 Two weeks ago week number
|
||
#' @param week_minus_3 Three weeks ago week number
|
||
#' @param borders Whether to display field borders (default: TRUE)
|
||
#' @param colorblind_friendly Whether to use colorblind-friendly color schemes (default: FALSE)
|
||
#' @return NULL (adds output directly to R Markdown document)
|
||
#'
|
||
ci_plot <- function(pivotName,
|
||
field_boundaries = AllPivots0,
|
||
current_ci = CI,
|
||
ci_minus_1 = CI_m1,
|
||
ci_minus_2 = CI_m2,
|
||
last_week_diff = last_week_dif_raster_abs,
|
||
three_week_diff = three_week_dif_raster_abs,
|
||
harvesting_data = harvesting_data,
|
||
week = week,
|
||
week_minus_1 = week_minus_1,
|
||
week_minus_2 = week_minus_2,
|
||
week_minus_3 = week_minus_3,
|
||
borders = TRUE,
|
||
colorblind_friendly = FALSE){
|
||
# Input validation
|
||
if (missing(pivotName) || is.null(pivotName) || pivotName == "") {
|
||
stop("pivotName is required")
|
||
}
|
||
if (missing(field_boundaries) || is.null(field_boundaries)) {
|
||
stop("field_boundaries is required")
|
||
}
|
||
if (missing(current_ci) || is.null(current_ci)) {
|
||
stop("current_ci is required")
|
||
}
|
||
# Note: ci_minus_1, ci_minus_2, last_week_diff, three_week_diff are now optional
|
||
# (may be NULL if historical data is not available for early seasons)
|
||
if (missing(harvesting_data) || is.null(harvesting_data)) {
|
||
stop("harvesting_data is required")
|
||
}
|
||
|
||
# Warn if critical rasters are missing
|
||
if (is.null(ci_minus_1) || is.null(ci_minus_2)) {
|
||
safe_log(paste("Warning: Historical CI data missing for field", pivotName, "- will show current week only"), "WARNING")
|
||
}
|
||
if (is.null(last_week_diff) || is.null(three_week_diff)) {
|
||
safe_log(paste("Warning: Difference rasters missing for field", pivotName, "- difference maps skipped"), "WARNING")
|
||
}
|
||
|
||
# Extract pivot shape and age data
|
||
tryCatch({
|
||
pivotShape <- field_boundaries %>% dplyr::filter(field %in% pivotName) %>% sf::st_transform(terra::crs(current_ci))
|
||
age <- harvesting_data %>%
|
||
dplyr::filter(field %in% pivotName) %>%
|
||
sort("year") %>%
|
||
tail(., 1) %>%
|
||
dplyr::select(age) %>%
|
||
unique() %>%
|
||
pull() %>%
|
||
round()
|
||
|
||
# Filter for the specific pivot
|
||
AllPivots2 <- field_boundaries %>% dplyr::filter(field %in% pivotName)
|
||
|
||
# Per-field mosaics are already cropped to field boundaries, so use directly without cropping
|
||
singlePivot <- current_ci
|
||
singlePivot_m1 <- ci_minus_1
|
||
singlePivot_m2 <- ci_minus_2
|
||
|
||
# Use difference maps directly (already field-specific)
|
||
abs_CI_last_week <- last_week_diff
|
||
abs_CI_three_week <- three_week_diff
|
||
|
||
# Get planting date
|
||
planting_date <- harvesting_data %>%
|
||
dplyr::filter(field %in% pivotName) %>%
|
||
ungroup() %>%
|
||
dplyr::select(season_start) %>%
|
||
unique()
|
||
|
||
# Create spans for borders
|
||
joined_spans2 <- field_boundaries %>%
|
||
sf::st_transform(sf::st_crs(pivotShape)) %>%
|
||
dplyr::filter(field %in% pivotName)
|
||
|
||
# Create maps conditionally based on data availability
|
||
# Always create current week map (required)
|
||
CImap <- create_CI_map(singlePivot, AllPivots2, joined_spans2,
|
||
show_legend = FALSE, legend_is_portrait = FALSE,
|
||
week = week, age = age, borders = borders, colorblind = colorblind_friendly)
|
||
|
||
# Create historical maps only if data is available
|
||
# Build list with all available maps - order matches original: [m2, m1, current, diff_1w, diff_3w]
|
||
maps_to_arrange <- list()
|
||
field_heading_note <- ""
|
||
|
||
# Try to create 2-week ago map (legend on left)
|
||
if (!is.null(singlePivot_m2)) {
|
||
CImap_m2 <- create_CI_map(singlePivot_m2, AllPivots2, joined_spans2,
|
||
show_legend = TRUE, legend_is_portrait = TRUE,
|
||
legend_position = "left",
|
||
week = week_minus_2, age = age - 2, borders = borders, colorblind = colorblind_friendly)
|
||
maps_to_arrange <- c(maps_to_arrange, list(CImap_m2))
|
||
}
|
||
|
||
# Try to create 1-week ago map
|
||
if (!is.null(singlePivot_m1)) {
|
||
CImap_m1 <- create_CI_map(singlePivot_m1, AllPivots2, joined_spans2,
|
||
show_legend = FALSE, legend_is_portrait = FALSE,
|
||
week = week_minus_1, age = age - 1, borders = borders, colorblind = colorblind_friendly)
|
||
maps_to_arrange <- c(maps_to_arrange, list(CImap_m1))
|
||
}
|
||
|
||
# Always add current week map (center position)
|
||
maps_to_arrange <- c(maps_to_arrange, list(CImap))
|
||
|
||
# Try to create 1-week difference map
|
||
if (!is.null(abs_CI_last_week)) {
|
||
CI_max_abs_last_week <- create_CI_diff_map(abs_CI_last_week, AllPivots2, joined_spans2,
|
||
show_legend = FALSE, legend_is_portrait = FALSE,
|
||
week_1 = week, week_2 = week_minus_1, age = age, borders = borders, colorblind = colorblind_friendly)
|
||
maps_to_arrange <- c(maps_to_arrange, list(CI_max_abs_last_week))
|
||
}
|
||
|
||
# Try to create 3-week difference map (legend on right)
|
||
if (!is.null(abs_CI_three_week)) {
|
||
CI_max_abs_three_week <- create_CI_diff_map(abs_CI_three_week, AllPivots2, joined_spans2,
|
||
show_legend = TRUE, legend_is_portrait = TRUE,
|
||
legend_position = "right",
|
||
week_1 = week, week_2 = week_minus_3, age = age, borders = borders, colorblind = colorblind_friendly)
|
||
maps_to_arrange <- c(maps_to_arrange, list(CI_max_abs_three_week))
|
||
}
|
||
|
||
# Add note if historical data is limited
|
||
if (length(maps_to_arrange) == 1) {
|
||
field_heading_note <- " (Current week only - historical data not yet available)"
|
||
} else if (length(maps_to_arrange) < 5) {
|
||
field_heading_note <- " (Limited historical data)"
|
||
}
|
||
|
||
# Arrange the maps in a row with more width for first and last (for legends)
|
||
# Give maps with legends (1st and 5th) more space: 23%, middle maps get 18% each
|
||
widths <- if (length(maps_to_arrange) == 5) {
|
||
c(0.23, 0.18, 0.18, 0.18, 0.23)
|
||
} else if (length(maps_to_arrange) == 4) {
|
||
c(0.25, 0.25, 0.25, 0.25) # Equal if only 4 maps
|
||
} else if (length(maps_to_arrange) == 3) {
|
||
c(0.33, 0.33, 0.34) # Equal if only 3 maps
|
||
} else if (length(maps_to_arrange) == 2) {
|
||
c(0.5, 0.5) # Equal if only 2 maps
|
||
} else {
|
||
NULL # Single map or other cases
|
||
}
|
||
|
||
tst <- do.call(tmap_arrange, c(maps_to_arrange, list(nrow = 1, widths = widths)))
|
||
|
||
# Output heading and map to R Markdown
|
||
age_months <- round(age / 4.348, 1)
|
||
cat(paste0("## ", tr_key("field_section_header", "Field {pivotName} - {age} weeks/ {age_months} months after planting/harvest"), field_heading_note, "\n\n"))
|
||
print(tst)
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error creating CI plot for pivot", pivotName, ":", e$message), "ERROR")
|
||
cat(paste("# Field", pivotName, "- Error creating visualization", "\n\n"))
|
||
cat(paste("Error:", e$message, "\n\n"))
|
||
})
|
||
}
|
||
|
||
#' Creates a plot showing Chlorophyll Index data over time for a pivot field
|
||
#'
|
||
#' @param pivotName The name or ID of the pivot field to visualize
|
||
#' @param ci_quadrant_data Data frame containing CI quadrant data with field, sub_field, Date, DAH, cumulative_CI, value and season columns
|
||
#' @param plot_type Type of plot to generate: "absolute", "cumulative", or "both"
|
||
#' @param facet_on Whether to facet the plot by season (TRUE) or overlay all seasons (FALSE)
|
||
#' @param x_unit Unit for x-axis: "days" for DAH or "weeks" for week number (default: "days")
|
||
#' @param colorblind_friendly Whether to use colorblind-friendly color schemes (default: FALSE)
|
||
#' @param show_benchmarks Whether to show historical benchmark lines (default: FALSE)
|
||
#' @param estate_name Name of the estate for benchmark calculation (required if show_benchmarks = TRUE)
|
||
#' @param benchmark_percentiles Vector of percentiles for benchmarks (default: c(10, 50, 90))
|
||
#' @param rain_data data.frame(date, rain_mm) for this field's current season,
|
||
#' as returned by rain_fetch_for_fields() / rain_join_to_ci(). NULL disables overlay.
|
||
#' @return NULL (adds output directly to R Markdown document)
|
||
#'
|
||
cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "absolute", facet_on = FALSE, x_unit = "days", colorblind_friendly = FALSE, show_benchmarks = FALSE, estate_name = NULL, benchmark_percentiles = c(10, 50, 90), benchmark_data = NULL, rain_data = NULL) {
|
||
# Input validation
|
||
if (missing(pivotName) || is.null(pivotName) || pivotName == "") {
|
||
stop("pivotName is required")
|
||
}
|
||
if (missing(ci_quadrant_data) || is.null(ci_quadrant_data)) {
|
||
stop("ci_quadrant_data is required")
|
||
}
|
||
if (!plot_type %in% c("absolute", "cumulative", "both")) {
|
||
stop("plot_type must be one of: 'absolute', 'cumulative', or 'both'")
|
||
}
|
||
if (!x_unit %in% c("days", "weeks")) {
|
||
stop("x_unit must be either 'days' or 'weeks'")
|
||
}
|
||
|
||
# Filter data for the specified pivot
|
||
tryCatch({
|
||
data_ci <- ci_quadrant_data %>% dplyr::filter(field == pivotName)
|
||
|
||
if (nrow(data_ci) == 0) {
|
||
safe_log(paste("No CI data found for field", pivotName), "WARNING")
|
||
return(cum_ci_plot2(pivotName)) # Use fallback function when no data is available
|
||
}
|
||
|
||
# Process data
|
||
data_ci2 <- data_ci %>%
|
||
dplyr::mutate(CI_rate = cumulative_CI / DAH,
|
||
week = lubridate::week(Date)) %>%
|
||
dplyr::group_by(field) %>%
|
||
dplyr::mutate(mean_CIrate_rolling_10_days = zoo::rollapplyr(CI_rate, width = 10, FUN = mean, partial = TRUE),
|
||
mean_rolling_10_days = zoo::rollapplyr(value, width = 10, FUN = mean, partial = TRUE))
|
||
|
||
data_ci2 <- data_ci2 %>% dplyr::mutate(season = as.factor(season))
|
||
|
||
# Resolved translated labels (used for y-axis labels and facet strip labels)
|
||
rolling_mean_label <- tr_key("lbl_rolling_mean_ci", "10-Day Rolling Mean CI")
|
||
cumulative_label <- tr_key("lbl_cumulative_ci", "Cumulative CI")
|
||
|
||
# Compute benchmarks if requested and not provided
|
||
if (show_benchmarks && is.null(benchmark_data)) {
|
||
benchmark_data <- compute_ci_benchmarks(ci_quadrant_data, estate_name, benchmark_percentiles)
|
||
}
|
||
|
||
# Prepare benchmark data for plotting if available
|
||
if (!is.null(benchmark_data)) {
|
||
benchmark_data <- benchmark_data %>%
|
||
dplyr::mutate(
|
||
ci_type_label = case_when(
|
||
ci_type == "value" ~ rolling_mean_label,
|
||
ci_type == "cumulative_CI" ~ cumulative_label,
|
||
TRUE ~ ci_type
|
||
),
|
||
benchmark_label = paste0(percentile, "th Percentile")
|
||
)
|
||
safe_log("Benchmark data prepared for plotting", "INFO")
|
||
} else if (show_benchmarks) {
|
||
safe_log("No benchmark data available", "WARNING")
|
||
}
|
||
data_ci3 <- tidyr::pivot_longer(
|
||
data_ci2,
|
||
cols = c("mean_rolling_10_days", "cumulative_CI"),
|
||
names_to = "ci_type", # This column will say "mean_rolling_10_days" or "cumulative_CI"
|
||
values_to = "ci_value" # This column will have the numeric values
|
||
)
|
||
|
||
# Prepare date information by season
|
||
date_preparation_perfect_pivot <- data_ci2 %>%
|
||
dplyr::group_by(season) %>%
|
||
dplyr::summarise(min_date = min(Date),
|
||
max_date = max(Date),
|
||
days = max_date - min_date)
|
||
|
||
# Get the 3 most recent seasons
|
||
unique_seasons <- sort(unique(date_preparation_perfect_pivot$season), decreasing = TRUE)[1:3]
|
||
latest_season <- unique_seasons[1] # Identify the latest season
|
||
|
||
# Create plotting function that uses data_ci3 and filters by ci_type
|
||
create_plot <- function(ci_type_filter, y_label, title_suffix) {
|
||
# Filter data based on ci_type
|
||
plot_data <- data_ci3 %>%
|
||
dplyr::filter(season %in% unique_seasons, ci_type == ci_type_filter) %>%
|
||
dplyr::mutate(is_latest = season == latest_season) # Flag for latest season
|
||
|
||
# Determine x-axis variable based on x_unit parameter
|
||
x_var <- if (x_unit == "days") {
|
||
if (facet_on) "Date" else "DAH"
|
||
} else {
|
||
"week"
|
||
}
|
||
|
||
x_label <- switch(x_unit,
|
||
"days" = if (facet_on) tr_key("lbl_date", "Date") else tr_key("lbl_age_of_crop_days", "Age of Crop (Days)"),
|
||
"weeks" = tr_key("lbl_week_number", "Week Number"))
|
||
|
||
# Calculate dynamic max values for breaks
|
||
max_dah <- max(plot_data$DAH, na.rm = TRUE) + 20
|
||
max_week <- max(as.numeric(plot_data$week), na.rm = TRUE) + ceiling(20 / 7)
|
||
|
||
# Create plot with either facets by season or overlay by DAH/week
|
||
if (facet_on) {
|
||
g <- ggplot2::ggplot(data = plot_data) +
|
||
ggplot2::facet_wrap(~season, scales = "free_x") +
|
||
ggplot2::geom_line(
|
||
ggplot2::aes(
|
||
x = .data[[x_var]],
|
||
y = .data[["ci_value"]],
|
||
col = .data[["sub_field"]],
|
||
group = .data[["sub_field"]]
|
||
)
|
||
) +
|
||
ggplot2::labs(title = paste(tr_key("lbl_plot_of", "Plot of"), y_label),
|
||
color = tr_key("lbl_field_name", "Field Name"),
|
||
y = y_label,
|
||
x = x_label) +
|
||
ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%m-%Y",
|
||
sec.axis = ggplot2::sec_axis(~ ., name = tr_key("lbl_age_in_months", "Age in Months"),
|
||
breaks = scales::breaks_pretty(),
|
||
labels = function(x) round(as.numeric(x - min(x)) / 30.44, 1))) +
|
||
ggplot2::theme_minimal() +
|
||
ggplot2::theme(axis.text.x = ggplot2::element_text(hjust = 0.5),
|
||
axis.text.x.top = ggplot2::element_text(hjust = 0.5),
|
||
axis.title.x.top = ggplot2::element_text(size = 8),
|
||
legend.justification = c(1, 0),
|
||
legend.position = "inside",
|
||
legend.position.inside = c(1, 0),
|
||
legend.title = ggplot2::element_text(size = 8),
|
||
legend.text = ggplot2::element_text(size = 8)) +
|
||
ggplot2::guides(color = ggplot2::guide_legend(nrow = 2, byrow = TRUE))
|
||
} else {
|
||
# Choose color palette based on colorblind_friendly flag
|
||
color_scale <- if (colorblind_friendly) {
|
||
ggplot2::scale_color_brewer(type = "qual", palette = "Set2")
|
||
} else {
|
||
ggplot2::scale_color_discrete()
|
||
}
|
||
|
||
g <- ggplot2::ggplot(data = plot_data) +
|
||
# Add benchmark lines first (behind season lines)
|
||
{
|
||
if (!is.null(benchmark_data) && ci_type_filter %in% benchmark_data$ci_type) {
|
||
# Clip benchmark to max DAH of plotted seasons + 10% buffer
|
||
max_dah_clip <- max(plot_data$DAH, na.rm = TRUE) * 1.1
|
||
benchmark_subset <- benchmark_data %>%
|
||
dplyr::filter(ci_type == ci_type_filter, DAH <= max_dah_clip) %>%
|
||
dplyr::mutate(
|
||
benchmark_x = if (x_var == "DAH") {
|
||
DAH
|
||
} else if (x_var == "week") {
|
||
DAH / 7
|
||
} else {
|
||
DAH
|
||
}
|
||
)
|
||
ggplot2::geom_smooth(
|
||
data = benchmark_subset,
|
||
ggplot2::aes(
|
||
x = .data[["benchmark_x"]],
|
||
y = .data[["benchmark_value"]],
|
||
group = factor(.data[["percentile"]])
|
||
),
|
||
color = "gray70", linewidth = 0.5, se = FALSE, inherit.aes = FALSE, fullrange = FALSE
|
||
)
|
||
}
|
||
} +
|
||
# Plot older seasons with lighter lines
|
||
ggplot2::geom_line(
|
||
data = plot_data %>% dplyr::filter(!is_latest),
|
||
ggplot2::aes(
|
||
x = .data[[x_var]],
|
||
y = .data[["ci_value"]],
|
||
col = .data[["season"]],
|
||
group = .data[["season"]]
|
||
),
|
||
linewidth = 0.7, alpha = 0.4
|
||
) +
|
||
# Plot latest season with thicker, more prominent line
|
||
ggplot2::geom_line(
|
||
data = plot_data %>% dplyr::filter(is_latest),
|
||
ggplot2::aes(
|
||
x = .data[[x_var]],
|
||
y = .data[["ci_value"]],
|
||
col = .data[["season"]],
|
||
group = .data[["season"]]
|
||
),
|
||
linewidth = 1.5, alpha = 1
|
||
) +
|
||
ggplot2::labs(title = paste(tr_key("lbl_plot_of", "Plot of"), y_label, tr_key("lbl_for_field", "for Field"), pivotName, title_suffix),
|
||
color = tr_key("lbl_season", "Season"),
|
||
y = y_label,
|
||
x = x_label) +
|
||
color_scale +
|
||
{
|
||
if (x_var == "DAH") {
|
||
# Dynamic breaks based on actual data range
|
||
max_dah_plot <- max(plot_data$DAH, na.rm = TRUE)
|
||
# Ensure the max value is included in breaks
|
||
max_dah_plot <- max(plot_data$DAH, na.rm = TRUE)
|
||
dah_breaks <- scales::pretty_breaks(n = 5)(c(0, max_dah_plot))
|
||
# Month breaks: in secondary axis scale (month numbers 0, 1, 2, ...)
|
||
n_months <- ceiling(max_dah_plot / 30.44)
|
||
month_breaks <- seq(0, n_months, by = 1)
|
||
ggplot2::scale_x_continuous(
|
||
breaks = dah_breaks,
|
||
sec.axis = ggplot2::sec_axis(
|
||
~ . / 30.44,
|
||
name = tr_key("lbl_age_in_months", "Age in Months"),
|
||
breaks = month_breaks,
|
||
labels = function(x) as.integer(x) # Show all month labels
|
||
)
|
||
)
|
||
} else if (x_var == "week") {
|
||
# Dynamic breaks based on actual data range
|
||
max_week_plot <- max(as.numeric(plot_data$week), na.rm = TRUE)
|
||
# Ensure the max value is included in breaks
|
||
max_week_plot <- max(as.numeric(plot_data$week), na.rm = TRUE)
|
||
week_breaks <- scales::pretty_breaks(n = 5)(c(0, max_week_plot))
|
||
# Month breaks: in secondary axis scale (month numbers 0, 1, 2, ...)
|
||
n_months <- ceiling(max_week_plot / 4.348)
|
||
month_breaks <- seq(0, n_months, by = 1)
|
||
ggplot2::scale_x_continuous(
|
||
breaks = week_breaks,
|
||
sec.axis = ggplot2::sec_axis(
|
||
~ . / 4.348,
|
||
name = tr_key("lbl_age_in_months", "Age in Months"),
|
||
breaks = month_breaks,
|
||
labels = function(x) as.integer(x) # Show all month labels
|
||
)
|
||
)
|
||
}
|
||
} +
|
||
ggplot2::theme_minimal() +
|
||
ggplot2::theme(axis.text.x = ggplot2::element_text(hjust = 0.5),
|
||
axis.text.x.top = ggplot2::element_text(hjust = 0.5),
|
||
axis.title.x.top = ggplot2::element_text(size = 8),
|
||
legend.justification = c(1, 0),
|
||
legend.position = "inside",
|
||
legend.position.inside = c(1, 0),
|
||
legend.title = ggplot2::element_text(size = 8),
|
||
legend.text = ggplot2::element_text(size = 8)) +
|
||
ggplot2::guides(color = ggplot2::guide_legend(nrow = 2, byrow = TRUE))
|
||
}
|
||
|
||
# Y-axis limits + optional rain overlay (single-panel plots)
|
||
y_max <- if (ci_type_filter == "mean_rolling_10_days") {
|
||
7
|
||
} else {
|
||
max(plot_data$ci_value, na.rm = TRUE) * 1.05
|
||
}
|
||
|
||
if (!is.null(rain_data)) {
|
||
latest_ci_dates <- plot_data %>%
|
||
dplyr::filter(is_latest) %>%
|
||
dplyr::distinct(Date, DAH, week)
|
||
rain_joined <- rain_join_to_ci(rain_data, latest_ci_dates)
|
||
g <- rain_add_to_plot(g, rain_joined, ci_type_filter, x_var, y_max)
|
||
} else {
|
||
if (ci_type_filter == "mean_rolling_10_days") {
|
||
g <- g + ggplot2::ylim(0, y_max)
|
||
}
|
||
}
|
||
|
||
return(g)
|
||
}
|
||
|
||
# Generate plots based on plot_type
|
||
if (plot_type == "absolute") {
|
||
g <- create_plot("mean_rolling_10_days", rolling_mean_label, "")
|
||
subchunkify(g, 2.8, 10)
|
||
} else if (plot_type == "cumulative") {
|
||
g <- create_plot("cumulative_CI", cumulative_label, "")
|
||
subchunkify(g, 2.8, 10)
|
||
} else if (plot_type == "both") {
|
||
# Build each panel independently so each gets its own secondary rain y-axis.
|
||
# (facet_wrap + free_y does not support per-facet sec.axis in ggplot2.)
|
||
both_plot_title <- tr_key("lbl_ci_analysis_title", "CI Analysis for Field {pivotName}")
|
||
|
||
g_abs <- create_plot("mean_rolling_10_days", rolling_mean_label, "") +
|
||
ggplot2::labs(title = rolling_mean_label) +
|
||
ggplot2::theme(legend.position = "none")
|
||
|
||
g_cum <- create_plot("cumulative_CI", cumulative_label, "") +
|
||
ggplot2::labs(title = cumulative_label)
|
||
|
||
combined <- gridExtra::arrangeGrob(g_abs, g_cum, ncol = 2, top = both_plot_title)
|
||
|
||
subchunkify(combined, 2.8, 10)
|
||
}
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error creating CI trend plot for pivot", pivotName, ":", e$message), "ERROR")
|
||
cum_ci_plot2(pivotName) # Use fallback function in case of error
|
||
})
|
||
}
|
||
|
||
#' Fallback function for creating CI visualization when data is missing
|
||
#'
|
||
#' @param pivotName The name or ID of the pivot field to visualize
|
||
#' @return NULL (adds output directly to R Markdown document)
|
||
#'
|
||
cum_ci_plot2 <- function(pivotName){
|
||
# Input validation
|
||
if (missing(pivotName) || is.null(pivotName) || pivotName == "") {
|
||
stop("pivotName is required")
|
||
}
|
||
|
||
# Create a simple plot showing "No data available"
|
||
tryCatch({
|
||
end_date <- Sys.Date()
|
||
start_date <- end_date %m-% months(11) # 11 months ago from end_date
|
||
date_seq <- seq.Date(from = start_date, to = end_date, by = "month")
|
||
midpoint_date <- start_date + (end_date - start_date) / 2
|
||
|
||
# Pre-evaluate translated title here (not inside labs()) so {pivotName} resolves correctly
|
||
fallback_title <- tr_key("lbl_rolling_mean_fallback", "14 day rolling MEAN CI rate - Field {pivotName}")
|
||
|
||
g <- ggplot() +
|
||
scale_x_date(limits = c(start_date, end_date), date_breaks = "1 month", date_labels = "%m-%Y") +
|
||
scale_y_continuous(limits = c(0, 4)) +
|
||
labs(title = fallback_title,
|
||
x = tr_key("lbl_date", "Date"), y = tr_key("lbl_ci_rate", "CI Rate")) +
|
||
theme_minimal() +
|
||
theme(axis.text.x = element_text(hjust = 0.5),
|
||
legend.justification = c(1, 0),
|
||
legend.position = "inside",
|
||
legend.position.inside = c(1, 0),
|
||
legend.title = element_text(size = 8),
|
||
legend.text = element_text(size = 8)) +
|
||
annotate("text", x = midpoint_date, y = 2, label = tr_key("lbl_no_data", "No data available"), size = 6, hjust = 0.5)
|
||
|
||
subchunkify(g, 3.2, 10)
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error creating fallback CI plot for pivot", pivotName, ":", e$message), "ERROR")
|
||
cat(paste("No data available for field", pivotName, "\n"))
|
||
})
|
||
}
|
||
|
||
#' Gets the file path for a specific week's mosaic
|
||
#'
|
||
#' @param mosaic_path Base directory containing mosaic files
|
||
#' @param input_date Reference date to calculate from
|
||
#' @param week_offset Number of weeks to offset from input date (positive or negative)
|
||
#' @return File path to the requested week's mosaic TIF file
|
||
#'
|
||
get_week_path <- function(mosaic_path, input_date, week_offset) {
|
||
# Input validation
|
||
if (missing(mosaic_path) || is.null(mosaic_path) || mosaic_path == "") {
|
||
stop("mosaic_path is required")
|
||
}
|
||
if (missing(input_date)) {
|
||
stop("input_date is required")
|
||
}
|
||
|
||
tryCatch({
|
||
# Convert input_date to Date object (in case it's a string)
|
||
input_date <- as.Date(input_date)
|
||
if (is.na(input_date)) {
|
||
stop("Invalid input_date. Expected a Date object or a string convertible to Date.")
|
||
}
|
||
|
||
# Validate week_offset
|
||
week_offset <- as.integer(week_offset)
|
||
if (is.na(week_offset)) {
|
||
stop("Invalid week_offset. Expected an integer value.")
|
||
}
|
||
|
||
# Get the start of the week for the input date (adjust to Monday as the start of the week)
|
||
start_of_week <- lubridate::floor_date(input_date, unit = "week", week_start = 1)
|
||
|
||
# Calculate the new date after applying the week offset
|
||
target_date <- start_of_week + lubridate::weeks(week_offset)
|
||
|
||
# Get the week number and year of the target date
|
||
target_week <- sprintf("%02d", lubridate::isoweek(target_date)) # Left-pad week number with a zero if needed
|
||
target_year <- lubridate::isoyear(target_date)
|
||
|
||
# Load single-file mosaic for the given week
|
||
path_to_week <- here::here(mosaic_path, paste0("week_", target_week, "_", target_year, ".tif"))
|
||
|
||
# Log the path calculation
|
||
safe_log(paste("Calculated path for week", target_week, "of year", target_year, ":", path_to_week), "INFO")
|
||
|
||
# Return the path
|
||
return(path_to_week)
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error calculating week path:", e$message), "ERROR")
|
||
stop(e$message)
|
||
})
|
||
}
|
||
|
||
#' Computes historical percentile benchmarks for CI data per estate
|
||
#'
|
||
#' @param ci_quadrant_data Data frame containing CI quadrant data with field, Date, DAH, cumulative_CI, value, season columns
|
||
#' @param estate_name Name of the estate/client to filter data for
|
||
#' @param percentiles Vector of percentiles to compute (e.g., c(10, 50, 90))
|
||
#' @param min_seasons Minimum number of seasons required for reliable benchmarks (default: 3)
|
||
#' @return Data frame with DAH, percentile, ci_type, benchmark_value, or NULL if insufficient data
|
||
#'
|
||
compute_ci_benchmarks <- function(ci_quadrant_data, estate_name, percentiles = c(10, 50, 90), min_seasons = 3) {
|
||
# Input validation
|
||
if (missing(ci_quadrant_data) || is.null(ci_quadrant_data)) {
|
||
stop("ci_quadrant_data is required")
|
||
}
|
||
if (missing(estate_name) || is.null(estate_name) || estate_name == "") {
|
||
stop("estate_name is required")
|
||
}
|
||
if (!all(percentiles >= 0 & percentiles <= 100)) {
|
||
stop("percentiles must be between 0 and 100")
|
||
}
|
||
|
||
tryCatch({
|
||
# Filter data for the specified estate (assuming estate is not directly in data, but we can infer from context)
|
||
# Since the data is per field, and fields are unique to estates, we'll use all data but could add estate filtering if available
|
||
data_filtered <- ci_quadrant_data
|
||
|
||
# Check if we have enough seasons
|
||
unique_seasons <- unique(data_filtered$season)
|
||
if (length(unique_seasons) < min_seasons) {
|
||
safe_log(paste("Insufficient historical seasons for estate", estate_name, ":", length(unique_seasons), "seasons found, need at least", min_seasons), "WARNING")
|
||
return(NULL)
|
||
}
|
||
|
||
# Prepare data for both CI types
|
||
data_prepared <- data_filtered %>%
|
||
dplyr::ungroup() %>% # Ensure no existing groupings
|
||
dplyr::select(DAH, value, cumulative_CI, season) %>%
|
||
tidyr::pivot_longer(
|
||
cols = c("value", "cumulative_CI"),
|
||
names_to = "ci_type",
|
||
values_to = "ci_value"
|
||
) %>%
|
||
dplyr::filter(!is.na(ci_value)) # Remove NA values
|
||
|
||
# Compute percentiles for each DAH and ci_type
|
||
benchmarks <- data_prepared %>%
|
||
dplyr::group_by(DAH, ci_type) %>%
|
||
dplyr::summarise(
|
||
p10 = tryCatch(quantile(ci_value, 0.1, na.rm = TRUE), error = function(e) NA_real_),
|
||
p50 = tryCatch(quantile(ci_value, 0.5, na.rm = TRUE), error = function(e) NA_real_),
|
||
p90 = tryCatch(quantile(ci_value, 0.9, na.rm = TRUE), error = function(e) NA_real_),
|
||
n_observations = n(),
|
||
.groups = 'drop'
|
||
) %>%
|
||
dplyr::filter(n_observations >= min_seasons) %>% # Only include DAHs with sufficient data
|
||
tidyr::pivot_longer(
|
||
cols = c(p10, p50, p90),
|
||
names_to = "percentile",
|
||
values_to = "benchmark_value"
|
||
) %>%
|
||
dplyr::mutate(
|
||
percentile = case_when(
|
||
percentile == "p10" ~ 10,
|
||
percentile == "p50" ~ 50,
|
||
percentile == "p90" ~ 90
|
||
)
|
||
) %>%
|
||
dplyr::filter(!is.na(benchmark_value)) # Remove any NA benchmarks
|
||
|
||
# Rename columns for clarity
|
||
benchmarks <- benchmarks %>%
|
||
dplyr::select(DAH, ci_type, percentile, benchmark_value)
|
||
|
||
safe_log(paste("Computed CI benchmarks for estate", estate_name, "with", length(unique_seasons), "seasons and", nrow(benchmarks), "benchmark points"), "INFO")
|
||
|
||
return(benchmarks)
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error computing CI benchmarks for estate", estate_name, ":", e$message), "ERROR")
|
||
print(paste("DEBUG: Error details:", e$message, "Call:", deparse(e$call)))
|
||
return(NULL)
|
||
})
|
||
}
|
||
|
||
#' Aggregate per-field weekly mosaics into a farm-level mosaic
|
||
#'
|
||
#' Reads all per-field mosaic TIFs for a given week and merges them into a single farm-level mosaic.
|
||
#' This is used for overview maps in the report (Script 90).
|
||
#'
|
||
#' Per-field mosaics already have proper geospatial metadata (CRS, geotransform) from Script 10,
|
||
#' so terra can align them automatically without needing field boundaries or extent information.
|
||
#'
|
||
#' @param weekly_mosaic_dir Path to weekly_mosaic directory (e.g., "laravel_app/storage/app/{project}/weekly_mosaic")
|
||
#' @param target_week ISO week number (e.g., 52)
|
||
#' @param target_year ISO year (e.g., 2025)
|
||
#' @return SpatRaster object (5-band: R,G,B,NIR,CI) or NULL if no fields found
|
||
#'
|
||
#' @details
|
||
#' Per-field mosaics are located at: weekly_mosaic/{FIELD}/week_WW_YYYY.tif
|
||
#' This function:
|
||
#' 1. Finds all per-field subdirectories
|
||
#' 2. Loads each field's weekly mosaic
|
||
#' 3. Merges to a single raster using terra::mosaic() (alignment handled automatically by metadata)
|
||
#' 4. Returns combined 5-band raster for visualization
|
||
#'
|
||
aggregate_per_field_mosaics_to_farm_level <- function(
|
||
weekly_mosaic_dir,
|
||
target_week,
|
||
target_year
|
||
) {
|
||
|
||
tryCatch({
|
||
|
||
# Validate directory exists
|
||
if (!dir.exists(weekly_mosaic_dir)) {
|
||
safe_log(paste("Weekly mosaic directory not found:", weekly_mosaic_dir), "WARNING")
|
||
return(NULL)
|
||
}
|
||
|
||
# Find all per-field subdirectories (non-TIF files at top level)
|
||
all_items <- list.files(weekly_mosaic_dir, full.names = FALSE)
|
||
field_dirs <- all_items[
|
||
!grepl("\\.tif$", all_items, ignore.case = TRUE) &
|
||
dir.exists(file.path(weekly_mosaic_dir, all_items))
|
||
]
|
||
|
||
if (length(field_dirs) == 0) {
|
||
safe_log(paste("No per-field directories found in", weekly_mosaic_dir), "WARNING")
|
||
return(NULL)
|
||
}
|
||
|
||
safe_log(paste("Found", length(field_dirs), "field directories. Aggregating week",
|
||
sprintf("%02d", target_week), target_year), "INFO")
|
||
|
||
# Collect rasters from each field
|
||
raster_list <- list()
|
||
|
||
for (field_dir in field_dirs) {
|
||
field_mosaic_path <- file.path(
|
||
weekly_mosaic_dir,
|
||
field_dir,
|
||
paste0("week_", sprintf("%02d", target_week), "_", target_year, ".tif")
|
||
)
|
||
|
||
if (file.exists(field_mosaic_path)) {
|
||
tryCatch({
|
||
r <- terra::rast(field_mosaic_path)
|
||
raster_list[[field_dir]] <- r
|
||
safe_log(paste("Loaded mosaic for field:", field_dir), "DEBUG")
|
||
}, error = function(e) {
|
||
safe_log(paste("Could not load mosaic for field", field_dir, ":", e$message), "WARNING")
|
||
})
|
||
}
|
||
}
|
||
|
||
if (length(raster_list) == 0) {
|
||
safe_log(paste("No field mosaics found for week", sprintf("%02d", target_week), target_year), "WARNING")
|
||
return(NULL)
|
||
}
|
||
|
||
safe_log(paste("Successfully loaded mosaics for", length(raster_list), "fields"), "INFO")
|
||
|
||
# Create a SpatRasterCollection and merge using correct terra syntax
|
||
tryCatch({
|
||
rsrc <- terra::sprc(raster_list)
|
||
safe_log(paste("Created SpatRasterCollection with", length(raster_list), "rasters"), "DEBUG")
|
||
|
||
# Merge the rasters into a single continuous raster (no overlap expected between fields)
|
||
farm_mosaic <- terra::merge(rsrc)
|
||
|
||
safe_log(paste("Aggregated", length(raster_list), "per-field mosaics into farm-level mosaic"), "INFO")
|
||
|
||
# Verify mosaic was created successfully
|
||
if (is.null(farm_mosaic)) {
|
||
stop("merge() returned NULL")
|
||
}
|
||
|
||
return(farm_mosaic)
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error during mosaic creation:", e$message), "ERROR")
|
||
return(NULL)
|
||
})
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error aggregating per-field mosaics:", e$message), "ERROR")
|
||
return(NULL)
|
||
})
|
||
}
|
||
|
||
|
||
#' Get per-field mosaic path (new per-field architecture)
|
||
#'
|
||
#' Returns the path to a per-field weekly mosaic for direct visualization.
|
||
#' Replaces the old cropping workflow: now we load the field's own mosaic instead of cropping farm-level.
|
||
#'
|
||
#' @param weekly_mosaic_dir Path to weekly_mosaic directory
|
||
#' @param field_name Name of the field
|
||
#' @param target_week ISO week number
|
||
#' @param target_year ISO year
|
||
#' @return Path to field-specific mosaic TIF, or NULL if not found
|
||
#'
|
||
get_per_field_mosaic_path <- function(
|
||
weekly_mosaic_dir,
|
||
field_name,
|
||
target_week,
|
||
target_year
|
||
) {
|
||
|
||
path <- file.path(
|
||
weekly_mosaic_dir,
|
||
field_name,
|
||
paste0("week_", sprintf("%02d", target_week), "_", target_year, ".tif")
|
||
)
|
||
|
||
if (file.exists(path)) {
|
||
return(path)
|
||
} else {
|
||
safe_log(paste("Per-field mosaic not found for field", field_name,
|
||
"week", sprintf("%02d", target_week), target_year), "WARNING")
|
||
return(NULL)
|
||
}
|
||
}
|
||
|
||
#' Determine field priority level based on CV and Moran's I
|
||
#'
|
||
#' @param cv Coefficient of Variation (uniformity metric)
|
||
#' @param morans_i Moran's I spatial autocorrelation index
|
||
#' @return Priority level: 1=Urgent, 2=Monitor, 3=No stress
|
||
#'
|
||
get_field_priority_level <- function(cv, morans_i) {
|
||
# Handle NA values
|
||
if (is.na(cv) || is.na(morans_i)) return(3) # Default to no stress
|
||
|
||
# Determine priority based on thresholds
|
||
if (cv < 0.1) {
|
||
if (morans_i < 0.7) {
|
||
return(3) # No stress
|
||
} else if (morans_i <= 0.9) {
|
||
return(2) # Monitor (young field with some clustering)
|
||
} else {
|
||
return(1) # Urgent
|
||
}
|
||
} else if (cv <= 0.15) {
|
||
if (morans_i < 0.7) {
|
||
return(2) # Monitor
|
||
} else {
|
||
return(1) # Urgent
|
||
}
|
||
} else { # cv > 0.15
|
||
return(1) # Urgent
|
||
}
|
||
}
|
||
|
||
#' Generate field-specific KPI summary for display in reports
|
||
#'
|
||
#' @param field_name Name of the field to summarize
|
||
#' @param field_details_table Data frame with field-level KPI details
|
||
#' @param CI_quadrant Data frame containing CI quadrant data with Date, DAH, season columns
|
||
#' @param report_date Report date (used for filtering current season data)
|
||
#' @return Formatted text string with field KPI summary
|
||
#'
|
||
generate_field_kpi_summary <- function(field_name, field_details_table, CI_quadrant, report_date = Sys.Date()) {
|
||
tryCatch({
|
||
# Get field age from CI quadrant data for the CURRENT SEASON only
|
||
# First identify the current season for this field
|
||
# Get field age from CI quadrant data for the CURRENT SEASON only
|
||
# First identify the current season for this field
|
||
current_season_data <- CI_quadrant %>%
|
||
filter(field == field_name, Date <= as.Date(report_date)) %>%
|
||
group_by(season) %>%
|
||
summarise(season_end = max(Date), .groups = 'drop') %>%
|
||
filter(season == max(season))
|
||
|
||
if (nrow(current_season_data) == 0) {
|
||
return(paste("**Field", field_name, "KPIs:** No CI data available for current season"))
|
||
}
|
||
current_season <- current_season_data %>% pull(season)
|
||
|
||
# Get the most recent DAH from the current season
|
||
field_age_data <- CI_quadrant %>%
|
||
filter(field == field_name, season == current_season) %>%
|
||
pull(DAH)
|
||
|
||
field_age <- if (length(field_age_data) > 0) max(field_age_data, na.rm = TRUE) else NA_real_
|
||
# Filter data for this specific field
|
||
field_data <- field_details_table %>%
|
||
filter(Field == field_name)
|
||
|
||
if (nrow(field_data) == 0) {
|
||
return(paste("**Field", field_name, "KPIs:** Data not available"))
|
||
}
|
||
|
||
# Aggregate sub-field data for field-level summary
|
||
# For categorical data, take the most common value or highest risk level
|
||
field_summary <- field_data %>%
|
||
summarise(
|
||
field_size = sum(`Field Size (acres)`, na.rm = TRUE),
|
||
uniformity_levels = paste(unique(`Growth Uniformity`), collapse = "/"),
|
||
avg_yield_forecast = ifelse(is.na(`Yield Forecast (t/ha)`[1]), NA, mean(`Yield Forecast (t/ha)`, na.rm = TRUE)),
|
||
max_gap_score = max(`Gap Score`, na.rm = TRUE),
|
||
highest_decline_risk = case_when(
|
||
any(`Decline Risk` == "Very-high") ~ "Very-high",
|
||
any(`Decline Risk` == "High") ~ "High",
|
||
any(`Decline Risk` == "Moderate") ~ "Moderate",
|
||
any(`Decline Risk` == "Low") ~ "Low",
|
||
TRUE ~ "Unknown"
|
||
),
|
||
highest_weed_risk = case_when(
|
||
any(`Weed Risk` == "High") ~ "High",
|
||
any(`Weed Risk` == "Moderate") ~ "Moderate",
|
||
any(`Weed Risk` == "Low") ~ "Low",
|
||
TRUE ~ "Unknown"
|
||
),
|
||
avg_mean_ci = mean(`Mean CI`, na.rm = TRUE),
|
||
avg_cv = mean(`CV Value`, na.rm = TRUE),
|
||
.groups = 'drop'
|
||
)
|
||
|
||
# Apply age-based filtering to yield forecast
|
||
if (is.na(field_age) || field_age < 240) {
|
||
field_summary$avg_yield_forecast <- NA_real_
|
||
}
|
||
|
||
# Format the summary text
|
||
yield_text <- if (is.na(field_summary$avg_yield_forecast)) {
|
||
"Yield Forecast: NA"
|
||
} else {
|
||
paste0("Yield Forecast: ", round(field_summary$avg_yield_forecast, 1), " t/ha")
|
||
}
|
||
|
||
kpi_text <- paste0(
|
||
"Size: ", round(field_summary$field_size * 0.404686, 1), " ha | Mean CI: ", round(field_summary$avg_mean_ci, 2),
|
||
" | Growth Uniformity: ", field_summary$uniformity_levels,
|
||
" | ", yield_text, " | Gap Score: ", round(field_summary$max_gap_score, 1),
|
||
" | Decline Risk: ", field_summary$highest_decline_risk, " | Weed Risk: ", field_summary$highest_weed_risk
|
||
)
|
||
|
||
# Wrap in smaller text HTML tags for Word output
|
||
kpi_text <- paste0("<span style='font-size:10pt'>", kpi_text, "</span>")
|
||
|
||
return(kpi_text)
|
||
|
||
}, error = function(e) {
|
||
safe_log(paste("Error generating KPI summary for field", field_name, ":", e$message), "ERROR")
|
||
return(paste("**Field", field_name, "KPIs:** Error generating summary"))
|
||
})
|
||
}
|
||
|
||
#' Normalize field_details_table column structure
|
||
#'
|
||
#' Standardizes column names from various legacy and pipeline-generated schemas
|
||
#' into a single canonical set, then ensures all expected KPI columns exist
|
||
#' (adding \code{NA} columns for any that are absent).
|
||
#'
|
||
#' Rename rules applied in order:
|
||
#' \itemize{
|
||
#' \item \code{Field} → \code{Field_id}
|
||
#' \item \code{Mean CI} → \code{Mean_CI}
|
||
#' \item \code{CV Value} → \code{CV}
|
||
#' \item \code{TCH_Forecasted} / \code{Yield Forecast (t/ha)} → \code{TCH_Forecasted}
|
||
#' \item \code{Gap Score} → \code{Gap_Score}
|
||
#' \item \code{Growth Uniformity} / \code{Uniformity_Category} → \code{Uniformity_Interpretation}
|
||
#' \item \code{Decline_Risk} → \code{Decline_Severity}
|
||
#' \item \code{Moran's I} / \code{Morans_I} → \code{Morans_I}
|
||
#' }
|
||
#'
|
||
#' @param field_details_table A data.frame to normalize.
|
||
#' @return A data.frame with standardized column names and all expected KPI
|
||
#' columns present (missing ones filled with \code{NA}).
|
||
normalize_field_details_columns <- function(field_details_table) {
|
||
if (is.null(field_details_table) || nrow(field_details_table) == 0) {
|
||
return(field_details_table)
|
||
}
|
||
|
||
rename_if_missing <- function(df, from, to) {
|
||
if (from %in% names(df) && !to %in% names(df))
|
||
df <- dplyr::rename(df, !!to := !!rlang::sym(from))
|
||
df
|
||
}
|
||
|
||
field_details_table <- field_details_table %>%
|
||
rename_if_missing("Field", "Field_id") %>%
|
||
rename_if_missing("Mean CI", "Mean_CI") %>%
|
||
rename_if_missing("CV Value", "CV") %>%
|
||
rename_if_missing("Yield Forecast (t/ha)", "TCH_Forecasted") %>%
|
||
rename_if_missing("Gap Score", "Gap_Score") %>%
|
||
rename_if_missing("Growth Uniformity", "Uniformity_Interpretation") %>%
|
||
rename_if_missing("Uniformity_Category", "Uniformity_Interpretation") %>%
|
||
rename_if_missing("Decline_Risk", "Decline_Severity") %>%
|
||
rename_if_missing("Moran's I", "Morans_I")
|
||
|
||
# Ensure all expected KPI columns exist; add as NA if missing
|
||
expected_cols <- c(
|
||
"Field_id", "Mean_CI", "CV", "Morans_I", "TCH_Forecasted", "Gap_Score",
|
||
"Trend_Interpretation", "Weekly_CI_Change", "Uniformity_Interpretation",
|
||
"Decline_Severity", "Patchiness_Risk"
|
||
)
|
||
for (col in expected_cols) {
|
||
if (!col %in% names(field_details_table)) {
|
||
field_details_table[[col]] <- NA
|
||
}
|
||
}
|
||
|
||
return(field_details_table)
|
||
}
|
||
|
||
# ==============================================================================
|
||
# TREND / ARROW HELPERS
|
||
# ==============================================================================
|
||
|
||
#' Map trend text to arrow symbols or formatted labels
|
||
#'
|
||
#' Converts trend category strings (e.g. \code{"strong growth"},
|
||
#' \code{"slight decline"}) to Unicode arrow symbols, optionally combined with
|
||
#' translated text labels. Normalises legacy and current trend category names
|
||
#' to a canonical output. Vectorised over \code{text_vec}.
|
||
#'
|
||
#' @param text_vec Character vector of trend category strings.
|
||
#' @param include_text Logical. If \code{TRUE}, returns
|
||
#' \code{"Label (arrow)"}; if \code{FALSE} (default), returns the arrow
|
||
#' symbol only.
|
||
#' @return Character vector the same length as \code{text_vec}. \code{NA} is
|
||
#' returned for missing / empty inputs; an em-dash (\code{"—"}) is returned
|
||
#' for unrecognised values when \code{include_text = FALSE}.
|
||
#' @seealso \code{\link{tr_key}}
|
||
#'
|
||
map_trend_to_arrow <- function(text_vec, include_text = FALSE) {
|
||
text_lower <- tolower(as.character(text_vec))
|
||
|
||
sapply(text_lower, function(text) {
|
||
if (is.na(text) || nchar(trimws(text)) == 0) return(NA_character_)
|
||
|
||
if (grepl("\\bstrong growth\\b", text, perl = TRUE)) {
|
||
arrow <- "↑↑"; trans_key <- "Strong growth"
|
||
} else if (grepl("\\b(?:slight|weak) growth\\b|(?<!no\\s)\\bgrowth\\b|\\bincreasing\\b", text, perl = TRUE)) {
|
||
arrow <- "↑"; trans_key <- "Slight growth"
|
||
} else if (grepl("\\bstable\\b|\\bno growth\\b", text, perl = TRUE)) {
|
||
arrow <- "→"; trans_key <- "Stable"
|
||
} else if (grepl("\\b(?:weak|slight|moderate) decline\\b", text, perl = TRUE)) {
|
||
arrow <- "↓"; trans_key <- "Slight decline"
|
||
} else if (grepl("\\bstrong decline\\b|\\bsevere\\b", text, perl = TRUE)) {
|
||
arrow <- "↓↓"; trans_key <- "Strong decline"
|
||
} else {
|
||
return(if (include_text) as.character(text) else "—")
|
||
}
|
||
|
||
label <- tr_key(trans_key)
|
||
if (include_text) paste0(label, " (", arrow, ")") else arrow
|
||
}, USE.NAMES = FALSE)
|
||
}
|
||
|
||
# ==============================================================================
|
||
# DATE / WEEK HELPERS
|
||
# ==============================================================================
|
||
|
||
#' Extract ISO week and year from a date
|
||
#'
|
||
#' Returns the ISO 8601 week number and the corresponding ISO year for a given
|
||
#' date. Note that the ISO year may differ from the calendar year near
|
||
#' year-end boundaries (e.g. 2024-12-30 is ISO week 1 of 2025).
|
||
#'
|
||
#' @param date A \code{Date} object or a string coercible to \code{Date}.
|
||
#' @return A named list with elements:
|
||
#' \describe{
|
||
#' \item{\code{week}}{Integer ISO week number (1–53).}
|
||
#' \item{\code{year}}{Integer ISO year.}
|
||
#' }
|
||
#'
|
||
get_week_year <- function(date) {
|
||
date <- as.Date(date)
|
||
list(
|
||
week = as.integer(format(date, "%V")),
|
||
year = as.integer(format(date, "%G"))
|
||
)
|
||
}
|
||
|
||
# ==============================================================================
|
||
# RASTER HELPERS
|
||
# ==============================================================================
|
||
|
||
#' Downsample a SpatRaster to a maximum cell count
|
||
#'
|
||
#' Reduces the resolution of a raster by integer aggregation when the number
|
||
#' of cells exceeds \code{max_cells}. The aggregation factor is the smallest
|
||
#' integer that brings the cell count at or below the limit.
|
||
#'
|
||
#' @param r A \code{SpatRaster} object, or \code{NULL}.
|
||
#' @param max_cells Maximum number of cells to retain (default 2,000,000).
|
||
#' @param fun Aggregation function passed to \code{terra::aggregate()}
|
||
#' (default \code{"mean"}).
|
||
#' @return The (possibly downsampled) \code{SpatRaster}, or \code{NULL} if
|
||
#' \code{r} is \code{NULL}.
|
||
#'
|
||
downsample_raster <- function(r, max_cells = 2000000, fun = "mean") {
|
||
if (is.null(r)) return(NULL)
|
||
n_cells <- terra::ncell(r)
|
||
if (!is.na(n_cells) && n_cells > max_cells) {
|
||
fact <- ceiling(sqrt(n_cells / max_cells))
|
||
safe_log(paste("Downsampling raster by factor", fact), "INFO")
|
||
return(terra::aggregate(r, fact = fact, fun = fun, na.rm = TRUE))
|
||
}
|
||
r
|
||
}
|
||
|
||
#' Load the CI band from a per-field weekly mosaic
|
||
#'
|
||
#' Locates the weekly mosaic TIF for the given field and week via
|
||
#' \code{\link{get_per_field_mosaic_path}}, loads it with
|
||
#' \code{terra::rast()}, and returns the CI band (the layer named \code{"CI"},
|
||
#' or the first layer as a fallback).
|
||
#'
|
||
#' @param base_dir Path to the \code{weekly_mosaic} directory.
|
||
#' @param field_name Name of the field sub-directory.
|
||
#' @param week ISO week number.
|
||
#' @param year ISO year.
|
||
#' @return A single-layer \code{SpatRaster} (CI band), or \code{NULL} if the
|
||
#' file does not exist or cannot be loaded.
|
||
#' @seealso \code{\link{get_per_field_mosaic_path}}
|
||
#'
|
||
load_per_field_mosaic <- function(base_dir, field_name, week, year) {
|
||
path <- get_per_field_mosaic_path(base_dir, field_name, week, year)
|
||
if (is.null(path)) return(NULL)
|
||
|
||
tryCatch({
|
||
rast_obj <- terra::rast(path)
|
||
if ("CI" %in% names(rast_obj)) {
|
||
return(rast_obj[["CI"]])
|
||
} else if (terra::nlyr(rast_obj) > 0) {
|
||
return(rast_obj[[1]])
|
||
}
|
||
NULL
|
||
}, error = function(e) {
|
||
safe_log(paste("Could not load mosaic:", path, "-", e$message), "WARNING")
|
||
NULL
|
||
})
|
||
}
|
||
|
||
# ==============================================================================
|
||
# FIELD ALERT GENERATION
|
||
# ==============================================================================
|
||
|
||
#' Generate field-level alert flags from normalised KPI data
|
||
#'
|
||
#' Evaluates each field's CV, Moran's I, decline severity, patchiness risk,
|
||
#' and gap score against threshold rules, returning a tidy data frame of
|
||
#' translated alert messages. Only fields that trigger at least one alert are
|
||
#' included in the output.
|
||
#'
|
||
#' Expects a table that has been passed through
|
||
#' \code{\link{normalize_field_details_columns}}, which guarantees the columns
|
||
#' \code{Field_id}, \code{CV}, \code{Morans_I}, \code{Decline_Severity},
|
||
#' \code{Patchiness_Risk}, and \code{Gap_Score} are present.
|
||
#'
|
||
#' Alert rules:
|
||
#' \itemize{
|
||
#' \item Priority 1 (Urgent) or 2 (Monitor) from
|
||
#' \code{\link{get_field_priority_level}} based on CV / Moran's I.
|
||
#' \item Decline risk High or Very-high.
|
||
#' \item Patchiness risk High.
|
||
#' \item Gap score \eqn{> 20}.
|
||
#' }
|
||
#'
|
||
#' @param field_details_table A data frame normalised by
|
||
#' \code{\link{normalize_field_details_columns}}.
|
||
#' @return A data frame with columns \code{Field} and \code{Alert}, one row
|
||
#' per alert per field. Returns an empty 0-row data frame when no alerts
|
||
#' are triggered, or \code{NULL} if the input is empty / missing required
|
||
#' columns.
|
||
#' @seealso \code{\link{get_field_priority_level}}, \code{\link{normalize_field_details_columns}}
|
||
#'
|
||
generate_field_alerts <- function(field_details_table) {
|
||
if (is.null(field_details_table) || nrow(field_details_table) == 0) {
|
||
return(NULL)
|
||
}
|
||
|
||
required_cols <- c("Field_id", "CV", "Morans_I", "Decline_Severity",
|
||
"Patchiness_Risk", "Gap_Score")
|
||
missing_cols <- setdiff(required_cols, names(field_details_table))
|
||
if (length(missing_cols) > 0) {
|
||
safe_log(paste("generate_field_alerts: missing columns:",
|
||
paste(missing_cols, collapse = ", ")), "WARNING")
|
||
return(NULL)
|
||
}
|
||
|
||
summaries <- field_details_table %>%
|
||
dplyr::group_by(Field_id) %>%
|
||
dplyr::summarise(
|
||
avg_cv = mean(CV, na.rm = TRUE),
|
||
avg_morans_i = mean(Morans_I, na.rm = TRUE),
|
||
max_gap = suppressWarnings(max(Gap_Score, na.rm = TRUE)),
|
||
highest_decline = dplyr::case_when(
|
||
any(Decline_Severity == "Very-high", na.rm = TRUE) ~ "Very-high",
|
||
any(Decline_Severity == "High", na.rm = TRUE) ~ "High",
|
||
any(Decline_Severity == "Moderate", na.rm = TRUE) ~ "Moderate",
|
||
any(Decline_Severity == "Low", na.rm = TRUE) ~ "Low",
|
||
TRUE ~ "Unknown"
|
||
),
|
||
highest_patchiness = dplyr::case_when(
|
||
any(Patchiness_Risk == "High", na.rm = TRUE) ~ "High",
|
||
any(Patchiness_Risk == "Medium", na.rm = TRUE) ~ "Medium",
|
||
any(Patchiness_Risk == "Low", na.rm = TRUE) ~ "Low",
|
||
any(Patchiness_Risk == "Minimal", na.rm = TRUE) ~ "Minimal",
|
||
TRUE ~ "Unknown"
|
||
),
|
||
.groups = "drop"
|
||
) %>%
|
||
dplyr::mutate(
|
||
priority = purrr::map2_int(avg_cv, avg_morans_i, get_field_priority_level),
|
||
max_gap = dplyr::if_else(is.infinite(max_gap), NA_real_, max_gap)
|
||
)
|
||
|
||
alerts <- summaries %>%
|
||
dplyr::mutate(
|
||
a_priority = dplyr::case_when(
|
||
priority == 1 ~ tr_key("priority"),
|
||
priority == 2 ~ tr_key("monitor"),
|
||
TRUE ~ NA_character_
|
||
),
|
||
a_decline = dplyr::if_else(
|
||
highest_decline %in% c("High", "Very-high"), tr_key("growth_decline"), NA_character_
|
||
),
|
||
a_patch = dplyr::if_else(
|
||
highest_patchiness == "High", tr_key("high_patchiness"), NA_character_
|
||
),
|
||
a_gap = dplyr::if_else(
|
||
!is.na(max_gap) & max_gap > 20, tr_key("gaps_present"), NA_character_
|
||
)
|
||
) %>%
|
||
tidyr::pivot_longer(
|
||
cols = c(a_priority, a_decline, a_patch, a_gap),
|
||
names_to = NULL,
|
||
values_to = "Alert"
|
||
) %>%
|
||
dplyr::filter(!is.na(Alert)) %>%
|
||
dplyr::select(Field = Field_id, Alert)
|
||
|
||
if (nrow(alerts) == 0) {
|
||
return(data.frame(Field = character(), Alert = character()))
|
||
}
|
||
|
||
alerts
|
||
}
|