Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
---
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")
```
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment