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")
Related
I have a larger application where i need to identify data clusters.
For this I would like to create a pair plot and use the brush option to mark some points. These marked points are later used in another part of the program.
The problem is that i can not specify the xvar and yvar parameters for the pair plot.
At the moment i have no idea how to solve this.
Is there someone around who had the same problem?
I tried to create a simple application that demonstrates the problem.
Finally i need the IMG_Selected_Tiles variable to mark specific parts of a source image...
Thanks for any help
Jan
IMG_SelectedTiles <- reactiveValues ()
IMG_Statistics <- reactiveValues ()
library ("ggplot2")
shinyApp(
ui = basicPage(
fluidRow(
column(width = 4,
plotOutput("plot", height=300,
click = "plot_click", # Equiv, to click=clickOpts(id="plot_click")
hover = hoverOpts(id = "plot_hover", delayType = "throttle"),
brush = brushOpts(id = "plot_brush")
),
h4("Clicked points"),
tableOutput("plot_clickedpoints"),
h4("Brushed points"),
tableOutput("plot_brushedpoints")
),
column(width = 4,
verbatimTextOutput("plot_clickinfo"),
verbatimTextOutput("plot_hoverinfo")
),
column(width = 4,
wellPanel(actionButton("newplot", "New plot")),
verbatimTextOutput("plot_brushinfo"),
verbatimTextOutput("text_IMG_selected_tiles")
)
)
),
server = function(input, output, session) {
IMG_Statistics$data <- reactive({
input$newplot
iris
})
output$plot <- renderPlot({
d <- IMG_Statistics$data ()
ggpairs (d)
#plot(d$speed, d$dist)
})
output$plot_clickinfo <- renderPrint({
cat("Click:\n")
str(input$plot_click)
})
output$plot_hoverinfo <- renderPrint({
cat("Hover (throttled):\n")
str(input$plot_hover)
})
output$plot_brushinfo <- renderPrint({
cat("Brush (debounced):\n")
str(input$plot_brush)
})
output$plot_clickedpoints <- renderTable({
# For base graphics, we need to specify columns, though for ggplot2,
# it's usually not necessary.
res <- nearPoints(IMG_Statistics$data(),
input$plot_click,
"speed",
"dist")
if (nrow(res) == 0) return()
res
})
output$plot_brushedpoints <- renderTable({
res <- brushedPoints(IMG_Statistics$data(), input$plot_brush, allRows = TRUE)
if (nrow (res) == 0) return()
#just as an example data are taken from another data structure
IMG_SelectedTiles <- cbind(IMG_Statistics$data [res_selected_, 1],
IMG_Statistics$data [res_selected_, 2],
IMG_Statistics$data [res_selected_, 3])
})
output$text_IMG_selected_Tiles <-renderTable ({
cat ("Selected data:\n")
str (IMG_Selected_Tiles())
})
}
)
Maybe with the help of plotly?
library(plotly)
library(GGally)
library(shiny)
ui <- fluidPage(
plotlyOutput("myPlot"),
)
server <- function(input, output, session){
output$myPlot = renderPlotly({
highlight_key(iris) %>%
GGally::ggpairs(aes(color = Species), columns = 1:4) %>%
ggplotly() %>%
highlight("plotly_selected") %>%
layout(dragmode = "select") %>%
event_register(event = "plotly_brushed") %>%
event_register(event = "plotly_selected")
})
observeEvent(event_data("plotly_brushed"), {
cat("Selected box:\n")
print(event_data("plotly_brushed"))
# alternative method
#xmin <- event_data("plotly_brushed")$x[1]
#xmax <- event_data("plotly_brushed")$x[2]
#ymin <- event_data("plotly_brushed")$y[1]
#ymax <- event_data("plotly_brushed")$y[2]
})
observeEvent(event_data("plotly_selected"), {
cat("Selected points:\n")
print(event_data("plotly_selected"))
})
}
shinyApp(ui, server)
Thanks for your help, Stéphane!
I finally made a solution for the problem, using your approach in a very similar way.
I think, that this is a little tricky problem. Thus, I prepared some sample code. It is not the most elegant sample, but it may help some others facing a similar problem...
Jan
library ("plotly")
IMG_SelectedTiles <- reactiveValues ()
IMG_Statistics <- reactiveValues ()
IMG_selected_keys <- reactiveValues ()
IMG_selected_points <- reactiveValues ()
ui <- fluidPage(
wellPanel(actionButton("newplot", "New plot")),
plotlyOutput("myPlot"),
h4 ("Selected points"),
tableOutput("selected_points"),
h4 ("Selected keys"),
tableOutput("selected_keys"),
h4 ("Selected data"),
tableOutput("selected_data")
)
server <- function(input, output, session){
# get arbitrary data into my reactive variable
IMG_Statistics$data <- reactive({
input$newplot
iris
})
output$myPlot = renderPlotly({
#height = "1500px"
#width = "1500px",
highlight_key(IMG_Statistics$data() ) %>%
GGally::ggpairs () %>%#(aes(color = "black"), columns = 1:4) %>%
ggplotly() %>%
highlight("plotly_selected") %>%
layout(dragmode = "select", autosize = FALSE, height = 1500, width = 1500) %>%
# event_register(event = "plotly_brushed") %>%
event_register(event = "plotly_selected")
})
observeEvent(event_data("plotly_brushed"), {
# cat("Selected brush:\n")
# print (str (event_data("plotly_brushed")))
# alternative method
#xmin <- event_data("plotly_brushed")$x[1]
#xmax <- event_data("plotly_brushed")$x[2]
#ymin <- event_data("plotly_brushed")$y[1]
#ymax <- event_data("plotly_brushed")$y[2]
})
observeEvent(event_data("plotly_selected"), {
cat("Data:\n")
print (str (IMG_Statistics$data))
IMG_selected_keys$data <- event_data("plotly_selected")$key
cat("Selected keys:\n")
print ( IMG_selected_keys$data)
IMG_selected_points$data <- event_data("plotly_selected")$pointNumber
cat("Selected point numbers:\n")
print (IMG_selected_points$data)
IMG_SelectedTiles$data <- IMG_Statistics$data () [as.numeric (event_data ("plotly_selected")$key), ]
cat("Selected tiles:\n")
print (IMG_SelectedTiles$data)
})
output$selected_keys <- renderPrint ({IMG_selected_keys$data })
output$selected_points <- renderPrint ({IMG_selected_points$data})
output$selected_data <- renderTable({
IMG_SelectedTiles$data
})
}
shinyApp(ui, server)
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)
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:
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)
How can we get interactive coordinates(x and y) of multiple histograms in shiny. I have tried this code
#server.R
library(xts)
shinyServer(function(input, output,session) {
output$info <- renderText({
paste0("x=", input$plot_click$x, "\ny=", input$plot_click$y)
})
output$plot<- renderPlot({
set.seed(3)
Ex <- xts(1:100, Sys.Date()+1:100)
df = data.frame(Ex,matrix(rnorm(100*3,mean=123,sd=3), nrow=100))
df<-df[,-1]
par(mfrow = c(2,2))
for(i in names(df)){
hist(df[[i]] , main=i,xlab="x",freq=TRUE,label=TRUE,plot = TRUE)
}
})
})
ui.R
#ui.r
mainPanel(
tabsetPanel(type="tab",tabPanel("plot", plotOutput("plot",click = "plot_click"), verbatimTextOutput("info"))
)
The problem with above code is I get random coordinates of the whole plot like this
x=124.632301932263
y=20.4921068342051
instead I want to get coordinates of individual plots with its corresponding values. For example if I click any place in X1's chart I should get x and y coordinates of that chart . How can I do this?
I originally was going to say that this occurs because the click is governed by the pixels of the plot instead of the data, but I am proved wrong here:
Notice that the x and y coordinates are scaled to the data, as opposed to simply being the pixel coordinates. This makes it easy to use those values to select or filter data.
I instead am going to honestly guess that within a graphics device Shiny can't tell the difference between the individual plots, to which a solution would be to create individual devices for each plot:
ui.R
library(shiny)
shinyUI(
tabsetPanel(type="tab",
tabPanel("plot",
uiOutput("coords"),
uiOutput("plots")
)
)
)
server.R
library(xts)
set.seed(3)
Ex <- xts(1:100, Sys.Date() + 1:100)
df <- data.frame(Ex, matrix(rnorm(100*3, mean = 123, sd = 3), nrow = 100))
cn <- colnames(df)
df <- df[, cn[cn != "Ex"]]
n_seq <- seq(ncol(df))
shinyServer(function(input, output, session) {
output$plots <- renderUI({
plot_output_list <- lapply(n_seq, function(i) {
plotOutput(paste0("plot", i), click = paste0("plot_click", i),
height = 250, width = 300)
})
})
for (i in n_seq) {
output[[paste0("plot", i)]] <- renderPlot({
hist(df[[i]] , main = i, xlab = "x", freq = TRUE, label = TRUE)
})
}
output$coords <- renderUI({
coords_output_list <- lapply(n_seq, function(i) {
renderText({
set <- input[[paste0("plot_click", i)]]
paste0("Plot ", i, ": x=", set$x, "\ny=", set$y)
})
})
})
})