使用包 idefix 创建 R Shinyapp - 在本地工作，但服务器在 Shinyapp.io 服务器上断开连接，没有错误消息
相关标签： # json# 服务器# 服务器# 软件# 软件
我已经解开了 R 包中的代码：idefix 以使用闪亮的应用程序构建离散选择实验设计。这个闪亮的应用程序有两个主要功能：
使用导入的 csv 文件构建设计（初始调查问题）；
根据对初始问题的回答生成额外的调查问题（自适应调查问题）
该代码适用于初始调查问题和自适应问题。但是，只有最初的问题适用于 shinyapps.io 服务器。回答完所有初始问题后，接下来应该会出现自适应问题，但网页显示为灰色并且服务器已断开连接。
我考虑过的一些事情：
存储/读取响应：应用程序只能在服务器上测试初始集时读取、下载、上传响应。相同的代码（用于存储/读取响应）被用作生成自适应问题的函数的输入。
响应时间：我已将 shinyapps.io 上的设置更改为免费闪亮服务器上的最大值，包括连接超时（900 秒）、读取超时（3600 秒）、启动超时（60 秒）、空闲超时（60 秒）。
此外，只需几秒钟即可在本地生成自适应问题。
我已经被这个问题困扰了很长时间......任何帮助将不胜感激！
这是服务器错误日志：
2022-05-30T01:00:33.380293+00:00 shinyapps[6271676]: Running on host: 6ca5a36904c0
2022-05-30T01:00:33.380381+00:00 shinyapps[6271676]: Server version: 2022.03.1
2022-05-30T01:00:33.380507+00:00 shinyapps[6271676]: Working directory: /srv/connect/apps/constructDCE
2022-05-30T01:00:33.380445+00:00 shinyapps[6271676]: LANG: C.UTF-8
2022-05-30T01:00:33.380567+00:00 shinyapps[6271676]: R version: 4.2.0
2022-05-30T01:00:33.380627+00:00 shinyapps[6271676]: shiny version: 1.7.1
2022-05-30T01:00:33.380675+00:00 shinyapps[6271676]: httpuv version: 1.6.5
2022-05-30T01:00:33.380731+00:00 shinyapps[6271676]: rmarkdown version: (none)
2022-05-30T01:00:33.380786+00:00 shinyapps[6271676]: knitr version: 1.39
2022-05-30T01:00:33.380892+00:00 shinyapps[6271676]: RJSONIO version: (none)
2022-05-30T01:00:33.381045+00:00 shinyapps[6271676]: Using pandoc: /opt/connect/ext/pandoc/2.16
2022-05-30T01:00:33.380994+00:00 shinyapps[6271676]: reticulate version: (none)
2022-05-30T01:00:33.380841+00:00 shinyapps[6271676]: jsonlite version: 1.8.0
2022-05-30T01:00:33.381442+00:00 shinyapps[6271676]:
2022-05-30T01:00:33.380941+00:00 shinyapps[6271676]: htmltools version: 0.5.2
2022-05-30T01:00:33.381509+00:00 shinyapps[6271676]: Listening on http://127.0.0.1:40973
2022-05-30T01:00:33.381096+00:00 shinyapps[6271676]: Using jsonlite for JSON processing
2022-05-30T01:00:33.381144+00:00 shinyapps[6271676]:
2022-05-30T01:00:33.381315+00:00 shinyapps[6271676]: Starting R with process ID: '24'
2022-05-30T01:00:33.381382+00:00 shinyapps[6271676]: Shiny application starting ...
另请参阅此应用程序的代码（R软件包idefix“ImpsamMNL”和“SeqMOD”中的函数仅用于生成自适应调查问题）：
library(rdrop2)
library(idefix)
library(shiny)
c.lvls = NULL
lower = NULL
upper = NULL
parallel = TRUE
reduce = TRUE
########################################################################
dat <- read.csv("test1.csv")
des <- dat[,-1]
rownames(des) <- dat[,1]
des <- as.matrix(des)
########################################################################
n.total <- 6 #Adaptive + initial
alts <- c("Alt A", "Alt B","None")
atts <- c("Price", "Time", "Comfort")
alt.cte <- c(0,0,1)
no.choice <- 3
prior.mean <- c(0.7, 0.3, 0.7, 0.3)
prior.covar <- diag(length(prior.mean))
cand.set <- Profiles(lvls=c(2,2,2), coding = c("D","D","D"))
n.draws = 10
lvl.names <- vector(mode = "list", length(atts))
lvl.names[[1]] <- c("$10", "$5")
lvl.names[[2]] <- c("20 min", "12 min")
lvl.names[[3]] <- c("bad", "average")
coding <- c("D", "D", "D")
buttons.text <- "Please choose the alternative you prefer"
intro.text <- "Welcome, here are some instructions ... good luck!"
end.text <- "Thanks for taking the survey"
data.dir <- getwd()
########################################################################
Rcnames <- function(n.sets, n.alts, alt.cte, no.choice)
{
r.s <- rep(1:n.sets, each = n.alts)
r.a <- rep(1:n.alts, n.sets)
r.names <- paste(paste("set", r.s, sep = ""), paste("alt",
r.a, sep = ""), sep = ".")
if (no.choice) {
ncsek <- seq(n.alts, (n.sets * n.alts), n.alts)
r.names[ncsek] <- "no.choice"
}
if (sum(alt.cte) > 0.2) {
cte.names <- paste(paste("alt", which(alt.cte == 1),
sep = ""), ".cte", sep = "")
}
else {
cte.names <- NULL
}
return(list(r.names, cte.names))
}
Altspec <- function (alt.cte, n.sets)
{
mat <- diag(length(alt.cte))
n.zero <- which(alt.cte == 0)
mat[n.zero, n.zero] <- 0
del.col <- c(which(apply(mat, 2, function(x) all(x == 0))))
mat <- mat[, -del.col]
mat <- as.matrix(mat)
cte.mat <- do.call(rbind, replicate(n.sets, mat, simplify = FALSE))
return(cte.mat)
}
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
n.init <- nrow(des)/n.alts
n.cte <- sum(alt.cte)
te.des <- Altspec(alt.cte = alt.cte, n.sets = n.init)
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]]
lower <- rep(-Inf, length(prior.mean))
upper <- rep(Inf, length(prior.mean))
fulldes <- des
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")))
server <- function(input, output,session) {
observeEvent(input$OK, {
sn <<- sn + 1
})
Select <- function() {
if (sn <= n.total) {
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 <- idefix::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 <- idefix::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)
}
}
}
Charbin <- function (resp = resp, alts = alts, n.alts = n.alts, no.choice)
{
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)
}
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)
y.bin <<- Charbin(resp = resp, alts = alts, n.alts = n.alts,no.choice=no.choice)
sdata[["bin.responses"]] <- y.bin
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)
})
saveData <- function (data, data.dir, n.atts)
{
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)
numname <- sprintf("%s_num_data.txt", as.integer(Sys.time()))
charname <- sprintf("%s_char_data.txt", as.integer(Sys.time()))
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)
drop_upload(file.path(data.dir, numname),path="idefix")
drop_upload(file.path(data.dir,charname),path="idefix")
}
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()
}
})
}
shinyApp(ui=ui,server=server)
特别声明：以上内容（图片及文字）均为互联网收集或者用户上传发布，本站仅提供信息存储服务！如有侵权或有涉及法律问题请联系我们。
举报
