R/survey_code.R

In shinysurveys: Create and Deploy Surveys in 'Shiny'

#' Convert dataframe of questions to list for use in Shiny UI
#'
#' @param df A user supplied dataframe in the format of teaching_r_questions.
#'
#'
#' @keywords internal
#'
#' @return A list of unique questions for each UI element
#'
listUniqueQuestions <- function(df) {

  # Replace any NAs in the option column with "Placeholder"
  df[["option"]][is.na(df[["option"]])] <- "Placeholder"

  # separate unique questions partially -- some in nested list
  partial <- lapply(get_questions(df), split_dependence)

  # pull each element so every UI element (dependence/question combo) is in one list
  output <- NULL

  for (question in 1:length(partial)) {
    output <- c(output, pluck_by_index(partial, question))
  }

  return(output)
}

#' Check if a question is required
#'
#' This function is for internal use. It will check if a question in the
#' user-supplied questions dataframe is required. If so, it will add the label
#' with an asterisk. If not, it will just return the label.
#'
#' @param df One element (a dataframe) in the list of unique questions.
#'
#'
#' @keywords internal
#' @return A label with or without an asterisk to signify it is required.
#'
#'
addRequiredUI_internal <- function(df) {

  if (length(base::unique(df$question)) != 1 & base::unique(df$input_type) != "matrix") {
    stop(paste0("The question with input ID '", df$input_id, "' has more than one question in the `question` column. Perhaps there is a spelling error?"))
  }

  if (df$required[1] == TRUE) {
    label <- shiny::tagList(base::unique(df$question), shiny::span("*", class = "required"))
  } else if (df$required[1] == FALSE) {
    label <- base::unique(df$question)
  }
  return(label)
}

