Exclude data points by click in plotly in a shiny app r - r

I want to exclude certain data points that are selected by the user by clicking, like in this example (but using plotly).
I tried to do it with the code i show below but it doesnt work.
What i'm triying to do is identify the position of the data point and then once i get the position, set the var delete as TRUE if the row_number() is in the set of selected data points and then just filter is delete is TRUE.
I dont know if this is the most effient form to perfom that.
I would appreciate any help or guidance.
library(shiny)
library(plotly)
library(dplyr)
n <- 20
x <- 1:n
y <- cumsum(rnorm(n))
z <- runif(n,10,200)
cat <- sample(letters[1:5],n,replace = TRUE)
delete <- FALSE
df<-data.frame(cat,x,y,z, delete)
ui <- fluidPage(
selectInput("var","var", c("y","z"), "y"),
mainPanel(plotlyOutput("plot")),
verbatimTextOutput("selection"),
actionButton("delete","Delete", style = "display:inline-block;"),
actionButton("reset","Reset", style = "display:inline-block;"),
)
server <- function(input, output, session) {
myData <- reactive({df})
output$plot <- renderPlotly({
plot_ly(myData(),
x = ~x,
y = ~get(input$var),
type = "scatter",
mode = "markers",
text = ~cat,
marker = list(size = 10),
source = "A")
})
p1 <- reactive({
event_data("plotly_click", source = "A")
})
p2 <- reactiveValues(points = c())
observeEvent(p1(),{
p2$points <- c(p2$points,as.list(p1())$pointNumber)
})
observeEvent(input$reset,{
p2$points <- c()
})
output$selection <- renderPrint({ if(length(p2$points+1)<1){"Select data points to delete"}else{(p2$points+1)} })
observeEvent(input$delete,{
myData() <- myData() %>%
mutate(delete = ifelse(row_number() %in% c(p2$puntos+1),TRUE,delete)) %>%
filter(!delete)
})
}
shinyApp(ui, server)

Nice trick with event_data there! I think all that's needing done differently is to make myData$df a named reactiveValue (with one small correction to p2$points lower down). This works for me now:
library(shiny)
library(plotly)
library(dplyr)
n <- 20
x <- 1:n
y <- cumsum(rnorm(n))
z <- runif(n,10,200)
cat <- sample(letters[1:5],n,replace = TRUE)
delete <- FALSE
df<-data.frame(cat,x,y,z, delete)
ui <- fluidPage(
selectInput("var","var", c("y","z"), "y"),
mainPanel(plotlyOutput("plot")),
verbatimTextOutput("selection"),
actionButton("delete","Delete", style = "display:inline-block;"),
actionButton("reset","Reset", style = "display:inline-block;"),
)
server <- function(input, output, session) {
myData <- reactiveValues(df = df)
output$plot <- renderPlotly({
plot_ly(myData$df,
x = ~x,
y = ~get(input$var),
type = "scatter",
mode = "markers",
text = ~cat,
marker = list(size = 10),
source = "A")
})
p1 <- reactive({
event_data("plotly_click", source = "A")
})
p2 <- reactiveValues(points = c())
observeEvent(p1(),{
p2$points <- c(p2$points,as.list(p1())$pointNumber)
})
observeEvent(input$reset,{
p2$points <- c()
})
output$selection <- renderPrint({ if(length(p2$points+1)<1){"Select data points to delete"}else{(p2$points+1)} })
observeEvent(input$delete,{
# browser()
myData$df <- myData$df %>%
mutate(delete = ifelse(row_number() %in% c(p2$points+1),TRUE,delete)) %>%
filter(!delete)
# And clear input?
p2$points <- c()
})
}
shinyApp(ui, server)

Related

Display the count of clicks in a plot using shiny

