Some work on importing protocols

R/app_server.R

@@ -96,6 +96,12 @@ app_server <- function(input, output, session) {
     shinyjs::runjs(jscode)
   })
 
+  # Initiate watching flags
+  # gargoyle::init("import_overview", "import_design",
+  #                "import_specification",
+  #                "import_context",
+  #                "import_prioritization", session = session)
+
   # title page ----------------------------------------------------------------
   # Adding module server code
   mod_Home_server("Home_1", results, session)
@@ -109,7 +115,7 @@ app_server <- function(input, output, session) {
   mod_News_server("News_1")
   mod_Glossary_server("Glossary_1")
   # Import/Export
-  mod_Import_server("Import_1")
+  mod_Import_server("Import_1", results, session)
   mod_Export_server("Export_1", results)
 
   # Automatically stop a Shiny app when closing the browser tab

R/misc.R

@@ -79,3 +79,28 @@ format_studyregion_to_text <- function(val){
   }
   return(val)
 }
+
+#' Small helper for conversion wkt to spatial
+#' @param val A [`character`] with studyregion string
+#' @return A [`sf`] object.
+#' @noRd
+format_text_to_studyregion <- function(val){
+  assertthat::assert_that(is.character(val))
+
+  # Split by semicolon
+  ss <- strsplit(val,";")[[1]]
+
+  # Convert to spatial and set crs
+  pol <- sf::st_as_sfc(ss[[2]])
+  pol <- sf::st_set_crs(pol, value = sf::st_crs(ss[1]) )
+
+  # Convert to sf
+  if(!inherits(pol, "sf")){
+    pol <- sf::st_as_sf(pol)
+  }
+
+  # Rename geometry name to be sure
+  sf::st_geometry(pol) <- "geometry" # rename
+
+  return(pol)
+}

R/mod_Import.R

