I'm working on a Shiny app for a project where a ggplot is the main interface for the user. Depending on input from the sidebar, I'd like the app to record coordinates for two events: a single click (which I have working), or a double click (which is where I'm stuck). Essentially, I'd like to be able to create a way to record a starting and ending point based on sidebar conditions. Here's a brief example:
library(shiny)
library(ggplot2)
ui = pageWithSidebar(
headerPanel("Example"),
sidebarPanel(
radioButtons("color", "Pick Color", c("Pink", "Green", "Blue")),
selectInput("shape", "Select Shape:", c("Circle", "Triangle"))
),
mainPanel(
fluidRow(column(width = 6,
h4("Click plot to add points"),
plotOutput("plot1", click = "plot_click"),
actionButton("rem_point", "Remove Last Point")),
column(width = 6,
h4("Table of points on plot"),
tableOutput("table")))
)
)
server = function(input, output){
values = reactiveValues()
values$DT = data.frame(x = numeric(),
y = numeric(),
color = factor(),
shape = factor())
output$plot1 = renderPlot({
ggplot(values$DT, aes(x = x, y = y)) +
geom_point(aes(color = color,
shape = shape), size = 5) +
lims(x = c(0, 100), y = c(0, 100)) +
theme(legend.position = "bottom") +
scale_color_discrete(drop = FALSE) +
scale_shape_discrete(drop = FALSE)
})
observeEvent(input$plot_click, {
add_row = data.frame(x = input$plot_click$x,
y = input$plot_click$y,
color = factor(input$color, levels = c("Pink", "Green", "Blue")),
shape = factor(input$shape, levels = c("Circle", "Triangle")))
values$DT = rbind(values$DT, add_row)
})
observeEvent(input$rem_point, {
rem_row = values$DT[-nrow(values$DT), ]
values$DT = rem_row
})
output$table = renderTable({
values$DT[, c('color', 'shape')]
})
}
shinyApp(ui, server)
In this example, when the user selects Green or Blue, I'd like to only record the single click as the starting point and record NA for the end point. When they select Pink, I'd like to record the single click as the starting point and the double click as the ending point. Any help would be greatly appreciated!
(Example created by #blondeclover on a question from earlier.)
Found a solution! Just create an observeEvent() to observe a double click and update values$DT with the new information.
Related
I would like click-select points and group them based on color.
I can save selected points with color information into a new data frame and plot it, however I would like to keep track and see what was already selected on the interactive plot.
How can I show/label already selected points or make it permanent after "Add selection"?
library(shiny)
library(tidyverse)
library(DT)
library(colourpicker)
ui = fluidPage(
colourInput("col", "Select colour", "purple"),
actionButton("addToDT", "Add selection", icon = icon("plus")), hr(),
plotOutput("plot", click = "plot_click", dblclick = "plot_reset"),
DT::dataTableOutput('plot_DT'), hr(),
textOutput("clickcoord"),
DT::dataTableOutput('final_DT'),
plotOutput("plotSelected")
)
server = function(input, output, session) {
selectedPoint = reactiveVal(rep(FALSE, nrow(mtcars)))
output$clickcoord <- renderPrint({
print(input$plot_click)
})
observeEvent(input$plot_click, {
clicked = nearPoints(mtcars, input$plot_click, allRows = TRUE)$selected_
selectedPoint(clicked | selectedPoint())
})
observeEvent(input$plot_reset, {
selectedPoint(rep(FALSE, nrow(mtcars)))
})
output$plot_DT = DT::renderDataTable({
mtcars$sel = selectedPoint()
mtcars = dplyr::filter(mtcars, sel == TRUE) %>% mutate(group_color = input$col)
})
final_DT = reactiveValues()
final_DT$df = data.frame()
FinalData = eventReactive(input$addToDT, {
mtcars$sel = selectedPoint()
mtcars = dplyr::filter(mtcars, sel == TRUE) %>% mutate(group_color = input$col)
final_DT$df = bind_rows(final_DT$df, mtcars)
})
output$final_DT = renderDataTable({FinalData()})
output$plot = renderPlot({
mtcars$sel = selectedPoint()
ggplot(mtcars, aes(wt, mpg, color = mtcars$sel, fill=mpg)) +
geom_point(shape = 21, size = 6, stroke = 2) +
scale_color_manual(values = c("#ffffff00", input$col)) +
scale_fill_viridis_c() +
theme_bw()
})
output$plotSelected = renderPlot({
sel_df = FinalData()
ggplot(sel_df, aes(wt, mpg, fill = group_color, colour = group_color)) +
geom_point(shape = 21, size = 6, stroke = 2) +
scale_color_manual(values = unique(sel_df$group_color)) +
scale_fill_manual(values = unique(sel_df$group_color)) +
theme_bw()
})
observeEvent(input$addToDT, {
selectedPoint(rep(FALSE, nrow(mtcars)))
})
}
shinyApp(ui, server)
I think this is the "crux" of what your are looking for. I used a very similar example that I found in the help for entitled:
A demonstration of clicking, hovering, and brushing
(https://shiny.rstudio.com/reference/shiny/0.13.1/plotoutput)
It is very similar to your example.
I create a matrix of T/F elements where the rows are the observations and the columns are in which batch the observation is selected. So when you launch the whole matrix is False, but as you click on observations the switch to positive in the first column. Then if you click addSelection and continue you start switching the observations in the next column.
Could you confirm that this what you are looking for?
Below is the code.
shinyApp(
ui = basicPage(
fluidRow(
column(
width = 4,
plotOutput("plot",
height = 300,
click = "plot_click", # Equiv, to click=clickOpts(id='plot_click')
),
actionButton("addToDT", "Add selection", icon = icon("plus")), hr(),
h4("Clicked points"),
tableOutput("plot_clickedpoints"),
),
column(
width = 4,
verbatimTextOutput("counter"),
),
)
),
server = function(input, output, session) {
data <- reactive({
input$newplot
# Add a little noise to the cars data so the points move
cars + rnorm(nrow(cars))
})
output$plot <- renderPlot({
d <- data()
plot(d$speed, d$dist, main = paste("No of Sets Chosen", input$addToDT))
})
output$plot_clickinfo <- renderPrint({
cat("Click:
")
str(input$plot_click)
})
selectedPoints <- reactiveVal(rep(FALSE, nrow(cars)))
selectionMatrix <- reactiveVal(matrix(data = F, nrow = nrow(cars), ncol = 7))
observeEvent(input$plot_click, {
clicked <- nearPoints(data(), input$plot_click, "speed", "dist", allRows = TRUE)$selected
selectedPoints(clicked | selectedPoints())
tmp <- unlist(selectionMatrix())
tmp[, (input$addToDT + 1)] <- selectedPoints()
selectionMatrix(tmp)
})
observeEvent(input$addToDT, {
selectedPoints(rep(FALSE, nrow(cars)))
})
output$plot_clickedpoints <- renderTable({
# if (input$addToDT==0) {
res <- selectionMatrix()
return(res)
})
}
)
I'm creating an Rshiny with two tabs. The data is a list of students, and the plots/tables are to be filtered through the input of grade selection on a drop-down list. The table I have on tab one is working fine, but everything I have tried to do to connect the last two plots on the second tab to the input are not working. Now I have it to where it is just showing totals without using the input filter of grade. Can anyone detail how to connect my input to both output plots? I'll put my code below
library(shiny)
library(tidyverse)
students = read.csv("C:/Users/j062d273/Downloads/RShiny Grade EX.csv",
stringsAsFactors = FALSE)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
headerPanel("Student Data"),
# tabs set up
tabsetPanel(
tabPanel(title = "Students by Grade",
mainPanel(width = 12, align = "center",
selectInput("grade", "Select Grade", choices=unique(sort(students$Grade,
decreasing = FALSE)), selected = 1),
submitButton("Go"),
tags$h3("Student List"),
div(style = "border:1px black solid;width:80%",tableOutput("student_list"))
)),
tabPanel(title = "Trends by Grade",
mainPanel(width = 12,align = "center",
div(style = "float:left;width:36%;",plotOutput("male_fem_dist")),
div(style = "float:right;width:64%;",plotOutput("ethnicity_plot")))
)))
# Define server logic required to draw plot
server <- function(input, output) {
output$student_list <- renderTable({
gradefilter <- subset(students, students$Grade == input$grade)
})
output$male_fem_dist <- renderPlot({
ggplot(students, aes(x=Gender)) +
geom_bar(fill = "blue", color = "red") +
ggtitle("Gender Count by Selected Grade")
})
output$ethnicity_plot <- renderPlot({
ggplot(students, aes(x=Ethnicity)) +
geom_bar(fill = "red", color = "blue") +
ggtitle("Ethnicity Count by Selected Grade")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Filter the dataset first, and then use it in both table and plot.
Try this
server <- function(input, output) {
gradefilter <- reactive({subset(students, students$Grade == input$grade)})
output$student_list <- renderTable({gradefilter()})
output$male_fem_dist <- renderPlot({
ggplot(gradefilter(), aes(x=Gender)) +
geom_bar(fill = "blue", color = "red") +
ggtitle("Gender Count by Selected Grade")
})
output$ethnicity_plot <- renderPlot({
ggplot(gradefilter(), aes(x=Ethnicity)) +
geom_bar(fill = "red", color = "blue") +
ggtitle("Ethnicity Count by Selected Grade")
})
}
I'm trying to create an app that allows 1) a user to hover over scatter plot points, which displays a label associated with the point, and 2) search for a specific point by label.
Currently, to highlight a point, I re-plot the graph each time the user submits a search term, adding that single point on top of rest of the points that have been plotted.
In order to avoid the server re-plotting before the user finishes typing the label, I require that the "search" button be pressed. However, I'm struggling to get the plot to display BEFORE the user has searched for any labels.
Here's what I have so far:
library(shiny)
library(ggplot2)
library(ggiraph)
df <- data.frame(x = rnorm(100), y = rnorm(100), label = paste("gene", seq(100)))
head(df)
x y label
1 -0.3383215 0.91212341 gene 1
2 -0.5318215 -0.63273778 gene 2
3 1.1281345 -0.01296204 gene 3
4 -1.2964345 -2.21689946 gene 4
5 1.5877938 -0.24993362 gene 5
6 0.6385419 0.07849135 gene 6
gg_scatter <- ggplot(data = df, aes(x, y)) +
geom_point_interactive(aes(tooltip = label, data_id = label))
ui <- fluidPage(
textInput(inputId = "gene_symbol",
label = "Search for a gene",
placeholder = "gene 1"),
actionButton(inputId = "go",
label = "Search"),
girafeOutput("scatterplot"),
textOutput("message")
)
server <- function(input, output) {
gene_search <- eventReactive(input$go, {
input$gene_symbol
})
output$scatterplot <-
renderGirafe({
gg_scatter_highlight <- gg_scatter +
geom_point_interactive(data = subset(df, label == gene_search()),
tooltip = gene_search(),
size = 3,
color = "red")
girafe(code = print(gg_scatter_highlight),
options = list(opts_selection(type = "single")))
})
output$message <- renderText({
if(sum(is.element(df$label, req(gene_search()))) == 0) {
paste("Gene not found")
}
})
}
shinyApp(ui = ui, server = server)
I'm trying to add something like this to output$scatterplot:
output$scatterplot <-
renderGirafe({
## If the user has not searched for anything, plot without any points highlighted
if(!isTruthy(gene_search)) {
girafe(code = print(gg_scatter),
options = list(opts_selection(type = "single")))
}
## Highlight the point that the user searched for
else {
gg_scatter_highlight <- gg_scatter +
geom_point_interactive(data = subset(df, label == gene_search()),
tooltip = gene_search(),
size = 3,
color = "red")
girafe(code = print(gg_scatter_highlight),
options = list(opts_selection(type = "single")))
}
})
... Unfortunately this still results in no plot being displayed until a label is searched.
Any help would be much appreciated.
Set ignoreNULL = FALSE in eventReactive to have a default value at the beginning.
library(shiny)
library(ggplot2)
library(ggiraph)
gg_scatter <- ggplot(data = df, aes(x, y)) +
geom_point_interactive(aes(tooltip = label, data_id = label))
ui <- fluidPage(
textInput(inputId = "gene_symbol",
label = "Search for a gene",
placeholder = "gene 1"),
actionButton(inputId = "go",
label = "Search"),
girafeOutput("scatterplot"),
textOutput("message")
)
server <- function(input, output) {
gene_search <- eventReactive(input$go, {
input$gene_symbol
}, ignoreNULL = FALSE)
output$scatterplot <-
renderGirafe({
gg_scatter_highlight <- gg_scatter +
geom_point_interactive(data = subset(df, label == gene_search()),
tooltip = gene_search(),
size = 3,
color = "red")
girafe(code = print(gg_scatter_highlight),
options = list(opts_selection(type = "single")))
})
output$message <- renderText({
if(sum(is.element(df$label, req(gene_search()))) == 0) {
paste("Gene not found")
}
})
}
shinyApp(ui = ui, server = server)
Hello I have created a shiny app which creates a scatter plot between selected variables. Then when I click on a data point the name of the point is printed in the plot. The problem is that when I update the plot with other variables the printed are not erased. My thought is to use this kind of logic:R shiny, shinyjs, remove plot and draw it again if button is clicked but Im not sure if I got it right as I want just the data labels to get disappeared and not the whole plot
#ui.r
library(shiny)
library(ggplot2)
library(plotly)
library(dplyr)
fluidPage(
useShinyjs(),
# App title ----
titlePanel(div("CROSS CORRELATION",style = "color:blue")),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
),
# Main panel for displaying outputs ----
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Correlation Plot",
fluidRow(
column(3, uiOutput("lx1")),
column(3,uiOutput("lx2")),
actionButton("hideshow", "Hide/show plot")),
hr(),
fluidRow(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"
)
),
fluidRow(
plotlyOutput("sc"))
)
)
)))
#server.r
function(input, output,session) {
output$lx1<-renderUI({
selectInput("lx1", label = h4("Select 1st Expression Profile"),
choices = colnames(iris[,1:4]),
selected = "Lex1")
})
output$lx2<-renderUI({
selectInput("lx2", label = h4("Select 2nd Expression Profile"),
choices = colnames(iris[,1:4]),
selected = "Lex2")
})
# 1. create reactive values
vals <- reactiveValues()
# 2. create df to store clicks
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
# 3. add points upon plot click
observe({
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = click_data[["key"]],
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
})
output$sc<-renderPlotly({
p1 <- ggplot(iris, aes_string(x = input$lx1, y = input$lx2,key = "Species"))+
# Change the point options in geom_point
geom_point(color = "darkblue") +
# Change the title of the plot (can change axis titles
# in this option as well and add subtitle)
labs(title = "Cross Correlation") +
# Change where the tick marks are
# Change how the text looks for each element
theme_bw()+
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_x = 0.25)
ggplotly(p1,source = "select", tooltip = c("key")) %>%
layout(hoverlabel = list(bgcolor = "white",
font = list(family = "Calibri",
size = 9,
color = "black")))
})
observeEvent(input$hideshow, {
# every time the button is pressed, alternate between hiding and showing the plot
toggle("sc")
})
}
I have a shiny app which creates a scatter plot between selected variables of the mtcars dataset. As you can see I have modified the data labels in order to display the car type in every point instead of the x-y coordinates. The problem is that when I click on my trendline, on spots where there are no data -so the coordinates are displayed-the app is breaking down. Here is a reproducible example:
#ui.r
library(shiny)
library(ggplot2)
library(plotly)
library(dplyr)
fluidPage(
# App title ----
titlePanel(div("CROSS CORRELATION",style = "color:blue")),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
),
# Main panel for displaying outputs ----
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Correlation Plot",
fluidRow(
column(3, uiOutput("lx1")),
column(3,uiOutput("lx2"))),
hr(),
fluidRow(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"
)
),
fluidRow(
plotlyOutput("sc"))
)
)
)))
#server.r
function(input, output) {
output$lx1<-renderUI({
selectInput("lx1", label = h4("Select 1st Expression Profile"),
choices = colnames(mtcars[,2:5]),
selected = "Lex1")
})
output$lx2<-renderUI({
selectInput("lx2", label = h4("Select 2nd Expression Profile"),
choices = colnames(mtcars[,2:5]),
selected = "Lex2")
})
# 1. create reactive values
vals <- reactiveValues()
# 2. create df to store clicks
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
# 3. add points upon plot click
observe({
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = click_data[["key"]],
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
})
output$sc<-renderPlotly({
mtcars$car <- row.names(mtcars)
p1 <- ggplot(mtcars, aes_string(x = input$lx1, y = input$lx2,key = "car",group="car"))+
# Change the point options in geom_point
geom_point(color = "darkblue") +
# Change the title of the plot (can change axis titles
# in this option as well and add subtitle)
labs(title = "Cross Correlation") +
# Change where the tick marks are
# Change how the text looks for each element
theme_bw()+
geom_smooth(aes(group = 1))+
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_x = 0.25)
ggplotly(p1,source = "select", tooltip = c("key")) %>%
layout(hoverlabel = list(bgcolor = "white",
font = list(family = "Calibri",
size = 9,
color = "black")))
})
}
As you said, the app breaks down after clicking on the trend line where there is no point that corresponds to a car. Let us stick to that scenario. You get following error:
Warning: Error in data.frame: arguments imply differing number of rows: 1, 0
The reason for this error is that after clicking on the trend line the data frame stored in click_data variable does not contain variable key.
You try to access this variable anyway via click_data[["key"]] and the output of it is NULL as it is not existent.
In the next step you want to build a new data.frame label_data, where label is assigned to NULL and hence the error.
label_data <- data.frame(x = click_data[["x"]], # it is fine because it is number
y = click_data[["y"]], # also fine
label = NULL, # label gets NULL
stringsAsFactors = FALSE)
We can simply reproduce this error with
> data.frame(x = 1, y = 1, label = NULL)
Error in data.frame(x = 1, y = 1, label = NULL) :
arguments imply differing number of rows: 1, 0
Now that we know why we get the error, we can find multiple solutions to it. One of them would be to require first that
click_data <- event_data("plotly_click", source = "select")
returns a data frame and then if it does not contain key variable, we set the value of label to "" with
label_ <- ifelse(is.null(click_data[["key"]]),
yes = "",
no = click_data[["key"]])
That is
observe({
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# Require that click_data is available (does not return NULL)
req(click_data)
label_ <- ifelse(is.null(click_data[["key"]]),
yes = "",
no = click_data[["key"]])
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = label_,
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
})
Full code:
library(shiny)
library(ggplot2)
library(plotly)
library(dplyr)
ui <- fluidPage(
# App title ----
titlePanel(div("CROSS CORRELATION",style = "color:blue")),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
),
# Main panel for displaying outputs ----
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Correlation Plot",
fluidRow(
column(3, uiOutput("lx1")),
column(3,uiOutput("lx2"))),
hr(),
fluidRow(
tags$style(type="text/css",
".shiny-output-error { visibility: hidden; }",
".shiny-output-error:before { visibility: hidden; }"
)
),
fluidRow(
plotlyOutput("sc"))
)
)
)))
#server.r
server <- function(input, output) {
output$lx1<-renderUI({
selectInput("lx1", label = h4("Select 1st Expression Profile"),
choices = colnames(mtcars[,2:5]),
selected = "Lex1")
})
output$lx2<-renderUI({
selectInput("lx2", label = h4("Select 2nd Expression Profile"),
choices = colnames(mtcars[,2:5]),
selected = "Lex2")
})
# 1. create reactive values
vals <- reactiveValues()
# 2. create df to store clicks
vals$click_all <- data.frame(x = numeric(),
y = numeric(),
label = character())
# 3. add points upon plot click
observe({
# get clicked point
click_data <- event_data("plotly_click", source = "select")
# Require that click_data is available (does not return NULL)
req(click_data)
label_ <- ifelse(is.null(click_data[["key"]]),
yes = "",
no = click_data[["key"]])
# get data for current point
label_data <- data.frame(x = click_data[["x"]],
y = click_data[["y"]],
label = label_,
stringsAsFactors = FALSE)
# add current point to df of all clicks
vals$click_all <- merge(vals$click_all,
label_data,
all = TRUE)
})
output$sc<-renderPlotly({
mtcars$car <- row.names(mtcars)
p1 <- ggplot(mtcars, aes_string(x = input$lx1, y = input$lx2,key = "car",group="car"))+
# Change the point options in geom_point
geom_point(color = "darkblue") +
# Change the title of the plot (can change axis titles
# in this option as well and add subtitle)
labs(title = "Cross Correlation") +
# Change where the tick marks are
# Change how the text looks for each element
theme_bw()+
geom_smooth(aes(group = 1))+
# 4. add labels for clicked points
geom_text(data = vals$click_all,
aes(x = x, y = y, label = label),
inherit.aes = FALSE, nudge_x = 0.25)
ggplotly(p1,source = "select", tooltip = c("key")) %>%
layout(hoverlabel = list(bgcolor = "white",
font = list(family = "Calibri",
size = 9,
color = "black")))
})
}
shinyApp(ui, server)