作为用户界面的一部分，用户选择一组位于三级深度列表结构底部的模型参数。
在服务器端，我使用
observe({
updateSelectInput(session, 'level1', choices = attributes(model[[input$toplevel]]))
})
observe({
updateSelectInput(session, 'level2', choices = attributes(model[[input$toplevel]][[input$level1]]))
})
在ui selectInput部分中选择level1，level2设置为NULL。这会将选择框更新为仅适用于上述选择级别的相应属性。
保存的长URL名称确实包含所选的level1和level2选项。但是在使用时，总是只使用属性列表的顶部进行顶层选择的两个深层次。
有一个聪明的方法吗？我假设它是selectInput的selected =的一些用法，但我似乎正在绊倒，无法发现正确的语法，即所谓的输入$ level1和输入$ level2在服务器端。
感谢
答案 0 :(得分：1)
shinyURL 初始化用户输入是通过将URL查询字符串中的名称与input中的名称相匹配来执行的。您的应用中发生的情况是，所有selectInput在开始时都由 shinyURL 同时设置，但此更改会触发观察者执行，从而将输入重置为默认值。
您可以使用函数renderUI动态渲染第2级和第3级输入来避免这种情况。这将允许延迟初始化，因为 shinyURL 等待设置输入直到它们可用。请参阅下面的示例，了解此方法的说明。
library(shiny)
library(shinyURL)
data = list(
A = list(
a = as.list(1:3),
b = as.list(4:6),
c = as.list(7:9)
),
B = list(
d = as.list(1:3),
e = as.list(4:6),
f = as.list(7:9)
)
)
ui <- shinyUI(fluidPage(
# Application title
titlePanel("Dynamic UI"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput("toplevel", "Nested List", choices = names(data)),
uiOutput("s1"),
uiOutput("s2"),
shinyURL.ui()
),
mainPanel(
h2("Selected level"),
textOutput("selectedLevel")
)
)
))
server <- shinyServer(function(input, output) {
shinyURL.server()
output$s1 = renderUI(selectInput("lvl1",
label = NULL,
choices = names(data[[input$toplevel]])))
output$s2 = renderUI({
req(input$lvl1)
selectInput("lvl2",
label = NULL,
choices = data[[input$toplevel]][[input$lvl1]])
})
output$selectedLevel = renderText(
paste(input$toplevel, input$lvl1, input$lvl2, sep = " > ")
)
})
# Run the application
shinyApp(ui = ui, server = server)
仅当用户切换到包含输入的选项卡时，才会初始化由renderUI动态呈现并放置在不同选项卡上的输入的原因如下：呈现的outputUI接口元素此类输入是输出对象，因此默认情况下在网页上隐藏它们时会被禁用。
解决方案是为每个相应的suspendWhenHidden = FALSE元素调用outputOptions设置outputUI选项。
我已将Ken O＆＃39; Brien提供的修改后的示例上传到https://gist.github.com/aoles/a68892717c0280647455。它可以从R运行
shiny::runGist("a68892717c0280647455")
请注意，我已对原始示例进行了一些小改进：
attributes() names()的来电
req() id参数添加到tabsetPanel以允许还原它们ui.R和server.R中的一些常用部分包含在函数答案 1 :(得分：0)
@aoles
我的第一个答案是我的观察起点。把它放在一起我发现了一个有趣的细节。调用的URL -will-load level2值用于设置使用topLevel设置为属性列表的第一个值。 level3仍然是错误的。
GetModelParams.r中的模型
model <- list()
#*********************************************************
#
model$savory$creamcheese$wheat$beta <- 1
model$savory$creamcheese$wheat$alpha <- 2
model$savory$creamcheese$wheat$gamma <- 3
#
model$savory$creamcheese$raisin$beta <- 4
model$savory$creamcheese$raisin$alpha <- 5
model$savory$creamcheese$raisin$gamma <- 6
#
model$savory$lox$poppy$beta <- 7
model$savory$lox$poppy$alpha <- 8
model$savory$lox$poppy$gamma <- 9
#
model$savory$lox$sesame$beta <- 8
model$savory$lox$sesame$alpha <- 7
model$savory$lox$sesame$gamma <- 6
#
model$savory$butter$poppy$beta <- 5
model$savory$butter$poppy$alpha <- 4
model$savory$butter$poppy$gamma <- 3
#
model$savory$butter$wheat$beta <- 2
model$savory$butter$wheat$alpha <- 1
model$savory$butter$wheat$gamma <- 1
#
model$salty$bacon$toasted$beta <- 2
model$salty$bacon$toasted$alpha <- 3
model$salty$bacon$toasted$gamma <- 4
#
model$salty$bacon$untoasted$beta <- 5
model$salty$bacon$untoasted$alpha <- 6
model$salty$bacon$untoasted$gamma <- 7
#
model$sweet$jelly$white$beta <- 6
model$sweet$jelly$white$alpha <- 5
model$sweet$jelly$white$gamma <- 4
#
model$sweet$jelly$muffin$beta <- 3
model$sweet$jelly$muffin$alpha <- 2
model$sweet$jelly$muffin$gamma <- 1
#
model$sweet$jam$white$beta <- 7
model$sweet$jam$white$alpha <- 11
model$sweet$jam$white$gamma <- 13
#
model$sweet$jam$muffin$beta <- 1
model$sweet$jam$muffin$alpha <- 3
model$sweet$jam$muffin$gamma <- 5
ui.R：
library(shiny)
library(shinyURL)
##############################
### ui.R #####################
##############################
source("GetModelParams.r")
topLevel <- attributes(model)
shinyUI(pageWithSidebar(
headerPanel("URL conditional setting example"),
sidebarPanel(
tabsetPanel(
tabPanel("setup",
radioButtons(inputId = "nTraces",
label = "multiple trace, single parameter variation ",
choices = list("single trace" = 1, "2 traces" = 2, "3 traces" = 3, "4 traces" = 4)),
selectInput(inputId = "topLev1",
label = "select top Level",
choices = topLevel),
selectInput(inputId = "secondLev1",
label = "select second level",
choices = NULL),
selectInput(inputId = "thirdLev1",
label = "select third level",
choices = NULL),
numericInput(inputId = "area1",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5),
sliderInput(inputId = "temp1",
label = "Temperature (C)",
min = 85, max = 125, value = 125, step = 5)
),
tabPanel("trace 2",
conditionalPanel(
condition = "input.nTraces == '2' || input.nTraces == '3' || input.nTraces == '4'",
radioButtons(inputId = "parVary",
label = "choose single parameter variation ",
choices = list("model" = "model", "area" = "area", "temperature" = "temp")
),
conditionalPanel(
condition = "input.parVary == 'model'",
selectInput(inputId = "topLev2",
label = "select top level",
choices = topLevel),
selectInput(inputId = "secondLev2",
label = "select second level",
choices = NULL),
selectInput(inputId = "thirdLev2",
label = "select third Level",
choices = NULL)
),
conditionalPanel(
condition = "input.parVary == 'area'",
numericInput(inputId = "area2",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5)
),
conditionalPanel(
condition = "input.parVary == 'temp'",
sliderInput(inputId = "temp2",
label = "Temperature (C)",
min = 85, max = 125, value = 0, step = 5)
)
)
),
tabPanel("trace 3",
conditionalPanel(
condition = "input.nTraces == '3' || input.nTraces == '4'",
conditionalPanel(
condition = "input.parVary == 'model'",
selectInput(inputId = "topLev3",
label = "select top level",
choices = topLevel),
selectInput(inputId = "secondLev3",
label = "select second level",
choices = NULL),
selectInput(inputId = "thirdLev3",
label = "select third level",
choices = NULL)
),
conditionalPanel(
condition = "input.parVary == 'area'",
numericInput(inputId = "area3",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5)
),
conditionalPanel(
condition = "input.parVary == 'temp'",
sliderInput(inputId = "temp3",
label = "Temperature (C)",
min = 85, max = 125, value = 0, step = 5)
)
)
),
tabPanel("trace 4",
conditionalPanel(
condition = "input.nTraces == '4'",
conditionalPanel(
condition = "input.parVary == 'model'",
selectInput(inputId = "topLev4",
label = "select top level",
choices = topLevel),
selectInput(inputId = "secondLev4",
label = "select second level",
choices = NULL),
selectInput(inputId = "thirdLev4",
label = "select third level",
choices = NULL)
),
conditionalPanel(
condition = "input.parVary == 'area'",
numericInput(inputId = "area4",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5)
),
conditionalPanel(
condition = "input.parVary == 'temp'",
sliderInput(inputId = "temp4",
label = "Temperature (C)",
min = 85, max = 125, value = 0, step = 5)
)
)
),
shinyURL.ui(tinyURL = FALSE)
)
),
mainPanel(
tabsetPanel(
tabPanel("Output and data type", tableOutput("textDisplay")),
tabPanel("Model plots", plotOutput("modelPlot"))
)
)
))
server.R：
library(shiny)
library(shinyURL)
##########################################
##### server.R ###########################
##########################################
source("GetModelParams.r")
shinyServer(function(input, output, session) {
shinyURL.server(session)
modelCalc <- function(temp,area,model)
{
hrs <- seq(from =0, to = 2, by = 0.05)
F <- area*(model$alpha) + hrs*(model$beta)^3 + exp(model$gamma*(temp/100)*hrs)
list(F = F, hrs = hrs)
}
observe({
updateSelectInput(session, 'thirdLev4', choices = attributes(model[[input$topLev4]][[input$secondLev4]]))
})
observe({
updateSelectInput(session, 'secondLev4', choices = attributes(model[[input$topLev4]]))
})
observe({
updateSelectInput(session, 'thirdLev3', choices = attributes(model[[input$topLev3]][[input$secondLev3]]))
})
observe({
updateSelectInput(session, 'secondLev3', choices = attributes(model[[input$topLev3]]))
})
observe({
updateSelectInput(session, 'thirdLev2', choices = attributes(model[[input$topLev2]][[input$secondLev2]]))
})
observe({
updateSelectInput(session, 'secondLev2', choices = attributes(model[[input$topLev2]]))
})
observe({
updateSelectInput(session, 'thirdLev1', choices = attributes(model[[input$topLev1]][[input$secondLev1]]))
})
observe({
updateSelectInput(session, 'secondLev1', choices = attributes(model[[input$topLev1]]))
})
output$modelPlot <- renderPlot({
temp <- lapply(paste0("temp",1:as.numeric(input$nTraces)), function(x) input[[x]])
area <- lapply(paste0("area",1:as.numeric(input$nTraces)), function(x) input[[x]])
modelStr <- c("topLev", "secondLev", "thirdLev")
modelCall <- lapply(1:as.numeric(input$nTraces), function(n) paste0(modelStr,n))
modelIn <- lapply(modelCall,function(x) model[[input[[x[1]]]]][[input[[x[2]]]]][[input[[x[3]]]]])
mLegendStr <- lapply(modelCall, function(x) paste(input[[x[1]]],input[[x[2]]],input[[x[3]]]))
modelOut <- list()
if(input$nTraces == '1')
{
modelOut <- modelCalc(area=area[[1]],temp=temp[[1]],model=modelIn[[1]])
} else
{
modelOut <- switch(input$parVary,
"model" = lapply(modelIn,modelCalc,area=area[[1]],temp=temp[[1]]),
"temp" = lapply(temp,modelCalc,area=area[[1]],model=modelIn[[1]]),
"area" = lapply(area,modelCalc,temp=temp[[1]],model=modelIn[[1]])
)
}
if(input$nTraces =='1')
{
modelOut_flat <- unlist(modelOut)
} else
{
modelOut_flat <- unlist(lapply(modelOut,unlist,recursive=FALSE))
}
colorVec <- c('red','blue','green','cyan','magenta','black')
F_flat <- modelOut_flat[grep("^F",names(modelOut_flat))]
hrs_flat <- modelOut_flat[grep("^hrs",names(modelOut_flat))]
ylim_v <- range(F_flat[F_flat>0])
xlim_h <- range(hrs_flat[hrs_flat>0])
if(input$nTraces == '1')
{
plot(modelOut$hrs[modelOut$F>0],modelOut$F[modelOut$F>0],
log="xy",pch=1, col=colorVec[1],
xlab="Time [hrs]", ylab="Model output",'o',
ylim=ylim_v,xlim=xlim_h)
} else
{
plot(modelOut[[1]]$hrs[modelOut[[1]]$F>0],modelOut[[1]]$F[modelOut[[1]]$F>0],
log="xy",pch=1, col=colorVec[1],
xlab="Time [hrs]",ylab="Model output",'o',
ylim=ylim_v,xlim=xlim_h)
}
grid(col="blue")
if(input$nTraces != '1')
{
for(i in 2:length(modelOut)) {
points(modelOut[[i]]$hrs[modelOut[[i]]$F>0],modelOut[[i]]$F[modelOut[[i]]$F>0],
pch=1,col=colorVec[i],'o')
}
}
leg.names <- switch(input$parVary,
"temp" = sprintf('Temp=%.0f C',temp),
"area" = sprintf('Area=%.2e um^2',area),
"model"= sprintf('model=%s',mLegendStr)
)
legend("topleft",leg.names,bg="white",pch=1,lty=1,col=colorVec)
par(ps=11)
titleRet <- switch(input$parVary,
"temp" = title(sprintf("%s %s %s MODEL; Area=%.2eum^2", input$topLev1,input$secondLev1,input$thirdLev1,area[[1]])),
"area" = title(sprintf("%s %s %s MODEL; temp=%.0fC", input$topLev1,input$secondLev1,input$thirdLev1,temp[[1]])),
"model"= title(sprintf("MODEL; temp=%.0fC; Area=%.2eum^2", temp[[1]],area[[1]]))
)
})
output$textDisplay <- renderTable({
getMat = matrix(c(input$nTraces, class(input$nTraces),
input$topLev1, class(input$topLev1),
input$secondLev1, class(input$secondLev1),
input$thirdLev1, class(input$thirdLev1),
input$temp1, class(input$temp1),
input$area1, class(input$area1),
input$topLev2, class(input$topLev2),
input$secondLev2, class(input$secondLev2),
input$thirdLev2, class(input$thirdLev2),
input$temp2, class(input$temp2),
input$area2, class(input$area2),
input$topLev3, class(input$topLev3),
input$secondLev3, class(input$secondLev3),
input$thirdLev3, class(input$thirdLev3),
input$temp3, class(input$temp3),
input$area3, class(input$area3),
input$parVary, class(input$parVary)
), ncol=2, byrow = TRUE)
colnames(getMat) = c("Value", "Class")
getMat
})
})
答案 2 :(得分：0)
@aoles第二个答案包含了你的建议。这基本上用作URL调用-AFTER-用户手动逐步设置为参数变化的“模型”，然后单步执行跟踪选项卡。我希望能有一些不需要手工操作的东西。
非常感谢您的关注。
模型参数文件相同。
ui.R：
library(shiny)
library(shinyURL)
##############################
### ui.R #####################
##############################
source("GetModelParams.r")
topLevel <- attributes(model)
shinyUI(pageWithSidebar(
headerPanel("URL conditional setting example"),
sidebarPanel(
tabsetPanel(
tabPanel("setup",
radioButtons(inputId = "nTraces",
label = "multiple trace, single parameter variation ",
choices = list("single trace" = 1, "2 traces" = 2, "3 traces" = 3, "4 traces" = 4)),
selectInput(inputId = "topLev1",
label = "select top Level",
choices = topLevel),
uiOutput("sec1"),
uiOutput("thrd1"),
numericInput(inputId = "area1",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5),
sliderInput(inputId = "temp1",
label = "Temperature (C)",
min = 85, max = 125, value = 125, step = 5)
),
tabPanel("trace 2",
conditionalPanel(
condition = "input.nTraces == '2' || input.nTraces == '3' || input.nTraces == '4'",
radioButtons(inputId = "parVary",
label = "choose single parameter variation ",
choices = list("model" = "model", "area" = "area", "temperature" = "temp")
),
conditionalPanel(
condition = "input.parVary == 'model'",
selectInput(inputId = "topLev2",
label = "select top level",
choices = topLevel),
uiOutput("sec2"),
uiOutput("thrd2")
),
conditionalPanel(
condition = "input.parVary == 'area'",
numericInput(inputId = "area2",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5)
),
conditionalPanel(
condition = "input.parVary == 'temp'",
sliderInput(inputId = "temp2",
label = "Temperature (C)",
min = 85, max = 125, value = 0, step = 5)
)
)
),
tabPanel("trace 3",
conditionalPanel(
condition = "input.nTraces == '3' || input.nTraces == '4'",
conditionalPanel(
condition = "input.parVary == 'model'",
selectInput(inputId = "topLev3",
label = "select top level",
choices = topLevel),
uiOutput("sec3"),
uiOutput("thrd3")
),
conditionalPanel(
condition = "input.parVary == 'area'",
numericInput(inputId = "area3",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5)
),
conditionalPanel(
condition = "input.parVary == 'temp'",
sliderInput(inputId = "temp3",
label = "Temperature (C)",
min = 85, max = 125, value = 0, step = 5)
)
)
),
tabPanel("trace 4",
conditionalPanel(
condition = "input.nTraces == '4'",
conditionalPanel(
condition = "input.parVary == 'model'",
selectInput(inputId = "topLev4",
label = "select top level",
choices = topLevel),
uiOutput("sec4"),
uiOutput("thrd4")
),
conditionalPanel(
condition = "input.parVary == 'area'",
numericInput(inputId = "area4",
label = "Total gate area (um^2)",
min = 1, max = 10, value = 5)
),
conditionalPanel(
condition = "input.parVary == 'temp'",
sliderInput(inputId = "temp4",
label = "Temperature (C)",
min = 85, max = 125, value = 0, step = 5)
)
)
),
shinyURL.ui(tinyURL = FALSE)
)
),
mainPanel(
tabsetPanel(
tabPanel("Output and data type", tableOutput("textDisplay")),
tabPanel("Model plots", plotOutput("modelPlot"))
)
)
))
server.R：
library(shiny)
library(shinyURL)
##########################################
##### server.R ###########################
##########################################
source("GetModelParams.r")
shinyServer(function(input, output, session) {
shinyURL.server(session)
modelCalc <- function(temp,area,model)
{
hrs <- seq(from =0, to = 2, by = 0.05)
F <- area*(model$alpha) + hrs*(model$beta)^3 + exp(model$gamma*(temp/100)*hrs)
list(F = F, hrs = hrs)
}
output$sec1 <- renderUI({
selectInput(inputId = "secondLev1",
label = "select second level",
choices = attributes(model[[input$topLev1]])
)
})
output$thrd1 <- renderUI({
req(input$secondLev1)
selectInput(inputId = "thirdLev1",
label = "select third level",
choices = attributes(model[[input$topLev1]][[input$secondLev1]])
)
})
output$sec2 <- renderUI({
selectInput(inputId = "secondLev2",
label = "select second level",
choices = attributes(model[[input$topLev2]])
)
})
output$thrd2 <- renderUI({
selectInput(inputId = "thirdLev2",
label = "select third level",
choices = attributes(model[[input$topLev2]][[input$secondLev2]])
)
})
output$sec3 <- renderUI({
selectInput(inputId = "secondLev3",
label = "select second level",
choices = attributes(model[[input$topLev3]])
)
})
output$thrd3 <- renderUI({
selectInput(inputId = "thirdLev3",
label = "select third level",
choices = attributes(model[[input$topLev3]][[input$secondLev3]])
)
})
output$sec4 <- renderUI({
selectInput(inputId = "secondLev4",
label = "select second level",
choices = attributes(model[[input$topLev4]])
)
})
output$thrd4 <- renderUI({
selectInput(inputId = "thirdLev4",
label = "select third level",
choices = attributes(model[[input$topLev4]][[input$secondLev4]])
)
})
output$modelPlot <- renderPlot({
temp <- lapply(paste0("temp",1:as.numeric(input$nTraces)), function(x) input[[x]])
area <- lapply(paste0("area",1:as.numeric(input$nTraces)), function(x) input[[x]])
modelStr <- c("topLev", "secondLev", "thirdLev")
modelCall <- lapply(1:as.numeric(input$nTraces), function(n) paste0(modelStr,n))
modelIn <- lapply(modelCall,function(x) model[[input[[x[1]]]]][[input[[x[2]]]]][[input[[x[3]]]]])
mLegendStr <- lapply(modelCall, function(x) paste(input[[x[1]]],input[[x[2]]],input[[x[3]]]))
modelOut <- list()
if(input$nTraces == '1')
{
modelOut <- modelCalc(area=area[[1]],temp=temp[[1]],model=modelIn[[1]])
} else
{
modelOut <- switch(input$parVary,
"model" = lapply(modelIn,modelCalc,area=area[[1]],temp=temp[[1]]),
"temp" = lapply(temp,modelCalc,area=area[[1]],model=modelIn[[1]]),
"area" = lapply(area,modelCalc,temp=temp[[1]],model=modelIn[[1]])
)
}
if(input$nTraces =='1')
{
modelOut_flat <- unlist(modelOut)
} else
{
modelOut_flat <- unlist(lapply(modelOut,unlist,recursive=FALSE))
}
colorVec <- c('red','blue','green','cyan','magenta','black')
F_flat <- modelOut_flat[grep("^F",names(modelOut_flat))]
hrs_flat <- modelOut_flat[grep("^hrs",names(modelOut_flat))]
ylim_v <- range(F_flat[F_flat>0])
xlim_h <- range(hrs_flat[hrs_flat>0])
if(input$nTraces == '1')
{
plot(modelOut$hrs[modelOut$F>0],modelOut$F[modelOut$F>0],
log="xy",pch=1, col=colorVec[1],
xlab="Time [hrs]", ylab="Model output",'o',
ylim=ylim_v,xlim=xlim_h)
} else
{
plot(modelOut[[1]]$hrs[modelOut[[1]]$F>0],modelOut[[1]]$F[modelOut[[1]]$F>0],
log="xy",pch=1, col=colorVec[1],
xlab="Time [hrs]",ylab="Model output",'o',
ylim=ylim_v,xlim=xlim_h)
}
grid(col="blue")
if(input$nTraces != '1')
{
for(i in 2:length(modelOut)) {
points(modelOut[[i]]$hrs[modelOut[[i]]$F>0],modelOut[[i]]$F[modelOut[[i]]$F>0],
pch=1,col=colorVec[i],'o')
}
}
leg.names <- switch(input$parVary,
"temp" = sprintf('Temp=%.0f C',temp),
"area" = sprintf('Area=%.2e um^2',area),
"model"= sprintf('model=%s',mLegendStr)
)
legend("topleft",leg.names,bg="white",pch=1,lty=1,col=colorVec)
par(ps=11)
titleRet <- switch(input$parVary,
"temp" = title(sprintf("%s %s %s MODEL; Area=%.2eum^2", input$topLev1,input$secondLev1,input$thirdLev1,area[[1]])),
"area" = title(sprintf("%s %s %s MODEL; temp=%.0fC", input$topLev1,input$secondLev1,input$thirdLev1,temp[[1]])),
"model"= title(sprintf("MODEL; temp=%.0fC; Area=%.2eum^2", temp[[1]],area[[1]]))
)
})
output$textDisplay <- renderTable({
getMat = matrix(c(input$nTraces, class(input$nTraces),
input$topLev1, class(input$topLev1),
input$secondLev1, class(input$secondLev1),
input$thirdLev1, class(input$thirdLev1),
input$temp1, class(input$temp1),
input$area1, class(input$area1),
input$topLev2, class(input$topLev2),
input$secondLev2, class(input$secondLev2),
input$thirdLev2, class(input$thirdLev2),
input$temp2, class(input$temp2),
input$area2, class(input$area2),
input$topLev3, class(input$topLev3),
input$secondLev3, class(input$secondLev3),
input$thirdLev3, class(input$thirdLev3),
input$temp3, class(input$temp3),
input$area3, class(input$area3),
input$parVary, class(input$parVary)
), ncol=2, byrow = TRUE)
colnames(getMat) = c("Value", "Class")
getMat
})
})