demo of a shiny survey

global.R

# global.R

# Static Non-Reactive Area

# Read Survey Questions & Suggested Answers
Q <- read.csv("survey.csv", 'header' = FALSE)
    # column 1 : questions
    # column 2+: several answers
    
# Store Survey Questions & User Answers in a dataframe
A <- rep("", nrow(Q))
names(A)  <- Q[,3]
A[nrow(Q)+1] <- ""
names(A)[nrow(Q)+1] <- "Time"
A[nrow(Q)+2] <- ""
names(A)[nrow(Q)+2] <- "User"
A[nrow(Q)+3] <- ""
names(A)[nrow(Q)+3] <- "Course"
A[nrow(Q)+4] <- ""
names(A)[nrow(Q)+4] <- "Program"
A[nrow(Q)+5] <- ""
names(A)[nrow(Q)+5] <- "Title"
df0 <- data.frame(names(A), stringsAsFactors = FALSE)
names(df0) <- "Survey"

server.R

# server.R

library("shiny")

shinyServer(
  function(input, output, session) {
  
    # create directory in which to save data
    if (!file.exists("data/")) {
      dir.create("data/")
    }

    # reactiveValues holds the counter - i - and User Answers - A - 
    values <- reactiveValues(i = 0, A = A)
  
    # The observers re-run the code whenever the button is clicked
    # Use isolate to avoid getting stuck in an infinite loop
    observe({ 
      if(is.null(input$increment) || input$increment == 0){return()} 
      values$i <- isolate(values$i) + 1
    }) 
    
    observe({ 
      if(is.null(input$decrement) || input$decrement == 0){return()} 
      values$i <- isolate(values$i) - 1 
    }) 
    
    # User Info Area
    userInfo <- renderUI({
      list(
        textInput("userName", "Enter your random ID:", "ABC123")
        ,
        textInput("programName", "Enter program name:", "LBA")
        ,
        textInput("courseName", "Enter course code:", "LBA201")
        ,
        textInput("courseTitle", "Enter course name:", "Accounting I")
        ,
        br()
      )
    })
    
    # Next Question Button
    nextButton <- renderUI({
      actionButton("increment", "Next")
    })
        
    # Previous Question Button
    backButton <- renderUI({
      actionButton("decrement", "Back")
    })

    # End Survey Button
    submitButton <- renderUI({
      actionButton("submit", HTML("<span style='color:#FF0000;'>Submit!</span>"))
    })
    
    # Save Data Button
    saveButton <- renderUI({
      downloadButton("download", "Save")
    })
    
    # Abort Survey Button
    abortButton <- renderUI({
      HTML("<a class='btn' href='/'>Start Over</a>")
    })
    
    # Display Survey in mainPanel
    output$survey <- renderUI({
      # Start Survey
      if (values$i == 0) { 
        return(list(h4("Ready to start the survey?"),br(),userInfo(),br(),nextButton()))
      } else {
        # End Survey
        if (values$i > nrow(Q)) { #values$i == nrow(Q)+1 is vulnerable to rapid clicks
          # Save Survey
          if ( is.null(input$submit) || input$submit==0 ) {
            return(list(
                list(h4("Ready to submit your answers?"),br())
                ,
                list(backButton(),submitButton(),br(),br())
                ,
                tableOutput("summary")
            ))
          } 
          # Start Over
          return(list(br(),h4("Survey Completed, thanks!"),br(),abortButton()))
        } else { 
        # Main Survey
          return(list(
              h4(textOutput("Question1"))
              , br(),
              h4(textOutput("Question2"))
              , br(),
              radioButtons("survey", "Select an answer:", c(Answers()))
              ,
              list(backButton(),nextButton(),br())
          ))
        }
      } 
    })
    
    # Survey Question Printed
    output$Question1 <- renderText({
        paste0("Q", values$i,":  ", Q[values$i,2])
    })

    # Survey Question Printed
    output$Question2 <- renderText({
        v <- paste0(Q[values$i,3])
        v <- sub("the program", paste0("the ",input$programName," program"), v, fixed = TRUE) 
        v <- sub("this course", paste0("this course (",input$courseName,")"), v, fixed = TRUE) 
        return(v)
    })
    
    # Survey Question Displayed as counter is incremented/decremented
    Answers <- reactive({
      N <- length(Q[values$i,])
      Q <- Q[values$i,4:N]
      as.matrix(Q[Q!=""])
    })
    
    # Save each answers after each click on "next"
    observe({ 
      if(is.null(input$survey)) {return()}
      if (values$i > 0 & values$i < nrow(Q)+1) {
        values$A[values$i] <- input$survey
        # filename <- paste0("data/answers-",input$courseName, "-", input$userName, "-", as.numeric(Sys.time()))
        # write.table(values$A, 'file' = paste0(filename,".csv"), 'sep' = ",", 'col.names' = FALSE)
      }
    })
 
    # Save User Info
    observe({
      if (is.null(input$userName)){return()}
      values$A[nrow(Q)+1] <- as.character(Sys.time())
      values$A[nrow(Q)+2] <- input$userName
      values$A[nrow(Q)+3] <- input$courseName
      values$A[nrow(Q)+4] <- input$programName
      values$A[nrow(Q)+5] <- input$courseTitle
    })
    
    # Save all answers after click on "submit"
    observe({
      if(is.null(input$submit) || input$submit == 0) {return()}
      filename <- "data/results.Rdata"
      if (!file.exists(filename)) {df <- df0} # initialize dataframe
      if (file.exists(filename)) {load(file = filename)}
      isolate({
        df1 <- data.frame(values$A, stringsAsFactors = FALSE)
        names(df1) <- gsub("\\.","",paste0(as.numeric(Sys.time(),LETTERS[sample(1:5)])))
        df <- cbind(df, df1)
        save(df, file = filename, compress = "xz")
      })
    })
    
    # Display User Answers
    output$summary <- renderTable({
        if (values$i < nrow(Q)+1) {return()}
        as.data.frame(values$A[(nrow(Q)+3):1])
      }, 'include.rownames' = TRUE
       , 'include.colnames' = FALSE
       , 'sanitize.text.function' = function(x){x}
    )
         
    # Download Answers
    output$download <- downloadHandler(
      filename = function() {
        paste0("answers-", Sys.Date(), ".csv")
      } , 
      content = function(file) {
        write.table(values$A, file, 'sep' = ",", 'col.names' = FALSE)
      }
    )
        

    # Debug Area 
    
    output$Console <- renderUI({
        btnTags <- function(){tags$style(type = 'text/css',"")}
        if (is.null(input$console) || !nzchar(input$console) || input$console == 0) {
            btnTags <- function(){tags$style(type = 'text/css'
              , '#console {color: rgb(221,17,68);}'
              , '#console.recalculating {color: grey; opacity: 0.2; transition: opacity 250ms ease 500ms;}'
              )}
        }
        list(btnTags(),actionButton(inputId = "console", label = "console"))
    })
    
    observe(label = "console", {
      if (is.null(input$console) || !nzchar(input$console)) {return()}
      if (input$console != 0) {
        options(browserNLdisabled = TRUE)
        saved_console <- ".RDuetConsole"
        if (file.exists(saved_console)) {load(saved_console)}
        isolate(browser())
        save(file = saved_console, list = ls(environment()))
      }
    })
    
    
})

