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_
|
||||
}
|
||||
|
||||
#' 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
|
||||
|
|
|
|||
Loading…
Reference in a new issue