From b7488c9a621970c1fe28e82ccb2386780c838403 Mon Sep 17 00:00:00 2001 From: Pingfan Hu Date: Fri, 29 Nov 2024 16:12:58 -0500 Subject: [PATCH] minor updates --- R/config.R | 989 +++++++++++++++++++++++++---------------------------- R/db.R | 20 +- R/ui.R | 896 +++++++++++++++++++++++------------------------- R/util.R | 348 ++++++++++--------- 4 files changed, 1107 insertions(+), 1146 deletions(-) diff --git a/R/config.R b/R/config.R index 24b7a393..c9dcf68a 100644 --- a/R/config.R +++ b/R/config.R @@ -8,602 +8,563 @@ run_config <- function( rate_survey, language ) { - # Check for sd_close() in survey.qmd if rate_survey used - if (rate_survey) { check_sd_close() } + # Check for sd_close() in survey.qmd if rate_survey used + if (rate_survey) { check_sd_close() } - # Get paths to files and create '_survey' folder if necessary - paths <- get_paths() + # Get paths to files and create '_survey' folder if necessary + paths <- get_paths() - # Check for changes in survey.qmd and app.R files - files_need_updating <- check_files_need_updating(paths) + # Check for changes in survey.qmd and app.R files + files_need_updating <- check_files_need_updating(paths) - if (files_need_updating) { - message("Output files not up-to-date - rendering qmd file and extracting content.") + if (files_need_updating) { + message("Output files not up-to-date - rendering qmd file and extracting content.") - # Prepare translations (check for inputs) - set_translations(paths, language) + # Prepare translations (check for inputs) + set_translations(paths, language) - # Render the qmd file into the "_survey" folder - render_qmd(paths) + # Render the qmd file into the "_survey" folder + render_qmd(paths) - # Get the html content from the rendered survey.html file - html_content <- rvest::read_html(paths$target_html) + # Get the html content from the rendered survey.html file + html_content <- rvest::read_html(paths$target_html) - # Extract head content (for CSS and JS) and save to "_survey" folder - head_content <- extract_head_content(paths, html_content) + # Extract head content (for CSS and JS) and save to "_survey" folder + head_content <- extract_head_content(paths, html_content) - # Extract all divs with class "sd-page" and save to "_survey" folder - pages <- extract_html_pages( - paths, html_content, required_questions, - all_questions_required, show_if - ) - - # Get the question structure (If changes detected, extract from HTML, otherwise YAML) - question_structure <- get_question_structure(paths, html_content) - - message( - 'Survey rendered and saved to "', paths$target_html, - '. Extracted content saved to "', paths$target_pages, '", "', - paths$target_head, '", and "', paths$target_questions, '" files.' - ) - - } else { - message( - 'No changes detected. Importing contents from "_survey" folder.' - ) - - # Load head content from _survey folder - head_content <- readRDS(paths$target_head) - - # Load pages object from _survey folder - pages <- readRDS(paths$target_pages) - - # Load question structure from _survey folder - question_structure <- load_question_structure_yaml(paths$target_questions) - } - - # Get page and question IDs - page_ids <- sapply(pages, function(p) p$id) - question_ids <- names(question_structure) - - # Check for duplicate, overlapping, or pre-defined IDs - check_ids(page_ids, question_ids) - - # Determine required questions, excluding matrix question IDs - if (all_questions_required) { - matrix_question_ids <- names(which(sapply(question_structure, `[[`, "is_matrix"))) - question_required <- setdiff(question_ids, matrix_question_ids) - } else { - question_required <- required_questions - } + # Extract all divs with class "sd-page" and save to "_survey" folder + pages <- extract_html_pages( + paths, html_content, required_questions, + all_questions_required, show_if + ) - # Check that start_page (if used) points to an actual page - if (!is.null(start_page) && !(start_page %in% page_ids)) { - stop("The specified start_page does not exist - check that you have not mis-spelled the id") - } + # Get the question structure (If changes detected, extract from HTML, otherwise YAML) + question_structure <- get_question_structure(paths, html_content) - # Set the start page - if (is.null(start_page)) { - start_page <- page_ids[1] - } + message( + 'Survey rendered and saved to "', paths$target_html, + '. Extracted content saved to "', paths$target_pages, '", "', + paths$target_head, '", and "', paths$target_questions, '" files.' + ) - # Check skip_if and show_if inputs - question_values <- unname(unlist(lapply(question_structure, `[[`, "options"))) - - check_skip_show(question_ids, question_values, page_ids, skip_if, show_if) - - # Store all config settings - config <- list( - pages = pages, - head_content = head_content, - page_ids = page_ids, - question_ids = question_ids, - question_required = question_required, - start_page = start_page, - admin_page = admin_page, - question_structure = question_structure + } else { + message( + 'No changes detected. Importing contents from "_survey" folder.' ) - return(config) + # Load head content from _survey folder + head_content <- readRDS(paths$target_head) + + # Load pages object from _survey folder + pages <- readRDS(paths$target_pages) + + # Load question structure from _survey folder + question_structure <- load_question_structure_yaml(paths$target_questions) + } + + # Get page and question IDs + page_ids <- sapply(pages, function(p) p$id) + question_ids <- names(question_structure) + + # Check for duplicate, overlapping, or pre-defined IDs + check_ids(page_ids, question_ids) + + # Determine required questions, excluding matrix question IDs + if (all_questions_required) { + matrix_question_ids <- names(which(sapply(question_structure, `[[`, "is_matrix"))) + question_required <- setdiff(question_ids, matrix_question_ids) + } else { + question_required <- required_questions + } + + # Check that start_page (if used) points to an actual page + if (!is.null(start_page) && !(start_page %in% page_ids)) { + stop("The specified start_page does not exist - check that you have not mis-spelled the id") + } + + # Set the start page + if (is.null(start_page)) { + start_page <- page_ids[1] + } + + # Check skip_if and show_if inputs + question_values <- unname(unlist(lapply(question_structure, `[[`, "options"))) + check_skip_show(question_ids, question_values, page_ids, skip_if, show_if) + + # Store all config settings + config <- list( + pages = pages, + head_content = head_content, + page_ids = page_ids, + question_ids = question_ids, + question_required = question_required, + start_page = start_page, + admin_page = admin_page, + question_structure = question_structure + ) + return(config) } check_sd_close <- function() { - # Read the content of survey.qmd - qmd_content <- readLines('survey.qmd', warn = FALSE) + # Read the content of survey.qmd + qmd_content <- readLines('survey.qmd', warn = FALSE) - # Check for sd_close() call with any parameters - sd_close_present <- any(grepl("sd_close\\s*\\(.*\\)", qmd_content)) + # Check for sd_close() call with any parameters + sd_close_present <- any(grepl("sd_close\\s*\\(.*\\)", qmd_content)) - if (!sd_close_present) { - warning("\u274C No sd_close() function found in 'survey.qmd' file. You must use sd_close() to trigger the rating question response at the end of the survey. You can also remove this rating question by setting 'rate_survey = FALSE' in sd_server().") - } + if (!sd_close_present) { + warning("\u274C No sd_close() function found in 'survey.qmd' file. You must use sd_close() to trigger the rating question response at the end of the survey. You can also remove this rating question by setting 'rate_survey = FALSE' in sd_server().") + } } get_paths <- function() { - target_folder <- "_survey" - - if (!fs::dir_exists(target_folder)) { fs::dir_create(target_folder)} - - paths <- list( - qmd = "survey.qmd", - app = "app.R", - root_html = "survey.html", - transl = "translations.yml", - target_transl = file.path(target_folder, "translations.yml"), - target_html = file.path(target_folder, "survey.html"), - target_pages = file.path(target_folder, "pages.rds"), - target_head = file.path(target_folder, "head.rds"), - target_questions = file.path(target_folder, "questions.yml") - ) - return(paths) + target_folder <- "_survey" + if (!fs::dir_exists(target_folder)) { fs::dir_create(target_folder)} + paths <- list( + qmd = "survey.qmd", + app = "app.R", + root_html = "survey.html", + transl = "translations.yml", + target_transl = file.path(target_folder, "translations.yml"), + target_html = file.path(target_folder, "survey.html"), + target_pages = file.path(target_folder, "pages.rds"), + target_head = file.path(target_folder, "head.rds"), + target_questions = file.path(target_folder, "questions.yml") + ) + return(paths) } check_files_need_updating <- function(paths) { - # Re-render if any of the target files are missing - targets <- c( - paths$target_html, paths$target_pages, - paths$target_head, paths$target_questions - ) - if (any(!fs::file_exists(targets))) { return(TRUE) } - - # Re-render if the target pages file is out of date with 'survey.qmd', 'app.R' - time_qmd <- file.info(paths$qmd)$mtime - time_app <- file.info(paths$app)$mtime - time_pages <- file.info(paths$target_pages)$mtime - - if ((time_qmd > time_pages) || (time_app > time_pages)) { return(TRUE) } - - # Re-render if the user provided a 'translations.yml' file which is out of date - if (fs::file_exists(paths$transl)) { - - time_transl <- file.info(paths$transl)$mtime - - if (time_transl > time_pages) { return(TRUE) } - } - - return(FALSE) + # Re-render if any of the target files are missing + targets <- c( + paths$target_html, paths$target_pages, + paths$target_head, paths$target_questions + ) + if (any(!fs::file_exists(targets))) { return(TRUE) } + + # Re-render if the target pages file is out of date with 'survey.qmd', 'app.R' + time_qmd <- file.info(paths$qmd)$mtime + time_app <- file.info(paths$app)$mtime + time_pages <- file.info(paths$target_pages)$mtime + + if ((time_qmd > time_pages) || (time_app > time_pages)) { return(TRUE) } + + # Re-render if the user provided a 'translations.yml' file which is out of date + if (fs::file_exists(paths$transl)) { + time_transl <- file.info(paths$transl)$mtime + if (time_transl > time_pages) { return(TRUE) } + } + return(FALSE) } set_translations <- function(paths, language) { - # Load default translations - translations <- get_translations_default() - - # Check for valid language input (see https://shiny.posit.co/r/reference/shiny/1.7.0/dateinput) - valid_languages <- get_valid_languages() - - # Fallback to English if not set or not supported (from shiny::dateInput()) - if (is.null(language) || !(language %in% valid_languages)) { - message("Invalid or unsupported language selected. Falling back to predefined English.") - message("Check https://shiny.posit.co/r/reference/shiny/1.7.0/dateinput for supported languages.") - language <- "en" - } - - # Include user provided translations if translations.yml file is in root - if (fs::file_exists(paths$transl)) { - # Read translations file and select translations for selected language - tryCatch({ - user_transl <- yaml::read_yaml(paths$transl) - user_transl <- user_transl[unique(names(user_transl))] - user_transl <- user_transl[names(user_transl) == language] - - # Check if there is a valid set of translations for - # selected language - if (length(user_transl) == 1) { - message( - "User provided translations for language '", language, - "' from '", paths$transl, "' file loaded." - ) - - # Add possible missing text elements from default - # translations (if not available, use English) - if (language %in% names(translations)) { - predef_transl <- translations[[language]] - } else { - predef_transl <- translations[["en"]] - } - user_transl[[1]] <- c( - user_transl[[1]], - predef_transl[!(names(predef_transl) %in% names(user_transl[[1]]))] - ) - - } else { - user_transl <- NULL - } - }, error = function(e) { - message( - "Error reading '", paths$transl, - "' file. Please review and revise the file. Error details: ", - e$message - ) - user_transl <- NULL - }) - - # Combine user provided translations with predefined translations - translations <- c(user_transl, translations) # user provided take precedence - } + # Load default translations + translations <- get_translations_default() + + # Check for valid language input (see https://shiny.posit.co/r/reference/shiny/1.7.0/dateinput) + valid_languages <- get_valid_languages() + + # Fallback to English if not set or not supported (from shiny::dateInput()) + if (is.null(language) || !(language %in% valid_languages)) { + message("Invalid or unsupported language selected. Falling back to predefined English.") + message("Check https://shiny.posit.co/r/reference/shiny/1.7.0/dateinput for supported languages.") + language <- "en" + } + + # Include user provided translations if translations.yml file is in root + if (fs::file_exists(paths$transl)) { + # Read translations file and select translations for selected language + tryCatch({ + user_transl <- yaml::read_yaml(paths$transl) + user_transl <- user_transl[unique(names(user_transl))] + user_transl <- user_transl[names(user_transl) == language] + + # Check for valid set of translations for selected language + if (length(user_transl) == 1) { + message( + "User provided translations for language '", language, + "' from '", paths$transl, "' file loaded." + ) - # Choose translations by chosen language - if (! language %in% names(translations)) { - # Fallback to English if no translations found for selected language - sd_create_translations(language) - translations <- translations["en"] - names(translations) <- language - } else { - translations <- translations[names(translations) == language] - translations <- translations[1] - } + # Add missing texts from default translations (if not available, use English) + if (language %in% names(translations)) { + predef_transl <- translations[[language]] + } else { + predef_transl <- translations[["en"]] + } + user_transl[[1]] <- c( + user_transl[[1]], + predef_transl[!(names(predef_transl) %in% names(user_transl[[1]]))] + ) + } else { + user_transl <- NULL + } + }, error = function(e) { + message( + "Error reading '", paths$transl, + "' file. Please review and revise the file. Error details: ", + e$message + ) + user_transl <- NULL + }) - # write translations file - yaml::write_yaml(translations, paths$target_transl) + # Combine user provided translations with predefined translations + translations <- c(user_transl, translations) # user provided take precedence + } + + # Choose translations by chosen language + if (! language %in% names(translations)) { + # Fallback to English if no translations found for selected language + sd_create_translations(language) + translations <- translations["en"] + names(translations) <- language + } else { + translations <- translations[names(translations) == language] + translations <- translations[1] + } + + # write translations file + yaml::write_yaml(translations, paths$target_transl) } render_qmd <- function(paths) { - tryCatch( - { - # Render the 'survey.qmd' file - quarto::quarto_render( - paths$qmd, - pandoc_args = c("--embed-resources") - ) - - # Move rendered 'survey.html' into '_survey' folder - fs::file_move(paths$root_html, paths$target_html) - }, - error = function(e) { - stop("Error rendering 'survey.qmd' file. Please review and revise the file. Error details: ", e$message) - } - ) + tryCatch( + { + # Render the 'survey.qmd' file + quarto::quarto_render( + paths$qmd, + pandoc_args = c("--embed-resources") + ) + + # Move rendered 'survey.html' into '_survey' folder + fs::file_move(paths$root_html, paths$target_html) + }, + error = function(e) { + stop("Error rendering 'survey.qmd' file. Please review and revise the file. Error details: ", e$message) + } + ) } extract_head_content <- function(paths, html_content) { - head_content <- html_content |> - rvest::html_element("head") |> - rvest::html_children() |> - sapply(as.character) |> - paste(collapse = "\n") - - saveRDS(head_content, paths$target_head) - - return(head_content) + head_content <- html_content |> + rvest::html_element("head") |> + rvest::html_children() |> + sapply(as.character) |> + paste(collapse = "\n") + saveRDS(head_content, paths$target_head) + return(head_content) } extract_html_pages <- function( paths, html_content, required_questions, all_questions_required, show_if ) { - pages <- html_content |> - rvest::html_elements(".sd-page") |> - lapply(function(x) { - page_id <- rvest::html_attr(x, "id") - question_containers <- rvest::html_elements(x, ".question-container") - question_ids <- character(0) - required_question_ids <- character(0) - - for (i in seq_along(question_containers)) { - container <- question_containers[[i]] - question_id <- rvest::html_attr(container, "data-question-id") - question_ids <- c(question_ids, question_id) - - # Check if it's a matrix question - is_matrix <- length(rvest::html_elements(container, ".matrix-question")) > 0 - - # Determine if the question is required - is_required <- if (is_matrix) { - FALSE # Matrix questions are not required by default - } else if (all_questions_required) { - TRUE - } else { - question_id %in% required_questions - } - - # Track required questions and display asterisk - if (is_required) { - asterisk <- rvest::html_element(container, ".hidden-asterisk") - xml2::xml_attr(asterisk, "style") <- "display: inline;" - required_question_ids <- c(required_question_ids, question_id) - } - - if (!is.null(show_if)) { - if (question_id %in% show_if$targets) { - current_style <- xml2::xml_attr(container, "style") - new_style <- paste(current_style, "display: none;", sep = " ") - xml2::xml_attr(container, "style") <- new_style - } - } - question_containers[[i]] <- container - } - - # Update the 'Next' button ID and extract the next_page_id - next_button_id <- make_next_button_id(page_id) - next_button <- rvest::html_element(x, "#page_id_next") - if (is.na(next_button)) { - # No next button on this page - next_page_id <- NULL - } else { - xml2::xml_attr(next_button, "id") <- next_button_id - next_page_id <- rvest::html_attr( - xml2::xml_parent(next_button), "data-next-page" - ) - } - - list( - id = page_id, - questions = question_ids, - required_questions = required_question_ids, - next_button_id = next_button_id, - next_page_id = next_page_id, - content = as.character(x) - ) - }) - - saveRDS(pages, paths$target_pages) - - return(pages) + pages <- html_content |> + rvest::html_elements(".sd-page") |> + lapply(function(x) { + page_id <- rvest::html_attr(x, "id") + question_containers <- rvest::html_elements(x, ".question-container") + question_ids <- character(0) + required_question_ids <- character(0) + + for (i in seq_along(question_containers)) { + container <- question_containers[[i]] + question_id <- rvest::html_attr(container, "data-question-id") + question_ids <- c(question_ids, question_id) + + # Check if it's a matrix question + is_matrix <- length(rvest::html_elements(container, ".matrix-question")) > 0 + + # Determine if the question is required + is_required <- if (is_matrix) { + FALSE # Matrix questions are not required by default + } else if (all_questions_required) { + TRUE + } else { + question_id %in% required_questions + } + + # Track required questions and display asterisk + if (is_required) { + asterisk <- rvest::html_element(container, ".hidden-asterisk") + xml2::xml_attr(asterisk, "style") <- "display: inline;" + required_question_ids <- c(required_question_ids, question_id) + } + if (!is.null(show_if)) { + if (question_id %in% show_if$targets) { + current_style <- xml2::xml_attr(container, "style") + new_style <- paste(current_style, "display: none;", sep = " ") + xml2::xml_attr(container, "style") <- new_style + } + } + question_containers[[i]] <- container + } + + # Update the 'Next' button ID and extract the next_page_id + next_button_id <- make_next_button_id(page_id) + next_button <- rvest::html_element(x, "#page_id_next") + if (is.na(next_button)) { + # No next button on this page + next_page_id <- NULL + } else { + xml2::xml_attr(next_button, "id") <- next_button_id + next_page_id <- rvest::html_attr( + xml2::xml_parent(next_button), "data-next-page" + ) + } + list( + id = page_id, + questions = question_ids, + required_questions = required_question_ids, + next_button_id = next_button_id, + next_page_id = next_page_id, + content = as.character(x) + ) + }) + saveRDS(pages, paths$target_pages) + return(pages) } # Get question structure ('smart': load YAML or extract from HTML and save to YAML) get_question_structure <- function(paths, html_content) { - - question_structure <- extract_question_structure_html(html_content) - - write_question_structure_yaml(question_structure, paths$target_questions) - - return(question_structure) + question_structure <- extract_question_structure_html(html_content) + write_question_structure_yaml(question_structure, paths$target_questions) + return(question_structure) } # Extract question structure from HTML extract_question_structure_html <- function(html_content) { - question_nodes <- rvest::html_nodes(html_content, "[data-question-id]") - - question_structure <- list() - - # Loop through all question nodes and extract information - for (question_node in question_nodes) { - question_id <- rvest::html_attr(question_node, "data-question-id") - - type <- question_node |> - rvest::html_nodes(glue::glue("#{question_id}")) |> - rvest::html_attr("class") - - is_matrix <- length(rvest::html_nodes(question_node, ".matrix-question")) > 0 - - if (is_matrix) type <- "matrix" - - # Extract the question text (label) - label <- question_node |> - rvest::html_nodes("p") |> - rvest::html_text(trim = TRUE) - - # Write main information to the question structure - question_structure[[question_id]] <- list( - type = type, - is_matrix = is_matrix, - label = label - ) - - # Extract options for the question ( mc, *_multiple, *_buttons, and select) - if (grepl("radio|checkbox|select|matrix", type)) { - - options <- question_node |> - rvest::html_nodes("input[type='radio'], input[type='checkbox'], option") |> - rvest::html_attr("value") - - label_options <- question_node |> - rvest::html_nodes("label>span, button, option") |> - rvest::html_text(trim = TRUE) - - names(options) <- label_options - - # Write options to the question structure - question_structure[[question_id]]$options <- as.list(options) - - # Extract options for the question (slider) - } else if (grepl("slider", type)) { - options_raw <- question_node |> - rvest::html_nodes("input") |> - rvest::html_attr("data-swvalues") - - options <- gsub("\\[|\\]|\\\"", "", options_raw) |> - strsplit(",") |> - unlist() - - # names(options) <- options # TODO no labels in html for slider - - question_structure[[question_id]]$options <- as.list(options) - } - - # Extract the rows and options for the matrix main question - if (is_matrix) { - - rows <- question_node |> - rvest::html_nodes("div > div[id]") |> - rvest::html_attr("id") + question_nodes <- rvest::html_nodes(html_content, "[data-question-id]") + question_structure <- list() + + # Loop through all question nodes and extract information + for (question_node in question_nodes) { + question_id <- rvest::html_attr(question_node, "data-question-id") + type <- question_node |> + rvest::html_nodes(glue::glue("#{question_id}")) |> + rvest::html_attr("class") + is_matrix <- length(rvest::html_nodes(question_node, ".matrix-question")) > 0 + + if (is_matrix) type <- "matrix" + + # Extract the question text (label) + label <- question_node |> + rvest::html_nodes("p") |> + rvest::html_text(trim = TRUE) + + # Write main information to the question structure + question_structure[[question_id]] <- list( + type = type, + is_matrix = is_matrix, + label = label + ) - # Remove the question ID prefix from the row names - rows <- gsub(glue::glue("{question_id}_"), "", rows) + # Extract options for the question ( mc, *_multiple, *_buttons, and select) + if (grepl("radio|checkbox|select|matrix", type)) { + options <- question_node |> + rvest::html_nodes("input[type='radio'], input[type='checkbox'], option") |> + rvest::html_attr("value") + label_options <- question_node |> + rvest::html_nodes("label>span, button, option") |> + rvest::html_text(trim = TRUE) + names(options) <- label_options + + # Write options to the question structure + question_structure[[question_id]]$options <- as.list(options) + + # Extract options for the question (slider) + } else if (grepl("slider", type)) { + options_raw <- question_node |> + rvest::html_nodes("input") |> + rvest::html_attr("data-swvalues") + options <- gsub("\\[|\\]|\\\"", "", options_raw) |> + strsplit(",") |> + unlist() + + # names(options) <- options # TODO no labels in html for slider + + question_structure[[question_id]]$options <- as.list(options) + } - label_rows <- question_node |> - rvest::html_nodes("td:nth-child(1)") |> - rvest::html_text(trim = TRUE) + # Extract the rows and options for the matrix main question + if (is_matrix) { + rows <- question_node |> + rvest::html_nodes("div > div[id]") |> + rvest::html_attr("id") - # remove first empty row label (option header) - label_rows <- label_rows[label_rows != ""] + # Remove the question ID prefix from the row names + rows <- gsub(glue::glue("{question_id}_"), "", rows) + label_rows <- question_node |> + rvest::html_nodes("td:nth-child(1)") |> + rvest::html_text(trim = TRUE) - names(rows) <- label_rows + # remove first empty row label (option header) + label_rows <- label_rows[label_rows != ""] + names(rows) <- label_rows - # Write rows to the question structure - question_structure[[question_id]]$row <- as.list(rows) + # Write rows to the question structure + question_structure[[question_id]]$row <- as.list(rows) - # Correct to unique options (first extraction multiplies by subquestions) - options <- options[1:(length(options) / length(rows))] - question_structure[[question_id]]$options <- as.list(options) - } + # Correct to unique options (first extraction multiplies by subquestions) + options <- options[1:(length(options) / length(rows))] + question_structure[[question_id]]$options <- as.list(options) } - - return(question_structure) + } + return(question_structure) } # Write question structure to YAML write_question_structure_yaml <- function(question_structure, file_yaml) { - # Map question types to extracted html classes - type_replacement <- c( - 'shiny-input-text form-control' = 'text', - 'shiny-input-textarea form-control' = 'textarea', - 'shiny-input-number form-control' = 'numeric', - 'form-group shiny-input-radiogroup shiny-input-container' = 'mc', - 'radio-group-buttons' = 'mc_buttons', - 'form-group shiny-input-checkboxgroup shiny-input-container' = 'mc_multiple', - 'checkbox-group-buttons' = 'mc_multiple_buttons', - 'shiny-input-select' = 'select', - 'js-range-slider sw-slider-text' = 'slider', - 'shiny-date-input form-group shiny-input-container' = 'date', - 'shiny-date-range-input form-group shiny-input-container' = 'daterange' - ) - - # Loop through question structure and clean/prepare questions - question_structure <- lapply(question_structure, function(question) { - - # Rename type to function option names - question$type <- type_replacement[names(type_replacement) == question$type] - if (question$is_matrix) { question$type <- "matrix" } - if (length(question$type) == 0) question$type <- "unknown" - - # Remove indicator if is matrix (type is correctly set) - question$is_matrix <- NULL - - # Mark matrix subquestion to remove from list (and end further processing) - if (question$type == "mc" & length(question$label) == 0) { - return(NULL) - } - - # Remove first option from select type question - if (question$type == "select") { - question$options <- question$options[-1] - } - - return(question) - }) - - # Remove NULL elements (matrix subquestions) - question_structure <- Filter(Negate(is.null), question_structure) - - # Write question to YAML (with comment in first lines) - yaml_content <- yaml::as.yaml(question_structure) - - comment_line1 <- "# ! JUST READ - don't change the content of this file\n" - comment_line2 <- "# Question structure extracted from survey.html\n" - - full_content <- paste0(comment_line1, comment_line2, yaml_content) + # Map question types to extracted html classes + type_replacement <- c( + 'shiny-input-text form-control' = 'text', + 'shiny-input-textarea form-control' = 'textarea', + 'shiny-input-number form-control' = 'numeric', + 'form-group shiny-input-radiogroup shiny-input-container' = 'mc', + 'radio-group-buttons' = 'mc_buttons', + 'form-group shiny-input-checkboxgroup shiny-input-container' = 'mc_multiple', + 'checkbox-group-buttons' = 'mc_multiple_buttons', + 'shiny-input-select' = 'select', + 'js-range-slider sw-slider-text' = 'slider', + 'shiny-date-input form-group shiny-input-container' = 'date', + 'shiny-date-range-input form-group shiny-input-container' = 'daterange' + ) + + # Loop through question structure and clean/prepare questions + question_structure <- lapply(question_structure, function(question) { + + # Rename type to function option names + question$type <- type_replacement[names(type_replacement) == question$type] + if (question$is_matrix) { question$type <- "matrix" } + if (length(question$type) == 0) question$type <- "unknown" + + # Remove indicator if is matrix (type is correctly set) + question$is_matrix <- NULL + + # Mark matrix subquestion to remove from list (and end further processing) + if (question$type == "mc" & length(question$label) == 0) { + return(NULL) + } - writeLines(full_content, con = file_yaml) + # Remove first option from select type question + if (question$type == "select") { + question$options <- question$options[-1] + } + return(question) + }) + + # Remove NULL elements (matrix subquestions) + question_structure <- Filter(Negate(is.null), question_structure) + + # Write question to YAML (with comment in first lines) + yaml_content <- yaml::as.yaml(question_structure) + comment_line1 <- "# ! JUST READ - don't change the content of this file\n" + comment_line2 <- "# Question structure extracted from survey.html\n" + full_content <- paste0(comment_line1, comment_line2, yaml_content) + writeLines(full_content, con = file_yaml) } # Load question structure from YAML load_question_structure_yaml <- function(file_yaml) { - # Read question structure from YAML file - question_structure <- yaml::read_yaml(file_yaml) - - # Add matrix question indicator to all questions as FALSE (correct later) - question_structure <- lapply(question_structure, function(question) { - question$is_matrix <- FALSE - return(question) - }) - - # Get question types to create subquestions for matrix questions - question_types <- sapply(question_structure, function(q) q$type) - matrix_questions_ids <- names(question_types)[question_types == "matrix"] - - # Loop trough matrix questions and add subquestions - for (matrix_question_id in matrix_questions_ids) { - - # Get matrix question and subquestion (rows option) from question list - matrix_question <- question_structure[[matrix_question_id]] - rows <- matrix_question$row - - # Loop over subquestions and add to question structure (with label and options) - for (row_number in seq_along(rows)) { - - subquestion_id <- paste0(matrix_question_id, "_", rows[[row_number]]) - - subquestion_structure <- list( - type = "mc", - label = names(rows)[row_number], - options = matrix_question$options - ) - - question_structure[[subquestion_id]] <- subquestion_structure - } - - # Add matrix question indicator - question_structure[[matrix_question_id]]$is_matrix <- TRUE + # Read question structure from YAML file + question_structure <- yaml::read_yaml(file_yaml) + + # Add matrix question indicator to all questions as FALSE (correct later) + question_structure <- lapply(question_structure, function(question) { + question$is_matrix <- FALSE + return(question) + }) + + # Get question types to create subquestions for matrix questions + question_types <- sapply(question_structure, function(q) q$type) + matrix_questions_ids <- names(question_types)[question_types == "matrix"] + + # Loop trough matrix questions and add subquestions + for (matrix_question_id in matrix_questions_ids) { + + # Get matrix question and subquestion (rows option) from question list + matrix_question <- question_structure[[matrix_question_id]] + rows <- matrix_question$row + + # Loop over subquestions and add to question structure (with label and options) + for (row_number in seq_along(rows)) { + subquestion_id <- paste0(matrix_question_id, "_", rows[[row_number]]) + subquestion_structure <- list( + type = "mc", + label = names(rows)[row_number], + options = matrix_question$options + ) + question_structure[[subquestion_id]] <- subquestion_structure } - # Negate NULL elements in is_matrix (matrix subquestions) - for (question in names(question_structure)) { - if (is.null(question_structure[[question]]$is_matrix)) { - question_structure[[question]]$is_matrix <- FALSE - } - } + # Add matrix question indicator + question_structure[[matrix_question_id]]$is_matrix <- TRUE + } - return(question_structure) + # Negate NULL elements in is_matrix (matrix subquestions) + for (question in names(question_structure)) { + if (is.null(question_structure[[question]]$is_matrix)) { + question_structure[[question]]$is_matrix <- FALSE + } + } + return(question_structure) } get_output_ids <- function() { - output <- shiny::getDefaultReactiveDomain()$output - outs <- shiny::outputOptions(output) - return(names(outs)) + output <- shiny::getDefaultReactiveDomain()$output + outs <- shiny::outputOptions(output) + return(names(outs)) } check_skip_show <- function( question_ids, question_values, page_ids, skip_if, show_if ) { - if (!is.null(skip_if)) { - invalid_skip_targets <- setdiff(skip_if$targets, page_ids) - if (length(invalid_skip_targets) > 0) { - stop(sprintf( - "Invalid skip_if targets: %s. These must be valid page IDs.", - paste(invalid_skip_targets, collapse = ", ")) - ) - } + if (!is.null(skip_if)) { + invalid_skip_targets <- setdiff(skip_if$targets, page_ids) + if (length(invalid_skip_targets) > 0) { + stop(sprintf( + "Invalid skip_if targets: %s. These must be valid page IDs.", + paste(invalid_skip_targets, collapse = ", ")) + ) } + } - if (!is.null(show_if)) { - # Get any potential question_ids from the output - invalid_show_targets <- setdiff( - show_if$targets, - c(question_ids, get_output_ids()) - ) - if (length(invalid_show_targets) > 0) { - stop(sprintf( - "Invalid show_if targets: %s. These must be question IDs defined in the survey.qmd file.", - paste(invalid_show_targets, collapse = ", ")) - ) - } + if (!is.null(show_if)) { + # Get any potential question_ids from the output + invalid_show_targets <- setdiff( + show_if$targets, + c(question_ids, get_output_ids()) + ) + if (length(invalid_show_targets) > 0) { + stop(sprintf( + "Invalid show_if targets: %s. These must be question IDs defined in the survey.qmd file.", + paste(invalid_show_targets, collapse = ", ")) + ) } - - return(TRUE) + } + return(TRUE) } check_ids <- function(page_ids, question_ids) { - # Check for duplicate page IDs - duplicate_page_ids <- page_ids[duplicated(page_ids)] - if (length(duplicate_page_ids) > 0) { - stop("Duplicate page IDs found: ", paste(duplicate_page_ids, collapse = ", ")) - } - - # Check for duplicate question IDs - duplicate_question_ids <- question_ids[duplicated(question_ids)] - if (length(duplicate_question_ids) > 0) { - stop("Duplicate question IDs found: ", paste(duplicate_question_ids, collapse = ", ")) - } - - # Check for restricted IDs - restricted_ids <- c("session_id", "time_start", "time_end", "exit_survey_rating") - used_restricted_ids <- intersect(restricted_ids, question_ids) - if (length(used_restricted_ids) > 0) { - stop("Restricted question IDs found: ", paste(used_restricted_ids, collapse = ", "), - ". These IDs are reserved and should not be used for survey questions.") - } + # Check for duplicate page IDs + duplicate_page_ids <- page_ids[duplicated(page_ids)] + if (length(duplicate_page_ids) > 0) { + stop("Duplicate page IDs found: ", paste(duplicate_page_ids, collapse = ", ")) + } + + # Check for duplicate question IDs + duplicate_question_ids <- question_ids[duplicated(question_ids)] + if (length(duplicate_question_ids) > 0) { + stop("Duplicate question IDs found: ", paste(duplicate_question_ids, collapse = ", ")) + } + + # Check for restricted IDs + restricted_ids <- c("session_id", "time_start", "time_end", "exit_survey_rating") + used_restricted_ids <- intersect(restricted_ids, question_ids) + if (length(used_restricted_ids) > 0) { + stop("Restricted question IDs found: ", paste(used_restricted_ids, collapse = ", "), + ". These IDs are reserved and should not be used for survey questions.") + } } diff --git a/R/db.R b/R/db.R index 964a1bd6..4fc4cc78 100644 --- a/R/db.R +++ b/R/db.R @@ -56,16 +56,16 @@ #' } #' @export sd_database <- function( - host = NULL, - dbname = NULL, - port = NULL, - user = NULL, - table = NULL, - password = Sys.getenv("SURVEYDOWN_PASSWORD"), - gssencmode = "prefer", - ignore = FALSE, - min_size = 1, - max_size = Inf + host = NULL, + dbname = NULL, + port = NULL, + user = NULL, + table = NULL, + password = Sys.getenv("SURVEYDOWN_PASSWORD"), + gssencmode = "prefer", + ignore = FALSE, + min_size = 1, + max_size = Inf ) { if (ignore) { diff --git a/R/ui.R b/R/ui.R index f0bc0f3b..1e9dd83f 100644 --- a/R/ui.R +++ b/R/ui.R @@ -1,25 +1,3 @@ -# Load resource files -load_resource <- function(..., package = "surveydown") { - files <- c(...) - lapply(files, function(file) { - file_type <- tolower(tools::file_ext(file)) - if (!(file_type %in% c("css", "js"))) { - stop(paste("Unsupported file type:", file_type, "for file:", file)) - } - path <- system.file(paste0(file_type, "/", file), package = package) - if (file.exists(path)) { - if (file_type == "css") { - shiny::includeCSS(path) - } else { - shiny::includeScript(path) - } - } else { - warning(paste("File not found:", file, "in package:", package)) - NULL - } - }) -} - #' Create the UI for a surveydown survey #' #' This function creates the user interface for a surveydown survey, @@ -70,79 +48,79 @@ load_resource <- function(..., package = "surveydown") { #' @export sd_ui <- function() { - # Throw error if "survey.qmd" file missing - if (!survey_file_exists()) { - stop('Missing "survey.qmd" file. Your survey file must be named "survey.qmd"') - } + # Throw error if "survey.qmd" file missing + if (!survey_file_exists()) { + stop('Missing "survey.qmd" file. Your survey file must be named "survey.qmd"') + } - # Get the theme from the survey.qmd file - metadata <- quarto::quarto_inspect("survey.qmd") - theme <- get_theme(metadata) - - # Get progress bar settings from the survey.qmd file - barcolor <- get_barcolor(metadata) - barposition <- get_barposition(metadata) - - shiny::fluidPage( - shinyjs::useShinyjs(), - load_resource( - "auto_scroll.js", - "cookies.js", - "countdown.js", - "enter_key.js", - "keep_alive.js", - "surveydown.css" - ), - if (any(theme == "default")) { - load_resource("default_theme.css") - }, - shiny::tags$script("var surveydownConfig = {};"), - if (!is.null(barcolor)) { - shiny::tags$style(htmltools::HTML(sprintf(" + # Get the theme from the survey.qmd file + metadata <- quarto::quarto_inspect("survey.qmd") + theme <- get_theme(metadata) + + # Get progress bar settings from the survey.qmd file + barcolor <- get_barcolor(metadata) + barposition <- get_barposition(metadata) + + shiny::fluidPage( + shinyjs::useShinyjs(), + load_resource( + "auto_scroll.js", + "cookies.js", + "countdown.js", + "enter_key.js", + "keep_alive.js", + "surveydown.css" + ), + if (any(theme == "default")) { + load_resource("default_theme.css") + }, + 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") ) + }, + shiny::tags$div( + class = "content", + shiny::uiOutput("main") ) + ) } 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) } #' Create a survey question @@ -218,269 +196,269 @@ get_barposition <- function(metadata) { #' #' @export sd_question <- function( - type, - id, - label, - cols = "80", - direction = "horizontal", - status = "default", - width = "100%", - height = "100px", - selected = NULL, - label_select = "Choose an option...", - grid = TRUE, - individual = TRUE, - justified = FALSE, - force_edges = TRUE, - option = NULL, - placeholder = NULL, - resize = NULL, - row = NULL + type, + id, + label, + cols = "80", + direction = "horizontal", + status = "default", + width = "100%", + height = "100px", + selected = NULL, + label_select = "Choose an option...", + grid = TRUE, + individual = TRUE, + justified = FALSE, + force_edges = TRUE, + option = NULL, + placeholder = NULL, + resize = NULL, + row = NULL ) { - output <- NULL + output <- NULL - # Load translations for selected label and date language option - translations <- get_translations() - language <- translations$language - translations <- translations$translations + # Load translations for selected label and date language option + translations <- get_translations() + language <- translations$language + translations <- translations$translations - # Check if question if answered - js_interaction <- sprintf("Shiny.setInputValue('%s_interacted', true, {priority: 'event'});", id) + # Check if question if answered + js_interaction <- sprintf("Shiny.setInputValue('%s_interacted', true, {priority: 'event'});", id) - # Create label with hidden asterisk - label <- markdown_to_html(label) + # Create label with hidden asterisk + label <- markdown_to_html(label) - if (type == "select") { - label_select <- translations[['choose_option']] + if (type == "select") { + label_select <- translations[['choose_option']] - # Add blank option for visible selected option - option <- c("", option) - names(option)[1] <- label_select + # Add blank option for visible selected option + option <- c("", option) + names(option)[1] <- label_select - output <- shiny::selectInput( - inputId = id, - label = label, - choices = option, - multiple = FALSE, - selected = FALSE - ) - } else if (type == "mc") { + output <- shiny::selectInput( + inputId = id, + label = label, + choices = option, + multiple = FALSE, + selected = FALSE + ) + } else if (type == "mc") { - output <- shiny::radioButtons( - inputId = id, - label = label, - choices = option, - selected = FALSE - ) + output <- shiny::radioButtons( + inputId = id, + label = label, + choices = option, + selected = FALSE + ) - } else if (type == "mc_multiple") { + } else if (type == "mc_multiple") { - output <- shiny::checkboxGroupInput( - inputId = id, - label = label, - choices = option, - selected = FALSE - ) + output <- shiny::checkboxGroupInput( + inputId = id, + label = label, + choices = option, + selected = FALSE + ) - } else if (type == "mc_buttons") { + } else if (type == "mc_buttons") { - output <- shinyWidgets::radioGroupButtons( - inputId = id, - label = label, - choices = list_name_md_to_html(option), - direction = direction, - selected = character(0) - ) + output <- shinyWidgets::radioGroupButtons( + inputId = id, + label = label, + choices = list_name_md_to_html(option), + direction = direction, + selected = character(0) + ) - output <- shiny::tagAppendChild(output, shiny::tags$script(htmltools::HTML(sprintf(" + output <- shiny::tagAppendChild(output, shiny::tags$script(htmltools::HTML(sprintf(" $(document).on('click', '#%s .btn', function() { %s }); ", id, js_interaction)))) - } else if (type == "mc_multiple_buttons") { + } else if (type == "mc_multiple_buttons") { - output <- shinyWidgets::checkboxGroupButtons( - inputId = id, - label = label, - choices = list_name_md_to_html(option), - direction = direction, - individual = individual, - justified = FALSE - ) + output <- shinyWidgets::checkboxGroupButtons( + inputId = id, + label = label, + choices = list_name_md_to_html(option), + direction = direction, + individual = individual, + justified = FALSE + ) - output <- shiny::tagAppendChild(output, shiny::tags$script(htmltools::HTML(sprintf(" + output <- shiny::tagAppendChild(output, shiny::tags$script(htmltools::HTML(sprintf(" $(document).on('click', '#%s .btn', function() { %s }); ", id, js_interaction)))) - } else if (type == "text") { + } else if (type == "text") { - output <- shiny::textInput( - inputId = id, - label = label, - placeholder = option - ) + output <- shiny::textInput( + inputId = id, + label = label, + placeholder = option + ) - } else if (type == "textarea") { - - output <- shiny::textAreaInput( - inputId = id, - label = label, - height = height, - cols = cols, - value = NULL, - rows = "6", - placeholder = placeholder, - resize = resize - ) + } else if (type == "textarea") { + + output <- shiny::textAreaInput( + inputId = id, + label = label, + height = height, + cols = cols, + value = NULL, + rows = "6", + placeholder = placeholder, + resize = resize + ) - } else if (type == "numeric") { + } else if (type == "numeric") { - output <- shiny::numericInput( - inputId = id, - label = label, - value = NULL - ) + output <- shiny::numericInput( + inputId = id, + label = label, + value = NULL + ) - } else if (type == "slider") { - - output <- shinyWidgets::sliderTextInput( - inputId = id, - label = label, - choices = option, - selected = selected, - force_edges = force_edges, - grid = grid, - animate = FALSE, - hide_min_max = FALSE, - from_fixed = FALSE, - to_fixed = FALSE, - from_min = NULL, - from_max = NULL, - to_min = NULL, - to_max = NULL, - pre = NULL, - post = NULL, - dragRange = TRUE - ) + } else if (type == "slider") { + + output <- shinyWidgets::sliderTextInput( + inputId = id, + label = label, + choices = option, + selected = selected, + force_edges = force_edges, + grid = grid, + animate = FALSE, + hide_min_max = FALSE, + from_fixed = FALSE, + to_fixed = FALSE, + from_min = NULL, + from_max = NULL, + to_min = NULL, + to_max = NULL, + pre = NULL, + post = NULL, + dragRange = TRUE + ) - } else if (type == "date") { - - output <- shiny::dateInput( - inputId = id, - label = label, - value = NULL, - min = NULL, - max = NULL, - format = "mm/dd/yyyy", - startview = "month", - weekstart = 0, - language = language, - autoclose = TRUE, - datesdisabled = NULL, - daysofweekdisabled = NULL - ) + } else if (type == "date") { + + output <- shiny::dateInput( + inputId = id, + label = label, + value = NULL, + min = NULL, + max = NULL, + format = "mm/dd/yyyy", + startview = "month", + weekstart = 0, + language = language, + autoclose = TRUE, + datesdisabled = NULL, + daysofweekdisabled = NULL + ) - output <- date_interaction(output, id) - - } else if (type == "daterange") { - - output <- shiny::dateRangeInput( - inputId = id, - label = label, - start = NULL, - end = NULL, - min = NULL, - max = NULL, - format = "mm/dd/yyyy", - startview = "month", - weekstart = 0, - language = language, - separator = "-", - autoclose = TRUE - ) + output <- date_interaction(output, id) + + } else if (type == "daterange") { + + output <- shiny::dateRangeInput( + inputId = id, + label = label, + start = NULL, + end = NULL, + min = NULL, + max = NULL, + format = "mm/dd/yyyy", + startview = "month", + weekstart = 0, + language = language, + separator = "-", + autoclose = TRUE + ) - output <- date_interaction(output, id) + output <- date_interaction(output, id) - } else if (type == "matrix") { - header <- shiny::tags$tr( - shiny::tags$th(""), - lapply(names(option), function(opt) shiny::tags$th(opt)) - ) - rows <- lapply(row, function(q_id) { - full_id <- paste(id, q_id, sep = "_") - shiny::tags$tr( - shiny::tags$td(names(row)[row == q_id]), - shiny::tags$td( - colspan = length(option), - sd_question( - type = "mc", - id = full_id, - label = NULL, - option = option, - direction = "horizontal" - ) + } else if (type == "matrix") { + header <- shiny::tags$tr( + shiny::tags$th(""), + lapply(names(option), function(opt) shiny::tags$th(opt)) + ) + rows <- lapply(row, function(q_id) { + full_id <- paste(id, q_id, sep = "_") + shiny::tags$tr( + shiny::tags$td(names(row)[row == q_id]), + shiny::tags$td( + colspan = length(option), + sd_question( + type = "mc", + id = full_id, + label = NULL, + option = option, + direction = "horizontal" ) ) - }) - - output <- shiny::div( - class = "matrix-question-container", - shiny::tags$label(class = "control-label", label), - shiny::tags$table( - class = "matrix-question", - header, - shiny::tags$tbody(rows) - ) ) - } - - # Create wrapper div - output_div <- make_question_container(id, output, width) + }) + + output <- shiny::div( + class = "matrix-question-container", + shiny::tags$label(class = "control-label", label), + shiny::tags$table( + class = "matrix-question", + header, + shiny::tags$tbody(rows) + ) + ) + } - if (!is.null(shiny::getDefaultReactiveDomain())) { - # In a reactive context, directly add to output with renderUI - shiny::isolate({ - output_div <- shiny::tags$div(output) - output <- shiny::getDefaultReactiveDomain()$output - output[[id]] <- shiny::renderUI({ output_div }) - }) - } else { - # If not in a reactive context, just return the element - return(output_div) - } + # Create wrapper div + output_div <- make_question_container(id, output, width) + + if (!is.null(shiny::getDefaultReactiveDomain())) { + # In a reactive context, directly add to output with renderUI + shiny::isolate({ + output_div <- shiny::tags$div(output) + output <- shiny::getDefaultReactiveDomain()$output + output[[id]] <- shiny::renderUI({ output_div }) + }) + } else { + # If not in a reactive context, just return the element + return(output_div) + } } date_interaction <- function(output, id) { - js_code <- sprintf( - "setTimeout(function() { + js_code <- sprintf( + "setTimeout(function() { $('#%s').on('change', function() { Shiny.setInputValue('%s_interacted', true, {priority: 'event'}); }); }, 1000);", # 1000 ms delay - id, id - ) - shiny::tagAppendChild(output, shiny::tags$script(htmltools::HTML(js_code))) + id, id + ) + shiny::tagAppendChild(output, shiny::tags$script(htmltools::HTML(js_code))) } make_question_container <- function(id, object, width) { - # Check if question if answered - js_interaction <- sprintf( - "Shiny.setInputValue('%s_interacted', true, {priority: 'event'});", - id - ) - return(shiny::tags$div( - id = paste0("container-", id), - `data-question-id` = id, - class = "question-container", - style = sprintf("width: %s;", width), - oninput = js_interaction, - object, - shiny::tags$span(class = "hidden-asterisk", "*") - )) + # Check if question if answered + js_interaction <- sprintf( + "Shiny.setInputValue('%s_interacted', true, {priority: 'event'});", + id + ) + return(shiny::tags$div( + id = paste0("container-", id), + `data-question-id` = id, + class = "question-container", + style = sprintf("width: %s;", width), + oninput = js_interaction, + object, + shiny::tags$span(class = "hidden-asterisk", "*") + )) } #' Create a 'Next' Button for Page Navigation @@ -528,33 +506,33 @@ make_question_container <- function(id, object, width) { #' #' @export sd_next <- function(next_page = NULL, label = NULL) { - # Get translations - translations <- get_translations()$translations + # Get translations + translations <- get_translations()$translations - # If no label provided, use default - if (is.null(label)) { - label <- translations[['next']] - } + # If no label provided, use default + if (is.null(label)) { + label <- translations[['next']] + } - button_id <- "page_id_next" # Placeholder ID - shiny::tagList( - shiny::div( - `data-next-page` = if (!is.null(next_page)) next_page else "", - style = "margin-top: 0.5rem; margin-bottom: 0.5rem;", - shiny::actionButton( - inputId = button_id, - label = label, - class = "sd-enter-button", - style = "display: block; margin: auto;", - onclick = "Shiny.setInputValue('next_page', this.parentElement.getAttribute('data-next-page'));" - ) - ) + button_id <- "page_id_next" # Placeholder ID + shiny::tagList( + shiny::div( + `data-next-page` = if (!is.null(next_page)) next_page else "", + style = "margin-top: 0.5rem; margin-bottom: 0.5rem;", + shiny::actionButton( + inputId = button_id, + label = label, + class = "sd-enter-button", + style = "display: block; margin: auto;", + onclick = "Shiny.setInputValue('next_page', this.parentElement.getAttribute('data-next-page'));" + ) ) + ) } # Generate Next Button ID make_next_button_id <- function(page_id) { - return(paste0(page_id, "_next")) + return(paste0(page_id, "_next")) } #' Create a 'Close' Button to Exit the Survey @@ -619,7 +597,7 @@ sd_close <- function(label = NULL) { # If no label provided, use default if (is.null(label)) { - label <- translations[['exit']] + label <- translations[['exit']] } button_id <- "close-survey-button" @@ -724,113 +702,113 @@ sd_redirect <- function( delay = NULL, newtab = FALSE ) { - # Get translations - translations <- get_translations()$translations + # Get translations + translations <- get_translations()$translations - # If no label provided, use default - if (is.null(label)) { - label <- translations[['click']] - } + # If no label provided, use default + if (is.null(label)) { + label <- translations[['click']] + } - if (!is.null(shiny::getDefaultReactiveDomain())) { - # In a reactive context, directly add to output with renderUI - shiny::isolate({ - output <- shiny::getDefaultReactiveDomain()$output - output[[id]] <- shiny::renderUI({ - create_redirect_element(id, url, button, label, delay, newtab) - }) - }) - } else { - # If not in a reactive context, just return the element - return(create_redirect_element(id, url, button, label, delay, newtab)) - } + if (!is.null(shiny::getDefaultReactiveDomain())) { + # In a reactive context, directly add to output with renderUI + shiny::isolate({ + output <- shiny::getDefaultReactiveDomain()$output + output[[id]] <- shiny::renderUI({ + create_redirect_element(id, url, button, label, delay, newtab) + }) + }) + } else { + # If not in a reactive context, just return the element + return(create_redirect_element(id, url, button, label, delay, newtab)) + } } # Function to create the redirect element create_redirect_element <- function(id, url, button, label, delay, newtab = FALSE) { - # Validate URL - if (!grepl("^https?://", url)) { - url <- paste0("https://", url) - } + # Validate URL + if (!grepl("^https?://", url)) { + url <- paste0("https://", url) + } - # Create JavaScript for redirection - redirect_js <- if (newtab) { - paste0("window.open('", url, "', '_blank');") - } else { - paste0("window.location.href = '", url, "';") - } + # Create JavaScript for redirection + redirect_js <- if (newtab) { + paste0("window.open('", url, "', '_blank');") + } else { + paste0("window.location.href = '", url, "';") + } - # Create button or text element - if (button) { - element <- shiny::actionButton( - inputId = id, - label = label, - onclick = redirect_js - ) - } else { - element <- shiny::span(label) - } + # Create button or text element + if (button) { + element <- shiny::actionButton( + inputId = id, + label = label, + onclick = redirect_js + ) + } else { + element <- shiny::span(label) + } - # Get translations - translations <- get_translations()$translations - text_redirect <- translations[["redirect"]] - text_seconds <- translations[["seconds"]] - text_newtab <- translations[["new_tab"]] - text_error <- translations[["redirect_error"]] - - # Add automatic redirection if delay is specified - if (!is.null(delay) && is.numeric(delay) && delay > 0) { - countdown_id <- paste0("countdown_", id) - element <- shiny::tagList( - shiny::div( - class = "sd-wrapper", - shiny::div( - id = id, - class = "sd-container", - element, - shiny::p( - style = "margin: 0.5rem 0 0 0;", - text_redirect, " ", - shiny::tags$strong(id = countdown_id, delay), - " ", text_seconds, ".", - if (newtab) { - glue::glue(" ({text_newtab})") - } else { - NULL - } - ) - ) - ), - shiny::tags$script(htmltools::HTML(sprintf( - "startCountdown(%d, function() { %s }, '%s', '%s');", - delay, - redirect_js, - countdown_id, - id - ))) - ) - } else if (!button) { - # If no delay and no button, inform the user that no action is possible - element <- shiny::div( - class = "sd-wrapper", - shiny::div( - class = "sd-container", - element, - shiny::p(style = "margin: 0.5rem 0 0 0;", text_error) - ) - ) - } else { - # If it's a button without delay, just wrap it in the styled container - element <- shiny::div( - class = "sd-wrapper", - shiny::div( - class = "sd-container", - element - ) + # Get translations + translations <- get_translations()$translations + text_redirect <- translations[["redirect"]] + text_seconds <- translations[["seconds"]] + text_newtab <- translations[["new_tab"]] + text_error <- translations[["redirect_error"]] + + # Add automatic redirection if delay is specified + if (!is.null(delay) && is.numeric(delay) && delay > 0) { + countdown_id <- paste0("countdown_", id) + element <- shiny::tagList( + shiny::div( + class = "sd-wrapper", + shiny::div( + id = id, + class = "sd-container", + element, + shiny::p( + style = "margin: 0.5rem 0 0 0;", + text_redirect, " ", + shiny::tags$strong(id = countdown_id, delay), + " ", text_seconds, ".", + if (newtab) { + glue::glue(" ({text_newtab})") + } else { + NULL + } + ) ) - } + ), + shiny::tags$script(htmltools::HTML(sprintf( + "startCountdown(%d, function() { %s }, '%s', '%s');", + delay, + redirect_js, + countdown_id, + id + ))) + ) + } else if (!button) { + # If no delay and no button, inform the user that no action is possible + element <- shiny::div( + class = "sd-wrapper", + shiny::div( + class = "sd-container", + element, + shiny::p(style = "margin: 0.5rem 0 0 0;", text_error) + ) + ) + } else { + # If it's a button without delay, just wrap it in the styled container + element <- shiny::div( + class = "sd-wrapper", + shiny::div( + class = "sd-container", + element + ) + ) + } - return(element) + return(element) } #' Get URL Parameters in a 'shiny' Application @@ -893,28 +871,28 @@ create_redirect_element <- function(id, url, button, label, delay, newtab = FALS #' #' @export sd_get_url_pars <- function(...) { - shiny::reactive({ - session <- shiny::getDefaultReactiveDomain() + shiny::reactive({ + session <- shiny::getDefaultReactiveDomain() - if (is.null(session)) { - stop("sd_get_url_pars() must be called from within a Shiny reactive context") - } + if (is.null(session)) { + stop("sd_get_url_pars() must be called from within a Shiny reactive context") + } - full_url <- session$clientData$url_search - parsed_query <- shiny::parseQueryString(full_url) + full_url <- session$clientData$url_search + parsed_query <- shiny::parseQueryString(full_url) - requested_params <- list(...) + requested_params <- list(...) - if (length(requested_params) == 0) { - return(parsed_query) - } + if (length(requested_params) == 0) { + return(parsed_query) + } - requested_params <- unlist(requested_params) - filtered_query <- parsed_query[requested_params] - filtered_query[!sapply(filtered_query, is.null)] - })() - # Extra parentheses is added so that the reactive expression is evaluated - # when the function is called + requested_params <- unlist(requested_params) + filtered_query <- parsed_query[requested_params] + filtered_query[!sapply(filtered_query, is.null)] + })() + # Extra parentheses is added so that the reactive expression is evaluated + # when the function is called } #' Create a placeholder for a reactive survey question @@ -1012,38 +990,38 @@ sd_output <- function( wrapper = NULL, ... ) { - if (is.null(type)) { - # If only id is provided, behave like shiny::uiOutput - return(shiny::uiOutput(id, inline = inline, ...)) - } - - if (type == "question") { - return(make_question_container(id, shiny::uiOutput(id), width)) - } + if (is.null(type)) { + # If only id is provided, behave like shiny::uiOutput + return(shiny::uiOutput(id, inline = inline, ...)) + } - if (type %in% c("value", "label_option", "label_question")) { - type_id <- paste0(id, "_", type) + if (type == "question") { + return(make_question_container(id, shiny::uiOutput(id), width)) + } - if (!display %in% c("text", "verbatim", "ui")) { - stop("Invalid display type. Choose 'text', 'verbatim', or 'ui'.") - } + if (type %in% c("value", "label_option", "label_question")) { + type_id <- paste0(id, "_", type) - output <- switch(display, - "text" = shiny::textOutput(type_id, inline = inline), - "verbatim" = shiny::verbatimTextOutput(type_id, inline = inline), - "ui" = shiny::uiOutput(type_id, inline = inline), - # Default to textOutput if display is not specified - shiny::textOutput(type_id, inline = inline) - ) + if (!display %in% c("text", "verbatim", "ui")) { + stop("Invalid display type. Choose 'text', 'verbatim', or 'ui'.") + } - if (!is.null(wrapper)) { - output <- wrapper(output, ...) - } + output <- switch(display, + "text" = shiny::textOutput(type_id, inline = inline), + "verbatim" = shiny::verbatimTextOutput(type_id, inline = inline), + "ui" = shiny::uiOutput(type_id, inline = inline), + # Default to textOutput if display is not specified + shiny::textOutput(type_id, inline = inline) + ) - return(output) + if (!is.null(wrapper)) { + output <- wrapper(output, ...) } - stop("Invalid type. Choose 'question' or 'value'.") + return(output) + } + + stop("Invalid type. Choose 'question' or 'value'.") } #' Generate a Random Completion Code @@ -1066,16 +1044,16 @@ sd_output <- function( #' #' @export sd_completion_code <- function(digits = 6) { - if (!is.numeric(digits) || digits < 1 || digits != round(digits)) { - stop("'digits' must be a positive integer") - } + if (!is.numeric(digits) || digits < 1 || digits != round(digits)) { + stop("'digits' must be a positive integer") + } - # Generate random digits - digits_vector <- sample(0:9, digits, replace = TRUE) + # Generate random digits + digits_vector <- sample(0:9, digits, replace = TRUE) - # Ensure the first digit is not 0 - digits_vector[1] <- sample(1:9, 1) + # Ensure the first digit is not 0 + digits_vector[1] <- sample(1:9, 1) - # Combine into a single string - paste(digits_vector, collapse = "") + # Combine into a single string + paste(digits_vector, collapse = "") } diff --git a/R/util.R b/R/util.R index b95a6387..66c5e467 100644 --- a/R/util.R +++ b/R/util.R @@ -1,19 +1,19 @@ # Convert Markdown to HTML markdown_to_html <- function(text) { - if (is.null(text)) { return(text) } - return(shiny::HTML(markdown::renderMarkdown(text = text))) + if (is.null(text)) { return(text) } + return(shiny::HTML(markdown::renderMarkdown(text = text))) } # Convert List Names from Markdown to HTML list_name_md_to_html <- function(list) { - list_names_md <- names(list) - list_names_html <- lapply(list_names_md, function(name) { - html_name <- markdown_to_html(name) - plain_name <- gsub("<[/]?p>|\\n", "", html_name) - return(plain_name) - }) - names(list) <- unlist(list_names_html) - return(list) + list_names_md <- names(list) + list_names_html <- lapply(list_names_md, function(name) { + html_name <- markdown_to_html(name) + plain_name <- gsub("<[/]?p>|\\n", "", html_name) + return(plain_name) + }) + names(list) <- unlist(list_names_html) + return(list) } #' Display Package Information on Attach @@ -29,52 +29,52 @@ list_name_md_to_html <- function(list) { #' @noRd .onAttach <- function(libname, pkgname) { - # Add special folders to resource path - folders <- c('_survey', 'images', 'css', 'js', 'www') - for (folder in folders) { include_folder(folder) } - - # Print package data - desc <- utils::packageDescription(pkgname, libname) - packageStartupMessage( - "Version: ", desc$Version, "\n", - "Author: ", "John Paul Helveston, Pingfan Hu, Bogdan Bunea (George Washington University)", "\n\n", - "Consider submitting praise at\n", - "https://github.com/jhelvy/surveydown/issues/41.\n\n", - "Please cite our package in your publications, see:\ncitation(\"surveydown\")" - ) + # Add special folders to resource path + folders <- c('_survey', 'images', 'css', 'js', 'www') + for (folder in folders) { include_folder(folder) } + + # Print package data + desc <- utils::packageDescription(pkgname, libname) + packageStartupMessage( + "Version: ", desc$Version, "\n", + "Author: ", "John Paul Helveston, Pingfan Hu, Bogdan Bunea (George Washington University)", "\n\n", + "Consider submitting praise at\n", + "https://github.com/jhelvy/surveydown/issues/41.\n\n", + "Please cite our package in your publications, see:\ncitation(\"surveydown\")" + ) } survey_file_exists <- function() { - files <- basename(list.files(full.names = TRUE)) - if ("survey.qmd" %in% files) { return(TRUE) } - return(FALSE) + files <- basename(list.files(full.names = TRUE)) + if ("survey.qmd" %in% files) { return(TRUE) } + return(FALSE) } is_self_contained <- function() { - metadata <- quarto::quarto_inspect("survey.qmd") - embedded <- metadata$formats$html$pandoc$`embed-resources` - if (!is.null(embedded)) { - if (embedded) { - return(TRUE) - } + metadata <- quarto::quarto_inspect("survey.qmd") + embedded <- metadata$formats$html$pandoc$`embed-resources` + if (!is.null(embedded)) { + if (embedded) { + return(TRUE) } - self <- metadata$formats$html$pandoc$`self-contained` - if (!is.null(self)) { - if (self) { - return(TRUE) - } + } + self <- metadata$formats$html$pandoc$`self-contained` + if (!is.null(self)) { + if (self) { + return(TRUE) } - return(FALSE) + } + return(FALSE) } include_folder <- function(folder, create = FALSE) { - folder_exists <- dir.exists(folder) - if (folder_exists) { - shiny::addResourcePath(folder, folder) - } else if (create) { - dir.create(folder) - shiny::addResourcePath(folder, folder) - } + folder_exists <- dir.exists(folder) + if (folder_exists) { + shiny::addResourcePath(folder, folder) + } else if (create) { + dir.create(folder) + shiny::addResourcePath(folder, folder) + } } #' Include a folder to the 'shiny' resource path @@ -104,46 +104,68 @@ include_folder <- function(folder, create = FALSE) { #' #' @export sd_include_folder <- function(folder) { - # List of folders pre-included by the package - pre_included_folders <- names(shiny::resourcePaths()) + # List of folders pre-included by the package + pre_included_folders <- names(shiny::resourcePaths()) - if (folder %in% pre_included_folders) { - message(paste("The folder", folder, "is already included by the package. No action needed.")) - return(invisible(NULL)) - } + if (folder %in% pre_included_folders) { + message(paste("The folder", folder, "is already included by the package. No action needed.")) + return(invisible(NULL)) + } - if (!dir.exists(folder)) { - stop(paste("The folder", folder, "does not exist in the current directory.")) - } + if (!dir.exists(folder)) { + stop(paste("The folder", folder, "does not exist in the current directory.")) + } - shiny::addResourcePath(folder, folder) - message(paste("Successfully added", folder, "to Shiny's resource path.")) + shiny::addResourcePath(folder, folder) + message(paste("Successfully added", folder, "to Shiny's resource path.")) - invisible(NULL) + invisible(NULL) } # Convert Vector to JSON Array vector_to_json_array <- function(vec) { - if (length(vec) == 0) return("[]") - - # Ensure all elements are properly quoted - quoted_elements <- sapply(vec, function(x) { - if (is.character(x)) { - sprintf('"%s"', gsub('"', '\\"', x)) # Escape any quotes within strings - } else { - as.character(x) - } - }) - - # Join elements and wrap in brackets - sprintf("[%s]", paste(quoted_elements, collapse = ",")) + if (length(vec) == 0) return("[]") + + # Ensure all elements are properly quoted + quoted_elements <- sapply(vec, function(x) { + if (is.character(x)) { + sprintf('"%s"', gsub('"', '\\"', x)) # Escape any quotes within strings + } else { + as.character(x) + } + }) + + # Join elements and wrap in brackets + sprintf("[%s]", paste(quoted_elements, collapse = ",")) } -# Load and Run JavaScript File +# Dynamically load JS files load_js_file <- function(name) { - js_file_path <- system.file("js", name, package = "surveydown") - js_code <- paste(readLines(js_file_path), collapse = "\n") - shinyjs::runjs(js_code) + js_file_path <- system.file("js", name, package = "surveydown") + js_code <- paste(readLines(js_file_path), collapse = "\n") + shinyjs::runjs(js_code) +} + +# Load CSS and JS files +load_resource <- function(..., package = "surveydown") { + files <- c(...) + lapply(files, function(file) { + file_type <- tolower(tools::file_ext(file)) + if (!(file_type %in% c("css", "js"))) { + stop(paste("Unsupported file type:", file_type, "for file:", file)) + } + path <- system.file(paste0(file_type, "/", file), package = package) + if (file.exists(path)) { + if (file_type == "css") { + shiny::includeCSS(path) + } else { + shiny::includeScript(path) + } + } else { + warning(paste("File not found:", file, "in package:", package)) + NULL + } + }) } tibble_to_list_of_lists <- function(tbl) { @@ -201,53 +223,53 @@ tibble_to_list_of_lists <- function(tbl) { #' sd_create_survey(structure = "multi") #' } sd_create_survey <- function(path = getwd(), structure = "single") { - # Check if using current directory and confirm with user - if (path == getwd() && !usethis::ui_yeah(paste("Use the current directory (", path, ") as the path?"))) { - stop("Operation aborted by the user.") - } + # Check if using current directory and confirm with user + if (path == getwd() && !usethis::ui_yeah(paste("Use the current directory (", path, ") as the path?"))) { + stop("Operation aborted by the user.") + } - # Validate the structure parameter - if (!structure %in% c("single", "multi")) { - stop("Invalid structure. Choose either 'single' or 'multi'.") - } + # Validate the structure parameter + if (!structure %in% c("single", "multi")) { + stop("Invalid structure. Choose either 'single' or 'multi'.") + } - # Create the directory if it doesn't exist - dir.create(path, recursive = TRUE, showWarnings = FALSE) + # Create the directory if it doesn't exist + dir.create(path, recursive = TRUE, showWarnings = FALSE) - # Get the path to the template folder and list files - template_path <- system.file(file.path("templates", structure), package = "surveydown") - if (!dir.exists(template_path)) { - stop(paste("Template directory for", structure, "structure does not exist.")) - } - template_files <- list.files(template_path, full.names = TRUE, recursive = TRUE) - - # Copy files, checking for conflicts - files_copied <- sapply(template_files, function(file) { - relative_path <- sub(template_path, "", file) - target_file <- file.path(path, relative_path) - - # Ensure target directory exists - dir.create(dirname(target_file), recursive = TRUE, showWarnings = FALSE) - - file_name <- basename(file) - if (grepl("\\.Rproj$", file_name) && length(list.files(path, pattern = "\\.Rproj$"))) { - warning("Skipping the .Rproj file since one already exists.", call. = FALSE, immediate. = TRUE) - return(FALSE) - } else if (file.exists(target_file)) { - warning(paste("Skipping", file_name, "since it already exists."), call. = FALSE, immediate. = TRUE) - return(FALSE) - } else { - file.copy(from = file, to = target_file, overwrite = FALSE) - return(TRUE) - } - }) - - # Provide feedback to the user - if (any(files_copied)) { - usethis::ui_done(paste(structure, "version of template created at", path)) + # Get the path to the template folder and list files + template_path <- system.file(file.path("templates", structure), package = "surveydown") + if (!dir.exists(template_path)) { + stop(paste("Template directory for", structure, "structure does not exist.")) + } + template_files <- list.files(template_path, full.names = TRUE, recursive = TRUE) + + # Copy files, checking for conflicts + files_copied <- sapply(template_files, function(file) { + relative_path <- sub(template_path, "", file) + target_file <- file.path(path, relative_path) + + # Ensure target directory exists + dir.create(dirname(target_file), recursive = TRUE, showWarnings = FALSE) + + file_name <- basename(file) + if (grepl("\\.Rproj$", file_name) && length(list.files(path, pattern = "\\.Rproj$"))) { + warning("Skipping the .Rproj file since one already exists.", call. = FALSE, immediate. = TRUE) + return(FALSE) + } else if (file.exists(target_file)) { + warning(paste("Skipping", file_name, "since it already exists."), call. = FALSE, immediate. = TRUE) + return(FALSE) } else { - usethis::ui_done("Since all files exist, no file was added.") + file.copy(from = file, to = target_file, overwrite = FALSE) + return(TRUE) } + }) + + # Provide feedback to the user + if (any(files_copied)) { + usethis::ui_done(paste(structure, "version of template created at", path)) + } else { + usethis::ui_done("Since all files exist, no file was added.") + } } #' Required Set Up Function @@ -263,8 +285,8 @@ sd_create_survey <- function(path = getwd(), structure = "single") { #' #' @export sd_setup <- function() { - # v0.3.0 - .Deprecated("") + # v0.3.0 + .Deprecated("") } question_templates <- function(type = "mc") { @@ -280,28 +302,28 @@ question_templates <- function(type = "mc") { ) ', - text = 'sd_question( + text = 'sd_question( type = "text", id = "apple_text", label = "Write a type of apple:" ) ', - textarea = 'sd_question( +textarea = 'sd_question( type = "textarea", id = "apple_textarea", label = "What do you like about apple?" ) ', - numeric = 'sd_question( +numeric = 'sd_question( type = "numeric", id = "apple_numeric", label = "How many apple(s) do you eat per day?" ) ', - mc_buttons = 'sd_question( +mc_buttons = 'sd_question( type = "mc_buttons", id = "apple_mc_buttons", label = "Which apple do you prefer most?", @@ -313,7 +335,7 @@ question_templates <- function(type = "mc") { ) ', - mc_multiple = 'sd_question( +mc_multiple = 'sd_question( type = "mc_multiple", id = "apple_mc_multiple", label = "What are your favorite apple types (select all that apply)?", @@ -325,7 +347,7 @@ question_templates <- function(type = "mc") { ) ', - mc_multiple_buttons = 'sd_question( +mc_multiple_buttons = 'sd_question( type = "mc_multiple_buttons", id = "apple_mc_multiple_buttons", label = "What are your favorite apple types (select all that apply)?", @@ -337,7 +359,7 @@ question_templates <- function(type = "mc") { ) ', - select = 'sd_question( +select = 'sd_question( type = "select", id = "apple_select", label = "Which apple do you prefer most?", @@ -349,7 +371,7 @@ question_templates <- function(type = "mc") { ) ', - slider = 'sd_question( +slider = 'sd_question( type = "slider", id = "apple_slider", label = "To what extent do you like apple?", @@ -363,14 +385,14 @@ question_templates <- function(type = "mc") { ) ', - date = 'sd_question( +date = 'sd_question( type = "date", id = "apple_date", label = "What is the last day you had apple?" ) ', - daterange = 'sd_question( +daterange = 'sd_question( type = "daterange", id = "vacation_daterange", label = "Please select the date range of your upcoming vacation." @@ -379,7 +401,7 @@ question_templates <- function(type = "mc") { ' ) - return(templates[[type]]) +return(templates[[type]]) } #' Add a Question Template to the Current Document @@ -434,7 +456,7 @@ question_templates <- function(type = "mc") { sd_add_question <- function(type = "mc", chunk = FALSE) { template <- question_templates(type) if (chunk) { - template <- paste0("```{r}\n", template, "```\n") + template <- paste0("```{r}\n", template, "```\n") } # Get the current document context @@ -553,47 +575,47 @@ sd_next() #' @examples #' surveydown::sd_version() sd_version <- function() { - # Get local version - local_surveydown_version <- utils::packageVersion("surveydown") + # Get local version + local_surveydown_version <- utils::packageVersion("surveydown") - # Get latest online version - latest_surveydown_version <- get_latest_version("https://raw.githubusercontent.com/surveydown-dev/surveydown/main/DESCRIPTION", "Version: ") + # Get latest online version + latest_surveydown_version <- get_latest_version("https://raw.githubusercontent.com/surveydown-dev/surveydown/main/DESCRIPTION", "Version: ") - # Display version information - message("surveydown (local): ", local_surveydown_version) - message("surveydown (latest): ", - if(is.null(latest_surveydown_version)) "Unable to fetch" else latest_surveydown_version) + # Display version information + message("surveydown (local): ", local_surveydown_version) + message("surveydown (latest): ", + if(is.null(latest_surveydown_version)) "Unable to fetch" else latest_surveydown_version) - # Check if update is needed - if (is.null(latest_surveydown_version)) { - message("\nUnable to determine if an update is available.") - message("Please ensure you have an active internet connection and try again later.") - } else { - pkg_needs_update <- local_surveydown_version < latest_surveydown_version + # Check if update is needed + if (is.null(latest_surveydown_version)) { + message("\nUnable to determine if an update is available.") + message("Please ensure you have an active internet connection and try again later.") + } else { + pkg_needs_update <- local_surveydown_version < latest_surveydown_version - if (pkg_needs_update) { - message("\nAn update is available. To update surveydown to the latest version, run: surveydown::sd_update()") - } else { - message("\nsurveydown is up to date.") - } + if (pkg_needs_update) { + message("\nAn update is available. To update surveydown to the latest version, run: surveydown::sd_update()") + } else { + message("\nsurveydown is up to date.") } + } } get_latest_version <- function(url, pattern) { - tryCatch({ - content <- readLines(url) - version_line <- grep(pattern, content, value = TRUE) - if (length(version_line) > 0) { - version <- sub(pattern, "", version_line[1]) - return(package_version(trimws(version))) - } else { - message("Version information not found in the file at ", url) - return(NULL) - } - }, error = function(e) { - message("Error occurred while fetching version from ", url, ": ", e$message) - return(NULL) - }) + tryCatch({ + content <- readLines(url) + version_line <- grep(pattern, content, value = TRUE) + if (length(version_line) > 0) { + version <- sub(pattern, "", version_line[1]) + return(package_version(trimws(version))) + } else { + message("Version information not found in the file at ", url) + return(NULL) + } + }, error = function(e) { + message("Error occurred while fetching version from ", url, ": ", e$message) + return(NULL) + }) } #' Create a translations template file