在 R 闪亮中，如何指定用于绘图的反应对象列？

Posted 2023-03-24

【中文标题】在 R 闪亮中，如何指定用于绘图的反应对象列？

【英文标题】：In R shiny, how to specify column of reactive object for plotting?

【发布时间】：2021-10-27 08:39:54

【问题描述】：

当第一次调用下面的 MWE 代码时，主面板中会出现一个包含 2 列的默认值的表格：左列中列出了 60 个周期，右列中列出了 60 个周期中每个周期的 20.0%。这可以正常工作，如下图第一张所示。

当用户单击主面板中的“向量图”操作按钮时，应该会出现一个图，显示 60 个周期的相同值 0.2。相反，如下面的第二张图片所示，我得到了一个 1-60 的值（来自表格的第一列）的图，然后是 20 的值，用于 61-120 期间。这是不正确的。

在下面的 MWE 中生成的对象是表格和绘图共有的vectorsAll。

如何指定要绘制的vectorsAll 的正确列（第二列）？它目前绘制第一列 (1-60)，我不知道为什么它会用完 120。

我正在尝试在原生 Shiny 中执行此操作，没有像 ggplot 这样的其他绘图包。

在操作此应用程序时，如果用户点击侧边栏面板中的“输入负债”操作按钮，模态对话框中会出现输入矩阵网格。在这个 MWE 中只有第一行“A”是可操作的。如果用户更改 R 中的值，它会立即反映在主面板表中（正常工作）和绘图。

我对这段代码进行了足够的精简，因此不需要 shinyWidgets 包 --- 我认为。

请注意，output$graph1 <-renderPlot(plot(sapply... 下面的行从vectorsAll 对象中去除了 % 符号。

MWE 代码：

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

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("Liabilities module", value=4,
                 fluidRow(h5(strong(helpText("Select model output to view:")))),
                 fluidRow(
                   actionButton('showVectorValueBtn','Vector values'),
                   actionButton('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(sapply(vectorsAll(),function(x)gsub("%","",x)))) 
  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, showModal, showModal function, and observeEvent, in that order
) # close server

shinyApp(ui, server)

【参考方案1】：

也许这会解决它。

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

【讨论】：

效果很好，谢谢。我正在尝试vectorsAll（[，2]），但现在我看到[]中的行/列定位器需要跟随（）而不是驻留在（）内。所以正确的语法是 object()[r,c]。通过这样重复，也许我最终会记得。我休了 2 周的假期，在那段时间里似乎忘记了很多事情。