有光泽：每个menuSubItems

时间：2017-02-16 09:18:20

标签： jquery shiny shinydashboard shinyjs

我使用shinydashboard创建了一个应用程序，其中包含一组menuItems和menuSubItems以及相应的tabItems，并且每个menuSubItems都有一个带有不同输入参数的conditionalPanel，以及一个用于不同分析和绘图任务的actionButton，现在它可以工作了在单击actionButton之前，也就是说，在menuSubItems之间切换时，conditionalPanel发生了变化，并且它在第一次单击actionButton时效果也很好，也就是说它按预期显示了html，但是在第一次单击actionButton之后，条件面板在menuSubItems之间切换时，不再像以前那样改变了，似乎在用ui点击鼠标时，menuSubItems无法更新。

确切地说，有两个问题：

  1. 在单击runButton之前，当在menusubItems之间切换时，条件parinbox会正确更改，并且它可以自由地在menusubItems之间切换，并且当第一次单击runButton时，会生成带有绘图的html并加载为预期，虽然它在第二次切换到另一个menusubItem时不起作用，输入$ sidebarmenu似乎没有改变？

  2. 如何在单击menusubItem时取消折叠parinbox？

    3. Dean Attali友好地指出，menusubItems的tabname实际上并不是应用程序中子菜单元素的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)

3 个答案:

答案 0 :(得分：1)

首先，请避免使用观察者包装反应式表达式（docker exec -it gitlab /bin/bash -c 'gitlab-rake gitlab:backup:create' ），只需将其放在服务器函数下面，如下所示：

htmlvalues()

我发现如果rmarkdown html直接注入for(item in c('subItemOne','subItemTwo','subItemThree','subItemFour')) { output[[paste(item,"html",sep="_")]] <- renderUI({ input$runButton if(input$runButton==0) return() isolate({shinyOutput(input)}) }) } ，shiny::includeHTML不会再改变，可能注入的html会破坏shinydashboard的内部设置。您可以通过将呈现的input$sidebarmenu保存到应用根目录中的tmp.html文件夹来解决此问题，然后使用www将其包含在内，或者您可以使用tags$iframe导入shiny::includeMarkdown文件而不是html。

答案 1 :(得分：1)

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

答案 2 :(得分：0)

杨建议的固定代码，但是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)
相关问题
最新问题