Feature/various issues (#263)

* changes for issue #228 changes for issue #223 required edits implemented * added number of samples to teh analysis settings number of samples is retrieved from analysis settings in step 3 minor adjustments * fix to pop up tooltip * replaced "Model Values" table with set of tabs * small bug fix restored correct package versions * added functionality for single tab in model values in case no parameters_group is available * fixed list parameters rendering adjusted number of characters limit in tooltip box * adjusted list format * updates for locnumbers e.g. "1-" * fixes for exposure validation map * clean up for validation map * update to buildcustom * merging of data files for exposure validation map * Update analysis setting names (#265) Co-authored-by: sambles <[email protected]>
OasisLMF · Dec 6, 2021 · 197ff91 · 197ff91
1 parent fdff9e2
commit 197ff91
Show file tree

Hide file tree

Showing 11 changed files with 815 additions and 322 deletions.
diff --git a/BFE_RShiny/oasisui/NAMESPACE b/BFE_RShiny/oasisui/NAMESPACE
@@ -4,6 +4,7 @@ export("%>%")
 export("%notin%")
 export(APIgetenv)
 export(DataHub)
+export(Global_funs)
 export(OASISUI_GUEST_ID)
 export(OasisAPI)
 export(Status)
@@ -164,7 +165,9 @@ importFrom(DT,styleEqual)
 importFrom(R6,R6Class)
 importFrom(arrow,read_parquet)
 importFrom(arrow,write_parquet)
+importFrom(bsplus,bs_embed_popover)
 importFrom(bsplus,bs_embed_tooltip)
+importFrom(bsplus,use_bs_popover)
 importFrom(data.table,fread)
 importFrom(data.table,fwrite)
 importFrom(dplyr,"%>%")

diff --git a/BFE_RShiny/oasisui/R/buildCustom_module.R b/BFE_RShiny/oasisui/R/buildCustom_module.R
diff --git a/BFE_RShiny/oasisui/R/check_loc.R b/BFE_RShiny/oasisui/R/check_loc.R
@@ -16,6 +16,7 @@
 #'
 #' @export
 check_loc <- function(analysisID, portfolioID, data_hub) {
+
   logMessage(".check_loc called")
 
   uploaded_locs <- data_hub$get_pf_location_content(id = portfolioID) %>%

diff --git a/BFE_RShiny/oasisui/R/datahub.R b/BFE_RShiny/oasisui/R/datahub.R
@@ -477,6 +477,11 @@ DataHub <- R6Class(
       query_response <- private$oasisapi$api_get_query(query_path = paste("analyses", id, "lookup_errors_file",  sep = "/"))
       content(query_response$result)
     },
+    # get lookup success file
+    get_ana_success_summary_content = function(id,  ...) {
+      query_response <- private$oasisapi$api_get_query(query_path = paste("analyses", id, "lookup_success_file",  sep = "/"))
+      content(query_response$result)
+    },
     # invalidate analysis validation summary content
     invalidate_ana_validation_summary_content = function(id, dataset_identifier, type, ...) {
       self$invalidate_ana_dataset_header(id, dataset_identifier, type, ...)

diff --git a/BFE_RShiny/oasisui/R/exposurevalidation_map_module.R b/BFE_RShiny/oasisui/R/exposurevalidation_map_module.R
@@ -154,24 +154,33 @@ exposurevalidationmap <- function(input,
 
   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)
-      } 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 (!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 (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 (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))
+        }
       }
-    }
-  })
+    })
 
   # Show/Hide table button -----------------------------------------------------
   observeEvent(result$uploaded_locs_check_peril, ignoreNULL = FALSE, {
@@ -272,6 +281,7 @@ exposurevalidationmap <- function(input,
 
   observeEvent(input$exposure_map_click, {
     if (input$tot_tiv_param == "Circles") {
+
       hide("exposure_table")
 
       circles_features <- input$exposure_map_draw_all_features$features
@@ -387,8 +397,8 @@ exposurevalidationmap <- function(input,
           }
 
           # check for pins within country borders
-          match_lat <- grep(TRUE, between(result$uploaded_locs_check_peril$Latitude, min(unlist(lati)), max(unlist(lati))))
-          match_long <- grep(TRUE, between(result$uploaded_locs_check_peril$Longitude, min(unlist(long)), max(unlist(long))))
+          match_lat <- grep(TRUE, between(result$uploaded_locs_check_peril$latitude, min(unlist(lati)), max(unlist(lati))))
+          match_long <- grep(TRUE, between(result$uploaded_locs_check_peril$longitude, min(unlist(long)), max(unlist(long))))
 
           # adjust TIV wrt damage ratio
           if (is.null(input$damage_ratio)) {
@@ -432,8 +442,8 @@ exposurevalidationmap <- function(input,
           long <- regions@polygons[[entry]]@Polygons[[set]]@coords[,1]
 
           # check for pins within country borders
-          match_lat <- grep(TRUE, between(result$uploaded_locs_check_peril$Latitude, min(lati), max(lati)))
-          match_long <- grep(TRUE, between(result$uploaded_locs_check_peril$Longitude, min(long), max(long)))
+          match_lat <- grep(TRUE, between(result$uploaded_locs_check_peril$latitude, min(lati), max(lati)))
+          match_long <- grep(TRUE, between(result$uploaded_locs_check_peril$longitude, min(long), max(long)))
 
           # adjust TIV wrt damage ratio
           if (is.null(input$damage_ratio)) {
@@ -517,12 +527,16 @@ exposurevalidationmap <- function(input,
   # Exposure validation map
   .createExposureValMap <- function(df) {
     marker_colors <- c('green', 'red')
+    # if ("Latitude" %in% colnames(df)) {
+    # colnames(df) <- tolower(colnames(df))
+    # }
+
     if (is.null(input$chkgrp_perils)) {
       icon_map <- NULL
       df <- df
       leaflet(df) %>%
         addTiles() %>%
-        leaflet::setView(mean(df$Longitude), mean(df$Latitude), zoom = 20)
+        leaflet::setView(mean(df$longitude), mean(df$latitude), zoom = 20)
     } else {
       df <- df %>%
         mutate(modeled = case_when(
@@ -638,11 +652,11 @@ exposurevalidationmap <- function(input,
   # Drawn circles infos, outputs and radius
   .DrawnCircles <- function(radius, lat_click, long_click, ratio) {
     # calculate LocID and TIV for pins inside areas
-    df_info <- data.frame("LocNumber" = format(result$uploaded_locs_check_peril$LocNumber, big.mark = "",
+    df_info <- data.frame("LocNumber" = format(result$uploaded_locs_check_peril$locnumber, big.mark = "",
                                                scientific = FALSE),
-                          "TIV" = result$uploaded_locs_check_peril$BuildingTIV * (ratio/100))
-    if(!is.null(result$uploaded_locs_check_peril$StreetAddress)) {
-      df_info <- cbind(df_info, "Address" = result$uploaded_locs_check_peril$StreetAddress)
+                          "TIV" = result$uploaded_locs_check_peril$buildingtiv * (ratio/100))
+    if(!is.null(result$uploaded_locs_check_peril$streetaddress)) {
+      df_info <- cbind(df_info, "Address" = result$uploaded_locs_check_peril$streetaddress)
     }
     info <- .is_within_bounds(df_info, radius, lat_click, long_click, ratio)
 
@@ -668,8 +682,8 @@ exposurevalidationmap <- function(input,
   .is_within_bounds <- function(uploaded_locs_input, radius, lat_click, long_click, ratio) {
 
     # get pins coordinates
-    long <- result$uploaded_locs_check_peril$Longitude
-    lat <- result$uploaded_locs_check_peril$Latitude
+    long <- result$uploaded_locs_check_peril$longitude
+    lat <- result$uploaded_locs_check_peril$latitude
 
     coord_df <- cbind(long_click, lat_click)
 
@@ -686,7 +700,7 @@ exposurevalidationmap <- function(input,
     degrees_dist_4 <- degrees_dist_2 + 22.5
     circle_bounds_4 <- destPoint(coord_df, degrees_dist_4, radius)
 
-    lapply(seq_len(length(result$uploaded_locs_check_peril$Longitude)), function(x) {
+    lapply(seq_len(length(result$uploaded_locs_check_peril$longitude)), function(x) {
       if ((.between_min_max(circle_bounds_1[, 1], long[x]) &&
            .between_min_max(circle_bounds_1[, 2], lat[x])) ||
           (.between_min_max(circle_bounds_2[, 1], long[x]) &&
@@ -740,7 +754,7 @@ exposurevalidationmap <- function(input,
   .showCountryInfo <- function(code, match_long, match_lat, ratio, country_num, part) {
     if(length(match_long) > 0 && length(match_lat) > 0) {
       result$tot_country_tiv <- add_commas(sum(unlist(lapply(seq_len(length(match_long)), function (x) {
-        result$uploaded_locs_check_peril$BuildingTIV[x]
+        result$uploaded_locs_check_peril$buildingtiv[x]
       }))) * (ratio/100))
     } else {
       result$tot_country_tiv <- "No locations in this country"

diff --git a/BFE_RShiny/oasisui/R/map.R b/BFE_RShiny/oasisui/R/map.R
@@ -112,12 +112,23 @@ build_marker_data <- function(data, session, paramID, step = NULL) {
 
 # Extract error messages
 .keys_errors_msg <- function(data, session, paramID) {
+  keys_success <- session$userData$data_hub$get_ana_success_summary_content(paramID)
   keys_errors <- session$userData$data_hub$get_ana_errors_summary_content(id = paramID)
-  if (!is.null(keys_errors) && is.null(keys_errors$detail)) {
-    message <- group_by(keys_errors, LocID) %>%
-      summarize(message = paste(paste(PerilID, ":", Message), collapse = " / "))
-    if (length(as.numeric(keys_errors$LocID)) > 0) {
-      errmessage <- left_join(data, message, by = c("locnumber" = "LocID"))$message
+  # unify names cases for merging
+  names(keys_success) <- tolower(names(keys_success))
+  names(keys_errors) <- tolower(names(keys_errors))
+
+  if (!is.null(keys_errors) && is.null(keys_errors$detail) && !is.null(keys_success)) {
+    if (length(as.numeric(keys_errors$locid)) > 0) {
+      key_chain <- left_join(keys_success, keys_errors, by = c("loc_id" = "locid"))
+      message <- group_by(key_chain, loc_id) %>%
+        summarize(message = paste(paste(perilid, ":", message), collapse = " / "))
+      if (grepl("locnumber.x", names(data))) {
+        names(data) <- gsub(".x", "", names(data))
+      }
+      data$locnumber <- as.character(data$locnumber)
+      message$loc_id <- as.character(message$loc_id)
+      errmessage <- left_join(data, message, by = c("locnumber" = "loc_id"))$message
     } else {
       errmessage <- rep_len(NA, nrow(data))
     }