Passing a reactiveEvent to update plot regression in Shiny - r

I have the following App:
The objective is to:
Add new points to the plot when the user clicks on it.
These are updated in the table (where you can remove points also)
(Where the App fails): Plot the linear regression and spline regression based on the new users updated data.
When I comment-out the lines
#geom_line(aes(x=x, y=fitlm(), color="Simple")) +
#geom_line(aes(x=x, y=fitbslm(), color="B-spline")) +
in the ggplot renderPlot() function at the end, I am able to add points and update the plot without problem
The problem occurs when I try to add these two lines back into the plot and then the updated data is passed to the fitlm and fitBslm eventReactive() functions.
For some reason it doesn't want to re-compute the regressions and apply/update the plot.
Question:
How can I introduce the regressions to the ggplot based on the new users updated data. (I am happy with it updating automatically or through a button)
After clicking the Generate Plot button it makes the below plot. However, the plot failed Error: [object Object] when I click on the plot to add a new point.
App:
library(shiny)
library(dplyr)
library(splines2)
library(ggplot2)
# Get the Temp values, which defines the accepted range of knots
# for the b-spline model.
library(dplyr)
data("airquality")
airquality <- filter(airquality, !is.na(Ozone)) %>%
select(c(Ozone, Temp)) %>%
set_names(c("x", "y"))
uniqueTemps <- unique(airquality[order(airquality$x), "x"])
selectedTemps <- sample(uniqueTemps, 2)
# Define UI for application that draws a histogram
ui <- shinyUI(fluidPage(
# Application title
titlePanel("Simple Linear vs Spline Fit"),
# Sidebar
sidebarLayout(
sidebarPanel(
selectInput("knotSel", "Select knot values for B-spline fit:",
uniqueTemps, selected=selectedTemps,
multiple=TRUE),
actionButton("calcFit", "Generate Plot"),
actionButton("computeRegressions", "Compute Regressions")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("plot_splines", click = "plot_click"),
h4("Example Data: airquality {datasets}"),
p("This plot uses linear models to predict ozone levels based on temperature readings.",
tags$br(),
tags$em("Simple formula: ")
# tags$code("lm(Ozone ~ Temp + I(Temp^2) + I(Temp^3) - 1, airquality)"),
# tags$br(),
# tags$em("Spline formula: "),
# tags$code("lm(airquality$Ozone ~ bSpline(airquality$Temp, knots=getKnots(), degree=3) - 1)")
),
fluidRow(column(width = 6,
h4("Click plot to add points"),
actionButton("rem_point", "Remove Last Point")
#plotOutput("plot1", click = "plot_click")
),
column(width = 6,
h4("Table of points on plot"),
tableOutput("table"))),
fluidRow(column(width = 6,
DTOutput('tab1')),
column(width = 6,
DTOutput('tab2'))
)
)
)))
server <- (function(input, output) {
# Load the airquality dataset.
# data("airquality")
# # Remove observations lacking an Ozone measure.
# airquality <- filter(airquality, !is.na(Ozone)) %>%
# select(c(Ozone, Temp)) %>%
# set_names(c("y", "x"))
########################### Add selections to plot ###########################
## 1. set up reactive dataframe ##
values <- reactiveValues()
values$DT <- data.frame(x = numeric(),
y = numeric()
) %>%
bind_rows(airquality)
## 2. Create a plot ##
# output$plot1 = renderPlot({
# ggplot(values$DT, aes(x = x, y = y)) +
# geom_point(size = 5) +
# lims(x = c(0, 100), y = c(0, 100)) +
# theme(legend.position = "bottom")
# # include so that colors don't change as more color/shape chosen
# # scale_color_discrete(drop = FALSE) +
# # scale_shape_discrete(drop = FALSE)
# })
## 3. add new row to reactive dataframe upon clicking plot ##
observeEvent(input$plot_click, {
# each input is a factor so levels are consistent for plotting characteristics
add_row <- data.frame(x = input$plot_click$x,
y = input$plot_click$y
)
# add row to the data.frame
values$DT <- rbind(values$DT, add_row)
})
## 4. remove row on actionButton click ##
observeEvent(input$rem_point, {
rem_row <- values$DT[-nrow(values$DT), ]
values$DT <- rem_row
})
## 5. render a table of the growing dataframe ##
output$table <- renderTable({
values$DT
})
##############################################################################
# Fit the simple linear model
fitlm <- eventReactive(input$calcFit, {
slm <- lm(y ~ x + I(x^2) + I(x^3) - 1, values$DT)
fitlm <- slm$fitted.values
fitlm
})
# Get knot selection
getKnots <- reactive({as.integer(input$knotSel)})
# Fit the spline model, with the knot selection
fitBslm <- eventReactive(input$calcFit, {
bsMat <- bSpline(values$DT$x, knots=getKnots(), degree=3)
bslm <- lm(values$DT$y ~ bsMat - 1)
bslm
})
# observeEvent({
# print(fitBslm())
# })
# Generate the plot
output$plot_splines <- renderPlot({
splineMdl <- fitBslm()
fitbslm <- splineMdl$fitted.values
cols <- c("Simple"="#ef615c", "B-spline"="#20b2aa", "knot"="black")
g <- ggplot(values$DT, aes(x=x, y=y)) +
geom_point(color="blue") +
geom_line(aes(x=x, y=fitlm(), color="Simple")) +
#geom_line(aes(x=x, y=fitbslm(), color="B-spline")) +
geom_vline(aes(color="knot"), xintercept=getKnots(), linetype="dashed", size=1) +
scale_colour_manual(name="Fit Lines",values=cols) +
ggtitle("Ozone as predicted by Temp", "(knots shown as vertical lines)")
g
})
output$tab1 <- renderDataTable(
airquality
)
output$tab2 <- renderDataTable(
values$DT
)
})
shinyApp(ui, server)