I want to build a shiny app that counts the number of clicks I make on any image, but I don't know how to make the counter increase, it just plots the number 1
I tried to create loops inside renderPlot but it doesn't work.
It is necessary to change the path of the files to a directory that contains .jpg images
library(shiny)
ui <- fluidPage(
titlePanel("Click Count"),
sidebarPanel(selectInput("IMAGE", "Sample image:",
list.files(path = "~",
pattern = ".jpg",
full.names = TRUE,
include.dirs = FALSE))),
fluidRow(
plotOutput("IMG", click = "countClick", "100%", "500px")
),
verbatimTextOutput("info")
)
server <- function(input, output, session){
# Creating a reactive variable that recognizes the selected image
img <- reactive({
f <- input$IMAGE
imager::load.image(f)
})
# Creating a spot where i can store reactive values
initX <- 1
initY <- 2
source_coords <- reactiveValues(xy = c(x=initX,y=initY))
# Coords
dest_coords <- reactiveValues(x=initX, y = initY)
observeEvent(plot_click(),{
dest_coords$x <- c(dest_coords$x, floor(plot_click()$x))
dest_coords$y <- c(dest_coords$y, floor(plot_click()$y))
})
plot_click <- debounce(reactive(input$countClick), 300)
output$IMG <- renderPlot({
plot(img(), axes = FALSE)
n <- 0
ex <- expression(n+1)
text(dest_coords$x, dest_coords$y,eval(ex),cex = 1 ,col = 'red')
})
output$info <- renderPrint({
req(input$countClick)
x <- round(input$countClick$x,2)
y <- round(input$countClick$y,2)
cat("[", x, ", ", y, "]", sep = "")
})
}
shinyApp(ui, server)
countClick is not a good name because input$countClick does not contain the numbers of clicks.
Not tested:
numberOfClicks <- reactiveVal(0)
dest_coords <- reactiveValues(x = initX, y = initY)
observeEvent(plot_click(),{
numberOfClicks(numberOfClicks() + 1)
dest_coords$x <- c(dest_coords$x, floor(plot_click()$x))
dest_coords$y <- c(dest_coords$y, floor(plot_click()$y))
})
plot_click <- debounce(reactive(input$countClick), 300)
output$IMG <- renderPlot({
plot(img(), axes = FALSE)
n <- numberOfClicks()
text(dest_coords$x, dest_coords$y, n, cex = 1 ,col = 'red')
})

How to create a draggable plot in R Shiny using a reactive dataframe?

