Skip to content

Instantly share code, notes, and snippets.

@wch
Last active July 29, 2018 08:56
Show Gist options
  • Save wch/25a1c4ce8fc84022d3e7 to your computer and use it in GitHub Desktop.
Save wch/25a1c4ce8fc84022d3e7 to your computer and use it in GitHub Desktop.
Display the source blob
Display the rendered blob
Raw
Loading
Sorry, something went wrong. Reload?
Sorry, we cannot display this file.
Sorry, this file is invalid so it cannot be displayed.
---
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