Change eventReactive to just reactive. Also, you just need fitbslm in the second geom_line without (). Try this
server <- (function(input, output) {
########################### Add selections to plot ###########################
## 1. set up reactive dataframe ##
values <- reactiveValues()
values$DT <- data.frame(x = numeric(),
y = numeric()
) %>%
bind_rows(airquality)
## 3. add new row to reactive dataframe upon clicking plot ##
observeEvent(input$plot_click, {
# each input is a factor so levels are consistent for plotting characteristics
add_row <- data.frame(x = input$plot_click$x,
y = input$plot_click$y
)
# add row to the data.frame
values$DT <- rbind(values$DT, add_row)
})
## 4. remove row on actionButton click ##
observeEvent(input$rem_point, {
rem_row <- values$DT[-nrow(values$DT), ]
values$DT <- rem_row
})
## 5. render a table of the growing dataframe ##
output$table <- renderTable({
values$DT
})
##############################################################################
# Fit the simple linear model
# fitlm <- eventReactive(input$calcFit, {
fitlm <- reactive({
slm <- lm(y ~ x + I(x^2) + I(x^3) - 1, values$DT)
fitlm <- slm$fitted.values
fitlm
})
# Get knot selection
getKnots <- reactive({as.integer(input$knotSel)})
# Fit the spline model, with the knot selection
#fitBslm <- eventReactive(input$calcFit, {
fitBslm <- reactive({
bsMat <- bSpline(values$DT$x, knots=getKnots(), degree=3)
bslm <- lm(values$DT$y ~ bsMat - 1)
bslm
})
myPlot <- reactive({
splineMdl <- fitBslm()
fitbslm <- splineMdl$fitted.values
cols <- c("Simple"="#ef615c", "B-spline"="#20b2aa", "knot"="black")
g <- ggplot(values$DT, aes(x=x, y=y)) +
geom_point(color="blue") +
geom_line(aes(x=x, y=fitlm(), color="Simple")) +
geom_line(aes(x=x, y=fitbslm , color="B-spline")) +
geom_vline(aes(color="knot"), xintercept=getKnots(), linetype="dashed", size=1) +
scale_colour_manual(name="Fit Lines",values=cols) +
ggtitle("Ozone as predicted by Temp", "(knots shown as vertical lines)")
g
})
# Generate the plot
output$plot_splines <- renderPlot({
myPlot()
})
output$tab1 <- renderDataTable(
airquality
)
output$tab2 <- renderDataTable(
values$DT
)
})

Related

Adding Zoom to a Density Plot in Shiny

