In lupyanlab/programming-questionnaire: Programming Questionnaire

# free-responses.Rmd is an interactive document. To run it,
# clone this repo, and open this file in RStudio. Then select
# the Run Document command.

library(knitr)
library(shiny)

opts_chunk$set(echo=FALSE, message=FALSE, warning=FALSE,
               fig.width=4, fig.height=4, dpi=144,
               cache=FALSE)

library(tidyverse)
library(magrittr)

library(programmingquestionnaire)
data("questions")
data("questionnaire")
data("languages")
data("language_paradigms")

get_question_text <- function(name) {
  filter(questions, question_name == name)$question_text
}

create_wrapped_title <- function(name, width = 80) {
  get_question_text(name) %>%
    strwrap(width) %>%
    paste(collapse = "\n")
}

# Filter question data ----
filter_question_names <- c(
  "cr1", "cp1",
  "repo1","rec1", "cfo1", "cfo2",
  "env1", "env2", "inter1", "inter2",
  # agreement w/ other questions
  "oss1", "fp3", "fp4", "psych",
  # multiple choice questions
  "fp1", "pipe1", "computer"
)

# Free response data ----
free_response_question_names <- c(
  "cr1describe", "cr2describe", "cp1describe",
  "repo1describe", "rec1describe",
  "fp1describe", "pipe1describe",
  "cfo3describe", "oss1describe", "inter2describe", "fp5describe",
  "pa1example",
  "best",
  "design1", "recursive", "metaphor", "history",
  "design2", "reusable", "challenges", "nontransfer"
)

# Languages ----
known_languages <- unique(language_paradigms$language_name) %>% sort()

checkboxInput(
  inputId = "show_free_response_question_texts_table",
  label = "Show table of free response questions",
  value = 0
)

conditionalPanel(
  'input.show_free_response_question_texts_table == 1',
  renderTable({
    filter(questions, question_name %in% filter_question_names) %>%
      select(question_name, question_text)
  },
    caption = "Question text for all free response questions.",
    caption.placement = "top"
  )
)

# Create checkbox toggle for filtering free responses by
# responses to a multiple choice question.
checkboxInput(
  inputId = "filter_on",
  label = "Filter free responses by responses to a multiple choice question",
  value = 0
)

conditionalPanel(
  'input.filter_on == 1',
  renderUI({
    checkboxInput(
      inputId = "show_filter_question_texts_table",
      label = "Show table of filter questions",
      value = 0
    )
  }),
  conditionalPanel(
    'input.show_filter_question_texts_table == 1',
    renderTable({
      filter_questions <- filter_question_names
      filter(questions, question_name %in% filter_questions) %>%
        select(question_name, question_text)
    },
      caption = "Question text for filter questions.",
      caption.placement = "top"
    )
  ),
  selectInput(
    inputId = "filter_question_name",
    label = "Filter question",
    choices = c("none", filter_question_names),
    selected = 1
  )
)

conditionalPanel(
  'input.filter_on == 1 && input.filter_question_name != "none"',
  renderUI({
    choices <- levels(questionnaire[[input$filter_question_name]])
    checkboxGroupInput(
      inputId = "filter_responses",
      label = "Filter responses",
      choices = choices,
      selected = choices,
      inline = TRUE,
      width = "100%"
    )
  })
)

conditionalPanel(
  'input.filter_on == 1 && input.filter_question_name != "none"',
  renderPlot({
    if(input$filter_question_name == "none") return(NULL)

    selected_data <- questionnaire[, c("subj_id", input$filter_question_name)] %>%
      drop_na()
    colnames(selected_data) <- c("subj_id", "response")

    selected_data$is_filtered <- factor(selected_data$response %in% input$filter_responses, levels = c(F, T))
    ggplot(selected_data) +
      aes(response, y = ..count.., fill = is_filtered) +
      geom_bar(width = 0.9, color = "gray") +
      labs(x = "", y = "count") +
      scale_fill_manual(values = c("white", "gray"), drop = FALSE) +
      ggtitle(create_wrapped_title(input$filter_question_name)) +
      coord_flip()
  })
)

checkboxInput(
  inputId = "language_filter_on",
  label = "Filter free responses by people who know a certain language",
  value = 0
)

conditionalPanel(
  'input.language_filter_on == 1',
  checkboxGroupInput(
    inputId = "filtered_languages",
    label = "Filter languages",
    choices = known_languages,
    selected = NULL,
    width = "100%"
  )
)

selectInput(
  inputId = "question_name", 
  label = "Free response question", 
  choices = free_response_question_names, 
  selected = 1)

h4(renderText({
  get_question_text(input$question_name)
}))

renderTable({
  data("questionnaire")

  if(input$language_filter_on == 1) {
    data("languages")
    subjs <- languages %>%
      filter(language_name %in% input$filtered_languages) %>%
      .$subj_id %>%
      unique()

    questionnaire <- filter(questionnaire, subj_id %in% subjs)
  }

  if(input$filter_question_name != "none") {
    free_responses <- questionnaire[, c("subj_id", input$filter_question_name, input$question_name)] %>%
      drop_na()

    is_filtered <- free_responses[[input$filter_question_name]] %in% input$filter_responses
    free_responses <- free_responses[is_filtered, ] %>%
      arrange_(.dots = input$filter_question_name)
    free_responses <- free_responses[rev(rownames(free_responses)), ]
  } else {
    free_responses <- questionnaire[, c("subj_id", input$question_name)] %>%
      drop_na()
  }
  free_responses
})