@@ -11,9 +11,10 @@
 #' @importFrom shiny actionButton tabsetPanel column
 mod_Import_ui <- function(id){
   ns <- NS(id)
+  # Spinner
+  waiter::autoWaiter()
 
-  # TODO:
-  # Import existing Marxan / Zonation / Prioritizr configuration files?
+  # Import board
   bs4Dash::tabItem(tabName = "Import",
           shiny::fluidPage(
             bs4Dash::box(
@@ -30,7 +31,8 @@ mod_Import_ui <- function(id){
             shiny::br(),
             shiny::div("Please note:"),
             shiny::helpText("> Non accepted fields will not be parsed."),shiny::br(),
-            shiny::helpText("> Reexporting the protocol resets internally the version and date."),
+            shiny::helpText("> Importing a protocol overwrites all existing values!"),shiny::br(),
+            shiny::helpText("> Re-exporting the protocol resets internally the version and date."),
             shiny::br(),
             shiny::hr(),
             shiny::fileInput(
@@ -52,7 +54,7 @@ mod_Import_ui <- function(id){
 #' Import Server Functions
 #'
 #' @noRd
-mod_Import_server <- function(id){
+mod_Import_server <- function(id, results, parentsession){
  shiny::moduleServer( id, function(input, output, session){
     ns <- session$ns
 
@@ -80,6 +82,7 @@ mod_Import_server <- function(id){
           stop(shiny::safeError(e))
         }
       )
+
       # Checks
       if(inherits(out, "try-error")){
         shiny::showNotification("File not valid!", duration = 2, type = "error")
@@ -99,13 +102,41 @@ mod_Import_server <- function(id){
     # Validate the protocol and import protocol
     shiny::observeEvent(imports(), {
       if(!is.null(imports())){
-        check <- validate_protocol_results(imports())
+        check <- try({ validate_protocol_results(imports()) },silent = TRUE)
+        if(inherits(check, "try-error")){
+          shiny::showNotification("Parsing failed. Protocol not valid!", duration = 5,
+                                  closeButton = TRUE, type = "error")
+        }
         if(!is.null(check)){
           shiny::showNotification(check, duration = 5,closeButton = TRUE, type = "error")
+        } else {
+          # --- #
+          #### Parse and insert protocol entries ####
+          # ODPSCP import functions
+          new <- imports()
+
+          # First get types for all ids
+          ft <- get_protocol_fieldtypes()
+
+          # Now iterate over each field and update respectively
+          for(i in 1:nrow(ft)){
+
+            # Result id and value
+            val <- new[[ft$group[i]]][[ft$id[i]]]
+
+            # Insert depending on type
+            # if(ft$fieldtype[i]=="textbox"){
+            # message(ft$id[i], "-", val)
+              results[[ft$id[i]]] <- val
+              # Trigger
+              # gargoyle::trigger(paste0("import_",ft$group[i]),
+              #                   session = parentsession)
+            # }
+          }
+          shiny::showNotification("Existing protocol sucessfully loaded!",
+                                  duration = 5, closeButton = TRUE, type = "message")
         }
       }
-      # Insert protocol
-      bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Overview")
     })
   })
 }

R/mod_Overview.R

@@ -486,7 +486,7 @@ mod_Overview_server <- function(id, results, parentsession){
     })
 
     # ----- #
-    #### Studyregion updates ####
+    #### Study region updates ####
 
     # Gather study region from bounding box
     # xmin <- shiny::reactive(input$studyregion_bbox_xmin)
@@ -597,6 +597,16 @@ mod_Overview_server <- function(id, results, parentsession){
       map
     })
 
+    # ----- #
+    #### Trigger watch ----
+
+    # Import trigger
+    # gargoyle::on("import_overview",{
+      # Triggering
+      # shiny::updateTextAreaInput(inputId = "studyname",
+      #                            value = results$overview$studyname)
+    # })
+
     # ----- #
     # Send a pre-rendered image, and don't delete the image after sending it
     output$peng2011 <- shiny::renderImage({

R/utils_load_protocol.R

@@ -139,6 +139,40 @@ get_protocol_options <- function(id, path_protocol = NULL, field = "options"){
   return(check)
 }
 
+#' Get field types of all protocol ids
+#'
+#' @description
+#' Utility function to get the the type of all protocol ids.
+#' @details
+#' This function is needed to collate input fields and ultimately correctly update
+#' them, for example by importing an existing protocol.
+#'
+#' @param path_protocol The file path to the actual protocol template (Default: \code{NULL})
+#' @returns A [`data.frame`] containing the \code{"id"} and \code{"fieldtype"}.
+#' @examples
+#' /dontrun{
+#'  get_protocol_fieldtypes()
+#' }
+#'
+#' @noRd
+get_protocol_fieldtypes <- function(path_protocol = NULL){
+  assertthat::assert_that(is.character(path_protocol) || is.null(path_protocol))
+
+  # If is null, load protocol
+  template <- load_protocol(path_protocol)
+
+  # Get and save all ids
+  out <- data.frame(
+    group = NA,
+    id = get_protocol_ids(path_protocol = path_protocol),
+    fieldtype = NA)
+
+  out$group <- sapply(out$id, function(z) get_protocol_elementgroup(z)[["group"]] )
+  out$fieldtype <- sapply(out$id, function(z) get_protocol_options(z,field = "fieldtype"))
+
+  return(out)
+}
+
 #' Check for mandatory fields to be filled
 #'
 #' @description
@@ -247,9 +281,15 @@ validate_protocol_results <- function(results, path_protocol = NULL){
   }
 
   # Check mandatory entries
-  if(!all(get_protocol_mandatory(path_protocol = path_protocol)) %in% ids){
+  if(!all(get_protocol_mandatory(path_protocol = path_protocol) %in% ids)){
     return("Exported protocol does not contain all mandatory groups!")
   }
+
   # --- #
+  # Check more specific entry validities as spot checks
+  if(!(results$overview$studyscale %in% template$overview$extent$options)){
+    return("Incorrect study extent?")
+  }
+
   return(NULL)
 }