r - 在 R Shiny 中，如何使用操作按钮更改主面板中的输出？

Question

下面的 MWE 代码大部分都按预期工作（有一些小错误，出于示例的目的，这些小错误并不重要；这些是在精简代码以方便演示时出现的）。当用户输入到左侧的侧面板时，主面板中的绘图输出会反应（立即）反映这些输入。到目前为止我想要什么。

请注意主面板顶部的 2 个操作按钮：“向量图”和“向量值”（分别为 id = 'showVectorPlotBtn' 和 'showVectorValueBtn'）。我将如何调整代码以反映以下功能？(a) 当用户点击“向量值”时，该图将替换为具有相同值的数据表——该数据表将具有与该图相同的反应性；(b) 当用户在查看“向量值”的同时单击“向量图”时，该图会在不重置值的情况下恢复——最后输入的值会保留在图中；(c) 首次调用应用程序时，主面板始终默认显示当前的绘图。

如何才能做到这一点？我一直在摆弄这个并且被卡住了。

这是 MWE 代码：

library(shiny)
library(shinyMatrix)
library(shinyjs)

matrix1.input <- function(x){
  matrixInput(x, 
              value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
              rows = list(extend = FALSE,  names = TRUE),
              cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
              class = "numeric")}

matrix2.input <- function(x,y,z){
  matrixInput(x,
              value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
              rows = list(extend = TRUE,  names = FALSE),
              cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
              class = "numeric")}  

matrix.validate <- function(x,y){
  a <- y
  a[,1][a[,1]>x] <- x 
  b <- diff(a[,1,drop=FALSE])
  b[b<=0] <- NA
  b <- c(1,b)  
  a <- cbind(a,b)
  a <- na.omit(a)
  a <- a[,-c(3),drop=FALSE]
  return(a)}

vector.base <- function(x,y){
  a <- rep(y,x)
  b <- seq(1:x)
  c <- data.frame(x = b, y = a)
  return(c)}

vector.multi <- function(x,y,z){                                            
  a <- rep(NA, x)
  a[y] <- z                                       
  a[seq_len(min(y)-1)] <- a[min(y)]               
  if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}     
  a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y    
  b <- seq(1:x)                                                       
  c <- data.frame(x = b, z = a)                                       
  return(c)}

vector.multiFinal <- function(x,y){vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}

button  <- function(x,y){actionButton(x,y,)}

matrix.link <- function(x,y){
  observeEvent(input$periods|input$base_input,{
    updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))})}

ui <- 
  pageWithSidebar(
    headerPanel("Model"),
    sidebarPanel(uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Dynamic", value=2,
                 helpText("Select output:"),
                 actionButton('showVectorPlotBtn','Vector plots',style="width:90px;font-size:80%"),
                 actionButton('showVectorValueBtn','Vector values',style="width:90px;font-size:80%"),
                 plotOutput("graph1")),
        tabPanel("Data", value=3, 
                 conditionalPanel(condition="input.choice==2"),
                 conditionalPanel(condition="input.choice==3")),
        tabPanel("Plot", value=4, plotOutput("plot")), 
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  periods              <-  reactive(input$periods)
  base_input           <-  reactive(input$base_input)
  vector_input         <-  reactive(input$vector_input)
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        numericInput('begin.bal','',value=100000,step=1000,width = '100%'),
        sliderInput('periods','',min=1,max=120,value=60),
        matrix1.input("base_input"),
        useShinyjs(),
        actionButton('showVectorBtn','Show',style="width:8vw;margin-bottom:10px"), 
        actionButton('hideVectorBtn','Hide',style="width:8vw;margin-bottom:10px"),
        actionButton('resetVectorBtn','Reset',style="width:8vw;margin-bottom:10px"),
        hidden(uiOutput("Vectors"))),
      conditionalPanel(
        condition="input.tabselected==3"),
      conditionalPanel(
        condition="input.tabselected==4")
    ) # close tagList
  }) # close renderUI
  
  renderUI({matrix.link("vector_input",input$base_input[1,1])})
  
  output$Vectors <- renderUI({
    input$resetVectorBtn
    tagList(matrix2.input("vector_input",input$periods,input$base_input[1,1]))
  }) # close render UI
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
  
  output$graph1 <- renderPlot(
    plot(if(input$showVectorBtn == 0) vector.base(periods(),input$base_input[1,1])
         else vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))))
}) # close server

shinyApp(ui, server)

标签： rshiny

Answer 1

我不确定您要做什么。但是，您的操作按钮现在应该可以工作了。请根据您的用例进行调整。

ui <- 
  pageWithSidebar(
    headerPanel("Model"),
    sidebarPanel(uiOutput("Panels")),
    mainPanel(
      tabsetPanel(
        tabPanel("Dynamic", value=2,
                 helpText("Select output:"),
                 actionButton('showVectorPlotBtn','Vector plots',style="width:90px;font-size:80%"),
                 actionButton('showVectorValueBtn','Vector values',style="width:90px;font-size:80%"),
                 #plotOutput("graph1")
                 uiOutput("graphrtable")
                 ),
        tabPanel("Data", value=3, 
                 conditionalPanel(condition="input.choice==2"),
                 conditionalPanel(condition="input.choice==3")),
        tabPanel("Plot", value=4, plotOutput("plot")), 
        id = "tabselected")
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)({
  periods              <-  reactive(input$periods)
  base_input           <-  reactive(input$base_input)
  vector_input         <-  reactive(input$vector_input)
  rv <- reactiveValues()
  
  output$Panels <- renderUI({
    tagList( 
      conditionalPanel(
        condition="input.tabselected==2",
        numericInput('begin.bal','',value=100000,step=1000,width = '100%'),
        sliderInput('periods','',min=1,max=120,value=60),
        matrix1.input("base_input"),
        useShinyjs(),
        actionButton('showVectorBtn','Show',style="width:8vw;margin-bottom:10px"), 
        actionButton('hideVectorBtn','Hide',style="width:8vw;margin-bottom:10px"),
        actionButton('resetVectorBtn','Reset',style="width:8vw;margin-bottom:10px"),
        hidden(uiOutput("Vectors"))),
      conditionalPanel(
        condition="input.tabselected==3"),
      conditionalPanel(
        condition="input.tabselected==4")
    ) # close tagList
  }) # close renderUI
  
  renderUI({matrix.link("vector_input",input$base_input[1,1])})
  
  output$Vectors <- renderUI({
    input$resetVectorBtn
    tagList(matrix2.input("vector_input",input$periods,input$base_input[1,1]))
  }) # close render UI
  
  observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
  observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})
  
  # output$graph1 <- renderPlot(
  #   plot(if(input$showVectorBtn == 0) vector.base(periods(),input$base_input[1,1])
  #        else vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))))
  
  output$graph1 <- renderPlot({
    plot(vector.base(periods(),input$base_input[1,1]))
    #plot(cars) ## replace this with your plot
  })
  
  output$table1 <- renderDT({
    #vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))
    datatable(cars) ## replace this with your table
  })
  
  observeEvent(input$showVectorPlotBtn, {
    rv$showme <- plotOutput("graph1")
  }, ignoreNULL = FALSE)
  
  observeEvent(input$showVectorValueBtn, {
    rv$showme <- DTOutput("table1")
  })
    
  output$graphrtable <- renderUI({
    rv$showme
  })
  
  
}) # close server

shinyApp(ui, server)