00-shiny-interactive-graphics.pdf

interactivity-examples.Rmd

---
title: "Code for interactive graphics"
output: html_document
---

```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)

library(shiny)
library(ggplot2)
```


## Clicking

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", click = "plot_click", width = 400),
  verbatimTextOutput("info")
)

server <- function(input, output) {
  output$plot1 <- renderPlot({
    plot(mtcars$wt, mtcars$mpg)
  })

  output$info <- renderText({
    paste0("x=", input$plot_click$x, "\n",
           "y=", input$plot_click$y)
  })
}

shinyApp(ui, server)
```


## Selecting nearest point

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", click = "plot_click", width = 400),
  verbatimTextOutput("info")
)

server <- function(input, output) {
  output$plot1 <- renderPlot({
    plot(mtcars$wt, mtcars$mpg)
  })

  output$info <- renderPrint({
    row <- nearPoints(mtcars, input$plot_click,
      xvar = "wt", yvar = "mpg",
      threshold = 5, maxpoints = 1)

    cat("Nearest point within 5 pixels:\n")
    print(row)
  })
}

shinyApp(ui, server)
```


## Adding points

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", click = "plot_click", width = 400)
)

server <- function(input, output) {
  output$plot1 <- renderPlot({
    mtc <- mtcars[, c("wt", "mpg")]

    if (!is.null(input$plot_click)) {
      mtc <- rbind(mtc,
        data.frame(wt = input$plot_click$x, mpg = input$plot_click$y)
      )
    }
    
    plot(mtc$wt, mtc$mpg)
  })
}

shinyApp(ui, server)
```


## State accumulation

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", click = "plot_click", width = 400)
)

server <- function(input, output) {
  vals <- reactiveValues(mtc = mtcars[, c("wt", "mpg")])

  observeEvent(input$plot_click, {
    vals$mtc <- rbind(vals$mtc,
      data.frame(wt = input$plot_click$x, mpg = input$plot_click$y)
    )
  })

  output$plot1 <- renderPlot({
    plot(vals$mtc$wt, vals$mtc$mpg)
  })
}

shinyApp(ui, server)
```


## Returning values

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", click = "plot_click", width = 400),
  actionButton("done", "Done")
)

server <- function(input, output, session) {
  vals <- reactiveValues(mtc = mtcars[, c("wt", "mpg")])

  observeEvent(input$plot_click, {
    vals$mtc <- rbind(vals$mtc,
      data.frame(wt = input$plot_click$x, mpg = input$plot_click$y)
    )
  })
    
  output$plot1 <- renderPlot({
    plot(vals$mtc$wt, vals$mtc$mpg)
  })
  
  observeEvent(input$done, {
    stopApp(vals$mtc)
  })
}
app <- shinyApp(ui, server)

value <- runApp(app)
```


## Exercises

* With a scatterplot, display information about a point when you hover over it.
* Remove a point when you click on it.
* Add a "Done" button that quits and returns the updated data.

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", width = 400)
)

server <- function(input, output) {
  output$plot1 <- renderPlot({
    plot(mtcars$wt, mtcars$mpg)
  })
}

shinyApp(ui, server)
```


## Data structures

```{r eval=FALSE}
ui <- fluidPage(
  # Some custom CSS for a smaller font for preformatted text
  tags$head(
    tags$style(HTML("
      pre, table.table {
        font-size: smaller;
      }
    "))
  ),

  fluidRow(
    column(width = 6,
      # In a plotOutput, passing values for click, dblclick, hover, or brush
      # will enable those interactions.
      plotOutput("plot1", height = 350,
        # Equivalent to: click = clickOpts(id = "plot_click")
        click = "plot_click",
        dblclick = dblclickOpts(
          id = "plot_dblclick"
        ),
        hover = hoverOpts(
          id = "plot_hover"
        ),
        brush = brushOpts(
          id = "plot_brush"
        )
      )
    )
  ),
  fluidRow(
    column(width = 3,
      verbatimTextOutput("click_info")
    ),
    column(width = 3,
      verbatimTextOutput("dblclick_info")
    ),
    column(width = 3,
      verbatimTextOutput("hover_info")
    ),
    column(width = 3,
      verbatimTextOutput("brush_info")
    )
  )
)


server <- function(input, output) {
  output$plot1 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg)) + geom_point()
  })

  output$click_info <- renderPrint({
    cat("input$plot_click:\n")
    str(input$plot_click)
  })
  output$hover_info <- renderPrint({
    cat("input$plot_hover:\n")
    str(input$plot_hover)
  })
  output$dblclick_info <- renderPrint({
    cat("input$plot_dblclick:\n")
    str(input$plot_dblclick)
  })
  output$brush_info <- renderPrint({
    cat("input$plot_brush:\n")
    str(input$plot_brush)
  })
}


shinyApp(ui, server)
```


## Brushing

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", width = 400,
    brush = "plot_brush"
  ),
  verbatimTextOutput("info")
)

server <- function(input, output) {
  output$plot1 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg)) + geom_point()
  })

  output$info <- renderPrint({
    rows <- brushedPoints(mtcars, input$plot_brush)
    cat("Brushed points:\n")
    print(rows)
  })
}