In Code1 below I am trying to create a draggable plot using the plotly package. The user should be able to drag the points of the plot and capture the new points in the data frame rendered to the left called "Data1". When running the code I get the error "Warning: Error in <-: invalid (NULL) left side of assignment". What am I doing wrong?
As an FYI, Code2 below does just this but using a different data set, though both are structured the same. In running Code2, I compare the data frame that works in Code2 (called "Data") with the data frame that does not work in Code1 ("Data1") to show how similarly the two data frames are in structure. Drag the plotted data points in Code2 and see how nicely the "Data" table to the left updates. This is what I'm trying to get at in Code1, but instead by using Data1 data.
Solution spoiler: see ismirsehregal answer below. The difference between Code1 and Code2, where Code1 fails and Code2 doesn't, is due to the inappropriate use of reactive() in defining the data1() dataframe in Code1. Since data1() is modified from different places (sliderInput(), the drag feauture in plotly), reactiveVal() or reactiveValues() must be used and not reactive() in defining the dataframe. Also note the use of reactiveValuesToList() in rendering the modified dataframe after dragging a plot point.
Code1:
library(plotly)
library(purrr)
library(shiny)
ui <- fluidPage(
fluidRow(column(5,sliderInput('periods','Nbr of periods:',min=0,max=24,value=12))),
fluidRow(column(2,h5("Data1:"),tableOutput('data1')),
column(6, plotlyOutput("p")))
)
server <- function(input, output, session) {
data1 <- reactive({
data.frame(
x = c(1:input$periods),
y = c((0.15-0.70)*(exp(-50/100*(1:input$periods))-exp(-50/100*input$periods)*
(1:input$periods)/input$periods)) + 0.70
)
})
output$p <- renderPlotly({
circles <- map2(data1()$x, data1()$y,
~list(type = "circle",
xanchor = .x,
yanchor = .y,
x0 = -4, x1 = 4,
y0 = -4, y1 = 4,
xsizemode = "pixel",
ysizemode = "pixel",
fillcolor = "blue",
line = list(color = "transparent"))
)
plot_ly() %>%
add_lines(x = data1()$x, y = data1()$y, color = I("red")) %>%
layout(shapes = circles) %>%
config(edits = list(shapePosition = TRUE))
})
output$data1 <- renderTable(data1())
# update x/y reactive values in response to changes in shape anchors
observe({
ed <- event_data("plotly_relayout")
shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
if (length(shape_anchors) != 2) return()
row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
pts <- as.numeric(shape_anchors)
data1()$x[row_index] <- pts[1]
data1()$y[row_index] <- pts[2]
})
}
shinyApp(ui, server)
Code2:
library(plotly)
library(purrr)
library(shiny)
ui <- fluidPage(
fluidRow(column(5,sliderInput('periods','Nbr of periods:',min=0,max=24,value=12))),
fluidRow(
column(2,h5(strong(("Data:"))),tableOutput('data')),
column(2,h5(strong(("Data1:"))),tableOutput('data1')),
column(6,h5(strong(("Move the points and see how `Data` table to left updates:"))), plotlyOutput("p")),
),
fluidRow(h5(strong(("Data1 above shown for comparison purposes, would like to substitute Data with Data1 in the plot"))))
)
server <- function(input, output, session) {
rv <- reactiveValues( x = mtcars$mpg,y = mtcars$wt)
data <- reactive(data.frame(x=(rv$x_sub),y=(rv$y_sub)))
data1 <- reactive({
data.frame(
x = c(1:input$periods),
y = c((0.15-0.70) * (exp(-50/100*(1:input$periods))-
exp(-50/100*input$periods)*(1:input$periods)/input$periods)) + 0.70
)
})
observe({
rv$x_sub <- rv$x[1:input$periods]
rv$y_sub <- rv$y[1:input$periods]
})
output$p <- renderPlotly({
circles <- map2(rv$x_sub, rv$y_sub,
~list(
type = "circle",
xanchor = .x,
yanchor = .y,
x0 = -4, x1 = 4,
y0 = -4, y1 = 4,
xsizemode = "pixel",
ysizemode = "pixel",
fillcolor = "blue",
line = list(color = "transparent")
)
)
plot_ly() %>%
add_lines(x = rv$x_sub, y = rv$y_sub, color = I("red")) %>%
layout(shapes = circles) %>%
config(edits = list(shapePosition = TRUE))
})
output$data <- renderTable(data())
output$data1 <- renderTable(data1())
# update x/y reactive values in response to changes in shape anchors
observe({
ed <- event_data("plotly_relayout")
shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
if (length(shape_anchors) != 2) return()
row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
pts <- as.numeric(shape_anchors)
rv$x[row_index] <- pts[1]
rv$y[row_index] <- pts[2]
})
}
shinyApp(ui, server)
Unfortunately you can't modify a reactive in multiple places. For this use case reactiveVal or reactiveValues are intended.
Please check the following:
library(plotly)
library(purrr)
library(shiny)
ui <- fluidPage(
fluidRow(column(5,sliderInput('periods','Nbr of periods:',min=0,max=24,value=12))),
fluidRow(column(2,h5("Data1:"),tableOutput('data1table')),
column(6, plotlyOutput("p")))
)
server <- function(input, output, session) {
data1 <- reactiveValues(x = NULL, y = NULL)
observe({
data1$x <- c(1:input$periods)
data1$y <- c((0.15-0.70)*(exp(-50/100*(1:input$periods))-exp(-50/100*input$periods)*
(1:input$periods)/input$periods)) + 0.70
})
output$p <- renderPlotly({
circles <- map2(data1$x, data1$y,
~list(type = "circle",
xanchor = .x,
yanchor = .y,
x0 = -4, x1 = 4,
y0 = -4, y1 = 4,
xsizemode = "pixel",
ysizemode = "pixel",
fillcolor = "blue",
line = list(color = "transparent"))
)
plot_ly() %>%
add_lines(x = data1$x, y = data1$y, color = I("red")) %>%
layout(shapes = circles) %>%
config(edits = list(shapePosition = TRUE))
})
output$data1table <- renderTable({
as.data.frame(reactiveValuesToList(data1))
})
# update x/y reactive values in response to changes in shape anchors
observe({
ed <- event_data("plotly_relayout")
shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
if (length(shape_anchors) != 2) return()
row_index <- unique(readr::parse_number(names(shape_anchors)) + 1)
pts <- as.numeric(shape_anchors)
data1$x[row_index] <- pts[1]
data1$y[row_index] <- pts[2]
})
}
shinyApp(ui, server)

R Shiny Plotly generate graph for each item in list

Right now I'm using shiny and Plotly in R to make graphs to visualize data.
I have this list with items and for each item I want to generate a graph with the name of this item.
Is it possible to have your graph output name based on this list item?
In the simplest terms:
What I have:
output$plot <- renderPlotly({})
What I want:
listitems <- c("graph1", "graph2")
output$listitems[1] <- renderPlotly({})
This situation would be ideal, as I want to generate multiple graphs by using a function to minimalize code.
If I understand correctly, you don't want to assign every plot manually. Accordingly we can use a for-loop or lapply like this:
library(shiny)
library(plotly)
ui <- fluidPage(
uiOutput("myPlots")
)
server <- function(input, output, session) {
listItems <- paste0("graph", 1:10)
dfList <- replicate(10, data.frame(x = 1:10, y = runif(10)), simplify = FALSE)
names(dfList) <- listItems
lapply(seq_along(dfList), function(i){
output[[listItems[i]]] <- renderPlotly({plot_ly(dfList[[i]], x = ~x, y = ~y, type = "scatter", mode = "lines+markers") %>% layout(title = listItems[i])})
})
output$myPlots <- renderUI({
lapply(listItems, plotlyOutput)
})
}
shinyApp(ui, server)
Take a look at subplots. In your example, this would have to be something like:
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("plot")
)
server <- function(input, output, session) {
p1 <- plot_ly(economics, x = ~date, y = ~unemploy) %>%
add_lines(name = ~"unemploy")
p2 <- plot_ly(economics, x = ~date, y = ~uempmed) %>%
add_lines(name = ~"uempmed")
listitems <- list(p1, p2)
output$plot <- renderPlotly({
subplot(listitems)
})
}
shinyApp(ui, server)
Output:

Shiny Plotly reactive data plot

I've put together this Shiny app from tutorial and examples, and I've become stuck. My aim is to make the plot reactive, so that the data points in 'uval$df' are plotted, meaning that selected points will be removed from the graph, and it can't be selected twice. How do I do this? (I've got a feeling it's something lacking in my basic understanding)
Thanks!
library(shiny)
library(plotly)
library(dplyr)
ui <- fluidPage(
fluidRow(
column(12,plotlyOutput("plot"),
verbatimTextOutput("txtout1"),
verbatimTextOutput("txtout2"),
verbatimTextOutput("txtout3"))
)
)
server <- function(input, output, session) {
x<-c(1,2,34,2,1,23,24)
y<-c(10,20,30,40,50,60,70)
df<-data.frame(x,y)
vector.is.empty <- function(x) return(length(x) ==0 )
K <-reactive({
event_data("plotly_selected",source = "B")
})
M<-reactive({
K()[,c("x","y")]
})
values <- reactiveValues()
values$df <- data.frame(x = numeric(0), y = numeric(0))
newEntry <- observeEvent(K(),priority = 1,{
new0 <- isolate(M())
isolate(values$df <- rbind(values$df, new0))
})
uval <- reactiveValues()
uval$df <- df
newEntry1 <- observeEvent({values$df},priority = 2,{
new1 <- isolate(data.frame(values$df))
isolate(uval$df <- setdiff(df,new1))
})
output$plot <- renderPlotly({
plot_ly(x = df$x, y = df$y, mode = "markers",source="B") %>%
layout(dragmode = "select", title = "Original Plot", font=list(size=10))
})
output$txtout1 <- renderPrint({
if(vector.is.empty(K())) "Click and drag across points" else M()
})
output$txtout2 <- renderPrint({
uval$df
})
output$txtout3 <- renderPrint({
values$df
})
}
shinyApp(ui, server, options = list(display.mode = "showcase"))
Simple, as I thought.
plot_ly(uval$df, x = x, y = y, mode = "markers",source="B")

Plotly Heatmap & Scatter Linked in Shiny Not Working in a Module