survey.csv

ui.R

# ui.R

library("shiny")

# Define UI for slider demo application
shinyUI(
  pageWithSidebar( 
    headerPanel("LBA Program Survey")
    ,
    sidebarPanel(
    # customize display settings    
      tags$head(
        tags$style(type='text/css'
          , ".span12 h1 {font-size: 21px; line-height:21px;}" # font size in title
          , ".span12 h1 {color: rgb(0,0,150);}" # color in title
          , ".row-fluid .span4 {width: 25%;}" # width of sidebarPanel
          , ".row-fluid .span4 .well {font-size: 10pt;}"
          , ".shiny-bound-input {font-size: 120%;}" # font size in input panel
          , ".shiny-bound-output {font-size: 100%;}" # font size in output panel
          , ".btn {padding: 8px; font-size: 120%;}" # button appearance
          , ".data td, .data th, .data tr {font-family: monospace; text-align: left;}"
          , "table.data td[align=right] {font-family: monospace; text-align: left;}" # row.names appearance
          , ".data tr:nth-child(even){background-color: rgb(245,245,245);}"  # even-numbered rows background
          , ".table {border-spacing: 0px;}" # horizontal line and background color superimposed
          , ".table.data {color: rgb(0,0,150);}" # background color in data table
          , ".table-bordered td, .table-bordered th {border-top: 1px solid rgb(245,245,245);}" # horizontal lines
          , ".table-bordered {border-width: 0px;}" # suppress border around whole table
          , ".table-bordered td, .table-bordered th {border-left: none;}" # suppress vertical lines
        )
      )
      ,
      helpText("Webmaster:"
        , a("patrick.toche@usj.edu.mo"
          , href="mailto:patrick.toche@usj.edu.mo?Subject=LBA Survey"
          , target="_top"
        )
      )
      ,
      helpText("Shiny App written by Patrick Toche © 2014.")
      ,
      helpText("This app is intended for use by instructors of the LBA (Licentiate in Business Administration) of the Faculty of Business, Government, and Social Work at the University of Saint Joseph in Macau.  The app is written in the open source R language and relies on the shiny package designed by RStudio.")
      ,
      tags$hr()
      ,
      helpText("This app is presently hosted on the shiny beta server. Thanks to the RStudio team for making this app and the server available free of charge. ")
      , 
      tags$hr()
      ,
      uiOutput("Console")
    )
    ,
    mainPanel(
      uiOutput("survey")
    )
  )
)

This app keeps breaking. One minute it's working, another it's broken. Sometimes the stable version of shiny works, sometimes the dev version is needed. I must be doing something wrong.

Hi Patrick. I wonder whether you could figure out what might be wrong? I am new to shiny R but extremely interested in your survey approach (comes pretty close to what I want to do). However, I get the same error massage. I can run the app if I change the code for the buttons in the server file to:

e.g.
nextButton <- actionButton("increment", "Next")
output$survey <- renderUI({list(h4("text"), br(), nextButton, br())})

Hence, there seems to be a problem with using rederUI for the buttons.. but I have no idea why!
Any other solutions or thoughts?
Cheers,
Simeon