adding functions to create summary definitions from R-Instat data

NAMESPACE

@@ -5,12 +5,20 @@ export(add_data_to_bucket)
 export(add_definitions_to_bucket)
 export(add_summaries_to_bucket)
 export(data_definitions)
+export(extract_value)
 export(gcs_auth_file)
+export(get_annual_rain_definitions)
+export(get_annual_summaries_definitions)
 export(get_binary_file)
 export(get_daily_data)
 export(get_data)
 export(get_definitions_data)
+export(get_end_rains_definitions)
+export(get_end_season_definitions)
 export(get_forecast_data)
+export(get_r_instat_definitions)
+export(get_season_length_definitions)
+export(get_start_rains_definitions)
 export(get_summaries_data)
 export(station_metadata)
 export(station_metadata_definitions)

R/extract_value.R

@@ -0,0 +1,22 @@
+#' Extract Value
+#'
+#' Extracts a specific value from a string using a regular expression.
+#'
+#' @param string The input string.
+#' @param value_expr The regular expression pattern to extract the value.
+#' @param as_numeric Logical indicating whether the extracted value should be converted to numeric.
+#' @return The extracted value.
+#' @export
+#' 
+#' @examples
+#' # Example usage:
+#' extract_value("Example string with value: 123.45", "\\d+(\\.\\d+)?")
+extract_value <- function(string, value_expr, as_numeric = TRUE){
+  if (as_numeric){
+    value <- stringr::str_match(string, paste0(value_expr, "([0-9]+(?:\\.[0-9]+)?)"))[1, 2]
+    value <- as.numeric(value)
+  } else {
+    value <- gsub("\\)", "", stringr::str_match(string, paste0(value_expr, "([^\\s,]+)")))[1, 2]
+  }
+  return(value)
+}

R/get_annual_rain_definitions.R

@@ -0,0 +1,55 @@
+#' Get annual rain definitions
+#'
+#' Retrieves annual rain definitions.
+#'
+#' @param annual_rain The annual rain data.
+#' @param ghana_defs The Ghana definitions.
+#' @return A JSON representation of annual rain definitions.
+#' @export
+#' @examples
+#' # Example usage:
+#' #get_annual_rain_definitions(annual_rain, ghana_defs)
+#' 
+#' # In Progress.
+get_annual_rain_definitions <- function(sum_rain = NULL, n_rain_def = NULL, data_definition){
+  data_list <- list()
+  data_list[["annual_rain"]] <- list()
+  if (is.null(sum_rain) & is.null(n_rain_def)) {
+    return(data_list)
+  }
+
+  if (!is.null(sum_rain)){
+    annual_rain <- "TRUE"
+  } else {
+    annual_rain <- "FALSE"    
+  }
+
+  if (!is.null(n_rain_def)){
+    n_rain <- "TRUE"
+    rain_day <- extract_value(data_definition$count$rain_day[[2]], " >= ", FALSE)
+  } else {
+    n_rain <- "FALSE"    
+  }
+
+  sum_rain <- c(sum_rain, n_rain_def)
+  na_rm <- extract_value(sum_rain$function_exp, "na.rm = ", FALSE)
+  na_n <- extract_value(sum_rain$function_exp, "na_max_n = ", TRUE)
+  na_n_non <- extract_value(sum_rain$function_exp, "na_min_n = ", TRUE)
+  na_consec <- extract_value(sum_rain$function_exp, "na_consecutive_n = ", TRUE)
+  na_prop <- extract_value(sum_rain$function_exp, "na_max_prop = ", TRUE)
+
+  variables_list = c("annual_rain", "n_rain", "rain_day", "na_rm", "na_n",
+                     "na_n_non", "na_consec", "na_prop")
+
+  # Create an empty list
+  data_list <- list()
+  data_list[["annual_rain"]] <- list()
+
+  # Loop through variables and add to the list if defined
+  for (variable in variables_list) {
+    if (exists(variable) && !is.na(get(variable))) {
+      data_list[["annual_rain"]][[variable]] <- get(variable)
+    }
+  }
+  return(data_list)
+}

