shiny: verschiedene Aufgaben mit actionButton für jedes menuSubItems

Question

Ich habe eine App mit shinydashboard mit einer Gruppe von menuItems und menuSubItems sowie den entsprechenden tabItems erstellt, und es gibt ein conditionalPanel mit verschiedenen Eingabeparametern für jedes menuSubItems und einen actionButton für verschiedene Analyse und Plotten Aufgabe, jetzt funktioniert es, bevor der actionButton geklickt wird, das heißt, das conditionalPanel geändert, wenn zwischen menuSubItems, und es funktioniert auch gut zum ersten Mal actionButton ist angeklickt, das ist es zeigen eine Plot-HTML wie erwartet, aber Nach dem ersten Klick auf actionButton ändert sich das conditionalPanel nicht mehr wie zuvor beim Wechsel zwischen menuSubItems. Es scheint, dass die menuSubItems nicht aktualisiert werden können, wenn sie im UI mit der Maus angeklickt werden.

genau, gibt es zwei Probleme:

1. vor dem runButton geklickt wird, die condtional parinbox korrekt geändert, wenn zwischen menusubItems Schalt und kann frei zwischen menusubItems swithching, und wenn das erste Mal die runButton ist geklickt, ein html mit einem Plot wird erzeugt und geladen wie erwartet, während es beim zweiten Aufruf beim switchen zu einem anderen menusubItem nicht funktioniert, die Eingabe $ sidebarmenu scheint nicht verändert zu sein?

2. Wie dekomprimiere ich die Parinbox, wenn auf ein menusubItem geklickt wird?

Dean Attali hat darauf freundlich, dass tabname von menusubItems nicht tatsächlich die ID des Untermenü-Elements in der App zu gehen, kann dies die Ursache ist, aber ich weiß nicht, wie es zu beheben, jede Hilfe wird geschätzt.

ein minimaler wiederholbar Code ist wie folgt:

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) 

Answer 1

Für die Ausgabe von runButton isolieren, ich glaube, Sie den Server-Code diese ändern können:

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

Answer 2

Zunächst vermeiden bitte reaktiven Ausdruck (htmlvalues()) mit Beobachtern Einwickeln, es nur unter der Server-Funktion wie folgen setzen außen:

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

Ich fand, wenn ein rmarkdown HTML direkt mit shiny::includeHTML injiziert wird, würde die input$sidebarmenu nicht mehr ändern, vielleicht würde die injizierte HTML die inneren Einstellungen von Shinydashboard zerstören. Sie könnten dies lösen, indem Sie den gerenderten Ordner tmp.html in den Ordner www im Stammverzeichnis Ihrer App speichern und dann tags$iframe verwenden, um ihn einzuschließen, oder Sie können shiny::includeMarkdown verwenden, um die Datei tmp.md anstelle des HTML-Codes zu importieren.

Answer 3

der feste Code vorgeschlagen von Yang arbeitet aber mit dem Isolat von runButton scheint nicht funktioniert:

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)