r-在rshiny中的反应性事件中观察刷子

Question

我正在为我的初始表中选择的每条线显示标签图。我希望这些图在此处找到刷子/缩放功能。

这是我的代码：

library(shiny)
library(DT)
library(ggplot2)
library(scales)
library(reshape2)

首先是ui：下面带有选项卡UI的主表是响应主表中的行选择

中的行

ui <- fluidPage(
  mainPanel(
    fluidRow(
      column(12,DT::dataTableOutput(outputId = 'tableCurrencies'))
    ),
    fluidRow(
      uiOutput("selectedTabs")
    )
  )
)

则server函数：为示例起见，主表值是随机生成的。brush功能直接从提供的链接中提起。我怀疑我的问题与反应性功能中的反应功能有关，但我很高兴让专家决定。

server <- function(input,output){
  output$tableCurrencies <- DT::renderDataTable({datatable(data.frame(a=rnorm(10),b=rnorm(10),c=rnorm(10)))})
  origTable_selected <- reactive({
    ids <- input$tableCurrencies_rows_selected
    return(ids)
  })
  rangeRates <- reactiveValues(xRate = NULL, yRate = NULL)
  output$selectedTabs <- renderUI({
    myTabs <- lapply(origTable_selected(),function(i) {

      tabName <- paste0("test",i)
      a <- renderPlot({
        hist(rnorm(50))
      })
      output[[paste0(tabName,"rates")]] <- a
      #plot of realized vol and implied vols over 5 years
      observeEvent(input[[paste0(tabName,"rates_dblclick")]], {
        brush <- input[[paste0(tabName,"rates_brush")]]
        if (!is.null(brush)) {
          rangeRates$xRate <- c(brush$xmin, brush$xmax)
          rangeRates$yRate <- c(brush$ymin, brush$ymax)
        } else {
          rangeRates$xRate <- NULL
          rangeRates$yRate <- NULL
        }
      })
      return(tabPanel(
        tabName,
        fluidRow(
          column(6,plotOutput(paste0(tabName,"rates")))
        )
      ))
    })
    return(do.call(tabsetPanel,myTabs))
  })
}
app = shinyApp(ui,server)
runApp(app,port=3250,host='0.0.0.0')

Answer 1

您需要在plotOutput呼叫

中分配" Doubleclick ID"one_answers" Brush ID"

column(6, plotOutput(paste0(tabName, "rates"),
                     dblclick = paste0(tabName, "rates_dblclick"),
                     brush = brushOpts(
                       id = paste0(tabName, "rates_brush"),
                       resetOnNew = TRUE
                    )))

现在，观察者正确触发并发送正确的信息。rangeRates仍然存在第二个问题，对图可以解决以下方式

a <- renderPlot({
  if (!is.null(rangeRates$xRate))
    hist(rnorm(50), xlim = rangeRates$xRate,
         ylim = rangeRates$yRate)
  else
    hist(rnorm(50))
})

这是完整的工作版本

library(shiny)
library(DT)
ui <- fluidPage(
  mainPanel(
    fluidRow(column(12, DT::dataTableOutput(outputId = 'tableCurrencies'))),
    fluidRow(uiOutput("selectedTabs"))
  )
)
server <- function(input, output){      
  output$tableCurrencies <- DT::renderDataTable({
    data.frame(a = rnorm(10), b = rnorm(10), c = rnorm(10))
  })
  origTable_selected <- reactive({
    ids <- input$tableCurrencies_rows_selected
    return(ids)
  })
  rangeRates <- reactiveValues(xRate = NULL, yRate = NULL)
  output$selectedTabs <- renderUI({
    myTabs <- lapply(
      origTable_selected(), 
      function(i) {       
        tabName <- paste0("test", i)
        output[[paste0(tabName, "rates")]] <- renderPlot({
          if( !is.null(rangeRates$xRate) )
            hist(rnorm(50), xlim = rangeRates$xRate,
                 ylim = rangeRates$yRate)
          else
            hist(rnorm(50))
        })
        observeEvent(input[[paste0(tabName, "rates_dblclick")]], {
          brush <- input[[paste0(tabName, "rates_brush")]]
          if (!is.null(brush)) {
            rangeRates$xRate <- c(brush$xmin, brush$xmax)
            rangeRates$yRate <- c(brush$ymin, brush$ymax)              
          } else {
            rangeRates$xRate <- NULL
            rangeRates$yRate <- NULL
          }
        })
        tabPanel(
          tabName,
          fluidRow(column(6, plotOutput(
            paste0(tabName, "rates"),
            dblclick = paste0(tabName, "rates_dblclick"),
            brush = brushOpts(
              id = paste0(tabName, "rates_brush"),
              resetOnNew = TRUE)
          )))
        )
      })
    return(do.call(tabsetPanel, myTabs))
  })
}
shinyApp(ui, server)