R/get_annual_summaries_definitions.R

@@ -0,0 +1,39 @@
+#' Get annual summaries definitions
+#'
+#' Retrieves annual summaries definitions including start of rains, end of rains, end of season, seasonal length,
+#' and annual rainfall summaries.
+#'
+#' @param data_name The name of the data.
+#' @param by_definitions_list A list containing definitions for start of rains, end of rains, end of season, and seasonal length.
+#' @param data_definitions_list A list containing data definitions.
+#' @return A JSON representation of annual summaries definitions.
+#' @export
+#' @examples
+#' # Example usage:
+#' #get_annual_summaries_definitions("data_name", by_definitions_list, data_definitions_list)
+get_annual_summaries_definitions <- function(data_name, by_definitions_list, data_definitions_list){
+
+  start_of_rains <- get_start_rains_definitions(by_definitions_list$start_rain)
+  end_rains <- get_end_rains_definitions(by_definitions_list$end_rains)
+  end_season <- get_end_season_definitions(by_definitions_list$end_season)
+  seasonal_length <- get_season_length_definitions(by_definitions_list$seasonal_length)
+
+  # for annual rainfall / rainy days in year:
+  # # 1. check what the rainfall column is called
+  rain_name <- data_book$get_climatic_column_name(data_name = data_name, col_name = "rain")
+  sum_rain <- by_defs[[paste0("sum_", rain_name)]]
+  # 
+  # # 2. check if we have either sum_Rainday or sum_count
+  # # we can tell if there's a count of the number of rainy days by if "count" is a calculation:
+  if (!is.null(ghana_defs$count)){
+    n_rain_def <- c(by_defs$sum_count, by_defs$sum_Rainday)
+  }
+  annual_rain <- get_annual_rain_definitions(sum_rain, n_rain_def, data_definitions_list)
+
+  # Get the list of summaries:
+  summaries_list <- list(start_of_rains, end_rains, end_season, seasonal_length, annual_rain)
+
+  # Convert the list to JSON format
+  data_list <- jsonlite::toJSON(summaries_list, auto_unbox = TRUE, pretty = TRUE)
+  return(data_list)
+}

R/get_end_rains_definitions.R

@@ -0,0 +1,34 @@
+#' Get end rains definitions
+#'
+#' Retrieves end rains definitions.
+#'
+#' @param end_rains The end rains data.
+#' @return A JSON representation of end rains definitions.
+#' @export
+#' @examples
+#' # Example usage:
+#' #get_end_rains_definitions(end_rains)
+get_end_rains_definitions <- function(end_rains){
+  # Create an empty list
+  data_list <- list()
+  data_list[["end_rains"]] <- list()
+  if (is.null(end_rains)) {
+    return(data_list)
+  }
+  start_day <- extract_value(end_rains$filter_2, " >= ")
+  end_day <- extract_value(end_rains$filter_2, " <= ")
+  output <- "both"
+  min_rainfall <- extract_value(end_rains$filter[[1]], "roll_sum_rain > ")
+  interval_length <- extract_value(end_rains$filter$roll_sum_rain[[2]], "n=")
+
+  variables_list = c("start_day", "end_day",  "output", "min_rainfall", "interval_length")
+
+  # Loop through variables and add to the list if defined
+  for (variable in variables_list) {
+    if (exists(variable) && !is.na(get(variable))) {
+      data_list[["end_rains"]][[variable]] <- get(variable)
+    }
+  }
+
+  return(data_list)
+}

R/get_end_season_definitions.R

