Hi everyone, my name is a Gabriele, I'm a new subscriber.
I'm not an R expert but I really need it to create a survey for Stated Preference Experiments (DCE).
Basically I tried to replicate the function SurveyApp of the idefix package creating a shinyapp. However, i have several problems:
1)the app is not able to save responses ( the function SaveData doesn't work) on my directory (both online and offline). The function SurveyApp (offline) normally save a file for every answer and put together autonomously all the answers. This is what i need.
2)I don't know how to make mandatory answers
3)the app doesn't work always online
Thanks in advance for the help.
This is the code:
library(shiny)
library(idefix)
library(obAnalytics)
globalenv()
***#
- creation of design
mu <- c(0.5, 0.8, 0.2,0.4,1.3)
v <- diag(length(mu)) # Prior variance.
set.seed(123)
pd <- MASS::mvrnorm(n = 10, mu = mu, Sigma = v) # 10 draws.
p<-CEA(lvls = c(3, 2, 3,2,4), coding = c("C", "D", "C","D","C"), par.draws = pd,
c.lvls = list(c(4, 6,8),c(1,2,3),c(10,20,40,60)), n.alts = 2, n.sets = 36, parallel = FALSE)
p$design
design_final<-Decode(p$design,lvl.names=list(c("4","6","8"),c("italiano","argentino"),c("1","2","3"),c("alto","basso"),c("10","20","40","60")), n.alts=2, coding=c("C","D","C","D","C"), c.lvls = list(c( 4, 6,8),c(1,2,3),c(10,20,40,60)))
#variables for the survey
z<-c(rep(0,6))
xdes1 <- p$design[1:12,]
n.draws<-10
des<-p$design[1:12,]
lvl.names=list(c("4","6","8"),c("italiano","argentino"),c("1","2","3"),c("alto","basso"),c("10","20","40","60"))
c.lvls = list(c(4,6,8),c(1,2,3),c(10,20,40,60))
cand.set<-Profiles(lvls = c(3, 2, 3,2,4),coding=c("C", "D", "C","D","C"),list(c(4, 6,8),c(1,2,3),c(10,20,40,60)))
n.draws<-10
lower<-NULL
upper<-NULL
parallel<-TRUE
reduce<-TRUE
n.sets<-6
n.total<-n.sets
alts<-c("A","B")
n.alts <-2
sn<-0
n.init <- nrow(des)/n.alts
no.choice<-NULL
bs <- seq(1, (nrow(des) - n.alts + 1), n.alts)
es <- c((bs - 1), nrow(des))[-1]
alt.cte <- NULL
coding <- c("C", "D", "C","D","C")
atts<-c("Price", "Time", "Comfort","City","Year")
n.atts<-length(atts)
surveyData<-list()
sdata<-list()
fulldes<-des
intro.text <- "Welcome, here are some instructions ... good luck!"
buttons.text <- "Please choose the alternative you prefer"
end.text <- "Thanks for taking the survey"
data.dir<-"C:/Users/utente/OneDrive - Universita degli Studi Roma Tre/Desktop/Tesi magistrale/Econometria/Econometria corso/materiale R/DCEs"
n.total<-6
resp <- vector("character")
#Server
server <- function(input,
output) {
observeEvent(input$OK, {
sn <<- sn + 1
})
Select <- function() {
{
if (sn <= n.init) {
set <- des[bs[sn]:es[sn], ]
}
else {
if (sn == 1) {
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))])
}
}
else {
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
}
if (algorithm == "MOD") {
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
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)
}
}
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])
colnames(choice.set) <- alts
rownames(choice.set) <- atts
if (sn == 1) {
choice.sets <<- choice.set
}
else {
choice.sets <<- rbind(choice.sets, choice.set)
}
if (!is.null(no.choice)) {
no.choice.set <- choice.set[, -no.choice]
return(no.choice.set)
}
else {
return(choice.set)
}
}
}
observeEvent(input$OK, {
if (sn <= n.total) {
output$choice.set <- renderTable(Select(), rownames = TRUE)
}
if (sn > 1 && sn <= (n.total + 1)) {
resp <<- c(resp, input$survey)
sdata[["responses"]] <- resp
sdata[["desing"]] <- fulldes
sdata[["survey"]] <- choice.sets
surveyData <<- sdata
}
if (sn > n.total) {
output$choice.set <- renderTable(NULL)
}
})
output$buttons <- renderUI({
if (input$OK > 0 && input$OK <= n.total) {
return(list(radioButtons("survey", buttons.text,
alts, inline = TRUE, selected = "None")))
}
})
observeEvent(input$OK, {
if (sn < n.total) {
output$set.nr <- renderText(paste(c("choice set:",
sn, "/",n.total)))
}
else {
output$set.nr <- renderText(NULL)
}
})
output$intro <- renderText(intro.text)
observeEvent(input$OK, {
output$intro <- renderText(NULL)
})
observeEvent(input$OK, {
if (input$OK > n.total) {
output$end <- renderText(end.text)
}
if (input$OK > (n.total + 1)) {
if (!is.null(data.dir)) {
saveData(data = surveyData, data.dir =data.dir,
n.atts = n.atts)
}
stopApp()
}
})
}
#ui
ui <- fluidPage(column(8, align = "center",
textOutput("set.nr")), column(8, align = "center",
tableOutput("choice.set")), column(8, align = "center",
uiOutput("buttons")), column(8, align = "center",
textOutput("intro")), column(8, align = "center",
actionButton("OK", "OK")), column(8, align = "center",
textOutput("end")))
shinyApp(ui = ui, server = server)