闪亮:每个菜单都有带actionButton的不同任务 [英] shiny: different tasks with actionButton for each menuSubItems
本文介绍了闪亮:每个菜单都有带actionButton的不同任务的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我已经使用带有一组menuItems和menuSubItems以及coresponding tabItems的Shinydashboard创建了一个应用程序，并且有一个conditionalPanel，每个menuSubItems具有不同的输入参数，以及一个用于执行不同分析和绘图任务的actionButton，现在可以使用了在单击actionButton之前，即，在menuSubItems之间切换时，conditionalPanel发生了变化，并且在第一次单击actionButton时也能很好地工作，即按预期显示了html图，但是在第一次单击actionButton之后，conditionalPanel在切换menuSubItems时不再像以前一样更改，似乎在ui中用鼠标单击时menuSubItems无法更新.
确切地说，有两个问题:
-
在单击runButton之前，当在menusubItems之间切换时，常规的parinbox会正确更改，并且可以自由地在menusubItems之间切换，并且在第一次单击runButton时，将生成带有图的html并加载为预期，虽然切换到另一个menusubItem时第二次不起作用，但是input $ sidebarmenu似乎没有改变吗?
-
当单击menusubItem时如何取消折叠对话框?
Dean Attali友好地指出，menusubItems的选项卡名称实际上不是应用程序中子菜单元素的ID，可能是原因，但我不知道如何解决它，对您有所帮助. /p>
最小的可重复代码如下:
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)
解决方案
对于runButton隔离的问题，我认为您可以将服务器代码更改为此:
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]]
})
})
}
I have create an app using shinydashboard with a group of menuItems and menuSubItems as well as the coresponding tabItems, and there is a conditionalPanel with different input parameters for each menuSubItems, and an actionButton for different analysing and ploting task, now it works before the actionButton is clicked, that is, the conditionalPanel changed when switching between menuSubItems, and it also works well for the first time actionButton is clicked, that is it show a plot html as expected, but after the first clicked of actionButton, the conditionalPanel no longer changed as before when switching between menuSubItems, it seems that the menuSubItems can not update when clicked by mouse in the ui.
exactly, there is two problems:
before the runButton is clicked, the condtional parinbox changed correctly when switching between menusubItems, and it can swithching between menusubItems freely, and when the first time the runButton is clicked, a html with a plot is generated and loaded as expected, while it does not work for the second time when swithching to another menusubItem, the input$sidebarmenu seems not changed?
How to uncollapse the parinbox when a menusubItem is clicked?
Dean Attali has kindly pointed that tabname of menusubItems is not actually going to be the ID of the submenu element in the app, may be this is the cause, but I do not how to fix it, any help is appreciated.
a minimal repeatable code is as below:
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)
解决方案
For the issue of runButton isolate, I think you can change the server code to this:
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]]
})
})
}
这篇关于闪亮:每个菜单都有带actionButton的不同任务的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