@@ -0,0 +1,42 @@
+#' Get end of season definitions
+#'
+#' Retrieves end season definitions.
+#'
+#' @param end_season The end season data.
+#' @return A JSON representation of end season definitions.
+#' @export
+#' @examples
+#' # Example usage:
+#' #get_end_season_definitions(end_season)
+get_end_season_definitions <- function(end_season){
+  # Create an empty list
+  data_list <- list()
+  data_list[["end_season"]] <- list()
+  if (is.null(end_season))  {
+    return(data_list)
+  }
+
+  start_day <- extract_value(end_season$filter_2, " >= ")
+  end_day <- extract_value(end_season$filter_2, " <= ")
+  output <- "both"
+  water_balance_max <- extract_value(end_season$filter[[1]], "wb <= ")
+  capacity <- extract_value(end_season$filter$wb$wb_max$rain_max[[2]], "yes=")
+  evaporation_value <- extract_value(end_season$filter$wb$wb_max[[1]], "rain_max - ")
+  if (is.na(evaporation_value)){
+    evaporation_value <- extract_value(end_season$filter$wb$wb_max[[1]], "no=", FALSE)
+    evaporation <- "variable"
+  } else {
+    evaporation <- "value"
+  }
+
+  variables_list <- c("start_day", "end_day",  "output", "water_balance_max",
+                      "capacity", "evaporation", "evaporation_value")
+
+  # Loop through variables and add to the list if defined
+  for (variable in variables_list) {
+    if (exists(variable) && !is.na(get(variable))) {
+      data_list[["end_season"]][[variable]] <- get(variable)
+    }
+  }
+  return(data_list)
+}

R/get_r_instat_definitions.R

@@ -0,0 +1,57 @@
+#' Get R-Instat definitions
+#'
+#' Retrieves R-Instat definitions based on given calculations.
+#'
+#' @param calculation A list of calculations.
+#' 
+#' @return A list of R-Instat definitions.
+#' @export
+#' 
+#' @examples
+#' # Example usage:
+#' #get_r_instat_definitions()
+get_r_instat_definitions <- function(calculation){
+  manips <- NULL
+  type <- NULL
+  for (i in 1:length(calculation)){
+    calc <- calculation[[i]]
+    type[i] <- calc$type
+    if (type[i] == "summary"){
+      # this will tell us if it is DOY or date (or both)
+      # want recursive here:
+      # run the function with 
+      manips[[i]] <- c(variables = calc$calculated_from,
+                       function_exp = calc$function_exp, 
+                       get_r_instat_definitions(calculation = calc$manipulations))
+      type[i] <- calc$result_name
+    } else if (type[i] == "by"){
+      manips[[i]] <- calc$calculated_from
+      type[i] <- paste0("by_", i)
+    } else if (type[i] == "filter"){
+      if (length(calc$sub_calculations) > 0){
+        manips[[i]] <- c(calc$function_exp, get_r_instat_definitions(calculation = calc$sub_calculations))
+        type[i] <- paste0("filter")
+      } else {
+        manips[[i]] <- calc$function_exp
+        type[i] <- paste0("filter_2")
+      }
+    } else if (type[i] == "calculation"){
+      if (length(calc$sub_calculations) > 0){
+        manips[[i]] <- c(calc$function_exp, get_r_instat_definitions(calculation = calc$sub_calculations))
+        type[i] <- calc$result_name
+      } else {
+        if (length(calc$calculated_from) > 0){
+          manips[[i]] <- c(calc$calculated_from, calc$function_exp)        
+        } else {
+          manips[[i]] <- calc$function_exp
+        }
+        type[i] <- calc$result_name
+      }
+      type[i] <- calc$result_name
+    }
+  }
+  if (!is.null(manips)){
+    names(manips) <- type
+  }
+  return(manips)
+}

R/get_season_length_definitions.R

@@ -0,0 +1,31 @@
+#' Get season length definitions
+#'
+#' Retrieves season length definitions.
+#'
+#' @param length The season length data.
+#' @return A JSON representation of season length definitions.
+#' @export
+#' @examples
+#' # Example usage:
+#' #get_season_length_definitions(length)
+get_season_length_definitions <- function(length){ # TODO: it should be called "season" not "end_season"
+  # Create an empty list
+  data_list <- list()
+  data_list[["length"]] <- list()
+  if (is.null(length)) {
+    return(data_list)
+  }
+
+  end_type <- sub(" - .*", "", length[[3]])
+  end_type <- sub(".*?_", "", end_type)
+
+  variables_list <- c("end_type")
+
+  # Loop through variables and add to the list if defined
+  for (variable in variables_list) {
+    if (exists(variable) && !is.na(get(variable))) {
+      data_list[["seasonal_length"]][[variable]] <- get(variable)
+    }
+  }
+  return(data_list)
+}

