Merge branch 'main' of https://github.com/bcgov/CCISS_ShinyApp

bcgov · Nov 21, 2024 · a5fd286 · a5fd286
2 parents 0b7d8c4 + 2eaf59f
commit a5fd286
Show file tree

Hide file tree

Showing 3 changed files with 84 additions and 45 deletions.
diff --git a/app/global.R b/app/global.R
@@ -1,37 +1,56 @@
-# Shared shiny setup ----
-if (!requireNamespace("Require")) {
-  install.packages("Require")
-}
+# # Shared shiny setup ----
+# if (!requireNamespace("Require")) {
+#   install.packages("Require")
+# }
+# 
+# suppressPackageStartupMessages({
+#   Require::Require(c(
+#     "colourvalues",
+#     "leaflet.extras",
+#     "pagedown",
+#     "prettydoc",
+#     "prompter",
+#     "RPostgres"
+#   ), require = FALSE)  ## don't load
+# })
+# 
+# suppressPackageStartupMessages({
+#   Require::Require(c(
+#     "bslib",
+#     "bcgov/ccissr@main",
+#     "data.table",
+#     "DT",
+#     "ggplot2",
+#     "ggthemes",
+#     "kableExtra",
+#     "leaflet",
+#     "plotly",
+#     "pool",
+#     "rAmCharts4",
+#     "rhandsontable",
+#     "shiny",
+#     "shinyWidgets"
+#   ))
+# })
 
-suppressPackageStartupMessages({
-  Require::Require(c(
-    "colourvalues",
-    "leaflet.extras",
-    "pagedown",
-    "prettydoc",
-    "prompter",
-    "RPostgres"
-  ), require = FALSE)  ## don't load
-})
-
-suppressPackageStartupMessages({
-  Require::Require(c(
-    "bslib",
-    "bcgov/ccissr@main",
-    "data.table",
-    "DT",
-    "ggplot2",
-    "ggthemes",
-    "kableExtra",
-    "leaflet",
-    "plotly",
-    "pool",
-    "rAmCharts4",
-    "rhandsontable",
-    "shiny",
-    "shinyWidgets"
-  ))
-})
+req_libs <- list(
+  "bslib",
+  "ccissr",
+  "data.table",
+  "DT",
+  "ggplot2",
+  "ggthemes",
+  "kableExtra",
+  "leaflet",
+  "plotly",
+  "pool",
+  "rAmCharts4",
+  "rhandsontable",
+  "shiny",
+  "shinyWidgets",
+  "RPostgres"
+)
 
+lapply(req_libs, library, character.only = TRUE)
 source("./server/tooltip_verbage.R")
 bgc_choices <- SS[grep("BEC",Source),BGC]
diff --git a/app/server/generate.R b/app/server/generate.R
@@ -34,7 +34,7 @@ observeEvent(input$generate_results, priority = 100, {
   update_flag(update_flag() + 1) ##make sure things recalculate
   # UI select choices
   tic("Determine UI choices", ticker)
-
+  #browser()
   siterefs        <- uData$siterefs        <- sort(unique(bgc$SiteRef))
   ss_opts <- sort(unique(uData$sspreds$SS_NoSpace))
   bgc_opts <- unique(uData$bgc$BGC)
@@ -62,7 +62,7 @@ observeEvent(input$generate_results, priority = 100, {
     ss
   })
   names(ssl) <- siterefs
-  print(ssl)
+  #print(ssl)
 
   ssa <- unique(unname(unlist(ssl)))
   names(ssa) <- paste(
@@ -87,16 +87,18 @@ observeEvent(input$generate_results, priority = 100, {
   siteseries <- siteseries_list[[siteref]]
 
   tic("Populate UI choices", ticker)
-  updateSelectInput(inputId = "siteref_feas", choices = siterefs, selected = siteref)
-  updateSelectInput(inputId = "siteref_bgc_fut", choices = siterefs, selected = siteref)
-  updateSelectInput(inputId = "siteref_bgc_fut_spatial", choices = siterefs, selected = siteref)
-  updateSelectInput(inputId = "ss_bgc_fut", choices = siteseries, selected = siteseries[1])
-  updateSelectInput(inputId = "siteref_silv", choices = siterefs, selected = siteref)
-  updateSelectInput(inputId = "site_series_feas", choices = siteseries, selected = head(siteseries, 1))
-  updateSelectInput(inputId = "site_series_silv", choices = siteseries, selected = head(siteseries, 1))
+  updateSelectizeInput(inputId = "siteref_feas", choices = siterefs, selected = siteref, server = TRUE)
+  updateSelectizeInput(inputId = "siteref_bgc_fut", choices = siterefs, selected = siteref,server = TRUE)
+  updateSelectizeInput(inputId = "siteref_bgc_fut_spatial", choices = siterefs, selected = siteref,server = TRUE)
+  updateSelectizeInput(inputId = "ss_bgc_fut", choices = siteseries, selected = siteseries[1],server = TRUE)
+  updateSelectizeInput(inputId = "siteref_silv", choices = siterefs, selected = siteref,server = TRUE)
+  updateSelectizeInput(inputId = "site_series_feas", choices = siteseries, selected = head(siteseries, 1),server = TRUE)
+  updateSelectizeInput(inputId = "site_series_silv", choices = siteseries, selected = head(siteseries, 1),server = TRUE)
   updateSelectInput(inputId = "port_bgc", choices = bgc_opts, select = bgc_opts[1])
-  updateCheckboxGroupInput(inputId = "report_filter",choices = siteseries_all, selected = siteseries_all)
-
+  if(length(siteseries_all) < 25){ ## app crashes with too many options here
+    updateCheckboxGroupInput(inputId = "report_filter",choices = siteseries_all, selected = siteseries_all)
+
+  }
   # Use UI injected javascript to show download button and hide generate button
   tic("Inject javascript", ticker)
   session$sendCustomMessage(type="jsCode", list(

diff --git a/app/server/points.R b/app/server/points.R
@@ -55,7 +55,25 @@ new_points <- function(points) {
       points <- uData$basepoints
     } else {
       points[,`:=`(Long = round(Long, 5), Lat = round(Lat, 5))]
-      res <- dbPointInfo(pool, points)
+      res <- as.data.table(dbPointInfo(pool, points))
+      if(nrow(points) > 1){
+        setnames(res, old = "id", new = "ID")
+        points[,ID := as.numeric(ID)]
+        res[,ID := as.numeric(ID)]
+        setorder(res, ID)
+        setorder(points, ID)
+        # res[, popups := paste("<b>", tools::toTitleCase(gsub("_", " ", names(.SD))), ":</b>", .SD, collapse = "<br />"),
+        #                                   by=1:NROW(res)]$V1
+        # points[, popups := sapply(popups, HTML)]
+        # points[res, `:=`(
+        #   BGC = map_label,
+        #   ForestRegion = forest_region,
+        #   Site = Site_no,
+        #   Elev = elevation_m,
+        #   onbcland = onbcland,
+        # )]
+      }
+      #browser()
       points[, `:=`(
         BGC = if(uData$bec_click_flag) input$bgc_point_click else res$map_label,
         ForestRegion = res$forest_region,