shiny: different tasks with actionButton for each menuSubItems

问题

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)

回答1:

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]]
    })
  })
}

回答2:

First, please avoid wrapping reactive expression (htmlvalues()) with observer, just put it outside under the server function like this:

for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) {
  output[[paste(item,"html",sep="_")]] <- renderUI({
    input$runButton
    if(input$runButton==0) return()
    isolate({shinyOutput(input)})
  })
}

I found if a rmarkdown html is injected directly with shiny::includeHTML, the input$sidebarmenu would not change any more, maybe the injected html would destruct the inner settings of shinydashboard. You could solve this by saving the rendered tmp.html to www folder in the root of your app, then use tags$iframe to include it, or you can use shiny::includeMarkdown to import the tmp.md file instead of the html.

回答3:

the fixed code suggested by Yang works but with the isolate of runButton seems not works:

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)

来源：https://stackoverflow.com/questions/42269571/shiny-different-tasks-with-actionbutton-for-each-menusubitems

标签

jquery

Shiny

shinydashboard

shinyjs