fixed the KPIs calculation for agronomic utils, fixed the path for saving the excel and rds, updated the main file
This commit is contained in:
DimitraVeropoulou
parent
13015f6ec0
commit
750db99a41
|
|
@ -370,7 +370,7 @@ main <- function() {
|
|||
current_year <- as.numeric(format(end_date, "%G"))
|
||||
|
||||
# Call with correct signature
|
||||
kpi_results <- calculate_all_kpis(
|
||||
kpi_results <- calculate_all_field_analysis_agronomic_support(
|
||||
field_boundaries_sf = field_boundaries_sf,
|
||||
current_week = current_week,
|
||||
current_year = current_year,
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
# 80_UTILS_AGRONOMIC_SUPPORT.R
|
||||
# ============================================================================
|
||||
# SPECIFIC KPI UTILITIES (SCRIPT 80 - CLIENT TYPE: agronomic_support)
|
||||
# AURA-SPECIFIC KPI UTILITIES (SCRIPT 80 - CLIENT TYPE: agronomic_support)
|
||||
#
|
||||
# Contains all 6 KPI calculation functions and helpers:
|
||||
# Contains all 6 AURA KPI calculation functions and helpers:
|
||||
# - Field uniformity KPI (CV-based, spatial autocorrelation)
|
||||
# - Area change KPI (week-over-week CI changes)
|
||||
# - TCH forecasted KPI (tonnage projections from harvest data)
|
||||
|
|
@ -12,7 +12,7 @@
|
|||
# - KPI reporting (summary tables, field details, text interpretation)
|
||||
# - KPI export (Excel, RDS, data export)
|
||||
#
|
||||
# Orchestrator: calculate_all_kpis()
|
||||
# Orchestrator: calculate_all_field_analysis_agronomic_support()
|
||||
# Dependencies: 00_common_utils.R (safe_log), sourced from common
|
||||
# Used by: 80_calculate_kpis.R (when client_type == "agronomic_support")
|
||||
# ============================================================================
|
||||
|
|
@ -24,6 +24,8 @@ library(tidyr)
|
|||
library(readxl)
|
||||
library(writexl)
|
||||
library(spdep)
|
||||
library(caret)
|
||||
library(CAST)
|
||||
|
||||
# ============================================================================
|
||||
# SHARED HELPER FUNCTIONS (NOW IN 80_UTILS_COMMON.R)
|
||||
|
|
@ -65,7 +67,7 @@ prepare_predictions <- function(harvest_model, field_data, scenario = "optimisti
|
|||
}
|
||||
|
||||
# ============================================================================
|
||||
# KPI CALCULATION FUNCTIONS (6 KPIS)
|
||||
# AURA KPI CALCULATION FUNCTIONS (6 KPIS)
|
||||
# ============================================================================
|
||||
|
||||
#' KPI 1: Calculate field uniformity based on CV and spatial autocorrelation
|
||||
|
|
@ -75,36 +77,52 @@ prepare_predictions <- function(harvest_model, field_data, scenario = "optimisti
|
|||
#'
|
||||
#' @param ci_pixels_by_field List of CI pixel arrays for each field
|
||||
#' @param field_boundaries_sf SF object with field geometries
|
||||
#' @param ci_raster Raster object with CI values (for spatial autocorrelation)
|
||||
#' @param ci_band Raster band with CI values
|
||||
#'
|
||||
#' @return Data frame with field_idx, cv_value, morans_i, uniformity_score, interpretation
|
||||
calculate_field_uniformity_kpi <- function(ci_pixels_by_field, field_boundaries_sf, ci_raster = NULL) {
|
||||
results_list <- list()
|
||||
calculate_field_uniformity_kpi <- function(ci_pixels_by_field, field_boundaries_sf, ci_band = NULL) {
|
||||
result <- data.frame(
|
||||
field_idx = integer(),
|
||||
cv_value = numeric(),
|
||||
morans_i = numeric(),
|
||||
uniformity_score = numeric(),
|
||||
interpretation = character(),
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
for (field_idx in seq_len(nrow(field_boundaries_sf))) {
|
||||
ci_pixels <- ci_pixels_by_field[[field_idx]]
|
||||
|
||||
if (is.null(ci_pixels) || length(ci_pixels) == 0) {
|
||||
results_list[[length(results_list) + 1]] <- list(
|
||||
result <- rbind(result, data.frame(
|
||||
field_idx = field_idx,
|
||||
cv_value = NA_real_,
|
||||
morans_i = NA_real_,
|
||||
uniformity_score = NA_real_,
|
||||
interpretation = "No data"
|
||||
)
|
||||
interpretation = "No data",
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
next
|
||||
}
|
||||
|
||||
cv_val <- calculate_cv(ci_pixels)
|
||||
|
||||
morans_i <- NA_real_
|
||||
if (!is.null(ci_raster)) {
|
||||
morans_result <- calculate_spatial_autocorrelation(ci_raster, field_boundaries_sf[field_idx, ])
|
||||
if (is.list(morans_result)) {
|
||||
morans_i <- morans_result$morans_i
|
||||
} else {
|
||||
morans_i <- morans_result
|
||||
}
|
||||
if (!is.null(ci_band) && inherits(ci_band, "SpatRaster")) {
|
||||
tryCatch({
|
||||
# Get single field geometry
|
||||
single_field <- field_boundaries_sf[field_idx, ]
|
||||
morans_result <- calculate_spatial_autocorrelation(ci_band, single_field)
|
||||
|
||||
if (is.list(morans_result)) {
|
||||
morans_i <- morans_result$morans_i
|
||||
} else {
|
||||
morans_i <- morans_result
|
||||
}
|
||||
}, error = function(e) {
|
||||
message(paste(" Warning: Spatial autocorrelation failed for field", field_idx, ":", e$message))
|
||||
morans_i <<- NA_real_
|
||||
})
|
||||
}
|
||||
|
||||
# Normalize CV (0-1 scale, invert so lower CV = higher score)
|
||||
|
|
@ -135,18 +153,15 @@ calculate_field_uniformity_kpi <- function(ci_pixels_by_field, field_boundaries_
|
|||
interpretation <- "Very poor uniformity"
|
||||
}
|
||||
|
||||
results_list[[length(results_list) + 1]] <- list(
|
||||
result <- rbind(result, data.frame(
|
||||
field_idx = field_idx,
|
||||
cv_value = cv_val,
|
||||
morans_i = morans_i,
|
||||
uniformity_score = round(uniformity_score, 3),
|
||||
interpretation = interpretation
|
||||
)
|
||||
}
|
||||
|
||||
# Convert accumulated list to data frame in a single operation
|
||||
result <- do.call(rbind, lapply(results_list, as.data.frame))
|
||||
|
||||
interpretation = interpretation,
|
||||
stringsAsFactors = FALSE
|
||||
))
|
||||
}
|
||||
return(result)
|
||||
}
|
||||
|
||||
|
|
@ -214,12 +229,19 @@ calculate_tch_forecasted_kpi <- function(field_statistics, harvesting_data = NUL
|
|||
next
|
||||
}
|
||||
|
||||
if (is.na(result$mean_ci[i])) {
|
||||
result$tch_forecasted[i] <- NA_real_
|
||||
result$tch_lower_bound[i] <- NA_real_
|
||||
result$tch_upper_bound[i] <- NA_real_
|
||||
result$confidence[i] <- "No data"
|
||||
}
|
||||
ci_val <- result$mean_ci[i]
|
||||
|
||||
# Simple linear model
|
||||
tch_est <- 50 + (ci_val * 10)
|
||||
|
||||
# Confidence interval based on CI range
|
||||
tch_lower <- tch_est * 0.85
|
||||
tch_upper <- tch_est * 1.15
|
||||
|
||||
result$tch_forecasted[i] <- round(tch_est, 2)
|
||||
result$tch_lower_bound[i] <- round(tch_lower, 2)
|
||||
result$tch_upper_bound[i] <- round(tch_upper, 2)
|
||||
result$confidence[i] <- "Medium"
|
||||
}
|
||||
|
||||
return(result)
|
||||
|
|
@ -338,190 +360,107 @@ calculate_weed_presence_kpi <- function(ci_pixels_by_field) {
|
|||
return(result)
|
||||
}
|
||||
|
||||
# #' Calculate Gap Filling Score KPI (placeholder)
|
||||
# #' @param ci_raster Current week CI raster
|
||||
# #' @param field_boundaries Field boundaries
|
||||
# #' @return Data frame with field-level gap filling scores
|
||||
# calculate_gap_filling_kpi <- function(ci_raster, field_boundaries) {
|
||||
# # Handle both sf and SpatVector inputs
|
||||
# if (!inherits(field_boundaries, "SpatVector")) {
|
||||
# field_boundaries_vect <- terra::vect(field_boundaries)
|
||||
# } else {
|
||||
# field_boundaries_vect <- field_boundaries
|
||||
# }
|
||||
#' Calculate Gap Filling Score KPI (placeholder)
|
||||
#' @param ci_raster Current week CI raster
|
||||
#' @param field_boundaries Field boundaries
|
||||
#' @return List with summary data frame and field-level results data frame
|
||||
calculate_gap_filling_kpi <- function(ci_raster, field_boundaries) {
|
||||
# Handle both sf and SpatVector inputs
|
||||
if (!inherits(field_boundaries, "SpatVector")) {
|
||||
field_boundaries_vect <- terra::vect(field_boundaries)
|
||||
} else {
|
||||
field_boundaries_vect <- field_boundaries
|
||||
}
|
||||
|
||||
# results_list <- list()
|
||||
field_results <- data.frame()
|
||||
|
||||
# # Ensure field_boundaries_vect is valid and matches field_boundaries dimensions
|
||||
# n_fields_vect <- length(field_boundaries_vect)
|
||||
# n_fields_sf <- nrow(field_boundaries)
|
||||
|
||||
# if (n_fields_sf != n_fields_vect) {
|
||||
# warning(paste("Field boundary mismatch: nrow(field_boundaries)=", n_fields_sf, "vs length(field_boundaries_vect)=", n_fields_vect, ". Using actual SpatVector length."))
|
||||
# }
|
||||
for (i in seq_len(nrow(field_boundaries))) {
|
||||
field_name <- if ("field" %in% names(field_boundaries)) field_boundaries$field[i] else NA_character_
|
||||
sub_field_name <- if ("sub_field" %in% names(field_boundaries)) field_boundaries$sub_field[i] else NA_character_
|
||||
field_vect <- field_boundaries_vect[i]
|
||||
|
||||
# for (i in seq_len(n_fields_vect)) {
|
||||
# field_vect <- field_boundaries_vect[i]
|
||||
# Extract CI values using helper function
|
||||
ci_values <- extract_ci_values(ci_raster, field_vect)
|
||||
valid_values <- ci_values[!is.na(ci_values) & is.finite(ci_values)]
|
||||
|
||||
# # Extract CI values using helper function
|
||||
# ci_values <- extract_ci_values(ci_raster, field_vect)
|
||||
# valid_values <- ci_values[!is.na(ci_values) & is.finite(ci_values)]
|
||||
if (length(valid_values) > 1) {
|
||||
# Gap score using 2σ below median to detect outliers
|
||||
median_ci <- median(valid_values)
|
||||
sd_ci <- sd(valid_values)
|
||||
outlier_threshold <- median_ci - (2 * sd_ci)
|
||||
low_ci_pixels <- sum(valid_values < outlier_threshold)
|
||||
total_pixels <- length(valid_values)
|
||||
gap_score <- round((low_ci_pixels / total_pixels) * 100, 2)
|
||||
|
||||
# if (length(valid_values) > 1) {
|
||||
# # Calculate % of valid (non-NA) values = gap filling success
|
||||
# total_pixels <- length(ci_values)
|
||||
# valid_pixels <- length(valid_values)
|
||||
# gap_filling_success <- (valid_pixels / total_pixels) * 100
|
||||
# na_percent <- ((total_pixels - valid_pixels) / total_pixels) * 100
|
||||
# Classify gap severity
|
||||
gap_level <- dplyr::case_when(
|
||||
gap_score < 10 ~ "Minimal",
|
||||
gap_score < 25 ~ "Moderate",
|
||||
TRUE ~ "Significant"
|
||||
)
|
||||
|
||||
# results_list[[length(results_list) + 1]] <- list(
|
||||
# field_idx = i,
|
||||
# gap_filling_success = round(gap_filling_success, 2),
|
||||
# na_percent_pre_interpolation = round(na_percent, 2),
|
||||
# mean_ci = round(mean(valid_values), 2)
|
||||
# )
|
||||
# } else {
|
||||
# # Not enough valid data
|
||||
# results_list[[length(results_list) + 1]] <- list(
|
||||
# field_idx = i,
|
||||
# gap_filling_success = NA_real_,
|
||||
# na_percent_pre_interpolation = NA_real_,
|
||||
# mean_ci = NA_real_
|
||||
# )
|
||||
# }
|
||||
# }
|
||||
field_results <- rbind(field_results, data.frame(
|
||||
field = field_name,
|
||||
sub_field = sub_field_name,
|
||||
gap_level = gap_level,
|
||||
gap_score = gap_score,
|
||||
mean_ci = mean(valid_values),
|
||||
outlier_threshold = outlier_threshold
|
||||
))
|
||||
} else {
|
||||
# Not enough valid data, fill with NA row
|
||||
field_results <- rbind(field_results, data.frame(
|
||||
field = field_name,
|
||||
sub_field = sub_field_name,
|
||||
gap_level = NA_character_,
|
||||
gap_score = NA_real_,
|
||||
mean_ci = NA_real_,
|
||||
outlier_threshold = NA_real_
|
||||
))
|
||||
}
|
||||
}
|
||||
# Summarize results
|
||||
gap_summary <- field_results %>%
|
||||
dplyr::group_by(gap_level) %>%
|
||||
dplyr::summarise(field_count = n(), .groups = 'drop') %>%
|
||||
dplyr::mutate(percent = round((field_count / sum(field_count)) * 100, 1))
|
||||
|
||||
# Convert accumulated list to data frame in a single operation
|
||||
field_results <- do.call(rbind, lapply(results_list, as.data.frame))
|
||||
|
||||
return(field_results)
|
||||
return(list(summary = gap_summary, field_results = field_results))
|
||||
}
|
||||
|
||||
# ============================================================================
|
||||
# KPI ORCHESTRATOR AND REPORTING
|
||||
# ============================================================================
|
||||
|
||||
#' Create summary tables for all 6 KPIs (AGGREGATED farm-level summaries)
|
||||
#' Create summary tables for all 6 KPIs
|
||||
#'
|
||||
#' @param all_kpis List containing results from all 6 KPI functions (per-field data)
|
||||
#' @param all_kpis List containing results from all 6 KPI functions
|
||||
#'
|
||||
#' @return List of summary data frames ready for reporting (farm-level aggregates)
|
||||
#' @return List of summary data frames ready for reporting
|
||||
create_summary_tables <- function(all_kpis) {
|
||||
|
||||
# ==========================================
|
||||
# 1. UNIFORMITY SUMMARY (count by interpretation)
|
||||
# ==========================================
|
||||
uniformity_summary <- all_kpis$uniformity %>%
|
||||
group_by(interpretation) %>%
|
||||
summarise(
|
||||
field_count = n(),
|
||||
avg_cv = mean(cv_value, na.rm = TRUE),
|
||||
avg_morans_i = mean(morans_i, na.rm = TRUE),
|
||||
.groups = 'drop'
|
||||
) %>%
|
||||
rename(
|
||||
Status = interpretation,
|
||||
`Field Count` = field_count,
|
||||
`Avg CV` = avg_cv,
|
||||
`Avg Moran's I` = avg_morans_i
|
||||
)
|
||||
|
||||
# ==========================================
|
||||
# 2. AREA CHANGE SUMMARY (improving/stable/declining counts)
|
||||
# ==========================================
|
||||
area_change_summary <- all_kpis$area_change %>%
|
||||
group_by(interpretation) %>%
|
||||
summarise(
|
||||
field_count = n(),
|
||||
avg_ci_change = mean(mean_ci_pct_change, na.rm = TRUE),
|
||||
.groups = 'drop'
|
||||
) %>%
|
||||
rename(
|
||||
Status = interpretation,
|
||||
`Field Count` = field_count,
|
||||
`Avg CI Change %` = avg_ci_change
|
||||
)
|
||||
|
||||
# ==========================================
|
||||
# 3. TCH FORECAST SUMMARY (yield statistics)
|
||||
# ==========================================
|
||||
tch_summary <- all_kpis$tch_forecasted %>%
|
||||
summarise(
|
||||
avg_tch = mean(tch_forecasted, na.rm = TRUE),
|
||||
min_tch = min(tch_forecasted, na.rm = TRUE),
|
||||
max_tch = max(tch_forecasted, na.rm = TRUE),
|
||||
avg_ci = mean(mean_ci, na.rm = TRUE),
|
||||
fields_with_data = sum(!is.na(tch_forecasted))
|
||||
) %>%
|
||||
rename(
|
||||
`Avg Forecast (t/ha)` = avg_tch,
|
||||
`Min (t/ha)` = min_tch,
|
||||
`Max (t/ha)` = max_tch,
|
||||
`Avg CI` = avg_ci,
|
||||
`Fields` = fields_with_data
|
||||
)
|
||||
|
||||
# ==========================================
|
||||
# 4. GROWTH DECLINE SUMMARY (trend interpretation)
|
||||
# ==========================================
|
||||
growth_summary <- all_kpis$growth_decline %>%
|
||||
group_by(trend_interpretation) %>%
|
||||
summarise(
|
||||
field_count = n(),
|
||||
avg_trend = mean(four_week_trend, na.rm = TRUE),
|
||||
.groups = 'drop'
|
||||
) %>%
|
||||
rename(
|
||||
Trend = trend_interpretation,
|
||||
`Field Count` = field_count,
|
||||
`Avg 4-Week Trend` = avg_trend
|
||||
)
|
||||
|
||||
# ==========================================
|
||||
# 5. WEED PRESSURE SUMMARY (risk level counts)
|
||||
# ==========================================
|
||||
weed_summary <- all_kpis$weed_presence %>%
|
||||
group_by(weed_pressure_risk) %>%
|
||||
summarise(
|
||||
field_count = n(),
|
||||
avg_fragmentation = mean(fragmentation_index, na.rm = TRUE),
|
||||
.groups = 'drop'
|
||||
) %>%
|
||||
rename(
|
||||
`Risk Level` = weed_pressure_risk,
|
||||
`Field Count` = field_count,
|
||||
`Avg Fragmentation` = avg_fragmentation
|
||||
)
|
||||
|
||||
# ==========================================
|
||||
# 6. GAP FILLING SUMMARY
|
||||
# ==========================================
|
||||
gap_summary <- if (!is.null(all_kpis$gap_filling) && is.data.frame(all_kpis$gap_filling) && nrow(all_kpis$gap_filling) > 0) {
|
||||
all_kpis$gap_filling %>%
|
||||
summarise(
|
||||
avg_gap_filling = mean(gap_filling_success, na.rm = TRUE),
|
||||
avg_na_percent = mean(na_percent_pre_interpolation, na.rm = TRUE),
|
||||
fields_with_data = n()
|
||||
) %>%
|
||||
rename(
|
||||
`Avg Gap Filling Success %` = avg_gap_filling,
|
||||
`Avg NA % Pre-Interpolation` = avg_na_percent,
|
||||
`Fields Analyzed` = fields_with_data
|
||||
)
|
||||
} else {
|
||||
data.frame(`Avg Gap Filling Success %` = NA_real_, `Avg NA % Pre-Interpolation` = NA_real_, `Fields Analyzed` = 0, check.names = FALSE)
|
||||
}
|
||||
|
||||
# Return as list (each element is a farm-level summary table)
|
||||
kpi_summary <- list(
|
||||
uniformity = uniformity_summary,
|
||||
area_change = area_change_summary,
|
||||
tch_forecast = tch_summary,
|
||||
growth_decline = growth_summary,
|
||||
weed_pressure = weed_summary,
|
||||
gap_filling = gap_summary
|
||||
uniformity = all_kpis$uniformity %>%
|
||||
select(field_idx, cv_value, morans_i, uniformity_score, interpretation),
|
||||
|
||||
area_change = all_kpis$area_change %>%
|
||||
select(field_idx, mean_ci_pct_change, interpretation),
|
||||
|
||||
tch_forecast = all_kpis$tch_forecasted %>%
|
||||
select(field_idx, mean_ci, tch_forecasted, tch_lower_bound, tch_upper_bound, confidence),
|
||||
|
||||
growth_decline = all_kpis$growth_decline %>%
|
||||
select(field_idx, four_week_trend, trend_interpretation, decline_severity),
|
||||
|
||||
weed_pressure = all_kpis$weed_presence %>%
|
||||
select(field_idx, fragmentation_index, weed_pressure_risk),
|
||||
|
||||
gap_filling = if (!is.null(all_kpis$gap_filling)) {
|
||||
all_kpis$gap_filling %>%
|
||||
select(field_idx, gap_score, gap_level, mean_ci)
|
||||
} else {
|
||||
NULL
|
||||
}
|
||||
)
|
||||
|
||||
return(kpi_summary)
|
||||
}
|
||||
|
||||
|
|
@ -531,7 +470,7 @@ create_summary_tables <- function(all_kpis) {
|
|||
#' @param all_kpis List with all KPI results
|
||||
#' @param field_boundaries_sf SF object with field boundaries
|
||||
#'
|
||||
#' @return Data frame with one row per field, all KPI columns (renamed for reporting compatibility)
|
||||
#' @return Data frame with one row per field, all KPI columns
|
||||
create_field_detail_table <- function(field_df, all_kpis, field_boundaries_sf) {
|
||||
result <- field_df %>%
|
||||
left_join(
|
||||
|
|
@ -543,7 +482,7 @@ create_field_detail_table <- function(field_df, all_kpis, field_boundaries_sf) {
|
|||
by = c("field_idx")
|
||||
) %>%
|
||||
left_join(
|
||||
all_kpis$tch_forecasted %>% select(field_idx, tch_forecasted, mean_ci),
|
||||
all_kpis$tch_forecasted %>% select(field_idx, tch_forecasted),
|
||||
by = c("field_idx")
|
||||
) %>%
|
||||
left_join(
|
||||
|
|
@ -553,26 +492,7 @@ create_field_detail_table <- function(field_df, all_kpis, field_boundaries_sf) {
|
|||
left_join(
|
||||
all_kpis$weed_presence %>% select(field_idx, weed_pressure_risk),
|
||||
by = c("field_idx")
|
||||
) %>%
|
||||
# Rename columns to match reporting script expectations
|
||||
rename(
|
||||
Field = field_name,
|
||||
`Growth Uniformity` = uniformity_interpretation,
|
||||
`Yield Forecast (t/ha)` = tch_forecasted,
|
||||
`Decline Risk` = decline_severity,
|
||||
`Weed Risk` = weed_pressure_risk,
|
||||
`CI Change %` = mean_ci_pct_change,
|
||||
`Mean CI` = mean_ci,
|
||||
`CV Value` = cv_value
|
||||
) %>%
|
||||
# Add placeholder columns expected by reporting script (will be populated from other sources)
|
||||
mutate(
|
||||
`Field Size (ha)` = NA_real_,
|
||||
`Gap Score` = NA_real_
|
||||
) %>%
|
||||
select(field_idx, Field, `Field Size (ha)`, `Growth Uniformity`, `Yield Forecast (t/ha)`,
|
||||
`Gap Score`, `Decline Risk`, `Weed Risk`, `CI Change %`, `Mean CI`, `CV Value`)
|
||||
|
||||
)
|
||||
return(result)
|
||||
}
|
||||
|
||||
|
|
@ -583,7 +503,7 @@ create_field_detail_table <- function(field_df, all_kpis, field_boundaries_sf) {
|
|||
#' @return Character string with formatted KPI summary text
|
||||
create_field_kpi_text <- function(all_kpis) {
|
||||
text_parts <- c(
|
||||
"## KPI ANALYSIS SUMMARY\n",
|
||||
"## AURA KPI ANALYSIS SUMMARY\n",
|
||||
"### Field Uniformity\n",
|
||||
paste(all_kpis$uniformity$interpretation, collapse = "; "), "\n",
|
||||
"### Growth Trends\n",
|
||||
|
|
@ -597,69 +517,21 @@ create_field_kpi_text <- function(all_kpis) {
|
|||
|
||||
#' Export detailed KPI data to Excel/RDS
|
||||
#'
|
||||
#' @param all_kpis List with all KPI results (per-field data)
|
||||
#' @param kpi_summary List with summary tables (farm-level aggregates)
|
||||
#' @param project_dir Project name (for filename)
|
||||
#' @param all_kpis List with all KPI results
|
||||
#' @param kpi_summary List with summary tables
|
||||
#' @param output_dir Directory for output files
|
||||
#' @param week Week number
|
||||
#' @param year Year
|
||||
#' @param field_boundaries_sf SF object with field boundaries (optional, for field_details_table)
|
||||
#'
|
||||
#' @return List of output file paths
|
||||
export_kpi_data <- function(all_kpis, kpi_summary, project_dir, output_dir, week, year, field_boundaries_sf = NULL) {
|
||||
export_kpi_data <- function(all_kpis, kpi_summary, output_dir, week, year, project_dir) {
|
||||
# Ensure output directory exists
|
||||
if (!dir.exists(output_dir)) {
|
||||
dir.create(output_dir, recursive = TRUE)
|
||||
}
|
||||
|
||||
# Create unified field details table if field_boundaries_sf is provided
|
||||
field_details_table <- NULL
|
||||
if (!is.null(field_boundaries_sf)) {
|
||||
tryCatch({
|
||||
# Create a basic field_df from the boundaries
|
||||
# Robust field name extraction with multiple fallbacks
|
||||
field_name <- NA_character_
|
||||
|
||||
# Check for 'name' column in the data.frame
|
||||
if ("name" %in% names(field_boundaries_sf)) {
|
||||
field_name <- field_boundaries_sf$name
|
||||
} else if ("properties" %in% names(field_boundaries_sf)) {
|
||||
# Extract from properties column (may be a list-column)
|
||||
props <- field_boundaries_sf$properties
|
||||
if (is.list(props) && length(props) > 0 && "name" %in% names(props[[1]])) {
|
||||
field_name <- sapply(props, function(x) ifelse(is.null(x$name), NA_character_, x$name))
|
||||
} else if (!is.list(props)) {
|
||||
# Try direct access if properties is a simple column
|
||||
field_name <- props
|
||||
}
|
||||
}
|
||||
|
||||
# Ensure field_name is a character vector of appropriate length
|
||||
if (length(field_name) != nrow(field_boundaries_sf)) {
|
||||
field_name <- rep(NA_character_, nrow(field_boundaries_sf))
|
||||
}
|
||||
|
||||
# Replace only NA elements with fallback names, keeping valid names intact
|
||||
na_indices <- which(is.na(field_name))
|
||||
if (length(na_indices) > 0) {
|
||||
field_name[na_indices] <- paste0("Field_", na_indices)
|
||||
}
|
||||
|
||||
field_df <- data.frame(
|
||||
field_idx = 1:nrow(field_boundaries_sf),
|
||||
field_name = field_name,
|
||||
stringsAsFactors = FALSE
|
||||
)
|
||||
|
||||
field_details_table <- create_field_detail_table(field_df, all_kpis, field_boundaries_sf)
|
||||
message(paste("✓ Field details table created with", nrow(field_details_table), "fields"))
|
||||
}, error = function(e) {
|
||||
message(paste("WARNING: Could not create field_details_table:", e$message))
|
||||
})
|
||||
}
|
||||
|
||||
# Export all KPI tables to a single Excel file - use project_dir"
|
||||
excel_file <- file.path(output_dir, paste0(project_dir, "_kpi_summary_tables_week", sprintf("%02d_%d", week, year), ".xlsx"))
|
||||
# Export all KPI tables to a single Excel file
|
||||
excel_file <- paste0(project_dir, "_field_analysis_week", sprintf("%02d_%d", week, year), ".xlsx")
|
||||
excel_path <- file.path(output_dir, excel_file)
|
||||
|
||||
sheets <- list(
|
||||
"Uniformity" = as.data.frame(kpi_summary$uniformity),
|
||||
|
|
@ -670,40 +542,38 @@ export_kpi_data <- function(all_kpis, kpi_summary, project_dir, output_dir, week
|
|||
"Gap_Filling" = as.data.frame(kpi_summary$gap_filling)
|
||||
)
|
||||
|
||||
write_xlsx(sheets, excel_file)
|
||||
message(paste("✓ KPI data exported to:", excel_file))
|
||||
write_xlsx(sheets, excel_path)
|
||||
message(paste("✓ AURA KPI data exported to:", excel_path))
|
||||
|
||||
# Export to RDS for programmatic access (CRITICAL: Both per-field AND summary tables)
|
||||
# The reporting script expects: summary_tables (list of 6 summary tables)
|
||||
# We also provide: all_kpis (per-field data) and field_details (unified field view)
|
||||
rds_file <- file.path(output_dir, paste0(project_dir, "_kpi_summary_tables_week", sprintf("%02d_%d", week, year), ".rds"))
|
||||
|
||||
# Create the export structure that reporting scripts expect
|
||||
export_data <- list(
|
||||
summary_tables = kpi_summary, # Farm-level aggregates (6 KPI summaries)
|
||||
all_kpis = all_kpis, # Per-field data (6 KPI per-field tables)
|
||||
field_details = field_details_table # Unified field-level detail table
|
||||
# Also export to RDS for programmatic access
|
||||
rds_file <- paste0(project_dir, "_field_analysis_week", sprintf("%02d_%d", week, year), ".rds")
|
||||
rds_path <- file.path(output_dir, rds_file)
|
||||
|
||||
# Save complete structure including metadata
|
||||
kpi_export_data <- list(
|
||||
kpis = all_kpis,
|
||||
summary_tables = kpi_summary,
|
||||
metadata = list(
|
||||
week = week,
|
||||
year = year,
|
||||
project = project_dir,
|
||||
created_at = Sys.time()
|
||||
)
|
||||
)
|
||||
|
||||
saveRDS(export_data, rds_file)
|
||||
message(paste("✓ KPI RDS exported to:", rds_file))
|
||||
message(" Structure: list($summary_tables, $all_kpis, $field_details)")
|
||||
saveRDS(kpi_export_data, rds_path)
|
||||
message(paste("✓ AURA KPI RDS exported to:", rds_path))
|
||||
|
||||
# Return including field_details for orchestrator to capture
|
||||
return(list(
|
||||
excel = excel_file,
|
||||
rds = rds_file,
|
||||
field_details = field_details_table
|
||||
))
|
||||
return(list(excel = excel_path, rds = rds_path))
|
||||
}
|
||||
|
||||
# ============================================================================
|
||||
# ORCHESTRATOR FUNCTION
|
||||
# ============================================================================
|
||||
|
||||
#' Calculate all 6 KPIs
|
||||
#' Calculate all 6 AURA KPIs
|
||||
#'
|
||||
#' Main entry point for KPI calculation.
|
||||
#' Main entry point for AURA KPI calculation.
|
||||
#' This function orchestrates the 6 KPI calculations and returns all results.
|
||||
#'
|
||||
#' @param field_boundaries_sf SF object with field geometries
|
||||
|
|
@ -714,7 +584,6 @@ export_kpi_data <- function(all_kpis, kpi_summary, project_dir, output_dir, week
|
|||
#' @param ci_rds_path Path to combined CI RDS file
|
||||
#' @param harvesting_data Data frame with harvest data (optional)
|
||||
#' @param output_dir Directory for KPI exports
|
||||
#' @param project_dir Project name (for filename in exports)
|
||||
#'
|
||||
#' @return List with results from all 6 KPI functions
|
||||
#'
|
||||
|
|
@ -722,11 +591,11 @@ export_kpi_data <- function(all_kpis, kpi_summary, project_dir, output_dir, week
|
|||
#' This function:
|
||||
#' 1. Loads current week mosaic and extracts field statistics
|
||||
#' 2. (Optionally) loads previous week mosaic for comparison metrics
|
||||
#' 3. Calculates all 6 KPIs
|
||||
#' 3. Calculates all 6 AURA KPIs
|
||||
#' 4. Creates summary tables
|
||||
#' 5. Exports results to Excel/RDS
|
||||
#'
|
||||
calculate_all_kpis <- function(
|
||||
calculate_all_field_analysis_agronomic_support <- function(
|
||||
field_boundaries_sf,
|
||||
current_week,
|
||||
current_year,
|
||||
|
|
@ -738,7 +607,7 @@ calculate_all_kpis <- function(
|
|||
project_dir = NULL
|
||||
) {
|
||||
|
||||
message("\n============ KPI CALCULATION (6 KPIs) ============")
|
||||
message("\n============ AURA KPI CALCULATION (6 KPIs) ============")
|
||||
|
||||
# Load current week mosaic
|
||||
message("Loading current week mosaic...")
|
||||
|
|
@ -751,7 +620,12 @@ calculate_all_kpis <- function(
|
|||
# Extract field statistics
|
||||
message("Extracting field statistics from current mosaic...")
|
||||
current_stats <- extract_field_statistics_from_ci(current_mosaic, field_boundaries_sf)
|
||||
ci_pixels_by_field <- extract_ci_values(current_mosaic, field_boundaries_sf)
|
||||
#Extract CI pixels for each field individually
|
||||
ci_pixels_by_field <- list()
|
||||
for (i in seq_len(nrow(field_boundaries_sf))) {
|
||||
field_vect <- terra::vect(field_boundaries_sf[i, ])
|
||||
ci_pixels_by_field[[i]] <- extract_ci_values(current_mosaic, field_vect)
|
||||
}
|
||||
|
||||
# Load previous week mosaic (if available)
|
||||
previous_stats <- NULL
|
||||
|
|
@ -787,14 +661,19 @@ calculate_all_kpis <- function(
|
|||
|
||||
message("Calculating KPI 4: Growth Decline...")
|
||||
growth_decline_kpi <- calculate_growth_decline_kpi(
|
||||
ci_pixels_by_field # Would need historical data for real trend
|
||||
list(ci_pixels_by_field) # Would need historical data for real trend
|
||||
)
|
||||
|
||||
message("Calculating KPI 5: Weed Presence...")
|
||||
weed_kpi <- calculate_weed_presence_kpi(ci_pixels_by_field)
|
||||
|
||||
message("Calculating KPI 6: Gap Filling...")
|
||||
gap_filling_kpi <- calculate_gap_filling_kpi(current_mosaic, field_boundaries_sf)
|
||||
gap_filling_result <- calculate_gap_filling_kpi(current_mosaic, field_boundaries_sf)
|
||||
|
||||
# Add field_idx to gap filling results
|
||||
gap_filling_kpi <- gap_filling_result$field_results %>%
|
||||
mutate(field_idx = row_number()) %>%
|
||||
select(field_idx, gap_score, gap_level, mean_ci, outlier_threshold)
|
||||
|
||||
# Compile results
|
||||
all_kpis <- list(
|
||||
|
|
@ -807,21 +686,21 @@ calculate_all_kpis <- function(
|
|||
)
|
||||
|
||||
# Create summary tables
|
||||
message("\nCreating summary tables...")
|
||||
kpi_summary <- create_summary_tables(all_kpis)
|
||||
|
||||
# Export - pass project_dir for proper filename and field_boundaries_sf for field details table
|
||||
if (is.null(project_dir)) {
|
||||
project_dir <- "AURA" # Fallback if not provided
|
||||
}
|
||||
export_result <- export_kpi_data(all_kpis, kpi_summary, project_dir, output_dir, current_week, current_year, field_boundaries_sf)
|
||||
# Export
|
||||
message("\nExporting KPI data...")
|
||||
export_paths <- export_kpi_data(all_kpis, kpi_summary, output_dir, current_week, current_year, project_dir)
|
||||
|
||||
message(paste("\n✓", project_dir, "KPI calculation complete. Week", current_week, current_year, "\n"))
|
||||
message(paste("\n✓ AURA KPI calculation complete. Week", current_week, current_year))
|
||||
|
||||
# Return combined structure (for integration with 80_calculate_kpis.R)
|
||||
# Capture field_details from export_result to propagate it out
|
||||
return(list(
|
||||
all_kpis = all_kpis,
|
||||
kpis = all_kpis,
|
||||
summary_tables = kpi_summary,
|
||||
field_details = export_result$field_details # Propagate field_details from export_kpi_data
|
||||
))
|
||||
metadata = list(
|
||||
week = current_week,
|
||||
year = current_year,
|
||||
project = project_dir,
|
||||
export_paths = export_paths) ))
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in a new issue