I would like to be able to zoom in on the vlines in a density plot in shiny. I am using the iris dataset for reproducible purposes. The vlines are labeled with row names.
In my actual dataset, I have many vlines very close to each other. They are so close that I often cannot distinguish the row number labels. I would like to find a way to zoom in on the vline labels. I have attempted using a brush but that is not working.
library(tidyverse)
library(cluster)
library(shiny)
ui <- fluidPage({
pageWithSidebar(
headerPanel('Iris k-means clustering'),
sidebarPanel(
numericInput('clusters', 'Cluster count', 3, min = 1, max = 9)
),
mainPanel(
plotOutput('plot1',
dblclick = 'plot1_dblclick',
brush = brushOpts(
id = 'plot1_brush',
resetOnNew = TRUE
))
)
)
})
server <- function(input, output){
ClusterData <- reactive({
iris[,1:4]
})
# need to keep row numbers for outlier labels
ClusterData2 <- reactive({
ClusterData2 <- data.frame(ClusterData())
row.names(ClusterData2) <- 1:nrow(ClusterData2)
return(ClusterData2)
})
# scale the iris data
ScaledData <- reactive({
scale(ClusterData2())
})
# kmeans clustering
final <- reactive({
kmeans(ScaledData(), input$clusters, nstart = 25)
})
# find centers
states.centers <- reactive({
final()$centers[final()$cluster, ]
})
# find outliers
distances <- reactive({
sqrt(rowSums((ScaledData() - states.centers())^2))
})
# bind distances back to data
outliers <- reactive({
cbind(ClusterData(), Distance = distances())
})
# bind cluster number to data
clusterMember <- reactive({
cbind(outliers(), clusterNum = final()$cluster)
})
# turn into data frame
clusterMember2 <- reactive({
as.data.frame(clusterMember())
})
# find points that are their own cluster
dist0 <- reactive({
clusterMember() %>%
filter(distances() == 0)
})
# arrange distances largest to smallest
distArrange <- reactive({
clusterMember() %>%
arrange(desc(Distance))
})
# find top 5 outliers
filtTop5 <- reactive({
distArrange()[1:5,]
})
# bind outliers and single clusters together
AllOutliers <- reactive({
rbind(filtTop5(), dist0())
})
########## output plot
output$plot1 <- renderPlot({
ClusterData() %>%
ggplot(aes(x = Petal.Length)) +
geom_density(fill = "blue", alpha = 0.4) +
geom_vline(xintercept = AllOutliers()$Petal.Length) +
annotate("text", x = AllOutliers()$Petal.Length,
y = 0,
label = rownames(AllOutliers()),
hjust = 0.5,
vjust = -1)
})
######### zoom brush
observeEvent(input$plot1_dblclick, {
brush <- input$plot1_brush
if (!is.null(brush)) {
ranges$x <- c(brush$xmin, brush$xmax)
ranges$y <- c(brush$ymin, brush$ymax)
} else {
ranges$x <- NULL
ranges$y <- NULL
}
})
}
shinyApp(ui, server)
I am not invested in the above approach. Any suggestions would be welcome.
Thank you.
I advise you to try plotly package.
Modified code from your question:
library(tidyverse)
library(cluster)
library(shiny)
library(plotly)
ui <- fluidPage({
pageWithSidebar(
headerPanel('Iris k-means clustering'),
sidebarPanel(
numericInput('clusters', 'Cluster count', 3, min = 1, max = 9)
),
mainPanel(
plotlyOutput('plot1')
)
)
})
server <- function(input, output){
ClusterData <- reactive({
iris[,1:4]
})
# need to keep row numbers for outlier labels
ClusterData2 <- reactive({
ClusterData2 <- data.frame(ClusterData())
row.names(ClusterData2) <- 1:nrow(ClusterData2)
return(ClusterData2)
})
# scale the iris data
ScaledData <- reactive({
scale(ClusterData2())
})
# kmeans clustering
final <- reactive({
kmeans(ScaledData(), input$clusters, nstart = 25)
})
# find centers
states.centers <- reactive({
final()$centers[final()$cluster, ]
})
# find outliers
distances <- reactive({
sqrt(rowSums((ScaledData() - states.centers())^2))
})
# bind distances back to data
outliers <- reactive({
cbind(ClusterData(), Distance = distances())
})
# bind cluster number to data
clusterMember <- reactive({
cbind(outliers(), clusterNum = final()$cluster)
})
# turn into data frame
clusterMember2 <- reactive({
as.data.frame(clusterMember())
})
# find points that are their own cluster
dist0 <- reactive({
clusterMember() %>%
filter(distances() == 0)
})
# arrange distances largest to smallest
distArrange <- reactive({
clusterMember() %>%
arrange(desc(Distance))
})
# find top 5 outliers
filtTop5 <- reactive({
distArrange()[1:5,]
})
# bind outliers and single clusters together
AllOutliers <- reactive({
rbind(filtTop5(), dist0())
})
########## output plot
output$plot1 <- renderPlotly({
plot1 <- ClusterData() %>%
ggplot(aes(x = Petal.Length)) +
geom_density(fill = "#6495ed", alpha = 0.3) +
geom_vline(xintercept = AllOutliers()$Petal.Length, size = 0.5, colour = "#013220") +
annotate("text", x = AllOutliers()$Petal.Length,
y = 0,
label = rownames(AllOutliers()),
colour = "#d4240b",
size = 4)
ggplotly(plot1)
})
}
shinyApp(ui, server)
Output (zoomed with cluster count = 9):