shinyApp(ui, server)
```

If you know that your app will be running locally, you can speed up responsiveness with `delay`:

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("plot1", width = 400,
    brush = brushOpts(id = "plot_brush",
      delayType = "throttle",
      delay = 30
    )
  ),
  verbatimTextOutput("info")
)

server <- function(input, output) {
  output$plot1 <- renderPlot({
    ggplot(mtcars, aes(wt, mpg)) + geom_point()
  })

  output$info <- renderPrint({
    rows <- brushedPoints(mtcars, input$plot_brush)
    cat("Brushed points:\n")
    print(rows)
  })
}

shinyApp(ui, server)
```


## Linked brushing

```{r eval=FALSE}
ui <- basicPage(
  fluidRow(
    column(width = 6,
      plotOutput("scatter1", 
        brush = brushOpts(id = "brush")
      )
    ),
    column(width = 6,
      plotOutput("scatter2")
    )
  )
)

server <- function(input, output) {
  output$scatter1 <- renderPlot({
    ggplot(mtcars, aes(disp, hp)) +
      geom_point(size = 3, shape = 21, fill = "white", colour = "black") +
      theme_bw(base_size = 16)
  })

  output$scatter2 <- renderPlot({
    brushed <- brushedPoints(mtcars, input$brush)
    ggplot(mtcars, aes(wt, mpg)) +
      geom_point(size = 3, shape = 21, fill = "white", colour = "black") +
      geom_point(data = brushed, colour = "#4488ee", size = 3) +
      theme_bw(base_size = 16)
  })
}

shinyApp(ui, server)
```


## Linked zooming

```{r eval=FALSE}
ui <- basicPage(
  plotOutput("zoom", height = "350px"),
  plotOutput("overall", height = "150px",
    brush =  brushOpts(id = "brush", direction = "x")
  )
)

server <- function(input, output) {
  ss <- data.frame(
    n = as.numeric(sunspots),
    year = rep(1749:1983, each = 12) + (0:11)/12
  )

  p <- ggplot(ss, aes(year, n)) +
    geom_line() +
    theme_bw(base_size = 16)
  
  output$zoom <- renderPlot({
    if (!is.null(input$brush)) {
      p <- p + xlim(input$brush$xmin, input$brush$xmax)
    }
    p
  })

  output$overall <- renderPlot(p)
}

shinyApp(ui, server)
```


## Gadget demo

```{r eval=FALSE}
library(shiny)

# Example usage:
# lmGadget(mtcars, "wt", "mpg")
#
# Returns a list with two items:
#   $data: Data with excluded rows removed.
#   $model: lm (model) object.
lmGadget <- function(data, xvar, yvar) {
  library(miniUI)
  library(ggplot2)

  ui <- miniPage(
    gadgetTitleBar("Interactive lm"),
    miniContentPanel(
      fillRow(flex = c(NA, 1),
        fillCol(width = "100px",
          selectInput("degree", "Polynomial degree", c(1, 2, 3, 4))
        ),
        plotOutput("plot1",
          height = "100%",
          click = "plot1_click",
          brush = brushOpts(
            id = "plot1_brush"
          )
        )
      )
    ),
    miniButtonBlock(
      actionButton("exclude_toggle", "Toggle points"),
      actionButton("exclude_reset", "Reset")
    )
  )

  server <- function(input, output) {
    # For storing which rows have been excluded
    vals <- reactiveValues(
      keeprows = rep(TRUE, nrow(data))
    )

    output$plot1 <- renderPlot({
      req(input$degree)
      formula <- as.formula(paste0("y ~ poly(x, degree = ", input$degree, ")"))

      # Plot the kept and excluded points as two separate data sets
      keep    <- data[ vals$keeprows, , drop = FALSE]
      exclude <- data[!vals$keeprows, , drop = FALSE]

      ggplot(keep, aes_string(xvar, yvar)) +
        geom_point(size = 3) +
        geom_smooth(method = lm, formula = formula, fullrange = TRUE, color = "gray50") +
        geom_point(data = exclude, fill = NA, color = "black", size = 3, alpha = 0.25) +
        coord_cartesian(xlim = range(data[[xvar]]), ylim = range(data[[yvar]])) +
        theme_bw(base_size = 14)
    })

    # Toggle points that are clicked
    observeEvent(input$plot1_click, {
      res <- nearPoints(data, input$plot1_click, allRows = TRUE)

      vals$keeprows <- xor(vals$keeprows, res$selected_)
    })

    # Toggle points that are brushed, when button is clicked
    observeEvent(input$exclude_toggle, {
      res <- brushedPoints(data, input$plot1_brush, allRows = TRUE)

      vals$keeprows <- xor(vals$keeprows, res$selected_)
    })

    # Reset all points
    observeEvent(input$exclude_reset, {
      vals$keeprows <- rep(TRUE, nrow(data))
    })

    # Handle the Done button being pressed.
    observeEvent(input$done, {
      # Replace x and y in the formula with the values in xvar and yvar
      formula <- as.formula(paste0(yvar, " ~ poly(", xvar, ", degree = ", input$degree, ")"))
      keep_data <- data[vals$keeprows, , drop = FALSE]

      # Return the kept points.
      stopApp(
        list(
          data = keep_data,
          model = lm(formula, keep_data)
        )
      )
    })

  }

  runGadget(ui, server)
}

lmGadget(mtcars, "wt", "mpg")
```