Timon/SmartCane
1
1
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Merge pull request #16 from TimonWeitkamp:translations

Browse source 
Translations
This commit is contained in:
Timon Weitkamp 2026-03-10 14:16:44 +01:00 committed by GitHub
parent de9027434f 23bbd7b450
commit 685d35e579
No known key found for this signature in database
GPG key ID: B5690EEEBB952194
6 changed files with 509 additions and 633 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
.claude/settings.local.json Normal file
View file

@ -0,0 +1,12 @@
{
"permissions": {
"allow": [
"Bash(python -c \":*)",
"Bash(where python)",
"Bash(where py)",
"Bash(where python3)",
"Bash(where conda)",
"Bash(/c/Users/timon/AppData/Local/r-miniconda/python.exe -c \":*)"
]
}
}

196
r_app/30_growth_model_utils.R
View file

@ -71,54 +71,43 @@ load_combined_ci_data <- function(daily_vals_dir, harvesting_data = NULL) {
safe_log(sprintf("Filtered to %d files within harvest season date range", length(all_daily_files))) safe_log(sprintf("Filtered to %d files within harvest season date range", length(all_daily_files)))
} }
# Set up parallel future plan (Windows PSOCK multisession; Mac/Linux can use forking) # Adaptive core count: scale with file count to avoid parallel overhead on small projects
# Automatically detect available cores and limit to reasonable number n_files <- length(all_daily_files)
n_cores <- min(parallel::detectCores() - 1, 8) # Use max 8 cores (diminishing returns after) n_cores_io <- if (n_files < 200) {
future::plan(strategy = future::multisession, workers = n_cores) 1
safe_log(sprintf("Using %d parallel workers for file I/O", n_cores)) } else if (n_files < 600) {
2
# Parallel file reading: future_map_dfr processes each file in parallel } else if (n_files < 1500) {
# Returns combined dataframe directly (no need to rbind) min(parallel::detectCores() - 1, 4)
combined_long <- furrr::future_map_dfr( } else {
all_daily_files, min(parallel::detectCores() - 1, 8)
.progress = TRUE, }
.options = furrr::furrr_options(seed = TRUE), safe_log(sprintf("Using %d parallel workers for file I/O (%d files)", n_cores_io, n_files))
function(file) {
# Extract date from filename: {YYYY-MM-DD}.rds read_one_file <- function(file) {
filename <- basename(file) filename <- basename(file)
date_str <- tools::file_path_sans_ext(filename) date_str <- tools::file_path_sans_ext(filename)
if (nchar(date_str) != 10 || !grepl("^\\d{4}-\\d{2}-\\d{2}$", date_str)) return(data.frame())
# Parse date parsed_date <- as.Date(date_str, format = "%Y-%m-%d")
if (nchar(date_str) == 10 && grepl("^\\d{4}-\\d{2}-\\d{2}$", date_str)) { if (is.na(parsed_date)) return(data.frame())
parsed_date <- as.Date(date_str, format = "%Y-%m-%d") tryCatch({
} else { rds_data <- readRDS(file)
return(data.frame()) # Return empty dataframe if parse fails if (is.null(rds_data) || nrow(rds_data) == 0) return(data.frame())
} rds_data %>% dplyr::mutate(Date = parsed_date)
}, error = function(e) data.frame())
if (is.na(parsed_date)) { }
return(data.frame())
} if (n_cores_io > 1) {
future::plan(strategy = future::multisession, workers = n_cores_io)
# Read RDS file combined_long <- furrr::future_map_dfr(
tryCatch({ all_daily_files, read_one_file,
rds_data <- readRDS(file) .progress = TRUE,
.options = furrr::furrr_options(seed = TRUE)
if (is.null(rds_data) || nrow(rds_data) == 0) { )
return(data.frame()) future::plan(future::sequential)
} } else {
combined_long <- purrr::map_dfr(all_daily_files, read_one_file)
# Add date column to the data }
rds_data %>%
dplyr::mutate(Date = parsed_date)
}, error = function(e) {
return(data.frame()) # Return empty dataframe on error
})
}
)
# Return to sequential processing to avoid nested parallelism
future::plan(future::sequential)
if (nrow(combined_long) == 0) { if (nrow(combined_long) == 0) {
safe_log("Warning: No valid CI data loaded from daily files", "WARNING") safe_log("Warning: No valid CI data loaded from daily files", "WARNING")
@ -244,57 +233,81 @@ generate_interpolated_ci_data <- function(years, harvesting_data, ci_data) {
failed_fields <- list() failed_fields <- list()
total_fields <- 0 total_fields <- 0
successful_fields <- 0 successful_fields <- 0
# Pre-compute total valid fields across all years to decide core count once
total_valid_fields <- sum(sapply(years, function(yr) {
sfs <- harvesting_data %>%
dplyr::filter(year == yr, !is.na(season_start)) %>%
dplyr::pull(sub_field)
sum(sfs %in% unique(ci_data$sub_field))
}))
# Adaptive core count: scale with field count, avoid parallel overhead for small projects
n_cores_interp <- if (total_valid_fields <= 1) {
1
} else if (total_valid_fields <= 10) {
2
} else if (total_valid_fields <= 50) {
min(parallel::detectCores() - 1, 4)
} else {
min(parallel::detectCores() - 1, 8)
}
safe_log(sprintf("Interpolating %d fields across %d year(s) using %d worker(s)",
total_valid_fields, length(years), n_cores_interp))
# Set up parallel plan once before the year loop (avoid per-year startup cost)
if (n_cores_interp > 1) {
future::plan(strategy = future::multisession, workers = n_cores_interp)
}
# Process each year # Process each year
result <- purrr::map_df(years, function(yr) { result <- purrr::map_df(years, function(yr) {
# Get the fields harvested in this year with valid season start dates # Get the fields harvested in this year with valid season start dates
sub_fields <- harvesting_data %>% sub_fields <- harvesting_data %>%
dplyr::filter(year == yr, !is.na(season_start)) %>% dplyr::filter(year == yr, !is.na(season_start)) %>%
dplyr::pull(sub_field) dplyr::pull(sub_field)
if (length(sub_fields) == 0) { if (length(sub_fields) == 0) return(data.frame())
return(data.frame())
}
# Filter sub_fields to only include those with value data in ci_data # Filter sub_fields to only include those with value data in ci_data
valid_sub_fields <- sub_fields %>% valid_sub_fields <- sub_fields %>%
purrr::keep(~ any(ci_data$sub_field == .x)) purrr::keep(~ any(ci_data$sub_field == .x))
if (length(valid_sub_fields) == 0) { if (length(valid_sub_fields) == 0) return(data.frame())
return(data.frame())
}
total_fields <<- total_fields + length(valid_sub_fields) total_fields <<- total_fields + length(valid_sub_fields)
safe_log(sprintf("Year %d: Processing %d fields in parallel", yr, length(valid_sub_fields))) safe_log(sprintf("Year %d: Processing %d fields", yr, length(valid_sub_fields)))
# Set up parallel future plan for field interpolation # Process fields — parallel if workers > 1, otherwise plain map (no overhead)
# Allocate 1 core per ~100 fields (with minimum 2 cores) if (n_cores_interp > 1) {
n_cores <- max(2, min(parallel::detectCores() - 1, ceiling(length(valid_sub_fields) / 100))) result_list <- furrr::future_map(
future::plan(strategy = future::multisession, workers = n_cores) valid_sub_fields,
.progress = TRUE,
# PARALLELIZE: Process all fields in parallel (each extracts & interpolates independently) .options = furrr::furrr_options(seed = TRUE),
result_list <- furrr::future_map( function(field) {
valid_sub_fields, extract_CI_data(field,
.progress = TRUE, harvesting_data = harvesting_data,
.options = furrr::furrr_options(seed = TRUE), field_CI_data = ci_data,
function(field) { season = yr,
# Call with verbose=FALSE to suppress warnings during parallel iteration verbose = FALSE)
extract_CI_data(field, }
harvesting_data = harvesting_data, )
field_CI_data = ci_data, } else {
result_list <- purrr::map(valid_sub_fields, function(field) {
extract_CI_data(field,
harvesting_data = harvesting_data,
field_CI_data = ci_data,
season = yr, season = yr,
verbose = FALSE) verbose = TRUE)
} })
) }
# Return to sequential processing
future::plan(future::sequential)
# Process results and tracking # Process results and tracking
for (i in seq_along(result_list)) { for (i in seq_along(result_list)) {
field_result <- result_list[[i]] field_result <- result_list[[i]]
field_name <- valid_sub_fields[i] field_name <- valid_sub_fields[i]
if (nrow(field_result) > 0) { if (nrow(field_result) > 0) {
successful_fields <<- successful_fields + 1 successful_fields <<- successful_fields + 1
} else { } else {
@ -305,15 +318,16 @@ generate_interpolated_ci_data <- function(years, harvesting_data, ci_data) {
) )
} }
} }
# Combine all results for this year # Combine all results for this year
result_list <- result_list[sapply(result_list, nrow) > 0] # Keep only non-empty result_list <- result_list[sapply(result_list, nrow) > 0]
if (length(result_list) > 0) { if (length(result_list) > 0) purrr::list_rbind(result_list) else data.frame()
purrr::list_rbind(result_list)
} else {
data.frame()
}
}) })
# Tear down parallel plan once after all years are processed
if (n_cores_interp > 1) {
future::plan(future::sequential)
}
# Print summary # Print summary
safe_log(sprintf("\n=== Interpolation Summary ===")) safe_log(sprintf("\n=== Interpolation Summary ==="))

341
r_app/90_CI_report_with_kpis_agronomic_support.Rmd
View file

@ -12,8 +12,8 @@ params:
facet_by_season: FALSE facet_by_season: FALSE
x_axis_unit: "days" x_axis_unit: "days"
output: output:
word_document: word_document:
reference_docx: !expr file.path("word-styles-reference-var1.docx") reference_docx: !expr file.path("word-styles-reference-var1.docx")
toc: no toc: no
editor_options: editor_options:
chunk_output_type: console chunk_output_type: console
@ -472,9 +472,8 @@ tryCatch({
translations <- do.call(rbind, translation_list) translations <- do.call(rbind, translation_list)
if (!is.null(translations)) { if (!is.null(translations)) {
safe_log("Translations file succesfully loaded") safe_log("Translations file successfully loaded")
} else { } else { safe_log("Failed to load translations", "ERROR")
safe_log("Failed to load translations", "ERROR")
translations <- NULL translations <- NULL
} }
}, error = function(e) { }, error = function(e) {
@ -498,72 +497,7 @@ tryCatch({
localisation <<- NULL localisation <<- NULL
}) })
# Helper function to handle missing translation keys # tr_key() and map_trend_to_arrow() are defined in 90_report_utils.R (sourced above)
tr_key <- function(key) {
if (key %in% names(tr)) {
txt <- glue(tr[key], .envir = parent.frame())
txt <- gsub("\n", " \n", txt)
return(enc2utf8(as.character(txt)))
} else if (is.na(key)) {
return(tr_key("NA"))
} else if (key == "") {
return("")
} else {
return(paste0(key))
}
}
# ============================================================================
# SHARED TREND MAPPING HELPER
# ============================================================================
# Canonical function for converting trend text to arrows/formatted text
# Normalizes all legacy and current trend category names to standardized output
# Used by: combined_kpi_table, field_details_table, and compact_field_display chunks
map_trend_to_arrow <- function(text_vec, include_text = FALSE) {
# Normalize: convert to character and lowercase
text_lower <- tolower(as.character(text_vec))
# Apply mapping to each element
sapply(text_lower, function(text) {
# Handle NA and empty values
if (is.na(text) || text == "" || nchar(trimws(text)) == 0) {
return(NA_character_)
}
# Determine category and build output with translated labels
# Using word-boundary anchored patterns (perl=TRUE) to avoid substring mis-matches
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 {
# Fallback: return "—" (em-dash) for arrow-only mode, raw text for text mode
# This signals an unmatched trend value that should be logged
return(if (include_text) as.character(text) else "—")
}
# Get translated label using tr_key()
label <- tr_key(trans_key)
# Return formatted output based on include_text flag
if (include_text) {
paste0(label, " (", arrow, ")")
} else {
arrow
}
}, USE.NAMES = FALSE)
}
``` ```
<!-- Dynamic cover page --> <!-- Dynamic cover page -->
@ -781,144 +715,12 @@ if (exists("summary_tables") && !is.null(summary_tables) && length(summary_table
`r tr_key("field_alerts")` `r tr_key("field_alerts")`
```{r field_alerts_table, echo=FALSE, results='asis'} ```{r field_alerts_table, echo=FALSE, results='asis'}
# Generate alerts for all fields # generate_field_alerts() is defined in 90_report_utils.R (sourced above).
generate_field_alerts <- function(field_details_table) { # field_details_table has already been normalised by normalize_field_details_columns().
if (is.null(field_details_table) || nrow(field_details_table) == 0) {
return(NULL) # Return NULL to signal no data
}
# Check for required columns
required_cols <- c("Field", "Growth Uniformity", "Yield Forecast (t/ha)",
"Gap Score", "Decline Risk", "Patchiness Risk", "Mean CI", "CV Value", "Moran's I")
missing_cols <- setdiff(required_cols, colnames(field_details_table))
if (length(missing_cols) > 0) {
message("Field details missing required columns: ", paste(missing_cols, collapse = ", "))
return(NULL) # Return NULL if required columns are missing
}
alerts_list <- list()
# Get unique fields
unique_fields <- unique(field_details_table$Field)
for (field_name in unique_fields) {
field_data <- field_details_table %>% filter(Field == field_name)
# Aggregate data for the field
field_summary <- field_data %>%
summarise(
uniformity_levels = paste(unique(`Growth Uniformity`), collapse = "/"),
avg_yield_forecast = 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_patchiness_risk = case_when(
any(`Patchiness Risk` == "High") ~ "High",
any(`Patchiness Risk` == "Medium") ~ "Medium",
any(`Patchiness Risk` == "Low") ~ "Low",
any(`Patchiness Risk` == "Minimal") ~ "Minimal",
TRUE ~ "Unknown"
),
avg_mean_ci = mean(`Mean CI`, na.rm = TRUE),
avg_cv = mean(`CV Value`, na.rm = TRUE),
.groups = 'drop'
)
# Generate alerts for this field based on simplified CV-Moran's I priority system (3 levels)
field_alerts <- c()
# Get CV and Moran's I values
avg_cv <- field_summary$avg_cv
morans_i <- mean(field_data[["Moran's I"]], na.rm = TRUE)
# Determine priority level (1=Urgent, 2=Monitor, 3=No stress)
priority_level <- get_field_priority_level(avg_cv, morans_i)
# Generate alerts based on priority level
if (priority_level == 1) {
field_alerts <- c(field_alerts, tr_key("priority"))
} else if (priority_level == 2) {
field_alerts <- c(field_alerts, tr_key("monitor"))
}
# Priority 3: No alert (no stress)
# Keep other alerts for decline risk, patchiness risk, gap score
if (field_summary$highest_decline_risk %in% c("High", "Very-high")) {
field_alerts <- c(field_alerts, tr_key("growth_decline"))
}
if (field_summary$highest_patchiness_risk == "High") {
field_alerts <- c(field_alerts, tr_key("high_patchiness"))
}
if (field_summary$max_gap_score > 20) {
field_alerts <- c(field_alerts, tr_key("gaps_present"))
}
# Only add alerts if there are any (skip fields with no alerts)
if (length(field_alerts) > 0) {
# Add to alerts list
for (alert in field_alerts) {
alerts_list[[length(alerts_list) + 1]] <- data.frame(
Field = field_name,
Alert = alert
)
}
}
}
# Combine all alerts
if (length(alerts_list) > 0) {
alerts_df <- do.call(rbind, alerts_list)
return(alerts_df)
} else {
return(data.frame(Field = character(), Alert = character()))
}
}
# Generate and display alerts table # Generate and display alerts table
if (exists("field_details_table") && !is.null(field_details_table) && nrow(field_details_table) > 0) { if (exists("field_details_table") && !is.null(field_details_table) && nrow(field_details_table) > 0) {
# Adapter: Map normalized column names back to legacy names for generate_field_alerts() alerts_data <- generate_field_alerts(field_details_table)
# (generates from the normalized schema created by normalize_field_details_columns + column_mappings)
field_details_for_alerts <- field_details_table
# Rename normalized columns back to legacy names (only if they exist)
if ("Field_id" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(Field = Field_id)
}
if ("Mean_CI" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Mean CI` = Mean_CI)
}
if ("CV" %in% names(field_details_for_alerts) && !("CV Value" %in% names(field_details_for_alerts))) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`CV Value` = CV)
}
if ("TCH_Forecasted" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Yield Forecast (t/ha)` = TCH_Forecasted)
}
if ("Gap_Score" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Gap Score` = Gap_Score)
}
if ("Uniformity_Category" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Growth Uniformity` = Uniformity_Category)
}
if ("Decline_Risk" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Decline Risk` = Decline_Risk)
}
if ("Decline_Severity" %in% names(field_details_for_alerts) && !("Decline Risk" %in% names(field_details_for_alerts))) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Decline Risk` = Decline_Severity)
}
if ("Patchiness_Risk" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Patchiness Risk` = Patchiness_Risk)
}
if ("Morans_I" %in% names(field_details_for_alerts)) {
field_details_for_alerts <- field_details_for_alerts %>% dplyr::rename(`Moran's I` = Morans_I)
}
alerts_data <- generate_field_alerts(field_details_for_alerts)
if (!is.null(alerts_data) && nrow(alerts_data) > 0) { if (!is.null(alerts_data) && nrow(alerts_data) > 0) {
ft <- flextable(alerts_data) %>% ft <- flextable(alerts_data) %>%
# set_caption("Field Alerts Summary") %>% # set_caption("Field Alerts Summary") %>%
@ -1027,36 +829,23 @@ if (!exists("field_details_table") || is.null(field_details_table)) {
tryCatch({ tryCatch({
safe_log("Starting farm-level raster aggregation for overview maps") safe_log("Starting farm-level raster aggregation for overview maps")
# Helper function to safely aggregate mosaics for a specific week # Aggregate per-field mosaics into farm-level rasters for current, week-1, week-3
aggregate_mosaics_safe <- function(week_num, year_num, label) { # aggregate_per_field_mosaics_to_farm_level() is defined in 90_report_utils.R (sourced above)
tryCatch({ farm_mosaic_current <- aggregate_per_field_mosaics_to_farm_level(
safe_log(paste("Aggregating mosaics for", label, "(week", week_num, ",", year_num, ")")) weekly_mosaic_dir = weekly_CI_mosaic,
target_week = current_week,
# Call the utility function from 90_report_utils.R target_year = current_iso_year
# This function reads all per-field mosaics and merges them into a single raster )
farm_mosaic <- aggregate_per_field_mosaics_to_farm_level( farm_mosaic_minus_1 <- aggregate_per_field_mosaics_to_farm_level(
weekly_mosaic_dir = weekly_CI_mosaic, weekly_mosaic_dir = weekly_CI_mosaic,
target_week = week_num, target_week = as.numeric(week_minus_1),
target_year = year_num target_year = week_minus_1_year
) )
farm_mosaic_minus_3 <- aggregate_per_field_mosaics_to_farm_level(
if (!is.null(farm_mosaic)) { weekly_mosaic_dir = weekly_CI_mosaic,
safe_log(paste("✓ Successfully aggregated farm mosaic for", label, "")) target_week = as.numeric(week_minus_3),
return(farm_mosaic) target_year = week_minus_3_year
} else { )
safe_log(paste("Warning: Farm mosaic is NULL for", label), "WARNING")
return(NULL)
}
}, error = function(e) {
safe_log(paste("Error aggregating mosaics for", label, ":", e$message), "WARNING")
return(NULL)
})
}
# Aggregate mosaics for three weeks: current, week-1, week-3
farm_mosaic_current <- aggregate_mosaics_safe(current_week, current_iso_year, "current week")
farm_mosaic_minus_1 <- aggregate_mosaics_safe(as.numeric(week_minus_1), week_minus_1_year, "week-1")
farm_mosaic_minus_3 <- aggregate_mosaics_safe(as.numeric(week_minus_3), week_minus_3_year, "week-3")
# Extract CI band (5th band, or named "CI") from each aggregated mosaic # Extract CI band (5th band, or named "CI") from each aggregated mosaic
farm_ci_current <- NULL farm_ci_current <- NULL
@ -1111,18 +900,7 @@ tryCatch({
AllPivots0_ll <- AllPivots0 AllPivots0_ll <- AllPivots0
target_crs <- "EPSG:4326" target_crs <- "EPSG:4326"
downsample_raster <- function(r, max_cells = 2000000) { # downsample_raster() is defined in 90_report_utils.R (sourced above)
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 = mean, na.rm = TRUE))
}
r
}
if (!is.null(farm_ci_current) && !terra::is.lonlat(farm_ci_current)) { if (!is.null(farm_ci_current) && !terra::is.lonlat(farm_ci_current)) {
farm_ci_current_ll <- terra::project(farm_ci_current, target_crs, method = "bilinear") farm_ci_current_ll <- terra::project(farm_ci_current, target_crs, method = "bilinear")
@ -1396,14 +1174,8 @@ tryCatch({
dplyr::group_by(field) %>% dplyr::group_by(field) %>%
dplyr::summarise(.groups = 'drop') dplyr::summarise(.groups = 'drop')
# Helper to get week/year from a date # get_week_year() is defined in 90_report_utils.R (sourced above)
get_week_year <- function(date) {
list(
week = as.numeric(format(date, "%V")),
year = as.numeric(format(date, "%G"))
)
}
# Calculate week/year for current and historical weeks # Calculate week/year for current and historical weeks
current_ww <- get_week_year(as.Date(today)) current_ww <- get_week_year(as.Date(today))
minus_1_ww <- get_week_year(as.Date(today) - lubridate::weeks(1)) minus_1_ww <- get_week_year(as.Date(today) - lubridate::weeks(1))
@ -1413,26 +1185,8 @@ tryCatch({
message(paste("Processing", nrow(AllPivots_merged), "fields for weeks:", message(paste("Processing", nrow(AllPivots_merged), "fields for weeks:",
current_ww$week, minus_1_ww$week, minus_2_ww$week, minus_3_ww$week)) current_ww$week, minus_1_ww$week, minus_2_ww$week, minus_3_ww$week))
# Helper function to safely load per-field mosaic if it exists # load_per_field_mosaic() is defined in 90_report_utils.R (sourced above)
load_per_field_mosaic <- function(base_dir, field_name, week, year) {
path <- file.path(base_dir, field_name, paste0("week_", sprintf("%02d", week), "_", year, ".tif"))
if (file.exists(path)) {
tryCatch({
rast_obj <- terra::rast(path)
# Extract CI band if present, otherwise first band
if ("CI" %in% names(rast_obj)) {
return(rast_obj[["CI"]])
} else if (nlyr(rast_obj) > 0) {
return(rast_obj[[1]])
}
}, error = function(e) {
message(paste("Warning: Could not load", path, ":", e$message))
return(NULL)
})
}
return(NULL)
}
# Iterate through fields using purrr::walk # Iterate through fields using purrr::walk
purrr::walk(AllPivots_merged$field, function(field_name) { purrr::walk(AllPivots_merged$field, function(field_name) {
tryCatch({ tryCatch({
@ -1571,38 +1325,7 @@ tryCatch({
}) })
``` ```
```{r generate_subarea_visualizations, eval=FALSE, echo=FALSE, fig.height=3.8, fig.width=6.5, message=FALSE, warning=FALSE, dpi=150, results='asis'} \newpage
# Alternative visualization grouped by sub-area (disabled by default)
tryCatch({
# Group pivots by sub-area
pivots_grouped <- AllPivots0
# Iterate over each subgroup
for (subgroup in unique(pivots_grouped$sub_area)) {
# Add subgroup heading
cat("\n")
cat("## Subgroup: ", subgroup, "\n")
# Filter data for current subgroup
subset_data <- dplyr::filter(pivots_grouped, sub_area == subgroup)
# Generate visualizations for each field in the subgroup
purrr::walk(subset_data$field, function(field_name) {
cat("\n")
ci_plot(field_name)
cat("\n")
cum_ci_plot(field_name)
cat("\n")
})
# Add page break after each subgroup
cat("\\newpage\n")
}
}, error = function(e) {
safe_log(paste("Error in subarea visualization section:", e$message), "ERROR")
cat("Error generating subarea plots. See log for details.\n")
})
```
`r tr_key("detailed_field")` `r tr_key("detailed_field")`
@ -1700,7 +1423,7 @@ if (!exists("field_details_table") || is.null(field_details_table) || nrow(field
field_details_clean <- field_details_clean %>% field_details_clean <- field_details_clean %>%
select( select(
field = Field_id, field = Field_id,
field_size = field_size_acres, field_size = field_size_area,
mean_ci = Mean_CI, mean_ci = Mean_CI,
yield_forecast = TCH_Forecasted, yield_forecast = TCH_Forecasted,
gap_score = Gap_Score, gap_score = Gap_Score,

413
r_app/90_report_utils.R
View file

@ -24,8 +24,35 @@ subchunkify <- function(g, fig_height=7, fig_width=5) {
"\n`","`` "\n`","``
") ")
cat(knitr::knit(text = knitr::knit_expand(text = sub_chunk), quiet = TRUE)) 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 #' Creates a Chlorophyll Index map for a pivot
#' #'
@ -74,7 +101,7 @@ create_CI_map <- function(pivot_raster, pivot_shape, pivot_spans, show_legend =
outliers.trunc = c(TRUE, TRUE) outliers.trunc = c(TRUE, TRUE)
), ),
col.legend = tm_legend( col.legend = tm_legend(
title = "CI", title = tr_key("map_legend_ci_title", "CI"),
orientation = if (legend_is_portrait) "portrait" else "landscape", orientation = if (legend_is_portrait) "portrait" else "landscape",
show = show_legend, show = show_legend,
position = if (show_legend) tm_pos_out(legend_position, "center") else c("left", "bottom"), position = if (show_legend) tm_pos_out(legend_position, "center") else c("left", "bottom"),
@ -82,8 +109,9 @@ create_CI_map <- function(pivot_raster, pivot_shape, pivot_spans, show_legend =
) )
) )
# Add layout elements # Add layout elements
age_days <- age * 7
map <- map + tm_layout( map <- map + tm_layout(
main.title = paste0("Max CI week ", week,"\n", age, " weeks (", age * 7, " days) old"), main.title = tr_key("map_title_max_ci", "Max CI week {week}\n{age} weeks ({age_days} days) old"),
main.title.size = 0.7, main.title.size = 0.7,
#legend.height = 0.85, # Constrain vertical legend height to not exceed map #legend.height = 0.85, # Constrain vertical legend height to not exceed map
asp = 1 # Fixed aspect ratio asp = 1 # Fixed aspect ratio
@ -151,7 +179,7 @@ create_CI_diff_map <- function(pivot_raster, pivot_shape, pivot_spans, show_lege
outliers.trunc = c(TRUE, TRUE) outliers.trunc = c(TRUE, TRUE)
), ),
col.legend = tm_legend( col.legend = tm_legend(
title = "CI diff.", title = tr_key("map_legend_ci_diff", "CI diff."),
orientation = if (legend_is_portrait) "portrait" else "landscape", orientation = if (legend_is_portrait) "portrait" else "landscape",
show = show_legend, show = show_legend,
position = if (show_legend) tm_pos_out(legend_position, "center") else c("left", "bottom"), position = if (show_legend) tm_pos_out(legend_position, "center") else c("left", "bottom"),
@ -159,8 +187,9 @@ create_CI_diff_map <- function(pivot_raster, pivot_shape, pivot_spans, show_lege
) )
) )
# Add layout elements # Add layout elements
age_days <- age * 7
map <- map + tm_layout( map <- map + tm_layout(
main.title = paste0("CI change week ", week_1, " - week ", week_2, "\n", age, " weeks (", age * 7, " days) old"), 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, main.title.size = 0.7,
#legend.height = 0.85, # Constrain vertical legend height to not exceed map #legend.height = 0.85, # Constrain vertical legend height to not exceed map
asp = 1 # Fixed aspect ratio asp = 1 # Fixed aspect ratio
@ -344,7 +373,7 @@ ci_plot <- function(pivotName,
# Output heading and map to R Markdown # Output heading and map to R Markdown
age_months <- round(age / 4.348, 1) age_months <- round(age / 4.348, 1)
cat(paste("## Field", pivotName, "-", age, "weeks/", age_months, "months after planting/harvest", field_heading_note, "\n\n")) cat(paste0("## ", tr_key("field_section_header", "Field {pivotName} - {age} weeks/ {age_months} months after planting/harvest"), field_heading_note, "\n\n"))
print(tst) print(tst)
}, error = function(e) { }, error = function(e) {
@ -400,7 +429,11 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
mean_rolling_10_days = zoo::rollapplyr(value, 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)) 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 # Compute benchmarks if requested and not provided
if (show_benchmarks && is.null(benchmark_data)) { if (show_benchmarks && is.null(benchmark_data)) {
benchmark_data <- compute_ci_benchmarks(ci_quadrant_data, estate_name, benchmark_percentiles) benchmark_data <- compute_ci_benchmarks(ci_quadrant_data, estate_name, benchmark_percentiles)
@ -411,8 +444,8 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
benchmark_data <- benchmark_data %>% benchmark_data <- benchmark_data %>%
dplyr::mutate( dplyr::mutate(
ci_type_label = case_when( ci_type_label = case_when(
ci_type == "value" ~ "10-Day Rolling Mean CI", ci_type == "value" ~ rolling_mean_label,
ci_type == "cumulative_CI" ~ "Cumulative CI", ci_type == "cumulative_CI" ~ cumulative_label,
TRUE ~ ci_type TRUE ~ ci_type
), ),
benchmark_label = paste0(percentile, "th Percentile") benchmark_label = paste0(percentile, "th Percentile")
@ -454,9 +487,9 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
} }
x_label <- switch(x_unit, x_label <- switch(x_unit,
"days" = if (facet_on) "Date" else "Age of Crop (Days)", "days" = if (facet_on) tr_key("lbl_date", "Date") else tr_key("lbl_age_of_crop_days", "Age of Crop (Days)"),
"weeks" = "Week Number") "weeks" = tr_key("lbl_week_number", "Week Number"))
# Calculate dynamic max values for breaks # Calculate dynamic max values for breaks
max_dah <- max(plot_data$DAH, na.rm = TRUE) + 20 max_dah <- max(plot_data$DAH, na.rm = TRUE) + 20
max_week <- max(as.numeric(plot_data$week), na.rm = TRUE) + ceiling(20 / 7) max_week <- max(as.numeric(plot_data$week), na.rm = TRUE) + ceiling(20 / 7)
@ -473,12 +506,12 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
group = .data[["sub_field"]] group = .data[["sub_field"]]
) )
) + ) +
ggplot2::labs(title = paste("Plot of", y_label), ggplot2::labs(title = paste(tr_key("lbl_plot_of", "Plot of"), y_label),
color = "Field Name", color = tr_key("lbl_field_name", "Field Name"),
y = y_label, y = y_label,
x = x_label) + x = x_label) +
ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%m-%Y", ggplot2::scale_x_date(date_breaks = "1 month", date_labels = "%m-%Y",
sec.axis = ggplot2::sec_axis(~ ., name = "Age in Months", sec.axis = ggplot2::sec_axis(~ ., name = tr_key("lbl_age_in_months", "Age in Months"),
breaks = scales::breaks_pretty(), breaks = scales::breaks_pretty(),
labels = function(x) round(as.numeric(x - min(x)) / 30.44, 1))) + labels = function(x) round(as.numeric(x - min(x)) / 30.44, 1))) +
ggplot2::theme_minimal() + ggplot2::theme_minimal() +
@ -547,16 +580,16 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
), ),
linewidth = 1.5, alpha = 1 linewidth = 1.5, alpha = 1
) + ) +
ggplot2::labs(title = paste("Plot of", y_label, "for Field", pivotName, title_suffix), ggplot2::labs(title = paste(tr_key("lbl_plot_of", "Plot of"), y_label, tr_key("lbl_for_field", "for Field"), pivotName, title_suffix),
color = "Season", color = tr_key("lbl_season", "Season"),
y = y_label, y = y_label,
x = x_label) + x = x_label) +
color_scale + color_scale +
{ {
if (x_var == "DAH") { if (x_var == "DAH") {
ggplot2::scale_x_continuous(breaks = seq(0, 450, by = 50), sec.axis = ggplot2::sec_axis(~ . / 30.44, name = "Age in Months", breaks = seq(0, 14, by = 1))) ggplot2::scale_x_continuous(breaks = seq(0, 450, by = 50), sec.axis = ggplot2::sec_axis(~ . / 30.44, name = tr_key("lbl_age_in_months", "Age in Months"), breaks = seq(0, 14, by = 1)))
} else if (x_var == "week") { } else if (x_var == "week") {
ggplot2::scale_x_continuous(breaks = seq(0, max_week, by = 4), sec.axis = ggplot2::sec_axis(~ . / 4.348, name = "Age in Months", breaks = seq(0, 14, by = 1))) ggplot2::scale_x_continuous(breaks = seq(0, max_week, by = 4), sec.axis = ggplot2::sec_axis(~ . / 4.348, name = tr_key("lbl_age_in_months", "Age in Months"), breaks = seq(0, 14, by = 1)))
} }
} + } +
ggplot2::theme_minimal() + ggplot2::theme_minimal() +
@ -581,19 +614,19 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
# Generate plots based on plot_type # Generate plots based on plot_type
if (plot_type == "absolute") { if (plot_type == "absolute") {
g <- create_plot("mean_rolling_10_days", "10-Day Rolling Mean CI", "") g <- create_plot("mean_rolling_10_days", rolling_mean_label, "")
subchunkify(g, 2.8, 10) subchunkify(g, 2.8, 10)
} else if (plot_type == "cumulative") { } else if (plot_type == "cumulative") {
g <- create_plot("cumulative_CI", "Cumulative CI", "") g <- create_plot("cumulative_CI", cumulative_label, "")
subchunkify(g, 2.8, 10) subchunkify(g, 2.8, 10)
} else if (plot_type == "both") { } else if (plot_type == "both") {
# Create faceted plot with both CI types using pivot_longer approach # Create faceted plot with both CI types using pivot_longer approach
plot_data_both <- data_ci3 %>% plot_data_both <- data_ci3 %>%
dplyr::filter(season %in% unique_seasons) %>% dplyr::filter(season %in% unique_seasons) %>%
dplyr::mutate( dplyr::mutate(
ci_type_label = case_when( ci_type_label = case_when(
ci_type == "mean_rolling_10_days" ~ "10-Day Rolling Mean CI", ci_type == "mean_rolling_10_days" ~ rolling_mean_label,
ci_type == "cumulative_CI" ~ "Cumulative CI", ci_type == "cumulative_CI" ~ cumulative_label,
TRUE ~ ci_type TRUE ~ ci_type
), ),
is_latest = season == latest_season # Flag for latest season is_latest = season == latest_season # Flag for latest season
@ -607,9 +640,9 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
} }
x_label <- switch(x_unit, x_label <- switch(x_unit,
"days" = if (facet_on) "Date" else "Age of Crop (Days)", "days" = if (facet_on) tr_key("lbl_date", "Date") else tr_key("lbl_age_of_crop_days", "Age of Crop (Days)"),
"weeks" = "Week Number") "weeks" = tr_key("lbl_week_number", "Week Number"))
# Choose color palette based on colorblind_friendly flag # Choose color palette based on colorblind_friendly flag
color_scale <- if (colorblind_friendly) { color_scale <- if (colorblind_friendly) {
ggplot2::scale_color_brewer(type = "qual", palette = "Set2") ggplot2::scale_color_brewer(type = "qual", palette = "Set2")
@ -620,7 +653,10 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
# Calculate dynamic max values for breaks # Calculate dynamic max values for breaks
max_dah_both <- max(plot_data_both$DAH, na.rm = TRUE) + 20 max_dah_both <- max(plot_data_both$DAH, na.rm = TRUE) + 20
max_week_both <- max(as.numeric(plot_data_both$week), na.rm = TRUE) + ceiling(20 / 7) max_week_both <- max(as.numeric(plot_data_both$week), na.rm = TRUE) + ceiling(20 / 7)
# Pre-evaluate translated title here (not inside labs()) so {pivotName} resolves correctly
both_plot_title <- tr_key("lbl_ci_analysis_title", "CI Analysis for Field {pivotName}")
# Create the faceted plot # Create the faceted plot
g_both <- ggplot2::ggplot(data = plot_data_both) + g_both <- ggplot2::ggplot(data = plot_data_both) +
# Add benchmark lines first (behind season lines) # Add benchmark lines first (behind season lines)
@ -636,8 +672,8 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
DAH DAH
}, },
ci_type_label = case_when( ci_type_label = case_when(
ci_type == "value" ~ "10-Day Rolling Mean CI", ci_type == "value" ~ rolling_mean_label,
ci_type == "cumulative_CI" ~ "Cumulative CI", ci_type == "cumulative_CI" ~ cumulative_label,
TRUE ~ ci_type TRUE ~ ci_type
) )
) )
@ -675,18 +711,18 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
), ),
linewidth = 1.5, alpha = 1 linewidth = 1.5, alpha = 1
) + ) +
ggplot2::labs(title = paste("CI Analysis for Field", pivotName), ggplot2::labs(title = both_plot_title,
color = "Season", color = tr_key("lbl_season", "Season"),
y = "CI Value", y = tr_key("lbl_ci_value", "CI Value"),
x = x_label) + x = x_label) +
color_scale + color_scale +
{ {
if (x_var == "DAH") { if (x_var == "DAH") {
ggplot2::scale_x_continuous(breaks = seq(0, 450, by = 50), sec.axis = ggplot2::sec_axis(~ . / 30.44, name = "Age in Months", breaks = seq(0, 14, by = 1))) ggplot2::scale_x_continuous(breaks = seq(0, 450, by = 50), sec.axis = ggplot2::sec_axis(~ . / 30.44, name = tr_key("lbl_age_in_months", "Age in Months"), breaks = seq(0, 14, by = 1)))
} else if (x_var == "week") { } else if (x_var == "week") {
ggplot2::scale_x_continuous(breaks = seq(0, max_week_both, by = 4), sec.axis = ggplot2::sec_axis(~ . / 4.348, name = "Age in Months", breaks = seq(0, 14, by = 1))) ggplot2::scale_x_continuous(breaks = seq(0, max_week_both, by = 4), sec.axis = ggplot2::sec_axis(~ . / 4.348, name = tr_key("lbl_age_in_months", "Age in Months"), breaks = seq(0, 14, by = 1)))
} else if (x_var == "Date") { } else if (x_var == "Date") {
ggplot2::scale_x_date(breaks = "1 month", date_labels = "%b-%Y", sec.axis = ggplot2::sec_axis(~ ., name = "Age in Months", breaks = scales::breaks_pretty())) ggplot2::scale_x_date(breaks = "1 month", date_labels = "%b-%Y", sec.axis = ggplot2::sec_axis(~ ., name = tr_key("lbl_age_in_months", "Age in Months"), breaks = scales::breaks_pretty()))
} }
} + } +
ggplot2::theme_minimal() + ggplot2::theme_minimal() +
@ -707,7 +743,7 @@ cum_ci_plot <- function(pivotName, ci_quadrant_data = CI_quadrant, plot_type = "
# Add invisible points to set the y-axis range for rolling mean facet # Add invisible points to set the y-axis range for rolling mean facet
dummy_data <- data.frame( dummy_data <- data.frame(
ci_type_label = "10-Day Rolling Mean CI", ci_type_label = rolling_mean_label,
ci_value = c(0, 7), ci_value = c(0, 7),
stringsAsFactors = FALSE stringsAsFactors = FALSE
) )
@ -749,11 +785,14 @@ cum_ci_plot2 <- function(pivotName){
date_seq <- seq.Date(from = start_date, to = end_date, by = "month") date_seq <- seq.Date(from = start_date, to = end_date, by = "month")
midpoint_date <- start_date + (end_date - start_date) / 2 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() + g <- ggplot() +
scale_x_date(limits = c(start_date, end_date), date_breaks = "1 month", date_labels = "%m-%Y") + scale_x_date(limits = c(start_date, end_date), date_breaks = "1 month", date_labels = "%m-%Y") +
scale_y_continuous(limits = c(0, 4)) + scale_y_continuous(limits = c(0, 4)) +
labs(title = paste("14 day rolling MEAN CI rate - Field ", pivotName), labs(title = fallback_title,
x = "Date", y = "CI Rate") + x = tr_key("lbl_date", "Date"), y = tr_key("lbl_ci_rate", "CI Rate")) +
theme_minimal() + theme_minimal() +
theme(axis.text.x = element_text(hjust = 0.5), theme(axis.text.x = element_text(hjust = 0.5),
legend.justification = c(1, 0), legend.justification = c(1, 0),
@ -761,7 +800,7 @@ cum_ci_plot2 <- function(pivotName){
legend.position.inside = c(1, 0), legend.position.inside = c(1, 0),
legend.title = element_text(size = 8), legend.title = element_text(size = 8),
legend.text = element_text(size = 8)) + legend.text = element_text(size = 8)) +
annotate("text", x = midpoint_date, y = 2, label = "No data available", size = 6, hjust = 0.5) 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) subchunkify(g, 3.2, 10)
@ -1175,31 +1214,295 @@ generate_field_kpi_summary <- function(field_name, field_details_table, CI_quadr
#' Normalize field_details_table column structure #' Normalize field_details_table column structure
#' #'
#' Standardizes column names and ensures all expected KPI columns exist. #' Standardizes column names from various legacy and pipeline-generated schemas
#' Handles Field → Field_id rename and injects missing columns as NA. #' into a single canonical set, then ensures all expected KPI columns exist
#' (adding \code{NA} columns for any that are absent).
#' #'
#' @param field_details_table data.frame to normalize #' Rename rules applied in order:
#' @return data.frame with standardized column structure #' \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) { normalize_field_details_columns <- function(field_details_table) {
if (is.null(field_details_table) || nrow(field_details_table) == 0) { if (is.null(field_details_table) || nrow(field_details_table) == 0) {
return(field_details_table) return(field_details_table)
} }
# Rename Field → Field_id if needed rename_if_missing <- function(df, from, to) {
if ("Field" %in% names(field_details_table) && !("Field_id" %in% names(field_details_table))) { if (from %in% names(df) && !to %in% names(df))
field_details_table <- field_details_table %>% df <- dplyr::rename(df, !!to := !!rlang::sym(from))
dplyr::rename(Field_id = Field) 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 # Ensure all expected KPI columns exist; add as NA if missing
expected_cols <- c("Field_id", "Mean_CI", "CV", "TCH_Forecasted", "Gap_Score", expected_cols <- c(
"Trend_Interpretation", "Weekly_CI_Change", "Uniformity_Interpretation", "Field_id", "Mean_CI", "CV", "Morans_I", "TCH_Forecasted", "Gap_Score",
"Decline_Severity", "Patchiness_Risk") "Trend_Interpretation", "Weekly_CI_Change", "Uniformity_Interpretation",
"Decline_Severity", "Patchiness_Risk"
)
for (col in expected_cols) { for (col in expected_cols) {
if (!col %in% names(field_details_table)) { if (!col %in% names(field_details_table)) {
field_details_table[[col]] <- NA field_details_table[[col]] <- NA
} }
} }
return(field_details_table) 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
}

180
r_app/MANUAL_PIPELINE_RUNNER.R
View file

@ -439,14 +439,14 @@
rmarkdown::render( rmarkdown::render(
"r_app/90_CI_report_with_kpis_agronomic_support.Rmd", "r_app/90_CI_report_with_kpis_agronomic_support.Rmd",
params = list(data_dir = "aura", report_date = as.Date("2026-02-18"), language = "en" ), params = list(data_dir = "aura", report_date = as.Date("2026-02-18"), language = "en" ),
output_file = "SmartCane_Report_agronomic_support_aura_2026-02-18_en.docx", output_file = "SmartCane_Report_agronomic_support_aura_2026-02-18_en_test.docx",
output_dir = "laravel_app/storage/app/aura/reports" output_dir = "laravel_app/storage/app/aura/reports"
) )
rmarkdown::render( rmarkdown::render(
"r_app/90_CI_report_with_kpis_agronomic_support.Rmd", "r_app/90_CI_report_with_kpis_agronomic_support.Rmd",
params = list(data_dir = "aura", report_date = as.Date("2026-02-18"), language = "es" ), params = list(data_dir = "aura", report_date = as.Date("2026-02-18"), language = "es" ),
output_file = "SmartCane_Report_agronomic_support_aura_2026-02-18_es.docx", output_file = "SmartCane_Report_agronomic_support_aura_2026-02-18_es_test.docx",
output_dir = "laravel_app/storage/app/aura/reports" output_dir = "laravel_app/storage/app/aura/reports"
) )
# #
@ -461,179 +461,3 @@ rmarkdown::render(
output_dir = "laravel_app/storage/app/angata/reports" output_dir = "laravel_app/storage/app/angata/reports"
) )
# #
# EXPECTED OUTPUT:
# File: SmartCane_Report_*_{PROJECT}_{DATE}.docx
# Location: laravel_app/storage/app/{PROJECT}/reports/
# Script execution time: 5-10 minutes
#
# NOTE:
# These are R Markdown files and cannot be run directly via Rscript
# Use rmarkdown::render() from an R interactive session or wrapper script
# See run_full_pipeline.R for an automated example
#
# ============================================================================
# ==============================================================================
# QUICK REFERENCE: Common Workflows
# ==============================================================================
#
# WORKFLOW A: Weekly Update (Most Common)
# ─────────────────────────────────────────────────────────────────────────
# Goal: Process latest week of data through full pipeline
#
# Parameters:
# $PROJECT = "angata"
# $END_DATE = "2026-02-04" # Today or latest date available
# $OFFSET = 7 # One week back
#
# Steps:
# 1. SKIP Python download (if you already have data)
# 2. Run R10: & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/10_create_per_field_tiffs.R angata 2026-02-04 7
# (Argument order: [PROJECT] [END_DATE] [OFFSET])
# 3. Run R20: & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/20_ci_extraction_per_field.R angata 2026-02-04 7
# 4. Run R30: & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/30_interpolate_growth_model.R angata
# 5. Run R21: & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/21_convert_ci_rds_to_csv.R angata
# 6. Run R40: & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/40_mosaic_creation_per_field.R 2026-02-04 7 angata
# (Argument order: [END_DATE] [OFFSET] [PROJECT])
# 7. Run R80: & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/80_calculate_kpis.R 2026-02-04 angata 7
# (Argument order: [END_DATE] [PROJECT] [OFFSET] - DIFFERENT from R40!)
# 8. OPTIONAL R91 (Cane Supply) - Use automated runner:
# & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/run_full_pipeline.R
# OR from R console:
# rmarkdown::render("r_app/91_CI_report_with_kpis_cane_supply.Rmd",
# params=list(data_dir="angata", report_date=as.Date("2026-02-04")),
# output_file="SmartCane_Report_cane_supply_angata_2026-02-04.docx",
# output_dir="laravel_app/storage/app/angata/reports")
#
# Execution time: ~60-90 minutes total
#
#
# WORKFLOW B: Initial Setup (Large Backfill)
# ─────────────────────────────────────────────────────────────────────────
# Goal: Process multiple weeks of historical data
#
# Steps:
# 1. Python download (your entire date range)
# 2. Run R10 with large offset to process all historical dates:
# & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/10_create_per_field_tiffs.R angata 2026-02-04 365
# (This processes from 2025-02-04 to 2026-02-04, covering entire year)
# 3. Run R20 with large offset to process all historical dates:
# & "C:\Program Files\R\R-4.4.3\bin\x64\Rscript.exe" r_app/20_ci_extraction_per_field.R angata 2026-02-04 365
# (This processes from 2025-02-04 to 2026-02-04, covering entire year)
# 4. Run R30 once (growth model full season)
# 5. Run R21 once (CSV export)
# 6. Run R40 with specific week windows as needed
# 7. Run R80 for each week you want KPIs for
# 6. For each week, run:
# - R40 with different END_DATE values (one per week)
# - R80 with different WEEK/YEAR values (one per week)
# - R91 optional (one per week report)
#
# Pro tip: Script R40 with offset=14 covers two weeks at once
# Then R40 again with offset=7 for just one week
#
#
# WORKFLOW C: Troubleshooting (Check Intermediate Outputs)
# ─────────────────────────────────────────────────────────────────────────
# Goal: Verify outputs before moving to next step
#
# After R10: Check field_tiles/{FIELD_ID}/ has #dates files
# After R20: Check field_tiles_CI/{FIELD_ID}/ has same #dates files
# After R30: Check Data/extracted_ci/cumulative_vals/ has All_pivots_*.rds
# After R40: Check weekly_mosaic/{FIELD_ID}/ has week_WW_YYYY.tif per week
# After R80: Check output/ has {PROJECT}_field_analysis_week*.xlsx
#
# ============================================================================
# ==============================================================================
# TROUBLESHOOTING
# ==============================================================================
#
# ISSUE: R20 not processing all field_tiles files
# ────────────────────────────────────────────────
# Symptom: field_tiles has 496 files, field_tiles_CI only has 5
#
# Possible causes:
# 1. Source files incomplete or corrupted
# 2. Script 20 skips because CI TIFF already exists (even if incomplete)
# 3. Partial run from previous attempt
#
# Solutions:
# 1. Delete the small number of files in field_tiles_CI/{FIELD}/ (don't delete all!)
# rm laravel_app/storage/app/angata/field_tiles_CI/{fieldnum}/*
# 2. Re-run Script 20
# 3. If still fails, delete field_tiles_CI completely and re-run Script 20
# rm -r laravel_app/storage/app/angata/field_tiles_CI/
#
# ISSUE: Script 80 says "No per-field mosaic files found"
# ────────────────────────────────────────────────────────
# Symptom: R80 fails to calculate KPIs
#
# Possible causes:
# 1. Script 40 hasn't run yet (weekly_mosaic doesn't exist)
# 2. Wrong END_DATE or WEEK/YEAR combination
# 3. weekly_mosaic/{FIELD}/ directory missing (old format?)
#
# Solutions:
# 1. Ensure Script 40 has completed: Check weekly_mosaic/{FIELD}/ exists with week_WW_YYYY.tif
# 2. Verify END_DATE is within date range of available CI data
# 3. For current week: End date must be THIS week (same ISO week as today)
#
# ISSUE: Python download fails ("Not authorized")
# ────────────────────────────────────────────────
# Symptom: python 00_download_8band_pu_optimized.py fails with authentication error
#
# Cause: PLANET_API_KEY environment variable not set
#
# Solution:
# 1. Save your Planet API key: $env:PLANET_API_KEY = "your_key_here"
# 2. Verify: $env:PLANET_API_KEY (should show your key)
# 3. Try download again
#
# ISSUE: R30 takes too long
# ──────────────────────────
# Symptom: Script 30 running for >30 minutes
#
# Cause: LOESS interpolation is slow with many dates/fields
#
# Solution:
# 1. This is normal - large date ranges slow down interpolation
# 2. Subsequent runs are faster (cached results)
# 3. If needed: reduce offset or run fewer weeks at a time
#
# ==============================================================================
# ==============================================================================
# SUMMARY OF FILES CREATED BY EACH SCRIPT
# ==============================================================================
#
# Script 10 creates:
# laravel_app/storage/app/{PROJECT}/field_tiles/{FIELD}/{DATE}.tif
#
# Script 20 creates:
# laravel_app/storage/app/{PROJECT}/field_tiles_CI/{FIELD}/{DATE}.tif
# laravel_app/storage/app/{PROJECT}/Data/extracted_ci/daily_vals/{FIELD}/{DATE}.rds
#
# Script 30 creates:
# laravel_app/storage/app/{PROJECT}/Data/extracted_ci/cumulative_vals/All_pivots_Cumulative_CI_quadrant_year_v2.rds
#
# Script 21 creates:
# laravel_app/storage/app/{PROJECT}/ci_data_for_python.csv
#
# Python 31 creates:
# laravel_app/storage/app/{PROJECT}/reports/kpis/field_stats/{PROJECT}_harvest_imminent_week_{WW}_{YYYY}.csv
#
# Script 40 creates:
# laravel_app/storage/app/{PROJECT}/weekly_mosaic/{FIELD}/{DATE}/week_{WW}_{YYYY}.tif
#
# Script 80 creates:
# laravel_app/storage/app/{PROJECT}/output/{PROJECT}_field_analysis_week{WW}_{YYYY}.xlsx
# laravel_app/storage/app/{PROJECT}/output/{PROJECT}_field_analysis_week{WW}_{YYYY}.rds
#
# Script 90/91 creates:
# laravel_app/storage/app/{PROJECT}/output/SmartCane_Report_week{WW}_{YYYY}.docx
#
# ==============================================================================

BIN
r_app/translations/translations.xlsx
View file

Binary file not shown.