R Shiny: Adding to plot via a loop

后端 未结 1 1441
佛祖请我去吃肉
佛祖请我去吃肉 2021-01-28 13:19

I\'m trying to create an app that displays an animation of sampling means using Shiny. Something similar to the example shown here.

Here\'s some minimal code showing jus

1条回答
  •  野趣味
    野趣味 (楼主)
    2021-01-28 13:47

    You can use reactiveTimer to do that. I have modified the server part of your code. In the code below I have set the timer for two seconds so that the plot updates every two seconds.

      server <- function(input, output) {
    
        autoInvalidate <- reactiveTimer(2000)
        plot1 <- NULL
    
        output$plot1 <- renderPlot({
          plot1 <<- ggplot(data, aes(x=x, y=y)) + geom_point(colour="red") + theme_bw()
          plot1 <<- plot1 + geom_vline(xintercept = mean(data$x), size=1.1, colour="red")
          plot1
        })
    
        observeEvent(input$button,{
    
          output$plot1 <- renderPlot({
            autoInvalidate()
            data$sampled <- "red"
            sample.rows <- sample(data$ID, 20, replace = F)
            data$sampled[sample.rows] <- "green"
    
            plot1 <<- plot1 + geom_point(x=data$x, y=data$y, colour=data$sampled, size=2)
    
            sample.mean.x <- mean(data$x[sample.rows])
    
            plot1 <<- plot1 + geom_vline(xintercept = sample.mean.x, colour="green")
    
            plot1
    
          })
        })
      }
    

    [EDIT]:

    As you wanted the loop to be run only 20 times I have modified the code with the help of the answer in this link so that the reactive timer is run only till the count is 20. Here is the code that you need to add from the link:

      invalidateLaterNew <- function (millis, session = getDefaultReactiveDomain(), update = TRUE) 
      {
        if(update){
          ctx <- shiny:::.getReactiveEnvironment()$currentContext()
          shiny:::timerCallbacks$schedule(millis, function() {
            if (!is.null(session) && session$isClosed()) {
              return(invisible())
            }
            ctx$invalidate()
          })
          invisible()
        }
      }
    
      unlockBinding("invalidateLater", as.environment("package:shiny"))
      assign("invalidateLater", invalidateLaterNew, "package:shiny")
    

    Here is the server code for it:

    server <- function(input, output, session) {
    
    count = 0
    plot1 <- NULL
    
    
      output$plot1 <- renderPlot({
        plot1 <<- ggplot(data, aes(x=x, y=y)) + geom_point(colour="red") + theme_bw()
        plot1 <<- plot1 + geom_vline(xintercept = mean(data$x), size=1.1, colour="red")
        plot1
      })
    
    observeEvent(input$button,{
     count <<- 0
      output$plot1 <- renderPlot({
    
        count <<- count+1
        invalidateLater(1500, session,  count < 20)
        data$sampled <- "red"
        sample.rows <- sample(data$ID, 20, replace = F)
        data$sampled[sample.rows] <- "green"
    
        plot1 <<- plot1 + geom_point(x=data$x, y=data$y, colour=data$sampled, size=2)
    
        sample.mean.x <- mean(data$x[sample.rows])
    
        plot1 <<- plot1 + geom_vline(xintercept = sample.mean.x, colour="green")
    
        plot1
    
      })
    })
    
    
     }
    

    0 讨论(0)
提交回复
热议问题