#' Generate the UI Code for demographic questions
#'
#' @param df One element (a dataframe) in the list of unique questions.
#'
#' @keywords internal
#' @return UI Code for a Shiny App.
#'
surveyOutput_individual <- function(df) {

  inputType <- base::unique(df$input_type)

  if (length(inputType) != 1) {
    if (!"instructions" %in% inputType) {
      stop("Please double check your data frame and ensure that the input type for all questions is supported.")
    } else if ("instructions" %in% inputType) {
      instructions <- df[which(df$input_type == "instructions"), "question", drop = FALSE]$question
      instructions <- shiny::tagList(
        shiny::div(class = "question-instructions",
                   instructions)
      )

      inputType <- inputType[which(inputType != "instructions")]
      df <- df[which(df$input_type != "instructions"),]
    }
  } else if (length(inputType == 1)) {
    instructions <- NULL
  }

  if (grepl("rank_{{", inputType, perl = T)) {
    stop('Ranking input types have been superseded by the "matrix" input type.')
  }

  survey_env$current_question <- df

  if (inputType ==  "select") {
    output <-
      shiny::selectizeInput(
        inputId = base::unique(df$input_id),
        label = addRequiredUI_internal(df),
        choices = df$option,
        options = list(
          placeholder = '',
          onInitialize = I('function() { this.setValue(""); }')
        )
      )
  } else if (inputType == "numeric") {

    output <-
      numberInput(
        inputId = base::unique(df$input_id),
        label = addRequiredUI_internal(df),
        placeholder = df$option
      )

  } else if (inputType == "mc") {

    output <-
      shiny::radioButtons(
        inputId = base::unique(df$input_id),
        label = addRequiredUI_internal(df),
        selected = base::character(0),
        choices = df$option
      )
  } else if (inputType == "text") {

    output <-
      shiny::textInput(inputId = base::unique(df$input_id),
                       label = addRequiredUI_internal(df),
                       placeholder = df$option)

  } else if (inputType == "y/n") {

    output <-
      shiny::radioButtons(
        inputId = base::unique(df$input_id),
        label = addRequiredUI_internal(df),
        selected = base::character(0),
        choices = df$option
      )

  } else if (inputType == "matrix") {

    required_matrix <- ifelse(all(df$required), TRUE, FALSE)

    output <-
      radioMatrixInput(
        inputId = base::unique(df$input_id),
        responseItems = base::unique(df$question),
        choices = base::unique(df$option),
        selected = NULL,
        .required = required_matrix
      )

  } else if (inputType == "instructions") {

    output <- shiny::div(
      class = "instructions-only",
      df$question
    )

  } else if (inputType %in% survey_env$input_type) {
    output <- eval(survey_env$input_extension[[inputType]])
  } else {
    stop(paste0("Input type '", inputType, "' from the supplied data frame of questions is not recognized by {shinysurveys}.
                Did you mean to register a custom input extension with `extendInputType()`?"))
  }

  if (!base::is.na(df$dependence[1])) {
    output <- shiny::div(class = "questions dependence",
                         id = paste0(df$input_id[1], "-question"),
                         shiny::div(class = "question-input",
                                    instructions,
                                    output))
  } else if (base::is.na(df$dependence[1])) {
    output <- shiny::div(class = "questions",
                         id = paste0(df$input_id[1], "-question"),
                         shiny::div(class = "question-input",
                                    instructions,
                                    output))
  }

  return(output)

}

#' Check survey metadata
#'
#' Returns title/description HTML tags as needed.
#'
#' @param survey_description The survey's description from surveyOutput
#' @param survey_title The survey's title from surveyOutput
#'
#' @keywords internal
#'
#' @return Returns error messages if required paramters are not supplied,
#'   otherwise it returns the appropriate code for survey titles and description
#'   for use in surveyOutput.
#'
check_survey_metadata <- function(survey_description, survey_title) {

  if (!missing(survey_description) && missing(survey_title)) {
    stop("Must provide a survey title in order to provide a survey description.")
  } else if (missing(survey_title) && missing(survey_description)) {
    return()
  } else if (!missing(survey_title) && missing(survey_description)) {

    if (is.null(survey_title)) {
      return()
    } else {
      return(
        shiny::div(class = "title-description",
                   shiny::h1(id = "survey-title", survey_title))
      )
    }


  } else if (!missing(survey_title) && !missing(survey_description)) {

    if (is.null(survey_title) && is.null(survey_description)){
      return()
    } else {
      return(
        shiny::div(class = "title-description",
                   shiny::h1(id = "survey-title", survey_title),
                   shiny::p(id = "survey-description", survey_description))
      )
    }

  }
}

#' Generate the UI Code for demographic questions
#'
#' Create the UI code for a Shiny app based on user-supplied questions.
#'
#' @param df A user supplied data frame in the format of teaching_r_questions.
#' @param survey_title (Optional) user supplied title for the survey
#' @param survey_description (Optional) user supplied description for the survey
#' @param theme A valid R color: predefined such as "red" or "blue"; hex colors
#'   such as #63B8FF (default). To customize the survey's appearance entirely, supply NULL.
#' @param ... Additional arguments to pass into \link[shiny]{actionButton} used to submit survey responses.
#'
#' @return UI Code for a Shiny App.
#' @export
#'
#' @examples
#'
#' if (interactive()) {
#'
#'   library(shiny)
#'   library(shinysurveys)
#'
#'   df <- data.frame(question = "What is your favorite food?",
#'                    option = "Your Answer",
#'                    input_type = "text",
#'                    input_id = "favorite_food",
#'                    dependence = NA,
#'                    dependence_value = NA,
#'                    required = F)
#'
#'   ui <- fluidPage(
#'     surveyOutput(df = df,
#'                  survey_title = "Hello, World!",
#'                  theme = "#63B8FF")
#'   )
#'
#'   server <- function(input, output, session) {
#'     renderSurvey()
#'
#'     observeEvent(input$submit, {
#'       showModal(modalDialog(
#'         title = "Congrats, you completed your first shinysurvey!",
#'         "You can customize what actions happen when a user finishes a survey using input$submit."
#'       ))
#'     })
#'   }
#'
#'   shinyApp(ui, server)
#'
#' }


surveyOutput <- function(df, survey_title, survey_description, theme = "#63B8FF", ...) {

  survey_env$theme <- theme
  survey_env$question_df <- df
  survey_env$unique_questions <- listUniqueQuestions(df)
  if (!missing(survey_title)) {
    survey_env$title <- survey_title
  }
  if (!missing(survey_description)) {
    survey_env$description <- survey_description
  }

  if ("page" %in% names(df)) {
    main_ui <- multipaged_ui(df = df)
  } else if (!"page" %in% names(df)) {
    main_ui <- shiny::tagList(
      check_survey_metadata(survey_title = survey_title,
                            survey_description = survey_description),
      lapply(survey_env$unique_questions, surveyOutput_individual),
      shiny::div(class = "survey-buttons",
                 shiny::actionButton("submit",
                                     "Submit",
                                     ...)
      )
    )
  }

  if (!is.null(survey_env$theme)) {
    survey_style <- sass::sass(list(
      list(color = survey_env$theme),
      readLines(
        system.file("render_survey.scss",
                    package = "shinysurveys")
      )
    ))
  } else if (is.null(survey_env$theme)) {
    survey_style <- NULL
  }


  shiny::tagList(shiny::includeScript(system.file("shinysurveys-js.js",
                                                  package = "shinysurveys")),
                 shiny::includeScript(system.file("save_data.js",
                                                  package = "shinysurveys")),
                 shiny::tags$style(shiny::HTML(survey_style)),
                 shiny::div(class = "survey",
                            shiny::div(style = "display: none !important;",
                                       shiny::textInput(inputId = "userID",
                                                        label = "Enter your username.",
                                                        value = "NO_USER_ID")),
                            main_ui))

}

#' Show dependence questions
#'
#' @param input Input from server
#' @param df One element (a dataframe) in the list of unique questions.
#'
#'
#' @keywords internal
#' @return NA; shows a dependence question in the UI.
#'
showDependence <- function(input = input, df) {

  if(is.na(df$dependence_value[1]) || is.null(input[[df$dependence[1]]])) {
    return()
  }

  # if there is a dependence
  if (!base::is.na(df$dependence[1])) {
    # check that the input of that question's dependence
    # is equal to its dependence value. If so,
    # show the question.
    if (input[[df$dependence[1]]] == df$dependence_value[1]) {
      remove_class(.id = paste0(df$input_id[1], "-question"),
                   .class = "dependence")
      df$required <- TRUE
    } else {
      add_class(.id = paste0(df$input_id[1], "-question"),
                .class = "dependence")
      df$required <- FALSE
    }
  }
}


#' Get required IDs
#'
#' @param df The dataframe of questions
#'
#' @keywords internal
#'
#' @return The input ID for required questions
#'
getID <- function(df) {
  if (df$required[1] == TRUE) {
    base::unique(df$input_id)
  } else {
    return(NA)
  }
}

#' Get a character vector of required questions
#'
#' @param questions The list of unique questions from \code{\link{listUniqueQuestions}}.
#'
#'
#' @keywords internal
#' @return A character vectors with the input ID of required questions.
#'
getRequired_internal <- function(questions) {

  out <- as.data.frame(
    do.call(
      rbind,
      lapply(questions, getID)
    ),
    stringsAsFactors = FALSE
  )

  names(out) <- "required_id"

  out <- out$required_id

  return(out)

}

#' Check if individual inputs have a value
#'
#' @param input Input from server
#' @param input_id The input_id to check
#'
#'
#' @keywords internal
#' @return TRUE if the input has a value; false otherwise.
#'
checkIndividual <- function(input = input, input_id) {
  if (!is.null(input[[input_id]]) && input[[input_id]] != "" && !is.na(input[[input_id]])) {
    TRUE
  } else {
    FALSE
  }
}

#' Check all required questions have been answered
#'
#' @param input Input from server
#' @param required_inputs_vector The output of \code{\link{getRequired_internal}}.
#'
#'
#' @keywords internal
#'
#' @return TRUE if all required questions have been answered. FALSE otherwise.
#'

checkRequired_internal <- function(input = input, required_inputs_vector) {
  if (all(is.na(required_inputs_vector))) {
    return(TRUE)
  } else {
    required_inputs_vector <- required_inputs_vector[!is.na(required_inputs_vector)]
  }

  instructions_id <- survey_env$question_df[which(survey_env$question_df$input_type == "instructions"), "input_id", drop = FALSE]$input_id
  required_inputs_vector <- required_inputs_vector[which(!required_inputs_vector %in% c(input$shinysurveysHiddenInputs, instructions_id))]

  all(vapply(required_inputs_vector, checkIndividual, input = input, FUN.VALUE = logical(1), USE.NAMES = FALSE))
}



#' Server code for adding survey questions
#'
#' Include server-side logic for shinysurveys.
#'
#'
#' @param df **Deprecated** *please only place argument in
#'   \code{\link{surveyOutput}}.* A user supplied data frame in the format of
#'   teaching_r_questions.
#' @param theme **Deprecated** *please place the theme argument in
#'   \code{\link{surveyOutput}}.* A valid R color: predefined such as "red" or
#'   "blue"; hex colors such as #63B8FF (default). To customize the survey's
#'   appearance entirely, supply NULL.
#'
#' @export
#'
#' @return NA; used for server-side logic in Shiny apps.
#'
#' @examples
#'

#' if (interactive()) {
#'
#'   library(shiny)
#'   library(shinysurveys)
#'
#'   df <- data.frame(question = "What is your favorite food?",
#'                    option = "Your Answer",
#'                    input_type = "text",
#'                    input_id = "favorite_food",
#'                    dependence = NA,
#'                    dependence_value = NA,
#'                    required = F)
#'
#'   ui <- fluidPage(
#'     surveyOutput(df = df,
#'                  survey_title = "Hello, World!",
#'                  theme = "#63B8FF")
#'   )
#'
#'   server <- function(input, output, session) {
#'     renderSurvey()
#'
#'     observeEvent(input$submit, {
#'       showModal(modalDialog(
#'         title = "Congrats, you completed your first shinysurvey!",
#'         "You can customize what actions happen when a user finishes a survey using input$submit."
#'       ))
#'     })
#'   }
#'
#'   shinyApp(ui, server)
#'
#' }
#'
renderSurvey <- function(df, theme = "#63B8FF") {

  if (missing(df)) {
    df <- survey_env$question_df
  } else if (!missing(df)) {
    warning("The `df` argument in `renderSurvey()` is deprecated and will be removed in a future version. Please only pass the data frame of questions to `surveyOutput()`.")
  }

  if (missing(theme)) {
    theme <- survey_env$theme
  } else if (!missing(theme)) {
    warning("The `theme` argument in `renderSurvey()` is deprecated and will be removed in a future version. Please only pass the theme color to `surveyOutput()`.")
  }

  session <- shiny::getDefaultReactiveDomain()

  required_vec <- getRequired_internal(survey_env$unique_questions)

  shiny::observe({

    query <- shiny::parseQueryString(session$clientData$url_search)
    if (!base::is.null(query[["user_id"]])) {
      new_value <- base_extract_user_id(query)
      shiny::updateTextInput(session, inputId = "userID", value = new_value)
    }

    # Update the dependencies
    for (id in seq_along(survey_env$unique_questions)) showDependence(input = session$input, df = survey_env$unique_questions[[id]])

    toggle_element(id = "submit",
                   condition = checkRequired_internal(input = session$input,
                                                      required_inputs_vector = required_vec))

  })

  # Clean up non-essential internal environmental variables
  shiny::onStop(function() rm(list = ls(survey_env)[which(!ls(survey_env) %in% c("question_df",
                                                                                 "unique_questions",
                                                                                 "input_type",
                                                                                 "input_extension"))], envir = survey_env))

  shiny::onStop(function() unlink(survey_env$css_file))

}