Задача с динамически генерируемыми интерактивными графиками R Shiny (в основном функционирующим кодом) - PullRequest
Новая
       7

Задача с динамически генерируемыми интерактивными графиками R Shiny (в основном функционирующим кодом)

0 голосов
/ 25 января 2019

Ниже указан минимальный код.Это работает, но есть странная проблема.Вот что работает:

  1. Пользователь может выбрать количество графиков (по умолчанию 3).
  2. Пользователь может щелкнуть график и отобразить это значение (частично работает).

Действия по воспроизведению «частично работ»:

  1. При запуске щелкните на графике № 3, нет проблем.
  2. Кликните на графике №2, ничего не происходит.
  3. Уменьшите количество графиков с 3 до 2, а затем верните до 3.
  4. Кликните на графике №2, теперь оноработает.
  5. Щелкните на графике № 1, ничего не происходит.
  6. Уменьшите количество графиков с 3 до 1, а затем верните до 3.
  7. Нажмите на графике № 1,теперь это работает.

Если вы перезагрузите приложение и начнете с шага 6, описанного выше, все графики будут интерактивными, как и ожидалось. 

rm(list=ls())
library(shiny)

#
# Dynamic number of plots: https://stackoverflow.com/questions/26931173/shiny-r-renderplots-on-the-fly
# That can invalidate each other: https://stackoverflow.com/questions/33382525/how-to-invalidate-reactive-observer-using-code
#

ui <- (fluidPage(sidebarLayout(
         sidebarPanel(
            numericInput("np", "Plots:", min=0, max=10, value=3, step=1)
         )
         ,mainPanel(
            fluidRow(uiOutput("plots"))
         )
)))

server <- function(input, output, session) {
   val <- reactiveValues()
   dum <- reactiveValues(v=0)
   obs <- list()

    ### This is the function to break the whole data into different blocks for each page
    plotInput <- reactive({
      print("Reactive")
      np <- input$np
      for(i in 1:np) {
         cx <- paste0("clk_p",i); dx <- paste0("dbl_p",i); px <- paste0("p",i)
         obs[[cx]] <- observeEvent(input[[cx]], {
            req(input[[cx]]); val[[px]] <- input[[cx]]$x; dum$v <- dum$v+1; print(paste("Dum",dum$v))
         })
         obs[[dx]] <- observeEvent(input[[dx]], {
            req(input[[dx]]); val[[px]] <- NULL
         })
      }

      return (list(np=np))
    })

    ##### Create divs######
    output$plots <- renderUI({
      print("Tag plots")
      pls <- list()
      for(i in 1:plotInput()$np) {
         pls[[i]] <- column(4,
                           plotOutput(paste0("p",i), height=200, width=200
                                     ,click=paste0("clk_p",i)
                                     ,dblclick=paste0("dbl_p",i))
                         )
      }
      tagList(pls)
    })

    observe({
      print("Observe")
      lapply(1:plotInput()$np, function(i){
        output[[paste("p", i, sep="") ]] <- renderPlot({
          print(paste("Plot",dum$v))
          x <- val[[paste0("p",i)]]
          x <- ifelse(is.null(x),"NA",round(x,2))
          par(mar=c(2,2,2,2))
          plot(x=runif(20), y=runif(20), main=i, xlim=c(0,1), ylim=c(0,1), pch=21, bg="gray", cex=1.5)
          if(is.numeric(x)) abline(v=x, col="blue")
          rm(x)
        })
      })
    })
}

shinyApp(ui, server)

1 Ответ

0 голосов
/ 11 февраля 2019

Вот рабочая версия того, что вы пытаетесь сделать: 

library(shiny)

ui <- fluidPage(
  sidebarPanel(
    numericInput("num", "Plots:", 3)
  ),
  mainPanel(
    uiOutput("plots")
  )
)

server <- function(input, output, session) {
  obs <- list()
  val <- reactiveValues()

  observe({
    lapply(seq(input$num), function(i){
      output[[paste0("plot", i) ]] <- renderPlot({
        click_id <- paste0("clk_p",i);
        plot(x = runif(20), y = runif(20), main=i)
        if (!is.null(val[[click_id]])) {
          abline(v = val[[click_id]], col = "blue")
        }
      })
    })
  })
  observe({
    lapply(seq(input$num), function(i){
      id <- paste0("clk_p",i);
      if (!is.null(obs[[id]])) {
        obs[[id]]$destroy()
      }
      val[[id]] <- NULL
      obs[[id]] <<- observeEvent(input[[id]], {
        cat('clicked ', id, ' ', input[[id]]$x, '\n')
        val[[id]] <- input[[id]]$x
      }, ignoreInit = TRUE)
    })
  })

  output$plots <- renderUI({
    lapply(seq(input$num), function(i) {
      id <- paste0("plot", i)
      plotOutput(id, height=200, width=200, click=paste0("clk_p",i))
    })
  })
}

shinyApp(ui,server)

Несколько основных указателей для тех, кто видит это в будущем:

  • Основная проблема с исходным кодом заключалась в том, что все наблюдатели регистрировались только для последнего идентификатора. Это немного продвинутая концепция, связанная с тем, как работают среды в R, и потому что они были созданы в цикле for. Исправление для этого заключается в использовании lapply() вместо цикла for для создания наблюдателей
  • Другая проблема заключается в том, что obs перезаписывал наблюдателей в списке, но предыдущие наблюдатели все еще существуют и могут запускать, поэтому я добавил логику в destroy() существующих наблюдателей.
  • Одно из самых важных правил в сиянии - не помещать побочные эффекты внутри реактивов (plotInput имеет побочные эффекты), поэтому я переписал код таким образом, чтобы избежать
...