R/shiny_support.R
In traets/idefix: Efficient Designs for Discrete Choice Experiments
Defines functions
LoadData
saveData
Decode
SurveyApp
Documented in
Decode
LoadData
SurveyApp
#'Shiny application to generate a discrete choice survey.
#'
#'This function starts a shiny application which puts choice sets on screen and
#'saves the responses. The complete choice design can be provided in advance, or
#'can be generated sequentially adaptively, or can be a combination of both.
#'
#'A pregenerated design can be specified in \code{des}. This should be a matrix
#'in which each row is a profile. This can be generated with \code{\link{Modfed}}
#'or \code{\link{CEA}}, but it is not necessary.
#'
#'If \code{n.total} = \code{nrow(des)} / \code{length(alts)}, the specified
#'design will be put on screen, one set after the other, and the responses will
#'be saved. If \code{n.total} > (\code{nrow(des)} / \code{length(alts)}), first
#'the specified design will be shown and afterwards the remaining sets will be
#'generated adaptively. If \code{des} = \code{NULL}, \code{n.total} sets will be
#'generated adaptively. See \code{\link{SeqMOD}} for more information on adaptive
#'choice sets.
#'
#'Whenever adaptive sets will be generated, \code{prior.mean},
#'\code{prior.covar}, \code{cand.set} and \code{n.draws}, should be specified.
#'These arguments are necessary for the underlying importance sampling algorithm
#'to update the prior preference distribution. \code{lower} and \code{upper} can
#'be used to specify lower and upper truncation points. See
#'\code{\link{ImpsampMNL}} for more details.
#'
#'The names specified in \code{alts} will be used to label the choice
#'alternatives. The names specified in \code{atts} will be used to name the
#'attributes in the choice sets. The values of \code{lvl.names} will be used to
#'create the values in the choice sets. See \code{\link{Decode}} for more
#'details.
#'
#'The text specified in \code{buttons.text} will be displayed above the buttons
#'to indicate the preferred choice (for example: "indicate your preferred
#'choice"). The text specified in \code{intro.text} will be displayed before the
#'choice sets. This will generally be a description of the survey and some
#'instructions. The text specified in \code{end.text} will be displayed after
#'the survey. This will generally be a thanking note and some further
#'instructions.
#'
#'A no choice alternative is coded as an alternative with 1 alternative specific
#'constant and zero's for all other attribute levels. If a no choice alternative
#'is present in \code{des}, or is desired when generating adaptive choice sets,
#'\code{no.choice} should be specified. This should be done with an integer,
#'indicating which alternative is the no choice option. This alternative will
#'not be presented on screen, but the option to select "no choice" will be. The
#'\code{alt.cte} argument should be specified accordingly, namely with a
#'\code{1} on the location of the \code{no.choice} option. See examples for
#' illustration.
#'
#'When \code{parallel} is \code{TRUE}, \code{\link[parallel]{detectCores}} will
#'be used to decide upon the number of available cores. That number minus 1
#'cores will be used to search for the optimal adaptive choice set. For small problems
#'(6 parameters), \code{parallel = TRUE} can be slower. For larger problems the
#'computation time will decrease significantly.
#'
#'When \code{reduce = TRUE}, the set of all potential choice sets will be
#'reduced to choice sets that have a unique information matrix. If no
#'alternative specific constants are used, \code{reduce} should always be
#'\code{TRUE}. When alternative specific constants are used \code{reduce} can be
#'\code{TRUE} so that the algorithm will be faster, but the combinations of
#'constants and profiles will not be evaluated exhaustively.
#'
#'@param alts A character vector containing the names of the alternatives.
#'@param atts A character vector containing the names of the attributes.
#'@param n.total A numeric value indicating the total number of choice sets.
#'@param buttons.text A string containing the text presented together with the
#' option buttons.
#'@param no.choice An integer indicating which alternative should be a no choice
#' alternative. The default is \code{NULL}.
#'@param intro.text A string containing the text presented before the choice
#' survey.
#'@param end.text A string containing the text presented after the choice
#' survey.
#'@param data.dir A character string with the directory denoting where the data
#' needs to be written. The default is NULL
#'@inheritParams Decode
#'@inheritParams Modfed
#'@inheritParams Profiles
#'@inheritParams SeqMOD
#'@inheritParams ImpsampMNL
#'@importFrom Rdpack reprompt
#'@references \insertRef{ju}{idefix}
#'@return After completing the survey, two text files can be found in
#' \code{data.dir}. The file with "num" in the filename is a matrix with the
#' numeric choice data. The coded design matrix ("par"), presented during the
#' survey, together with the observed responses ("resp") can be found here.
#' Rownames indicate the setnumbers. The file with "char" in the filename is a
#' matrix with character choice data. The labeled design matrix ("par"),
#' presented during the survey, together with the observed responses ("resp")
#' can be found here. See \code{\link{LoadData}} to load the data.
#' @examples
#' \dontrun{
#'#### Present choice design without adaptive sets (n.total = sets in des)
#'# example design
#'data("example_design") # pregenerated design
#'xdes <- example_design
#'### settings of the design
#'code <- c("D", "D", "D")
#'n.sets <- 8
#'# settings of the survey
#'alternatives <- c("Alternative A", "Alternative B")
#'attributes <- c("Price", "Time", "Comfort")
#'labels <- vector(mode="list", length(attributes))
#'labels[[1]] <- c("$10", "$5", "$1")
#'labels[[2]] <- c("20 min", "12 min", "3 min")
#'labels[[3]] <- c("bad", "average", "good")
#'i.text <- "Welcome, here are some instructions ... good luck!"
#'b.text <- "Please choose the alternative you prefer"
#'e.text <- "Thanks for taking the survey"
#'dataDir <- getwd()
#'# Display the survey
#'SurveyApp (des = xdes, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text)
#'
#' #### Present choice design with partly adaptive sets (n.total > sets in des)
#' # example design
#' data("example_design") # pregenerated design
#' xdes <- example_design
#' ### settings of the design
#' code <- c("D", "D", "D")
#' n.sets <- 12
#' # settings of the survey
#' alternatives <- c("Alternative A", "Alternative B")
#' attributes <- c("Price", "Time", "Comfort")
#' labels <- vector(mode="list", length(attributes))
#' labels[[1]] <- c("$10", "$5", "$1")
#' labels[[2]] <- c("20 min", "12 min", "3 min")
#' labels[[3]] <- c("bad", "average", "good")
#' i.text <- "Welcome, here are some instructions ... good luck!"
#' b.text <- "Please choose the alternative you prefer"
#' e.text <- "Thanks for taking the survey"
#' # setting for adaptive sets
#' levels <- c(3, 3, 3)
#' cand <- Profiles(lvls = levels, coding = code)
#' p.mean <- c(0.3, 0.7, 0.3, 0.7, 0.3, 0.7)
#' p.var <- diag(length(p.mean))
#' dataDir <- getwd()
#' # Display the survey
#' SurveyApp(des = xdes, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' prior.mean = p.mean, prior.covar = p.var, cand.set = cand,
#' n.draws = 50)
#'
#'#### Choice design with only adaptive sets (des=NULL)
#'# setting for adaptive sets
#'levels <- c(3, 3, 3)
#'p.mean <- c(0.3, 0.7, 0.3, 0.7, 0.3, 0.7)
#'low = c(-Inf, -Inf, -Inf, 0, 0, -Inf)
#'up = rep(Inf, length(p.mean))
#'p.var <- diag(length(p.mean))
#'code <- c("D", "D", "D")
#'cand <- Profiles(lvls = levels, coding = code)
#'n.sets <- 12
#'# settings of the survey
#'alternatives <- c("Alternative A", "Alternative B")
#'attributes <- c("Price", "Time", "Comfort")
#'labels <- vector(mode="list", length(attributes))
#'labels[[1]] <- c("$10", "$5", "$1")
#'labels[[2]] <- c("20 min", "12 min", "3 min")
#'labels[[3]] <- c("bad", "average", "good")
#'i.text <- "Welcome, here are some instructions ... good luck!"
#'b.text <- "Please choose the alternative you prefer"
#'e.text <- "Thanks for taking the survey"
#'dataDir <- getwd()
#'# Display the survey
#'SurveyApp(des = NULL, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' prior.mean = p.mean, prior.covar = p.var, cand.set = cand,
#' lower = low, upper = up, n.draws = 50)
#' # If CEA algorithm is desired, cand.set argument is not needed
#'SurveyApp(des = NULL, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' prior.mean = p.mean, prior.covar = p.var,
#' lower = low, upper = up, n.draws = 50)
#'
#'#### Present choice design with a no choice alternative.
#'# example design
#'data("nochoice_design") # pregenerated design
#'xdes <- nochoice_design
#'### settings of the design
#'code <- c("D", "D", "D")
#'n.sets <- 8
#'# settings of the survey
#'alternatives <- c("Alternative A", "Alternative B", "None")
#'attributes <- c("Price", "Time", "Comfort")
#'labels <- vector(mode = "list", length(attributes))
#'labels[[1]] <- c("$10", "$5", "$1")
#'labels[[2]] <- c("20 min", "12 min", "3 min")
#'labels[[3]] <- c("bad", "average", "good")
#'i.text <- "Welcome, here are some instructions ... good luck!"
#'b.text <- "Please choose the alternative you prefer"
#'e.text <- "Thanks for taking the survey"
#'
#'# Display the survey
#'SurveyApp(des = xdes, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' no.choice = 3, alt.cte = c(0, 0, 1))
#'}
#'@import shiny
#'@export
SurveyApp <- function(des = NULL, n.total, alts, atts, lvl.names, coding,
alt.cte = NULL, no.choice = NULL,
buttons.text, intro.text, end.text, data.dir = NULL,
c.lvls = NULL, prior.mean = NULL,
prior.covar = NULL, cand.set = NULL, n.draws = NULL,
lower = NULL, upper = NULL, parallel = TRUE, reduce = TRUE) {
# Initialize
algorithm = "MOD"
sdata <- vector(mode = "list")
surveyData <- vector(mode = "list")
y.bin <- vector("numeric")
resp <- vector("character")
n.atts <- length(atts)
n.alts <- length(alts)
n.levels <- as.vector(unlist(lapply(lvl.names,length)))
choice.sets <- matrix(data = NA, nrow = n.total * n.alts, ncol = n.atts)
buttons <- NULL
sn <- 0
if (is.null(des)) {
n.init <- 0
} else {
n.init <- nrow(des) / n.alts
if (!isTRUE(all.equal(n.init, as.integer(n.init)))) {
stop("the number of rows of 'des' are not a multiple of length(alts)")
}
}
if (is.null(alt.cte) || all(alt.cte == 0)) {
alt.cte <- rep(0, n.alts)
n.cte <- 0
cte.des <- NULL
} else {
# Error
if (length(alt.cte) != n.alts) {
stop("length(alts) does not match length(alt.cte)")
}
if (!all(alt.cte %in% c(0, 1))) {
stop("'alt.cte' should only contain 0's or 1's.")
}
if (!any(alt.cte == 0)) {
stop("'alt.cte' should at least contain 1 zero")
}
n.cte <- sum(alt.cte)
if (!is.null(des)) {
cte.des <- Altspec(alt.cte = alt.cte, n.sets = n.init)
if (!isTRUE(all.equal(cte.des, matrix(des[ , 1:n.cte], ncol = n.cte)))) {
stop("the first column(s) of 'des' are different from what is expected based on 'alt.cte'")
}
}
}
# Error handling
if (!is.null(no.choice)) {
if (!is.numeric(no.choice)) {
stop("'no.choice' should be an integer indicating the no choice alternative.")
}
if (!no.choice %% 1 == 0) {
stop("'no.choice' should be an integer")
}
if (any(isTRUE(no.choice > (n.alts + 0.2)), isTRUE(no.choice < 0.2))) {
stop("'no.choice' does not indicate one of the alternatives")
}
if (!isTRUE(all.equal(alt.cte[no.choice], 1))) {
stop("the location of the 'no.choice' option in the 'alt.cte' vector should correspond with 1")
}
}
if (!is.null(data.dir)) {
if (!dir.exists(data.dir)) {
stop("Directory 'data.dir' does not exist")
}
}
if (n.total > n.init) {
if (is.null(lower)) {
lower <- rep(-Inf, length(prior.mean))
}
if (is.null(upper)) {
upper <- rep(Inf, length(prior.mean))
}
if (!any(c(isTRUE(all.equal(length(prior.mean), length(lower))), isTRUE(all.equal(length(prior.mean), length(upper)))))) {
stop("length 'prior.mean' should equal 'upper' and 'lower'")
}
if (algorithm == "MOD") {
if (any(c(is.null(prior.mean), is.null(prior.covar), is.null(cand.set),
is.null(n.draws)))) {
stop("When n.total is larger than the number of sets in argument des, arguments prior.mean, prior.covar, cand.set and n.draws should be specified.")
}
if (length(prior.mean) != ncol(cand.set) + sum(alt.cte)) {
stop("Number of parameters in prior.mean does not match with cand.set + alt.cte")
}
} else if (algorithm == "CEA") {
if (any(c(is.null(prior.mean), is.null(prior.covar), is.null(n.draws)))) {
stop("When n.total is larger than the number of sets in argument des, arguments prior.mean, prior.covar and n.draws should be specified.")
}
}
if (!isTRUE(all.equal(length(prior.mean), ncol(prior.covar)))) {
stop("length of 'prior.mean' differs from number of columns 'prior.covar'")
}
} else {
if (!is.null(prior.mean)) {
warning("'prior.mean' will be ignored, since there are no adaptive sets.")
}
if (!is.null(prior.covar)) {
warning("'prior.covar' will be ignored, since there are no adaptive sets.")
}
if (algorithm == "MOD" & !is.null(cand.set)) {
warning("'cand.set' will be ignored, since there are no adaptive sets.")
}
if (!is.null(lower) || !is.null(upper)) {
warning("'lower' and 'upper' bound will be ignored, since there are no adaptive sets.")
}
if (!is.null(n.draws)) {
warning("'n.draws' will be ignored, since there are no adaptive sets.")
}
}
if (is.null(des)) {
if (algorithm == "MOD") {
fulldes <- matrix(data = NA, nrow = (n.alts * n.total), ncol = ncol(cand.set))
} else {
fulldes <- matrix()
}
} else {
bs <- seq(1, (nrow(des) - n.alts + 1), n.alts)
es <- c((bs - 1), nrow(des))[-1]
rowcol <- Rcnames(n.sets = n.init, n.alts = n.alts, alt.cte = alt.cte,
no.choice = FALSE)
rownames(des) <- rowcol[[1]]
if (is.null(colnames(des))) {
colnames(des) <- c(rowcol[[2]], paste("par", 1:(ncol(des) - n.cte),
sep = "."))
}
fulldes <- des
# Error handling
if (length(bs) != n.init) {
stop("The number of rows in 'des' is not a multiple of length(atts)")
}
if ("no.choice.cte" %in% colnames(des)) {
if (is.null(no.choice)) {
warning("no.choice.cte column name detected in 'des' while 'no.choice = NULL'")
}
}
}
if (!(algorithm %in% c("MOD","CEA"))) {
stop("algorithm should be 'MOD' or 'CEA'")
}
shinyApp(
### User interface
ui <- fluidPage(
# Put setnr on screen
column(8, align = 'center', textOutput("set.nr")),
# Put design on screen
column(8, align = 'center', tableOutput("choice.set")),
# Put answer options on screen
column(8, align = 'center', uiOutput('buttons')),
# put introtext on screen
column(8, align = 'center', textOutput('intro')),
# Put action button on screen
column(8, align = "center", actionButton("OK", "OK")),
# put end text on screen
column(8, align = 'center', textOutput('end'))
),
### Server
server <- function(input, output) {
# Count set number
observeEvent(input$OK, {
sn <<- sn + 1
})
# Set selection function
Select <- function() {
if (sn <= n.total) {
# for initial sets
if (sn <= n.init) {
set <- des[bs[sn]:es[sn], ]
} else {
## sample drawing for adaptive sets
# if First set
if (sn == 1) {
# sample draws from prior
s <- tmvtnorm::rtmvnorm(n = n.draws, mean = prior.mean,
sigma = prior.covar, lower = lower,
upper = upper)
w <- rep(1, nrow(s)) / nrow(s)
if (sum(alt.cte) > 0.2) {
s <- list(as.matrix(s[ , 1:sum(alt.cte)], ncol = sum(alt.cte)),
s[ , -c(1:sum(alt.cte))])
}
# From second set
} else {
# Sample draws from updated posterior
sam <- ImpsampMNL(n.draws = n.draws, prior.mean = prior.mean,
prior.covar = prior.covar,
des = fulldes, n.alts = n.alts, y = y.bin,
alt.cte = alt.cte, lower = lower, upper = upper)
s <- sam$sample
w <- sam$weights
}
## Selecting set
if (algorithm == "MOD") {
# Select new set based on Modfed
setobj <- SeqMOD(des = des, cand.set = cand.set, n.alts = n.alts,
par.draws = s, prior.covar = prior.covar,
alt.cte = alt.cte, weights = w,
no.choice = no.choice, parallel = parallel,
reduce = reduce)
} else if (algorithm == "CEA") {
setobj <- SeqCEA(des = des, lvls = n.levels, coding = coding,
n.alts = n.alts, par.draws = s,
prior.covar = prior.covar, alt.cte = alt.cte,
weights = w, no.choice = no.choice,
parallel = parallel, reduce = reduce)
}
set <- setobj$set
db <- setobj$db
## Design storage
if (sn == 1) {
rowcol <- Rcnames(n.sets = 1, n.alts = n.alts, alt.cte = alt.cte, no.choice = FALSE)
rownames(set) <- rownames(set, do.NULL = FALSE, prefix = paste(paste("set", sn , sep = ""), "alt", sep = "."))
colnames(set) <- c(rowcol[[2]], paste("par", 1:(ncol(set) - n.cte), sep = "."))
fulldes <<- set
} else {
rowcol <- Rcnames(n.sets = 1, n.alts = n.alts, alt.cte = alt.cte, no.choice = FALSE)
rownames(set) <- rownames(set, do.NULL = FALSE, prefix = paste(paste("set", sn , sep = ""), "alt", sep = "."))
colnames(set) <- c(rowcol[[2]], paste("par", 1:(ncol(set) - n.cte), sep = "."))
fulldes <<- rbind(fulldes, set)
}
}
# Transform coded set to attribute level character set.
choice.set <- Decode(des = set, n.alts = n.alts, lvl.names = lvl.names, coding = coding,
alt.cte = alt.cte, c.lvls = c.lvls, no.choice = no.choice)[[1]]
choice.set <- t(choice.set[ , 1:n.atts])
# Fill in attribute names and alternatives names
colnames(choice.set) <- alts
rownames(choice.set) <- atts
# Store uncoded choice set
if (sn == 1) {
choice.sets <<- choice.set
} else {
choice.sets <<- rbind(choice.sets, choice.set)
}
#return design
if (!is.null(no.choice)) {
no.choice.set <- choice.set[ ,-no.choice]
return(no.choice.set)
} else {
return(choice.set)
}
}
}
#When action button is clicked
observeEvent(input$OK, {
# survey phase
if (sn <= n.total ) {
# Plot new choice set
output$choice.set <- renderTable(Select(), rownames = TRUE)
}
# Store responses and design
if (sn > 1 && sn <= (n.total + 1)) {
resp <<- c(resp, input$survey)
y.bin <<- Charbin(resp = resp, alts = alts, n.alts = n.alts)
sdata[["bin.responses"]] <- y.bin
sdata[["responses"]] <- resp
sdata[["desing"]] <- fulldes
sdata[["survey"]] <- choice.sets
surveyData <<- sdata
}
# end phase
if (sn > n.total) {
#Don't show choice set
output$choice.set <- renderTable(NULL)
}
})
#Output response options after first action button click
output$buttons <- renderUI({
# radiobuttons
if (input$OK > 0 && input$OK <= n.total) {
return(list(radioButtons("survey", buttons.text,
alts , inline = TRUE, selected = "None")))
}
})
# set nr
observeEvent(input$OK, {
if (sn < n.total) {
output$set.nr <- renderText(paste(c("choice set:", sn, "/", n.total)))
} else {output$set.nr <- renderText(NULL)}
})
# Introtext
output$intro <- renderText(intro.text)
observeEvent(input$OK, {
output$intro <- renderText(NULL)
})
# End of survey
observeEvent(input$OK, {
# Display end text
if (input$OK > n.total) {
# Display end text
output$end <- renderText(end.text)
}
# Quit application
if (input$OK > (n.total + 1)) {
# Write data to file
if (!is.null(data.dir)) {
saveData(data = surveyData, data.dir = data.dir, n.atts = n.atts)
}
# Stop application
stopApp()
}
})
}
)
}
#' Coded design to readable design.
#'
#' Transforms a coded design matrix into a design containing character attribute
#' levels, ready to be used in a survey. The frequency of each attribute level
#' in the design is also included in the output.
#'
#' \code{des} A design matrix, this can also be a single choice set. See for
#' example the output of \link[idefix]{Modfed} or \link[idefix]{CEA}.
#'
#' In \code{lvl.names}, the number of character vectors in the list should equal
#' the number of attributes in de choice set. The number of elements in each
#' character vector should equal the number of levels for that attribute.
#'
#' Valid arguments for \code{coding} are \code{C}, \code{D} and \code{E}. When
#' using \code{C} the attribute will be treated as continuous and no coding will
#' be applied. All possible levels of that attribute should then be specified in
#' \code{c.lvls}. If \code{D} (dummy coding) is used
#' \code{\link{contr.treatment}} will be applied to that attribute. The first
#' attribute wil be used as reference level. For \code{E} (effect coding)
#' \code{\link{contr.sum}} is applied, in this case the last attribute level is
#' used as reference level.
#'
#' If \code{des} contains columns for alternative specific constants,
#' \code{alt.cte} should be specified. In this case, the first column(s) (equal
#' to the number of nonzero elements in \code{alt.cte}) will be removed from
#' \code{des} before decoding the alternatives.
#'
#' @param des A numeric matrix which represents the design matrix. Each row is a
#' profile.
#' @param lvl.names A list containing character vectors with the values of each
#' level of each attribute.
#' @param coding A character vector denoting the type of coding used for each
#' attribute. See also \code{\link[idefix]{Profiles}}.
#' @param alt.cte A binary vector indicating for each alternative if an
#' alternative specific constant is present. The default is \code{NULL}.
#' @param no.choice An integer indicating the no choice alternative. The default
#' is \code{NULL}.
#' @inheritParams Profiles
#' @inheritParams Modfed
#' @return \item{design}{A character matrix which represents the design.}
#' \item{lvl.balance}{A list containing the frequency of appearance of each
#' attribute level in the design.}
#' @examples
#' \dontrun{
#' # Example without continuous attributes.
#' design <- example_design
#' coded <- c("D", "D", "D") # Coding.
#' # Levels as they should appear in survey.
#' al <- list(
#' c("$50", "$75", "$100"), # Levels attribute 1.
#' c("2 min", "15 min", "30 min"), # Levels attribute 2.
#' c("bad", "moderate", "good") # Levels attribute 3.
#' )
#' # Decode
#' Decode(des = design, n.alts = 2, lvl.names = al, coding = coded)
#'
#' # Example with alternative specific constants
#' design <- example_design2
#' coded <- c("D", "D", "D") # Coding.
#' # Levels as they should appear in survey.
#' al <- list(
#' c("$50", "$75", "$100"), # Levels attribute 1.
#' c("2 min", "15 min", "30 min"), # Levels attribute 2.
#' c("bad", "moderate", "good") # Levels attribute 3.
#' )
#' # Decode
#' Decode(des = design, n.alts = 3, lvl.names = al, coding = coded, alt.cte = c(1, 1, 0))
#' }
#' @export
Decode <- function(des, n.alts, lvl.names, coding, alt.cte = NULL, c.lvls = NULL, no.choice = NULL) {
n.sets <- nrow(des) / n.alts
if(!isTRUE(all.equal(n.sets %% 1, 0))){
stop("'n.alts' does not seem correct based on nrow(des)")
}
if(!is.list(lvl.names)){
stop("'lvl.names' should be a list")
}
if(!is.matrix(des)){
stop("'des' should be a matrix")
}
if(!is.null(alt.cte)) {
if(!isTRUE(all.equal(length(alt.cte), n.alts))){
stop("the length of 'alt.cte' does not match 'n.alts'")
}
contins <- which(alt.cte == 1)
if( !length(contins) == 0) {
des <- des[, -(1:length(contins))]
}
}
if(!is.null(no.choice)){
if(!is.numeric(no.choice)){
stop("'no.choice' should be an integer indicating the no choice alternative.")
}
if(!no.choice %% 1 == 0){
stop("'no.choice' should be an integer")
}
if(any(isTRUE(no.choice > (n.alts + 0.2)), isTRUE(no.choice < 0.2))){
stop("'no.choice' does not indicate one of the alternatives")
}
if(!isTRUE(all.equal(alt.cte[no.choice], 1))){
stop("the location of the 'no.choice' option in the 'alt.cte' vector should correspond with 1")
}
ncsek <- 1:nrow(des)
ncsek <- ncsek[-seq(no.choice, (n.sets * no.choice), no.choice)]
#des <- des[-ncsek, ]
} else {
ncsek <- 1:nrow(des)
}
N.alts <- nrow(des) # Number of total alternatives.
n.att <- length(lvl.names) # Number of attributes.
conts <- which(coding == "C") # Continuous levels.
# Create vector where each element denotes the number of levels for each attribute.
lvls <- numeric(n.att)
for (i in 1:n.att) {
lvls[i] <- length(lvl.names[[i]])
}
# Generate all possible profiles coded and uncoded
dc <- Profiles(lvls = lvls, coding = coding, c.lvls = c.lvls)
# Create uncoded grid.
d <- as.data.frame(expand.grid(lvl.names))
# Create new matrix for choice des with attribute level names
m <- matrix(data = NA, nrow = N.alts, ncol = n.att)
# Error handling
if (ncol(des) != ncol(dc)) {
stop("ncol(des) does not equal the expected number based on 'lvl.names' and 'alt.cte'.")
}
# For each alternative look for matching profile
for (i in ncsek) {
# if coded choice des, look for match in coded version first, then take uncoded equivalent.
lev.num <- d[as.numeric(which(apply(dc, 1, function(x) all(x == des[i, ])))), ]
lev.num <- as.numeric(lev.num)
# Error handling
if (any(is.na(lev.num))) {
stop("alternatives detected that do not match with the type of 'coding' provided.
Make sure 'no.choice' is specified if applicable.")
}
# For each attribute fill in the attribute level name
for (c in 1:n.att) {m[i, c] <- lvl.names[[c]][lev.num[c]]}
}
#frequency levels
ml <- list()
ml <- split(m, rep(1:ncol(m), each = nrow(m)))
lvl.balance <- lapply(ml, table)
names(lvl.balance) <- paste("attribute", 1:length(coding), "")
#col row names names
rownames(m) <- rownames(des)
return(list("design" = as.data.frame(m), "lvl.balance" = lvl.balance))
}
# Character vector to binary vector.
#
# Transforms a character vector with responses into a binary vector. Each
# alternative in each choice set wil be either 0 or 1. If the
# alternative was not chosen 0, and 1 if it was. The function can be used for example in a
# shiny application to transform the response vector received from
# \code{\link[shiny]{radioButtons}} into a numeric vector that can be used for
# estimation.
#
# The \code{n.alts} denotes the number of alternatives a respondent could
# choose from, without counting a possible no choice option.
#
# If \code{no.choice} is \code{TRUE} the first alternative specified in
# \code{alts} will be treated as a no choice option. If the no choice option
# was chosen all alternatives are zero for that choice set.
# @param resp String vector containing input responses
# @param alts String vector containing all possible alternatives. The order
# should be the same as the order of the design matrix.
# @param n.alts The number of alternatives per choice set.
# @param no.choice Logical value indicating whether a no.choice option is
# provided or not. The default = \code{FALSE}.
# @return A binary response vector with length equal to \code{length(resp) *
# length(n.alts)}.
# @examples
# \dontrun{
# # Observed Responses
# resp <- c("alt1", "alt3", "alt2", "no.choice", "alt1")
# # All possible alternatives
# alts <- c("no.choice", "alt1", "alt2", "alt3")
# # 3 alternatives + no.choice
# Charbin(resp = resp, alts = alts, n.alts = 3, no.choice = TRUE)
# }
Charbin <- function (resp, alts, n.alts, no.choice = FALSE) {
# Error resp not in altsions
if (!all(resp %in% alts)) {
stop("1 or more responses do not match the possible response options.")
}
# Error altsions
if (length(alts) != (n.alts + no.choice)) {
stop("Number of response options is not correct")
}
map <- match(resp, alts)
l <- list()
for(i in 1:length(map)){
l[[i]] <- rep(0, n.alts)
if (no.choice) {
l[[i]][map[i] - 1] <- 1
} else {
l[[i]][map[i]] <- 1
}
}
v <- unlist(l)
return(v)
}
# Function to save the data gathered by shiny app
saveData <- function(data, data.dir, n.atts) {
# Data manipulation
d <- as.data.frame(cbind(data$desing, resp = data$bin.responses))
unc_resp <- rep(data$responses, each = n.atts)
unc_setnr <- rep(1:length(data$responses), each = n.atts)
unc_d <- cbind(set = unc_setnr, data$survey, resp = unc_resp)
# Create unique file names
numname <- sprintf("%s_num_data.txt", as.integer(Sys.time()))
charname <- sprintf("%s_char_data.txt", as.integer(Sys.time()))
# Write files to data.dir
utils::write.table(
x = d,
file = file.path(data.dir, numname),
row.names = TRUE, quote = FALSE, sep = "\t", col.names = NA
)
utils::write.table(
x = unc_d,
file = file.path(data.dir, charname),
row.names = TRUE, quote = FALSE, sep = "\t", col.names = NA
)
}
#' Load numeric choice data from directory
#'
#' Reads all individual choice data files, created by \code{\link{SurveyApp}}
#' function, from a directory and concatenates
#' those files into a single data file. Files containing either "num" or "char"
#' will be read, with num indicating numeric data and char indicating character
#' data. For more information, see output of \code{\link{SurveyApp}}.
#'
#' @param data.dir A character string containing the directory to read from.
#' @param type Character vector containing either num or char.
#' @return A data frame containg the full design and all the responses of the
#' combined data files that were found. Different files are indicated by an
#' ID variable.
#' @export
LoadData <- function(data.dir, type) {
# ErrorS
if(!type %in% c("num", "char")){
stop("'type' must be either num or char")
}
if (!dir.exists(data.dir)) {
stop("Directory 'data.dir' does not exist")
}
error <- character(0)
if(identical(list.files(data.dir, full.names = TRUE, pattern = type), error)){
stop("No files of the specified 'type' in 'data.dir'")
}
# Read all files into list
files <- list.files(data.dir, full.names = TRUE, pattern = type)
data <- lapply(files, utils::read.table, stringsAsFactors = FALSE, sep = '\t', header = TRUE)
# check same col
ncols <- unlist(lapply(data, function(x) return(ncol(x))))
if(!isTRUE(all.equal(min(ncols), max(ncols)))){
stop("'data.dir'contains files with different number of columns")
}
# matrix
id_rows <- sapply(data, nrow)
id <- rep(1:length(id_rows), id_rows)
data <- lapply(data, as.data.frame)
# Bind together
data <- do.call(rbind, data)
data <- cbind("ID" = id, data)
return(data)
}
traets/idefix documentation built on April 7, 2022, 1:56 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions LoadData saveData Decode SurveyApp
Documented in Decode LoadData SurveyApp
#'Shiny application to generate a discrete choice survey.
#'
#'This function starts a shiny application which puts choice sets on screen and
#'saves the responses. The complete choice design can be provided in advance, or
#'can be generated sequentially adaptively, or can be a combination of both.
#'
#'A pregenerated design can be specified in \code{des}. This should be a matrix
#'in which each row is a profile. This can be generated with \code{\link{Modfed}}
#'or \code{\link{CEA}}, but it is not necessary.
#'
#'If \code{n.total} = \code{nrow(des)} / \code{length(alts)}, the specified
#'design will be put on screen, one set after the other, and the responses will
#'be saved. If \code{n.total} > (\code{nrow(des)} / \code{length(alts)}), first
#'the specified design will be shown and afterwards the remaining sets will be
#'generated adaptively. If \code{des} = \code{NULL}, \code{n.total} sets will be
#'generated adaptively. See \code{\link{SeqMOD}} for more information on adaptive
#'choice sets.
#'
#'Whenever adaptive sets will be generated, \code{prior.mean},
#'\code{prior.covar}, \code{cand.set} and \code{n.draws}, should be specified.
#'These arguments are necessary for the underlying importance sampling algorithm
#'to update the prior preference distribution. \code{lower} and \code{upper} can
#'be used to specify lower and upper truncation points. See
#'\code{\link{ImpsampMNL}} for more details.
#'
#'The names specified in \code{alts} will be used to label the choice
#'alternatives. The names specified in \code{atts} will be used to name the
#'attributes in the choice sets. The values of \code{lvl.names} will be used to
#'create the values in the choice sets. See \code{\link{Decode}} for more
#'details.
#'
#'The text specified in \code{buttons.text} will be displayed above the buttons
#'to indicate the preferred choice (for example: "indicate your preferred
#'choice"). The text specified in \code{intro.text} will be displayed before the
#'choice sets. This will generally be a description of the survey and some
#'instructions. The text specified in \code{end.text} will be displayed after
#'the survey. This will generally be a thanking note and some further
#'instructions.
#'
#'A no choice alternative is coded as an alternative with 1 alternative specific
#'constant and zero's for all other attribute levels. If a no choice alternative
#'is present in \code{des}, or is desired when generating adaptive choice sets,
#'\code{no.choice} should be specified. This should be done with an integer,
#'indicating which alternative is the no choice option. This alternative will
#'not be presented on screen, but the option to select "no choice" will be. The
#'\code{alt.cte} argument should be specified accordingly, namely with a
#'\code{1} on the location of the \code{no.choice} option. See examples for
#' illustration.
#'
#'When \code{parallel} is \code{TRUE}, \code{\link[parallel]{detectCores}} will
#'be used to decide upon the number of available cores. That number minus 1
#'cores will be used to search for the optimal adaptive choice set. For small problems
#'(6 parameters), \code{parallel = TRUE} can be slower. For larger problems the
#'computation time will decrease significantly.
#'
#'When \code{reduce = TRUE}, the set of all potential choice sets will be
#'reduced to choice sets that have a unique information matrix. If no
#'alternative specific constants are used, \code{reduce} should always be
#'\code{TRUE}. When alternative specific constants are used \code{reduce} can be
#'\code{TRUE} so that the algorithm will be faster, but the combinations of
#'constants and profiles will not be evaluated exhaustively.
#'
#'@param alts A character vector containing the names of the alternatives.
#'@param atts A character vector containing the names of the attributes.
#'@param n.total A numeric value indicating the total number of choice sets.
#'@param buttons.text A string containing the text presented together with the
#' option buttons.
#'@param no.choice An integer indicating which alternative should be a no choice
#' alternative. The default is \code{NULL}.
#'@param intro.text A string containing the text presented before the choice
#' survey.
#'@param end.text A string containing the text presented after the choice
#' survey.
#'@param data.dir A character string with the directory denoting where the data
#' needs to be written. The default is NULL
#'@inheritParams Decode
#'@inheritParams Modfed
#'@inheritParams Profiles
#'@inheritParams SeqMOD
#'@inheritParams ImpsampMNL
#'@importFrom Rdpack reprompt
#'@references \insertRef{ju}{idefix}
#'@return After completing the survey, two text files can be found in
#' \code{data.dir}. The file with "num" in the filename is a matrix with the
#' numeric choice data. The coded design matrix ("par"), presented during the
#' survey, together with the observed responses ("resp") can be found here.
#' Rownames indicate the setnumbers. The file with "char" in the filename is a
#' matrix with character choice data. The labeled design matrix ("par"),
#' presented during the survey, together with the observed responses ("resp")
#' can be found here. See \code{\link{LoadData}} to load the data.
#' @examples
#' \dontrun{
#'#### Present choice design without adaptive sets (n.total = sets in des)
#'# example design
#'data("example_design") # pregenerated design
#'xdes <- example_design
#'### settings of the design
#'code <- c("D", "D", "D")
#'n.sets <- 8
#'# settings of the survey
#'alternatives <- c("Alternative A", "Alternative B")
#'attributes <- c("Price", "Time", "Comfort")
#'labels <- vector(mode="list", length(attributes))
#'labels[[1]] <- c("$10", "$5", "$1")
#'labels[[2]] <- c("20 min", "12 min", "3 min")
#'labels[[3]] <- c("bad", "average", "good")
#'i.text <- "Welcome, here are some instructions ... good luck!"
#'b.text <- "Please choose the alternative you prefer"
#'e.text <- "Thanks for taking the survey"
#'dataDir <- getwd()
#'# Display the survey
#'SurveyApp (des = xdes, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text)
#'
#' #### Present choice design with partly adaptive sets (n.total > sets in des)
#' # example design
#' data("example_design") # pregenerated design
#' xdes <- example_design
#' ### settings of the design
#' code <- c("D", "D", "D")
#' n.sets <- 12
#' # settings of the survey
#' alternatives <- c("Alternative A", "Alternative B")
#' attributes <- c("Price", "Time", "Comfort")
#' labels <- vector(mode="list", length(attributes))
#' labels[[1]] <- c("$10", "$5", "$1")
#' labels[[2]] <- c("20 min", "12 min", "3 min")
#' labels[[3]] <- c("bad", "average", "good")
#' i.text <- "Welcome, here are some instructions ... good luck!"
#' b.text <- "Please choose the alternative you prefer"
#' e.text <- "Thanks for taking the survey"
#' # setting for adaptive sets
#' levels <- c(3, 3, 3)
#' cand <- Profiles(lvls = levels, coding = code)
#' p.mean <- c(0.3, 0.7, 0.3, 0.7, 0.3, 0.7)
#' p.var <- diag(length(p.mean))
#' dataDir <- getwd()
#' # Display the survey
#' SurveyApp(des = xdes, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' prior.mean = p.mean, prior.covar = p.var, cand.set = cand,
#' n.draws = 50)
#'
#'#### Choice design with only adaptive sets (des=NULL)
#'# setting for adaptive sets
#'levels <- c(3, 3, 3)
#'p.mean <- c(0.3, 0.7, 0.3, 0.7, 0.3, 0.7)
#'low = c(-Inf, -Inf, -Inf, 0, 0, -Inf)
#'up = rep(Inf, length(p.mean))
#'p.var <- diag(length(p.mean))
#'code <- c("D", "D", "D")
#'cand <- Profiles(lvls = levels, coding = code)
#'n.sets <- 12
#'# settings of the survey
#'alternatives <- c("Alternative A", "Alternative B")
#'attributes <- c("Price", "Time", "Comfort")
#'labels <- vector(mode="list", length(attributes))
#'labels[[1]] <- c("$10", "$5", "$1")
#'labels[[2]] <- c("20 min", "12 min", "3 min")
#'labels[[3]] <- c("bad", "average", "good")
#'i.text <- "Welcome, here are some instructions ... good luck!"
#'b.text <- "Please choose the alternative you prefer"
#'e.text <- "Thanks for taking the survey"
#'dataDir <- getwd()
#'# Display the survey
#'SurveyApp(des = NULL, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' prior.mean = p.mean, prior.covar = p.var, cand.set = cand,
#' lower = low, upper = up, n.draws = 50)
#' # If CEA algorithm is desired, cand.set argument is not needed
#'SurveyApp(des = NULL, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' prior.mean = p.mean, prior.covar = p.var,
#' lower = low, upper = up, n.draws = 50)
#'
#'#### Present choice design with a no choice alternative.
#'# example design
#'data("nochoice_design") # pregenerated design
#'xdes <- nochoice_design
#'### settings of the design
#'code <- c("D", "D", "D")
#'n.sets <- 8
#'# settings of the survey
#'alternatives <- c("Alternative A", "Alternative B", "None")
#'attributes <- c("Price", "Time", "Comfort")
#'labels <- vector(mode = "list", length(attributes))
#'labels[[1]] <- c("$10", "$5", "$1")
#'labels[[2]] <- c("20 min", "12 min", "3 min")
#'labels[[3]] <- c("bad", "average", "good")
#'i.text <- "Welcome, here are some instructions ... good luck!"
#'b.text <- "Please choose the alternative you prefer"
#'e.text <- "Thanks for taking the survey"
#'
#'# Display the survey
#'SurveyApp(des = xdes, n.total = n.sets, alts = alternatives,
#' atts = attributes, lvl.names = labels, coding = code,
#' buttons.text = b.text, intro.text = i.text, end.text = e.text,
#' no.choice = 3, alt.cte = c(0, 0, 1))
#'}
#'@import shiny
#'@export
SurveyApp <- function(des = NULL, n.total, alts, atts, lvl.names, coding,
alt.cte = NULL, no.choice = NULL,
buttons.text, intro.text, end.text, data.dir = NULL,
c.lvls = NULL, prior.mean = NULL,
prior.covar = NULL, cand.set = NULL, n.draws = NULL,
lower = NULL, upper = NULL, parallel = TRUE, reduce = TRUE) {
# Initialize
algorithm = "MOD"
sdata <- vector(mode = "list")
surveyData <- vector(mode = "list")
y.bin <- vector("numeric")
resp <- vector("character")
n.atts <- length(atts)
n.alts <- length(alts)
n.levels <- as.vector(unlist(lapply(lvl.names,length)))
choice.sets <- matrix(data = NA, nrow = n.total * n.alts, ncol = n.atts)
buttons <- NULL
sn <- 0
if (is.null(des)) {
n.init <- 0
} else {
n.init <- nrow(des) / n.alts
if (!isTRUE(all.equal(n.init, as.integer(n.init)))) {
stop("the number of rows of 'des' are not a multiple of length(alts)")
}
}
if (is.null(alt.cte) || all(alt.cte == 0)) {
alt.cte <- rep(0, n.alts)
n.cte <- 0
cte.des <- NULL
} else {
# Error
if (length(alt.cte) != n.alts) {
stop("length(alts) does not match length(alt.cte)")
}
if (!all(alt.cte %in% c(0, 1))) {
stop("'alt.cte' should only contain 0's or 1's.")
}
if (!any(alt.cte == 0)) {
stop("'alt.cte' should at least contain 1 zero")
}
n.cte <- sum(alt.cte)
if (!is.null(des)) {
cte.des <- Altspec(alt.cte = alt.cte, n.sets = n.init)
if (!isTRUE(all.equal(cte.des, matrix(des[ , 1:n.cte], ncol = n.cte)))) {
stop("the first column(s) of 'des' are different from what is expected based on 'alt.cte'")
}
}
}
# Error handling
if (!is.null(no.choice)) {
if (!is.numeric(no.choice)) {
stop("'no.choice' should be an integer indicating the no choice alternative.")
}
if (!no.choice %% 1 == 0) {
stop("'no.choice' should be an integer")
}
if (any(isTRUE(no.choice > (n.alts + 0.2)), isTRUE(no.choice < 0.2))) {
stop("'no.choice' does not indicate one of the alternatives")
}
if (!isTRUE(all.equal(alt.cte[no.choice], 1))) {
stop("the location of the 'no.choice' option in the 'alt.cte' vector should correspond with 1")
}
}
if (!is.null(data.dir)) {
if (!dir.exists(data.dir)) {
stop("Directory 'data.dir' does not exist")
}
}
if (n.total > n.init) {
if (is.null(lower)) {
lower <- rep(-Inf, length(prior.mean))
}
if (is.null(upper)) {
upper <- rep(Inf, length(prior.mean))
}
if (!any(c(isTRUE(all.equal(length(prior.mean), length(lower))), isTRUE(all.equal(length(prior.mean), length(upper)))))) {
stop("length 'prior.mean' should equal 'upper' and 'lower'")
}
if (algorithm == "MOD") {
if (any(c(is.null(prior.mean), is.null(prior.covar), is.null(cand.set),
is.null(n.draws)))) {
stop("When n.total is larger than the number of sets in argument des, arguments prior.mean, prior.covar, cand.set and n.draws should be specified.")
}
if (length(prior.mean) != ncol(cand.set) + sum(alt.cte)) {
stop("Number of parameters in prior.mean does not match with cand.set + alt.cte")
}
} else if (algorithm == "CEA") {
if (any(c(is.null(prior.mean), is.null(prior.covar), is.null(n.draws)))) {
stop("When n.total is larger than the number of sets in argument des, arguments prior.mean, prior.covar and n.draws should be specified.")
}
}
if (!isTRUE(all.equal(length(prior.mean), ncol(prior.covar)))) {
stop("length of 'prior.mean' differs from number of columns 'prior.covar'")
}
} else {
if (!is.null(prior.mean)) {
warning("'prior.mean' will be ignored, since there are no adaptive sets.")
}
if (!is.null(prior.covar)) {
warning("'prior.covar' will be ignored, since there are no adaptive sets.")
}
if (algorithm == "MOD" & !is.null(cand.set)) {
warning("'cand.set' will be ignored, since there are no adaptive sets.")
}
if (!is.null(lower) || !is.null(upper)) {
warning("'lower' and 'upper' bound will be ignored, since there are no adaptive sets.")
}
if (!is.null(n.draws)) {
warning("'n.draws' will be ignored, since there are no adaptive sets.")
}
}
if (is.null(des)) {
if (algorithm == "MOD") {
fulldes <- matrix(data = NA, nrow = (n.alts * n.total), ncol = ncol(cand.set))
} else {
fulldes <- matrix()
}
} else {
bs <- seq(1, (nrow(des) - n.alts + 1), n.alts)
es <- c((bs - 1), nrow(des))[-1]
rowcol <- Rcnames(n.sets = n.init, n.alts = n.alts, alt.cte = alt.cte,
no.choice = FALSE)
rownames(des) <- rowcol[[1]]
if (is.null(colnames(des))) {
colnames(des) <- c(rowcol[[2]], paste("par", 1:(ncol(des) - n.cte),
sep = "."))
}
fulldes <- des
# Error handling
if (length(bs) != n.init) {
stop("The number of rows in 'des' is not a multiple of length(atts)")
}
if ("no.choice.cte" %in% colnames(des)) {
if (is.null(no.choice)) {
warning("no.choice.cte column name detected in 'des' while 'no.choice = NULL'")
}
}
}
if (!(algorithm %in% c("MOD","CEA"))) {
stop("algorithm should be 'MOD' or 'CEA'")
}
shinyApp(
### User interface
ui <- fluidPage(
# Put setnr on screen
column(8, align = 'center', textOutput("set.nr")),
# Put design on screen
column(8, align = 'center', tableOutput("choice.set")),
# Put answer options on screen
column(8, align = 'center', uiOutput('buttons')),
# put introtext on screen
column(8, align = 'center', textOutput('intro')),
# Put action button on screen
column(8, align = "center", actionButton("OK", "OK")),
# put end text on screen
column(8, align = 'center', textOutput('end'))
),
### Server
server <- function(input, output) {
# Count set number
observeEvent(input$OK, {
sn <<- sn + 1
})
# Set selection function
Select <- function() {
if (sn <= n.total) {
# for initial sets
if (sn <= n.init) {
set <- des[bs[sn]:es[sn], ]
} else {
## sample drawing for adaptive sets
# if First set
if (sn == 1) {
# sample draws from prior
s <- tmvtnorm::rtmvnorm(n = n.draws, mean = prior.mean,
sigma = prior.covar, lower = lower,
upper = upper)
w <- rep(1, nrow(s)) / nrow(s)
if (sum(alt.cte) > 0.2) {
s <- list(as.matrix(s[ , 1:sum(alt.cte)], ncol = sum(alt.cte)),
s[ , -c(1:sum(alt.cte))])
}
# From second set
} else {
# Sample draws from updated posterior
sam <- ImpsampMNL(n.draws = n.draws, prior.mean = prior.mean,
prior.covar = prior.covar,
des = fulldes, n.alts = n.alts, y = y.bin,
alt.cte = alt.cte, lower = lower, upper = upper)
s <- sam$sample
w <- sam$weights
}
## Selecting set
if (algorithm == "MOD") {
# Select new set based on Modfed
setobj <- SeqMOD(des = des, cand.set = cand.set, n.alts = n.alts,
par.draws = s, prior.covar = prior.covar,
alt.cte = alt.cte, weights = w,
no.choice = no.choice, parallel = parallel,
reduce = reduce)
} else if (algorithm == "CEA") {
setobj <- SeqCEA(des = des, lvls = n.levels, coding = coding,
n.alts = n.alts, par.draws = s,
prior.covar = prior.covar, alt.cte = alt.cte,
weights = w, no.choice = no.choice,
parallel = parallel, reduce = reduce)
}
set <- setobj$set
db <- setobj$db
## Design storage
if (sn == 1) {
rowcol <- Rcnames(n.sets = 1, n.alts = n.alts, alt.cte = alt.cte, no.choice = FALSE)
rownames(set) <- rownames(set, do.NULL = FALSE, prefix = paste(paste("set", sn , sep = ""), "alt", sep = "."))
colnames(set) <- c(rowcol[[2]], paste("par", 1:(ncol(set) - n.cte), sep = "."))
fulldes <<- set
} else {
rowcol <- Rcnames(n.sets = 1, n.alts = n.alts, alt.cte = alt.cte, no.choice = FALSE)
rownames(set) <- rownames(set, do.NULL = FALSE, prefix = paste(paste("set", sn , sep = ""), "alt", sep = "."))
colnames(set) <- c(rowcol[[2]], paste("par", 1:(ncol(set) - n.cte), sep = "."))
fulldes <<- rbind(fulldes, set)
}
}
# Transform coded set to attribute level character set.
choice.set <- Decode(des = set, n.alts = n.alts, lvl.names = lvl.names, coding = coding,
alt.cte = alt.cte, c.lvls = c.lvls, no.choice = no.choice)[[1]]
choice.set <- t(choice.set[ , 1:n.atts])
# Fill in attribute names and alternatives names
colnames(choice.set) <- alts
rownames(choice.set) <- atts
# Store uncoded choice set
if (sn == 1) {
choice.sets <<- choice.set
} else {
choice.sets <<- rbind(choice.sets, choice.set)
}
#return design
if (!is.null(no.choice)) {
no.choice.set <- choice.set[ ,-no.choice]
return(no.choice.set)
} else {
return(choice.set)
}
}
}
#When action button is clicked
observeEvent(input$OK, {
# survey phase
if (sn <= n.total ) {
# Plot new choice set
output$choice.set <- renderTable(Select(), rownames = TRUE)
}
# Store responses and design
if (sn > 1 && sn <= (n.total + 1)) {
resp <<- c(resp, input$survey)
y.bin <<- Charbin(resp = resp, alts = alts, n.alts = n.alts)
sdata[["bin.responses"]] <- y.bin
sdata[["responses"]] <- resp
sdata[["desing"]] <- fulldes
sdata[["survey"]] <- choice.sets
surveyData <<- sdata
}
# end phase
if (sn > n.total) {
#Don't show choice set
output$choice.set <- renderTable(NULL)
}
})
#Output response options after first action button click
output$buttons <- renderUI({
# radiobuttons
if (input$OK > 0 && input$OK <= n.total) {
return(list(radioButtons("survey", buttons.text,
alts , inline = TRUE, selected = "None")))
}
})
# set nr
observeEvent(input$OK, {
if (sn < n.total) {
output$set.nr <- renderText(paste(c("choice set:", sn, "/", n.total)))
} else {output$set.nr <- renderText(NULL)}
})
# Introtext
output$intro <- renderText(intro.text)
observeEvent(input$OK, {
output$intro <- renderText(NULL)
})
# End of survey
observeEvent(input$OK, {
# Display end text
if (input$OK > n.total) {
# Display end text
output$end <- renderText(end.text)
}
# Quit application
if (input$OK > (n.total + 1)) {
# Write data to file
if (!is.null(data.dir)) {
saveData(data = surveyData, data.dir = data.dir, n.atts = n.atts)
}
# Stop application
stopApp()
}
})
}
)
}
#' Coded design to readable design.
#'
#' Transforms a coded design matrix into a design containing character attribute
#' levels, ready to be used in a survey. The frequency of each attribute level
#' in the design is also included in the output.
#'
#' \code{des} A design matrix, this can also be a single choice set. See for
#' example the output of \link[idefix]{Modfed} or \link[idefix]{CEA}.
#'
#' In \code{lvl.names}, the number of character vectors in the list should equal
#' the number of attributes in de choice set. The number of elements in each
#' character vector should equal the number of levels for that attribute.
#'
#' Valid arguments for \code{coding} are \code{C}, \code{D} and \code{E}. When
#' using \code{C} the attribute will be treated as continuous and no coding will
#' be applied. All possible levels of that attribute should then be specified in
#' \code{c.lvls}. If \code{D} (dummy coding) is used
#' \code{\link{contr.treatment}} will be applied to that attribute. The first
#' attribute wil be used as reference level. For \code{E} (effect coding)
#' \code{\link{contr.sum}} is applied, in this case the last attribute level is
#' used as reference level.
#'
#' If \code{des} contains columns for alternative specific constants,
#' \code{alt.cte} should be specified. In this case, the first column(s) (equal
#' to the number of nonzero elements in \code{alt.cte}) will be removed from
#' \code{des} before decoding the alternatives.
#'
#' @param des A numeric matrix which represents the design matrix. Each row is a
#' profile.
#' @param lvl.names A list containing character vectors with the values of each
#' level of each attribute.
#' @param coding A character vector denoting the type of coding used for each
#' attribute. See also \code{\link[idefix]{Profiles}}.
#' @param alt.cte A binary vector indicating for each alternative if an
#' alternative specific constant is present. The default is \code{NULL}.
#' @param no.choice An integer indicating the no choice alternative. The default
#' is \code{NULL}.
#' @inheritParams Profiles
#' @inheritParams Modfed
#' @return \item{design}{A character matrix which represents the design.}
#' \item{lvl.balance}{A list containing the frequency of appearance of each
#' attribute level in the design.}
#' @examples
#' \dontrun{
#' # Example without continuous attributes.
#' design <- example_design
#' coded <- c("D", "D", "D") # Coding.
#' # Levels as they should appear in survey.
#' al <- list(
#' c("$50", "$75", "$100"), # Levels attribute 1.
#' c("2 min", "15 min", "30 min"), # Levels attribute 2.
#' c("bad", "moderate", "good") # Levels attribute 3.
#' )
#' # Decode
#' Decode(des = design, n.alts = 2, lvl.names = al, coding = coded)
#'
#' # Example with alternative specific constants
#' design <- example_design2
#' coded <- c("D", "D", "D") # Coding.
#' # Levels as they should appear in survey.
#' al <- list(
#' c("$50", "$75", "$100"), # Levels attribute 1.
#' c("2 min", "15 min", "30 min"), # Levels attribute 2.
#' c("bad", "moderate", "good") # Levels attribute 3.
#' )
#' # Decode
#' Decode(des = design, n.alts = 3, lvl.names = al, coding = coded, alt.cte = c(1, 1, 0))
#' }
#' @export
Decode <- function(des, n.alts, lvl.names, coding, alt.cte = NULL, c.lvls = NULL, no.choice = NULL) {
n.sets <- nrow(des) / n.alts
if(!isTRUE(all.equal(n.sets %% 1, 0))){
stop("'n.alts' does not seem correct based on nrow(des)")
}
if(!is.list(lvl.names)){
stop("'lvl.names' should be a list")
}
if(!is.matrix(des)){
stop("'des' should be a matrix")
}
if(!is.null(alt.cte)) {
if(!isTRUE(all.equal(length(alt.cte), n.alts))){
stop("the length of 'alt.cte' does not match 'n.alts'")
}
contins <- which(alt.cte == 1)
if( !length(contins) == 0) {
des <- des[, -(1:length(contins))]
}
}
if(!is.null(no.choice)){
if(!is.numeric(no.choice)){
stop("'no.choice' should be an integer indicating the no choice alternative.")
}
if(!no.choice %% 1 == 0){
stop("'no.choice' should be an integer")
}
if(any(isTRUE(no.choice > (n.alts + 0.2)), isTRUE(no.choice < 0.2))){
stop("'no.choice' does not indicate one of the alternatives")
}
if(!isTRUE(all.equal(alt.cte[no.choice], 1))){
stop("the location of the 'no.choice' option in the 'alt.cte' vector should correspond with 1")
}
ncsek <- 1:nrow(des)
ncsek <- ncsek[-seq(no.choice, (n.sets * no.choice), no.choice)]
#des <- des[-ncsek, ]
} else {
ncsek <- 1:nrow(des)
}
N.alts <- nrow(des) # Number of total alternatives.
n.att <- length(lvl.names) # Number of attributes.
conts <- which(coding == "C") # Continuous levels.
# Create vector where each element denotes the number of levels for each attribute.
lvls <- numeric(n.att)
for (i in 1:n.att) {
lvls[i] <- length(lvl.names[[i]])
}
# Generate all possible profiles coded and uncoded
dc <- Profiles(lvls = lvls, coding = coding, c.lvls = c.lvls)
# Create uncoded grid.
d <- as.data.frame(expand.grid(lvl.names))
# Create new matrix for choice des with attribute level names
m <- matrix(data = NA, nrow = N.alts, ncol = n.att)
# Error handling
if (ncol(des) != ncol(dc)) {
stop("ncol(des) does not equal the expected number based on 'lvl.names' and 'alt.cte'.")
}
# For each alternative look for matching profile
for (i in ncsek) {
# if coded choice des, look for match in coded version first, then take uncoded equivalent.
lev.num <- d[as.numeric(which(apply(dc, 1, function(x) all(x == des[i, ])))), ]
lev.num <- as.numeric(lev.num)
# Error handling
if (any(is.na(lev.num))) {
stop("alternatives detected that do not match with the type of 'coding' provided.
Make sure 'no.choice' is specified if applicable.")
}
# For each attribute fill in the attribute level name
for (c in 1:n.att) {m[i, c] <- lvl.names[[c]][lev.num[c]]}
}
#frequency levels
ml <- list()
ml <- split(m, rep(1:ncol(m), each = nrow(m)))
lvl.balance <- lapply(ml, table)
names(lvl.balance) <- paste("attribute", 1:length(coding), "")
#col row names names
rownames(m) <- rownames(des)
return(list("design" = as.data.frame(m), "lvl.balance" = lvl.balance))
}
# Character vector to binary vector.
#
# Transforms a character vector with responses into a binary vector. Each
# alternative in each choice set wil be either 0 or 1. If the
# alternative was not chosen 0, and 1 if it was. The function can be used for example in a
# shiny application to transform the response vector received from
# \code{\link[shiny]{radioButtons}} into a numeric vector that can be used for
# estimation.
#
# The \code{n.alts} denotes the number of alternatives a respondent could
# choose from, without counting a possible no choice option.
#
# If \code{no.choice} is \code{TRUE} the first alternative specified in
# \code{alts} will be treated as a no choice option. If the no choice option
# was chosen all alternatives are zero for that choice set.
# @param resp String vector containing input responses
# @param alts String vector containing all possible alternatives. The order
# should be the same as the order of the design matrix.
# @param n.alts The number of alternatives per choice set.
# @param no.choice Logical value indicating whether a no.choice option is
# provided or not. The default = \code{FALSE}.
# @return A binary response vector with length equal to \code{length(resp) *
# length(n.alts)}.
# @examples
# \dontrun{
# # Observed Responses
# resp <- c("alt1", "alt3", "alt2", "no.choice", "alt1")
# # All possible alternatives
# alts <- c("no.choice", "alt1", "alt2", "alt3")
# # 3 alternatives + no.choice
# Charbin(resp = resp, alts = alts, n.alts = 3, no.choice = TRUE)
# }
Charbin <- function (resp, alts, n.alts, no.choice = FALSE) {
# Error resp not in altsions
if (!all(resp %in% alts)) {
stop("1 or more responses do not match the possible response options.")
}
# Error altsions
if (length(alts) != (n.alts + no.choice)) {
stop("Number of response options is not correct")
}
map <- match(resp, alts)
l <- list()
for(i in 1:length(map)){
l[[i]] <- rep(0, n.alts)
if (no.choice) {
l[[i]][map[i] - 1] <- 1
} else {
l[[i]][map[i]] <- 1
}
}
v <- unlist(l)
return(v)
}
# Function to save the data gathered by shiny app
saveData <- function(data, data.dir, n.atts) {
# Data manipulation
d <- as.data.frame(cbind(data$desing, resp = data$bin.responses))
unc_resp <- rep(data$responses, each = n.atts)
unc_setnr <- rep(1:length(data$responses), each = n.atts)
unc_d <- cbind(set = unc_setnr, data$survey, resp = unc_resp)
# Create unique file names
numname <- sprintf("%s_num_data.txt", as.integer(Sys.time()))
charname <- sprintf("%s_char_data.txt", as.integer(Sys.time()))
# Write files to data.dir
utils::write.table(
x = d,
file = file.path(data.dir, numname),
row.names = TRUE, quote = FALSE, sep = "\t", col.names = NA
)
utils::write.table(
x = unc_d,
file = file.path(data.dir, charname),
row.names = TRUE, quote = FALSE, sep = "\t", col.names = NA
)
}
#' Load numeric choice data from directory
#'
#' Reads all individual choice data files, created by \code{\link{SurveyApp}}
#' function, from a directory and concatenates
#' those files into a single data file. Files containing either "num" or "char"
#' will be read, with num indicating numeric data and char indicating character
#' data. For more information, see output of \code{\link{SurveyApp}}.
#'
#' @param data.dir A character string containing the directory to read from.
#' @param type Character vector containing either num or char.
#' @return A data frame containg the full design and all the responses of the
#' combined data files that were found. Different files are indicated by an
#' ID variable.
#' @export
LoadData <- function(data.dir, type) {
# ErrorS
if(!type %in% c("num", "char")){
stop("'type' must be either num or char")
}
if (!dir.exists(data.dir)) {
stop("Directory 'data.dir' does not exist")
}
error <- character(0)
if(identical(list.files(data.dir, full.names = TRUE, pattern = type), error)){
stop("No files of the specified 'type' in 'data.dir'")
}
# Read all files into list
files <- list.files(data.dir, full.names = TRUE, pattern = type)
data <- lapply(files, utils::read.table, stringsAsFactors = FALSE, sep = '\t', header = TRUE)
# check same col
ncols <- unlist(lapply(data, function(x) return(ncol(x))))
if(!isTRUE(all.equal(min(ncols), max(ncols)))){
stop("'data.dir'contains files with different number of columns")
}
# matrix
id_rows <- sapply(data, nrow)
id <- rep(1:length(id_rows), id_rows)
data <- lapply(data, as.data.frame)
# Bind together
data <- do.call(rbind, data)
data <- cbind("ID" = id, data)
return(data)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.