diff --git a/.Rbuildignore b/.Rbuildignore index aeebe33d..6259d1e6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -19,4 +19,8 @@ data-raw ^\.travis\.yml$ ^CRAN-RELEASE$ ^CRAN-SUBMISSION$ -^.vscode$ \ No newline at end of file +^.vscode$ +^app.R$ +^survey.qmd$ +^_extensions$ +^data.csv$ diff --git a/.gitignore b/.gitignore index 5f7f752a..9e8bf49d 100644 --- a/.gitignore +++ b/.gitignore @@ -10,17 +10,13 @@ notes Meta .idea data.csv -survey.qmd -survey.Rproj _extensions survey.html survey_files choice_questions.csv -images example.qmd .vdoc.r .Renviron example.html example_files example1.rmarkdown - diff --git a/DESCRIPTION b/DESCRIPTION index a7d38964..74aeb5b2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: surveydown Title: Markdown-Based Surveys Using Quarto Shiny Documents -Version: 0.2.4 +Version: 0.3.0 Authors@R: c( person(given = "John Paul", family = "Helveston", @@ -30,21 +30,22 @@ Suggests: knitr, testthat Imports: - bslib, DBI, digest, DT, htmltools, markdown, pool, + quarto, remotes, RPostgres, + rsconnect, rvest, shiny, shinyjs, shinyWidgets, usethis, utils, - yaml -url: https://pkg.surveydown.org/ + xml2 +URL: https://pkg.surveydown.org BugReports: https://github.com/surveydown-dev/surveydown/issues diff --git a/NAMESPACE b/NAMESPACE index 182c5a8f..acb5866d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,14 +1,15 @@ # Generated by roxygen2: do not edit by hand -export(sd_check_versions) -export(sd_config) +export(sd_close) export(sd_copy_value) export(sd_create_survey) export(sd_database) +export(sd_deploy) export(sd_display_question) export(sd_display_value) export(sd_get_data) export(sd_get_url_pars) +export(sd_include_folder) export(sd_next) export(sd_output) export(sd_question) @@ -16,11 +17,15 @@ export(sd_redirect) export(sd_server) export(sd_set_password) export(sd_setup) +export(sd_show_if) +export(sd_skip_if) export(sd_store_value) -export(sd_update_extension) -export(sd_update_surveydown) +export(sd_ui) +export(sd_update) +export(sd_version) import(shiny) importFrom(digest,digest) +importFrom(rsconnect,deployApp) importFrom(shiny,HTML) importFrom(shiny,actionButton) importFrom(shiny,getDefaultReactiveDomain) diff --git a/NEWS.md b/NEWS.md index c9662543..5bba8b9d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,19 @@ # surveydown (development version) -- Modified `sd_get_url_pars()` to include `reactive()` with the `()` at the end, so now the function returns an evaluated reactive expression. +# surveydown 0.3.0 + +- Introduced `sd_ui()` function to set placeholders for the shiny app ui. +- Heavily revised how `skip_if` and `show_if` works, removing `skip_if_custom` and `show_if_custom`. Now they work similar to the `case_when()` function, where you provide the formula `condition ~ target` for each condition in either function. These are also provided globally inside the `server()` function using `sd_skip_if()` and `sd_show_if()`. +- Require that the survey file be named `"survey.qmd"`. +- Added `sd_include_folder()` function so users can add a folder to the shiny resource path. +- Automatically include the `images`, `js`, `css`, and `www` folders as well as folders to quarto files to the shiny resource path when the package loads. +- Heavily modified how `sd_next()` works to improve page navigation and ensure that each `sd_next()` button has a unique id based on the current page. +- Removed the quarto extension. +- `sd_create_survey()` changed to sourcing template directly from the package. Two parameters are provided. The first parameter is `path`, which defines the relative path of the target. If left blank, the path will be the current working directory. The second parameter is `structure`, which defines which structure of the template the user wants to choose, default as `"single"` and can be changed to `"multi"`. +- `sd_deploy()` as a wrapper function of `rsconnect::deployApp()` to deploy the survey. +- `sd_update()` as a replacement of `sd_update_surveydown()` to update the package. +- `sd_version()` as a replacement of `sd_check_versions()` to check for the current version and the latest version. +- `sd_close()` function to create a close button for the survey. # surveydown 0.2.4 diff --git a/R/config.R b/R/config.R index c4e2ad2c..4e9eb4c0 100644 --- a/R/config.R +++ b/R/config.R @@ -1,179 +1,153 @@ -#' Configuration Function for surveydown Surveys -#' -#' This function sets up the configuration for a surveydown survey, including -#' page and question structures, conditional display settings, and navigation options. -#' -#' @param skip_if A list of conditions under which certain pages should be skipped. Defaults to NULL. -#' @param skip_if_custom A custom function to handle conditions under which certain pages should be skipped. Defaults to NULL. -#' @param show_if A list of conditions under which certain pages should be shown. Defaults to NULL. -#' @param show_if_custom A custom function to handle conditions under which certain pages should be shown. Defaults to NULL. -#' @param required_questions Vector of character strings. The IDs of questions that must -#' be answered before the respondent can continue in the survey or survey can be -#' submitted. Defaults to NULL. -#' @param all_questions_required Logical. If TRUE, all questions in the survey will be required. -#' This overrides the `required_questions` parameter. Defaults to FALSE. -#' @param start_page Character string. The ID of the page to start on. Defaults to NULL. -#' @param show_all_pages Logical. Whether to show all pages initially. Defaults to FALSE. -#' @param admin_page Logical. Whether to include an admin page for viewing and downloading survey data. Defaults to FALSE. -#' -#' @details The function retrieves the survey metadata, checks for duplicate page and question IDs, -#' validates the conditional display settings, and ensures that the specified start page (if any) exists. -#' It then stores these settings in a configuration list. If `admin_page` is set to TRUE, an admin page -#' will be included in the survey. This page allows viewing and downloading of survey data upon entering -#' the correct survey password (set using `sd_set_password()`). -#' -#' If `all_questions_required` is set to TRUE, it will override the `required_questions` parameter -#' and set all questions in the survey as required. -#' -#' @return A list containing the configuration settings for the survey, including: -#' \item{page_structure}{A list containing the structure of survey pages} -#' \item{question_structure}{A list containing the structure of survey questions} -#' \item{page_ids}{A vector of all page IDs} -#' \item{question_ids}{A vector of all question IDs} -#' \item{question_values}{A vector of all possible question values} -#' \item{question_required}{A vector of IDs for required questions} -#' \item{skip_if_custom}{Custom skip conditions} -#' \item{skip_if}{Standard skip conditions} -#' \item{show_if_custom}{Custom show conditions} -#' \item{show_if}{Standard show conditions} -#' \item{start_page}{The ID of the starting page} -#' \item{show_all_pages}{Whether to show all pages initially} -#' \item{admin_page}{Whether to include an admin page} -#' -#' @examples -#' \dontrun{ -#' # These examples assume you have set up a survey with appropriate .qmd files -#' -#' # Basic configuration -#' config <- sd_config() -#' -#' # Configuration with custom settings -#' config <- sd_config( -#' start_page = "intro", -#' all_questions_required = TRUE, -#' show_all_pages = FALSE, -#' admin_page = TRUE -#' ) -#' } -#' @export -sd_config <- function( - skip_if = NULL, - skip_if_custom = NULL, - show_if = NULL, - show_if_custom = NULL, +run_config <- function( + use_html = FALSE, required_questions = NULL, all_questions_required = FALSE, - start_page = NULL, - show_all_pages = FALSE, - admin_page = FALSE + start_page = NULL, + admin_page = FALSE, + skip_if = NULL, + show_if = NULL ) { + # Throw error if "survey.qmd" file missing + check_survey_file_exists() - # Get survey metadata - page_structure <- get_page_structure() - question_structure <- get_question_structure() - page_ids <- attr(page_structure, "all_ids") - question_ids <- attr(question_structure, "all_ids") + survey_file <- "survey.qmd" + if (use_html) { survey_file <- "survey.html" } + + # Get the html content from the qmd file (or html if pre-rendered) + html_content <- get_html_content(survey_file) + + # Extract all divs with class "sd-page" + pages <- extract_html_pages( + html_content, required_questions, all_questions_required, show_if + ) + + # Extract head content (for CSS and JS) + head_content <- html_content |> + rvest::html_element("head") |> + rvest::html_children() |> + sapply(as.character) |> + paste(collapse = "\n") + + # Extract page and question structures + question_structure <- get_question_structure(html_content) + + page_ids <- sapply(pages, function(p) p$id) + question_ids <- names(question_structure) # Check for duplicate or overlapping IDs check_ids(page_ids, question_ids) - question_values <- unname(unlist(lapply(question_structure, `[[`, "options"))) - question_required <- question_ids - if (! all_questions_required) { - question_required <- required_questions - } - - # Check skip_if and show_if inputs - check_skip_show(question_ids, question_values, page_ids, skip_if, show_if) + question_values <- unname(unlist(lapply(question_structure, `[[`, "options"))) + question_required <- if (all_questions_required) question_ids else required_questions # Check that start_page (if used) points to an actual page - if (!is.null(start_page)) { - if (! start_page %in% page_ids) { - stop( - "The specified start_page does not exist - check that you have ", - "not mis-spelled the id" - ) - } + 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") } - # Convert show_if_custom and skip_if_custom to list of lists - show_if_custom <- convert_to_list_of_lists(show_if_custom) - skip_if_custom <- convert_to_list_of_lists(skip_if_custom) + # Check skip_if and show_if inputs + check_skip_show(question_ids, question_values, page_ids, skip_if, show_if) # Store all config settings config <- list( - page_structure = page_structure, - question_structure = question_structure, - page_ids = page_ids, - question_ids = question_ids, - question_values = question_values, - question_required = question_required, - skip_if_custom = skip_if_custom, - skip_if = skip_if, - show_if_custom = show_if_custom, - show_if = show_if, - start_page = start_page, - show_all_pages = show_all_pages, - admin_page = admin_page + pages = pages, + head_content = head_content, + page_ids = page_ids, + question_ids = question_ids, + question_values = question_values, + question_required = question_required, + start_page = start_page, + admin_page = admin_page ) return(config) } -# Get page structure from HTML -get_page_structure <- function() { - # Get all page nodes - page_nodes <- get_page_nodes() - all_page_ids <- page_nodes |> rvest::html_attr("id") - - # Initialize a named list to hold the results - page_structure <- list() - - # Iterate over each page node to get the question_ids - for (i in seq_along(page_nodes)) { - page_id <- all_page_ids[i] - page_node <- page_nodes[i] - - # Extract all question IDs within this page - question_ids <- page_node |> - rvest::html_nodes("[data-question-id]") |> - rvest::html_attr("data-question-id") - - # Store the question IDs for this page in a named list - page_structure[[page_id]] <- list( - id = page_id, - questions = question_ids - ) +get_html_content <- function(survey_file) { + # Check if the file exists + if (!file.exists(survey_file)) { + stop("The specified survey file does not exist.") } - attr(page_structure, "all_ids") <- all_page_ids - return(page_structure) -} - -# Get page nodes from HTML -get_page_nodes <- function() { - - # Get the list of .qmd files in the current working directory - qmd_files <- list.files(pattern = "\\.qmd$", full.names = TRUE) + # Get the file extension + file_ext <- tools::file_ext(survey_file) - # Check if there is exactly one .qmd file - if (length(qmd_files) == 1) { - qmd_file_name <- qmd_files[1] - html_file_name <- sub("\\.qmd$", ".html", qmd_file_name) - - # Use the derived HTML file name to read the document with rvest - pages <- rvest::read_html(html_file_name) |> - rvest::html_nodes(".sd-page") - return(pages) + # Process based on file type + if (file_ext == "qmd") { + temp_html <- quarto_render_temp(survey_file) + html_content <- rvest::read_html(temp_html) + unlink(temp_html) + } else if (file_ext == "html") { + html_content <- rvest::read_html(survey_file) + } else { + stop("Invalid file type. Please provide either a .qmd or .html file.") } + return(html_content) +} - stop("Error: {surveydown} requires that only one .qmd file in the directory.") - +extract_html_pages <- function( + 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) + is_required <- all_questions_required | (question_id %in% required_questions) + if (is_required) { + required_question_ids <- c(required_question_ids, question_id) + asterisk <- rvest::html_element(container, ".required-asterisk") + xml2::xml_attr(asterisk, "style") <- "display:inline; color: red; font-size: 1.5em; vertical-align: middle; position: relative; top: 0.1em;" + } + + if (!is.null(show_if)) { + if (question_id %in% show_if$targets) { + current_style <- xml2::xml_attr(container, "style") + current_style <- if (is.na(current_style)) "" else current_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) + ) + }) + return(pages) } # Get question structure from HTML -get_question_structure <- function() { - question_nodes <- get_question_nodes() +get_question_structure <- function(html_content) { + + question_nodes <- rvest::html_nodes(html_content, "[data-question-id]") # Initialize a named list to hold the results question_structure <- list() @@ -205,79 +179,32 @@ get_question_structure <- function() { return(question_structure) } -# Get question nodes from HTML -get_question_nodes <- function() { - - # Get the list of .qmd files in the current working directory - qmd_files <- list.files(pattern = "\\.qmd$", full.names = TRUE) - - # Check if there is exactly one .qmd file - if (length(qmd_files) == 1) { - qmd_file_name <- qmd_files[1] - html_file_name <- sub("\\.qmd$", ".html", qmd_file_name) - - # Use the derived HTML file name to read the document with rvest - questions <- rvest::read_html(html_file_name) |> - rvest::html_nodes("[data-question-id]") - - return(questions) - } - - stop("Error: {surveydown} requires that only one .qmd file in the directory.") -} - check_skip_show <- function( question_ids, question_values, page_ids, skip_if, show_if ) { - required_names <- c("question_id", "question_value", "target") - if (!is.null(skip_if)) { - if (!is.data.frame(skip_if)) { - stop("skip_if must be a data frame or tibble.") - } - if (!all(required_names %in% names(skip_if))) { - stop("skip_if must contain the columns: question_id, question_value, and target.") - } - if (!all(skip_if$question_id %in% question_ids)) { - stop("All question_id values in skip_if must be valid question IDs.") - } - if (!all(skip_if$target %in% page_ids)) { - stop("All target values in skip_if must be valid page IDs.") - } - if (!all(skip_if$question_value %in% question_values)) { - stop("All question_value values in skip_if must be valid question values.") + 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)) { - if (!is.data.frame(show_if)) { - stop("show_if must be a data frame or tibble.") - } - if (!all(required_names %in% names(show_if))) { - stop("show_if must contain the columns: question_id, question_value, and target.") - } - if (!all(show_if$question_id %in% question_ids)) { - stop("All question_id values in show_if must be valid question IDs.") - } - if (!all(show_if$target %in% question_ids)) { - stop("All target values in show_if must be valid question IDs.") - } - if (!all(show_if$question_value %in% question_values)) { - stop("All question_value values in show_if must be valid question values.") + invalid_show_targets <- setdiff(show_if$targets, question_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) } -convert_to_list_of_lists <- function(tbl) { - if (is.data.frame(tbl)) { - return(tibble_to_list_of_lists(tbl)) - } else { - return(tbl) - } -} - check_ids <- function(page_ids, question_ids) { # Check for duplicate page IDs duplicate_page_ids <- page_ids[duplicated(page_ids)] diff --git a/R/server.R b/R/server.R index 3e71c262..66775bab 100644 --- a/R/server.R +++ b/R/server.R @@ -3,34 +3,24 @@ #' @description #' This function defines the server-side logic for a Shiny application used in surveydown. #' It handles various operations such as conditional display, progress tracking, -#' page navigation, database updates for survey responses, and admin functionality. +#' page navigation, and database updates for survey responses. #' -#' @param input The Shiny input object. -#' @param output The Shiny output object. -#' @param session The Shiny session object. -#' @param config A list containing configuration settings for the application. #' @param db A list containing database connection information created using -#' \code{\link{sd_database}} function. Defaults to \code{NULL}. +#' \code{\link{sd_database}} function. Defaults to \code{NULL}. +#' @param use_html Logical. By default, the `"survey.qmd"` file will be +#' rendered when the app launches, which can be slow. Users can render it +#' first into a html file and set `use_html = TRUE` to use the pre-rendered +#' file, which is faster when the app loads. Defaults to `FALSE`. +#' @param required_questions Vector of character strings. The IDs of questions that must be answered. Defaults to NULL. +#' @param all_questions_required Logical. If TRUE, all questions in the survey will be required. Defaults to FALSE. +#' @param start_page Character string. The ID of the page to start on. Defaults to NULL. +#' @param admin_page Logical. Whether to include an admin page for viewing and downloading survey data. Defaults to `FALSE`. #' #' @import shiny #' @importFrom stats setNames #' @importFrom shiny reactiveValuesToList observeEvent renderText #' #' @details -#' The \code{config} list should include the following elements: -#' \itemize{ -#' \item \code{page_structure}: A list defining the structure of survey pages. -#' \item \code{page_ids}: A vector of page identifiers. -#' \item \code{question_ids}: A vector of question identifiers. -#' \item \code{show_if}: A data frame defining conditions for showing questions. -#' \item \code{skip_if}: A data frame defining conditions for skipping pages. -#' \item \code{skip_if_custom}: A list of custom skip conditions. -#' \item \code{show_if_custom}: A list of custom show conditions. -#' \item \code{start_page}: The identifier of the starting page. -#' \item \code{question_required}: A vector of required question identifiers. -#' \item \code{all_questions_required}: A logical indicating if all questions are required. -#' \item \code{admin_page}: A logical indicating if an admin page should be included. -#' } #' #' The function performs the following tasks: #' \itemize{ @@ -51,35 +41,83 @@ #' #' @section Database Operations: #' If \code{db} is provided, the function will update the database with survey responses. -#' If \code{db} is \code{NULL} (pause mode), responses will be saved to a local CSV file. +#' If \code{db} is \code{NULL} (ignore mode), responses will be saved to a local CSV file. #' #' @return #' This function does not return a value; it sets up the server-side logic for the Shiny application. #' #' @examples #' \dontrun{ -#' shinyApp( -#' ui = sd_ui(), -#' server = function(input, output, session) { -#' sd_server(input, output, session, config = my_config, db = my_db) -#' } -#' ) +#' library(surveydown) +#' db <- sd_database() #' -#' # With admin page enabled -#' my_config <- sd_config(admin_page = TRUE) #' shinyApp( #' ui = sd_ui(), #' server = function(input, output, session) { -#' sd_server(input, output, session, config = my_config, db = my_db) +#' sd_server(db = db) #' } #' ) #' } #' #' @seealso -#' \code{\link{sd_database}}, \code{\link{sd_question}} +#' \code{\link{sd_database}} #' #' @export -sd_server <- function(input, output, session, config, db = NULL) { +sd_server <- function( + db = NULL, + use_html = FALSE, + required_questions = NULL, + all_questions_required = FALSE, + start_page = NULL, + admin_page = FALSE +) { + + # Get input, output, and session from the parent environment + parent_env <- parent.frame() + input <- get("input", envir = parent_env) + output <- get("output", envir = parent_env) + session <- get("session", envir = parent_env) + + # Tag start time and unique session_id + time_start <- get_utc_timestamp() + session_id <- session$token + + # Get any skip or show conditions + show_if <- shiny::getDefaultReactiveDomain()$userData$show_if + skip_if <- shiny::getDefaultReactiveDomain()$userData$skip_if + + # Run the configuration settings + config <- run_config( + use_html, + required_questions, + all_questions_required, + start_page, + admin_page, + skip_if, + show_if + ) + + # Set up show_if conditions + if (!is.null(show_if)) { set_show_if_conditions(show_if) } + + # Initialize local variables ---- + + # Check if db is NULL (either left blank or specified with ignore = TRUE) + ignore_mode <- is.null(db) + + # Create local objects from config file + pages <- config$pages + head_content <- config$head_content + page_ids <- config$page_ids + question_ids <- config$question_ids + start_page <- config$start_page + admin_page <- config$admin_page + question_required <- config$question_required + + # Pre-compute timestamp IDs + page_ts_ids <- paste0("time_p_", page_ids) + question_ts_ids <- paste0("time_q_", question_ids) + all_ts_ids <- c(page_ts_ids, question_ts_ids) # Initialize local functions ---- @@ -116,65 +154,13 @@ sd_server <- function(input, output, session, config, db = NULL) { } } - # Initialize local variables ---- - - # Tag start time and unique session_id - time_start <- get_utc_timestamp() - session_id <- session$token - - # Check if db is NULL (either left blank or specified with ignore = TRUE) - ignore_mode <- is.null(db) - - # Create local objects from config file - page_structure <- config$page_structure - page_ids <- config$page_ids - question_ids <- config$question_ids - skip_if <- config$skip_if - skip_if_custom <- config$skip_if_custom - show_if <- config$show_if - show_if_custom <- config$show_if_custom - start_page <- config$start_page - show_all_pages <- config$show_all_pages - admin_page <- config$admin_page - question_required <- config$question_required - - # Pre-compute timestamp IDs - page_ts_ids <- paste0("time_p_", page_ids) - question_ts_ids <- paste0("time_q_", question_ids) - all_ts_ids <- c(page_ts_ids, question_ts_ids) - - # Initial page settings ---- - - # Start from start_page (if specified) - if (!is.null(start_page)) { - shinyjs::show(start_page) - } else { - shinyjs::runjs("showFirstPage();") - } - - # Show all pages if show_all_pages is TRUE - if (show_all_pages) lapply(page_ids, shinyjs::show) - - # Conditional display (show_if conditions) - if (!is.null(show_if)) { basic_show_if_logic(input, show_if) } - if (!is.null(show_if_custom)) { custom_show_if_logic(input, show_if_custom) } - - # Other initial settings ---- + # Initial settings ---- # Keep-alive observer - this will be triggered every 60 seconds shiny::observeEvent(input$keepAlive, { cat("Session keep-alive at", format(Sys.time(), "%m/%d/%Y %H:%M:%S"), "\n") }) - # Show asterisks for required questions - session$onFlush(function() { - shinyjs::runjs(sprintf( - "console.log('Shiny initialized'); window.initializeRequiredQuestions(%s);", - # jsonlite::toJSON(question_required) # Requires dependency - vector_to_json_array(question_required) - )) - }, once = TRUE) - # Create admin page if admin_page is TRUE if (isTRUE(config$admin_page)) admin_enable(input, output, session, db) @@ -259,50 +245,247 @@ sd_server <- function(input, output, session, config, db = NULL) { }, ignoreNULL = FALSE, ignoreInit = TRUE) }) - # Main page observer ---- + # Page rendering ---- - shiny::observe({ - lapply(2:length(page_structure), function(i) { - current_page <- page_ids[i-1] - next_page <- page_ids[i] - current_ts_id <- page_ts_ids[i-1] - next_ts_id <- page_ts_ids[i] - - shiny::observeEvent(input[[make_next_button_id(next_page)]], { - # Update next page based on skip logic - next_page <- handle_skip_logic(input, skip_if, skip_if_custom, current_page, next_page) - - # Find the correct timestamp ID after skip logic - next_ts_id <- page_ts_ids[which(page_ids == next_page)] - - # Update timestamp for the next page - timestamps[[next_ts_id]] <- get_utc_timestamp() - - # Check if all required questions are answered - current_page_questions <- page_structure[[current_page]]$questions - all_required_answered <- check_all_required( - current_page_questions, question_required, input, show_if, show_if_custom + # Create reactive values for the current page ID + current_page_id <- shiny::reactiveVal(page_ids[1]) + + # Start from start_page (if specified) + if (!is.null(start_page)) { + current_page_id(start_page) + } + + get_current_page <- reactive({ + pages[[which(sapply(pages, function(p) p$id == current_page_id()))]] + }) + + # Render the current page + output$main <- shiny::renderUI({ + current_page <- get_current_page() + shiny::tagList( + shiny::tags$head(shiny::HTML(head_content)), + shiny::tags$div( + class = "content", + shiny::tags$div( + class = "page-columns page-rows-contents page-layout-article", + shiny::tags$div( + id = "quarto-content", + role = "main", + shiny::HTML(current_page$content) + ) ) + ) + ) + }) + + # Page navigation ---- + + # Determine which page is next, then update current_page_id() to it + shiny::observe({ + lapply(pages, function(page) { + shiny::observeEvent(input[[page$next_button_id]], { - if (all_required_answered) { - shinyjs::runjs("hideAllPages();") - shinyjs::show(next_page) + # Get current and next pages + current_page_id <- page$id + next_page_id <- get_default_next_page(page, page_ids) - # Update data after page change - update_data() - } else { - shinyjs::alert("Please answer all required questions before proceeding.") + # Determine next page based on the current page and skip logic + next_page_id <- handle_skip_logic( + input, skip_if, current_page_id, next_page_id + ) + + if (!is.null(next_page_id)) { + + # Check if all required questions are answered + required_answered <- check_required(page, input, show_if) + + if (required_answered) { + # Update the current page ID, then update the data + current_page_id(next_page_id) + # Update timestamp for the next page + next_ts_id <- page_ts_ids[which(page_ids == next_page_id)] + timestamps[[next_ts_id]] <- get_utc_timestamp() + update_data() + } else { + shiny::showNotification( + "Please answer all required questions before proceeding.", + type = "error" + ) + } } }) }) }) - # Add observer to ensure final update on session end + shiny::observe({ + page <- get_current_page() + if (is.null(page$next_page_id)) { + update_progress_bar(length(question_ids)) + } + }) + + # Ensure final update on session end shiny::onSessionEnded(function() { shiny::isolate({ update_data() }) }) + +} + +#' Define skip conditions for survey pages +#' +#' @description +#' This function is used to define conditions under which certain pages in the survey should be skipped. +#' It takes one or more formulas where the left-hand side is the condition and the right-hand side is the target page ID. +#' +#' @param ... One or more formulas defining skip conditions. +#' The left-hand side of each formula should be a condition based on input values, +#' and the right-hand side should be the ID of the page to skip to if the condition is met. +#' +#' @return A list of parsed conditions, where each element contains the condition and the target page ID. +#' +#' @examples +#' \dontrun{ +#' sd_skip_if( +#' as.numeric(input$age < 18) ~ "underage_page", +#' input$country != "USA" ~ "international_page" +#' ) +#'} +#' @seealso \code{\link{sd_show_if}} +#' +#' @export +sd_skip_if <- function(...) { + conditions <- parse_conditions(...) + + # Create a list in userData to store the skip_if targets + shiny::isolate({ + session <- shiny::getDefaultReactiveDomain() + if (is.null(session)) { + stop("sd_skip_if must be called within a Shiny reactive context") + } + if (is.null(session$userData$skip_if)) { + session$userData$skip_if <- list() + } + session$userData$skip_if$conditions <- conditions + session$userData$skip_if$targets <- get_unique_targets(conditions) + }) +} + +#' Define show conditions for survey questions +#' +#' @description +#' This function is used to define conditions under which certain questions in the survey should be shown. +#' It takes one or more formulas where the left-hand side is the condition and the right-hand side is the target question ID. +#' If called with no arguments, it will return NULL and set no conditions. +#' +#' @param ... One or more formulas defining show conditions. +#' The left-hand side of each formula should be a condition based on input values, +#' and the right-hand side should be the ID of the question to show if the condition is met. +#' +#' @return A list of parsed conditions, where each element contains the condition and the target question ID. +#' Returns NULL if no conditions are provided. +#' +#' @examples +#' \dontrun{ +#' sd_show_if( +#' input$has_pets == "yes" ~ "pet_details", +#' input$employment == "employed" ~ "job_questions" +#' ) +#' } +#' +#' @seealso \code{\link{sd_skip_if}} +#' +#' @export +sd_show_if <- function(...) { + conditions <- parse_conditions(...) + # Create a list in userData to store the show_if targets + shiny::isolate({ + session <- shiny::getDefaultReactiveDomain() + if (is.null(session)) { + stop("sd_show_if must be called within a Shiny reactive context") + } + if (is.null(session$userData$show_if)) { + session$userData$show_if <- list() + } + session$userData$show_if$conditions <- conditions + session$userData$show_if$targets <- get_unique_targets(conditions) + }) +} + +set_show_if_conditions <- function(show_if) { + conditions <- show_if$conditions + + # Check if conditions is empty + if (length(conditions) == 0) { + return() + } + + # Group conditions by target + grouped_conditions <- split(conditions, sapply(conditions, function(rule) rule$target)) + + # Create a reactive expression for each group of conditions + condition_reactives <- lapply(grouped_conditions, function(group) { + shiny::reactive({ + results <- lapply(group, function(rule) { + tryCatch({ + evaluate_condition(rule) + }, error = function(e) { + warning(sprintf( + "Error in show_if condition for target '%s', condition '%s': %s", + rule$target, + deparse(rule$condition), + conditionMessage(e) + )) + FALSE + }) + }) + any(unlist(results)) + }) + }) + + # Create a single observer to handle all condition groups + shiny::observe({ + for (target in names(grouped_conditions)) { + condition_met <- condition_reactives[[target]]() + + if (condition_met) { + shinyjs::runjs(sprintf(" + $('#%s').closest('.question-container').show(); + $('#%s').show(); + ", target, target)) + } else { + shinyjs::runjs(sprintf(" + $('#%s').closest('.question-container').hide(); + $('#%s').hide(); + ", target, target)) + } + } + }) +} + +get_unique_targets <- function(a) { + return(unique(sapply(a, function(x) x$target))) +} + +parse_conditions <- function(...) { + conditions <- list(...) + lapply(conditions, function(cond) { + if (!inherits(cond, "formula")) { + stop("Each condition must be a formula (condition ~ target)") + } + list( + condition = cond[[2]], # Left-hand side of the formula + target = eval(cond[[3]]) # Right-hand side of the formula + ) + }) +} + +evaluate_condition <- function(rule) { + isTRUE(eval( + rule$condition, + envir = list(input = shiny::getDefaultReactiveDomain()$input) + )) } # Function to get all stored values @@ -367,153 +550,86 @@ format_question_value <- function(val) { } } -# Handle basic show-if logic -basic_show_if_logic <- function(input, show_if) { - - # Ensure show_if is a tibble or data frame - if (!is.data.frame(show_if)) { - stop("show_if must be a data frame or tibble.") - } - - # Initially hide all conditional questions and their containers - unique_targets <- unique(show_if$target) - for (target in unique_targets) { - shinyjs::runjs(sprintf(" - $('#%s').closest('.question-container').hide(); - $('#%s').hide(); - ", target, target)) - } - - # Group show_if rules by question_id and target - show_if_grouped <- split(show_if, list(show_if$question_id, show_if$target)) - - # Iterate over each group of show_if rules - for (group in show_if_grouped) { - question_id <- group$question_id[1] - target <- group$target[1] - question_values <- group$question_value - - shiny::observeEvent(input[[question_id]], { - # Check if the condition is met to show/hide the question - val <- input[[question_id]] - if (!is.null(val) && val %in% question_values) { - shinyjs::runjs(sprintf(" - $('#%s').closest('.question-container').show(); - $('#%s').show(); - ", target, target)) - } else { - shinyjs::runjs(sprintf(" - $('#%s').closest('.question-container').hide(); - $('#%s').hide(); - ", target, target)) - } - }, ignoreNULL = TRUE) - } -} - -# Handle custom show-if logic -custom_show_if_logic <- function(input, show_if_custom) { - # Initially hide all conditional questions and their containers - lapply(show_if_custom, function(x) { - shinyjs::runjs(sprintf(" - $('#%s').closest('.question-container').hide(); - $('#%s').hide(); - ", x$target, x$target)) - }) - - # Create a reactive expression for each condition - condition_reactives <- lapply(show_if_custom, function(rule) { - shiny::reactive({ rule$condition(input) }) - }) - - # Create a single observer to handle all conditions - shiny::observe({ - for (i in seq_along(show_if_custom)) { - condition_result <- condition_reactives[[i]]() - condition_met <- isTRUE(condition_result) - target <- show_if_custom[[i]]$target - - if (condition_met) { - shinyjs::runjs(sprintf(" - $('#%s').closest('.question-container').show(); - $('#%s').show(); - ", target, target)) - } else { - shinyjs::runjs(sprintf(" - $('#%s').closest('.question-container').hide(); - $('#%s').hide(); - ", target, target)) - } - } - }) -} - -# Handle overall skip logic -handle_skip_logic <- function(input, skip_if, skip_if_custom, current_page, next_page) { - if (!is.null(skip_if)) { - next_page <- basic_skip_logic(input, skip_if, current_page, next_page) - } - if (!is.null(skip_if_custom)) { - next_page <- custom_skip_logic(input, skip_if_custom, current_page, next_page) - } - return(next_page) -} - -# Handle basic skip logic -basic_skip_logic <- function( - input, skip_if, current_page, next_page -) { - - for (i in 1:nrow(skip_if)) { - rule <- skip_if[i,] - val <- input[[rule$question_id]] - if (!is.null(val)) { - if ((val == rule$question_value) & (current_page != rule$target)) { - return(rule$target) - } +get_default_next_page <- function(page, page_ids) { + if (is.null(page$next_page_id)) { return(NULL) } + next_page_id <- page$next_page_id + if (next_page_id == "") { + # No next page specified, so just go to the next one + index <- which(page_ids == page$id) + 1 + if (index <= length(page_ids)) { + return(page_ids[index]) + } else { + return(NULL) # No next page if we're on the last page } } - - return(next_page) + return(next_page_id) } -# Handle custom skip logic -custom_skip_logic <- function( - input, skip_if_custom, current_page, next_page -) { +handle_skip_logic <- function(input, skip_if, current_page_id, next_page_id) { + if (is.null(next_page_id) | is.null(skip_if)) { return(next_page_id) } # Loop through each skip logic condition - for (j in 1:length(skip_if_custom)) { - rule <- skip_if_custom[[j]] + conditions <- skip_if$conditions + for (i in seq_along(conditions)) { + rule <- conditions[[i]] # Evaluate the condition - condition_result <- rule$condition(input) + condition_result <- tryCatch({ + evaluate_condition(rule) + }, error = function(e) { + warning(sprintf( + "Error in skip_if condition for target '%s': %s", + rule$target, conditionMessage(e)) + ) + FALSE + }) # Check if the condition is met - if (isTRUE(condition_result) & (current_page != rule$target)) { + if (condition_result & (current_page_id != rule$target)) { return(rule$target) } } - - return(next_page) + return(next_page_id) } -# Check if all required questions are answered -check_all_required <- function( - questions, questions_required, input, show_if, show_if_custom -) { - results <- vapply(questions, function(q) { - is_required <- q %in% questions_required - is_visible <- is_question_visible(q, show_if, show_if_custom, input) - is_answered <- check_answer(q, input) - - if (!is_required) return(TRUE) +check_required <- function(page, input, show_if) { + results <- vapply(page$questions, function(q) { + if (!q %in% page$required_questions) return(TRUE) + is_visible <- is_question_visible(q, show_if, input) if (!is_visible) return(TRUE) - return(is_answered) + return(check_answer(q, input)) }, logical(1)) + return(all(results)) +} + +is_question_visible <- function(q, show_if, input) { + if (is.null(show_if)) return(TRUE) + + # Get all conditions for this question + question_conditions <- get_conditions_for_question(show_if$conditions, q) + + # If there are no conditions, the question is always visible + if (length(question_conditions) == 0) return(TRUE) + + # Check if any of the conditions are met + is_visible <- any(sapply(question_conditions, function(rule) { + tryCatch({ + evaluate_condition(rule) + }, error = function(e) { + warning(sprintf( + "Error evaluating condition for question '%s': %s", + q, conditionMessage(e) + )) + FALSE + }) + })) + + return(is_visible) +} - all_required_answered <- all(results) - return(all_required_answered) +# Helper function to get conditions for a specific question +get_conditions_for_question <- function(conditions, q) { + Filter(function(rule) rule$target == q, conditions) } # Check if a single question is answered @@ -527,31 +643,6 @@ check_answer <- function(q, input) { return(TRUE) # Default to true for unknown types } -# Check if a question is visible -is_question_visible <- function(q, show_if, show_if_custom, input) { - # Check basic show_if conditions - basic_visible <- if (is.null(show_if) || nrow(show_if) == 0) TRUE else { - rules <- show_if[show_if$target == q, ] - nrow(rules) == 0 || any(sapply(1:nrow(rules), function(i) { - input_value <- input[[rules$question_id[i]]] - expected_value <- rules$question_value[i] - if (is.null(input_value)) FALSE - else if (is.list(input_value)) expected_value %in% unlist(input_value) - else input_value == expected_value - })) - } - - # Check custom show_if conditions - custom_visible <- if (is.null(show_if_custom)) TRUE else { - !any(sapply(show_if_custom, function(rule) { - rule$target == q && !isTRUE(rule$condition(input)) - })) - } - - # Return TRUE if the question is visible according to both conditions - basic_visible && custom_visible -} - admin_enable <- function(input, output, session, db) { #not fun to figure out, do not render the admin page at the start if you are #using an outright hide_pages js file @@ -647,7 +738,7 @@ admin_enable <- function(input, output, session, db) { #Read table value in, change it from true to false - #Add in Sd_server if(survey_paused == TRUE) + #Add in sd_server if(survey_paused == TRUE) #Create and display a blank page that says the survey is pause diff --git a/R/templates.R b/R/templates.R deleted file mode 100644 index 7fcffa9d..00000000 --- a/R/templates.R +++ /dev/null @@ -1,133 +0,0 @@ -#' Create a Survey Template -#' -#' This function creates a survey template in a specified directory. It can use -#' different templates, with `"simple"` being the default. The function prompts -#' the user to confirm the use of the current working directory if no path is -#' specified. -#' -#' @param path A character string specifying the directory in which to create -#' the survey template. Defaults to the current working directory. -#' @param template A character string specifying the survey template to use. -#' Defaults to `"simple"`. Currently, only the "simple" template is available. -#' -#' @return Invisibly returns TRUE if the survey template was successfully created. -#' @export -#' -#' @details -#' This function downloads the latest version of the surveydown extension from GitHub, -#' and uses it to create a new survey project. It copies all necessary files and -#' directories to the specified path, excluding some files like README.md and .gitignore. -#' -#' @examples -#' \dontrun{ -#' sd_create_survey() -#' sd_create_survey(path = "path/to/survey", template = "simple") -#' } -sd_create_survey <- function(path = getwd(), template = "simple") { - using_current_dir <- path == getwd() - if (using_current_dir && !usethis::ui_yeah(paste("Do you want to use the current working directory (", path, ") as the path?"))) { - stop("Operation aborted by the user.") - } - - temp_dir <- tempfile() - dir.create(temp_dir) - unzipped_dir <- download_extension(temp_dir) - - dir.create(path, recursive = TRUE, showWarnings = FALSE) - - if (using_current_dir) { - existing_rproj <- list.files(path, pattern = "\\.Rproj$", full.names = TRUE) - if (length(existing_rproj) > 0) { - example_rproj <- file.path(unzipped_dir, "example.Rproj") - if (file.exists(example_rproj)) { - file.remove(example_rproj) - } - } - } - - target_surveydown_path <- file.path(path, "_extensions", "surveydown-dev", "surveydown") - if (dir.exists(target_surveydown_path)) { - unlink(target_surveydown_path, recursive = TRUE) - } - - target_surveydown_dev_path <- file.path(path, "_extensions", "surveydown-dev") - dir.create(target_surveydown_dev_path, recursive = TRUE, showWarnings = FALSE) - - source_surveydown_path <- file.path(unzipped_dir, "_extensions", "surveydown-dev", "surveydown") - file.copy(source_surveydown_path, target_surveydown_dev_path, recursive = TRUE) - - items_to_move <- list.files(unzipped_dir, all.files = TRUE, full.names = TRUE, no.. = TRUE) - items_to_move <- items_to_move[!grepl("_extensions", items_to_move)] - - # Exclude README.md and .gitignore - exclude_files <- c("README.md", ".gitignore") - items_to_move <- items_to_move[!basename(items_to_move) %in% exclude_files] - - for (item in items_to_move) { - if (dir.exists(item)) { - file.copy(item, path, recursive = TRUE) - } else { - file.copy(item, file.path(path, basename(item)), overwrite = TRUE) - } - } - - unlink(temp_dir, recursive = TRUE) - - usethis::ui_done(paste("Survey template created at", path)) -} - -#' Update Survey Extension -#' -#' This function updates or creates the _extensions/surveydown-dev/surveydown folder -#' with the latest contents from the surveydown-ext repository. -#' -#' @param path A character string specifying the directory in which to update -#' or create the extension. Defaults to the current working directory. -#' -#' @return Invisibly returns TRUE if the extension was successfully updated. -#' @export -#' -#' @details -#' This function downloads the latest version of the surveydown extension from GitHub, -#' and updates the local copy in the specified path. If the extension directory -#' doesn't exist, it will be created. -#' -#' @examples -#' \dontrun{ -#' sd_update_extension() -#' sd_update_extension(path = "path/to/survey") -#' } -sd_update_extension <- function(path = getwd()) { - temp_dir <- tempfile() - dir.create(temp_dir) - unzipped_dir <- download_extension(temp_dir) - - source_path <- file.path(unzipped_dir, "_extensions", "surveydown-dev", "surveydown") - target_path <- file.path(path, "_extensions", "surveydown-dev", "surveydown") - - if (dir.exists(target_path)) { - unlink(list.files(target_path, full.names = TRUE), recursive = TRUE) - } else { - dir.create(target_path, recursive = TRUE, showWarnings = FALSE) - } - - file.copy(list.files(source_path, full.names = TRUE), target_path, recursive = TRUE) - - unlink(temp_dir, recursive = TRUE) - - usethis::ui_done(paste("Survey extension updated at", target_path)) -} - -# Download and Extract Survey Extension -download_extension <- function(temp_dir) { - repo_url <- "https://github.com/surveydown-dev/surveydown-ext/archive/refs/heads/main.zip" - temp_file <- tempfile(fileext = ".zip") - - utils::download.file(repo_url, temp_file, mode = "wb") - utils::unzip(temp_file, exdir = temp_dir) - - unzipped_dir <- file.path(temp_dir, "surveydown-ext-main") - unlink(temp_file) - - return(unzipped_dir) -} diff --git a/R/ui.R b/R/ui.R index f18aee1e..057e8c8a 100644 --- a/R/ui.R +++ b/R/ui.R @@ -1,3 +1,118 @@ +# Load resource file from the surveydown package (CSS or JS) +load_resource <- function(files, type = c("css", "js"), package = "surveydown") { + type <- match.arg(type) + sapply(files, function(file) { + path <- system.file(paste0(type, "/", file), package = package) + if (type == "css") { + shiny::includeCSS(path) + } else { + shiny::includeScript(path) + } + }, simplify = FALSE, USE.NAMES = FALSE) +} + +#' Create the UI for a surveydown survey +#' +#' This function creates the user interface for a surveydown survey, +#' including necessary CSS and JavaScript files, and applies custom styling. +#' It retrieves theme and progress bar settings from the survey.qmd file. +#' +#' @return A Shiny UI object +#' @export +#' +#' @details +#' The function reads the following settings from the survey.qmd YAML header: +#' \itemize{ +#' \item \code{theme}: The theme to be applied to the survey. +#' \item \code{barcolor}: The color of the progress bar (should be a valid hex color). +#' \item \code{barposition}: The position of the progress bar ('top', 'bottom', or 'none'). +#' } +#' +#' If \code{barcolor} is not specified or is NULL, the default theme color will be used. +#' If \code{barposition} is not specified, it defaults to 'top'. +#' +#' @examples +#' \dontrun{ +#' # In your app.R or ui.R file: +#' ui <- sd_ui() +#' } +sd_ui <- function() { + # Throw error if "survey.qmd" file missing + check_survey_file_exists() + + # Get the theme from the survey.qmd file + metadata <- quarto::quarto_inspect("survey.qmd") + theme <- get_theme(metadata) + default_theme_css <- "" + if (theme == "default") { + default_theme_css <- " + body, button, input, select, textarea { + font-family: 'Raleway', sans-serif; + } + h1, h2, h3, h4, h5, h6 { + font-family: 'Raleway', sans-serif; + font-weight: 800; + } + " + } + + # Get progress bar settings from the survey.qmd file + barcolor <- get_barcolor(metadata) + barposition <- get_barposition(metadata) + + shiny::fluidPage( + shinyjs::useShinyjs(), + shiny::tags$style(HTML(default_theme_css)), + load_resource("surveydown.css", type = "css"), + load_resource("keep_alive.js", type = "js"), + if (!is.null(barcolor)) { + shiny::tags$style(HTML(sprintf(" + :root { + --progress-color: %s; + } + ", barcolor))) + }, + if (barposition != "none") { + shiny::tags$div( + 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) +} + +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.") + } + } + return(barcolor) +} + +get_barposition <- function(metadata) { + barposition <- metadata$formats$html$metadata$barposition + if (is.null(barposition)) { + return("top") + } + return(barposition) +} + #' Create a survey question #' #' This function creates various types of survey questions for use in a Surveydown survey. @@ -116,6 +231,12 @@ sd_question <- function( status = status ) + output <- shiny::tagAppendChild(output, shiny::tags$script(shiny::HTML(sprintf(" + $(document).on('click', '#%s .btn', function() { + %s + }); + ", id, js_interaction)))) + } else if (type == "mc_multiple_buttons") { output <- shinyWidgets::checkboxGroupButtons( @@ -128,6 +249,12 @@ sd_question <- function( width = width ) + output <- shiny::tagAppendChild(output, shiny::tags$script(shiny::HTML(sprintf(" + $(document).on('click', '#%s .btn', function() { + %s + }); + ", id, js_interaction)))) + } else if (type == "text") { output <- shiny::textInput( @@ -227,7 +354,7 @@ sd_question <- function( # Wrap the output in a div with custom data attributes output_div <- shiny::tags$div( - id = paste("container-", id), + id = paste0("container-", id), `data-question-id` = id, class = "question-container", oninput = js_interaction, @@ -277,20 +404,16 @@ date_interaction <- function(output, id) { #' #' @export sd_next <- function(next_page = NULL, label = "Next") { - if (is.null(next_page)) { - stop("You must specify the current_page for the 'Next' button.") - } - - button_id <- make_next_button_id(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, style = "display: block; margin: auto;", - onclick = sprintf("Shiny.setInputValue('next_page', '%s');", next_page) + onclick = "Shiny.setInputValue('next_page', this.parentElement.getAttribute('data-next-page'));" ) ), shiny::tags$script(shiny::HTML(enter_key_js(button_id))) @@ -298,8 +421,44 @@ sd_next <- function(next_page = NULL, label = "Next") { } # Generate Next Button ID -make_next_button_id <- function(next_page) { - return(paste0("next-", next_page)) +make_next_button_id <- function(page_id) { + return(paste0(page_id, "_next")) +} + +#' Create a 'Close' Button to Exit the Survey +#' +#' This function creates a 'Close' button that, when clicked, will close the current browser tab or window. +#' The button can be activated by clicking or by pressing the Enter key. +#' +#' @param label Character string. The label of the 'Close' button. Defaults to "Exit Survey". +#' +#' @details The function generates a Shiny action button that, when clicked or when the Enter key is pressed, +#' will attempt to close the current browser tab or window. Note that for security reasons, +#' some browsers may not allow JavaScript to close windows that were not opened by JavaScript. +#' In such cases, the button will prompt the user to close the tab manually. +#' +#' @return A Shiny action button UI element with associated JavaScript for closing the page and Enter key functionality. +#' +#' @examples +#' sd_close() +#' sd_close("Exit Survey") +#' +#' @export +sd_close <- function(label = "Exit Survey") { + button_id <- "close-survey-button" + + shiny::tagList( + shiny::div( + style = "margin-top: 0.5rem; margin-bottom: 0.5rem;", + shiny::actionButton( + inputId = button_id, + label = label, + style = "display: block; margin: auto;", + onclick = "window.close(); if (!window.closed) { alert('Please close this tab manually to exit the survey.'); }" + ) + ), + shiny::tags$script(shiny::HTML(enter_key_js(button_id))) + ) } #' Create a Redirect Element for Shiny Applications @@ -546,8 +705,7 @@ sd_get_url_pars <- function(...) { #' Create a placeholder for a reactive survey question #' -#' This function creates a placeholder div for a reactive survey question in a Surveydown survey. -#' It's used in conjunction with sd_question to allow for dynamic question rendering. +#' This function is depreciated - use `sd_output()` instead. #' #' @param id A unique identifier for the question. #' @return A Shiny UI element that serves as a placeholder for the reactive question. @@ -569,6 +727,7 @@ sd_display_question <- function(id) { #' Display the value of a survey question #' +#' This function is depreciated - use `sd_output()` instead. #' @param id The ID of the question to display #' @param display_type The type of display. Can be "inline" (default), "text", "verbatim", or "ui". #' @param wrapper A function to wrap the output diff --git a/R/util.R b/R/util.R index 4640a6b3..d1329ae9 100644 --- a/R/util.R +++ b/R/util.R @@ -1,30 +1,3 @@ -#' Required Set Up Function -#' -#' This function is required for any surveydown survey. It sets up a Shiny application with Bootstrap 5 and initializes Shinyjs for JavaScript functionalities. -#' -#' @details The function configures the Shiny application to use Bootstrap 5 for styling and enables -#' Shinyjs for JavaScript functionalities within the application. -#' -#' @return This function does not return a value. It is called for its side effects of setting up the Shiny application. -#' -#' @examples -#' \dontrun{ -#' ui <- fluidPage( -#' sd_setup(), -#' # Your UI elements here -#' ) -#' server <- function(input, output, session) { -#' # Your server logic here -#' } -#' shinyApp(ui, server) -#' } -#' -#' @export -sd_setup <- function() { - shiny::shinyOptions(bootstrapTheme = bslib::bs_theme(version = 5L)) - shinyjs::useShinyjs(rmd = TRUE) -} - # Convert Markdown to HTML markdown_to_html <- function(text) { if (is.null(text)) { return(text) } @@ -53,6 +26,17 @@ list_name_md_to_html <- function(list) { #' #' @noRd .onAttach <- function(libname, pkgname) { + + # Add special folders to resource path + folders <- c('images', 'css', 'js', 'www') + for (folder in folders) { include_folder(folder) } + + # Add survey_files folder to resource path + # (if survey.qmd exists and it's not self contained) + folder <- get_survey_file_folder() + if (!is.null(folder)) { include_folder(folder, create = TRUE) } + + # Print package data desc <- utils::packageDescription(pkgname, libname) packageStartupMessage( "Version: ", desc$Version, "\n", @@ -63,6 +47,80 @@ list_name_md_to_html <- function(list) { ) } +get_survey_file_folder <- function() { + if (!survey_file_exists()) { return(NULL) } + if (!is_self_contained("survey.qmd")) { + return("survey_files") + } + return(NULL) +} + +survey_file_exists <- function() { + files <- basename(list.files(full.names = TRUE)) + if ("survey.qmd" %in% files) { return(TRUE) } + return(FALSE) +} + +is_self_contained <- function(x) { + result <- quarto::quarto_inspect(x)$formats$html$pandoc$`self-contained` + if (is.null(result)) { return(FALSE) } + return(result) +} + +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) + } +} + +check_survey_file_exists <- function() { + if (!survey_file_exists()) { + stop('Missing "survey.qmd" file. Your survey file must be named "survey.qmd"') + } +} + +#' Include a folder to Shiny's resource path +#' +#' This function includes a specified folder to Shiny's resource path, +#' making it accessible for serving static files in a Shiny application. +#' It checks for pre-existing resource paths to avoid conflicts with +#' folders already included by the package. +#' +#' @param folder A character string specifying the name of the folder to include. +#' This folder should exist in the root directory of your Shiny app. +#' +#' @return `NULL` invisibly. The function is called for its side effect of +#' adding a resource path to Shiny. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' sd_include_folder("custom_images") +#' } +sd_include_folder <- function(folder) { + # 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 (!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.")) + + invisible(NULL) +} + # Convert Vector to JSON Array vector_to_json_array <- function(vec) { if (length(vec) == 0) return("[]") @@ -103,3 +161,170 @@ tibble_to_list_of_lists <- function(tbl) { ) }) } + +# Function to render Quarto document to a temporary file +quarto_render_temp <- function(input) { + + # Create a temporary directory + temp_dir <- tempdir() + + # Get the output file path in the original directory + x <- quarto::quarto_inspect(input) + output_format <- names(x$formats) + original_output <- x$formats[[output_format]]$pandoc$`output-file` + original_output_path <- file.path(dirname(input), original_output) + + # Render the Quarto document + quarto::quarto_render(input) + + # Define the path for the temporary file + temp_output_path <- file.path(temp_dir, "temp_output.html") + + # Copy the rendered file to the temporary location and delete the original + file.copy(from = original_output_path, to = temp_output_path, overwrite = TRUE) + file.remove(original_output_path) + + # Return the path to the temporary file + return(temp_output_path) +} + +#' Create a new survey template +#' +#' This function creates a new survey template by copying files from the package's +#' template directory to a specified path. It handles file conflicts and provides +#' appropriate warnings and feedback. +#' +#' @param path A character string specifying the directory where the survey template +#' should be created. Defaults to the current working directory. +#' @param structure A character string specifying the template structure to use. +#' Must be either "single" or "multi". Defaults to "single". +#' +#' @return Invisible NULL. The function is called for its side effects of creating +#' files and providing user feedback. +#' +#' @details +#' The function performs the following steps: +#' \itemize{ +#' \item If the specified path is the current working directory, it asks for user confirmation. +#' \item Validates the specified structure ("single" or "multi"). +#' \item Creates the target directory if it doesn't exist. +#' \item Copies all files from the package's template directory (based on the specified structure) to the target path. +#' \item Preserves the directory structure of the template. +#' \item Skips existing files and provides warnings for each skipped file. +#' \item Handles .Rproj files specially, skipping if any .Rproj file already exists in the target directory. +#' \item Provides feedback on whether files were copied or if all files already existed. +#' } +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' # Create a multi-page survey template in the current working directory +#' sd_create_survey() +#' +#' # Create a single-page survey template in a specific directory +#' sd_create_survey("path/to/my/survey", structure = "single") +#' +#' # Create a multi-page survey template in a specific directory +#' sd_create_survey("path/to/my/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.") + } + + # 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) + + # 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)) + } else { + usethis::ui_done("Since all files exist, no file was added.") + } +} + +#' Deploy a Surveydown App +#' +#' This function is a wrapper for `rsconnect::deployApp()` specifically designed +#' for deploying Surveydown applications. It simplifies the deployment process +#' by allowing you to specify just the app name. +#' +#' @param name A character string specifying the name of the app. Default is "survey". +#' +#' @return This function doesn't return a value; it deploys the app to Shiny Server. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' # Deploy with default name "survey" +#' sd_deploy() +#' +#' # Deploy with a custom name +#' sd_deploy("my_custom_survey") +#' } +#' +#' @seealso \code{\link[rsconnect]{deployApp}} +#' +#' @importFrom rsconnect deployApp +sd_deploy <- function(name = "survey") { + rsconnect::deployApp(appName = name) +} + +#' Required Set Up Function +#' +#' This function is depreciated and no longer needed. +#' +#' @details The function configures the Shiny application to use Bootstrap 5 for styling and enables +#' Shinyjs for JavaScript functionalities within the application. +#' +#' @return This function does not return a value. It is called for its side effects of setting up the Shiny application. +#' +#' @examples +#' \dontrun{ +#' ui <- fluidPage( +#' sd_setup(), +#' # Your UI elements here +#' ) +#' } +#' +#' @export +sd_setup <- function() { + # v0.3.0 + .Deprecated("") +} diff --git a/R/version.R b/R/version.R index dcdd1632..03aa2027 100644 --- a/R/version.R +++ b/R/version.R @@ -1,106 +1,86 @@ -#' Update Surveydown Package and Extension +#' Update Surveydown Package #' -#' This function checks and updates both the surveydown R package and its -#' associated Quarto extension. It ensures that both components are up-to-date -#' and their versions match. +#' This function checks and updates surveydown. +#' It ensures that the package is up-to-date. #' -#' @param force Logical; if TRUE, forces an update regardless of current versions. +#' @param force Logical; if TRUE, forces an update regardless of current version. #' Defaults to FALSE. -#' @param ... Optional arguments to pass on to `sd_update_extension()` #' #' @return No return value, called for side effects. #' @export #' #' @examples #' \dontrun{ -#' sd_update_surveydown() -#' sd_update_surveydown(force = TRUE) +#' sd_update() +#' sd_update(force = TRUE) #' } -sd_update_surveydown <- function(force = FALSE, ...) { - # Check R package version - pkg_version <- utils::packageVersion("surveydown") +sd_update <- function(force = FALSE) { + # Check surveydown version + surveydown_version <- utils::packageVersion("surveydown") - # Check Quarto extension version - ext_version <- get_extension_version() + # Check latest version + latest_version <- get_latest_version("https://raw.githubusercontent.com/surveydown-dev/surveydown/main/DESCRIPTION", "Version: ") - if (is.null(ext_version)) { - message("Quarto extension not found. Installing both package and extension.") - force <- TRUE - } else if (pkg_version != ext_version) { - message("Version mismatch detected. Updating both package and extension.") - force <- TRUE + if (is.null(latest_version)) { + message("Unable to fetch the latest version. Please check your internet connection.") + return(invisible()) } - if (force) { - message("Updating surveydown R package and all dependencies...") + if (force || surveydown_version < latest_version) { + message("Updating surveydown and all dependencies...") remotes::install_github( "surveydown-dev/surveydown", force = TRUE, dependencies = TRUE, upgrade = "always" ) - - message("Updating surveydown Quarto extension...") - surveydown::sd_update_extension(...) - message("Update complete.") } else { - message("Both R package and Quarto extension are up-to-date.") + message("surveydown is up-to-date.") } } -#' Check Surveydown Versions +#' Check Surveydown Version #' -#' This function checks if the local surveydown R package and Quarto extension -#' are up-to-date with the latest online version. It compares local versions -#' with the latest versions available on GitHub and provides information about -#' whether updates are needed. +#' This function checks if the local surveydown package is up-to-date with +#' the latest online version. It compares the local version with the latest +#' version available on GitHub and provides information about whether an update +#' is needed. #' #' @return No return value, called for side effects (prints version information #' and update status to the console). #' @export #' #' @examples -#' sd_check_versions() -sd_check_versions <- function() { - # Get local versions - local_pkg_version <- utils::packageVersion("surveydown") - local_ext_version <- get_extension_version() +#' sd_version() +sd_version <- function() { + # Get local version + local_surveydown_version <- utils::packageVersion("surveydown") - # Get latest online versions - latest_pkg_version <- get_latest_version_from_url("https://raw.githubusercontent.com/surveydown-dev/surveydown/main/DESCRIPTION", "Version: ") - latest_ext_version <- get_latest_version_from_url("https://raw.githubusercontent.com/surveydown-dev/surveydown-ext/main/_extensions/surveydown-dev/surveydown/_extension.yml", "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 R package (local): ", local_pkg_version) - message("surveydown R package (latest): ", - if(is.null(latest_pkg_version)) "Unable to fetch" else latest_pkg_version) - - if (is.null(local_ext_version)) { - message("surveydown Quarto ext (local): Not found") - } else { - message("surveydown Quarto ext (local): ", local_ext_version) - } - message("surveydown Quarto ext (latest): ", - if(is.null(latest_ext_version)) "Unable to fetch" else latest_ext_version) + message("surveydown (local): ", local_surveydown_version) + message("surveydown (latest): ", + if(is.null(latest_surveydown_version)) "Unable to fetch" else latest_surveydown_version) - # Check if updates are needed - if (is.null(latest_pkg_version) || is.null(latest_ext_version)) { - message("\nUnable to determine if updates are available.") + # 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_pkg_version < latest_pkg_version - ext_needs_update <- is.null(local_ext_version) || local_ext_version < latest_ext_version + pkg_needs_update <- local_surveydown_version < latest_surveydown_version - if (pkg_needs_update || ext_needs_update) { - message("\nUpdates are available. To update both the package and extension to the latest version, run: surveydown::sd_update_surveydown()") + if (pkg_needs_update) { + message("\nAn update is available. To update surveydown to the latest version, run: surveydown::sd_update()") } else { - message("\nBoth the R package and Quarto extension are up to date.") + message("\nsurveydown is up to date.") } } } -get_latest_version_from_url <- function(url, pattern) { +get_latest_version <- function(url, pattern) { tryCatch({ content <- readLines(url) version_line <- grep(pattern, content, value = TRUE) @@ -116,12 +96,3 @@ get_latest_version_from_url <- function(url, pattern) { return(NULL) }) } - -get_extension_version <- function(path = getwd()) { - ext_yaml <- file.path(path, "_extensions", "surveydown-dev", "surveydown", "_extension.yml") - if (!file.exists(ext_yaml)) { - return(NULL) - } - yaml_content <- yaml::read_yaml(ext_yaml) - return(yaml_content$version) -} diff --git a/README.Rmd b/README.Rmd index f4f69ae3..9b621a82 100644 --- a/README.Rmd +++ b/README.Rmd @@ -17,11 +17,9 @@ knitr::opts_chunk$set( # surveydown surveydown package logo: a hex shape with a large letter S and a down arrow -### Visit our main site [surveydown.org](https://surveydown.org) for more information! +> Note: This site only documents the {surveydown} R package - visit our main site at [surveydown.org](https://surveydown.org) for more information! -> Note: This is still an early-stage project. Use with caution, and please give us feedback! - -This package helps you create markdown-based surveys with [Quarto Shiny Documents](https://quarto.org/docs/dashboards/interactivity/shiny-r.html). It brings together three open source technologies ([Quarto](https://quarto.org/), [shiny](https://shiny.posit.co/), and [supabase](https://supabase.com/)) to create dynamic, markdown-based surveys. Here's the basic concept: +**surveydown** is a flexible, open-source platform for making surveys with [R](https://www.r-project.org/), [Quarto](https://quarto.org/), [Shiny](https://shiny.posit.co/), and [Supabase](https://supabase.com/).
@@ -29,41 +27,42 @@ This package helps you create markdown-based surveys with [Quarto Shiny Document

-1. Design your survey as a [Quarto shiny document](https://quarto.org/docs/dashboards/interactivity/shiny-r.html) using markdown and R code. -2. Render your doc into a [shiny](https://shiny.posit.co/) app that can be hosted online and sent to respondents. -3. Store your survey responses in a [supabase](https://supabase.com/) database. +The basic concept is: + +1. Design your survey as a [Quarto](https://quarto.org/) document using markdown and R code. +2. Convert your survey into a [Shiny](https://shiny.posit.co/) app that can be hosted online and sent to respondents. +3. Store your survey responses in a [Supabase](https://supabase.com/) database (or any Postgres database). -The {surveydown} R package works in tandem with our [surveydown Quarto extension](https://github.com/surveydown-dev/surveydown-ext) to make everything work. +The {surveydown} R package provides functions to bring this all together. **See the [documentation](https://surveydown.org) to get started making your own surveydown survey!** # Background & Motivation -Most survey platforms (e.g., Google forms, Qualtrics, etc.) use drag-and-drop interfaces to design surveys, making version control and collaboration with others difficult. They're also not reproducible. +Most survey platforms (e.g., Google forms, Qualtrics, etc.) use drag-and-drop interfaces to design surveys, making version control and collaboration with others difficult. They're also not reproducible (others cannot easily reproduce a survey made on these platforms), and many require a paid subscription or license to use. -As an open-source, markdown-based platform, surveydown was designed to address these problems. In surveydown, all survey content is created with plain text (markdown and R code) in a single .qmd file that renders into a shiny app. This makes your survey easy to reproduce, share, and version control with common tools like Git. The resulting shiny app for each survey can be hosted on a number of platforms, like [shinyapps.io](https://shinyapps.io/) or [huggingface](https://huggingface.co/), and the survey data collected is owned by the survey designer in a supabase account. Best of all, everything is open source and free :) +The surveydown package was designed to address these problems. As an open-source, markdown-based platform, all survey content is defined with plain text (markdown and R code) in a `survey.qmd` file and an `app.R` file that renders your survey into a Shiny app that can be hosted online. This makes your survey easy to reproduce, share, and version control with common tools like Git. The survey data collected is also owned by the survey designer in a separate Postgres database (we recommend Supabase as a free and open-source database provider). -If you're curious where this whole idea came from, check out this [blog post](https://www.jhelvy.com/blog/2023-04-06-markdown-surveys/), which outlines more on the general idea and the motivation for it. The post is now outdated in terms of the overall design, but it provides something of an origin story and some of the motivation for developing this project. +If you're curious where this whole idea came from, check out this [blog post](https://www.jhelvy.com/blog/2023-04-06-markdown-surveys/), which outlines more on the general idea and the motivation for it. The post is now outdated in terms of the overall package design, but it provides something of an origin story and some of the motivation for developing this project. # TODO List -This is a running list of things we're working on adding to the project: +This is a running list of things we're working on / have already added to the project: - [x] show_if (conditionally display question) - [x] skip_if (conditionally skip to page) - [x] Set defaults for questions to not have any choices selected on launch. - [x] Ability to embed markdown inside choice options (like mc buttons in formr) -- [x] Option for `preview = TRUE` (database is ignored) -- [x] Export timestamps on each page in the data -- [x] Export timestamps on each question interaction (since this will increase the data size considerably, maybe add this as `question_times = FALSE` argument) +- [x] Option for `ignore = TRUE` setting (database connection is ignored) +- [x] Automatically include timestamps on each page and question interaction in the data - [x] Option to start at a designated page, e.g. `start_page = 'page_name'` -- [x] A `show_all = TRUE` argument to show all the pages and hidden questions when launched (e.g. to be able to print out the entire survey text). Could also be called `print_mode = TRUE`. -- [x] Set up SCSS to be compatible with Quarto-supported bootstrap themes -- [x] Add an optional progress bar +- [ ] A `show_all_pages = TRUE` argument to show all the pages and hidden questions when launched (e.g. to be able to print out the entire survey text). Could also be a `sd_print_survey()` function to print it to pdf. +- [x] Set up SCSS to be compatible with Quarto-supported bootstrap themes. +- [x] Include an optional progress bar. - [x] Include input checks for `skip_if` and `show_if` (`question_id` exists, and data frame names are correct) -- [x] Required questions (`required = TRUE`): post a popup if a question is required before allowing next button. Default should be `required = FALSE`. +- [x] Required questions: post a popup if a question is required before allowing next button. - [x] Add a `sd_get_data()` function so the survey designer can obtain the current survey results from inside the app: https://shinysurveys.jdtrat.com/articles/get-survey-data.html -- [x] Admin page w/password to preview / download data (see https://github.com/daattali/shinyforms) +- [ ] Admin page w/password to preview / download data (see https://github.com/daattali/shinyforms) - [x] Ability to pass url parameters, e.g. for tracking users. - [x] Ability to redirect users to another url. - [ ] Form validation: Make sure the user inputs the correct type depending on the question type. (see https://shiny.posit.co/r/reference/shiny/0.14/validate.html) diff --git a/README.md b/README.md index bcb84985..aa4a7ee3 100644 --- a/README.md +++ b/README.md @@ -3,17 +3,13 @@ # surveydown surveydown package logo: a hex shape with a large letter S and a down arrow -### Visit our main site [surveydown.org](https://surveydown.org) for more information! +> Note: This site only documents the {surveydown} R package - visit our +> main site at [surveydown.org](https://surveydown.org) for more +> information! -> Note: This is still an early-stage project. Use with caution, and -> please give us feedback! - -This package helps you create markdown-based surveys with [Quarto Shiny -Documents](https://quarto.org/docs/dashboards/interactivity/shiny-r.html). -It brings together three open source technologies -([Quarto](https://quarto.org/), [shiny](https://shiny.posit.co/), and -[supabase](https://supabase.com/)) to create dynamic, markdown-based -surveys. Here’s the basic concept: +**surveydown** is a flexible, open-source platform for making surveys +with [R](https://www.r-project.org/), [Quarto](https://quarto.org/), +[Shiny](https://shiny.posit.co/), and [Supabase](https://supabase.com/).
@@ -22,17 +18,17 @@ surveys. Here’s the basic concept:
-1. Design your survey as a [Quarto shiny - document](https://quarto.org/docs/dashboards/interactivity/shiny-r.html) - using markdown and R code. -2. Render your doc into a [shiny](https://shiny.posit.co/) app that can - be hosted online and sent to respondents. -3. Store your survey responses in a [supabase](https://supabase.com/) - database. +The basic concept is: + +1. Design your survey as a [Quarto](https://quarto.org/) document using + markdown and R code. +2. Convert your survey into a [Shiny](https://shiny.posit.co/) app that + can be hosted online and sent to respondents. +3. Store your survey responses in a [Supabase](https://supabase.com/) + database (or any Postgres database). -The {surveydown} R package works in tandem with our [surveydown Quarto -extension](https://github.com/surveydown-dev/surveydown-ext) to make -everything work. +The {surveydown} R package provides functions to bring this all +together. **See the [documentation](https://surveydown.org) to get started making your own surveydown survey!** @@ -41,29 +37,30 @@ your own surveydown survey!** Most survey platforms (e.g., Google forms, Qualtrics, etc.) use drag-and-drop interfaces to design surveys, making version control and -collaboration with others difficult. They’re also not reproducible. - -As an open-source, markdown-based platform, surveydown was designed to -address these problems. In surveydown, all survey content is created -with plain text (markdown and R code) in a single .qmd file that renders -into a shiny app. This makes your survey easy to reproduce, share, and -version control with common tools like Git. The resulting shiny app for -each survey can be hosted on a number of platforms, like -[shinyapps.io](https://shinyapps.io/) or -[huggingface](https://huggingface.co/), and the survey data collected is -owned by the survey designer in a supabase account. Best of all, -everything is open source and free :) +collaboration with others difficult. They’re also not reproducible +(others cannot easily reproduce a survey made on these platforms), and +many require a paid subscription or license to use. + +The surveydown package was designed to address these problems. As an +open-source, markdown-based platform, all survey content is defined with +plain text (markdown and R code) in a `survey.qmd` file and an `app.R` +file that renders your survey into a Shiny app that can be hosted +online. This makes your survey easy to reproduce, share, and version +control with common tools like Git. The survey data collected is also +owned by the survey designer in a separate Postgres database (we +recommend Supabase as a free and open-source database provider). If you’re curious where this whole idea came from, check out this [blog post](https://www.jhelvy.com/blog/2023-04-06-markdown-surveys/), which outlines more on the general idea and the motivation for it. The post is -now outdated in terms of the overall design, but it provides something -of an origin story and some of the motivation for developing this -project. +now outdated in terms of the overall package design, but it provides +something of an origin story and some of the motivation for developing +this project. # TODO List -This is a running list of things we’re working on adding to the project: +This is a running list of things we’re working on / have already added +to the project: - [x] show_if (conditionally display question) - [x] skip_if (conditionally skip to page) @@ -71,28 +68,27 @@ This is a running list of things we’re working on adding to the project: launch. - [x] Ability to embed markdown inside choice options (like mc buttons in formr) -- [x] Option for `preview = TRUE` (database is ignored) -- [x] Export timestamps on each page in the data -- [x] Export timestamps on each question interaction (since this will - increase the data size considerably, maybe add this as - `question_times = FALSE` argument) +- [x] Option for `ignore = TRUE` setting (database connection is + ignored) +- [x] Automatically include timestamps on each page and question + interaction in the data - [x] Option to start at a designated page, e.g. `start_page = 'page_name'` -- [x] A `show_all = TRUE` argument to show all the pages and hidden - questions when launched (e.g. to be able to print out the entire - survey text). Could also be called `print_mode = TRUE`. +- [ ] A `show_all_pages = TRUE` argument to show all the pages and + hidden questions when launched (e.g. to be able to print out the + entire survey text). Could also be a `sd_print_survey()` function to + print it to pdf. - [x] Set up SCSS to be compatible with Quarto-supported bootstrap - themes -- [x] Add an optional progress bar + themes. +- [x] Include an optional progress bar. - [x] Include input checks for `skip_if` and `show_if` (`question_id` exists, and data frame names are correct) -- [x] Required questions (`required = TRUE`): post a popup if a question - is required before allowing next button. Default should be - `required = FALSE`. +- [x] Required questions: post a popup if a question is required before + allowing next button. - [x] Add a `sd_get_data()` function so the survey designer can obtain the current survey results from inside the app: -- [x] Admin page w/password to preview / download data (see +- [ ] Admin page w/password to preview / download data (see ) - [x] Ability to pass url parameters, e.g. for tracking users. - [x] Ability to redirect users to another url. diff --git a/inst/css/surveydown.css b/inst/css/surveydown.css index 7af8cf26..f41ae6d5 100644 --- a/inst/css/surveydown.css +++ b/inst/css/surveydown.css @@ -1,66 +1,199 @@ -/* Progressbar */ +/* Import Raleway font */ +@import url('https://fonts.googleapis.com/css2?family=Raleway:ital,wght@0,400;0,800;1,400;1,800&display=swap'); + +/* Root variables */ +:root { + /* Layout and theme variables */ + --theme-color: var(--bs-primary, #2780E3); + --body-background-color: #f2f6f9; + --progressbar-position: top; + --progress-bar-height: 10px; + --progress-color: color-mix(in srgb, var(--theme-color) 80%, transparent); +} + +/* Body */ +body { + background-color: var(--body-background-color); +} + +/* Typography */ +h1, h2, h3, h4, h5, h6, +.h1, .h2, .h3, .h4, .h5, .h6 { + margin-top: 0.5rem !important; + margin-bottom: 0.5rem !important; +} + +p, .form-group, .control-label { + margin-bottom: 0.5rem; +} + +/* Unbolding question labels */ +.control-label, .radio label, .checkbox label { + font-weight: normal; + font-size: 1.1em; +} + +/* Layout */ +.container-fluid .content { + max-width: 800px; + margin: 0 auto !important; + padding: 0 0 5px !important; +} + +/* Button styling */ +.radio-inline, +.checkbox-inline, +.radio label, +.checkbox label { + padding-bottom: 0.25rem; +} + +/* Button group styling */ +.radio-group-buttons, +.checkbox-group-buttons, +.btn-group-container-sw { + display: inline-flex; + overflow: hidden; + border-radius: 4px; +} + +.radio-group-buttons .btn, +.checkbox-group-buttons .btn, +.btn-group-container-sw .btn { + border: 1px solid var(--theme-color); + background-color: color-mix(in srgb, var(--theme-color) 10%, white); + color: var(--theme-color); + transition: all 0.3s ease; + margin-right: -1px; + position: relative; +} + +.radio-group-buttons .btn:hover, +.checkbox-group-buttons .btn:hover, +.btn-group-container-sw .btn:hover { + z-index: 1; + background-color: color-mix(in srgb, var(--theme-color) 20%, white); +} + +.radio-group-buttons .btn:first-child, +.checkbox-group-buttons .btn:first-child, +.btn-group-container-sw .btn:first-child { + border-top-left-radius: 4px; + border-bottom-left-radius: 4px; +} + +.radio-group-buttons .btn:last-child, +.checkbox-group-buttons .btn:last-child, +.btn-group-container-sw .btn:last-child { + border-top-right-radius: 4px; + border-bottom-right-radius: 4px; + margin-right: 0; +} + +.radio-group-buttons .btn.active, +.checkbox-group-buttons .btn.active, +.btn-group-container-sw .btn.active { + background-color: color-mix(in srgb, var(--theme-color) 80%, white); + color: white; + z-index: 2; +} + +/* Date range styling*/ +.shiny-date-range-input .input-group-addon { + background: none; + border: none; + padding: 0 10px 0 5px; +} + +/* Progress bar */ #progressbar { - background-color: #ECE8DF; - padding: 3px; - width: 100%; position: fixed; left: 0; + right: 0; + height: var(--progress-bar-height); z-index: 1000; + background-color: #ECE8DF; +} + +#progressbar.top { + top: 0; } -#progressbar.POSITION_PLACEHOLDER { - POSITION_PLACEHOLDER: 0; + +#progressbar.bottom { + bottom: 0; } + #progressbar > div { width: 0%; - height: 10px; - border-radius: 0; + height: 100%; + background-color: var(--progress-color); + transition: width 0.4s ease; } -/* Top padding */ -body { - padding-top: 20px; +/* Form elements */ +.form-group { + border: 1px solid #ddd; + border-radius: 5px; + padding: 1rem; + background-color: #f9f9f9; } -/* Question border */ -.form-group { - border: 1px solid #ddd; /* Light gray border */ - border-radius: 5px; /* Rounded corners */ - padding: 1rem; /* Inner spacing */ - background-color: #f9f9f9; /* Light background */ +.form-control:focus { + border-color: var(--theme-color); + box-shadow: 0 0 0 0.2rem color-mix(in srgb, var(--theme-color) 25%, transparent); } + .question-container { - margin-bottom: 1rem; /* Space between questions */ + margin-bottom: 1rem; } -/* Bottom margin of texts */ -p, h1, h2, h3, h4, h5, h6, .form-group, .control-label { - margin-bottom: 0.5rem; -} -/* Margin of question label */ .form-group > label.control-label { - margin-top: 0rem; + margin-top: 0; margin-bottom: 0.3rem; } -p:last-child, .form-group:last-child { - margin-bottom: 0rem; -} - -/* Margin of question options */ -.radio { - margin-top: 0.25rem; - margin-bottom: 0.25rem; -} - -/* Center-align radio and checkbox button groups */ +/* Common styles for all button groups */ .radio-group-buttons, -.checkbox-group-buttons { - display: flex; - justify-content: center; - flex-wrap: wrap; -} +.checkbox-group-buttons, .btn-group-container-sw { display: flex; justify-content: center; flex-wrap: wrap; } + +/* Styles for multiple choice buttons (gap: 0.5rem) */ +.checkbox-group-buttons .btn-group-container-sw { + gap: 0.5rem; +} + +/* Page Navigation Buttons */ +.btn-primary, +.btn-primary:hover, +.btn-primary:active, +.btn-primary:focus, +.action-button { + background-color: var(--theme-color); + border-color: var(--theme-color); + color: #ffffff; +} + +.action-button { + background-color: color-mix(in srgb, var(--theme-color) 70%, transparent); + transition: background-color 0.3s ease; +} + +.action-button:hover, +.action-button:focus { + background-color: var(--theme-color); +} + +/* Link styling */ +a:hover { + color: color-mix(in srgb, var(--theme-color) 80%, black); +} + +/* Utility classes */ +p:last-child, +.form-group:last-child { + margin-bottom: 0; +} diff --git a/inst/js/page_nav.js b/inst/js/page_nav.js deleted file mode 100644 index 2331f41c..00000000 --- a/inst/js/page_nav.js +++ /dev/null @@ -1,21 +0,0 @@ -// Define a global function to hide all pages -window.hideAllPages = function() { - var pages = document.querySelectorAll("div[class*='sd-page'], section[class*='sd-page']"); - pages.forEach(function(page) { - page.style.display = 'none'; - }); -}; - -window.showFirstPage = function() { - var firstPage = document.querySelector("div[class*='sd-page'], section[class*='sd-page']"); - if (firstPage) { - firstPage.style.display = 'block'; - } -}; - -// Call the functions on initial load to hide all pages except the first -document.addEventListener("DOMContentLoaded", function() { - window.hideAllPages(); - window.showFirstPage(); -}); - diff --git a/inst/js/required_questions.js b/inst/js/required_questions.js deleted file mode 100644 index 9b8b5702..00000000 --- a/inst/js/required_questions.js +++ /dev/null @@ -1,63 +0,0 @@ -window.initializeRequiredQuestions = function(requiredQuestions) { - console.log("initializeRequiredQuestions called with:", requiredQuestions); - if (!Array.isArray(requiredQuestions) || requiredQuestions.length === 0) { - console.warn("No required questions provided or invalid input"); - return; - } - - function showAsterisk(id) { - var container = document.querySelector(`[data-question-id="${id}"]`) || - document.getElementById(`container-${id}`) || - document.querySelector(`.question-container[id$="-${id}"]`); - - if (!container) { - console.warn(`Container not found for question ID: ${id}`); - return; - } - - var asterisk = container.querySelector('.required-asterisk') || - container.querySelector('span[style*="display:none"]'); - - if (!asterisk) { - console.warn(`Asterisk not found for question ID: ${id}`); - return; - } - - asterisk.style.display = 'inline'; - console.log(`Asterisk display set to inline for question: ${id}`); - } - - // Initial check for all required questions - requiredQuestions.forEach(showAsterisk); - - // Set up a MutationObserver to watch for changes - var observer = new MutationObserver(function(mutations) { - mutations.forEach(function(mutation) { - if (mutation.type === 'childList') { - requiredQuestions.forEach(showAsterisk); - } - }); - }); - - // Start observing the document with the configured parameters - observer.observe(document.body, { childList: true, subtree: true }); -}; - -document.addEventListener('DOMContentLoaded', function() { - console.log("DOM fully loaded and parsed"); -}); - -// Function to check if Shiny is initialized -function checkShinyReady(callback) { - if (window.Shiny && window.Shiny.shinyapp && window.Shiny.shinyapp.isConnected()) { - callback(); - } else { - setTimeout(function() { checkShinyReady(callback); }, 100); - } -} - -checkShinyReady(function() { - console.log("Shiny is ready"); -}); - -console.log("required_questions.js loaded"); diff --git a/inst/quarto/filters/sd_main.lua b/inst/quarto/filters/sd_main.lua deleted file mode 100644 index 0cca7c19..00000000 --- a/inst/quarto/filters/sd_main.lua +++ /dev/null @@ -1,151 +0,0 @@ --- Function to get the path of a file in an R package -local function get_package_file_path(package_name, file_name, subdirectory) - local cmd = string.format( - "Rscript -e \"cat(system.file('%s', '%s', package = '%s'))\"", - subdirectory or "", file_name, package_name - ) - - local handle = io.popen(cmd) - if handle then - local result = handle:read("*a") - handle:close() - return (result or ""):gsub("%s+$", "") - else - return "" - end -end - -local function ensure_html_deps() - local package_name = "surveydown" - - local surveydown_css_path = get_package_file_path(package_name, "surveydown.css", "css") - local page_nav_js_path = get_package_file_path(package_name, "page_nav.js", "js") - local keep_alive_js_path = get_package_file_path(package_name, "keep_alive.js", "js") - local update_progress_js_path = get_package_file_path(package_name, "update_progress.js", "js") - local required_questions_js_path = get_package_file_path(package_name, "required_questions.js", "js") - - quarto.doc.add_html_dependency({ - name = 'surveydowncss', - stylesheets = {surveydown_css_path} - }) - quarto.doc.add_html_dependency({ - name = 'pagenavjs', - scripts = {page_nav_js_path} - }) - quarto.doc.add_html_dependency({ - name = 'keepalivejs', - scripts = {keep_alive_js_path} - }) - quarto.doc.add_html_dependency({ - name = 'updateprogressjs', - scripts = {update_progress_js_path} - }) - quarto.doc.add_html_dependency({ - name = 'requiredquestionsjs', - scripts = {required_questions_js_path} - }) -end - -local function process_document(doc) - ensure_html_deps() - -- Define Bootswatch theme primary colors - local theme_colors = { - cerulean = "#2FA4E7", - cosmo = "#2780E3", - cyborg = "#2A9FD6", - darkly = "#375A7F", - flatly = "#18BC9C", - journal = "#EB6864", - litera = "#007BFF", - lumen = "#F08D49", - lux = "#343A40", - materia = "#2196F3", - minty = "#78C2AD", - morph = "#218C74", - paper = "#2196F3", - pulse = "#593196", - quartz = "#8C9EFF", - readable = "#3273DC", - sandstone = "#93C54B", - simplex = "#D9230F", - sketchy = "#333333", - slate = "#007AFF", - spacelab = "#3398DC", - superhero = "#DF691A", - united = "#E95420", - vapor = "#9B59B6", - yeti = "#008CBA" - } - -- Fetch metadata values with defaults - local barcolor = pandoc.utils.stringify(doc.meta['barcolor'] or 'theme') - local barposition = pandoc.utils.stringify(doc.meta['barposition'] or 'top') - local theme = pandoc.utils.stringify(doc.meta['theme'] and doc.meta['theme'][1] or 'raleway') - local backgroundcolor = pandoc.utils.stringify(doc.meta['backgroundcolor'] or '#f2f6f9') - -- Function to check if a string is a valid hex color - local function is_hex_color(color) - return color:match("^#%x%x%x%x%x%x$") ~= nil - end - -- Determine the color - local color - if is_hex_color(barcolor) then - color = barcolor - else - color = barcolor == 'theme' and theme_colors[theme] or theme_colors['cosmo'] - end - -- Ensure valid position - local position = barposition == 'bottom' and 'bottom' or (barposition == 'none' and 'none' or 'top') - -- Replace placeholders in CSS template - local css = [[ - - ]] - -- Define the HTML for the progress bar - local progressbar = "" - if position ~= "none" then - progressbar = string.format([[ -
-
-
- ]], position, color) - end - -- Define CSS for Raleway font and link to Google Fonts - local raleway_html = [[ - - - ]] - -- Insert the CSS and progress bar HTML into the document - table.insert(doc.blocks, 1, pandoc.RawBlock('html', css)) - if position ~= "none" then - table.insert(doc.blocks, 2, pandoc.RawBlock('html', progressbar)) - end - -- Insert Raleway CSS if no theme is specified or if theme is 'raleway' - if theme == 'raleway' then - table.insert(doc.blocks, 3, pandoc.RawBlock('html', raleway_html)) - end - return doc -end - --- The main Pandoc function that will be called by the wrapper -local function Pandoc(doc) - return process_document(doc) -end - --- Return a table with all the functions we want to expose -return { - Pandoc = Pandoc, - ensure_html_deps = ensure_html_deps, - get_package_file_path = get_package_file_path -} diff --git a/inst/templates/multi/global.R b/inst/templates/multi/global.R new file mode 100644 index 00000000..629bf0d4 --- /dev/null +++ b/inst/templates/multi/global.R @@ -0,0 +1,21 @@ +# remotes::install_github("surveydown-dev/surveydown", force = TRUE) +library(surveydown) + +# Database setup + +# surveydown stores data on a database that you define at https://supabase.com/ +# To connect to a database, update the sd_database() function with details +# from your supabase database. For this demo, we set ignore = TRUE, which will +# ignore the settings and won't attempt to connect to the database. This is +# helpful for local testing if you don't want to record testing data in the +# database table. See the documentation for details: +# https://surveydown.org/store-data + +db <- sd_database( + host = "", + dbname = "", + port = "", + user = "", + table = "", + ignore = TRUE +) diff --git a/inst/templates/multi/server.R b/inst/templates/multi/server.R new file mode 100644 index 00000000..771ea268 --- /dev/null +++ b/inst/templates/multi/server.R @@ -0,0 +1,14 @@ +server <- function(input, output, session) { + + # Define any conditional skip logic here (skip to page if a condition is true) + sd_skip_if() + + # Define any conditional display logic here (show a question if a condition is true) + sd_show_if() + + # Database designation and other settings + sd_server( + db = db + ) + +} diff --git a/inst/templates/multi/survey.Rproj b/inst/templates/multi/survey.Rproj new file mode 100644 index 00000000..e83436a3 --- /dev/null +++ b/inst/templates/multi/survey.Rproj @@ -0,0 +1,16 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +AutoAppendNewline: Yes +StripTrailingWhitespace: Yes diff --git a/inst/templates/multi/survey.qmd b/inst/templates/multi/survey.qmd new file mode 100644 index 00000000..bbb683bb --- /dev/null +++ b/inst/templates/multi/survey.qmd @@ -0,0 +1,67 @@ +--- +echo: false +warning: false +--- + +```{r} +library(surveydown) +``` + +::: {#welcome .sd-page} + +# Welcome to our survey! + +This is a simple demonstration of a surveydown survey. It has two pages with one question on each page. + +Here is a basic "multiple choice" question, created using `type = 'mc'` inside the `sd_question()` function: + +```{r} +sd_question( + type = 'mc', + id = 'penguins', + label = "Which type of penguin do you like the best?", + option = c( + 'Adélie' = 'adelie', + 'Chinstrap' = 'chinstrap', + 'Gentoo' = 'gentoo' + ) +) +``` + +You need to insert next buttons with `sd_next()` and set the `next_page` argument to the name of the page you want to go to next. + +```{r} +sd_next(next_page = 'page2') +``` + +::: + +::: {#page2 .sd-page} + +This is another page in your survey. + +{surveydown} supports many types of questions. For example, here is a simple `text` type question: + +```{r} +sd_question( + type = "text", + id = "silly_word", + label = "Write a silly word here:" +) + +sd_next(next_page = 'end') +``` + +::: + +::: {#end .sd-page} + +## End + +This it the last page in the survey. + +```{r} +sd_close("Exit Survey") +``` + +::: diff --git a/inst/templates/multi/ui.R b/inst/templates/multi/ui.R new file mode 100644 index 00000000..91eb2b4c --- /dev/null +++ b/inst/templates/multi/ui.R @@ -0,0 +1,3 @@ +ui <- sd_ui( + # UI settings here... +) diff --git a/inst/templates/single/app.R b/inst/templates/single/app.R new file mode 100644 index 00000000..bd515e9a --- /dev/null +++ b/inst/templates/single/app.R @@ -0,0 +1,41 @@ +# remotes::install_github("surveydown-dev/surveydown", force = TRUE) +library(surveydown) + +# Database setup + +# surveydown stores data on a database that you define at https://supabase.com/ +# To connect to a database, update the sd_database() function with details +# from your supabase database. For this demo, we set ignore = TRUE, which will +# ignore the settings and won't attempt to connect to the database. This is +# helpful for local testing if you don't want to record testing data in the +# database table. See the documentation for details: +# https://surveydown.org/store-data + +db <- sd_database( + host = "", + dbname = "", + port = "", + user = "", + table = "", + ignore = TRUE +) + + +# Server setup +server <- function(input, output, session) { + + # Define any conditional skip logic here (skip to page if a condition is true) + sd_skip_if() + + # Define any conditional display logic here (show a question if a condition is true) + sd_show_if() + + # Database designation and other settings + sd_server( + db = db + ) + +} + +# shinyApp() initiates your app - don't change it +shiny::shinyApp(ui = sd_ui(), server = server) diff --git a/inst/templates/single/survey.Rproj b/inst/templates/single/survey.Rproj new file mode 100644 index 00000000..69fafd4b --- /dev/null +++ b/inst/templates/single/survey.Rproj @@ -0,0 +1,22 @@ +Version: 1.0 + +RestoreWorkspace: No +SaveWorkspace: No +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +AutoAppendNewline: Yes +StripTrailingWhitespace: Yes +LineEndingConversion: Posix + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace diff --git a/inst/templates/single/survey.qmd b/inst/templates/single/survey.qmd new file mode 100644 index 00000000..bbb683bb --- /dev/null +++ b/inst/templates/single/survey.qmd @@ -0,0 +1,67 @@ +--- +echo: false +warning: false +--- + +```{r} +library(surveydown) +``` + +::: {#welcome .sd-page} + +# Welcome to our survey! + +This is a simple demonstration of a surveydown survey. It has two pages with one question on each page. + +Here is a basic "multiple choice" question, created using `type = 'mc'` inside the `sd_question()` function: + +```{r} +sd_question( + type = 'mc', + id = 'penguins', + label = "Which type of penguin do you like the best?", + option = c( + 'Adélie' = 'adelie', + 'Chinstrap' = 'chinstrap', + 'Gentoo' = 'gentoo' + ) +) +``` + +You need to insert next buttons with `sd_next()` and set the `next_page` argument to the name of the page you want to go to next. + +```{r} +sd_next(next_page = 'page2') +``` + +::: + +::: {#page2 .sd-page} + +This is another page in your survey. + +{surveydown} supports many types of questions. For example, here is a simple `text` type question: + +```{r} +sd_question( + type = "text", + id = "silly_word", + label = "Write a silly word here:" +) + +sd_next(next_page = 'end') +``` + +::: + +::: {#end .sd-page} + +## End + +This it the last page in the survey. + +```{r} +sd_close("Exit Survey") +``` + +::: diff --git a/man/sd_check_versions.Rd b/man/sd_check_versions.Rd deleted file mode 100644 index 804cc372..00000000 --- a/man/sd_check_versions.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/version.R -\name{sd_check_versions} -\alias{sd_check_versions} -\title{Check Surveydown Versions} -\usage{ -sd_check_versions() -} -\value{ -No return value, called for side effects (prints version information -and update status to the console). -} -\description{ -This function checks if the local surveydown R package and Quarto extension -are up-to-date with the latest online version. It compares local versions -with the latest versions available on GitHub and provides information about -whether updates are needed. -} -\examples{ -sd_check_versions() -} diff --git a/man/sd_close.Rd b/man/sd_close.Rd new file mode 100644 index 00000000..b101ae73 --- /dev/null +++ b/man/sd_close.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ui.R +\name{sd_close} +\alias{sd_close} +\title{Create a 'Close' Button to Exit the Survey} +\usage{ +sd_close(label = "Exit Survey") +} +\arguments{ +\item{label}{Character string. The label of the 'Close' button. Defaults to "Exit Survey".} +} +\value{ +A Shiny action button UI element with associated JavaScript for closing the page and Enter key functionality. +} +\description{ +This function creates a 'Close' button that, when clicked, will close the current browser tab or window. +The button can be activated by clicking or by pressing the Enter key. +} +\details{ +The function generates a Shiny action button that, when clicked or when the Enter key is pressed, +will attempt to close the current browser tab or window. Note that for security reasons, +some browsers may not allow JavaScript to close windows that were not opened by JavaScript. +In such cases, the button will prompt the user to close the tab manually. +} +\examples{ +sd_close() +sd_close("Exit Survey") + +} diff --git a/man/sd_config.Rd b/man/sd_config.Rd deleted file mode 100644 index fe8bc64f..00000000 --- a/man/sd_config.Rd +++ /dev/null @@ -1,86 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/config.R -\name{sd_config} -\alias{sd_config} -\title{Configuration Function for surveydown Surveys} -\usage{ -sd_config( - skip_if = NULL, - skip_if_custom = NULL, - show_if = NULL, - show_if_custom = NULL, - required_questions = NULL, - all_questions_required = FALSE, - start_page = NULL, - show_all_pages = FALSE, - admin_page = FALSE -) -} -\arguments{ -\item{skip_if}{A list of conditions under which certain pages should be skipped. Defaults to NULL.} - -\item{skip_if_custom}{A custom function to handle conditions under which certain pages should be skipped. Defaults to NULL.} - -\item{show_if}{A list of conditions under which certain pages should be shown. Defaults to NULL.} - -\item{show_if_custom}{A custom function to handle conditions under which certain pages should be shown. Defaults to NULL.} - -\item{required_questions}{Vector of character strings. The IDs of questions that must -be answered before the respondent can continue in the survey or survey can be -submitted. Defaults to NULL.} - -\item{all_questions_required}{Logical. If TRUE, all questions in the survey will be required. -This overrides the \code{required_questions} parameter. Defaults to FALSE.} - -\item{start_page}{Character string. The ID of the page to start on. Defaults to NULL.} - -\item{show_all_pages}{Logical. Whether to show all pages initially. Defaults to FALSE.} - -\item{admin_page}{Logical. Whether to include an admin page for viewing and downloading survey data. Defaults to FALSE.} -} -\value{ -A list containing the configuration settings for the survey, including: -\item{page_structure}{A list containing the structure of survey pages} -\item{question_structure}{A list containing the structure of survey questions} -\item{page_ids}{A vector of all page IDs} -\item{question_ids}{A vector of all question IDs} -\item{question_values}{A vector of all possible question values} -\item{question_required}{A vector of IDs for required questions} -\item{skip_if_custom}{Custom skip conditions} -\item{skip_if}{Standard skip conditions} -\item{show_if_custom}{Custom show conditions} -\item{show_if}{Standard show conditions} -\item{start_page}{The ID of the starting page} -\item{show_all_pages}{Whether to show all pages initially} -\item{admin_page}{Whether to include an admin page} -} -\description{ -This function sets up the configuration for a surveydown survey, including -page and question structures, conditional display settings, and navigation options. -} -\details{ -The function retrieves the survey metadata, checks for duplicate page and question IDs, -validates the conditional display settings, and ensures that the specified start page (if any) exists. -It then stores these settings in a configuration list. If \code{admin_page} is set to TRUE, an admin page -will be included in the survey. This page allows viewing and downloading of survey data upon entering -the correct survey password (set using \code{sd_set_password()}). - -If \code{all_questions_required} is set to TRUE, it will override the \code{required_questions} parameter -and set all questions in the survey as required. -} -\examples{ -\dontrun{ -# These examples assume you have set up a survey with appropriate .qmd files - -# Basic configuration -config <- sd_config() - -# Configuration with custom settings -config <- sd_config( - start_page = "intro", - all_questions_required = TRUE, - show_all_pages = FALSE, - admin_page = TRUE -) -} -} diff --git a/man/sd_create_survey.Rd b/man/sd_create_survey.Rd index 7df912ee..b7829cc3 100644 --- a/man/sd_create_survey.Rd +++ b/man/sd_create_survey.Rd @@ -1,35 +1,49 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/templates.R +% Please edit documentation in R/util.R \name{sd_create_survey} \alias{sd_create_survey} -\title{Create a Survey Template} +\title{Create a new survey template} \usage{ -sd_create_survey(path = getwd(), template = "simple") +sd_create_survey(path = getwd(), structure = "single") } \arguments{ -\item{path}{A character string specifying the directory in which to create -the survey template. Defaults to the current working directory.} +\item{path}{A character string specifying the directory where the survey template +should be created. Defaults to the current working directory.} -\item{template}{A character string specifying the survey template to use. -Defaults to \code{"simple"}. Currently, only the "simple" template is available.} +\item{structure}{A character string specifying the template structure to use. +Must be either "single" or "multi". Defaults to "single".} } \value{ -Invisibly returns TRUE if the survey template was successfully created. +Invisible NULL. The function is called for its side effects of creating +files and providing user feedback. } \description{ -This function creates a survey template in a specified directory. It can use -different templates, with \code{"simple"} being the default. The function prompts -the user to confirm the use of the current working directory if no path is -specified. +This function creates a new survey template by copying files from the package's +template directory to a specified path. It handles file conflicts and provides +appropriate warnings and feedback. } \details{ -This function downloads the latest version of the surveydown extension from GitHub, -and uses it to create a new survey project. It copies all necessary files and -directories to the specified path, excluding some files like README.md and .gitignore. +The function performs the following steps: +\itemize{ +\item If the specified path is the current working directory, it asks for user confirmation. +\item Validates the specified structure ("single" or "multi"). +\item Creates the target directory if it doesn't exist. +\item Copies all files from the package's template directory (based on the specified structure) to the target path. +\item Preserves the directory structure of the template. +\item Skips existing files and provides warnings for each skipped file. +\item Handles .Rproj files specially, skipping if any .Rproj file already exists in the target directory. +\item Provides feedback on whether files were copied or if all files already existed. +} } \examples{ \dontrun{ +# Create a multi-page survey template in the current working directory sd_create_survey() -sd_create_survey(path = "path/to/survey", template = "simple") + +# Create a single-page survey template in a specific directory +sd_create_survey("path/to/my/survey", structure = "single") + +# Create a multi-page survey template in a specific directory +sd_create_survey("path/to/my/survey", structure = "multi") } } diff --git a/man/sd_deploy.Rd b/man/sd_deploy.Rd new file mode 100644 index 00000000..4b8081f3 --- /dev/null +++ b/man/sd_deploy.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util.R +\name{sd_deploy} +\alias{sd_deploy} +\title{Deploy a Surveydown App} +\usage{ +sd_deploy(name = "survey") +} +\arguments{ +\item{name}{A character string specifying the name of the app. Default is "survey".} +} +\value{ +This function doesn't return a value; it deploys the app to Shiny Server. +} +\description{ +This function is a wrapper for \code{rsconnect::deployApp()} specifically designed +for deploying Surveydown applications. It simplifies the deployment process +by allowing you to specify just the app name. +} +\examples{ +\dontrun{ +# Deploy with default name "survey" +sd_deploy() + +# Deploy with a custom name +sd_deploy("my_custom_survey") +} + +} +\seealso{ +\code{\link[rsconnect]{deployApp}} +} diff --git a/man/sd_display_question.Rd b/man/sd_display_question.Rd index 8fdb3fc3..85a66e18 100644 --- a/man/sd_display_question.Rd +++ b/man/sd_display_question.Rd @@ -13,8 +13,7 @@ sd_display_question(id) A Shiny UI element that serves as a placeholder for the reactive question. } \description{ -This function creates a placeholder div for a reactive survey question in a Surveydown survey. -It's used in conjunction with sd_question to allow for dynamic question rendering. +This function is depreciated - use \code{sd_output()} instead. } \examples{ \dontrun{ diff --git a/man/sd_display_value.Rd b/man/sd_display_value.Rd index ad99783f..bf2960e8 100644 --- a/man/sd_display_value.Rd +++ b/man/sd_display_value.Rd @@ -19,7 +19,7 @@ sd_display_value(id, display_type = "inline", wrapper = NULL, ...) A Shiny UI element displaying the question's value } \description{ -Display the value of a survey question +This function is depreciated - use \code{sd_output()} instead. } \examples{ \dontrun{ diff --git a/man/sd_include_folder.Rd b/man/sd_include_folder.Rd new file mode 100644 index 00000000..e1e56e8b --- /dev/null +++ b/man/sd_include_folder.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util.R +\name{sd_include_folder} +\alias{sd_include_folder} +\title{Include a folder to Shiny's resource path} +\usage{ +sd_include_folder(folder) +} +\arguments{ +\item{folder}{A character string specifying the name of the folder to include. +This folder should exist in the root directory of your Shiny app.} +} +\value{ +\code{NULL} invisibly. The function is called for its side effect of +adding a resource path to Shiny. +} +\description{ +This function includes a specified folder to Shiny's resource path, +making it accessible for serving static files in a Shiny application. +It checks for pre-existing resource paths to avoid conflicts with +folders already included by the package. +} +\examples{ +\dontrun{ +sd_include_folder("custom_images") +} +} diff --git a/man/sd_server.Rd b/man/sd_server.Rd index 3094285d..17859bf8 100644 --- a/man/sd_server.Rd +++ b/man/sd_server.Rd @@ -4,19 +4,31 @@ \alias{sd_server} \title{Server Logic for a surveydown survey} \usage{ -sd_server(input, output, session, config, db = NULL) +sd_server( + db = NULL, + use_html = FALSE, + required_questions = NULL, + all_questions_required = FALSE, + start_page = NULL, + admin_page = FALSE +) } \arguments{ -\item{input}{The Shiny input object.} +\item{db}{A list containing database connection information created using +\code{\link{sd_database}} function. Defaults to \code{NULL}.} -\item{output}{The Shiny output object.} +\item{use_html}{Logical. By default, the \code{"survey.qmd"} file will be +rendered when the app launches, which can be slow. Users can render it +first into a html file and set \code{use_html = TRUE} to use the pre-rendered +file, which is faster when the app loads. Defaults to \code{FALSE}.} -\item{session}{The Shiny session object.} +\item{required_questions}{Vector of character strings. The IDs of questions that must be answered. Defaults to NULL.} -\item{config}{A list containing configuration settings for the application.} +\item{all_questions_required}{Logical. If TRUE, all questions in the survey will be required. Defaults to FALSE.} -\item{db}{A list containing database connection information created using -\code{\link{sd_database}} function. Defaults to \code{NULL}.} +\item{start_page}{Character string. The ID of the page to start on. Defaults to NULL.} + +\item{admin_page}{Logical. Whether to include an admin page for viewing and downloading survey data. Defaults to \code{FALSE}.} } \value{ This function does not return a value; it sets up the server-side logic for the Shiny application. @@ -24,24 +36,9 @@ This function does not return a value; it sets up the server-side logic for the \description{ This function defines the server-side logic for a Shiny application used in surveydown. It handles various operations such as conditional display, progress tracking, -page navigation, database updates for survey responses, and admin functionality. +page navigation, and database updates for survey responses. } \details{ -The \code{config} list should include the following elements: -\itemize{ -\item \code{page_structure}: A list defining the structure of survey pages. -\item \code{page_ids}: A vector of page identifiers. -\item \code{question_ids}: A vector of question identifiers. -\item \code{show_if}: A data frame defining conditions for showing questions. -\item \code{skip_if}: A data frame defining conditions for skipping pages. -\item \code{skip_if_custom}: A list of custom skip conditions. -\item \code{show_if_custom}: A list of custom show conditions. -\item \code{start_page}: The identifier of the starting page. -\item \code{question_required}: A vector of required question identifiers. -\item \code{all_questions_required}: A logical indicating if all questions are required. -\item \code{admin_page}: A logical indicating if an admin page should be included. -} - The function performs the following tasks: \itemize{ \item Initializes variables and reactive values. @@ -64,29 +61,23 @@ of the last answered question's index to the total number of questions. \section{Database Operations}{ If \code{db} is provided, the function will update the database with survey responses. -If \code{db} is \code{NULL} (pause mode), responses will be saved to a local CSV file. +If \code{db} is \code{NULL} (ignore mode), responses will be saved to a local CSV file. } \examples{ \dontrun{ - shinyApp( - ui = sd_ui(), - server = function(input, output, session) { - sd_server(input, output, session, config = my_config, db = my_db) - } - ) + library(surveydown) + db <- sd_database() - # With admin page enabled - my_config <- sd_config(admin_page = TRUE) shinyApp( ui = sd_ui(), server = function(input, output, session) { - sd_server(input, output, session, config = my_config, db = my_db) + sd_server(db = db) } ) } } \seealso{ -\code{\link{sd_database}}, \code{\link{sd_question}} +\code{\link{sd_database}} } diff --git a/man/sd_setup.Rd b/man/sd_setup.Rd index 47450e18..9bdbd870 100644 --- a/man/sd_setup.Rd +++ b/man/sd_setup.Rd @@ -10,7 +10,7 @@ sd_setup() This function does not return a value. It is called for its side effects of setting up the Shiny application. } \description{ -This function is required for any surveydown survey. It sets up a Shiny application with Bootstrap 5 and initializes Shinyjs for JavaScript functionalities. +This function is depreciated and no longer needed. } \details{ The function configures the Shiny application to use Bootstrap 5 for styling and enables @@ -22,10 +22,6 @@ Shinyjs for JavaScript functionalities within the application. sd_setup(), # Your UI elements here ) - server <- function(input, output, session) { - # Your server logic here - } - shinyApp(ui, server) } } diff --git a/man/sd_show_if.Rd b/man/sd_show_if.Rd new file mode 100644 index 00000000..b745ca79 --- /dev/null +++ b/man/sd_show_if.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/server.R +\name{sd_show_if} +\alias{sd_show_if} +\title{Define show conditions for survey questions} +\usage{ +sd_show_if(...) +} +\arguments{ +\item{...}{One or more formulas defining show conditions. +The left-hand side of each formula should be a condition based on input values, +and the right-hand side should be the ID of the question to show if the condition is met.} +} +\value{ +A list of parsed conditions, where each element contains the condition and the target question ID. +Returns NULL if no conditions are provided. +} +\description{ +This function is used to define conditions under which certain questions in the survey should be shown. +It takes one or more formulas where the left-hand side is the condition and the right-hand side is the target question ID. +If called with no arguments, it will return NULL and set no conditions. +} +\examples{ +\dontrun{ +sd_show_if( + input$has_pets == "yes" ~ "pet_details", + input$employment == "employed" ~ "job_questions" +) +} + +} +\seealso{ +\code{\link{sd_skip_if}} +} diff --git a/man/sd_skip_if.Rd b/man/sd_skip_if.Rd new file mode 100644 index 00000000..517aa75b --- /dev/null +++ b/man/sd_skip_if.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/server.R +\name{sd_skip_if} +\alias{sd_skip_if} +\title{Define skip conditions for survey pages} +\usage{ +sd_skip_if(...) +} +\arguments{ +\item{...}{One or more formulas defining skip conditions. +The left-hand side of each formula should be a condition based on input values, +and the right-hand side should be the ID of the page to skip to if the condition is met.} +} +\value{ +A list of parsed conditions, where each element contains the condition and the target page ID. +} +\description{ +This function is used to define conditions under which certain pages in the survey should be skipped. +It takes one or more formulas where the left-hand side is the condition and the right-hand side is the target page ID. +} +\examples{ +\dontrun{ +sd_skip_if( + as.numeric(input$age < 18) ~ "underage_page", + input$country != "USA" ~ "international_page" +) +} +} +\seealso{ +\code{\link{sd_show_if}} +} diff --git a/man/sd_ui.Rd b/man/sd_ui.Rd new file mode 100644 index 00000000..c43bef53 --- /dev/null +++ b/man/sd_ui.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ui.R +\name{sd_ui} +\alias{sd_ui} +\title{Create the UI for a surveydown survey} +\usage{ +sd_ui() +} +\value{ +A Shiny UI object +} +\description{ +This function creates the user interface for a surveydown survey, +including necessary CSS and JavaScript files, and applies custom styling. +It retrieves theme and progress bar settings from the survey.qmd file. +} +\details{ +The function reads the following settings from the survey.qmd YAML header: +\itemize{ +\item \code{theme}: The theme to be applied to the survey. +\item \code{barcolor}: The color of the progress bar (should be a valid hex color). +\item \code{barposition}: The position of the progress bar ('top', 'bottom', or 'none'). +} + +If \code{barcolor} is not specified or is NULL, the default theme color will be used. +If \code{barposition} is not specified, it defaults to 'top'. +} +\examples{ +\dontrun{ +# In your app.R or ui.R file: +ui <- sd_ui() +} +} diff --git a/man/sd_update.Rd b/man/sd_update.Rd new file mode 100644 index 00000000..ca4219b3 --- /dev/null +++ b/man/sd_update.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/version.R +\name{sd_update} +\alias{sd_update} +\title{Update Surveydown Package} +\usage{ +sd_update(force = FALSE) +} +\arguments{ +\item{force}{Logical; if TRUE, forces an update regardless of current version. +Defaults to FALSE.} +} +\value{ +No return value, called for side effects. +} +\description{ +This function checks and updates surveydown. +It ensures that the package is up-to-date. +} +\examples{ +\dontrun{ +sd_update() +sd_update(force = TRUE) +} +} diff --git a/man/sd_update_extension.Rd b/man/sd_update_extension.Rd deleted file mode 100644 index 3e7032ee..00000000 --- a/man/sd_update_extension.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/templates.R -\name{sd_update_extension} -\alias{sd_update_extension} -\title{Update Survey Extension} -\usage{ -sd_update_extension(path = getwd()) -} -\arguments{ -\item{path}{A character string specifying the directory in which to update -or create the extension. Defaults to the current working directory.} -} -\value{ -Invisibly returns TRUE if the extension was successfully updated. -} -\description{ -This function updates or creates the _extensions/surveydown-dev/surveydown folder -with the latest contents from the surveydown-ext repository. -} -\details{ -This function downloads the latest version of the surveydown extension from GitHub, -and updates the local copy in the specified path. If the extension directory -doesn't exist, it will be created. -} -\examples{ -\dontrun{ -sd_update_extension() -sd_update_extension(path = "path/to/survey") -} -} diff --git a/man/sd_update_surveydown.Rd b/man/sd_update_surveydown.Rd deleted file mode 100644 index 8d220f8b..00000000 --- a/man/sd_update_surveydown.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/version.R -\name{sd_update_surveydown} -\alias{sd_update_surveydown} -\title{Update Surveydown Package and Extension} -\usage{ -sd_update_surveydown(force = FALSE) -} -\arguments{ -\item{force}{Logical; if TRUE, forces an update regardless of current versions. -Defaults to FALSE.} -} -\value{ -No return value, called for side effects. -} -\description{ -This function checks and updates both the surveydown R package and its -associated Quarto extension. It ensures that both components are up-to-date -and their versions match. -} -\examples{ -\dontrun{ -sd_update_surveydown() -sd_update_surveydown(force = TRUE) -} -} diff --git a/man/sd_version.Rd b/man/sd_version.Rd new file mode 100644 index 00000000..40782096 --- /dev/null +++ b/man/sd_version.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/version.R +\name{sd_version} +\alias{sd_version} +\title{Check Surveydown Version} +\usage{ +sd_version() +} +\value{ +No return value, called for side effects (prints version information +and update status to the console). +} +\description{ +This function checks if the local surveydown package is up-to-date with +the latest online version. It compares the local version with the latest +version available on GitHub and provides information about whether an update +is needed. +} +\examples{ +sd_version() +} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 96437708..a1476eb6 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -17,35 +17,44 @@ template: alt: "Logo for the surveydown package" reference: -- title: Survey Setup -- subtitle: Functions for setting up and creating surveys +- title: Survey Data contents: - - sd_setup - - sd_create_survey -- title: "Survey Components" - desc: "Functions for defining survey questions, navigation, and storing values" + - sd_database + - sd_get_data + +- title: Control Logic + contents: + - sd_show_if + - sd_skip_if + +- title: Server + contents: + - sd_server + - sd_get_data + - sd_set_password + - sd_store_value + - sd_copy_value + - sd_get_url_pars + +- title: Survey UI contents: - sd_question + - sd_next - sd_output + - sd_close + - sd_redirect - sd_display_question - sd_display_value - - sd_next - - sd_redirect - - sd_store_value - - sd_copy_value -- title: "Configuration and Server" - desc: "Functions for configuring surveys and setting up the server" + - sd_ui + +- title: Utilities contents: - - sd_config - - sd_database - - sd_get_data - - sd_get_url_pars - - sd_redirect - - sd_server - - sd_set_password -- title: "Version Management" - desc: "Functions for managing package and extension versions" + - sd_create_survey + - sd_include_folder + - sd_deploy + - sd_setup + +- title: Version Control contents: - - sd_check_versions - - sd_update_extension - - sd_update_surveydown + - sd_update + - sd_version