R/get_start_rains_definitions.R

@@ -0,0 +1,78 @@
+#' Get start of rains definitions
+#'
+#' Retrieves start rains definitions.
+#'
+#' @param start_rains The start rains data.
+#' @return A JSON representation of start rains definitions.
+#' @export
+#' @examples
+#' # Example usage:
+#' #get_start_rains_definitions(start_rains)
+get_start_rains_definitions <- function(start_rains){
+  # Create an empty list
+  data_list <- list()
+  data_list[["start_rains"]] <- list()
+  if (is.null(start_rains)) {
+    return(data_list)
+  }
+
+  start_day <- extract_value(start_rains$filter_2, " >= ")
+  end_day <- extract_value(start_rains$filter_2, " <= ")
+  output <- "both"
+
+  # Important! Assuming that threshold is the first argument!
+  threshold <- extract_value(start_rains$filter[[1]], " >= ")
+
+  # if null, then we didn't run it so set that to be false in definitions file.
+  if (is.null(start_rains$filter$roll_sum_rain)){
+    total_rainfall <- FALSE  
+  } else {
+    total_rainfall <- TRUE
+    if (is.null(start_rains$filter$wet_spell)){
+      over_days <- extract_value(start_rains$filter[[1]], "roll_sum_rain > ")
+      amount_rain <- extract_value(start_rains$filter$roll_sum_rain[[2]], "n=")
+      proportion <- FALSE
+    } else {
+      over_days <- extract_value(start_rains$filter$wet_spell$roll_sum_rain[[2]], "n=")
+      prob_rain_day <- extract_value(start_rains$filter$wet_spell[[1]], "probs=")
+      proportion <- TRUE
+    }
+  }
+  if (is.null(start_rains$filter$roll_n_rain_days)){
+    number_rain_days <- FALSE 
+  } else {
+    number_rain_days <- TRUE
+    min_rain_days <- extract_value(start_rains$filter[[1]], "roll_n_rain_days >= ")
+    rain_day_interval <- extract_value(start_rains$filter$roll_n_rain_days[[1]], "n=")
+  }
+  if (is.null(start_rains$filter$roll_max_dry_spell)){
+    dry_spell <- FALSE
+  } else {
+    dry_spell <- TRUE
+    spell_max_dry_days <- extract_value(start_rains$filter[[1]], "roll_max_dry_spell <= ")
+    spell_interval <- extract_value(start_rains$filter$roll_max_dry_spell[[1]], "n=")
+  }
+  if (is.null(start_rains$filter$n_dry_period)){
+    dry_period <- FALSE
+  } else {
+    dry_period <- TRUE
+    max_rain <- extract_value(start_rains$filter$n_dry_period[[1]], "roll_sum_rain_dry_period <= ")
+    period_interval <- extract_value(start_rains$filter$n_dry_period[[1]], "n=")
+    period_max_dry_days <- extract_value(start_rains$filter$n_dry_period[[1]],
+                                         paste0("n=", period_interval, " - "))
+  }
+
+  # Create a list
+  variables_list = c("start_day", "end_day", "threshold", "total_rainfall", 
+                     "over_days", "amount_rain", "proportion", "prob_rain_day", 
+                     "dry_spell", "spell_max_dry_days", "spell_interval", 
+                     "dry_period", "max_rain", "period_interval", "period_max_dry_days")
+
+  # Loop through variables and add to the list if defined
+  for (variable in variables_list) {
+    if (exists(variable) && !is.na(get(variable))) {
+      data_list[["start_rains"]][[variable]] <- get(variable)
+    }
+  }
+  return(data_list)
+}