Merge pull request #154 from surveydown-dev/ui_recovery

mc_multiple UI recovery solved
surveydown-dev · Dec 9, 2024 · c0db712 · c0db712
2 parents 1222c17 + 55c6f8a
commit c0db712
Show file tree

Hide file tree

Showing 3 changed files with 130 additions and 128 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,7 @@
 # surveydown (development version)
 
+- Bug fix: The `mc_multiple` question type could not resume its UI if multiple options are selected. Now it's solved.
+
 # surveydown 0.7.1
 
 - `custom` type added for `sd_question()`. Now users can create customized question types according to their own needs. A demo of leaflet map is created as well to showcase this ability.

diff --git a/R/server.R b/R/server.R
@@ -114,15 +114,15 @@
 #'
 #' @export
 sd_server <- function(
-    db                     = NULL,
-    required_questions     = NULL,
-    all_questions_required = FALSE,
-    start_page             = NULL,
-    admin_page             = FALSE,
-    auto_scroll            = FALSE,
-    rate_survey            = FALSE,
-    language               = "en",
-    use_cookies            = TRUE
+        db                     = NULL,
+        required_questions     = NULL,
+        all_questions_required = FALSE,
+        start_page             = NULL,
+        admin_page             = FALSE,
+        auto_scroll            = FALSE,
+        rate_survey            = FALSE,
+        language               = "en",
+        use_cookies            = TRUE
 ) {
 
     # 1. Initialize local variables ----
@@ -435,21 +435,21 @@ sd_server <- function(
     shiny::observe({
         # Get current page ID
         page_id <- current_page_id()
-        
+
         # Get all questions for current page
         page_questions <- names(input)[names(input) %in% question_ids]
-        
+
         # Create answers list
         answers <- list()
         last_timestamp <- NULL
         max_index <- 0
-        
+
         for (q_id in page_questions) {
             # Get question value
             val <- input[[q_id]]
             if (!is.null(val)) {
                 answers[[q_id]] <- val
-                
+
                 # If question was interacted with, check its position
                 if (!is.null(input[[paste0(q_id, "_interacted")]])) {
                     # Find this question's index in the overall sequence
@@ -464,16 +464,16 @@ sd_server <- function(
                 }
             }
         }
-        
+
         # Send to client to update cookie
         if (length(answers) > 0 && !is.null(db)) {  # Only update cookies in db mode
             page_data <- list(
                 answers = answers,
                 last_timestamp = last_timestamp
             )
-            session$sendCustomMessage("setAnswerData", 
-                                    list(pageId = page_id, 
-                                        pageData = page_data))
+            session$sendCustomMessage("setAnswerData",
+                                      list(pageId = page_id,
+                                           pageData = page_data))
         }
     })
 
@@ -1378,17 +1378,17 @@ get_local_data <- function() {
 get_cookie_data <- function(session, current_page_id) {
     # Get stored answer data from input
     answer_data <- session$input$stored_answer_data
-    
+
     if (is.null(answer_data) || !length(answer_data)) {
         return(NULL)
     }
-    
+
     # Extract data for current page
     page_data <- answer_data[[current_page_id]]
     if (is.null(page_data)) {
         return(NULL)
     }
-    
+
     # Return the full page data structure including answers and timestamps
     return(page_data)
 }
@@ -1406,7 +1406,7 @@ restore_current_page_values <- function(restore_data, session, page_filter = NUL
 }
 
 handle_data_restoration <- function(session_id, db, session, current_page_id, start_page,
-                                  question_ids, question_ts_ids, progress_updater) {
+                                    question_ids, question_ts_ids, progress_updater) {
     if (is.null(session_id)) return(NULL)
 
     # Get data based on source
@@ -1435,7 +1435,7 @@ handle_data_restoration <- function(session_id, db, session, current_page_id, st
         } else {
             current_page_id(start_page)
         }
-        
+
         # Get cookie data after page state is set
         answer_data <- NULL
         if (!is.null(db)) {
@@ -1472,7 +1472,7 @@ handle_data_restoration <- function(session_id, db, session, current_page_id, st
             # Use answer data from cookies for current page
             for (col in names(answer_data$answers)) {
                 val <- answer_data$answers[[col]]
-                if (length(val) == 1 && !is.null(val) && !is.na(val) && val != "") {
+                if (!is.null(val) && !identical(val, "")) {
                     session$sendInputMessage(col, list(value = val, priority = "event"))
                 }
             }

diff --git a/R/ui.R b/R/ui.R
@@ -55,7 +55,7 @@ sd_ui <- function() {
   theme <- get_theme(metadata)
   default_theme <- FALSE
   if (any(theme == "default")) {
-      default_theme <- TRUE
+    default_theme <- TRUE
   }
   barcolor <- get_barcolor(metadata)
   barposition <- get_barposition(metadata)
@@ -79,121 +79,121 @@ sd_ui <- function() {
       fs::file_move(paths$root_html, paths$target_html)
       message("Survey saved to ", paths$target_html, "\n")
     }, error = function(e) {
-        stop("Error rendering 'survey.qmd' file. Please review and revise the file. Error details: ", e$message)
+      stop("Error rendering 'survey.qmd' file. Please review and revise the file. Error details: ", e$message)
     })
   } else {
     # If no changes, just load head content from '_survey/head.rds'
     head_content <- readRDS(paths$target_head)
   }
 
   # Create the UI
-    shiny::tagList(
-      # Head content
-      shiny::tags$head(
-        # Survey head content (filtered)
-        shiny::HTML(head_content)
-      ),
-      # Body content
-      shiny::fluidPage(
-        shinyjs::useShinyjs(),
-        shiny::tags$script("var surveydownConfig = {};"),
-        if (!is.null(barcolor)) {
-          shiny::tags$style(htmltools::HTML(sprintf("
+  shiny::tagList(
+    # Head content
+    shiny::tags$head(
+      # Survey head content (filtered)
+      shiny::HTML(head_content)
+    ),
+    # Body content
+    shiny::fluidPage(
+      shinyjs::useShinyjs(),
+      shiny::tags$script("var surveydownConfig = {};"),
+      if (!is.null(barcolor)) {
+        shiny::tags$style(htmltools::HTML(sprintf("
             :root {
                 --progress-color: %s;
             }
           ", barcolor)))
-        },
-        if (barposition != "none") {
-          shiny::tags$div(
-            id = "progressbar",
-            class = barposition,
-            shiny::tags$div(id = "progress")
-          )
-        },
+      },
+      if (barposition != "none") {
         shiny::tags$div(
-          class = "content",
-          shiny::uiOutput("main")
+          id = "progressbar",
+          class = barposition,
+          shiny::tags$div(id = "progress")
         )
-      ) # fluidPage
-    ) # shiny::tagList()
+      },
+      shiny::tags$div(
+        class = "content",
+        shiny::uiOutput("main")
+      )
+    ) # fluidPage
+  ) # shiny::tagList()
 }
 
 get_theme <- function(metadata) {
-    x <- "survey.qmd"
-    theme <- metadata$formats$html$metadata$theme
-    if (is.null(theme)) {
-        return("default")
-    }
-    return(theme)
+  x <- "survey.qmd"
+  theme <- metadata$formats$html$metadata$theme
+  if (is.null(theme)) {
+    return("default")
+  }
+  return(theme)
 }
 
 get_barcolor <- function(metadata) {
-    barcolor <- metadata$formats$html$metadata$barcolor
-    if (!is.null(barcolor)) {
-        if (!grepl("^#([0-9A-Fa-f]{3}){1,2}$", barcolor)) {
-            stop("Invalid barcolor in YAML. Use a valid hex color.")
-        }
+  barcolor <- metadata$formats$html$metadata$barcolor
+  if (!is.null(barcolor)) {
+    if (!grepl("^#([0-9A-Fa-f]{3}){1,2}$", barcolor)) {
+      stop("Invalid barcolor in YAML. Use a valid hex color.")
     }
-    return(barcolor)
+  }
+  return(barcolor)
 }
 
 get_barposition <- function(metadata) {
-    barposition <- metadata$formats$html$metadata$barposition
-    if (is.null(barposition)) {
-        return("top")
-    }
-    return(barposition)
+  barposition <- metadata$formats$html$metadata$barposition
+  if (is.null(barposition)) {
+    return("top")
+  }
+  return(barposition)
 }
 
 survey_needs_updating <- function(paths) {
-    # Re-render if any of the target files are missing
-    targets <- c(paths$target_html, paths$target_head)
-    if (any(!fs::file_exists(targets))) { return(TRUE) }
+  # Re-render if any of the target files are missing
+  targets <- c(paths$target_html, paths$target_head)
+  if (any(!fs::file_exists(targets))) { return(TRUE) }
 
-    # Re-render if '_survey/survey.html' file is out of date with 'survey.qmd' file
-    time_qmd <- file.info(paths$qmd)$mtime
-    time_html <- file.info(paths$target_html)$mtime
+  # Re-render if '_survey/survey.html' file is out of date with 'survey.qmd' file
+  time_qmd <- file.info(paths$qmd)$mtime
+  time_html <- file.info(paths$target_html)$mtime
 
-    if (time_qmd > time_html) { return(TRUE) }
+  if (time_qmd > time_html) { return(TRUE) }
 
-    return(FALSE)
+  return(FALSE)
 }
 
 render_survey_qmd <- function(paths, default_theme = TRUE) {
-    # Copy lua filter to local folder
-    lua_file <- 'surveydown.lua'
-    fs::file_copy(
-        system.file("lua/include-resources.lua", package = "surveydown"),
-        lua_file,
-        overwrite = TRUE
-    )
+  # Copy lua filter to local folder
+  lua_file <- 'surveydown.lua'
+  fs::file_copy(
+    system.file("lua/include-resources.lua", package = "surveydown"),
+    lua_file,
+    overwrite = TRUE
+  )
 
-    # Render with Lua filter and metadata
-    quarto::quarto_render(
-        paths$qmd,
-        metadata = list(
-            default_theme = default_theme
-        ),
-        pandoc_args = c(
-            "--embed-resources",
-            "--lua-filter=surveydown.lua"
-        ),
-        quiet = TRUE
-    )
+  # Render with Lua filter and metadata
+  quarto::quarto_render(
+    paths$qmd,
+    metadata = list(
+      default_theme = default_theme
+    ),
+    pandoc_args = c(
+      "--embed-resources",
+      "--lua-filter=surveydown.lua"
+    ),
+    quiet = TRUE
+  )
 
-    # Delete local lua filter
-    fs::file_delete(lua_file)
+  # Delete local lua filter
+  fs::file_delete(lua_file)
 }
 
 extract_head_content <- function(html_content) {
-    # Head content from the rendered 'survey.html' file
-    head_content <- html_content |>
-        rvest::html_element("head") |>
-        rvest::html_children() |>
-        sapply(as.character) |>
-        paste(collapse = "\n")
-    return(head_content)
+  # Head content from the rendered 'survey.html' file
+  head_content <- html_content |>
+    rvest::html_element("head") |>
+    rvest::html_children() |>
+    sapply(as.character) |>
+    paste(collapse = "\n")
+  return(head_content)
 }
 
 #' Create a survey question
@@ -491,33 +491,33 @@ sd_question <- function(
       )
     )
   } else if (type == "custom") {
-      # Handle the main question container structure
-      output <- shiny::div(
-        class = "question-container",
-        `data-question-id` = id,
-        shiny::tags$label(class = "control-label", label),
-        # Hidden input to store the value
-        shiny::div(
-          style = "display: none;",
-          shiny::textInput(
-            inputId = id,
-            label = NULL,
-            value = "",
-            width = "0px"
-          )
-        ),
-        # Custom content container
-        shiny::div(
-          class = "custom-content",
-          onclick = sprintf(
-            "Shiny.setInputValue('%s_interacted', true, {priority: 'event'});",
-            id
-          ),
-          # Allow for custom content through option parameter
-          option
+    # Handle the main question container structure
+    output <- shiny::div(
+      class = "question-container",
+      `data-question-id` = id,
+      shiny::tags$label(class = "control-label", label),
+      # Hidden input to store the value
+      shiny::div(
+        style = "display: none;",
+        shiny::textInput(
+          inputId = id,
+          label = NULL,
+          value = "",
+          width = "0px"
+        )
+      ),
+      # Custom content container
+      shiny::div(
+        class = "custom-content",
+        onclick = sprintf(
+          "Shiny.setInputValue('%s_interacted', true, {priority: 'event'});",
+          id
         ),
-        shiny::tags$span(class = "hidden-asterisk", "*")
-      )
+        # Allow for custom content through option parameter
+        option
+      ),
+      shiny::tags$span(class = "hidden-asterisk", "*")
+    )
   }
 
   # Create wrapper div