ShinyAssessmentTest

2013-08-B.txt

		From San Francisco to New York to Paris, city governments, high-class restaurants,
	schools, and religious groups are ditching bottled water in favor of what comes out of the
	faucet. With people no longer content to pay 1,000 times as much for bottled water, a
	product no better than water from the tap, a backlash against bottled water is growing.
(5)		The U.S. Conference of Mayors, which represents some 1,100 American cities,
	discussed at its June 2007 meeting the irony of purchasing bottled water for city employees
	and for city functions while at the same time touting1 the quality of municipal water. The
	group passed a resolution sponsored by Mayors Gavin Newsom of San Francisco, Rocky
	Anderson of Salt Lake City, and R. T. Rybak of Minneapolis that called for the examination
(10)	of bottled water’s environmental impact. The resolution noted that with $43 billion a year
	going to provide clean drinking water in cities across the country, the United States
	municipal water systems are among the finest in the world.
		Tap water promotional campaigns would have seemed quaint a few decades ago, when
	water in bottles was a rarity. Now such endeavors are needed to counteract the pervasive2
(15)	marketing that has caused consumers to lose faith in the faucet. In fact, more than a quarter
	of bottled water is just processed tap water, including top-selling Aquafina and Coca-Cola’s
	Dasani. When Pepsi announced in July [2007] that it would clearly label its Aquafina water
	as from a “public water source,” it no doubt shocked everyone who believed that
	bottles with labels depicting pristine mountains or glaciers delivered a superior product. ...
(20)		With sales growing by 10 percent each year, far faster than any other beverage, bottled
	water now appears to be the drink of choice for many Americans they swallow more of it
	than milk, juice, beer, coffee, or tea. While some industry analysts are counting on bottled
	water to beat out carbonated soft drinks to top the charts in the near future, the
	burgeoning3 back-to-the-tap movement may reverse the trend.
(25)		In contrast to tap water, which is delivered through an energy-efficient infrastructure,
	bottled water is an incredibly wasteful product. It is usually packaged in single-serving
	plastic bottles made with fossil fuels. Just manufacturing the 29 billion plastic bottles used
	for water in the United States each year requires the equivalent of more than 17 million
	barrels of crude oil.
(30)		After being filled, the bottles may travel far. Nearly one quarter of bottled water
	crosses national borders before reaching consumers, and part of the cachet4 of certain
	bottled water brands is their remote origin. Adding in the Pacific Institute’s estimates for
	the energy used for pumping and processing, transportation, and refrigeration, brings the
	annual fossil fuel footprint of bottled water consumption in the United States to over 50
(35)	million barrels of oil equivalent enough to run 3 million cars for one year. If everyone
	drank as much bottled water as Americans do, the world would need the equivalent of more
	than 1 billion barrels of oil to produce close to 650 billion individual bottles. ...
		Slowing sales may be the wave of the future as the bottle boycott movement picks up
	speed. With more than 1 billion people around the globe still lacking access to a safe and
(40)	reliable source of water, the $100 billion the world spends on bottled water every year could
	certainly be put to better use creating and maintaining safe public water infrastructure
	everywhere.

Janet Larsen
excerpted from “Bottled Water Boycotts: Back-to-the-Tap
Movement Gains Momentum”
www.earthpolicy.org, December 7, 2007

1 touting - praising or publicizing loudly or extravagantly
2 pervasive - tends to become diffused throughout every part
3 burgeoning - growing rapidly
4 cachet - influential status

app.R

library(shiny)
library(ggplot2)

source('ShinyAssessment.R')

# Math items from: http://stattrek.com/ap-statistics/practice-test.aspx
math.items <- read.csv('items.csv', stringsAsFactors=FALSE)
mass.items <- read.csv('mass.csv', stringsAsFactors=FALSE)
read.items <- read.csv('ReadingItems.csv', stringsAsFactors=FALSE)

