Commit changes before implementation.

DESCRIPTION

@@ -30,6 +30,8 @@ Suggests:
     markdown,
     rmarkdown,
     officer,
+    ggplot2,
+    flextable,
     spelling,
     testthat (>= 3.0.0)
 Encoding: UTF-8

R/mod_Context.R

@@ -145,7 +145,7 @@ mod_Context_ui <- function(id){
                       shiny::br(),
                       # Any other constraints
                       bs4Dash::box(
-                        title = "Other constraints",
+                        title = "(Optional) Other constraints",
                         closable = FALSE,
                         width = 12,
                         solidHeader = TRUE,

R/mod_Design.R

@@ -64,7 +64,7 @@ mod_Design_ui <- function(id){
                    ),
                    shiny::br(),
                    bs4Dash::box(
-                     title = 'Analytical Framework',
+                     title = '(Optional) Analytical Framework',
                      closable = FALSE,
                      width = 12,
                      solidHeader = TRUE,

R/mod_Export.R

@@ -91,7 +91,7 @@ mod_Export_ui <- function(id){
             ),
             shiny::br(),
             shiny::hr(),
-            shiny::div(id = ns("missing"), class = 'missing',
+            shiny::div(id = ns("missing"),style = "color: red",
                        shiny::textOutput(outputId = ns("missingtext"))),
             shiny::br(),
             # Button
@@ -127,7 +127,7 @@ mod_Export_server <- function(id, results){
 
     # Format the results table to a data.frame
     output$results_table <- DT::renderDT({
-      DT::datatable(format_protocol(results, format = "data.frame") |>
+      DT::datatable(format_protocol(results, format = "data.frame", studyregiondummy=TRUE) |>
                       dplyr::select(-element),
                     rownames = FALSE,
                     filter = "top", selection = "none",
@@ -138,16 +138,21 @@ mod_Export_server <- function(id, results){
     # Get mandatory protocol entries
     mand <- get_protocol_mandatory()
 
-    # Check for mandatory outputs and highlight them in text
-    shiny::observeEvent(input$downloadData, {
-      # # Check the value of all mandatory fields
-      # output$missingtext <- shiny::renderText({
-      #   # validate(
-      #   #   need(input$sldr > 5,"Require > 5")
-      #   # )
-      #   test
-      # })
-    })
+    # # Check for mandatory outputs and highlight them in text
+    # test <- shiny::reactive({
+    #   req(results)
+    #   results
+    # })
+    #
+    # # Check the value of all mandatory fields
+    # shiny::observeEvent(test(), {
+    #   # miss <- check_protocol_mandatory(file, mand)
+    #   # output$missingtext <- shiny::renderText({
+    #   #   paste0("No entry found for mandatory fields:", miss)
+    #   # })
+    #   print("test")
+    #   shinyjs::toggle("downloadData")
+    # })
 
     # Get output format
     oftype <- shiny::reactive({input$downloadFormat})
@@ -180,11 +185,13 @@ mod_Export_server <- function(id, results){
           # yaml::read_yaml("../../../Downloads/test.yaml")
         } else if(oftype() == "docx"){
           # Create document from results, everything handled by function
-          protocol_to_document(results,file = file,format = "docx")
+          protocol <- format_protocol(results, format = "list")
+          protocol_to_document(protocol, file = file, format = "docx")
           # saveRDS(protocol, "test.rds")
         } else if(oftype() == "pdf"){
           # Create document from results
-          protocol_to_document(results,file = file,format = "pdf")
+          protocol <- format_protocol(results, format = "list")
+          protocol_to_document(protocol, file = file,format = "pdf")
         }
       }
     )

R/mod_Overview.R

@@ -86,7 +86,7 @@ mod_Overview_ui <- function(id){
           ),
           # Corresponding author
           bs4Dash::box(
-            title = "Corresponding Author ID",
+            title = "(Optional) Corresponding Author ID",
             closable = FALSE,
             width = 12,
             solidHeader = TRUE,
@@ -99,7 +99,7 @@ mod_Overview_ui <- function(id){
           ),
           # Link to study
           bs4Dash::box(
-            title = "Link to study",
+            title = "(Optional) Link to study",
             closable = FALSE,
             width = 12,
             solidHeader = TRUE,
@@ -151,7 +151,7 @@ mod_Overview_ui <- function(id){
           ),
           # Study region
           bs4Dash::box(
-            title = "Study region",
+            title = "(Optional) Study region",
             closable = FALSE,
             width = 12,
             solidHeader = TRUE,
@@ -250,7 +250,7 @@ mod_Overview_ui <- function(id){
               label = "Choose a range:",
               choices = 1960:2100,
               grid = TRUE,
-              selected = seq(1990,2020,1)
+              selected = c(2000,2020)
             ),
             shiny::br(),
             shiny::textAreaInput(inputId = ns("otherstudytime"), label = "(Optional) Custom coverage",
@@ -509,7 +509,7 @@ mod_Overview_server <- function(id, results, parentsession){
     myregion <- shiny::reactive({
       # Get the studypath
       file <- input$studyregion$datapath
-      req(file)
+      shiny::req(file)
 
       if(!is.null(input$studyregion)){
         # Found vector

R/mod_Prioritization.R

@@ -89,7 +89,7 @@ mod_Prioritization_ui <- function(id){
                      # Objective functions
                      shiny::br(),
                      bs4Dash::box(
-                       title = "Outcome identification",
+                       title = "(Optional) Outcome identification",
                        closable = FALSE,
                        width = 12,
                        solidHeader = TRUE,
@@ -111,7 +111,7 @@ mod_Prioritization_ui <- function(id){
                      ),
                      shiny::br(),
                      bs4Dash::box(
-                       title = "Key parameters",
+                       title = "(Optional) Key parameters",
                        closable = FALSE,
                        width = 12,
                        solidHeader = TRUE,

R/mod_Specification.R

@@ -570,7 +570,7 @@ mod_Specification_server <- function(id, results, parentsession){
     # Load an external file
     loadedfeatures <- shiny::reactive({
       file <- input$load_feature$datapath
-      req(file)
+      shiny::req(file)
 
       data <- readr::read_csv(file,show_col_types = FALSE)
       # Do some checks?
@@ -635,7 +635,7 @@ mod_Specification_server <- function(id, results, parentsession){
     # Load an external file
     loadedzones <- shiny::reactive({
       file <- input$load_zones$datapath
-      req(file)
+      shiny::req(file)
 
       data <- readr::read_csv(file,show_col_types = FALSE)
 

R/utils_format_protocol.R

@@ -8,13 +8,16 @@
 #' @param results A filled out protocol in [`list`] or reactive format.
 #' @param format The output format that the results should have. Available options
 #' include \code{"data.frame"} or \code{"list"}.
+#' @param studyregiondummy A [`logical`] flag of whether the studyregion should be replaced with a dummy?
 #' @param path_protocol The filepath to the actual protocol template.
 #' @return The return value, if any, from executing the utility.
 #'
 #' @noRd
-format_protocol <- function(results, format = "data.frame",path_protocol = NULL){
+format_protocol <- function(results, format = "data.frame",
+                            studyregiondummy = FALSE, path_protocol = NULL){
   assertthat::assert_that(is.list(results),
                           is.character(format),
+                          is.logical(studyregiondummy),
                           is.character(path_protocol) || is.null(path_protocol))
   # Match output format
   format <- match.arg(format, c("data.frame", "list"), several.ok = FALSE)
@@ -33,7 +36,15 @@ format_protocol <- function(results, format = "data.frame",path_protocol = NULL)
       if(any(exportVals[i] %in% protocol$render_id)) {
         val <- results[[exportVals[i]]]
         if(length(val)>0){
-          if(is.data.frame(val)){
+          # For studyregion:
+          if(utils::hasName(val, "datapath")){
+            if(studyregiondummy){
+              val <- "Study region provided!"
+            } else {
+              # Format EPSG and WKT to text
+              val <- format_studyregion_to_text(val)
+            }
+          } else if(is.data.frame(val)){
             val <- paste(val$forename, paste0(val$surename, " (",val$orcid,") "), sep = ",", collapse = "; ")
           }
           # Time slide correction
@@ -56,12 +67,39 @@ format_protocol <- function(results, format = "data.frame",path_protocol = NULL)
       # Get group
       gr <- get_protocol_elementgroup(exportVals[i])
       if(is.null(gr)) next()
-      protocol[[gr$group]][[exportVals[i]]] <- results[[exportVals[i]]]
+      # Get result
+      val <- results[[exportVals[i]]]
+      if(utils::hasName(val, "datapath")){
+        val <- format_studyregion_to_text(val)
+      }
+      protocol[[gr$group]][[exportVals[i]]] <- val
     }
   }
   return(protocol)
 }
 
+#' Small helper for spatial conversion to wkt
+#' @param val A [`list`] with the datapath for the spatial file
+#' @noRd
+format_studyregion_to_text <- function(val){
+  assertthat::assert_that(utils::hasName(val, "datapath"))
+  # Assume as sf and load as such
+  val <- try({
+    sf::st_as_sfc(
+      sf::st_read(val$datapath,quiet = TRUE)
+    )
+  },silent = TRUE)
+  if(inherits(val,"try-error")){
+    val <- "Studyregion could not be loaded?"
+  } else {
+    val <- paste0(
+      # Also append SRID in front
+      sf::st_crs(val) |> sf::st_as_text(),";",
+      sf::st_as_text(val)
+    )
+  }
+  return(val)
+}
 #' List to table
 #'
 #' @description
@@ -186,27 +224,41 @@ protocol_to_document <- function(results, file, format = "docx", path_protocol =
       # --- #
       # Parse the result
       res <- results[[g]][[el]]
-      if(is.list(res)) {
-        if(length(res)>0){
-          # Tables
-          ft <- flextable::flextable(res) |>
-                flextable::set_table_properties(layout = "autofit")
-          doc <- doc |> officer::body_add_flextable(value = ft)
-        } else {
-          res <- "Not specified"
+      # Specific function for studyregion rendering
+      if(el == "studyregion"){
+        # Render studyregion
+        sp <- strsplit(res,";") # Split SRID off
+        sp <- sp[[1]][2] |> sf::st_as_sfc() |> sf::st_sf(crs = sp[[1]][1])
+        g <- ggplot2::ggplot() +
+          ggplot2::geom_sf(data = sp) +
+          ggplot2::labs(title = "Outline of studyregion")
+        # Add to document
+        doc <- doc |> officer::body_add_gg(value = g)
+        try({ rm(g, sp) },silent = TRUE)
+      } else {
+        # All other entries
+        if(is.list(res)) {
+          if(length(res)>0){
+            # Tables
+            ft <- flextable::flextable(res) |>
+              flextable::set_table_properties(layout = "autofit")
+            doc <- doc |> flextable::body_add_flextable(value = ft)
+          } else {
+            res <- "Not specified"
+          }
         }
-      }
-      # If multiple entries, paste together via -
-      if(length(res)>1) res <- paste(res, collapse = " - ")
+        # If multiple entries, paste together via -
+        if(length(res)>1) res <- paste(res, collapse = " - ")
 
-      if(is.logical(res)) res <- ifelse(res, "Yes", "No")
-      if(is.na(res)) res <- "Not specified"
+        if(is.logical(res)) res <- ifelse(res, "Yes", "No")
+        if(is.na(res)) res <- "Not specified"
 
-      fpar <- officer::fpar(
-        officer::ftext(text = res,
-                       prop = officer::fp_text(font.size = 12,italic = FALSE))
-      )
-      doc <- doc |> officer::body_add_fpar(value = fpar)
+        fpar <- officer::fpar(
+          officer::ftext(text = res,
+                         prop = officer::fp_text(font.size = 12,italic = FALSE))
+        )
+        doc <- doc |> officer::body_add_fpar(value = fpar)
+      }
 
       # Small linebreak
       doc <- doc |> officer::body_add_par(value = "", style = "Normal")

R/utils_load_protocol.R

@@ -103,7 +103,7 @@ get_protocol_elementgroup <- function(id, path_protocol = NULL){
 #' @description
 #' Small convenience function that checks for mandatory fields
 #'
-#' @param protocol A filled out protocol in [`list`] format.
+#' @param path_protocol A [`character`] pointing to the destination of the protocol.
 #' @returns A [`vector`] of character entries that are mandatory in the protocol.
 #' @noRd
 get_protocol_mandatory <- function(path_protocol = NULL){
@@ -122,3 +122,39 @@ get_protocol_mandatory <- function(path_protocol = NULL){
   }
   return(results)
 }
+
+#' Check mandatory fields in results
+#'
+#' @description
+#' This small helper check whether mandatory entries in the results have been filled.
+#' @param results A [`list`] with the protocol results.
+#' @param mand A [`vector`] with [`character`] entries of the mandatory fields.
+#' @param path_protocol A [`character`] pointing to the destination of the protocol.
+#' @returns A [`vector`] of mandatory character entries that missing.
+#' @noRd
+check_protocol_mandatory <- function(results, mand, path_protocol = NULL){
+  # Checks protocol
+  assertthat::assert_that(is.character(path_protocol) || is.null(path_protocol))
+  assertthat::assert_that(is.character(mand) || missing(mand))
+  assertthat::assert_that(is.list(results))
+
+  # If is null, load protocol
+  template <- load_protocol(path_protocol)
+
+  # If missing, load again
+  if(missing(mand)) mand <- get_protocol_mandatory(path_protocol)
+
+  out <- vector()
+  for(gr in names(template)[-1]){
+    pp <- template[[gr]]
+    for(element in names(pp)){
+      ppp <- pp[[element]]
+      # Now check if present in results
+      op <- results[[gr]][[element]]$value
+      if(is.null(op) || op==""){
+        if(ppp[['render-id']] %in% mand) out <- append(out, ppp[['render-id']])
+      }
+    }
+  }
+  return(out)
+}

inst/01_protocol.yaml

@@ -35,7 +35,7 @@ overview:
     question: 'Email of corresponding author.'
     description: 'The email address of the corresponding author.'
     fieldtype: 'textbox'
-    mandatory: false
+    mandatory: true
     popexample: "darwin@thebeagle.ac.uk"
 
   orcid:
@@ -106,7 +106,7 @@ overview:
     fieldtype: 'slider'
     fieldtype_conditional_render-id: 'otherstudytime'
     fieldtype_conditional: 'textbox'
-    mandatory: false
+    mandatory: true
     popexample: "The study uses data from the period 2015-2020 in order to make
     recommendations for potential protected area network in 2030. The time period is thus 2015-2030."
 
@@ -510,7 +510,7 @@ specification:
     question: 'How were features created?'
     description: 'Describe the origin of the features.'
     fieldtype: 'textbox'
-    mandatory: false
+    mandatory: true
     popexample: "A description where or how the feature layers came about, if they are
     the result of some modelling process or similar."