Feature/various bugfixes (#305)

* fixes #277 * fixes #280 * fixes #282 * clean-up * fixes #277 * fixes #280 * fixes #282 * clean-up * fix condition sequencing * refactoring, simplification of reactivity prevent API queries if analysis status is NEW * reactivity improvement * reactivity improvement * check status of analysis before querying API extend drops from total table to include new fields * qualify log messages * fixes #292 (add logging / warnings for query issues) * fixes #299 also improve reactivity * simplified / enhanced reactivity retired old logic with auxiliary variables that became obsolete * improved / straightened reactivity related to #299
OasisLMF · Jan 31, 2023 · aa7761a · aa7761a
1 parent 48474fe
commit aa7761a
Show file tree

Hide file tree

Showing 13 changed files with 250 additions and 149 deletions.
diff --git a/BFE_RShiny/oasisui/R/API_utils.R b/BFE_RShiny/oasisui/R/API_utils.R
@@ -14,10 +14,18 @@
 showname <- function(x) {
   if (length(x) > 1) {
     y <- x$name
+    # 282
+    if (is.null(y)) y <- paste(unlist(x), collapse = ", ")
   } else if (length(x) == 0) {
     y <- "Not Available"
   } else {
-    y <- x
+    # length of 1
+    if (is.list(x)) {
+      # 282
+      y <- paste(unlist(x), collapse = ", ")
+    } else {
+      y <- x
+    }
   }
   y
 }

diff --git a/BFE_RShiny/oasisui/R/exposurevalidation_map_module.R b/BFE_RShiny/oasisui/R/exposurevalidation_map_module.R
@@ -141,46 +141,24 @@ exposurevalidationmap <- function(input,
     analysisID()
   }, {
     if (length(active()) > 0 && active() && counter() > 0 && !is.null(analysisID())) {
-      .reloadExposureValidation()
+      retReload <- .reloadExposureValidation()
       perils <- result$uploaded_locs_check$peril[!is.na(result$uploaded_locs_check$peril)] %>%
         unique()
       mapping <- session$userData$data_hub$get_oed_peril_codes_mapping()
       mapped_perils <- lapply(mapping[perils], function(x) {x[["desc"]]})
       result$perils_names <- unlist(mapped_perils,  use.names = FALSE)
-      result$peril_codes <- names(mapped_perils)
+      result$perils_codes <- names(mapped_perils)
       logMessage("Updating input$chkgrp_perils")
       updateCheckboxGroupInput(session, inputId = "chkgrp_perils", choices = as.list(perils), selected = as.list(perils))
     }
   })
 
