remove gap score calculation --> moved to common
This commit is contained in:
DimitraVeropoulou
parent
35e474cf5c
commit
5f2dca0a92
|
|
@ -166,153 +166,153 @@ calculate_status_alert <- function(imminent_prob, age_week, weekly_ci_change, me
|
||||||
NA_character_
|
NA_character_
|
||||||
}
|
}
|
||||||
|
|
||||||
#' Calculate Gap Filling Score KPI (2σ method)
|
# #' Calculate Gap Filling Score KPI (2σ method)
|
||||||
#' @param ci_raster Current week CI raster
|
# #' @param ci_raster Current week CI raster
|
||||||
#' @param field_boundaries Field boundaries
|
# #' @param field_boundaries Field boundaries
|
||||||
#' @return Data frame with field-level gap filling scores
|
# #' @return Data frame with field-level gap filling scores
|
||||||
calculate_gap_filling_kpi <- function(ci_raster, field_boundaries) {
|
# calculate_gap_filling_kpi <- function(ci_raster, field_boundaries) {
|
||||||
safe_log("Calculating Gap Filling Score KPI (placeholder)")
|
# safe_log("Calculating Gap Filling Score KPI (placeholder)")
|
||||||
|
|
||||||
# Handle both sf and SpatVector inputs
|
# # Handle both sf and SpatVector inputs
|
||||||
if (!inherits(field_boundaries, "SpatVector")) {
|
# if (!inherits(field_boundaries, "SpatVector")) {
|
||||||
field_boundaries_vect <- terra::vect(field_boundaries)
|
# field_boundaries_vect <- terra::vect(field_boundaries)
|
||||||
} else {
|
# } else {
|
||||||
field_boundaries_vect <- field_boundaries
|
# field_boundaries_vect <- field_boundaries
|
||||||
}
|
# }
|
||||||
|
|
||||||
# Ensure field_boundaries_vect is valid and matches field_boundaries dimensions
|
# # Ensure field_boundaries_vect is valid and matches field_boundaries dimensions
|
||||||
n_fields_vect <- length(field_boundaries_vect)
|
# n_fields_vect <- length(field_boundaries_vect)
|
||||||
n_fields_sf <- nrow(field_boundaries)
|
# n_fields_sf <- nrow(field_boundaries)
|
||||||
|
|
||||||
if (n_fields_sf != n_fields_vect) {
|
# 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."))
|
# 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))) {
|
# for (i in seq_len(nrow(field_boundaries))) {
|
||||||
field_name <- field_boundaries$field[i]
|
# field_name <- field_boundaries$field[i]
|
||||||
sub_field_name <- field_boundaries$sub_field[i]
|
# sub_field_name <- field_boundaries$sub_field[i]
|
||||||
field_vect <- field_boundaries_vect[i]
|
# field_vect <- field_boundaries_vect[i]
|
||||||
|
|
||||||
# Extract CI values using helper function
|
# # Extract CI values using helper function
|
||||||
ci_values <- extract_ci_values(ci_raster, field_vect)
|
# ci_values <- extract_ci_values(ci_raster, field_vect)
|
||||||
valid_values <- ci_values[!is.na(ci_values) & is.finite(ci_values)]
|
# valid_values <- ci_values[!is.na(ci_values) & is.finite(ci_values)]
|
||||||
|
|
||||||
if (length(valid_values) > 1) {
|
# if (length(valid_values) > 1) {
|
||||||
# Gap score using 2σ below median to detect outliers
|
# # Gap score using 2σ below median to detect outliers
|
||||||
median_ci <- median(valid_values)
|
# median_ci <- median(valid_values)
|
||||||
sd_ci <- sd(valid_values)
|
# sd_ci <- sd(valid_values)
|
||||||
outlier_threshold <- median_ci - (2 * sd_ci)
|
# outlier_threshold <- median_ci - (2 * sd_ci)
|
||||||
low_ci_pixels <- sum(valid_values < outlier_threshold)
|
# low_ci_pixels <- sum(valid_values < outlier_threshold)
|
||||||
total_pixels <- length(valid_values)
|
# total_pixels <- length(valid_values)
|
||||||
gap_score <- round((low_ci_pixels / total_pixels) * 100, 2)
|
# gap_score <- round((low_ci_pixels / total_pixels) * 100, 2)
|
||||||
|
|
||||||
# Classify gap severity
|
# # Classify gap severity
|
||||||
gap_level <- dplyr::case_when(
|
# gap_level <- dplyr::case_when(
|
||||||
gap_score < 10 ~ "Minimal",
|
# gap_score < 10 ~ "Minimal",
|
||||||
gap_score < 25 ~ "Moderate",
|
# gap_score < 25 ~ "Moderate",
|
||||||
TRUE ~ "Significant"
|
# TRUE ~ "Significant"
|
||||||
)
|
# )
|
||||||
|
|
||||||
field_results <- rbind(field_results, data.frame(
|
# field_results <- rbind(field_results, data.frame(
|
||||||
field = field_name,
|
# field = field_name,
|
||||||
sub_field = sub_field_name,
|
# sub_field = sub_field_name,
|
||||||
gap_level = gap_level,
|
# gap_level = gap_level,
|
||||||
gap_score = gap_score,
|
# gap_score = gap_score,
|
||||||
mean_ci = mean(valid_values),
|
# mean_ci = mean(valid_values),
|
||||||
outlier_threshold = outlier_threshold
|
# outlier_threshold = outlier_threshold
|
||||||
))
|
# ))
|
||||||
} else {
|
# } else {
|
||||||
# Not enough valid data, fill with NA row
|
# # Not enough valid data, fill with NA row
|
||||||
field_results <- rbind(field_results, data.frame(
|
# field_results <- rbind(field_results, data.frame(
|
||||||
field = field_name,
|
# field = field_name,
|
||||||
sub_field = sub_field_name,
|
# sub_field = sub_field_name,
|
||||||
gap_level = NA_character_,
|
# gap_level = NA_character_,
|
||||||
gap_score = NA_real_,
|
# gap_score = NA_real_,
|
||||||
mean_ci = NA_real_,
|
# mean_ci = NA_real_,
|
||||||
outlier_threshold = NA_real_
|
# outlier_threshold = NA_real_
|
||||||
))
|
# ))
|
||||||
}
|
# }
|
||||||
}
|
# }
|
||||||
return(list(field_results = field_results))
|
# return(list(field_results = field_results))
|
||||||
}
|
# }
|
||||||
|
|
||||||
|
|
||||||
#' Calculate gap filling scores for all per-field mosaics
|
# #' Calculate gap filling scores for all per-field mosaics
|
||||||
#' This is a wrapper function that processes multiple per-field mosaic files
|
# #' This is a wrapper function that processes multiple per-field mosaic files
|
||||||
#' and calculates gap scores for each field.
|
# #' and calculates gap scores for each field.
|
||||||
#' @param per_field_files Character vector of paths to per-field mosaic TIFFs
|
# #' @param per_field_files Character vector of paths to per-field mosaic TIFFs
|
||||||
#' @param field_boundaries_sf sf object with field geometries
|
# #' @param field_boundaries_sf sf object with field geometries
|
||||||
#' @return data.frame with Field_id and gap_score columns
|
# #' @return data.frame with Field_id and gap_score columns
|
||||||
calculate_gap_scores <- function(per_field_files, field_boundaries_sf) {
|
# calculate_gap_scores <- function(per_field_files, field_boundaries_sf) {
|
||||||
message("\nCalculating gap filling scores (2σ method)...")
|
# message("\nCalculating gap filling scores (2σ method)...")
|
||||||
message(paste(" Using per-field mosaics for", length(per_field_files), "fields"))
|
# 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) {
|
# process_gap_for_field <- function(field_file) {
|
||||||
field_id <- basename(dirname(field_file))
|
# field_id <- basename(dirname(field_file))
|
||||||
field_bounds <- field_boundaries_by_id[[field_id]]
|
# field_bounds <- field_boundaries_by_id[[field_id]]
|
||||||
|
|
||||||
if (is.null(field_bounds) || nrow(field_bounds) == 0) {
|
# if (is.null(field_bounds) || nrow(field_bounds) == 0) {
|
||||||
return(data.frame(Field_id = field_id, gap_score = NA_real_))
|
# return(data.frame(Field_id = field_id, gap_score = NA_real_))
|
||||||
}
|
# }
|
||||||
|
|
||||||
tryCatch({
|
# tryCatch({
|
||||||
field_raster <- terra::rast(field_file)
|
# field_raster <- terra::rast(field_file)
|
||||||
ci_band_name <- "CI"
|
# ci_band_name <- "CI"
|
||||||
if (!(ci_band_name %in% names(field_raster))) {
|
# if (!(ci_band_name %in% names(field_raster))) {
|
||||||
return(data.frame(Field_id = field_id, gap_score = NA_real_))
|
# return(data.frame(Field_id = field_id, gap_score = NA_real_))
|
||||||
}
|
# }
|
||||||
field_ci_band <- field_raster[[ci_band_name]]
|
# field_ci_band <- field_raster[[ci_band_name]]
|
||||||
names(field_ci_band) <- "CI"
|
# 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) {
|
# 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_))
|
# return(data.frame(Field_id = field_id, gap_score = NA_real_))
|
||||||
}
|
# }
|
||||||
|
|
||||||
gap_scores <- gap_result$field_results
|
# gap_scores <- gap_result$field_results
|
||||||
gap_scores$Field_id <- gap_scores$field
|
# gap_scores$Field_id <- gap_scores$field
|
||||||
gap_scores <- gap_scores[, c("Field_id", "gap_score")]
|
# 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))
|
# stats::aggregate(gap_score ~ Field_id, data = gap_scores, FUN = function(x) mean(x, na.rm = TRUE))
|
||||||
}, error = function(e) {
|
# }, error = function(e) {
|
||||||
message(paste(" WARNING: Gap score failed for field", field_id, ":", e$message))
|
# message(paste(" WARNING: Gap score failed for field", field_id, ":", e$message))
|
||||||
data.frame(Field_id = field_id, gap_score = NA_real_)
|
# data.frame(Field_id = field_id, gap_score = NA_real_)
|
||||||
})
|
# })
|
||||||
}
|
# }
|
||||||
|
|
||||||
# Process fields sequentially with progress bar
|
# # Process fields sequentially with progress bar
|
||||||
message(" Processing gap scores for ", length(per_field_files), " fields...")
|
# message(" Processing gap scores for ", length(per_field_files), " fields...")
|
||||||
pb <- utils::txtProgressBar(min = 0, max = length(per_field_files), style = 3, width = 50)
|
# pb <- utils::txtProgressBar(min = 0, max = length(per_field_files), style = 3, width = 50)
|
||||||
|
|
||||||
results_list <- lapply(seq_along(per_field_files), function(idx) {
|
# results_list <- lapply(seq_along(per_field_files), function(idx) {
|
||||||
result <- process_gap_for_field(per_field_files[[idx]])
|
# result <- process_gap_for_field(per_field_files[[idx]])
|
||||||
utils::setTxtProgressBar(pb, idx)
|
# utils::setTxtProgressBar(pb, idx)
|
||||||
result
|
# result
|
||||||
})
|
# })
|
||||||
close(pb)
|
# 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) {
|
# if (!is.null(gap_scores_df) && nrow(gap_scores_df) > 0) {
|
||||||
gap_scores_df <- gap_scores_df %>%
|
# gap_scores_df <- gap_scores_df %>%
|
||||||
dplyr::group_by(Field_id) %>%
|
# dplyr::group_by(Field_id) %>%
|
||||||
dplyr::summarise(gap_score = mean(gap_score, na.rm = TRUE), .groups = "drop")
|
# 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(" ✓ 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), "-",
|
# 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), "%"))
|
# round(max(gap_scores_df$gap_score, na.rm=TRUE), 2), "%"))
|
||||||
} else {
|
# } else {
|
||||||
message(" WARNING: No gap scores calculated from per-field mosaics")
|
# message(" WARNING: No gap scores calculated from per-field mosaics")
|
||||||
gap_scores_df <- NULL
|
# gap_scores_df <- NULL
|
||||||
}
|
# }
|
||||||
|
|
||||||
return(gap_scores_df)
|
# return(gap_scores_df)
|
||||||
}
|
# }
|
||||||
|
|
||||||
#' Build complete per-field KPI dataframe with all 22 columns
|
#' 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
|
#' @param current_stats data.frame with current week statistics from load_or_calculate_weekly_stats
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue