R Shiny: Adding to plot via a loop

Question

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 just the section I'm having trouble with. This is not the data I'm using, but a reproducible example data set.

library(shiny)
library(ggplot2)

data <- data.frame(ID=1:60, 
                   x=sort(runif(n = 60)), 
                   y=sort(runif(n = 60)+rnorm(60)))

ui <- fluidPage(
    sidebarPanel(
        sliderInput("n",
                    "Number of samples:",
                    min = 10,
                    max = 100,
                    value = 20),

        sliderInput("surveys",
                    "Number of surveys:",
                    min = 10,
                    max = 100,
                    value = 20),

        checkboxInput("replacement", 
                      "Sample with replacement?"),

        actionButton("button", "Go!")
    ),
    # Show the plot
    mainPanel(
        plotOutput("plot1")
    )
)

server <- function(input, output) {
    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

        for(i in 1: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")

            print(plot1)
            Sys.sleep(1.5)
        }
    })
}

# Run the application 
shinyApp(ui = ui, server = server)

The part within renderPlot({ ... }) does exactly what I want when pasted into the console, but how do I get this to happen in Shiny? Ideally, I would also like the plot to appear first, and then the animation (green bars) to start when the actionButton is clicked.

Thanks!

Answer 1

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

  })
})


 }