read.stems <- list()
read.stems[[1]] <- div(
			div(includeText('2013-08-B.txt'), style="white-space: pre; word-wrap: normal; 
                       overflow-x: auto; font-size: 11pt; padding: 10px; background: #fffff8;
					   border-style: solid; border-size:1px; border-color: #111111"),
			p(read.items[1,]$Stem))
for(i in 2:nrow(read.items)) {
	read.stems[[i]] <- p(read.items[i,]$Stem)
}

##### User Interface ###########################################################
ui <- shinyUI(fluidPage(
	uiOutput('ui')
))

##### Server ###################################################################
server <- shinyServer(function(input, output, session) {
	# Save the most recent assessment results to display
	assmt.results <- reactiveValues(
		math = logical(),
		mass = integer(),
		reading = logical()
	)
	
	# This function will be called when the assessment is completed.
	saveResults <- function(results) {
		assmt.results$math <- results == math.items$Answer
	}
	
	saveMASSResults <- function(results) {
		assmt.results$mass <- factor(results,
									 levels = names(mass.items)[2:6],
									 ordered = TRUE)
	}
	
	saveReadingResults <- function(results) {
		assmt.results$reading <- results == read.items$Answer
	}
	
	# Provide some basic feedback to students
	output$math.results <- renderText({
		txt <- ''
		if(length(assmt.results$math) > 0) {
			txt <- paste0('You got ', sum(assmt.results$math, na.rm=TRUE),
						  ' of ', length(assmt.results$math), ' items correct.')
		} else {
			txt <- 'No results found. Please complete the statistics assessment.'
		}
		return(txt)
	})
	
	output$mass.results <- renderText({
		txt <- ''
		if(length(assmt.results$mass) == 0) {
			txt <- 'No results found. Please complete the statistics assessment.'
		}
		return(txt)
	})
	
	output$reading.results <- renderText({
		txt <- ''
		if(length(assmt.results$reading) > 0) {
			txt <- paste0('You got ', sum(assmt.results$reading, na.rm=TRUE),
						  ' of ', length(assmt.results$reading), ' items correct.')
		} else {
			txt <- 'No results found. Please complete the reading assessment.'
		}
		return(txt)
	})
	
	output$mass.plot <- renderPlot({
		if(length(assmt.results$mass) > 0) {
			df <- data.frame(Item = mass.items$stem,
							 Response = assmt.results$mass)
			p <- ggplot(df, aes(x=Response, y=Item)) + geom_point()
			return(p)
		} else {
			return(NULL)
		}
	})
	
	# Multiple choice test example
	test <- ShinyAssessment(input, output, session,
							name = 'Statistcs',
							item.stems = math.items$Stem,
							item.choices = math.items[,c(4:8)],
							callback = saveResults,
							start.label = 'Start the Statistics Assessment',
							itemsPerPage = 1,
							inline = FALSE)
	
	# Likert scale example
	mass <- ShinyAssessment(input, output, session,
							name = 'MASS',
							item.stems = mass.items$stem,
							item.choices = mass.items[,2:6],
							callback = saveMASSResults,
							start.label = 'Take the Math Anxiety Survey',
							itemsPerPage = 7,
							inline = TRUE)
	
	reading <- ShinyAssessment(input, output, session,
							name = 'Reading',
							item.stems = read.stems,
							item.choices = read.items[,6:9],
							callback = saveReadingResults,
							start.label = 'Take the Reading Assessment',
							itemsPerPage = 6,
							inline = FALSE)
	
	output$ui <- renderUI({
		if(SHOW_ASSESSMENT$show) { # The assessment will take over the entire page.
			fluidPage(width = 12, uiOutput(SHOW_ASSESSMENT$assessment))
		} else { # Put other ui components here
			fluidPage(	 			
				titlePanel("Shiny Assessment Example"),
				sidebarLayout(
					sidebarPanel(
						# Show the start assessment link
						h4('Example multiple choice assessment'),
						p('You can use a link'),
						uiOutput(test$link.name),
						p('Or a button to start the assessment'),
						uiOutput(test$button.name),
						hr(),
						h4('Reading assessment with custom stems'),
						uiOutput(reading$button.name),
						hr(),
						h4('Example of a likert survey'),
						uiOutput(mass$button.name)
					),
					mainPanel(
						h3('Statistics Assessment Results'),
						textOutput('math.results'),
						hr(),
						h3('Reading Assessment Results'),
						textOutput('reading.results'),
						hr(),
						h3('Math Anxiety Survey Results'),
						textOutput('mass.results'),
						plotOutput('mass.plot')
					)
			)
			)
		}
	})
})

##### Run the application ######################################################
shinyApp(ui = ui, server = server)

items.csv

mass.csv

ReadingItems.csv

ShinyAssessment.R

#' Create Shiny UI for multiple choice assessment.
#' 
#' 
#' NOTE: This function will create an object \code{SHOW_ASSESSMENT} in the 
#' calling environment. This object is used to determine whether the assessment
#' should be shown or not. This object will be shared across multiple
#' \code{ShinyAssessment} instances.
#' 
#' @param input from \code{shinyServer}.
#' @param output from \code{shinyServer}.
#' @param session from \code{shinyServer}.
#' @param name the name of the assessment. This should be a name that follows
#'        R's naming rules (i.e. does not start with a number, no spaces, etc).
#' @param callback function called when the user submits the assessment. Used
#'        for saving the results.
#' @param item.stems a character vector or list with the item stems. If a list,
#'        any valid Shiny output is allowed (e.g. \code{p}, \code{div}, 
#'        \code{fluidRow}, etc.). For character vectors HTML is allowd.
#' @param item.choices a data frame with the item answers. For items that have 
#'        fewer choices than the total number of
#'        columns, place \code{NA} in that column's value. The results will be
#'        passed to the \code{callback} function as named list where the value
#'        is the name of the column selected.
#' @param start.label The label used for the link and button created to start
#'        the assessment.
#' @param itemsPerPage the number of items to display per page.
#' @param inline If \code{TRUE}, render the choices inline (i.e. horizontally).
#' @param width The width of the radio button input.
#' @param cancelButton should a cancel button be displayed on the assessment.
#' @return Returns a list with the following values:
#'         \itemize{
#'         \item{ui.name}{the name of the UI put on the output object for the items.}
#'         \item{link.name}{the name of the UI element for the start assessment link.}
#'         \item{button.name}{the name of the UI element for the start assessment button.}
#'         }
#' @export
ShinyAssessment <- function(input, output, session,
							name, callback,
							item.stems, item.choices,
							start.label = 'Start the Assessment',
							itemsPerPage = 1,
							inline = FALSE,
							width = '100%',
							cancelButton = TRUE
) {
	stopifnot(length(item.stems) == nrow(item.choices))
	
	if(!exists('SHOW_ASSESSMENT', envir = parent.env(environment()))) {
		# A bit of a hack and knowingly bad form. This will put an object in
		# the calling environment. This will allow for multiple asssessments
		# to be run in the same Shiny app.
		assign('SHOW_ASSESSMENT', 
			   value = reactiveValues(show = FALSE, assessment = NULL, 
			   					      unique = format(Sys.time(), '%Y%m%d%H%M%S')),
			   envir = parent.env(environment())
		)
	}
	
	ASSESSMENT <- reactiveValues(
		currentPage = 1,
		responses = rep(as.integer(NA), length(item.stems))
	)
	
	# Names of various UI elements. Note that for radio, next, cancel, and done
	# buttons the name has SHOW_ASSESSMENT$unique concatenated, which is the
	# current time in seconds when the assessment was started. This ensures that
	# a unique set of buttons are created for each assessment. Otherwise, answers
	# would be carried over from prior assessments. This is especially problematic
	# since the buttons remain in the session but previous responses not shown
	# to the user.

	link.name <- paste0('Start', name, 'Link')
	button.name <- paste0('Start', name, 'Button')
	cancel.name <- paste0('Cancel', name, 'Button')
	ui.name <- paste0(name, 'Items')
	save.name <- paste0(name, 'Save')
	page.name <- paste0(name, 'Page')
	totalPages <- ceiling(length(item.stems) / itemsPerPage)
	
	output[[link.name]] <- renderUI({
		observe({
			if(!is.null(input[[paste0(link.name, SHOW_ASSESSMENT$unique)]])) {
				if(input[[paste0(link.name, SHOW_ASSESSMENT$unique)]] == 1) {
					SHOW_ASSESSMENT$show <- TRUE
					SHOW_ASSESSMENT$assessment <- ui.name
				}
			}
		})
		
		actionLink(paste0(link.name, SHOW_ASSESSMENT$unique), start.label)
	})

	output[[button.name]] <- renderUI({
		observe({
			if(!is.null(input[[paste0(button.name, SHOW_ASSESSMENT$unique)]])) {
				if(input[[paste0(button.name, SHOW_ASSESSMENT$unique)]] == 1) {
					SHOW_ASSESSMENT$show <- TRUE
					SHOW_ASSESSMENT$assessment <- ui.name
				}
			}
		})
		
		actionButton(paste0(button.name, SHOW_ASSESSMENT$unique), start.label)
	})

	output[[cancel.name]] <- renderUI({
		observe({
			if(!is.null(input[[paste0(cancel.name, SHOW_ASSESSMENT$unique)]])) {
				if(input[[paste0(cancel.name, SHOW_ASSESSMENT$unique)]] == 1) {
					# TODO: Should the callback function be called with the
					#       incomplete results?
					SHOW_ASSESSMENT$show <- FALSE
					SHOW_ASSESSMENT$assessment <- NULL
					SHOW_ASSESSMENT$unique <- format(Sys.time(), '%Y%m%d%H%M%S')
					ASSESSMENT$currentPage <- 1
					ASSESSMENT$responses <- rep(as.integer(NA), length(item.stems))
				}
			}
		})
		
		actionButton(paste0(cancel.name, SHOW_ASSESSMENT$unique), 'Cancel')
	})
	
	output[[ui.name]] <- renderUI({
		# Build a list of radioButtons for each item.
		buttons <- list()
		for(i in seq_len(length(item.stems))) {
			choices <- character()
			for(j in 1:ncol(item.choices)) {
				if(!is.na(item.choices[i,j])) {
					choices[(j)] <- names(item.choices)[j]
					names(choices)[(j)] <- HTML(item.choices[i,j])
				}
			}
			button.label <- ''
			if(is.character(item.stems)) {
				button.label <- HTML(item.stems[i])
			} else {
				button.label <- item.stems[[i]]
			}
			buttons[[i]] <- radioButtons(inputId = paste0(name, i, SHOW_ASSESSMENT$unique), 
										 label = button.label,
										 choices = choices, 
										 inline = inline,
										 selected = character(),
										 width = width)
		}

		startPos <- ((ASSESSMENT$currentPage - 1) * itemsPerPage) + 1
		pos <- seq(startPos, min( (startPos + itemsPerPage - 1), length(buttons)))
	
		observe({
			# Save the results
			if(SHOW_ASSESSMENT$show & 
			   !is.null(input[[paste0(save.name, SHOW_ASSESSMENT$unique)]])
			) {
				if(input[[paste0(save.name, SHOW_ASSESSMENT$unique)]] == 1) {
					results <- character(length(item.stems))
					for(i in seq_len(length(buttons))) {
						ans <- input[[paste0(name, i, SHOW_ASSESSMENT$unique)]]
						results[i] <- ifelse(is.null(ans), NA, ans)
					}
					# Do callback
					callback(results)
					# Reset for another assessment
					SHOW_ASSESSMENT$show <- FALSE
					SHOW_ASSESSMENT$assessment <- NULL
					SHOW_ASSESSMENT$unique <- format(Sys.time(), '%Y%m%d%H%M%S')
					ASSESSMENT$currentPage <- 1
					ASSESSMENT$responses <- rep(as.integer(NA), length(item.stems))
				}
			}
		})
	
		# Increment the page
		nextButtonName <- paste(page.name, ASSESSMENT$currentPage, SHOW_ASSESSMENT$unique)
		if(!is.null(input[[nextButtonName]])) {
			if(input[[nextButtonName]] == 1) {
				for(i in seq( ((ASSESSMENT$currentPage - 1) * itemsPerPage) + 1,
							  ASSESSMENT$currentPage * itemsPerPage, by=1) ) {
					ans <- input[[paste0(name, i, SHOW_ASSESSMENT$unique)]]
					ASSESSMENT$responses[i] <- ifelse(is.null(ans), NA, ans)
				}
				ASSESSMENT$currentPage <- ASSESSMENT$currentPage + 1
				nextButtonName <- paste0(page.name, ASSESSMENT$currentPage)
			}
		}
		
		# Next or Done button
		if(ASSESSMENT$currentPage == totalPages) {
			nextButton <- actionButton(paste0(save.name, SHOW_ASSESSMENT$unique), 'Done')
		} else {
			nextButton <- actionButton(nextButtonName, 'Next')
		}
		
		mainPanel(width=12,
			br(),
			buttons[pos],
			br(),
			fluidRow(
				column(width=2, uiOutput(cancel.name)),
				column(width=8, p(paste0('Page ', ASSESSMENT$currentPage, ' of ', totalPages)), 
					   align='center'),
				column(width=2, nextButton)
			)
		)
	})
	
	return(list(ui.name = ui.name,
				link.name = link.name,
				button.name = button.name
	))
}

Nice idea 👍. You may also find the mirtCAT package useful, which is something very similar with shiny that is for IRT-based computerized adaptive tests (https://github.com/philchalmers/mirtCAT). There's some exposure to internal functions, so if you feel like using some of the low-level functions (like findNextItem()) feel free. Cheers.