Release Version: 24.11.1: Feat/1 update questions (#3)

.Rprofile

@@ -1,4 +1,18 @@
+# When starting a new R session, a specific directory is added to the libPath.
+# It's called libWin resp. libLinux. As it is on the first libPath position,
+# packages are installed into this directory by default. This enables working in
+# a sandbox.
+
 .First <- function() {
+  # Check operating system
+  if (Sys.info()["sysname"] == "Windows") {
+    # Add libWin with the full path to libPaths
+    .libPaths(new = c(paste(getwd(), "libWin", sep = "/"), .libPaths()))
+  } else if (Sys.info()["sysname"] == "Linux") {
+    .libPaths(new = c(paste(getwd(), "libLinux", sep = "/"), .libPaths()))
+  } else if (Sys.info()["sysname"] == "Darwin") {
+    .libPaths(new = c(paste(getwd(), "libMac", sep = "/"), .libPaths()))
+  }
   options(repos = c(getOption("repos"),
                     PANDORA = "https://Pandora-IsoMemo.github.io/drat/",
                     INWTLab = "https://inwtlab.github.io/drat/"

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: InquiryR
 Type: Package
 Title: Inquiry app for expert elicitation
-Version: 24.11.0
+Version: 24.11.1.1
 Authors@R: c(person("Antonia", "Runge", email = "antonia.runge@inwt-statistics.de", role = c("aut", "cre")))
 Description: An app for creating Inquiry templates, conducting a survey, and downloading the results based on the shinysurveys package.
 License: GPL (>= 3)
@@ -13,8 +13,16 @@ Suggests:
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 Imports:
+  cyphr,
+  DataTools (>= 24.11.0),
+  dplyr,
+  DT,
   futile.logger,
   jsonlite,
   shiny,
+  shinyjs,
   shinysurveys,
-  shinyTools
+  shinyTools (>= 24.11.1),
+  shinyWidgets,
+  sodium,
+  stats

Dockerfile

@@ -8,6 +8,7 @@ jags \
 qpdf \
 pandoc \
 libmagick++-dev \
+libsodium-dev \
 && echo "options(repos = c(getOption('repos'), PANDORA = 'https://Pandora-IsoMemo.github.io/drat/'))" >> /usr/local/lib/R/etc/Rprofile.site \
 && installPackage
 

NAMESPACE

@@ -1,3 +1,35 @@
 # Generated by roxygen2: do not edit by hand
 
+export(empty_template)
+export(inquiryTemplateServer)
+export(inquiryTemplateUI)
+export(is_encrypted)
+export(loadInquiryServer)
+export(loadInquiryUI)
+export(sanitizeQuestions)
+export(sanitizeQuestionsForJson)
 export(startApplication)
+export(validateImport)
+import(shiny, except = c(renderDataTable, dataTableOutput))
+importFrom(DT,DTOutput)
+importFrom(DT,datatable)
+importFrom(DT,renderDT)
+importFrom(DataTools,importOptions)
+importFrom(DataTools,importServer)
+importFrom(DataTools,importUI)
+importFrom(DataTools,updateListNamesIfDuplicate)
+importFrom(cyphr,decrypt_object)
+importFrom(cyphr,encrypt_object)
+importFrom(cyphr,key_sodium)
+importFrom(dplyr,"%>%")
+importFrom(dplyr,distinct)
+importFrom(dplyr,mutate)
+importFrom(shinyTools,shinyTryCatch)
+importFrom(shinyWidgets,pickerInput)
+importFrom(shinyWidgets,updatePickerInput)
+importFrom(shinyjs,disable)
+importFrom(shinyjs,enable)
+importFrom(shinyjs,hide)
+importFrom(shinyjs,show)
+importFrom(sodium,hash)
+importFrom(stats,setNames)

NEWS.md

@@ -1,3 +1,16 @@
+# InquiryR 24.11.1
+
+## New Features
+- option to import and modify inquiry templates (#1)
+  - set an inquiry _name_ and a _description_ 
+  - add _standard_ questions as supported by `shinysurveys` package, see [vignette](https://shinysurveys.jdtrat.com/articles/surveying-shinysurveys.html)
+  - remove questions from the template
+  - edit cells of the questions data frame
+- option to add a password before saving a template (#2)
+  - the password is required to load the template: either to modify the template or to respond to the inquiry
+  - when a password is set, the template is saved as an encrypted object; the download is a `raw` file instead of a `json` file
+  - after import, the file is checked if it is encrypted and if so, the user must enter the password to load it
+
 # InquiryR 24.11.0
 
 ## New Features

R/00-Namespace.R

@@ -0,0 +1,12 @@
+#' @rawNamespace import(shiny, except = c(renderDataTable, dataTableOutput))
+#' @importFrom cyphr decrypt_object encrypt_object key_sodium
+#' @importFrom DataTools importOptions importServer importUI updateListNamesIfDuplicate
+#' @importFrom dplyr %>% distinct mutate
+#' @importFrom DT datatable DTOutput renderDT
+#' @importFrom shinyjs disable enable hide show
+#' @importFrom shinyTools shinyTryCatch
+#' @importFrom shinyWidgets pickerInput updatePickerInput
+#' @importFrom sodium hash
+#' @importFrom stats setNames
+
+NULL

R/01-inquiryTemplate-module.R

@@ -0,0 +1,232 @@
+#' Inquiry Template UI
+#'
+#' @rdname inquiryTemplateServer
+#'
+#' @export
+inquiryTemplateUI <- function(id) {
+  ns <- NS(id)
+  tagList(
+    fluidRow(
+      column(
+        3,
+        style = "margin-top: 1em;",
+        textInput(
+          ns("title"),
+          label = NULL,
+          placeholder = "Enter template name*",
+          width = "100%"
+        )
+      ),
+      column(
+        9,
+        style = "margin-top: 1em;",
+        textInput(
+          ns("description"),
+          label = NULL,
+          placeholder = "Enter template description",
+          width = "100%"
+        )
+      )
+    ),
+    tags$br(),
+    addQuestionUI(ns("new_question")),
+    tags$br(),
+    removeQuestionUI(ns("remove_questions")),
+    tags$hr(),
+    tags$br(),
+    fluidRow(
+      column(10, DT::DTOutput(ns(
+        "questions_table"
+      ))),
+      column(
+        2,
+        actionButton(ns("submit"), "Submit Template", width = "100%"),
+        checkboxInput(ns("add_password"), "Add Password"),
+        conditionalPanel(
+          ns = ns,
+          condition = "input.add_password",
+          passwordInput(ns("password"), "Password"),
+          checkboxInput(ns("show_password"), "Show Password", value = FALSE)
+        )
+      )
+    )
+  )
+}
+
+#' Inquiry Template Server
+#'
+#' @param id The module id
+#' @param init_template An inquiry template containing the questions data frame
+#'
+#' @export
+inquiryTemplateServer <- function(id, init_template) {
+  moduleServer(id, function(input, output, session) {
+    ns <- session$ns
+
+    submitted_templates <- reactiveVal(list())
+
+    # observe Inquiry name and description ----
+    observe({
+      req(!identical(init_template$title, input$title))
+      logDebug("%s: Update 'input$title' value.", id)
+      updateTextInput(session, "title", value = init_template$title)
+    }) %>% bindEvent(init_template$title)
+
+    observe({
+      req(!identical(init_template$description, input$description))
+      logDebug("%s: Update 'input$description' value.", id)
+      updateTextInput(session, "description", value = init_template$description)
+    }) %>% bindEvent(init_template$description)
+
+    observe({
+      req(!identical(init_template$title, input$title))
+      logDebug("%s: Set 'init_template$title' value.", id)
+      init_template$title <- input$title
+    }) %>% bindEvent(input$title)
+
+    observe({
+      req(!identical(init_template$description, input$description))
+      logDebug("%s: Set 'init_template$description' value.", id)
+      init_template$description <- input$description
+    }) %>% bindEvent(input$description)
+
+    # render questions ----
+    output$questions_table <- DT::renderDT({
+      shiny::validate(need(
+        nrow(init_template$questions) > 0,
+        "Please add questions first ..."
+      ))
+      DT::datatable(init_template$questions,
+                    caption = "Questions dataframe: To change the value of a cell double click on it.",
+                    editable = TRUE,
+                    width = "100%")
+    })
+
+    observe({
+      logDebug("%s: Editing question dataframe.", id)
+      info <- input$questions_table_cell_edit
+      # update the reactive dataframe with the edited value
+      init_template$questions[info$row, info$col] <- info$value
+    }) %>% bindEvent(input$questions_table_cell_edit)
+
+    # observe new/removed questions ----
+    new_question <- addQuestionServer("new_question", reactive(init_template$questions))
+
+    observe({
+      logDebug("%s: Add new question.", id)
+      init_template$questions <- rbind(init_template$questions, new_question()) %>%
+        distinct() %>%
+        shinyTools::shinyTryCatch(errorTitle = "Adding question failed", alertStyle = "shinyalert")
+    }) %>% bindEvent(new_question())
+
+    new_questions <- removeQuestionServer("remove_questions", questions = reactive(init_template$questions))
+
+    observe({
+      logDebug("%s: Remove selected questions.", id)
+      init_template$questions <- new_questions()
+    }) %>% bindEvent(new_questions())
+
+    # show/hide password
+    observeShowPassword(input, id_password = ns("password"))
+
+    # enable/disable 'Submit' button
+    observe({
+      logDebug("%s: Enable/Disable 'Submit' button.", id)
+      if (!is.null(init_template$title) &&
+          init_template$title != "" &&
+          nrow(init_template$questions) > 0) {
+        shinyjs::enable(ns("submit"), asis = TRUE)
+      } else {
+        shinyjs::disable(ns("submit"), asis = TRUE)
+      }
+    })
+
+    # submit the inquiry template
+    save_template <- reactiveVal(FALSE)
+
+    observe({
+      logDebug("%s: Submit Inquiry Template.", id)
+
+      # check if name already exists
+      if (init_template$title %in% names(submitted_templates())) {
+        # ask the user if they want to overwrite the template
+        showModal(
+          modalDialog(
+            title = "Overwrite Template?",
+            "The template already exists. Do you want to overwrite it?",
+            footer = tagList(
+              modalButton("Cancel"),
+              actionButton(ns("confirm_overwrite"), label = "Overwrite")
+            )
+          )
+        )
+
+        observe({
+          logDebug("%s: Confirm Overwrite.", id)
+          # Save new value and close the modal
+          save_template(TRUE)
+          removeModal()
+        }) %>%
+          bindEvent(input$confirm_overwrite)
+      } else {
+        # else save the template
+        save_template(TRUE)
+      }
+    }) %>%
+      bindEvent(input$submit)
+
+    observe({
+      req(isTRUE(save_template()))
+      logDebug("%s: Save Inquiry Template.", id)
+      new_templates <- submitted_templates()
+
+      if (isFALSE(input$add_password)) {
+        new_template <- reactiveValuesToList(init_template)
+      }
+
+      if (isTRUE(input$add_password)) {
+        if (is.null(input$password) || input$password == "") {
+          showNotification("Please enter a password to encrypt the template.",
+                           duration = 5)
+          new_template <- NULL
+        } else{
+          # encrypt template using cyphr
+          key <- key_sodium(hash(charToRaw(input$password)))
+          message(input$password)
+          new_template <- encrypt_object(reactiveValuesToList(init_template), key)
+        }
+      }
+
+      # reset the trigger variable
+      save_template(FALSE)
+
+      req(new_template)
+      new_templates[[init_template$title]] <- new_template
+      submitted_templates(new_templates)
+      # notify user that the template was submitted
+      showNotification("An Inquiry Template has been saved", duration = 5)
+      # clean password
+      updateCheckboxInput(session, "show_password", value = FALSE)
+      updateTextInput(session, "password", value = "")
+    }) %>%
+      bindEvent(save_template())
+
+    return(submitted_templates)
+  })
+}
+
+# Observe Show/Hide Password
+#
+# @param input The input object
+# @param id_password The password input id
+# @param input_show The checkbox input id
+observeShowPassword <- function(input, id_password, input_show = "show_password") {
+  observe({
+    logDebug("Show/Hide password.")
+    if (isTRUE(input[[input_show]])) {
+      shinyjs::runjs(sprintf("$('#%s').attr('type', 'text');", id_password))
+    } else {
+      shinyjs::runjs(sprintf("$('#%s').attr('type', 'password');", id_password))
+    }
+  })
+}