- Updated all CI maps to use tm_scale_continuous() for proper tmap v4 compatibility - Added fixed color scale limits (1-8 for CI, -3 to +3 for differences) for consistent field comparison - Fixed YAML header formatting issues in CI_report_dashboard_planet.Rmd - Positioned RGB map before CI overview map as requested - Removed all obsolete use_breaks parameter references - Enhanced error handling and logging throughout the pipeline - Added new experimental analysis scripts and improvements to mosaic creation
722 lines
25 KiB
Plaintext
722 lines
25 KiB
Plaintext
---
|
|
params:
|
|
ref: "word-styles-reference-var1.docx"
|
|
output_file: CI_report.docx
|
|
report_date: "2025-06-16"
|
|
data_dir: "simba"
|
|
mail_day: "Wednesday"
|
|
borders: TRUE
|
|
use_breaks: FALSE
|
|
output:
|
|
# html_document:
|
|
# toc: yes
|
|
# df_print: paged
|
|
word_document:
|
|
reference_docx: !expr file.path("word-styles-reference-var1.docx")
|
|
toc: yes
|
|
editor_options:
|
|
chunk_output_type: console
|
|
---
|
|
|
|
```{r setup_parameters, include=FALSE}
|
|
# Set up basic report parameters from input values
|
|
report_date <- params$report_date
|
|
mail_day <- params$mail_day
|
|
borders <- params$borders
|
|
use_breaks <- params$use_breaks # Whether to use breaks or continuous spectrum in visualizations
|
|
|
|
# Environment setup notes (commented out)
|
|
# # Activeer de renv omgeving
|
|
# renv::activate()
|
|
# renv::deactivate()
|
|
# # Optioneel: Herstel de omgeving als dat nodig is
|
|
# # Je kunt dit commentaar geven als je het normaal niet wilt uitvoeren
|
|
# renv::restore()
|
|
```
|
|
|
|
```{r load_libraries, message=FALSE, warning=FALSE, include=FALSE}
|
|
# Configure knitr options
|
|
knitr::opts_chunk$set(warning = FALSE, message = FALSE)
|
|
|
|
# Path management
|
|
library(here)
|
|
|
|
# Spatial data libraries
|
|
library(sf)
|
|
library(terra)
|
|
library(exactextractr)
|
|
# library(raster) - Removed as it's no longer maintained
|
|
|
|
# Data manipulation and visualization
|
|
library(tidyverse) # Includes dplyr, ggplot2, etc.
|
|
library(tmap)
|
|
library(lubridate)
|
|
library(zoo)
|
|
|
|
# Machine learning
|
|
library(rsample)
|
|
library(caret)
|
|
library(randomForest)
|
|
library(CAST)
|
|
|
|
# Load custom utility functions
|
|
# tryCatch({
|
|
# source("report_utils.R")
|
|
# }, error = function(e) {
|
|
# message(paste("Error loading report_utils.R:", e$message))
|
|
# # Try alternative path if the first one fails
|
|
# tryCatch({
|
|
source(here::here("r_app", "report_utils.R"))
|
|
# }, error = function(e) {
|
|
# stop("Could not load report_utils.R from either location: ", e$message)
|
|
# })
|
|
# })
|
|
|
|
# Load executive report utilities
|
|
# tryCatch({
|
|
# source("executive_report_utils.R")
|
|
# }, error = function(e) {
|
|
# message(paste("Error loading executive_report_utils.R:", e$message))
|
|
# # Try alternative path if the first one fails
|
|
# tryCatch({
|
|
source(here::here("r_app","exec_dashboard", "executive_report_utils.R"))
|
|
# }, error = function(e) {
|
|
# stop("Could not load executive_report_utils.R from either location: ", e$message)
|
|
# })
|
|
# })
|
|
|
|
safe_log("Successfully loaded utility functions")
|
|
```
|
|
|
|
```{r initialize_project_config, message=FALSE, warning=FALSE, include=FALSE}
|
|
# Set the project directory from parameters
|
|
project_dir <- params$data_dir
|
|
|
|
# Source project parameters with error handling
|
|
tryCatch({
|
|
source(here::here("r_app", "parameters_project.R"))
|
|
}, error = function(e) {
|
|
stop("Error loading parameters_project.R: ", e$message)
|
|
})
|
|
|
|
# Log initial configuration
|
|
safe_log("Starting the R Markdown script")
|
|
safe_log(paste("mail_day params:", params$mail_day))
|
|
safe_log(paste("report_date params:", params$report_date))
|
|
safe_log(paste("mail_day variable:", mail_day))
|
|
```
|
|
|
|
```{r calculate_dates_and_weeks, message=FALSE, warning=FALSE, include=FALSE}
|
|
# Set locale for consistent date formatting
|
|
Sys.setlocale("LC_TIME", "C")
|
|
|
|
# Initialize date variables from parameters
|
|
today <- as.character(report_date)
|
|
mail_day_as_character <- as.character(mail_day)
|
|
|
|
# Calculate week days
|
|
report_date_as_week_day <- weekdays(lubridate::ymd(today))
|
|
days_of_week <- c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
|
|
|
|
# Calculate initial week number
|
|
week <- lubridate::week(today)
|
|
safe_log(paste("Initial week calculation:", week, "today:", today))
|
|
|
|
# Calculate previous dates for comparisons
|
|
today_minus_1 <- as.character(lubridate::ymd(today) - 7)
|
|
today_minus_2 <- as.character(lubridate::ymd(today) - 14)
|
|
today_minus_3 <- as.character(lubridate::ymd(today) - 21)
|
|
|
|
# Log the weekday calculations for debugging
|
|
safe_log(paste("Report date weekday:", report_date_as_week_day))
|
|
safe_log(paste("Weekday index:", which(days_of_week == report_date_as_week_day)))
|
|
safe_log(paste("Mail day:", mail_day_as_character))
|
|
safe_log(paste("Mail day index:", which(days_of_week == mail_day_as_character)))
|
|
|
|
# Adjust week calculation based on mail day
|
|
if (which(days_of_week == report_date_as_week_day) > which(days_of_week == mail_day_as_character)) {
|
|
safe_log("Adjusting weeks because of mail day")
|
|
week <- lubridate::week(today) + 1
|
|
today_minus_1 <- as.character(lubridate::ymd(today))
|
|
today_minus_2 <- as.character(lubridate::ymd(today) - 7)
|
|
today_minus_3 <- as.character(lubridate::ymd(today) - 14)
|
|
}
|
|
|
|
# Generate subtitle for report
|
|
subtitle_var <- paste("Report generated on", Sys.Date())
|
|
|
|
# Calculate week numbers for previous weeks
|
|
week_minus_1 <- week - 1
|
|
week_minus_2 <- week - 2
|
|
week_minus_3 <- week - 3
|
|
|
|
# Format current week with leading zeros
|
|
week <- sprintf("%02d", week)
|
|
|
|
# Get years for each date
|
|
year <- lubridate::year(today)
|
|
year_1 <- lubridate::year(today_minus_1)
|
|
year_2 <- lubridate::year(today_minus_2)
|
|
year_3 <- lubridate::year(today_minus_3)
|
|
```
|
|
|
|
```{r data, message=TRUE, warning=TRUE, include=FALSE}
|
|
# Load CI index data with error handling
|
|
tryCatch({
|
|
CI_quadrant <- readRDS(here::here(cumulative_CI_vals_dir, "All_pivots_Cumulative_CI_quadrant_year_v2.rds"))
|
|
safe_log("Successfully loaded CI quadrant data")
|
|
}, error = function(e) {
|
|
stop("Error loading CI quadrant data: ", e$message)
|
|
})
|
|
|
|
# Get file paths for different weeks using the utility function
|
|
tryCatch({
|
|
path_to_week_current = get_week_path(weekly_CI_mosaic, today, 0)
|
|
path_to_week_minus_1 = get_week_path(weekly_CI_mosaic, today, -1)
|
|
path_to_week_minus_2 = get_week_path(weekly_CI_mosaic, today, -2)
|
|
path_to_week_minus_3 = get_week_path(weekly_CI_mosaic, today, -3)
|
|
|
|
# Log the calculated paths
|
|
safe_log("Required mosaic paths:")
|
|
safe_log(paste("Path to current week:", path_to_week_current))
|
|
safe_log(paste("Path to week minus 1:", path_to_week_minus_1))
|
|
safe_log(paste("Path to week minus 2:", path_to_week_minus_2))
|
|
safe_log(paste("Path to week minus 3:", path_to_week_minus_3))
|
|
|
|
# Validate that files exist
|
|
if (!file.exists(path_to_week_current)) warning("Current week mosaic file does not exist: ", path_to_week_current)
|
|
if (!file.exists(path_to_week_minus_1)) warning("Week minus 1 mosaic file does not exist: ", path_to_week_minus_1)
|
|
if (!file.exists(path_to_week_minus_2)) warning("Week minus 2 mosaic file does not exist: ", path_to_week_minus_2)
|
|
if (!file.exists(path_to_week_minus_3)) warning("Week minus 3 mosaic file does not exist: ", path_to_week_minus_3)
|
|
|
|
# Load raster data with terra functions
|
|
CI <- terra::rast(path_to_week_current)$CI
|
|
CI_m1 <- terra::rast(path_to_week_minus_1)$CI
|
|
CI_m2 <- terra::rast(path_to_week_minus_2)$CI
|
|
CI_m3 <- terra::rast(path_to_week_minus_3)$CI
|
|
|
|
}, error = function(e) {
|
|
stop("Error loading raster data: ", e$message)
|
|
})
|
|
```
|
|
|
|
```{r calculate_difference_rasters, message=TRUE, warning=TRUE, include=FALSE}
|
|
# Calculate difference rasters for comparisons
|
|
tryCatch({
|
|
# Calculate weekly difference
|
|
last_week_dif_raster_abs <- (CI - CI_m1)
|
|
safe_log("Calculated weekly difference raster")
|
|
|
|
# Calculate three-week difference
|
|
three_week_dif_raster_abs <- (CI - CI_m3)
|
|
safe_log("Calculated three-week difference raster")
|
|
}, error = function(e) {
|
|
safe_log(paste("Error calculating difference rasters:", e$message), "ERROR")
|
|
# Create placeholder rasters if calculations fail
|
|
if (!exists("last_week_dif_raster_abs")) {
|
|
last_week_dif_raster_abs <- CI * 0
|
|
}
|
|
if (!exists("three_week_dif_raster_abs")) {
|
|
three_week_dif_raster_abs <- CI * 0
|
|
}
|
|
})
|
|
```
|
|
|
|
```{r load_field_boundaries, message=TRUE, warning=TRUE, include=FALSE}
|
|
# Load field boundaries from parameters
|
|
tryCatch({
|
|
AllPivots0 <- field_boundaries_sf
|
|
safe_log("Successfully loaded field boundaries")
|
|
}, error = function(e) {
|
|
stop("Error loading field boundaries: ", e$message)
|
|
})
|
|
```
|
|
|
|
```{r create_farm_health_data, message=FALSE, warning=FALSE, include=FALSE}
|
|
# Create farm health summary data from scratch
|
|
tryCatch({
|
|
# Ensure we have the required data
|
|
if (!exists("AllPivots0") || !exists("CI") || !exists("CI_m1") || !exists("harvesting_data")) {
|
|
stop("Required input data (field boundaries, CI data, or harvesting data) not available")
|
|
}
|
|
|
|
safe_log("Starting to calculate farm health data")
|
|
|
|
# Get unique field names
|
|
fields <- unique(AllPivots0$field)
|
|
safe_log(paste("Found", length(fields), "unique fields"))
|
|
|
|
# Initialize result dataframe
|
|
farm_health_data <- data.frame(
|
|
field = character(),
|
|
mean_ci = numeric(),
|
|
ci_change = numeric(),
|
|
ci_uniformity = numeric(),
|
|
status = character(),
|
|
anomaly_type = character(),
|
|
priority_level = numeric(),
|
|
age_weeks = numeric(),
|
|
harvest_readiness = character(),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
|
|
# Process each field with robust error handling
|
|
for (field_name in fields) {
|
|
tryCatch({
|
|
safe_log(paste("Processing field:", field_name))
|
|
|
|
# Get field boundary
|
|
field_shape <- AllPivots0 %>% dplyr::filter(field == field_name)
|
|
|
|
# Skip if field shape is empty
|
|
if (nrow(field_shape) == 0) {
|
|
safe_log(paste("Empty field shape for", field_name), "WARNING")
|
|
next
|
|
}
|
|
|
|
# Get field age from harvesting data - use direct filtering to avoid dplyr errors
|
|
field_age_data <- NULL
|
|
if (exists("harvesting_data") && !is.null(harvesting_data) && nrow(harvesting_data) > 0) {
|
|
field_age_data <- harvesting_data[harvesting_data$field == field_name, ]
|
|
if (nrow(field_age_data) > 0) {
|
|
field_age_data <- field_age_data[order(field_age_data$season_start, decreasing = TRUE), ][1, ]
|
|
}
|
|
}
|
|
|
|
# Default age if not available
|
|
field_age_weeks <- if (!is.null(field_age_data) && nrow(field_age_data) > 0 && !is.na(field_age_data$age)) {
|
|
field_age_data$age
|
|
} else {
|
|
10 # Default age
|
|
}
|
|
|
|
# Extract CI values using terra's extract function which is more robust
|
|
ci_values <- terra::extract(CI, field_shape)
|
|
ci_prev_values <- terra::extract(CI_m1, field_shape)
|
|
|
|
# Check if we got valid data
|
|
if (nrow(ci_values) == 0 || nrow(ci_prev_values) == 0) {
|
|
safe_log(paste("No CI data extracted for field", field_name), "WARNING")
|
|
# Add a placeholder row with Unknown status
|
|
farm_health_data <- rbind(farm_health_data, data.frame(
|
|
field = field_name,
|
|
mean_ci = NA,
|
|
ci_change = NA,
|
|
ci_uniformity = NA,
|
|
status = "Unknown",
|
|
anomaly_type = "Unknown",
|
|
priority_level = 5, # Low priority
|
|
age_weeks = field_age_weeks,
|
|
harvest_readiness = "Unknown",
|
|
stringsAsFactors = FALSE
|
|
))
|
|
next
|
|
}
|
|
|
|
# Calculate metrics - Handle NA values properly
|
|
ci_column <- if ("CI" %in% names(ci_values)) "CI" else colnames(ci_values)[1]
|
|
ci_prev_column <- if ("CI" %in% names(ci_prev_values)) "CI" else colnames(ci_prev_values)[1]
|
|
|
|
mean_ci <- mean(ci_values[[ci_column]], na.rm=TRUE)
|
|
mean_ci_prev <- mean(ci_prev_values[[ci_prev_column]], na.rm=TRUE)
|
|
ci_change <- mean_ci - mean_ci_prev
|
|
ci_sd <- sd(ci_values[[ci_column]], na.rm=TRUE)
|
|
ci_uniformity <- ci_sd / max(0.1, mean_ci) # Avoid division by zero
|
|
|
|
# Handle NaN or Inf results
|
|
if (is.na(mean_ci) || is.na(ci_change) || is.na(ci_uniformity) ||
|
|
is.nan(mean_ci) || is.nan(ci_change) || is.nan(ci_uniformity) ||
|
|
is.infinite(mean_ci) || is.infinite(ci_change) || is.infinite(ci_uniformity)) {
|
|
safe_log(paste("Invalid calculation results for field", field_name), "WARNING")
|
|
# Add a placeholder row with Unknown status
|
|
farm_health_data <- rbind(farm_health_data, data.frame(
|
|
field = field_name,
|
|
mean_ci = NA,
|
|
ci_change = NA,
|
|
ci_uniformity = NA,
|
|
status = "Unknown",
|
|
anomaly_type = "Unknown",
|
|
priority_level = 5, # Low priority
|
|
age_weeks = field_age_weeks,
|
|
harvest_readiness = "Unknown",
|
|
stringsAsFactors = FALSE
|
|
))
|
|
next
|
|
}
|
|
|
|
# Determine field status
|
|
status <- dplyr::case_when(
|
|
mean_ci >= 5 ~ "Excellent",
|
|
mean_ci >= 3.5 ~ "Good",
|
|
mean_ci >= 2 ~ "Fair",
|
|
mean_ci >= 1 ~ "Poor",
|
|
TRUE ~ "Critical"
|
|
)
|
|
|
|
# Determine anomaly type
|
|
anomaly_type <- dplyr::case_when(
|
|
ci_change > 2 ~ "Potential Weed Growth",
|
|
ci_change < -2 ~ "Potential Weeding/Harvesting",
|
|
ci_uniformity > 0.5 ~ "High Variability",
|
|
mean_ci < 1 ~ "Low Vigor",
|
|
TRUE ~ "None"
|
|
)
|
|
|
|
# Calculate priority level (1-5, with 1 being highest priority)
|
|
priority_score <- dplyr::case_when(
|
|
mean_ci < 1 ~ 1, # Critical - highest priority
|
|
anomaly_type == "Potential Weed Growth" ~ 2,
|
|
anomaly_type == "High Variability" ~ 3,
|
|
ci_change < -1 ~ 4,
|
|
TRUE ~ 5 # No urgent issues
|
|
)
|
|
|
|
# Determine harvest readiness
|
|
harvest_readiness <- dplyr::case_when(
|
|
field_age_weeks >= 52 & mean_ci >= 4 ~ "Ready for harvest",
|
|
field_age_weeks >= 48 & mean_ci >= 3.5 ~ "Approaching harvest",
|
|
field_age_weeks >= 40 & mean_ci >= 3 ~ "Mid-maturity",
|
|
field_age_weeks >= 12 ~ "Growing",
|
|
TRUE ~ "Early stage"
|
|
)
|
|
|
|
# Add to summary data
|
|
farm_health_data <- rbind(farm_health_data, data.frame(
|
|
field = field_name,
|
|
mean_ci = round(mean_ci, 2),
|
|
ci_change = round(ci_change, 2),
|
|
ci_uniformity = round(ci_uniformity, 2),
|
|
status = status,
|
|
anomaly_type = anomaly_type,
|
|
priority_level = priority_score,
|
|
age_weeks = field_age_weeks,
|
|
harvest_readiness = harvest_readiness,
|
|
stringsAsFactors = FALSE
|
|
))
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error processing field", field_name, ":", e$message), "ERROR")
|
|
# Add a placeholder row with Error status
|
|
farm_health_data <<- rbind(farm_health_data, data.frame(
|
|
field = field_name,
|
|
mean_ci = NA,
|
|
ci_change = NA,
|
|
ci_uniformity = NA,
|
|
status = "Unknown",
|
|
anomaly_type = "Unknown",
|
|
priority_level = 5, # Low priority since we don't know the status
|
|
age_weeks = NA,
|
|
harvest_readiness = "Unknown",
|
|
stringsAsFactors = FALSE
|
|
))
|
|
})
|
|
}
|
|
|
|
# Make sure we have data for all fields
|
|
if (nrow(farm_health_data) == 0) {
|
|
safe_log("No farm health data was created", "ERROR")
|
|
stop("Failed to create farm health data")
|
|
}
|
|
|
|
# Sort by priority level
|
|
farm_health_data <- farm_health_data %>% dplyr::arrange(priority_level, field)
|
|
|
|
safe_log(paste("Successfully created farm health data for", nrow(farm_health_data), "fields"))
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error creating farm health data:", e$message), "ERROR")
|
|
# Create an empty dataframe that can be filled by the verification chunk
|
|
})
|
|
```
|
|
|
|
```{r verify_farm_health_data, message=FALSE, warning=FALSE, include=FALSE}
|
|
# Verify farm_health_data exists and has content
|
|
if (!exists("farm_health_data") || nrow(farm_health_data) == 0) {
|
|
safe_log("farm_health_data not found or empty, generating default data", "WARNING")
|
|
|
|
# Create minimal fallback data
|
|
tryCatch({
|
|
# Get fields from boundaries
|
|
fields <- unique(AllPivots0$field)
|
|
|
|
# Create basic data frame with just field names
|
|
farm_health_data <- data.frame(
|
|
field = fields,
|
|
mean_ci = rep(NA, length(fields)),
|
|
ci_change = rep(NA, length(fields)),
|
|
ci_uniformity = rep(NA, length(fields)),
|
|
status = rep("Unknown", length(fields)),
|
|
anomaly_type = rep("Unknown", length(fields)),
|
|
priority_level = rep(5, length(fields)), # Low priority
|
|
age_weeks = rep(NA, length(fields)),
|
|
harvest_readiness = rep("Unknown", length(fields)),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
|
|
safe_log("Created fallback farm_health_data with basic field information")
|
|
}, error = function(e) {
|
|
safe_log(paste("Error creating fallback farm_health_data:", e$message), "ERROR")
|
|
farm_health_data <<- data.frame(
|
|
field = character(),
|
|
mean_ci = numeric(),
|
|
ci_change = numeric(),
|
|
ci_uniformity = numeric(),
|
|
status = character(),
|
|
anomaly_type = character(),
|
|
priority_level = numeric(),
|
|
age_weeks = numeric(),
|
|
harvest_readiness = character(),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
})
|
|
}
|
|
```
|
|
|
|
```{r calculate_farm_health, message=FALSE, warning=FALSE, include=FALSE}
|
|
# Calculate farm health summary metrics
|
|
tryCatch({
|
|
# Generate farm health summary data
|
|
farm_health_data <- generate_farm_health_summary(
|
|
field_boundaries = AllPivots0,
|
|
ci_current = CI,
|
|
ci_previous = CI_m1,
|
|
harvesting_data = harvesting_data
|
|
)
|
|
|
|
# Log the summary data
|
|
safe_log(paste("Generated farm health summary with", nrow(farm_health_data), "fields"))
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error in farm health calculation:", e$message), "ERROR")
|
|
# Create empty dataframe if calculation failed
|
|
farm_health_data <- data.frame(
|
|
field = character(),
|
|
mean_ci = numeric(),
|
|
ci_change = numeric(),
|
|
ci_uniformity = numeric(),
|
|
status = character(),
|
|
anomaly_type = character(),
|
|
priority_level = numeric(),
|
|
age_weeks = numeric(),
|
|
harvest_readiness = character(),
|
|
stringsAsFactors = FALSE
|
|
)
|
|
})
|
|
```
|
|
|
|
```{r advanced_analytics_functions, message=FALSE, warning=FALSE, include=FALSE}
|
|
# ADVANCED ANALYTICS FUNCTIONS
|
|
# Note: These functions are now imported from executive_report_utils.R
|
|
# The utility file contains functions for velocity/acceleration indicators,
|
|
# anomaly timeline creation, age cohort mapping, and cohort performance charts
|
|
safe_log("Using analytics functions from executive_report_utils.R")
|
|
```
|
|
|
|
\pagebreak
|
|
# Advanced Analytics
|
|
|
|
## Field Health Velocity and Acceleration
|
|
|
|
This visualization shows the rate of change in field health (velocity) and whether that change is speeding up or slowing down (acceleration). These metrics help identify if farm conditions are improving, stable, or deteriorating.
|
|
|
|
**How to interpret:**
|
|
- **Velocity gauge:** Shows the average weekly change in CI values across all fields
|
|
- Positive values (green/right side): Farm health improving week-to-week
|
|
- Negative values (red/left side): Farm health declining week-to-week
|
|
|
|
- **Acceleration gauge:** Shows whether the rate of change is increasing or decreasing
|
|
- Positive values (green/right side): Change is accelerating or improving faster
|
|
- Negative values (red/left side): Change is decelerating or slowing down
|
|
|
|
- **4-Week Trend:** Shows the overall CI value trajectory for the past month
|
|
|
|
```{r render_velocity_acceleration, echo=FALSE, fig.height=8, fig.width=10, message=FALSE, warning=FALSE}
|
|
# Render the velocity and acceleration indicators
|
|
tryCatch({
|
|
# Create and display the indicators using the imported utility function
|
|
velocity_plot <- create_velocity_acceleration_indicator(
|
|
health_data = farm_health_data,
|
|
ci_current = CI,
|
|
ci_prev1 = CI_m1,
|
|
ci_prev2 = CI_m2,
|
|
ci_prev3 = CI_m3,
|
|
field_boundaries = AllPivots0
|
|
)
|
|
|
|
# Print the visualization
|
|
print(velocity_plot)
|
|
|
|
# Create a table of fields with significant velocity changes
|
|
field_ci_metrics <- list()
|
|
|
|
# Process each field to get metrics
|
|
fields <- unique(AllPivots0$field)
|
|
for (field_name in fields) {
|
|
tryCatch({
|
|
# Get field boundary
|
|
field_shape <- AllPivots0 %>% dplyr::filter(field == field_name)
|
|
if (nrow(field_shape) == 0) next
|
|
|
|
# Extract CI values
|
|
ci_curr_values <- terra::extract(CI, field_shape)
|
|
ci_prev1_values <- terra::extract(CI_m1, field_shape)
|
|
|
|
# Calculate metrics
|
|
mean_ci_curr <- mean(ci_curr_values$CI, na.rm = TRUE)
|
|
mean_ci_prev1 <- mean(ci_prev1_values$CI, na.rm = TRUE)
|
|
velocity <- mean_ci_curr - mean_ci_prev1
|
|
|
|
# Store in list
|
|
field_ci_metrics[[field_name]] <- list(
|
|
field = field_name,
|
|
ci_current = mean_ci_curr,
|
|
ci_prev1 = mean_ci_prev1,
|
|
velocity = velocity
|
|
)
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error processing field", field_name, "for velocity table:", e$message), "WARNING")
|
|
})
|
|
}
|
|
|
|
# Convert list to data frame
|
|
velocity_df <- do.call(rbind, lapply(field_ci_metrics, function(x) {
|
|
data.frame(
|
|
field = x$field,
|
|
ci_current = round(x$ci_current, 2),
|
|
ci_prev1 = round(x$ci_prev1, 2),
|
|
velocity = round(x$velocity, 2),
|
|
direction = ifelse(x$velocity >= 0, "Improving", "Declining")
|
|
)
|
|
}))
|
|
|
|
# Select top 5 positive and top 5 negative velocity fields
|
|
top_positive <- velocity_df %>%
|
|
dplyr::filter(velocity > 0) %>%
|
|
dplyr::arrange(desc(velocity)) %>%
|
|
dplyr::slice_head(n = 5)
|
|
|
|
top_negative <- velocity_df %>%
|
|
dplyr::filter(velocity < 0) %>%
|
|
dplyr::arrange(velocity) %>%
|
|
dplyr::slice_head(n = 5)
|
|
|
|
# Display the tables if we have data
|
|
if (nrow(top_positive) > 0) {
|
|
cat("<h4>Fields with Fastest Improvement</h4>")
|
|
knitr::kable(top_positive %>%
|
|
dplyr::select(Field = field,
|
|
`Current CI` = ci_current,
|
|
`Previous CI` = ci_prev1,
|
|
`Weekly Change` = velocity))
|
|
}
|
|
|
|
if (nrow(top_negative) > 0) {
|
|
cat("<h4>Fields with Fastest Decline</h4>")
|
|
knitr::kable(top_negative %>%
|
|
dplyr::select(Field = field,
|
|
`Current CI` = ci_current,
|
|
`Previous CI` = ci_prev1,
|
|
`Weekly Change` = velocity))
|
|
}
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error rendering velocity visualization:", e$message), "ERROR")
|
|
cat("<div class='alert alert-danger'>Error generating velocity visualization.</div>")
|
|
})
|
|
```
|
|
|
|
\pagebreak
|
|
## Field Anomaly Timeline
|
|
|
|
This visualization shows the history of detected anomalies in fields across the monitoring period. It helps identify persistent issues or improvements over time.
|
|
|
|
**How to interpret:**
|
|
- **X-axis**: Dates of satellite observations
|
|
- **Y-axis**: Fields grouped by similar characteristics
|
|
- **Colors**: Red indicates negative anomalies, green indicates positive anomalies
|
|
- **Size**: Larger markers indicate stronger anomalies
|
|
|
|
```{r anomaly_timeline, echo=FALSE, fig.height=8, fig.width=10, message=FALSE, warning=FALSE}
|
|
# Generate anomaly timeline visualization
|
|
tryCatch({
|
|
# Use the imported function to create the anomaly timeline
|
|
anomaly_timeline <- create_anomaly_timeline(
|
|
field_boundaries = AllPivots0,
|
|
ci_data = CI_quadrant,
|
|
days_to_include = 90 # Show last 90 days of data
|
|
)
|
|
|
|
# Display the timeline
|
|
print(anomaly_timeline)
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error generating anomaly timeline:", e$message), "ERROR")
|
|
cat("<div class='alert alert-danger'>Error generating anomaly timeline visualization.</div>")
|
|
})
|
|
```
|
|
|
|
\pagebreak
|
|
## Field Age Cohorts Map
|
|
|
|
This map shows fields grouped by their crop age (weeks since planting). Understanding the distribution of crop ages helps interpret performance metrics and plan harvest scheduling.
|
|
|
|
**How to interpret:**
|
|
- **Colors**: Different colors represent different age groups (in weeks since planting)
|
|
- **Labels**: Each field is labeled with its name for easy reference
|
|
- **Legend**: Shows the age ranges in weeks and their corresponding colors
|
|
|
|
```{r age_cohort_map, echo=FALSE, fig.height=8, fig.width=10, message=FALSE, warning=FALSE}
|
|
# Generate age cohort map
|
|
tryCatch({
|
|
# Use the imported function to create the age cohort map
|
|
age_cohort_map <- create_age_cohort_map(
|
|
field_boundaries = AllPivots0,
|
|
harvesting_data = harvesting_data
|
|
)
|
|
|
|
# Display the map
|
|
print(age_cohort_map)
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error generating age cohort map:", e$message), "ERROR")
|
|
cat("<div class='alert alert-danger'>Error generating age cohort map visualization.</div>")
|
|
})
|
|
```
|
|
|
|
\pagebreak
|
|
## Cohort Performance Comparison
|
|
|
|
This visualization compares chlorophyll index (CI) performance across different age groups of fields. This helps identify if certain age groups are performing better or worse than expected.
|
|
|
|
**How to interpret:**
|
|
- **X-axis**: Field age groups in weeks since planting
|
|
- **Y-axis**: Average CI value for fields in that age group
|
|
- **Box plots**: Show the distribution of CI values within each age group
|
|
- **Line**: Shows the expected CI trajectory based on historical data
|
|
|
|
```{r cohort_performance_chart, echo=FALSE, fig.height=8, fig.width=10, message=FALSE, warning=FALSE}
|
|
# Generate cohort performance comparison chart
|
|
tryCatch({
|
|
# Use the imported function to create the cohort performance chart
|
|
cohort_chart <- create_cohort_performance_chart(
|
|
field_boundaries = AllPivots0,
|
|
ci_current = CI,
|
|
harvesting_data = harvesting_data
|
|
)
|
|
|
|
# Display the chart
|
|
print(cohort_chart)
|
|
|
|
}, error = function(e) {
|
|
safe_log(paste("Error generating cohort performance chart:", e$message), "ERROR")
|
|
cat("<div class='alert alert-danger'>Error generating cohort performance visualization.</div>")
|
|
})
|
|
```
|
|
|
|
|
|
|
|
|
|
|
|
|