闪亮：每个 menuSubItems 具有 actionButton 的不同任务
shiny: different tasks with actionButton for each menuSubItems
我已经使用带有一组 menuItems 和 menuSubItems 以及相应的 tabItems 的 shinydashboard 创建了一个应用程序，并且有一个条件面板，每个 menuSubItems 都有不同的输入参数，还有一个用于不同分析和绘图任务的 actionButton，现在它在单击 actionButton 之前起作用，也就是说，在 menuSubItems 之间切换时条件面板发生了变化，并且它在第一次单击 actionButton 时也能很好地工作，也就是说它按预期显示了一个情节 html，但是在第一次之后actionButton的clicked，conditionalPanel在menuSubItems之间切换时不再像以前那样变化，似乎在ui.
中用鼠标点击时menuSubItems无法更新
确切地说，有两个问题：
在点击runButton之前，切换menusubItem时condtional parinbox正确改变，可以自由切换menusubItems，第一次点击runButton时，一个html带有图的生成并按预期加载，虽然它在切换到另一个 menusubItem 时第二次不起作用，input$sidebarmenu 似乎没有改变？
如何在单击 menusubItem 时展开 parinbox？
Dean Attali 友善地指出，menusubItems 的 tabname 实际上并不是应用程序中子菜单元素的 ID，可能是这个原因，但我不知道如何解决它，任何帮助表示赞赏.
一个最小的可重复代码如下：
library(shiny)
library(shinyjs)
library(shinydashboard)
library(knitr)
library(markdown)
library(rmarkdown)
library(ggplot2)
# parinbox #############################
jsboxcollapsecode <- "shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"
selDateRange=dateRangeInput('dateRange',label='time:',start=Sys.Date()-7,end=Sys.Date()-1)
selcompyear=textInput("compyear",label="compyear:")
selmetsInput=selectInput(inputId="selmets",label="item:",choices=c("a","b","c"),selected=c("a","b"),multiple=TRUE)
condselcompyear =conditionalPanel("input.sidebarmenu=='subItemOne'||input.sidebarmenu=='subItemFour'",selcompyear)
condselmetsInput=conditionalPanel("input.sidebarmenu=='subItemThree'",selmetsInput)
runButton=actionButton(inputId="runButton",label=strong("run"),width=100)
opendirButton=actionButton(inputId="opendirButton",label=strong("opendir"),width=100)
fluidrunopenButton=fluidRow(column(4,offset=1,runButton),column(width=4,offset=1,opendirButton))
parInbox=box(id="parbox",title="Input parameter",status="primary",solidHeader=TRUE,collapsible=TRUE,collapsed=FALSE,width='auto',
selDateRange,condselcompyear,condselmetsInput,fluidrunopenButton)
absParInPanel=absolutePanel(id="parinbox",top=80,right=0,width=300,draggable=TRUE,parInbox)
# Sidebar #############################
sidebar <- dashboardSidebar(
tags$head(
tags$script(
HTML(
"
$(document).ready(function(){
// Bind classes to menu items, easiet to fill in manually
var ids = ['subItemOne','subItemTwo','subItemThree','subItemFour'];
for(i=0; i<ids.length; i++){
$('a[data-value='+ids[i]+']').addClass('my_subitem_class');
}
// Register click handeler
$('.my_subitem_class').on('click',function(){
// Unactive menuSubItems
$('.my_subitem_class').parent().removeClass('active');
})
})
"
)
)
),
width = 290,
sidebarMenu(id='sidebarmenu',
menuItem('Menu One', tabName = 'menuOne', icon = icon('line-chart'),
menuSubItem('Sub-Item One', tabName = 'subItemOne'),
menuSubItem('Sub-Item Two', tabName = 'subItemTwo')),
menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'),
menuSubItem('Sub-Item Three', tabName = 'subItemThree'),
menuSubItem('Sub-Item Four', tabName = 'subItemFour')))
# sidebarMenu(
# menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'),
# menuSubItem('Sub-Item Three', tabName = 'subItemThree'),
# menuSubItem('Sub-Item Four', tabName = 'subItemFour')))
)
# Body #############################
body <- dashboardBody(
useShinyjs(),
extendShinyjs(text=jsboxcollapsecode),
absParInPanel,
tabItems(
tabItem(tabName = 'subItemOne',
h2('Selected Sub-Item One'),uiOutput('subItemOne_html')),
tabItem(tabName = 'subItemTwo',
h2('Selected Sub-Item Two'),uiOutput('subItemTwo_html')),
tabItem(tabName = 'subItemThree',
h2('Selected Sub-Item Three'),uiOutput('subItemThree_html')),
tabItem(tabName = 'subItemFour',
h2('Selected Sub-Item Four'),uiOutput('subItemFour_html'))
)
)
# UI #############################
ui <- dashboardPage(
dashboardHeader(title = 'Test', titleWidth = 290),
sidebar,
body
)
# Server #############################
server <- function(input, output){
shinyOutput<- function(input=NULL){
sidebarmenu=input$sidebarmenu
start=as.Date(format(input$dateRange[1]))
end=as.Date(format(input$dateRange[2]))
time=seq(from=start,to=end+5,by="day")
gdata=data.frame(x=time,y=sample(1:100,length(time)))
if(sidebarmenu=='subItemOne'){
ggsave(ggplot(gdata,aes(x,y))+geom_line(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemTwo'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemThree'){
ggsave(ggplot(gdata,aes(x,y))+geom_dotplot(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemFour'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(fill="red"),device="png",filename="tmp.png")
}
Rmdfile="tmp.Rmd"
writeLines(c("---","output: 'html_document'","---","```{r rcode,cache=FALSE}","knitr::include_graphics('tmp.png')","```"),Rmdfile)
shiny::includeHTML(rmarkdown::render(Rmdfile,clean=FALSE))
}
htmlvalues=reactive({
if(input$runButton==0) return()
isolate({
input$runButton
renderUI({shinyOutput(input)})
})
})
observeEvent(input$runButton,
{
js$collapse("parbox")
print(paste("the current selected submenu is",input$sidebarmenu,sep=":"))
output[[paste(input$sidebarmenu,"html",sep="_")]]=htmlvalues()
})
}
shinyApp(ui, server)
首先，请避免用观察者包装反应式表达式（htmlvalues()），只需将其放在服务器功能下，如下所示：
for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) {
output[[paste(item,"html",sep="_")]] <- renderUI({
input$runButton
if(input$runButton==0) return()
isolate({shinyOutput(input)})
})
}
我发现如果直接用[=12=注入rmarkdown html，input$sidebarmenu不会再改变，也许注入的html会破坏内部设置闪亮的仪表板。您可以通过将呈现的 tmp.html 保存到应用程序根目录中的 www 文件夹来解决此问题，然后使用 tags$iframe 包含它，或者您可以使用 shiny::includeMarkdown 导入tmp.md 文件而不是 html.
Yang 建议的固定代码有效，但与 runButton 隔离似乎无效：
library(shiny)
library(shinyjs)
library(shinydashboard)
library(knitr)
library(markdown)
library(rmarkdown)
library(ggplot2)
# parinbox #############################
jsboxcollapsecode <- "shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"
selDateRange=dateRangeInput('dateRange',label='time:',start=Sys.Date()-7,end=Sys.Date()-1)
selcompyear=textInput("compyear",label="compyear:")
selmetsInput=selectInput(inputId="selmets",label="item:",choices=c("a","b","c"),selected=c("a","b"),multiple=TRUE)
condselcompyear =conditionalPanel("input.sidebarmenu=='subItemOne'||input.sidebarmenu=='subItemFour'",selcompyear)
condselmetsInput=conditionalPanel("input.sidebarmenu=='subItemThree'",selmetsInput)
runButton=actionButton(inputId="runButton",label=strong("run"),width=100)
opendirButton=actionButton(inputId="opendirButton",label=strong("opendir"),width=100)
fluidrunopenButton=fluidRow(column(4,offset=1,runButton),column(width=4,offset=1,opendirButton))
parInbox=box(id="parbox",title="Input parameter",status="primary",solidHeader=TRUE,collapsible=TRUE,collapsed=FALSE,width='auto',
selDateRange,condselcompyear,condselmetsInput,fluidrunopenButton)
absParInPanel=absolutePanel(id="parinbox",top=80,right=0,width=300,draggable=TRUE,parInbox)
# Sidebar #############################
sidebar <- dashboardSidebar(
width = 290,
sidebarMenu(id='sidebarmenu',
menuItem('Menu One', tabName = 'menuOne', icon = icon('line-chart'),
menuSubItem('Sub-Item One', tabName = 'subItemOne'),
menuSubItem('Sub-Item Two', tabName = 'subItemTwo')),
menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'),
menuSubItem('Sub-Item Three', tabName = 'subItemThree'),
menuSubItem('Sub-Item Four', tabName = 'subItemFour')))
)
# Body #############################
body <- dashboardBody(
useShinyjs(),
extendShinyjs(text=jsboxcollapsecode),
absParInPanel,
tabItems(
tabItem(tabName = 'subItemOne',
h2('Selected Sub-Item One'),uiOutput('subItemOne_html')),
tabItem(tabName = 'subItemTwo',
h2('Selected Sub-Item Two'),uiOutput('subItemTwo_html')),
tabItem(tabName = 'subItemThree',
h2('Selected Sub-Item Three'),uiOutput('subItemThree_html')),
tabItem(tabName = 'subItemFour',
h2('Selected Sub-Item Four'),uiOutput('subItemFour_html'))
)
)
# UI #############################
ui <- dashboardPage(
dashboardHeader(title = 'Test', titleWidth = 290),
sidebar,
body
)
# Server #############################
server <- function(input, output){
shinyOutput<- function(input=NULL){
sidebarmenu=input$sidebarmenu
start=as.Date(format(input$dateRange[1]))
end=as.Date(format(input$dateRange[2]))
time=seq(from=start,to=end+5,by="day")
gdata=data.frame(x=time,y=sample(1:100,length(time)))
if(sidebarmenu=='subItemOne'){
ggsave(ggplot(gdata,aes(x,y))+geom_line(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemTwo'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemThree'){
ggsave(ggplot(gdata,aes(x,y))+geom_dotplot(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemFour'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(fill="red"),device="png",filename="tmp.png")
}
Rmdfile="tmp.Rmd"
writeLines(c("---","output: 'html_document'","---","```{r rcode,cache=FALSE}","knitr::include_graphics('tmp.png')","```"),Rmdfile)
#shiny::includeHTML(rmarkdown::render(Rmdfile,clean=FALSE))
htmltools::HTML(markdown::markdownToHTML(knit(Rmdfile,quiet=TRUE)))
}
for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) {
output[[paste(item,"html",sep="_")]] <- renderUI({
input$runButton
if(input$runButton==0) return()
isolate({shinyOutput(input)})
})
}
}
shinyApp(ui, server)
关于runButton isolate的问题，我觉得你可以把服务器代码改成这样：
plots <- reactiveValues() # use a reactiveValue to store rendered html for each subItem
observeEvent(input$runButton, {
plots[[input$sidebarmenu]] <- shinyOutput(input)
})
for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) {
local({ ## use local to ensure the renderUI expression get correct item
current_item <- item
output[[paste(current_item,"html",sep="_")]] <- renderUI({
plots[[current_item]]
})
})
}
我已经使用带有一组 menuItems 和 menuSubItems 以及相应的 tabItems 的 shinydashboard 创建了一个应用程序，并且有一个条件面板，每个 menuSubItems 都有不同的输入参数，还有一个用于不同分析和绘图任务的 actionButton，现在它在单击 actionButton 之前起作用，也就是说，在 menuSubItems 之间切换时条件面板发生了变化，并且它在第一次单击 actionButton 时也能很好地工作，也就是说它按预期显示了一个情节 html，但是在第一次之后actionButton的clicked，conditionalPanel在menuSubItems之间切换时不再像以前那样变化，似乎在ui.
中用鼠标点击时menuSubItems无法更新确切地说，有两个问题：
在点击runButton之前，切换menusubItem时condtional parinbox正确改变，可以自由切换menusubItems，第一次点击runButton时，一个html带有图的生成并按预期加载，虽然它在切换到另一个 menusubItem 时第二次不起作用，input$sidebarmenu 似乎没有改变？
如何在单击 menusubItem 时展开 parinbox？
Dean Attali 友善地指出，menusubItems 的 tabname 实际上并不是应用程序中子菜单元素的 ID，可能是这个原因，但我不知道如何解决它，任何帮助表示赞赏.
一个最小的可重复代码如下：
library(shiny)
library(shinyjs)
library(shinydashboard)
library(knitr)
library(markdown)
library(rmarkdown)
library(ggplot2)
# parinbox #############################
jsboxcollapsecode <- "shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"
selDateRange=dateRangeInput('dateRange',label='time:',start=Sys.Date()-7,end=Sys.Date()-1)
selcompyear=textInput("compyear",label="compyear:")
selmetsInput=selectInput(inputId="selmets",label="item:",choices=c("a","b","c"),selected=c("a","b"),multiple=TRUE)
condselcompyear =conditionalPanel("input.sidebarmenu=='subItemOne'||input.sidebarmenu=='subItemFour'",selcompyear)
condselmetsInput=conditionalPanel("input.sidebarmenu=='subItemThree'",selmetsInput)
runButton=actionButton(inputId="runButton",label=strong("run"),width=100)
opendirButton=actionButton(inputId="opendirButton",label=strong("opendir"),width=100)
fluidrunopenButton=fluidRow(column(4,offset=1,runButton),column(width=4,offset=1,opendirButton))
parInbox=box(id="parbox",title="Input parameter",status="primary",solidHeader=TRUE,collapsible=TRUE,collapsed=FALSE,width='auto',
selDateRange,condselcompyear,condselmetsInput,fluidrunopenButton)
absParInPanel=absolutePanel(id="parinbox",top=80,right=0,width=300,draggable=TRUE,parInbox)
# Sidebar #############################
sidebar <- dashboardSidebar(
tags$head(
tags$script(
HTML(
"
$(document).ready(function(){
// Bind classes to menu items, easiet to fill in manually
var ids = ['subItemOne','subItemTwo','subItemThree','subItemFour'];
for(i=0; i<ids.length; i++){
$('a[data-value='+ids[i]+']').addClass('my_subitem_class');
}
// Register click handeler
$('.my_subitem_class').on('click',function(){
// Unactive menuSubItems
$('.my_subitem_class').parent().removeClass('active');
})
})
"
)
)
),
width = 290,
sidebarMenu(id='sidebarmenu',
menuItem('Menu One', tabName = 'menuOne', icon = icon('line-chart'),
menuSubItem('Sub-Item One', tabName = 'subItemOne'),
menuSubItem('Sub-Item Two', tabName = 'subItemTwo')),
menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'),
menuSubItem('Sub-Item Three', tabName = 'subItemThree'),
menuSubItem('Sub-Item Four', tabName = 'subItemFour')))
# sidebarMenu(
# menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'),
# menuSubItem('Sub-Item Three', tabName = 'subItemThree'),
# menuSubItem('Sub-Item Four', tabName = 'subItemFour')))
)
# Body #############################
body <- dashboardBody(
useShinyjs(),
extendShinyjs(text=jsboxcollapsecode),
absParInPanel,
tabItems(
tabItem(tabName = 'subItemOne',
h2('Selected Sub-Item One'),uiOutput('subItemOne_html')),
tabItem(tabName = 'subItemTwo',
h2('Selected Sub-Item Two'),uiOutput('subItemTwo_html')),
tabItem(tabName = 'subItemThree',
h2('Selected Sub-Item Three'),uiOutput('subItemThree_html')),
tabItem(tabName = 'subItemFour',
h2('Selected Sub-Item Four'),uiOutput('subItemFour_html'))
)
)
# UI #############################
ui <- dashboardPage(
dashboardHeader(title = 'Test', titleWidth = 290),
sidebar,
body
)
# Server #############################
server <- function(input, output){
shinyOutput<- function(input=NULL){
sidebarmenu=input$sidebarmenu
start=as.Date(format(input$dateRange[1]))
end=as.Date(format(input$dateRange[2]))
time=seq(from=start,to=end+5,by="day")
gdata=data.frame(x=time,y=sample(1:100,length(time)))
if(sidebarmenu=='subItemOne'){
ggsave(ggplot(gdata,aes(x,y))+geom_line(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemTwo'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemThree'){
ggsave(ggplot(gdata,aes(x,y))+geom_dotplot(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemFour'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(fill="red"),device="png",filename="tmp.png")
}
Rmdfile="tmp.Rmd"
writeLines(c("---","output: 'html_document'","---","```{r rcode,cache=FALSE}","knitr::include_graphics('tmp.png')","```"),Rmdfile)
shiny::includeHTML(rmarkdown::render(Rmdfile,clean=FALSE))
}
htmlvalues=reactive({
if(input$runButton==0) return()
isolate({
input$runButton
renderUI({shinyOutput(input)})
})
})
observeEvent(input$runButton,
{
js$collapse("parbox")
print(paste("the current selected submenu is",input$sidebarmenu,sep=":"))
output[[paste(input$sidebarmenu,"html",sep="_")]]=htmlvalues()
})
}
shinyApp(ui, server)
首先，请避免用观察者包装反应式表达式（htmlvalues()），只需将其放在服务器功能下，如下所示：
for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) {
output[[paste(item,"html",sep="_")]] <- renderUI({
input$runButton
if(input$runButton==0) return()
isolate({shinyOutput(input)})
})
}
我发现如果直接用[=12=注入rmarkdown html，input$sidebarmenu不会再改变，也许注入的html会破坏内部设置闪亮的仪表板。您可以通过将呈现的 tmp.html 保存到应用程序根目录中的 www 文件夹来解决此问题，然后使用 tags$iframe 包含它，或者您可以使用 shiny::includeMarkdown 导入tmp.md 文件而不是 html.
Yang 建议的固定代码有效，但与 runButton 隔离似乎无效：
library(shiny)
library(shinyjs)
library(shinydashboard)
library(knitr)
library(markdown)
library(rmarkdown)
library(ggplot2)
# parinbox #############################
jsboxcollapsecode <- "shinyjs.collapse = function(boxid) {
$('#' + boxid).closest('.box').find('[data-widget=collapse]').click();
}
"
selDateRange=dateRangeInput('dateRange',label='time:',start=Sys.Date()-7,end=Sys.Date()-1)
selcompyear=textInput("compyear",label="compyear:")
selmetsInput=selectInput(inputId="selmets",label="item:",choices=c("a","b","c"),selected=c("a","b"),multiple=TRUE)
condselcompyear =conditionalPanel("input.sidebarmenu=='subItemOne'||input.sidebarmenu=='subItemFour'",selcompyear)
condselmetsInput=conditionalPanel("input.sidebarmenu=='subItemThree'",selmetsInput)
runButton=actionButton(inputId="runButton",label=strong("run"),width=100)
opendirButton=actionButton(inputId="opendirButton",label=strong("opendir"),width=100)
fluidrunopenButton=fluidRow(column(4,offset=1,runButton),column(width=4,offset=1,opendirButton))
parInbox=box(id="parbox",title="Input parameter",status="primary",solidHeader=TRUE,collapsible=TRUE,collapsed=FALSE,width='auto',
selDateRange,condselcompyear,condselmetsInput,fluidrunopenButton)
absParInPanel=absolutePanel(id="parinbox",top=80,right=0,width=300,draggable=TRUE,parInbox)
# Sidebar #############################
sidebar <- dashboardSidebar(
width = 290,
sidebarMenu(id='sidebarmenu',
menuItem('Menu One', tabName = 'menuOne', icon = icon('line-chart'),
menuSubItem('Sub-Item One', tabName = 'subItemOne'),
menuSubItem('Sub-Item Two', tabName = 'subItemTwo')),
menuItem('Menu Two', tabName = 'menuTwo', icon = icon('users'),
menuSubItem('Sub-Item Three', tabName = 'subItemThree'),
menuSubItem('Sub-Item Four', tabName = 'subItemFour')))
)
# Body #############################
body <- dashboardBody(
useShinyjs(),
extendShinyjs(text=jsboxcollapsecode),
absParInPanel,
tabItems(
tabItem(tabName = 'subItemOne',
h2('Selected Sub-Item One'),uiOutput('subItemOne_html')),
tabItem(tabName = 'subItemTwo',
h2('Selected Sub-Item Two'),uiOutput('subItemTwo_html')),
tabItem(tabName = 'subItemThree',
h2('Selected Sub-Item Three'),uiOutput('subItemThree_html')),
tabItem(tabName = 'subItemFour',
h2('Selected Sub-Item Four'),uiOutput('subItemFour_html'))
)
)
# UI #############################
ui <- dashboardPage(
dashboardHeader(title = 'Test', titleWidth = 290),
sidebar,
body
)
# Server #############################
server <- function(input, output){
shinyOutput<- function(input=NULL){
sidebarmenu=input$sidebarmenu
start=as.Date(format(input$dateRange[1]))
end=as.Date(format(input$dateRange[2]))
time=seq(from=start,to=end+5,by="day")
gdata=data.frame(x=time,y=sample(1:100,length(time)))
if(sidebarmenu=='subItemOne'){
ggsave(ggplot(gdata,aes(x,y))+geom_line(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemTwo'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemThree'){
ggsave(ggplot(gdata,aes(x,y))+geom_dotplot(),device="png",filename="tmp.png")
}else if(sidebarmenu=='subItemFour'){
ggsave(ggplot(gdata,aes(x,y))+geom_col(fill="red"),device="png",filename="tmp.png")
}
Rmdfile="tmp.Rmd"
writeLines(c("---","output: 'html_document'","---","```{r rcode,cache=FALSE}","knitr::include_graphics('tmp.png')","```"),Rmdfile)
#shiny::includeHTML(rmarkdown::render(Rmdfile,clean=FALSE))
htmltools::HTML(markdown::markdownToHTML(knit(Rmdfile,quiet=TRUE)))
}
for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) {
output[[paste(item,"html",sep="_")]] <- renderUI({
input$runButton
if(input$runButton==0) return()
isolate({shinyOutput(input)})
})
}
}
shinyApp(ui, server)
关于runButton isolate的问题，我觉得你可以把服务器代码改成这样：
plots <- reactiveValues() # use a reactiveValue to store rendered html for each subItem
observeEvent(input$runButton, {
plots[[input$sidebarmenu]] <- shinyOutput(input)
})
for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) {
local({ ## use local to ensure the renderUI expression get correct item
current_item <- item
output[[paste(current_item,"html",sep="_")]] <- renderUI({
plots[[current_item]]
})
})
}