Following the example at: https://plot.ly/r/shinyapp-linked-click/ I was able to in a blank shiny project get this working (correlation matrix linked to a scatter graph). However, when I do the same in a shiny module the event_data based click action doesnt seem to work (the scatter remains blank no mater what happens, seems like the click is not connecting).
My reproducible example is below, any ideas or solutions would be much appreciated.
library(plotly)
#### Define Modules ####
correlation_matrix_shinyUI <- function(id) {
ns <- NS(id)
mainPanel(
plotlyOutput(ns("corr_matrix"), height = '650px'),
plotlyOutput(ns("scatterplot"), height = '550px')
)
}
correlation_matrix_shiny <- function(input, output, session) {
data_df <- reactive({
mtcars
})
corr_data <- reactive({
if (is.null(data_df()))
return()
corr_data <- cor(data_df())
diag(corr_data) <- NA
corr_data <- round(corr_data, 4)
corr_data
})
corr_names <- reactive({
if (is.null(data_df()))
return()
corr_names <- colnames(data_df())
corr_names
})
output$corr_matrix <- renderPlotly({
if (is.null(corr_names()))
return()
if (is.null(corr_data()))
return()
g <- plot_ly(x = corr_names(), y = corr_names(), z = corr_data(),
key = corr_data(), type = "heatmap", source = "CORR_MATRIX", zmax = 1, zmin = -1)
g
})
output$scatterplot <- renderPlotly({
if (is.null(data_df()))
return()
data_use <- data_df()
s <- event_data("plotly_click", source = "CORR_MATRIX")
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(data_use[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = x, y = y, mode = "markers") %>%
plotly::add_trace(x = x, y = yhat, mode = "lines") %>%
plotly::layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plot_ly()
}
})
}
############ End Module Definition ######
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
),
correlation_matrix_shinyUI(id = "cor_module")
)
)
server <- function(input, output, session) {
callModule(correlation_matrix_shiny, id = "cor_module")
}
shinyApp(ui = ui, server = server)
Your question really is interesting. I will answer with some text passages from the shiny modules page.
Foremost, your problem is a scoping issue. In more detail:
[...] input, output, and session cannot be used to access inputs/outputs that are outside of the namespace, nor can they directly access reactive expressions and reactive values from elsewhere in the application [...]
In your module, you are trying to access the plotly-owned and therefore server-level variable event_data that is used to store click (or other) events. The plots react normal, as you could see if you'd add
observe({print(event_data("plotly_click", source = "CORR_MATRIX"))})
inside your server function (and outside of the module). But this kind of input was not defined directly within the correlation_matrix_shinyUI namespace and so it remains inaccessible.
These restrictions are by design, and they are important. The goal is not to prevent modules from interacting with their containing apps, but rather, to make these interactions explicit.
This is well meant, but in your case, you weren't really given the chance to assign a name to this variable, since plotly handles everything under its cover. Luckily, there is a way:
If a module needs to access an input that isn’t part of the module, the containing app should pass the input value wrapped in a reactive expression (i.e. reactive(...)):
callModule(myModule, "myModule1", reactive(input$checkbox1))
This of course goes a bit contrary to the whole modularization...
So, the way this can be fixed is to fetch the click event outside of the module and then send it as extra input to the callModule function. This part in the code may look a bit redundant, but I found this to be the only way it worked.
Well, the rest can be best explained by the code itself. Changes have only been made to the server function and inside the correlation_matrix_shiny, where the variable s is defined.
I hope this helps!
Best regards
Code:
library(plotly)
#### Define Modules ####
correlation_matrix_shinyUI <- function(id) {
ns <- NS(id)
mainPanel(
plotlyOutput(ns("corr_matrix"), height = '650px'),
plotlyOutput(ns("scatterplot"), height = '550px')
)
}
correlation_matrix_shiny <- function(input, output, session, plotlyEvent) {
data_df <- reactive({
mtcars
})
corr_data <- reactive({
if (is.null(data_df()))
return()
corr_data <- cor(data_df())
diag(corr_data) <- NA
corr_data <- round(corr_data, 4)
corr_data
})
corr_names <- reactive({
if (is.null(data_df()))
return()
corr_names <- colnames(data_df())
corr_names
})
output$corr_matrix <- renderPlotly({
if (is.null(corr_names()))
return()
if (is.null(corr_data()))
return()
g <- plot_ly(x = corr_names(), y = corr_names(), z = corr_data(),
key = corr_data(), type = "heatmap", source = "CORR_MATRIX", zmax = 1, zmin = -1)
g
})
output$scatterplot <- renderPlotly({
if (is.null(data_df()))
return()
data_use <- data_df()
s <- plotlyEvent()
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(data_use[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = x, y = y, mode = "markers") %>%
plotly::add_trace(x = x, y = yhat, mode = "lines") %>%
plotly::layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plot_ly()
}
})
}
############ End Module Definition ######
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
),
correlation_matrix_shinyUI(id = "cor_module")
)
))
server <- function(input, output, session) {
plotlyEvent <- reactive(event_data("plotly_click", source = "CORR_MATRIX"))
callModule(correlation_matrix_shiny, id = "cor_module", reactive(plotlyEvent()))
}
shinyApp(ui = ui, server = server)

Resources