Adding vlines to a density plot in Shiny

I am trying to add vlines to a density plot in shiny for R. For reproducible purposes, I will use the iris data set. The data is clustered using kmeans from the cluster package. Outliers are located by measuring distances from the centers of clusters. Then I wish to create a density plot that has vlines and labels for each of the outliers.
The code works outside of shiny. Inside my shiny app, I get an error message: Error in [: invalid subscript type 'list'. I have tried unlist and making the outliers a variety of other forms and still get the list error. How do I add the vlines?
Global
library(tidyverse)
library(cluster)
library(shiny)
require(iris)
UI
ui <- fluidPage({
pageWithSidebar(
headerPanel('Iris k-means clustering'),
sidebarPanel(
numericInput('clusters', 'Cluster count', 3, min = 1, max = 9)
),
mainPanel(
plotOutput('plot1')
)
)
})
Server
server <- function(input, output){
ClusterData <- reactive({
iris[,1:4]
})
# need to keep row numbers for outlier labels
ClusterData2 <- reactive({
ClusterData2 <- data.frame(ClusterData())
row.names(ClusterData2) <- 1:nrow(ClusterData2)
return(ClusterData2)
})
# scale the iris data
ScaledData <- reactive({
scale(ClusterData2())
})
# kmeans clustering
final <- reactive({
kmeans(ScaledData(), 3, nstart = 25)
})
# find centers
states.centers <- reactive({
final()$centers[final()$cluster, ]
})
# find outliers
distances <- reactive({
sqrt(rowSums((ScaledData() - states.centers())^2))
})
# bind distances back to data
outliers <- reactive({
cbind(ClusterData(), Distance = distances())
})
# bind cluster number to data
clusterMember <- reactive({
cbind(outliers(), clusterNum = final()$cluster)
})
# turn into data frame
clusterMember2 <- reactive({
as.data.frame(clusterMember())
})
# find points that are their own cluster
dist0 <- reactive({
clusterMember() %>%
filter(distances() == 0)
})
# arrange distances largest to smallest
distArrange <- reactive({
clusterMember() %>%
arrange(desc(Distance))
})
# find top 5 outliers
filtTop5 <- reactive({
distArrange()[1:5,]
})
# bind outliers and single clusters together
AllOutliers <- reactive({
rbind(filtTop5(), dist0())
})
# for density plot: vlines and labels
lines_amt <- reactive({
data.frame(vlines = (clusterMember2()$Petal.Length[c(AllOutliers())]), labels = c(AllOutliers()))
})
########## output
output$plot1 <- renderPlot({
ClusterData() %>%
ggplot(aes(x = Petal.Length)) +
geom_density(fill = "blue", alpha = 0.4) #+
geom_vline(data = lines_amt(), aes(xintercept = get(vlines)))
})
}
Run App
shinyApp(ui, server)
Thank you.
The plot should look like the link.
PetalLengthDensityPlot
I think I have it all sorted out. Essentially I removed your lines_amt() reactive, and replaced geom_vline(), while also adding an annotate() for the labels:
library(tidyverse)
library(cluster)
library(shiny)
ui <- fluidPage({
pageWithSidebar(
headerPanel('Iris k-means clustering'),
sidebarPanel(
numericInput('clusters', 'Cluster count', 3, min = 1, max = 9)
),
mainPanel(
plotOutput('plot1')
)
)
})
server <- function(input, output){
ClusterData <- reactive({
iris[,1:4]
})
# need to keep row numbers for outlier labels
ClusterData2 <- reactive({
ClusterData2 <- data.frame(ClusterData())
row.names(ClusterData2) <- 1:nrow(ClusterData2)
return(ClusterData2)
})
# scale the iris data
ScaledData <- reactive({
scale(ClusterData2())
})
# kmeans clustering
final <- reactive({
kmeans(ScaledData(), 3, nstart = 25)
})
# find centers
states.centers <- reactive({
final()$centers[final()$cluster, ]
})
# find outliers
distances <- reactive({
sqrt(rowSums((ScaledData() - states.centers())^2))
})
# bind distances back to data
outliers <- reactive({
cbind(ClusterData(), Distance = distances())
})
# bind cluster number to data
clusterMember <- reactive({
cbind(outliers(), clusterNum = final()$cluster)
})
# turn into data frame
clusterMember2 <- reactive({
as.data.frame(clusterMember())
})
# find points that are their own cluster
dist0 <- reactive({
clusterMember() %>%
filter(distances() == 0)
})
# arrange distances largest to smallest
distArrange <- reactive({
clusterMember() %>%
arrange(desc(Distance))
})
# find top 5 outliers
filtTop5 <- reactive({
distArrange()[1:5,]
})
# bind outliers and single clusters together
AllOutliers <- reactive({
rbind(filtTop5(), dist0())
})
# for density plot: vlines and labels #Made the lines and labels without this
# lines_amt <- reactive({
# data.frame(vlines = (clusterMember2()$Petal.Length[c(AllOutliers()$Petal.Length)]), labels = c(AllOutliers()))
# })
########## output
output$plot1 <- renderPlot({
ClusterData() %>%
ggplot(aes(x = Petal.Length)) +
geom_density(fill = "blue", alpha = 0.4) +
# geom_vline(xintercept = lines_amt()$vlines)
geom_vline(xintercept = AllOutliers()$Petal.Length)+ #Used this in place of your current geom_vline()
annotate("text", x = AllOutliers()$Petal.Length, #Added this to add the text
y = 0,
label = rownames(AllOutliers()),
hjust = -1,
vjust = -1)
# geom_vline(data = lines_amt(), aes(xintercept = get(vlines)))
})
}
shinyApp(ui, server)
Hopefully this helps!

How to create a clickable histogram in Shiny?

I want to create a clickable histogram in shiny but I don't know if it is possible.
Some months ago I saw a clickable volcano plot which gives you a table of what you click.
Source: https://2-bitbio.com/2017/12/clickable-volcano-plots-in-shiny.html
The closest post that I found about creating clickable histograms is this one Click to get coordinates from multiple histogram in shiny
However, I don't want to get the coordinates. I want the rownames of the dataframe.
Having this dataframe, can I get the rownames everytime I click a bar from the histogram?
mtcars <- mtcars %>%
select("hp")
mtcars <- as.matrix(mtcars)
One example (but not clickable) in shiny:
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
plotOutput("hist"),
)
)
)
mtcars <- mtcars %>%
select("hp")
mtcars <- as.matrix(mtcars)
server <- function(input, output) {
output$hist <- renderPlot({
pp <- qplot(mtcars, geom = "histogram", bins = 10, xlab="values",
ylab="Frequency", main="Histogram",
fill=I("red"), col=I("black"), alpha=I(0.4))
pp + scale_x_continuous(breaks=pretty(mtcars, n=10))
})
}
shinyApp(ui = ui, server = server)
Does anyone know how to do it?
Thanks very much in advance!
Regards
This is a great question, and what makes it challenging is that the qplot/ggplot charts are static images. The below app.r is an example of how I would do it. I'd love to see other approaches.
In essence:
Create a sequence of numbers that will be used both as the breaks in your histogram and as intervals in your dataframe. I based these on user inputs, but you could hardcode them.
Assign a "bin" value to each row in the dataframe based on the interval in which the value falls.
Record the x-coordinate from the user's click event and assign that a "bin" value based on the same set of intervals.
Subset your dataframe and retain only those records where the "bin" value of the data matches the "bin" value of the x-coordinate from the user's click event.
Otherwise, if you're willing to go the d3 route, you could explore something like this posted by R Views.
#Load libraries ----------------------------------------------------
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
# Prepare data -----------------------------------------------------
df <- mtcars
df <- cbind(model = rownames(df), data.frame(df, row.names = NULL)) # setting the rownames as the first column
dm <- df$hp %>% as.matrix()
# UI function ------------------------------------------------------
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
tags$h5("I added the below text output only to demonstrate shiny's way for tracking user interaction on static plots. You can click, double-click, or click & drag (i.e. brushing). These functions are AWESOME when exploring scatterplots."),
tags$h3("Chart click and brushing"),
verbatimTextOutput("info"),
tags$h5("Now I'm applying the below UI inputs to the `vec` and `breaks` arguments in `findInterval()` and `qplot()` respectively; I'm using `findInterval()` to bin the values in the dataframe AND to bin the x-value of the user's click event input on the chart. Then we can return the dataframe rows with the same bin values as the x-value of the click input."),
sliderInput("seq_from_to"
, label = h3("Sequence 'From' and 'To'")
, min = 0
, max = 500
, value = c(50, 350)
),
sliderInput("seq_by"
, label = h3("Sequence 'By'")
, min = 25
, max = 200
, value = 50
, step = 5)
),
mainPanel(
plotOutput("hist",
click = "plot_click",
dblclick = "plot_dblclick",
hover = "plot_hover",
brush = "plot_brush"),
dataTableOutput("table")
)
)
)
# Server function --------------------------------------------------
server <- function(input, output) {
# Render Histogram Plot
output$hist <- renderPlot({
# Using the same `qplot` function but inserting the user inputs to set the breaks values in the plot
pp <- qplot(dm
, geom = "histogram"
, breaks = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by)
, xlab = "values"
, ylab = "Frequency"
, main = "Histogram"
, fill = I("red")
, col = I("black")
, alpha = I(0.4)
)
# Also using the user inputs to set the breaks values for the x-axis
pp + scale_x_continuous(breaks = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by))
})
# This is purely explanatory to help show how shiny can read user interaction on qplot/ggplot objects
# It's taken from the Shiny docs here: https://shiny.rstudio.com/articles/plot-interaction.html
output$info <- renderText({
# Retain the x and y coords of the user click event data
xy_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("x=", round(e$x, 1), " y=", round(e$y, 1), "\n")
}
# Retain the x and y range coords of click & drag (brush) data
xy_range_str <- function(e) {
if(is.null(e)) return("NULL\n")
paste0("xmin=", round(e$xmin, 1), " xmax=", round(e$xmax, 1),
" ymin=", round(e$ymin, 1), " ymax=", round(e$ymax, 1))
}
# Paste this together so we can read it in the UI function for demo purposes
paste0(
"click: ", xy_str(input$plot_click),
"dblclick: ", xy_str(input$plot_dblclick),
"hover: ", xy_str(input$plot_hover),
"brush: ", xy_range_str(input$plot_brush)
)
})
# Back to the story. Set a listener to trigger when one of the following is updated:
toListen <- reactive({list(
input$plot_click # user clicks on the plot
, input$seq_from_to # user updates the range slider
, input$seq_by # user updates the number input
)
})
# When one of those events are triggered, update the datatable output
observeEvent(toListen(), {
# Save the user click event data
click_data <- input$plot_click
print(click_data) # during your app preview, you can watch the R Console to see what click data is accessible
# Assign bin values to each row using the intervals that are set by the user input
df$bin <- findInterval(dm, vec = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by))
# Similarly assign a bin value to the click event based on what interval the x values falls within
click_data$x_bin <- findInterval(click_data$x, vec = seq(from = input$seq_from_to[1], to = input$seq_from_to[2], by = input$seq_by))
# Lastly, subset the df to only those records within the same interval as the click event x-value
df_results <- subset(df, bin == click_data$x_bin)
# Select what values to view in the table
df_results <- df_results %>% select(model, hp)
# And push these back out to the UI
output$table <- renderDataTable(df_results,
options = list(
pageLength = 5
)
)
})
}
shinyApp(ui = ui, server = server)
Well, someone answered. Since I took the time to put it together, here is another potential solution.
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
library(DescTools) # added for Closest()
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
plotOutput("hist", click = 'plot_click'), # added plot_click
verbatimTextOutput("x_value"), # added queues for interactivity
verbatimTextOutput("selected_rows") # added table for bin values
)
)
)
# this can be a dataframe or matrix for qplot or ggplot
# (not sure if there was another reason you had this code?)
# mtcars <- mtcars %>%
# select("hp") # if you only want hp
# mtcars <- as.matrix(mtcars) # I suggest making row names a column
# to keep 2 columns
pp <- ggplot(mtcars) +
geom_histogram(aes(x = hp),
bins = 10,
fill = "red",
color = "black",
alpha = .4) +
labs(x = "values",
y = "Frequency",
title = "Histogram")
# extract data from plot to find where each value falls within the histogram bins
# I kept the pkg name, function in more than one library
bd <- ggplot_build(ggplot2::last_plot())$data[[1]]
# add the assigned bin number to the mtcars frame; used for filtering matches
mtcars$bins <- lapply(mtcars$hp,
function(y) {
which(bd$x == Closest(bd$x, y))
}) %>% unlist()
server <- function(input, output) {
output$hist <- renderPlot({
# moved the plot outside of server, so that global variables could be created
# pp <- qplot(mtcars[,"hp"], geom = "histogram", bins = 10, xlab="values",
# ylab = "Frequency", main = "Histogram",
# fill = I("red"), col = I("black"), alpha = I(0.4))
# scale_x_continuous(breaks=pretty(mtcars, n=10)) # can't use this
pp
})
# # Print the name of the x value # added all that's below with server()
output$x_value <- renderPrint({
if (is.null(input$plot_click$x)) return()
# find the closest bin center to show where the user clicked on the histogram
cBin <- which(bd$x == Closest(bd$x, input$plot_click$x))
paste0("You selected bin ", cBin) # print out selected value based on bin center
})
# Print the rows of the data frame which match the x value
output$selected_rows <- renderPrint({
if (is.null(input$plot_click$x)) return()
# find the closest bin center to show where the user clicked on the histogram
cBin <- which(bd$x == Closest(bd$x, input$plot_click$x))
mtcars %>% filter(bins == cBin)
# mtcars
})
}
shinyApp(ui = ui, server = server)
Just in case someone ends in this post looking a way to include brushedPoints... inspired on this post, I found a way to do it!
Code:
#Load libraries ----------------------------------------------------
library(shiny)
library(ggplot2)
library(scales)
library(dplyr)
# Prepare data -----------------------------------------------------
df <- mtcars
df <- cbind(model = rownames(df), data.frame(df, row.names = NULL)) # setting the rownames as the first column
breaks_data = pretty(mtcars$hp, n=10)
my_breaks = seq(min(breaks_data), to=max(breaks_data), by=30)
# UI function ------------------------------------------------------
ui <- fluidPage(
titlePanel("Histogram"),
sidebarLayout(
sidebarPanel(
actionButton("draw_plot", "Draw the plot")
),
mainPanel(
plotOutput("hist",
brush = brushOpts("plot_brush", resetOnNew = T, direction = "x")),
dataTableOutput("table"),
)
)
)
# Server function --------------------------------------------------
server <- function(input, output) {
observeEvent(input$plot_brush, {
info_plot <- brushedPoints(df, input$plot_brush)
output$table <- renderDataTable(info_plot)
})
# If the user didn't choose to see the plot, it won't appear.
output$hist <- renderPlot({
df %>% ggplot(aes(hp)) +
geom_histogram(alpha=I(0.4), col = I("black"), fill = I("red"), bins=10) +
labs(x = "values",
y = "Frequency",
title = "Histogram") +
scale_x_continuous(breaks = my_breaks)
})
}
shinyApp(ui = ui, server = server)
How to do a scatterplot with hover
library(shiny)
library(tidyverse)
ui <- fluidPage(
titlePanel("hover tooltips demo"),
mainPanel(
plotOutput("plot1", hover = hoverOpts(id = "plot_hover", delay = 100, delayType = "debounce")),
uiOutput("hover_info") # , style = "pointer-events: none")
)
)
server <- function(input, output) {
output$plot1 <- renderPlot({
mtcars %>%
ggplot(aes(mpg, hp)) +
geom_point()
})
output$hover_info <- renderUI({
hover <- input$plot_hover
point <- shiny::nearPoints(mtcars,
coordinfo = hover,
xvar = 'mpg',
yvar = 'hp',
threshold = 20,
maxpoints = 1,
addDist = TRUE)
if (nrow(point) == 0) return(NULL)
style <- paste0("position:absolute; z-index:100; background-color: #3c8dbc; color: #ffffff;",
"font-weight: normal; font-size: 11pt;",
"left:", hover$coords_css$x + 5, "px;",
"top:", hover$coords_css$y + 5, "px;")
wellPanel(
style = style,
p(HTML(paste0("Some info about car: <br/>MPG ", point$mpg, "<br/>HP ", point$hp)))
)
})
}
shinyApp(ui = ui, server = server)

