From cc9a9855aa4351475da3df2663173bdea165aa9b Mon Sep 17 00:00:00 2001 From: Martin Jung Date: Sun, 29 Sep 2024 23:17:01 +0200 Subject: [PATCH] :fire: Updated minor fixes --- .gitignore | 2 + R/app_server.R | 58 ++++++++++++------ R/mod_Context.R | 1 + R/mod_Design.R | 9 +-- R/mod_Export.R | 38 +++++------- R/mod_Import.R | 122 ++++++++++++++++++++++++-------------- R/mod_News.R | 32 +++++----- R/mod_Overview.R | 41 +++++-------- R/mod_Prioritization.R | 13 ++-- R/mod_Specification.R | 20 +++---- R/utils_format_protocol.R | 22 ++++--- R/utils_load_protocol.R | 64 ++++++++++++++++++-- inst/01_protocol.yaml | 18 ++---- 13 files changed, 260 insertions(+), 180 deletions(-) diff --git a/.gitignore b/.gitignore index 5517f4a..b7c1774 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,5 @@ deploy/ # Shiny bookmarks shiny_bookmarks/ +# Log files +logs/*.rds diff --git a/R/app_server.R b/R/app_server.R index f5cbfba..6fce55b 100644 --- a/R/app_server.R +++ b/R/app_server.R @@ -7,13 +7,33 @@ app_server <- function(input, output, session) { # Your application server logic sever::sever() + # --- # # Add bookmark button to top # NOTE: For URL see also https://stackoverflow.com/questions/58396680/how-to-extract-the-url-from-the-shiny-bookmark-button-and-create-my-own-action-b - shiny::enableBookmarking(store = "url") + # shiny::enableBookmarking(store = "url") shiny::observeEvent(input$bookmark, { - session$doBookmark() + # session$doBookmark() + # Use manuall bookmarking instead owing to the complexity + shiny::showNotification("Export the current protocol as yaml. Then import later...", + duration = 5,closeButton = TRUE, type = "message") + bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Export") + }) + + # Save bookmark time too + shiny::onBookmark(function(state) { + savedTime <- as.character(Sys.time()) + cat("Last saved at", savedTime, "\n") + # state is a mutable reference object, and we can add arbitrary values to + # it. + state$values$time <- savedTime }) + # On restore + shiny::onRestore(function(state) { + cat("Restoring from state bookmarked at", state$values$time, "\n") + }) + # --- # + # Enable shinylogs # shinylogs::read_rds_logs("logs") shinylogs::track_usage(what = c("session", "input", "output", "error"), @@ -30,49 +50,51 @@ app_server <- function(input, output, session) { results <- shiny::reactiveValues() # Bottom page buttons ------------------------------------------------------- + # Javascript to be rendered with shinyjs + jscode <- "function() {document.body.scrollTop = 0;}" shiny::observeEvent(input$start_new_protocol, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Overview") + # Jump to top + shinyjs::runjs(jscode) }) # Final observer events for continue buttons shiny::observeEvent(input$go_home, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Home") + # Jump to top + shinyjs::runjs(jscode) }) shiny::observeEvent(input$go_overview, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Overview") + # Jump to top + shinyjs::runjs(jscode) }) shiny::observeEvent(input$go_design, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Design") + # Jump to top + shinyjs::runjs(jscode) }) shiny::observeEvent(input$go_specification, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Specification") + # Jump to top + shinyjs::runjs(jscode) }) shiny::observeEvent(input$go_context, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Context") + # Jump to top + shinyjs::runjs(jscode) }) shiny::observeEvent(input$go_prioritization, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Prioritization") + # Jump to top + shinyjs::runjs(jscode) }) shiny::observeEvent(input$go_export, { bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Export") + # Jump to top + shinyjs::runjs(jscode) }) - # --------------------------------------------------------------------------- - - # Add Help popups for every entry - # Add Tooltips for each element - # for(n in names(protocol)){ - # sub <- protocol[[n]] - # bs4Dash::addPopover( - # id = sub['render-id'], - # options = list( - # content = sub$popexample, - # title = sub$question, - # placement = "auto", - # trigger = "hover" - # ) - # ) - # } # title page ---------------------------------------------------------------- # Adding module server code diff --git a/R/mod_Context.R b/R/mod_Context.R index 0b30102..16d76af 100644 --- a/R/mod_Context.R +++ b/R/mod_Context.R @@ -83,6 +83,7 @@ mod_Context_ui <- function(id){ "Current conditions", "Future conditions", "Fully dynamic"), + selected = "Current conditions", multiple = TRUE, options = list(create = FALSE, placeholder = "Choose single or multiple from list")) diff --git a/R/mod_Design.R b/R/mod_Design.R index 6f38476..9c69252 100644 --- a/R/mod_Design.R +++ b/R/mod_Design.R @@ -77,9 +77,9 @@ mod_Design_ui <- function(id){ work? This could for example also be a specific planning protocol or established approaches such as structure decision making or adaptive management."), shiny::p("Example framework references:"), - shiny::p("Pressey, R. L., & Bottrill, M. C. (2009). Approaches to landscape-and seascape-scale conservation planning: convergence, contrasts and challenges. Oryx, 43(4), 464-475."), - shiny::p("Alvarez-Romero, J. G., Adams, V. M., Pressey, R. L., Douglas, M., Dale, A. P., Auge, A. A., ... & Perdrisat, I. (2015). Integrated cross-realm planning: A decision-makers' perspective. Biological Conservation, 191, 799-808."), - shiny::p("Niemiec, R. M., Gruby, R., Quartuch, M., Cavaliere, C. T., Teel, T. L., Crooks, K., ... & Manfredo, M. (2021). Integrating social science into conservation planning. Biological Conservation, 262, 109298."), + shiny::p("Pressey, R. L., & Bottrill, M. C. (2009). Approaches to landscape-and seascape-scale conservation planning: convergence, contrasts and challenges. Oryx, 43(4), 464-475. DOI: https://doi.org/10.1017/S0030605309990500"), + shiny::p("Alvarez-Romero, J. G., Adams, V. M., Pressey, R. L., Douglas, M., Dale, A. P., Auge, A. A., ... & Perdrisat, I. (2015). Integrated cross-realm planning: A decision-makers' perspective. Biological Conservation, 191, 799-808. DOI: https://doi.org/10.1016/j.biocon.2015.07.003"), + shiny::p("Niemiec, R. M., Gruby, R., Quartuch, M., Cavaliere, C. T., Teel, T. L., Crooks, K., ... & Manfredo, M. (2021). Integrating social science into conservation planning. Biological Conservation, 262, 109298. DOI: https://doi.org/10.1016/j.biocon.2021.109298"), shinyWidgets::pickerInput( inputId = ns("studyframework"), label = "Analytical Framework", @@ -303,7 +303,8 @@ mod_Design_ui <- function(id){ "Property owners"), multiple = TRUE, options = list(create = TRUE, - placeholder = "Choose from list, or type and click to add new option.")) + placeholder = "Choose from list, or type and click to add new option.") + ) ), shiny::br(), bs4Dash::box( diff --git a/R/mod_Export.R b/R/mod_Export.R index cdf5bed..b7c62e2 100644 --- a/R/mod_Export.R +++ b/R/mod_Export.R @@ -30,8 +30,8 @@ mod_Export_ui <- function(id){ shiny::p( "All protocol entries can be exported in a range of different formats for further use such as appending them to a manuscript. - It should be noted that only 'rData', 'csv' and 'yaml' are - machine-readable formats and be imported again by ODPSCP. + It should be noted that only 'csv' and 'yaml' are + machine-readable formats and can be imported again by ODPSCP. " ), shiny::br(), @@ -44,7 +44,7 @@ mod_Export_ui <- function(id){ size = "lg", status = "info", choices = c('docx', 'pdf', 'csv', 'yaml'), - selected = 'rData', + selected = 'yaml', checkIcon = list( yes = shiny::icon("circle-down"), no = NULL @@ -109,9 +109,6 @@ mod_Export_ui <- function(id){ collapsible = FALSE, DT::DTOutput(outputId = ns("results_table")) ) - # shiny::textOutput( - # outputId = ns("protocolmarkdown") - # ) ) # End Tab panel ) # End Tabset panel ) @@ -135,21 +132,13 @@ mod_Export_server <- function(id, results){ editable = FALSE) }) - # Get mandatory protocol entries - mand <- get_protocol_mandatory() - - # # 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) - # # }) + # --- # + # Check for mandatory outputs and highlight them in text + # shiny::observe(results, { + # miss <- check_protocol_mandatory(results) + # output$missingtext <- shiny::renderText({ + # paste0("No entry found for mandatory fields:", miss) + # }) # print("test") # shinyjs::toggle("downloadData") # }) @@ -162,8 +151,9 @@ mod_Export_server <- function(id, results){ filename = function() { # Compose output file paste0( + "ODPSCP__", format(Sys.Date(), "%Y_%m_%d"), - "__ODPSCP.", + ".", oftype() ) }, @@ -186,12 +176,12 @@ mod_Export_server <- function(id, results){ } else if(oftype() == "docx"){ # Create document from results, everything handled by function protocol <- format_protocol(results, format = "list") - protocol_to_document(protocol, file = file, format = "docx") # saveRDS(protocol, "test.rds") + protocol_to_document(protocol, file = file, format = "docx") } else if(oftype() == "pdf"){ # Create document from results protocol <- format_protocol(results, format = "list") - protocol_to_document(protocol, file = file,format = "pdf") + protocol_to_document(protocol, file = file, format = "pdf") } } ) diff --git a/R/mod_Import.R b/R/mod_Import.R index 21dd1e2..5c4d061 100644 --- a/R/mod_Import.R +++ b/R/mod_Import.R @@ -15,57 +15,38 @@ mod_Import_ui <- function(id){ # TODO: # Import existing Marxan / Zonation / Prioritizr configuration files? bs4Dash::tabItem(tabName = "Import", - # https://shiny.posit.co/r/gallery/widgets/file-upload/ shiny::fluidPage( bs4Dash::box( - title = "Not yet implemented", + title = shiny::tagList(shiny::icon("upload"), "Import a previously saved protocol"), closable = FALSE, - width = 12,status = "danger", + width = 12, solidHeader = TRUE, + status = "primary", + collapsed = FALSE, collapsible = FALSE, - "To be added..." - ) - # fileInput( - # inputId = ns("file1"), - # width = "100%", - # label = "Load your database", - # accept = c( - # "text/csv", - # "text/comma-separated-values", - # "text/tab-separated-values", - # "text/plain", - # ".csv", - # ".tsv", "xlsx" - # ) - # ), - # helpText("Default max. file size is 100MB"), - # box( - # title = tagList(shiny::icon("upload"), "Source"), - # solidHeader = FALSE, - # status = "success", - # maximizable = F, - # closable = F, - # width = 12, - # shinyWidgets::radioGroupButtons( - # inputId = ns("Id004"), - # choices = c("Example Data" = 1, "Import Data" = 2, "BrAPI" = 3), - # status = "success", - # selected = 1 - # ), - # shiny::conditionalPanel( - # condition = "input.Id004==1", - # h6("Use example data"), - # ns = ns - # ), - # shiny::conditionalPanel( - # condition = "input.Id004==2", - # h6("Import external data preferably csv/txt files."), - # ns = ns - # ) - # ) + shiny::p("Here you can upload a previously saved protocol file. This + file needs to be either in yaml or csv format. After uploading, + the various entries in the protocol will be filled with the previous version."), + 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::br(), + shiny::hr(), + shiny::fileInput( + inputId = ns("protocolFile"), + width = "100%", + label = "Load a previously exported protocol", + accept = c( + "text/csv", + "text/comma-separated-values", + ".yaml" + ) + ), + shiny::helpText("Default max. file size is 30MB") + ) # End of box ) # End fluid page - ) - + ) # End of tab box } #' Import Server Functions @@ -75,6 +56,57 @@ mod_Import_server <- function(id){ shiny::moduleServer( id, function(input, output, session){ ns <- session$ns + # Parse the results + imports <- shiny::reactive({ + file <- input$protocolFile$datapath + # Request the file + shiny::req(file) + + if(is.null(input$protocolFile)){ + return(NULL) + } + # Get extension + ext <- tools::file_ext(file) + # Different processing depending on upload type + out <- tryCatch({ + switch(ext, + csv = utils::read.csv(file, sep = ","), + yaml = yaml::read_yaml(file), + shiny::validate("Invalid file; Please upload a .csv or .yaml file!") + ) + }, + error = function(e) { + # return a safeError if a parsing error occurs + stop(shiny::safeError(e)) + } + ) + # Checks + if(inherits(out, "try-error")){ + shiny::showNotification("File not valid!", duration = 2, type = "error") + return(NULL) + } else if(is.data.frame(out)){ + shiny::validate( + shiny::need(nrow(out)>10, "Uploaded dataframe seems to small?") + ) + } else if(is.list(out)){ + shiny::validate( + shiny::need(length(out)>=5, "Uploaded data requires 5 entry groups.") + ) + } + return(out) + }) + + # Validate the protocol and import protocol + shiny::observeEvent(imports(), { + if(!is.null(imports())){ + check <- validate_protocol_results(imports()) + if(!is.null(check)){ + shiny::showNotification(check, duration = 5,closeButton = TRUE, type = "error") + } + } + # Insert protocol + bs4Dash::updateTabItems(session, inputId = "sidebarmenu", selected = "Overview") + }) }) } diff --git a/R/mod_News.R b/R/mod_News.R index 916fadb..d5841e7 100644 --- a/R/mod_News.R +++ b/R/mod_News.R @@ -48,20 +48,20 @@ mod_News_ui <- function(id){ width = 12, shiny::verbatimTextOutput(ns("current_protocol")) ) - ), - shiny::tabPanel( - title = "R Session Info", - shiny::br(), - bs4Dash::box( - title = "R Session Info", - status = "primary", - solidHeader = TRUE, - collapsed = FALSE, - width = 12, - shiny::verbatimTextOutput(ns("Rsession")) - ) ) - ) + # shiny::tabPanel( + # title = "R Session Info", + # shiny::br(), + # bs4Dash::box( + # title = "R Session Info", + # status = "primary", + # solidHeader = TRUE, + # collapsed = FALSE, + # width = 12, + # shiny::verbatimTextOutput(ns("Rsession")) + # ) + # ) + ) # End of tabset ) ) ) # End fluidpage @@ -76,9 +76,9 @@ mod_News_server <- function(id){ ns <- session$ns # Print out the current Rsession - output$Rsession <- shiny::renderPrint( - print(utils::sessionInfo()) - ) + # output$Rsession <- shiny::renderPrint( + # print(utils::sessionInfo()) + # ) # Get the protocol for print ppath <- system.file("01_protocol.yaml", diff --git a/R/mod_Overview.R b/R/mod_Overview.R index 5a480bc..970f344 100644 --- a/R/mod_Overview.R +++ b/R/mod_Overview.R @@ -17,20 +17,20 @@ mod_Overview_ui <- function(id){ shiny::fluidPage( shiny::fluidRow( shiny::column(width = 12, - bs4Dash::box( - title = "Provide an overview of the conducted work", - closable = FALSE, - width = 12, - solidHeader = FALSE, - collapsible = FALSE, - "Let's start with a new reporting protocol. In the overview step we describe - all the properties of the conducted planning study. The entries below - intend to both uniquely identify the study, provide necessary information - on the availability of code or data and allows to categorizes the study itself - based on the listed properties. - ", - shiny::br(), - shiny::strong("By default example popups are shown for text fields, which can be disabled through the questionmark at the top bar.") + bs4Dash::box( + title = "Provide an overview of the conducted work", + closable = FALSE, + width = 12, + solidHeader = FALSE, + collapsible = FALSE, + "Let's start with a new reporting protocol. In the overview step we describe + all the properties of the conducted planning study. The entries below + intend to both uniquely identify the study, provide necessary information + on the availability of code or data and allows to categorizes the study itself + based on the listed properties. + ", + shiny::br(), + shiny::strong("By default example popups are shown for text fields, which can be disabled through the questionmark at the top bar.") ), shiny::hr() ) @@ -84,19 +84,6 @@ mod_Overview_ui <- function(id){ placeholder = 'Email of the corresponding author', height = "45px", width = "100%", resize = "none") ), - # Corresponding author - bs4Dash::box( - title = "(Optional) Corresponding Author ID", - closable = FALSE, - width = 12, - solidHeader = TRUE, - status = "secondary", - collapsible = FALSE, - shiny::div("A ORCID can be used as unique identifier of the lead author even if institutions and emails change."), - shiny::textAreaInput(inputId = ns("authorid"), label = "", - placeholder = 'ORCID of the corresponding author if existing', - height = "45px", width = "100%", resize = "none") - ), # Link to study bs4Dash::box( title = "(Optional) Link to study", diff --git a/R/mod_Prioritization.R b/R/mod_Prioritization.R index e101f1e..8f9304a 100644 --- a/R/mod_Prioritization.R +++ b/R/mod_Prioritization.R @@ -89,7 +89,7 @@ mod_Prioritization_ui <- function(id){ # Objective functions shiny::br(), bs4Dash::box( - title = "(Optional) Outcome identification", + title = "Outcome identification", closable = FALSE, width = 12, solidHeader = TRUE, @@ -150,13 +150,10 @@ mod_Prioritization_ui <- function(id){ "External indicator", "Other") ), - shiny::conditionalPanel( - condition = "input.identsolution == 'Other'", - ns = ns, - shiny::textAreaInput(inputId = ns("otheridentification"), label = "", - placeholder = 'Explain how final solutions were obtained', - height = "45px", width = "100%", resize = "vertical") - ) + # Explain + shiny::textAreaInput(inputId = ns("otheridentification"), label = "", + placeholder = 'Explain how final solutions were obtained.', + height = "45px", width = "100%", resize = "vertical") ) ) ) diff --git a/R/mod_Specification.R b/R/mod_Specification.R index 4641f0e..5447e1b 100644 --- a/R/mod_Specification.R +++ b/R/mod_Specification.R @@ -280,7 +280,7 @@ mod_Specification_ui <- function(id){ or that, directly or indirectly, shape the planning outcome. The threat description broadly follows the IUCN Threat categorization system."), shiny::br(), - shiny::helpText("IUCN Threat classification: https://www.iucnredlist.org/resources/threat-classification-scheme"), + shiny::p("IUCN Threat classification: https://www.iucnredlist.org/resources/threat-classification-scheme"), # Threat types bs4Dash::box( title = "Threat types", @@ -312,13 +312,9 @@ mod_Specification_ui <- function(id){ ), shiny::br(), # Any other types? - shiny::conditionalPanel( - condition = "input.threattypes == 'Other'", - ns = ns, - shiny::textAreaInput(inputId = ns("otherthreattype"), label = "Other types", - placeholder = 'Any other type of threat not considered? Describe', - height = "45px", width = "100%", resize = "none") - ) + shiny::textAreaInput(inputId = ns("otherthreattype"), label = "Other types", + placeholder = 'Any other type of threat not considered? Describe', + height = "45px", width = "100%", resize = "none") ), # Threat type box end shiny::br(), # How were Threats considered/included? @@ -417,8 +413,8 @@ mod_Specification_ui <- function(id){ solidHeader = TRUE, status = "secondary", collapsible = FALSE, - shiny::p("An example is the use of Overall Species richness as - aggregated sum of species distributions in the planning"), + shiny::p("An common example is the use of 'stacked' distribution + layers and subsequent inclusion of species richness in the prioritization."), shinyWidgets::prettyToggle( inputId = ns('checkaggregated'), label_on = "Yes", @@ -474,7 +470,9 @@ mod_Specification_ui <- function(id){ describe how input features were created.'), shiny::textAreaInput(inputId = ns("featureorigin"), label = "", placeholder = 'Describe the origin of the input features', - height = "60px", width = "100%", resize = "vertical") + height = "60px", width = "100%", resize = "vertical"), + shiny::br(), + shiny::helpText("(Please be brief and where possible refer to existing text or other protocols)") ) ) ) # Fluid column end diff --git a/R/utils_format_protocol.R b/R/utils_format_protocol.R index 3d7b426..90ee5bb 100644 --- a/R/utils_format_protocol.R +++ b/R/utils_format_protocol.R @@ -100,6 +100,7 @@ format_studyregion_to_text <- function(val){ } return(val) } + #' List to table #' #' @description @@ -168,6 +169,7 @@ protocol_to_document <- function(results, file, format = "docx", path_protocol = is.character(file)) # Match the format format <- match.arg(format, c("html", "docx", "pdf"), several.ok = FALSE) + # Add docx by default (also for pandoc) if(tools::file_ext(file) != "docx") file <- paste0(tools::file_path_sans_ext(file), ".", "docx") # If is null, load protocol @@ -235,37 +237,41 @@ protocol_to_document <- function(results, file, format = "docx", path_protocol = # Add to document doc <- doc |> officer::body_add_gg(value = gg) try({ rm(gg, sp) },silent = TRUE) - } else { - # All other entries + } else if(el %in% c("authors_table","featurelist", + "evalidentification","specificzones")) { + + # Lists for example for table if(is.list(res)) { if(length(res)>0){ # Tables - ft <- flextable::flextable(res) |> + ft <- flextable::flextable( dplyr::bind_rows(res) ) |> flextable::set_table_properties(layout = "autofit") doc <- doc |> flextable::body_add_flextable(value = ft) } else { res <- "Not specified" } } + } else { + # All other entries + if(all(is.logical(res))) res <- ifelse(res, "Yes", "No") + if(all(is.na(res))) res <- "Not specified" + # 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" - + # Add to body 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") } } - # Generate output to file doc |> print(target = file) diff --git a/R/utils_load_protocol.R b/R/utils_load_protocol.R index 166fbde..893083d 100644 --- a/R/utils_load_protocol.R +++ b/R/utils_load_protocol.R @@ -146,7 +146,7 @@ get_protocol_mandatory <- function(path_protocol = NULL){ pp <- template[[gr]] for(element in names(pp)){ ppp <- pp[[element]] - if(ppp$mandatory) results <- append(results,values = ppp[['render-id']] ) + if(ppp$mandatory) results <- append(results, values = ppp[['render-id']] ) } } return(results) @@ -157,21 +157,19 @@ get_protocol_mandatory <- function(path_protocol = NULL){ #' @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){ +check_protocol_mandatory <- function(results, 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) + mand <- get_protocol_mandatory(path_protocol) out <- vector() for(gr in names(template)[-1]){ @@ -187,3 +185,59 @@ check_protocol_mandatory <- function(results, mand, path_protocol = NULL){ } return(out) } + +#' Validate loaded protocol results +#' +#' @description +#' This small helper check whether a loaded results file is actually valid. +#' In the case it is not +#' @param results A [`list`] with the protocol results. +#' @param path_protocol A [`character`] pointing to the destination of the protocol. +#' @returns Either \code{NULL} in case of no issues or a [`character`] with a error message. +#' @noRd +validate_protocol_results <- function(results, path_protocol = NULL){ + # Checks protocol + assertthat::assert_that(is.character(path_protocol) || is.null(path_protocol)) + assertthat::assert_that(is.list(results) || is.data.frame(results), + length(results)>1) + + # If is null, load protocol + template <- load_protocol(path_protocol) + + # --- # + # Entries missing + if(is.data.frame(results)){ + if(!all(results$group %in% names(template))){ + return("The loaded file is missing the protocol groups!") + } + } else { + if(!all(names(results) %in% names(template))){ + return("The loaded file is missing the protocol groups!") + } + } + + # Check specifically for data.frame + if(is.data.frame(results)){ + if(!utils::hasName(results, "group") || !utils::hasName(results, "render_id")){ + return("Necessary entries not found in uploaded data.frame!") + } + } + + # Check file ids + if(is.data.frame(results)){ + ids <- results$render_id + } else { + ids <- lapply(results, function(z) names(z)) |> unlist() + } + # Check that ids actually exist + if(!all(ids %in% get_protocol_ids(path_protocol = path_protocol))){ + return("Not all ids in the protocol file do exist in the current protocol!") + } + + # Check mandatory entries + if(!all(get_protocol_mandatory(path_protocol = path_protocol)) %in% ids){ + return("Exported protocol does not contain all mandatory groups!") + } + # --- # + return(NULL) +} diff --git a/inst/01_protocol.yaml b/inst/01_protocol.yaml index ecceab1..5e93bcf 100644 --- a/inst/01_protocol.yaml +++ b/inst/01_protocol.yaml @@ -4,7 +4,7 @@ protocol: version: '0.4' repository: 'https://github.com/iiasa/ODPSCP' website: 'https://odpscp.iiasa.ac.at/' - last_updated: 2024-09-01 + last_updated: 2024-09-30 #### Overview #### overview: @@ -38,18 +38,8 @@ overview: mandatory: true popexample: "darwin@thebeagle.ac.uk" - orcid: - render-nr: 4 - render-id: 'authorid' - render-group: 'study_box' - question: 'ORCID of the corresponding author if existing.' - description: 'A ORCID can be used as unique identifier of the lead author even if institutions and emails change.' - fieldtype: 'textbox' - mandatory: false - popexample: "A numeric id such as 000000000000000" - studylink: - render-nr: 5 + render-nr: 4 render-id: 'studylink' render-group: 'study_box' question: 'Link to the published study.' @@ -397,8 +387,8 @@ specification: inclusionexclusion: render-nr: 3 - render-id: 'zones' - render-group: 'inclusionexclusion' + render-id: 'inclusionexclusion' + render-group: 'checkzones' question: 'Any areas or actions that were included or excluded by default?' description: 'In a planning project, certain areas or actions can be included or excluded by default. ' fieldtype: 'dropdown'