-  observeEvent({input$chkgrp_perils
-    result$uploaded_locs_check}, ignoreNULL = FALSE, {
-      if (!is.null(result$uploaded_locs_check) && nrow(result$uploaded_locs_check) > 0) {
-        if (is.null(input$chkgrp_perils)) {
-          result$uploaded_locs_check_peril <- result$uploaded_locs_check %>%
-            mutate(modeled = NA)
-          if (any(grepl(".x", names(result$uploaded_locs_check_peril)))) {
-            names(result$uploaded_locs_check_peril) <- gsub(".x", "", names(result$uploaded_locs_check_peril))
-          }
-          names(result$uploaded_locs_check_peril) <- tolower(names(result$uploaded_locs_check_peril))
-        } else {
-          result$uploaded_locs_check_peril <- result$uploaded_locs_check %>%
-            # filter(peril_id %in% input$chkgrp_perils) %>%
-            mutate(modeled = case_when(
-              is.na(peril_id) ~ FALSE,
-              peril_id %in% input$chkgrp_perils ~ TRUE,
-              TRUE ~ NA)
-            ) %>%
-            filter(!is.na(modeled)) %>%
-            select(-peril_id) %>%
-            distinct()
-          if (any(grepl(".x", names(result$uploaded_locs_check_peril)))) {
-            names(result$uploaded_locs_check_peril) <- gsub(".x", "", names(result$uploaded_locs_check_peril))
-          }
-          names(result$uploaded_locs_check_peril) <- tolower(names(result$uploaded_locs_check_peril))
-        }
-      }
-    })
+  observeEvent({input$chkgrp_perils}, ignoreNULL = FALSE, {
+    # note that updateCheckboxGroupInput() manifests late, like any client input
+    # update that needs to ultimately receive a message back from client to
+    # server.
+    .updateUploadedLocsCheckPeril()
+  })
 
   # Show/Hide table button -----------------------------------------------------
   observeEvent(result$uploaded_locs_check_peril, ignoreNULL = FALSE, {
@@ -243,9 +221,10 @@ exposurevalidationmap <- function(input,
 
   # Map ------------------------------------------------------------------------
   output$exposure_map <- renderLeaflet({
+    # this should be called only once for a single analysis map load (i.e. once for initial NULL is fine, but otherwise 2x wouldn't be great)
     if (!is.null(result$uploaded_locs_check_peril) && nrow(result$uploaded_locs_check_peril) > 0) {
-      result$uploaded_locs_check_peril <- result$uploaded_locs_check_peril[, colSums(is.na(result$uploaded_locs_check_peril)) != nrow(result$uploaded_locs_check_peril)]
-      .createExposureValMap(result$uploaded_locs_check_peril)
+      sanitized_tbl <- result$uploaded_locs_check_peril[, colSums(is.na(result$uploaded_locs_check_peril)) != nrow(result$uploaded_locs_check_peril)]
+      .createExposureValMap(sanitized_tbl)
     } else {
       NULL
     }
@@ -308,7 +287,7 @@ exposurevalidationmap <- function(input,
                                                                                         weight = 5,
                                                                                         bringToFront = FALSE,
                                                                                         opacity = 1))
-        #re-set damage ratio everytime the user re-clicks on the map
+        # re-set damage ratio every time the user re-clicks on the map
         updateNumericInput(session, "damage_ratio", value = 100)
 
         if (is.null(input$damage_ratio)) {
@@ -372,7 +351,7 @@ exposurevalidationmap <- function(input,
         if (is.null(country_num)) {
           # if country_num is null, then do nothing
         } else {
-          #get set of coordinates for selected country
+          # get set of coordinates for selected country
           country_js <- js_lite$features$geometry$coordinates[[country_num]]
           if (class(country_js) == "list") {
             lati <- na.omit(unlist(lapply(seq_len(length(country_js)), function(x) {
@@ -506,7 +485,10 @@ exposurevalidationmap <- function(input,
   observeEvent(input$abuttonexposurerefresh, {
     # Get modeled locations
     withModalSpinner(
-      .reloadExposureValidation(),
+      {
+        retReload <- .reloadExposureValidation()
+        if (retReload) .updateUploadedLocsCheckPeril()
+      },
       "Refreshing...",
       size = "s", t = 0.5
     )
@@ -516,10 +498,51 @@ exposurevalidationmap <- function(input,
   # dummy for exposure location comparison
   .reloadExposureValidation <- function() {
     logMessage(".reloadExposureValidation called")
-    uploaded_locs_check <- check_loc(analysisID(), portfolioID(), data_hub = session$userData$data_hub)
+    anaStatus <- session$userData$oasisapi$api_return_query_res(
+      query_path = paste("analyses", analysisID(), sep = "/"),
+      query_method = "GET"
+    )[["status"]]
+    if (anaStatus == "NEW") {
+      uploaded_locs_check <- NULL
+    } else {
+      uploaded_locs_check <- check_loc(analysisID(), portfolioID(), data_hub = session$userData$data_hub)
+    }
     # updating reactive only when needed
-    if (!identical(uploaded_locs_check,result$uploaded_locs_check)) {
+    if (!identical(uploaded_locs_check, result$uploaded_locs_check)) {
       result$uploaded_locs_check <- uploaded_locs_check
+      logMessage(".reloadExposureValidation output TRUE")
+      return(1)
+    }
+    return(0)
+  }
+
+  # util to update result$uploaded_locs_check_peril
+  .updateUploadedLocsCheckPeril <- function() {
+    if (!is.null(result$uploaded_locs_check) && nrow(result$uploaded_locs_check) > 0) {
+      if (is.null(input$chkgrp_perils)) {
+        tmp <- result$uploaded_locs_check %>%
+          mutate(modeled = NA)
+        if (any(grepl(".x", names(tmp)))) {
+          names(tmp) <- gsub(".x", "", names(tmp))
+        }
+        names(tmp) <- tolower(names(tmp))
+      } else {
+        tmp <- result$uploaded_locs_check %>%
+          # filter(peril_id %in% input$chkgrp_perils) %>%
+          mutate(modeled = case_when(
+            is.na(peril_id) ~ FALSE,
+            peril_id %in% input$chkgrp_perils ~ TRUE,
+            TRUE ~ NA)
+          ) %>%
+          filter(!is.na(modeled)) %>%
+          select(-peril_id) %>%
+          distinct()
+        if (any(grepl(".x", names(tmp)))) {
+          names(tmp) <- gsub(".x", "", names(tmp))
+        }
+        names(tmp) <- tolower(names(tmp))
+      }
+      result$uploaded_locs_check_peril <- tmp
     }
     invisible()
   }
@@ -528,10 +551,9 @@ exposurevalidationmap <- function(input,
   .createExposureValMap <- function(df) {
     marker_colors <- c('green', 'red')
     # if ("Latitude" %in% colnames(df)) {
-    # colnames(df) <- tolower(colnames(df))
+    #   colnames(df) <- tolower(colnames(df))
     # }
-
-    if (is.null(input$chkgrp_perils)) {
+    if (is.null(isolate(input$chkgrp_perils))) {  # input$chkgrp_perils isolated to prevent redundant reactivity.
       icon_map <- NULL
       df <- df
       leaflet(df) %>%
@@ -542,7 +564,7 @@ exposurevalidationmap <- function(input,
         mutate(modeled = case_when(
           modeled == "TRUE" ~ 1,
           TRUE ~ 2
-        )) %>% build_marker_data(session = session, paramID = analysisID(), step = "Validation Map")
+        )) %>% build_marker_data(session = session, paramID = isolate(analysisID()), step = "Validation Map")
 
       icon_map <- awesomeIcons(
         icon = 'map-marker-alt',

diff --git a/BFE_RShiny/oasisui/R/exposurevalidation_summary_module.R b/BFE_RShiny/oasisui/R/exposurevalidation_summary_module.R
@@ -108,28 +108,39 @@ exposurevalidationsummary <- function(input,
     analysisID()
   }, {
     if (length(active()) > 0 && active() && counter() > 0) {
-      result$summary_tbl <- session$userData$data_hub$get_ana_validation_summary_content(analysisID())
-      result$perils <- unique(result$summary_tbl$peril)
-      keys_errors <- session$userData$data_hub$get_ana_errors_summary_content(id = analysisID())
-
-      result$peril_id <- unique(keys_errors$PerilID)
-      if (is.null(result$perils)) {
-        result$peril_choices <- "no perils available for summary"
-      } else if (!is.null(result$perils) && length(result$peril_id) == 0) {
-        result$peril_choices <- result$perils
+      # note this will remain TRUE as the active tab when switching to step 3!
+      # We should get the analysis first to check the status and only continue
+      # if the status is > than NEW, otherwise subsequent queries won't work.
+      anaStatus <- session$userData$oasisapi$api_return_query_res(
+        query_path = paste("analyses", analysisID(), sep = "/"),
+        query_method = "GET"
+      )[["status"]]
+      if (anaStatus == "NEW") {
+        # chill
       } else {
-        result$peril_choices <- paste0(result$perils, " (", result$peril_id, ")")
-      }
-      # remove "total" entry in peril choices
-      peril_choices_filter <- result$peril_choices[-grep("total", result$peril_choices)]
-      #peril_choices_filter <- result$peril_choices[result$peril_choices != "total"]
+        result$summary_tbl <- session$userData$data_hub$get_ana_validation_summary_content(analysisID())
+        result$perils <- unique(result$summary_tbl$peril)
+        keys_errors <- session$userData$data_hub$get_ana_errors_summary_content(id = analysisID())
+
+        result$peril_id <- unique(keys_errors$PerilID)  # just for adding labels if available
+        if (is.null(result$perils)) {
+          result$peril_choices <- "no perils available for summary"
+        } else if (!is.null(result$perils) && length(result$peril_id) == 0) {
+          result$peril_choices <- result$perils
+        } else {
+          result$peril_choices <- paste0(result$perils, " (", result$peril_id, ")")
+        }
+        # remove "total" entry in peril choices
+        peril_choices_filter <- result$peril_choices[-grep("total", result$peril_choices)]
+        #peril_choices_filter <- result$peril_choices[result$peril_choices != "total"]
 
-      checkChange <- identical(input$input_peril, peril_choices_filter)
-      updateSelectInput(session, inputId = "input_peril", choices = peril_choices_filter, selected = peril_choices_filter)
-      # if above "updateSelectInput" leaves input_peril the same, we still want to call .reloadSummary once
-      if (checkChange) {
-        .reloadSummary(input$input_peril)
-        .reloadSummary_total(result$peril_choices)
+        checkChange <- identical(input$input_peril, peril_choices_filter)
+        updateSelectInput(session, inputId = "input_peril", choices = peril_choices_filter, selected = peril_choices_filter)
+        # if above "updateSelectInput" leaves input_peril the same, we still want to call .reloadSummary once
+        if (checkChange) {
+          .reloadSummary(input$input_peril)
+          .reloadSummary_total(result$peril_choices)
+        }
       }
     }
   })
@@ -155,7 +166,7 @@ exposurevalidationsummary <- function(input,
       sum_tot_filter$portfolio <- add_commas(sum_tot_filter$portfolio)
 
       # drop unnecessary columns
-      drops <- c("all", "fail", "success", "nomatch")
+      drops <- c("all", "fail", "fail_ap", "fail_v", "success", "nomatch", "notatrisk", "noreturn")
       sum_tot_filter <- sum_tot_filter[, !(names(sum_tot_filter) %in% drops)]
 
       datatable(
@@ -223,9 +234,9 @@ exposurevalidationsummary <- function(input,
   .extract_df_plot <- function(df) {
     df <- df %>%
       filter(type %in% type_to_plot) %>%
-      mutate(fail = 100*fail/all,
-             success = 100*success/all,
-             nomatch = 100*nomatch/all,
+      mutate(fail = 100 * fail / all,
+             success = 100 * success / all,
+             nomatch = 100 * nomatch / all,
              all = NULL) %>%
       gather(key, value, factor_key = TRUE, -c(peril, type)) %>%
       mutate(peril = as.factor(peril),
@@ -237,17 +248,21 @@ exposurevalidationsummary <- function(input,
   .plot_stack_hist <- function(df) {
     brks <- c(0, 25, 50, 75, 100)
     lbs <- c("0%", "25%", "50%", "75%", "100%")
-    # n_plots_row <- ifelse(length(unique(df$peril)) < 4, length(unique(df$peril)), 4)
-    n_plots_row <- length(unique(df$peril))
+
     # leave only: Fail, Success and Nomatch statuses and remove peril "total"
     key_unwanted <- c("portfolio", "not-modelled", "modelled")
     df <- df %>% filter(key %notin% key_unwanted)
+    # 280: after more detailed keys had been added to the API, the exclusions
+    # above weren't sufficient anymore. Pick fail, success and nomatch
+    # explicitly as done in .extract_df_plot().
+    df <- df %>% filter(key %in% c("fail", "success", "nomatch"))
 
     if (length(grep("total", df$peril)) > 0) {
       df <- df[-grep("total", df$peril), ]
     }
     status <- df$key
     percentage <- df$value
+    n_plots_row <- length(unique(df$peril))
 
     p <- ggplot(data = df, aes(x = type, y = percentage, fill = status)) +
       theme(

diff --git a/BFE_RShiny/oasisui/R/modelParams_funs.R b/BFE_RShiny/oasisui/R/modelParams_funs.R
@@ -13,7 +13,7 @@ basicConfig_funs <- function(session, model_settings) {
   # Event set
   .event_set_fun <- function(model_settings) {
     # 291 - allow event_set and event_occurrence_id to be missing for certain models, in which case we will simply have no basic params:
-    if (!is.null(model_settings$event_set.name) && is.null(model_settings$event_set.used_for) || model_settings$event_set.used_for == "losses") {
+    if (!is.null(model_settings$event_set.name) && (is.null(model_settings$event_set.used_for) || model_settings$event_set.used_for == "losses")) {
       selectChoices <- lapply(model_settings$event_set.options, function(x) {
         x$id
       })
@@ -34,7 +34,7 @@ basicConfig_funs <- function(session, model_settings) {
 
   # Event occurrence
   .event_occurrence_fun <- function(model_settings) {
-    if (!is.null(model_settings$event_occurrence_id.name) && is.null(model_settings$event_occurrence_id.used_for) || model_settings$event_occurrence_id.used_for == "losses") {
+    if (!is.null(model_settings$event_occurrence_id.name) && (is.null(model_settings$event_occurrence_id.used_for) || model_settings$event_occurrence_id.used_for == "losses")) {
       selectChoices <- lapply(model_settings$event_occurrence_id.options, function(x) {
         x$id
       })

diff --git a/BFE_RShiny/oasisui/R/oasisapi.R b/BFE_RShiny/oasisui/R/oasisapi.R
@@ -161,10 +161,25 @@ OasisAPI <- R6Class(
       tryCatch(warn_for_status(response),
                warning = function(w) {warning(w$message)})
       status <- http_status(response)$category
+      # 292: more detailed logging of API query issues
       if (status == "Client error" && response$headers[["content-type"]] == "text/html") {
-        stop("Client error in api_handle_response, probably trying to access a non-existent query path.")
+        oasisuiNotification(type = "error",
+                            paste0(status_code(response), ": Client error in API query - bad request."))
+        warning(paste("Client error", status_code(response), "in api_handle_response, probably trying to access a non-existent query path."))
+        logMessage(response$url)
       } else if (status == "Client error" && !is.null(content(response)$detail) && content(response)$detail == "Not found.") {
-        warning("Client error in api_handle_response, valid query but API did not find / return the requested resource.")
+        oasisuiNotification(type = "error",
+                            paste0(status_code(response), ": Client error in API query - not found."))
+        warning(paste("Client error", status_code(response), "in api_handle_response, valid query but API did not find / return the requested resource."))
+        logMessage(response$url)
+      } else if (status == "Server error") {
+        oasisuiNotification(type = "error",
+                            paste0(status_code(response), ": Server error upon API query - retry and/or check network / API server."))
+        warning(paste("Server error", status_code(response), "in api_handle_response."))
+      } else if (status_code(response) != 200L) {  # 201 (create ana), 204 (delete pf)
+        # oasisuiNotification(type = "message",
+        #                     paste0(status_code(response), ": Unexpected status code returned by API query..."))
+        logMessage(paste("Unexpected status code", status_code(response), "in api_handle_response."))
       }
       structure(
         list(
@@ -333,17 +348,17 @@ OasisAPI <- R6Class(
               non_null_content_lst[[i]] <- non_null_content_lst[[i]][- grep_chunks]
             }
             if (!is.null(non_null_content_lst[[i]]$sub_task_error_ids)) {
-              grep_sub_errors<- grep("sub_task_error_ids", names(non_null_content_lst[[i]]))
+              grep_sub_errors <- grep("sub_task_error_ids", names(non_null_content_lst[[i]]))
               non_null_content_lst[[i]] <- non_null_content_lst[[i]][- grep_sub_errors]
             }
             if (!is.null(non_null_content_lst[[i]]$lookup_chunks)) {
-              grep_sub_errors<- grep("lookup_chunks", names(non_null_content_lst[[i]]))
-              non_null_content_lst[[i]] <- non_null_content_lst[[i]][- grep_sub_errors]
+              grep_chunks <- grep("lookup_chunks", names(non_null_content_lst[[i]]))
+              non_null_content_lst[[i]] <- non_null_content_lst[[i]][- grep_chunks]
             }
           }
           df <- bind_rows(non_null_content_lst) %>%
             as.data.frame()
-        } else if (length(content_lst) == 1 && length(content_lst[[1]]) == 1 && any(grepl("/", content_lst[[1]]))){
+        } else if (length(content_lst) == 1 && length(content_lst[[1]]) == 1 && any(grepl("/", content_lst[[1]]))) {
           df <- content_lst[[1]]
         } else {
           df <- NULL