checkboxInput in R shiny

I have a question about the checkboxInput in R shiny. When it is checked, the scatter plot should be colorful while when it is unchecked, the plot should be black. I have tried several methods, but it keeps colorful no matter whether it is checked or not. Could you please help me with fix the code? Thanks so much.
library(shiny)
library(dplyr)
library(ggplot2)
# Start a 'Shiny' part
shinyServer(function(input, output, session) {
# Create a new reactive variable
newVar <- reactive({
newData <- msleep %>% filter(vore == input$vore)
})
# Create a scatter plot
output$sleepPlot <- renderPlot({
newDat <- newVar()
g <- ggplot(newDat, aes(x = bodywt, y = sleep_total))
g + geom_point(size = input$size, aes(col = conservation))
})
# Create text info
output$info <- renderText({
newDat <- newVar()
paste("The average body weight for order", input$vore, "is", round(mean(newDat$bodywt, na.rm = TRUE), 2),
"and the average total sleep time is", round(mean(newDat$sleep_total, na.rm = TRUE), 2), sep = " ")
})
# Create output of observations
output$table <- renderTable({
newDat <- newVar()
newDat
})
})
library(ggplot2)
shinyUI(fluidPage(
# Application title
titlePanel("Investigation of Mammal Sleep Data"),
# Sidebar with options for the data set
sidebarLayout(
sidebarPanel(
h3("Select the mammal's biological order:"),
selectizeInput("vore", "Vore", selected = "omni",
choices = levels(as.factor(msleep$vore))),
br(),
sliderInput("size", "Size of Points on Graph",
min = 1, max = 10, value = 5, step = 1),
checkboxInput("conservation", h4("Color Code Conservation Status", style = "color:red;"))
),
# Show output
mainPanel(
plotOutput("sleepPlot"),
textOutput("info"),
tableOutput("table")
)
)
))
Try this
# Create a scatter plot
output$sleepPlot <- renderPlot({
newDat <- newVar()
colorme <- unique(newVar()$conservation)
ncolor <- length(colorme)
if (!input$conservation) {
mycolor <- c(rep("black",ncolor))
mylabels <- c(rep(" ",ncolor))
}
g <- ggplot(newDat, aes(x = bodywt, y = sleep_total)) +
geom_point(size = input$size, aes(col = conservation)) +
{if (!input$conservation) scale_color_manual(name=" ", values=mycolor, labels=mylabels)} +
{ if (!input$conservation) guides(color='none')}
g
})
You can adjust, as necessary.

