在 R Shiny 中，如何为反应对象渲染绘图？

Posted 2023-03-24

【中文标题】在 R Shiny 中，如何为反应对象渲染绘图？

【英文标题】：In R shiny, how do you render a plot for a reactive object?

【发布时间】：2021-10-26 16:19:00

【问题描述】：

我在 Shiny 中渲染了很多情节，但这个让我很吃惊。运行以下 MWE 代码时，默认数据表会正确呈现在“负债模块”选项卡下的主面板中。此数据表是首次打开此选项卡时的默认视图。请参阅下面的第一张图片以了解其外观。

但是，当我在同一个“负债模块”主面板中单击“向量图”操作按钮时，我得到 错误：需要有限的 'ylim' 值，如下图 2 所示.

用于渲染数据表（按预期工作）和绘图（不起作用）的反应对象是相同的 - vectorsAll。

如何绘制vectorsAll 对象？这样当用户在没有先点击侧边栏面板中的“输入负债”操作按钮的情况下点击“向量图”操作按钮时，现在会绘制来自默认表的相同数据（60 个周期的值为 0.2）？此外，当用户单击“输入负债”操作按钮并更改矩阵输入网格的 A 行中的值时，数据表和绘图都应相应更新（根据用户更改数据表的正确更新行从 0.2 到 0.23 的输入矩阵如下图 3 所示）。

我想把它保存在原生 Shiny 中，没有 ggplot 或其他绘图包。随着它的进展，我会在以后让这个应用程序变得更漂亮。

MWE 代码：

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

button2 <- function(x,y)actionButton(x,y,style="width:90px;margin-bottom:5px;font-size:80%")

matrix1Input <- 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")

pct <- function(x)paste(format(round(x*100,digits=1),nsmall=1),"%",sep="") # convert to percentage

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

ui <- 
  pageWithSidebar(
    headerPanel("Model..."),
    sidebarPanel(
      fluidRow(helpText(h5(strong("Base Input Panel")),align="center",
                        style="margin-top:-15px;margin-bottom:5px")),
      # Panels rendered with uiOuput & renderUI in server to stop flashing at invocation
      uiOutput("Panels") 
    ), # close sidebar panel
    mainPanel(
      tabsetPanel(
        tabPanel("By balances", value=2),
        tabPanel("By accounts", value=3), 
        tabPanel("Liabilities module", value=4,
                 fluidRow(h5(strong(helpText("Select model output to view:")))),
                 fluidRow(
                   button2('showVectorValueBtn','Vector values'),
                   button2('showVectorPlotBtn','Vector plots'),
                 ), # close fluid row
                 
                 div(style = "margin-top: 5px"),
                 
                 # Shows outputs on each page of main panel   
                 uiOutput('showResults')), 
        id = "tabselected"
      ) # close tabset panel
    ) # close main panel
  ) # close page with sidebar

server <- function(input,output,session)(
  
  base_input  <- reactive(input$base_input)
  showResults <- reactiveValues()
  
  yield   <- function()vectorBase(60,input$base_input[1,1]) # Must remain in server section
  
  # --- Conditional panels rendered here rather than in UI to eliminate invocation flashing ------------>
  output$Panels <- renderUI(
    tagList( 
      conditionalPanel(
        condition="input.tabselected==4",
        actionButton('showLiabilityGrid','Input Liabilities',style='width:100%;background-color:LightGrey'),
        setShadow(id='showLiabilityGrid'),
        div(style = "margin-bottom: 10px"),
      ), # close conditional panel
      conditionalPanel(condition="input.tabselected==3"),
      conditionalPanel(condition="input.tabselected==4")
    ) # close tagList
  ) # close renderUI
  
  # --- Below defines the vectorsAll object before user clicks on actionButton "Input Liabilities" ---->
  vectorsAll <- reactive(
    if (is.null(input$showLiabilityGrid))df <- NULL
    else 
      if(input$showLiabilityGrid < 1)df <- cbind(Period = 1:60,Yld_Rate = pct(0.2))  # define what you want to display by default
      else 
        req(input$base_input)
        df <- cbind(Period = 1:60,Yld_Rate = pct(yield()[,2]))
       # close 2nd else
     # close 1st else
    df
  ) # close reactive
  
  output$table1 <- renderTable(vectorsAll())
  
  # --- Below produces vector values after clicking "Vector Values" button; see above for pre-click ---->
  observeEvent(input$showVectorValueBtn,
               showResults$showme <-
                 tagList(tableOutput("table1"))
               ,ignoreNULL = FALSE)
  
  # --- Below produces vector plots -------------------------------------------------------------------->   
  output$graph1 <-renderPlot(plot(vectorsAll()))
  observeEvent(input$showVectorPlotBtn,showResults$showme <- plotOutput("graph1"))
  
  # --- Below sends both vector plots and vector values to UI section above ---------------------------->
  output$showResults <- renderUI(showResults$showme)
  
  # --- Below for modal dialog inputs ------------------------------------------------------------------>
  observeEvent(input$showLiabilityGrid,
               showModal(modalDialog(
                 matrix1Input("base_input"),
                 div(style = "margin-top: 0px"),
                 useShinyjs(),
               ) # close modalDialog
               ) # close showModal
                # close showModal function
  ) # close observeEvent
  
) # close server

shinyApp(ui, server)

【问题讨论】：

我认为要使这个问题更笼统，你应该删除所有不必要的问题。

完全同意。在这种情况下，我急于离开办公室，以至于我没有花时间将其归结为本质。我通常会尝试总结并概括我的问题。

【参考方案1】：

您的变量/列Yld_Rate 是其中包含% 的字符。一旦将其替换为缺失值，它就可以正常工作。试试这个

output$graph1 <-renderPlot(plot(sapply(vectorsAll(), function(x)gsub("%", "", x))))

【讨论】：

嗨 YBS，仔细观察后，y 轴需要显示 0.2（默认值）所有周期，x 轴需要用完 60 个周期。在此期间，我会尝试解决此问题。

OK 在 YBS 的相关帖子中我看到正确的语法应该是： output$graph1