Timon
6efcc8cfec
- 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
437 lines
17 KiB
R
437 lines
17 KiB
R
# EXECUTIVE REPORT UTILITIES
|
|
# This file contains functions for creating advanced visualizations for the executive summary report
|
|
|
|
#' Create a velocity and acceleration indicator for CI change
|
|
#'
|
|
#' @param health_data Current farm health data
|
|
#' @param ci_current Current CI raster
|
|
#' @param ci_prev1 CI raster from 1 week ago
|
|
#' @param ci_prev2 CI raster from 2 weeks ago
|
|
#' @param ci_prev3 CI raster from 3 weeks ago
|
|
#' @param field_boundaries Field boundaries spatial data (sf object)
|
|
#' @return A ggplot2 object with velocity and acceleration gauges
|
|
#'
|
|
create_velocity_acceleration_indicator <- function(health_data, ci_current, ci_prev1, ci_prev2, ci_prev3, field_boundaries) {
|
|
tryCatch({
|
|
# Calculate farm-wide metrics for multiple weeks
|
|
mean_ci_current <- mean(health_data$mean_ci, na.rm = TRUE)
|
|
|
|
# Calculate previous week metrics
|
|
# Extract CI values for previous weeks
|
|
field_ci_metrics <- data.frame(field = character(),
|
|
week_current = numeric(),
|
|
week_minus_1 = numeric(),
|
|
week_minus_2 = numeric(),
|
|
week_minus_3 = numeric(),
|
|
stringsAsFactors = FALSE)
|
|
|
|
# Process each field
|
|
fields <- unique(field_boundaries$field)
|
|
for (field_name in fields) {
|
|
tryCatch({
|
|
# Get field boundary
|
|
field_shape <- field_boundaries %>% dplyr::filter(field == field_name)
|
|
if (nrow(field_shape) == 0) next
|
|
|
|
# Extract CI values for all weeks
|
|
ci_curr_values <- terra::extract(ci_current, field_shape)
|
|
ci_prev1_values <- terra::extract(ci_prev1, field_shape)
|
|
ci_prev2_values <- terra::extract(ci_prev2, field_shape)
|
|
ci_prev3_values <- terra::extract(ci_prev3, field_shape)
|
|
|
|
# Calculate mean CI for each week
|
|
mean_ci_curr <- mean(ci_curr_values$CI, na.rm = TRUE)
|
|
mean_ci_prev1 <- mean(ci_prev1_values$CI, na.rm = TRUE)
|
|
mean_ci_prev2 <- mean(ci_prev2_values$CI, na.rm = TRUE)
|
|
mean_ci_prev3 <- mean(ci_prev3_values$CI, na.rm = TRUE)
|
|
|
|
# Add to metrics table
|
|
field_ci_metrics <- rbind(field_ci_metrics, data.frame(
|
|
field = field_name,
|
|
week_current = mean_ci_curr,
|
|
week_minus_1 = mean_ci_prev1,
|
|
week_minus_2 = mean_ci_prev2,
|
|
week_minus_3 = mean_ci_prev3,
|
|
stringsAsFactors = FALSE
|
|
))
|
|
}, error = function(e) {
|
|
message(paste("Error processing field", field_name, "for velocity indicator:", e$message))
|
|
})
|
|
}
|
|
|
|
# Calculate farm-wide averages
|
|
farm_avg <- colMeans(field_ci_metrics[, c("week_current", "week_minus_1", "week_minus_2", "week_minus_3")], na.rm = TRUE)
|
|
|
|
# Calculate velocity (rate of change) - current week compared to last week
|
|
velocity <- farm_avg["week_current"] - farm_avg["week_minus_1"]
|
|
|
|
# Calculate previous velocity (last week compared to two weeks ago)
|
|
prev_velocity <- farm_avg["week_minus_1"] - farm_avg["week_minus_2"]
|
|
|
|
# Calculate acceleration (change in velocity)
|
|
acceleration <- velocity - prev_velocity
|
|
|
|
# Prepare data for velocity gauge
|
|
velocity_data <- data.frame(
|
|
label = "Weekly CI Change",
|
|
value = velocity
|
|
)
|
|
|
|
# Prepare data for acceleration gauge
|
|
acceleration_data <- data.frame(
|
|
label = "Change Acceleration",
|
|
value = acceleration
|
|
)
|
|
|
|
# Create velocity trend data
|
|
trend_data <- data.frame(
|
|
week = c(-3, -2, -1, 0),
|
|
ci_value = c(farm_avg["week_minus_3"], farm_avg["week_minus_2"],
|
|
farm_avg["week_minus_1"], farm_avg["week_current"])
|
|
)
|
|
|
|
# Create layout grid for the visualizations
|
|
layout_matrix <- matrix(c(1, 1, 2, 2, 3, 3), nrow = 2, byrow = TRUE)
|
|
|
|
# Create velocity gauge
|
|
velocity_gauge <- ggplot2::ggplot(velocity_data, ggplot2::aes(x = 0, y = 0)) +
|
|
ggplot2::geom_arc_bar(ggplot2::aes(
|
|
x0 = 0, y0 = 0,
|
|
r0 = 0.5, r = 1,
|
|
start = -pi/2, end = pi/2,
|
|
fill = "background"
|
|
), fill = "#f0f0f0") +
|
|
ggplot2::geom_arc_bar(ggplot2::aes(
|
|
x0 = 0, y0 = 0,
|
|
r0 = 0.5, r = 1,
|
|
start = -pi/2,
|
|
end = -pi/2 + (pi * (0.5 + (velocity / 2))), # Scale to range -1 to +1
|
|
fill = "velocity"
|
|
), fill = ifelse(velocity >= 0, "#1a9850", "#d73027")) +
|
|
ggplot2::geom_text(ggplot2::aes(label = sprintf("%.2f", velocity)),
|
|
size = 8, fontface = "bold") +
|
|
ggplot2::geom_text(ggplot2::aes(label = "Velocity"), y = -0.3, size = 4) +
|
|
ggplot2::coord_fixed() +
|
|
ggplot2::theme_void() +
|
|
ggplot2::scale_fill_manual(values = c("background" = "#f0f0f0", "velocity" = "steelblue"),
|
|
guide = "none") +
|
|
ggplot2::annotate("text", x = -0.85, y = 0, label = "Declining",
|
|
angle = 90, size = 3.5) +
|
|
ggplot2::annotate("text", x = 0.85, y = 0, label = "Improving",
|
|
angle = -90, size = 3.5) +
|
|
ggplot2::labs(title = "Farm Health Velocity",
|
|
subtitle = "CI change per week") +
|
|
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 14, face = "bold"),
|
|
plot.subtitle = ggplot2::element_text(hjust = 0.5, size = 12))
|
|
|
|
# Create acceleration gauge
|
|
acceleration_gauge <- ggplot2::ggplot(acceleration_data, ggplot2::aes(x = 0, y = 0)) +
|
|
ggplot2::geom_arc_bar(ggplot2::aes(
|
|
x0 = 0, y0 = 0,
|
|
r0 = 0.5, r = 1,
|
|
start = -pi/2, end = pi/2,
|
|
fill = "background"
|
|
), fill = "#f0f0f0") +
|
|
ggplot2::geom_arc_bar(ggplot2::aes(
|
|
x0 = 0, y0 = 0,
|
|
r0 = 0.5, r = 1,
|
|
start = -pi/2,
|
|
end = -pi/2 + (pi * (0.5 + (acceleration / 1))), # Scale to range -0.5 to +0.5
|
|
fill = "acceleration"
|
|
), fill = ifelse(acceleration >= 0, "#1a9850", "#d73027")) +
|
|
ggplot2::geom_text(ggplot2::aes(label = sprintf("%.2f", acceleration)),
|
|
size = 8, fontface = "bold") +
|
|
ggplot2::geom_text(ggplot2::aes(label = "Acceleration"), y = -0.3, size = 4) +
|
|
ggplot2::coord_fixed() +
|
|
ggplot2::theme_void() +
|
|
ggplot2::scale_fill_manual(values = c("background" = "#f0f0f0", "acceleration" = "steelblue"),
|
|
guide = "none") +
|
|
ggplot2::annotate("text", x = -0.85, y = 0, label = "Slowing",
|
|
angle = 90, size = 3.5) +
|
|
ggplot2::annotate("text", x = 0.85, y = 0, label = "Accelerating",
|
|
angle = -90, size = 3.5) +
|
|
ggplot2::labs(title = "Change Acceleration",
|
|
subtitle = "Increasing or decreasing trend") +
|
|
ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5, size = 14, face = "bold"),
|
|
plot.subtitle = ggplot2::element_text(hjust = 0.5, size = 12))
|
|
|
|
# Create trend chart
|
|
trend_chart <- ggplot2::ggplot(trend_data, ggplot2::aes(x = week, y = ci_value)) +
|
|
ggplot2::geom_line(size = 1.5, color = "steelblue") +
|
|
ggplot2::geom_point(size = 3, color = "steelblue") +
|
|
ggplot2::geom_hline(yintercept = trend_data$ci_value[1], linetype = "dashed", color = "gray50") +
|
|
ggplot2::labs(
|
|
title = "4-Week CI Trend",
|
|
x = "Weeks from current",
|
|
y = "Average CI Value"
|
|
) +
|
|
ggplot2::theme_minimal() +
|
|
ggplot2::scale_x_continuous(breaks = c(-3, -2, -1, 0))
|
|
|
|
# Create table of top velocity changes
|
|
field_ci_metrics$velocity <- field_ci_metrics$week_current - field_ci_metrics$week_minus_1
|
|
top_velocity_fields <- field_ci_metrics %>%
|
|
dplyr::arrange(desc(abs(velocity))) %>%
|
|
dplyr::slice_head(n = 5) %>%
|
|
dplyr::select(field, velocity) %>%
|
|
dplyr::mutate(direction = ifelse(velocity >= 0, "Improving", "Declining"))
|
|
|
|
# Combine into multi-panel figure
|
|
main_plot <- gridExtra::grid.arrange(
|
|
gridExtra::grid.arrange(velocity_gauge, acceleration_gauge, ncol = 2),
|
|
trend_chart,
|
|
heights = c(1.5, 1),
|
|
nrow = 2
|
|
)
|
|
|
|
return(main_plot)
|
|
|
|
}, error = function(e) {
|
|
message(paste("Error in create_velocity_acceleration_indicator:", e$message))
|
|
return(ggplot2::ggplot() +
|
|
ggplot2::annotate("text", x = 0, y = 0, label = paste("Error creating velocity indicator:", e$message)) +
|
|
ggplot2::theme_void())
|
|
})
|
|
}
|
|
|
|
#' Generate a field health score based on CI values and trends
|
|
#'
|
|
#' @param ci_current Current CI raster
|
|
#' @param ci_change CI change raster
|
|
#' @param field_age_weeks Field age in weeks
|
|
#' @return List containing score, status, and component scores
|
|
#'
|
|
generate_field_health_score <- function(ci_current, ci_change, field_age_weeks) {
|
|
# Get mean CI value for the field
|
|
mean_ci <- terra::global(ci_current, "mean", na.rm=TRUE)[[1]]
|
|
|
|
# Get mean CI change
|
|
mean_change <- terra::global(ci_change, "mean", na.rm=TRUE)[[1]]
|
|
|
|
# Get CI uniformity (coefficient of variation)
|
|
ci_sd <- terra::global(ci_current, "sd", na.rm=TRUE)[[1]]
|
|
ci_uniformity <- ifelse(mean_ci > 0, ci_sd / mean_ci, 1)
|
|
|
|
# Calculate base score from current CI (scale 0-5)
|
|
# Adjusted for crop age - expectations increase with age
|
|
expected_ci <- min(5, field_age_weeks / 10) # Simple linear model
|
|
ci_score <- max(0, min(5, 5 - 2 * abs(mean_ci - expected_ci)))
|
|
|
|
# Add points for positive change (scale 0-3)
|
|
change_score <- max(0, min(3, 1 + mean_change))
|
|
|
|
# Add points for uniformity (scale 0-2)
|
|
uniformity_score <- max(0, min(2, 2 * (1 - ci_uniformity)))
|
|
|
|
# Calculate total score (0-10)
|
|
total_score <- ci_score + change_score + uniformity_score
|
|
|
|
# Create status label
|
|
status <- dplyr::case_when(
|
|
total_score >= 8 ~ "Excellent",
|
|
total_score >= 6 ~ "Good",
|
|
total_score >= 4 ~ "Fair",
|
|
total_score >= 2 ~ "Needs Attention",
|
|
TRUE ~ "Critical"
|
|
)
|
|
|
|
# Return results
|
|
return(list(
|
|
score = round(total_score, 1),
|
|
status = status,
|
|
components = list(
|
|
ci = round(ci_score, 1),
|
|
change = round(change_score, 1),
|
|
uniformity = round(uniformity_score, 1)
|
|
)
|
|
))
|
|
}
|
|
|
|
#' Create an irrigation recommendation map
|
|
#'
|
|
#' @param ci_current Current CI raster
|
|
#' @param ci_change CI change raster
|
|
#' @param field_shape Field boundary shape
|
|
#' @param title Map title
|
|
#' @return A tmap object with irrigation recommendations
|
|
#'
|
|
create_irrigation_map <- function(ci_current, ci_change, field_shape, title = "Irrigation Priority Zones") {
|
|
# Create a new raster for irrigation recommendations
|
|
irrigation_priority <- ci_current * 0
|
|
|
|
# Extract values for processing
|
|
ci_values <- terra::values(ci_current)
|
|
change_values <- terra::values(ci_change)
|
|
|
|
# Create priority zones:
|
|
# 3 = High priority (low CI, negative trend)
|
|
# 2 = Medium priority (low CI but stable, or good CI with negative trend)
|
|
# 1 = Low priority (watch, good CI with slight decline)
|
|
# 0 = No action needed (good CI, stable/positive trend)
|
|
priority_values <- rep(NA, length(ci_values))
|
|
|
|
# High priority: Low CI (< 2) and negative change (< 0)
|
|
high_priority <- which(ci_values < 2 & change_values < 0 & !is.na(ci_values) & !is.na(change_values))
|
|
priority_values[high_priority] <- 3
|
|
|
|
# Medium priority: Low CI (< 2) with stable/positive change, or moderate CI (2-4) with significant negative change (< -1)
|
|
medium_priority <- which(
|
|
(ci_values < 2 & change_values >= 0 & !is.na(ci_values) & !is.na(change_values)) |
|
|
(ci_values >= 2 & ci_values < 4 & change_values < -1 & !is.na(ci_values) & !is.na(change_values))
|
|
)
|
|
priority_values[medium_priority] <- 2
|
|
|
|
# Low priority (watch): Moderate/good CI (>= 2) with mild negative change (-1 to 0)
|
|
low_priority <- which(
|
|
ci_values >= 2 & change_values < 0 & change_values >= -1 & !is.na(ci_values) & !is.na(change_values)
|
|
)
|
|
priority_values[low_priority] <- 1
|
|
|
|
# No action needed: Good CI (>= 2) with stable/positive change (>= 0)
|
|
no_action <- which(ci_values >= 2 & change_values >= 0 & !is.na(ci_values) & !is.na(change_values))
|
|
priority_values[no_action] <- 0
|
|
|
|
# Set values in the irrigation priority raster
|
|
terra::values(irrigation_priority) <- priority_values
|
|
|
|
# Create the map
|
|
tm_shape(irrigation_priority) +
|
|
tm_raster(
|
|
style = "cat",
|
|
palette = c("#1a9850", "#91cf60", "#fc8d59", "#d73027"),
|
|
labels = c("No Action", "Watch", "Medium Priority", "High Priority"),
|
|
title = "Irrigation Need"
|
|
) +
|
|
tm_shape(field_shape) +
|
|
tm_borders(lwd = 2) +
|
|
tm_layout(
|
|
main.title = title,
|
|
legend.outside = FALSE,
|
|
legend.position = c("left", "bottom")
|
|
)
|
|
}
|
|
|
|
#' Simple mock function to get weather data for a field
|
|
#' In a real implementation, this would fetch data from a weather API
|
|
#'
|
|
#' @param start_date Start date for weather data
|
|
#' @param end_date End date for weather data
|
|
#' @param lat Latitude of the field center
|
|
#' @param lon Longitude of the field center
|
|
#' @return A data frame of weather data
|
|
#'
|
|
get_weather_data <- function(start_date, end_date, lat = -16.1, lon = 34.7) {
|
|
# This is a mock implementation - in production, you'd replace with actual API call
|
|
# to a service like OpenWeatherMap, NOAA, or other weather data provider
|
|
|
|
# Create date sequence
|
|
dates <- seq.Date(from = as.Date(start_date), to = as.Date(end_date), by = "day")
|
|
n_days <- length(dates)
|
|
|
|
# Generate some random but realistic weather data with seasonal patterns
|
|
# More rain in summer, less in winter (Southern hemisphere)
|
|
month_nums <- as.numeric(format(dates, "%m"))
|
|
|
|
# Simplified seasonal patterns - adjust for your local climate
|
|
is_rainy_season <- month_nums %in% c(11, 12, 1, 2, 3, 4)
|
|
|
|
# Generate rainfall - more in rainy season, occasional heavy rainfall
|
|
rainfall <- numeric(n_days)
|
|
rainfall[is_rainy_season] <- pmax(0, rnorm(sum(is_rainy_season), mean = 4, sd = 8))
|
|
rainfall[!is_rainy_season] <- pmax(0, rnorm(sum(!is_rainy_season), mean = 0.5, sd = 2))
|
|
|
|
# Add some rare heavy rainfall events
|
|
heavy_rain_days <- sample(which(is_rainy_season), size = max(1, round(sum(is_rainy_season) * 0.1)))
|
|
rainfall[heavy_rain_days] <- rainfall[heavy_rain_days] + runif(length(heavy_rain_days), 20, 50)
|
|
|
|
# Generate temperatures - seasonal variation
|
|
temp_mean <- 18 + 8 * sin((month_nums - 1) * pi/6) # Peak in January (month 1)
|
|
temp_max <- temp_mean + rnorm(n_days, mean = 5, sd = 1)
|
|
temp_min <- temp_mean - rnorm(n_days, mean = 5, sd = 1)
|
|
|
|
# Create weather data frame
|
|
weather_data <- data.frame(
|
|
date = dates,
|
|
rainfall_mm = round(rainfall, 1),
|
|
temp_max_c = round(temp_max, 1),
|
|
temp_min_c = round(temp_min, 1),
|
|
temp_mean_c = round((temp_max + temp_min) / 2, 1)
|
|
)
|
|
|
|
return(weather_data)
|
|
}
|
|
|
|
#' Creates a weather summary visualization integrated with CI data
|
|
#'
|
|
#' @param pivotName Name of the pivot field
|
|
#' @param ci_data CI quadrant data
|
|
#' @param days_to_show Number of days of weather to show
|
|
#' @return ggplot object
|
|
#'
|
|
create_weather_ci_plot <- function(pivotName, ci_data = CI_quadrant, days_to_show = 30) {
|
|
# Get field data
|
|
field_data <- ci_data %>%
|
|
dplyr::filter(field == pivotName) %>%
|
|
dplyr::arrange(Date) %>%
|
|
dplyr::filter(!is.na(value))
|
|
|
|
if (nrow(field_data) == 0) {
|
|
return(ggplot() +
|
|
annotate("text", x = 0, y = 0, label = "No data available") +
|
|
theme_void())
|
|
}
|
|
|
|
# Get the latest date and 30 days before
|
|
latest_date <- max(field_data$Date, na.rm = TRUE)
|
|
start_date <- latest_date - days_to_show
|
|
|
|
# Filter for recent data only
|
|
recent_field_data <- field_data %>%
|
|
dplyr::filter(Date >= start_date)
|
|
|
|
# Get center point coordinates for the field (would be calculated from geometry in production)
|
|
# This is mocked for simplicity
|
|
lat <- -16.1 # Mock latitude
|
|
lon <- 34.7 # Mock longitude
|
|
|
|
# Get weather data
|
|
weather_data <- get_weather_data(start_date, latest_date, lat, lon)
|
|
|
|
# Aggregate CI data to daily mean across subfields if needed
|
|
daily_ci <- recent_field_data %>%
|
|
dplyr::group_by(Date) %>%
|
|
dplyr::summarize(mean_ci = mean(value, na.rm = TRUE))
|
|
|
|
# Create combined plot with dual y-axis
|
|
g <- ggplot() +
|
|
# Rainfall as bars
|
|
geom_col(data = weather_data, aes(x = date, y = rainfall_mm),
|
|
fill = "#1565C0", alpha = 0.7, width = 0.7) +
|
|
# CI as a line
|
|
geom_line(data = daily_ci, aes(x = Date, y = mean_ci * 10),
|
|
color = "#2E7D32", size = 1) +
|
|
geom_point(data = daily_ci, aes(x = Date, y = mean_ci * 10),
|
|
color = "#2E7D32", size = 2) +
|
|
# Temperature range as ribbon
|
|
geom_ribbon(data = weather_data,
|
|
aes(x = date, ymin = temp_min_c, ymax = temp_max_c),
|
|
fill = "#FF9800", alpha = 0.2) +
|
|
# Primary y-axis (rainfall)
|
|
scale_y_continuous(
|
|
name = "Rainfall (mm)",
|
|
sec.axis = sec_axis(~./10, name = "Chlorophyll Index & Temperature (°C)")
|
|
) +
|
|
labs(
|
|
title = paste("Field", pivotName, "- Weather and CI Relationship"),
|
|
subtitle = paste("Last", days_to_show, "days"),
|
|
x = "Date"
|
|
) +
|
|
theme_minimal() +
|
|
theme(
|
|
axis.title.y.left = element_text(color = "#1565C0"),
|
|
axis.title.y.right = element_text(color = "#2E7D32"),
|
|
legend.position = "bottom"
|
|
)
|
|
|
|
return(g)
|
|
} |