R/Shiny: Change plot ONLY after action button has been clicked

I am setting up a small shiny app where I do not want the plot to change unless the action button is clicked. In the example below, when I first run the app, there is no plot until I click the action button. However, if I then change my menu option in the drop-down from Histogram to Scatter, the scatter plot is automatically displayed even though the value for input$show_plot has not changed because the action button has not been clicked.
Is there a way that I can change my menu selection from Histogram to Scatter, but NOT have the plot change until I click the action button? I've read through several different posts and articles and can't seem to get this worked out.
Thanks for any input!
ui.R
library(shiny)
fluidPage(
tabsetPanel(
tabPanel("Main",
headerPanel(""),
sidebarPanel(
selectInput('plot_type', 'Select plot type', c('Histogram','Scatter'), width = "250px"),
actionButton('show_plot',"Plot", width = "125px"),
width = 2
),
mainPanel(
conditionalPanel(
"input.plot_type == 'Histogram'",
plotOutput('plot_histogram')
),
conditionalPanel(
"input.plot_type == 'Scatter'",
plotOutput('plot_scatter')
)
))
)
)
server.R
library(shiny)
library(ggplot2)
set.seed(10)
function(input, output, session) {
### GENERATE SOME DATA ###
source_data <- reactive({
mydata1 = as.data.frame(rnorm(n = 100))
mydata2 = as.data.frame(rnorm(n = 100))
mydata = cbind(mydata1, mydata2)
colnames(mydata) <- c("value1","value2")
return(mydata)
})
# get a subset of the data for the histogram
hist_data <- reactive({
data_sub = as.data.frame(source_data()[sample(1:nrow(source_data()), 75), "value1"])
colnames(data_sub) <- "value1"
return(data_sub)
})
# get a subset of the data for the scatter plot
scatter_data <- reactive({
data_sub = as.data.frame(source_data()[sample(1:nrow(source_data()), 75),])
return(data_sub)
})
### MAKE SOME PLOTS ###
observeEvent(input$show_plot,{
output$plot_histogram <- renderPlot({
isolate({
plot_data = hist_data()
print(head(plot_data))
p = ggplot(plot_data, aes(x = value1, y = ..count..)) + geom_histogram()
return(p)
})
})
})
observeEvent(input$show_plot,{
output$plot_scatter <- renderPlot({
isolate({
plot_data = scatter_data()
print(head(plot_data))
p = ggplot(plot_data, aes(x = value1, y = value2)) + geom_point()
return(p)
})
})
})
}
Based on your desired behavior I don't see a need for actionButton() at all. If you want to change plots based on user input then the combo of selectinput() and conditionPanel() already does that for you.
On another note, it is not good practice to have output bindings inside any reactives. Here's an improved version of your server code. I think you are good enough to see notice the changes but comment if you have any questions. -
function(input, output, session) {
### GENERATE SOME DATA ###
source_data <- data.frame(value1 = rnorm(n = 100), value2 = rnorm(n = 100))
# get a subset of the data for the histogram
hist_data <- reactive({
# reactive is not needed if no user input is used for creating this data
source_data[sample(1:nrow(source_data), 75), "value1", drop = F]
})
# get a subset of the data for the histogram
scatter_data <- reactive({
# reactive is not needed if no user input is used for creating this data
source_data[sample(1:nrow(source_data), 75), , drop = F]
})
### MAKE SOME PLOTS ###
output$plot_histogram <- renderPlot({
req(hist_data())
print(head(hist_data()))
p = ggplot(hist_data(), aes(x = value1, y = ..count..)) + geom_histogram()
return(p)
})
output$plot_scatter <- renderPlot({
req(scatter_data())
print(head(scatter_data()))
p = ggplot(scatter_data(), aes(x = value1, y = value2)) + geom_point()
return(p)
})
}

Resources