From 5f2dca0a92c0c9ef313d31ae9ed082f391163e35 Mon Sep 17 00:00:00 2001 From: DimitraVeropoulou Date: Mon, 16 Feb 2026 15:05:52 +0100 Subject: [PATCH] remove gap score calculation --> moved to common --- r_app/80_utils_cane_supply.R | 244 +++++++++++++++++------------------ 1 file changed, 122 insertions(+), 122 deletions(-) diff --git a/r_app/80_utils_cane_supply.R b/r_app/80_utils_cane_supply.R index bceaa5d..6c93221 100644 --- a/r_app/80_utils_cane_supply.R +++ b/r_app/80_utils_cane_supply.R @@ -166,153 +166,153 @@ calculate_status_alert <- function(imminent_prob, age_week, weekly_ci_change, me NA_character_ } -#' Calculate Gap Filling Score KPI (2σ method) -#' @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) { - safe_log("Calculating Gap Filling Score KPI (placeholder)") +# #' Calculate Gap Filling Score KPI (2σ method) +# #' @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) { +# safe_log("Calculating Gap Filling Score KPI (placeholder)") - # Handle both sf and SpatVector inputs - if (!inherits(field_boundaries, "SpatVector")) { - field_boundaries_vect <- terra::vect(field_boundaries) - } else { - field_boundaries_vect <- 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 +# } - # Ensure field_boundaries_vect is valid and matches field_boundaries dimensions - n_fields_vect <- length(field_boundaries_vect) - n_fields_sf <- nrow(field_boundaries) +# # 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.")) - } +# 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.")) +# } - field_results <- data.frame() +# field_results <- data.frame() - for (i in seq_len(nrow(field_boundaries))) { - field_name <- field_boundaries$field[i] - sub_field_name <- field_boundaries$sub_field[i] - field_vect <- field_boundaries_vect[i] +# for (i in seq_len(nrow(field_boundaries))) { +# field_name <- field_boundaries$field[i] +# sub_field_name <- field_boundaries$sub_field[i] +# 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) { +# # 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) - # Classify gap severity - gap_level <- dplyr::case_when( - gap_score < 10 ~ "Minimal", - gap_score < 25 ~ "Moderate", - TRUE ~ "Significant" - ) +# # Classify gap severity +# gap_level <- dplyr::case_when( +# gap_score < 10 ~ "Minimal", +# gap_score < 25 ~ "Moderate", +# TRUE ~ "Significant" +# ) - 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_ - )) - } - } - return(list(field_results = field_results)) -} +# 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_ +# )) +# } +# } +# return(list(field_results = field_results)) +# } -#' Calculate gap filling scores for all per-field mosaics -#' This is a wrapper function that processes multiple per-field mosaic files -#' and calculates gap scores for each field. -#' @param per_field_files Character vector of paths to per-field mosaic TIFFs -#' @param field_boundaries_sf sf object with field geometries -#' @return data.frame with Field_id and gap_score columns -calculate_gap_scores <- function(per_field_files, field_boundaries_sf) { - message("\nCalculating gap filling scores (2σ method)...") - message(paste(" Using per-field mosaics for", length(per_field_files), "fields")) +# #' Calculate gap filling scores for all per-field mosaics +# #' This is a wrapper function that processes multiple per-field mosaic files +# #' and calculates gap scores for each field. +# #' @param per_field_files Character vector of paths to per-field mosaic TIFFs +# #' @param field_boundaries_sf sf object with field geometries +# #' @return data.frame with Field_id and gap_score columns +# calculate_gap_scores <- function(per_field_files, field_boundaries_sf) { +# message("\nCalculating gap filling scores (2σ method)...") +# message(paste(" Using per-field mosaics for", length(per_field_files), "fields")) - field_boundaries_by_id <- split(field_boundaries_sf, field_boundaries_sf$field) +# field_boundaries_by_id <- split(field_boundaries_sf, field_boundaries_sf$field) - process_gap_for_field <- function(field_file) { - field_id <- basename(dirname(field_file)) - field_bounds <- field_boundaries_by_id[[field_id]] +# process_gap_for_field <- function(field_file) { +# field_id <- basename(dirname(field_file)) +# field_bounds <- field_boundaries_by_id[[field_id]] - if (is.null(field_bounds) || nrow(field_bounds) == 0) { - return(data.frame(Field_id = field_id, gap_score = NA_real_)) - } +# if (is.null(field_bounds) || nrow(field_bounds) == 0) { +# return(data.frame(Field_id = field_id, gap_score = NA_real_)) +# } - tryCatch({ - field_raster <- terra::rast(field_file) - ci_band_name <- "CI" - if (!(ci_band_name %in% names(field_raster))) { - return(data.frame(Field_id = field_id, gap_score = NA_real_)) - } - field_ci_band <- field_raster[[ci_band_name]] - names(field_ci_band) <- "CI" +# tryCatch({ +# field_raster <- terra::rast(field_file) +# ci_band_name <- "CI" +# if (!(ci_band_name %in% names(field_raster))) { +# return(data.frame(Field_id = field_id, gap_score = NA_real_)) +# } +# field_ci_band <- field_raster[[ci_band_name]] +# names(field_ci_band) <- "CI" - gap_result <- calculate_gap_filling_kpi(field_ci_band, field_bounds) +# gap_result <- calculate_gap_filling_kpi(field_ci_band, field_bounds) - if (is.null(gap_result) || is.null(gap_result$field_results) || nrow(gap_result$field_results) == 0) { - return(data.frame(Field_id = field_id, gap_score = NA_real_)) - } +# if (is.null(gap_result) || is.null(gap_result$field_results) || nrow(gap_result$field_results) == 0) { +# return(data.frame(Field_id = field_id, gap_score = NA_real_)) +# } - gap_scores <- gap_result$field_results - gap_scores$Field_id <- gap_scores$field - gap_scores <- gap_scores[, c("Field_id", "gap_score")] +# gap_scores <- gap_result$field_results +# gap_scores$Field_id <- gap_scores$field +# gap_scores <- gap_scores[, c("Field_id", "gap_score")] - stats::aggregate(gap_score ~ Field_id, data = gap_scores, FUN = function(x) mean(x, na.rm = TRUE)) - }, error = function(e) { - message(paste(" WARNING: Gap score failed for field", field_id, ":", e$message)) - data.frame(Field_id = field_id, gap_score = NA_real_) - }) - } +# stats::aggregate(gap_score ~ Field_id, data = gap_scores, FUN = function(x) mean(x, na.rm = TRUE)) +# }, error = function(e) { +# message(paste(" WARNING: Gap score failed for field", field_id, ":", e$message)) +# data.frame(Field_id = field_id, gap_score = NA_real_) +# }) +# } - # Process fields sequentially with progress bar - message(" Processing gap scores for ", length(per_field_files), " fields...") - pb <- utils::txtProgressBar(min = 0, max = length(per_field_files), style = 3, width = 50) +# # Process fields sequentially with progress bar +# message(" Processing gap scores for ", length(per_field_files), " fields...") +# pb <- utils::txtProgressBar(min = 0, max = length(per_field_files), style = 3, width = 50) - results_list <- lapply(seq_along(per_field_files), function(idx) { - result <- process_gap_for_field(per_field_files[[idx]]) - utils::setTxtProgressBar(pb, idx) - result - }) - close(pb) +# results_list <- lapply(seq_along(per_field_files), function(idx) { +# result <- process_gap_for_field(per_field_files[[idx]]) +# utils::setTxtProgressBar(pb, idx) +# result +# }) +# close(pb) - gap_scores_df <- dplyr::bind_rows(results_list) +# gap_scores_df <- dplyr::bind_rows(results_list) - if (!is.null(gap_scores_df) && nrow(gap_scores_df) > 0) { - gap_scores_df <- gap_scores_df %>% - dplyr::group_by(Field_id) %>% - dplyr::summarise(gap_score = mean(gap_score, na.rm = TRUE), .groups = "drop") +# if (!is.null(gap_scores_df) && nrow(gap_scores_df) > 0) { +# gap_scores_df <- gap_scores_df %>% +# dplyr::group_by(Field_id) %>% +# dplyr::summarise(gap_score = mean(gap_score, na.rm = TRUE), .groups = "drop") - message(paste(" ✓ Calculated gap scores for", nrow(gap_scores_df), "fields")) - message(paste(" Gap score range:", round(min(gap_scores_df$gap_score, na.rm=TRUE), 2), "-", - round(max(gap_scores_df$gap_score, na.rm=TRUE), 2), "%")) - } else { - message(" WARNING: No gap scores calculated from per-field mosaics") - gap_scores_df <- NULL - } +# message(paste(" ✓ Calculated gap scores for", nrow(gap_scores_df), "fields")) +# message(paste(" Gap score range:", round(min(gap_scores_df$gap_score, na.rm=TRUE), 2), "-", +# round(max(gap_scores_df$gap_score, na.rm=TRUE), 2), "%")) +# } else { +# message(" WARNING: No gap scores calculated from per-field mosaics") +# gap_scores_df <- NULL +# } - return(gap_scores_df) -} +# return(gap_scores_df) +# } #' Build complete per-field KPI dataframe with all 22 columns #' @param current_stats data.frame with current week statistics from load_or_calculate_weekly_stats