R Shiny plotly DT table interaction - r

I want to do table-plot interaction using R-Shiny and Plotly.
After click any point in plot: I want to increase the size of point in graph, color it red also in the table bring corresponding row at top of the table and highlight the row.
Similarly, after clicking (single) row in the table, corresponding point in the plot should be highlighted in red and bigger in size.
As my data is big I need to do this on serve side.
I was able to create the plot and table below is my code.
ui.R file:
ui <- fluidPage(
fluidPage(column(width = 6, plotlyOutput("volcanoplot", height = 350))),
fluidPage(DT::dataTableOutput("de_table"))
)
And server.R file:
library("DT")
library(plotly)
library(shiny)
m <- mtcars[, c("mpg", "wt", "disp")] %>%
tibble::rownames_to_column()
function(input, output, session) {
shared_data <- SharedData$new(m, ~rowname)
output$volcanoplot <- renderPlotly({
pp <- shared_data %>% plot_ly(source = 'volcanoplot') %>%
add_trace(x = ~mpg, y = ~wt, type = 'scatter', mode = "markers")
})
# highlight selected rows in the table
output$de_table <- DT::renderDataTable({
dt <- DT::datatable(shared_data$data() , selection = 'single', rownames= FALSE)})
}
I was able to understand the click and table select variables as,
click_detect = plotly::event_data('plotly_click', source = 'volcanoplot')
s <- input$de_table_rows_selected
Thanks for the help.

Related

How to get the rows corresponding to a plot selection in shiny

I have a bar graph which is part of a shiny app. I have created it with plotly. I would like the user to be able to select a part of the graph (click) and on clicking a datatable would show all rows corresponding to the values given in the hover text from that part of the chart.
So far I am able to show the output from event.data which isnt very interesting. How can I show the relevant rows from the original table?
library(plotly)
library(shiny)
ui <- fluidPage(
uiOutput("ChooserDropdown"),
plotlyOutput("plot2"),
DT::dataTableOutput("tblpolypDetail2")
)
server <- function(input, output, session) {
output$plot2 <- renderPlotly({
# use the key aesthetic/argument to help uniquely identify selected observations
#key <- row.names(mtcars)
browser()
p <- ggplot(iris,aes_string(iris$Species,input$Chooser)) + geom_col()
ggplotly(p,source = "subset") %>% layout(dragmode = "select")
})
output$tblpolypDetail2 <- renderDataTable({
event.data <- event_data("plotly_click", source = "subset")
print(event.data)
})
output$ChooserDropdown<-renderUI({
selectInput("Chooser", label = h4("Choose the endoscopic documentation column"),
choices = colnames(iris) ,selected = 1
)
})
}
shinyApp(ui, server)

I created a small demo where you can highlight rows in datatable by clicking the plotly graph.
You need to do it in two steps:
Map pointNumber of a click to rows in datatable(), you can create an external table for it.
You need to create a dataTableProxy where you can update a datatable
library(plotly)
library(DT)
library(shiny)
library(dplyr)
data <- as_tibble(iris) %>%
group_by(Species) %>%
summarise(avg = mean(Sepal.Width)) %>%
mutate(Species = as.character(Species))
species_mapping <- data.frame(
Species = data$Species,
row_id = 1:length(data$Species),
stringsAsFactors = FALSE
)
ui <- fluidPage(
DT::dataTableOutput("table"),
plotlyOutput("plot")
)
server <- function(input, output, session) {
output$plot <- renderPlotly({
p <- data %>%
ggplot() +
geom_col(aes(x = Species, y = avg))
# register this plotly object
plotly_object <- ggplotly(p,source = "source1")
event_register(plotly_object,event = "plotly_click")
plotly_object
})
output$table <- DT::renderDataTable(data)
# create a proxy where we can update datatable
proxy <- DT::dataTableProxy("table")
observe({
s <- event_data("plotly_click",source = "source1")
req(!is.null(s))
# map point number to Species
row_clicked <- species_mapping[s$pointNumber + 1,"row_id"]
proxy %>%
selectRows(NULL) %>%
selectRows(row_clicked)
})
}
shinyApp(ui, server)

Plotly click event does not work due to range of values of in a single bar of a histogram

I have the dataframe below:
col1<-sample(500, size = 500, replace = TRUE)
col2<-sample(500, size = 500, replace = TRUE)
d<-data.frame(col1,col2)
And I create a histogram of this data frame that has click-event activated. When the user clicks on a bar the rows of the dataframe that have the relative value are displayed in a datatable. The problem is that the app works fine with a few values. If for example my dataframe had 5 rows instead of 500 with :
col1<-sample(5, size = 5, replace = TRUE)
col2<-sample(5, size = 5, replace = TRUE)
d<-data.frame(col1,col2)
But with more values the app does not work since the plotly gives a range of values in every single bar instead of a unique value.
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
render_value(d) # You need function otherwise data.frame NN is not visible
p <- plot_ly(x = d$col2, type = "histogram",source="subset") # set source so
# that you can get values from source using click_event
})
render_value=function(NN){
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click",source = "subset")
print(s)
return(DT::datatable(d[d$col2==s$y,]))
})
}
}
shinyApp(ui, server)

You can try this (added code to capture the count). You need to plot a histogram of count and then you can able to get your original data based on click event.
library(plotly)
library(shiny)
library(DT)
library(dplyr)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
col1<-sample(500, size = 500, replace = TRUE)
col2<-sample(500, size = 500, replace = TRUE)
d<-data.frame(col1,col2)
d=d %>%
group_by(col2) %>%
mutate(count = n()) # You can programatically add count for each row
render_value(d) # You need function otherwise data.frame NN is not visible
p <- plot_ly(x = d$count, type = "histogram",source="subset")
# You should histogram of count
# set source so that you can get values from source using click_event
})
render_value=function(d){
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click",source = "subset")
print(s)
return(DT::datatable(d[d$count==s$x,]))
})
}
}
shinyApp(ui, server)
Screenshot from the working prototype:

Shiny: Plotting a graph whose name contains an interactive input value

In ShinyApp, I want to plot a graph whose name has an interactive input value. So in the ui.R side, the user chooses an input value from 0, 1 or 2. And in the server.R side, I want the App to plot a graph whose name is either pl0, pl1 or pl2. That is to say, if the user chooses 0 as an input value, the App plots a graph pl0, so does the same for pl1 for input 1, and for pl2 and input 2. I am using plotly library for plotting graphs.
I have tried print(), plot(), return(), but neither of them worked.
Any solution or advice would be appreciated. Thank you very much!
Here is my ui.R
library(shiny)
shinyUI(fluidPage(
# Application title
titlePanel("Star Cluster Simulations"),
# Sidebar with a slider input for time
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "time",
label = "Select time to display a snapshot",
min = 0,
max = 2,
value = 0)
),
# Show a plot of the generated distribution
mainPanel(
plotlyOutput("distPlot")
)
)
))
And here is my server.R
library(shiny)
library(plotly)
# load data
for(i in 0:2) {
infile <- paste0("Data/c_0", i, "00.csv")
a <- read.csv(infile)
b <- assign(paste0("c_0", i, "00"), a)
names(a) <- paste0("c_0", i, "00")
pl <- plot_ly(b, x = ~x, y = ~y, z = ~z, color = ~id) %>%
add_markers() %>%
layout(scene = list(xaxis = list(title = 'x'),
yaxis = list(title = 'y'),
zaxis = list(title = 'z')))
assign(paste0("pl", i), pl)
}
# shinyServer
shinyServer(function(input, output) {
output$distPlot <- renderPlotly({
# this doesn't work
print(paste0("pl", input$time))
})
})

I can't test this since your question isn't reproducible (i.e. doesn't include data), but one way to switch between text values (i.e. the values returned from Shiny inputs) and R objects is by making a reactive expression that uses the switch function. You can call the reactive expression (in the case below, plot.data()) inside renderPlotly (or any other render function) to switch between datasets.
shinyServer(function(input, output) {
plot.data <- reactive({
switch(paste0("pl", input$time),
"pl0" = pl0,
"pl1" = pl1,
"pl2" = pl2)
})
output$distPlot <- renderPlotly({
plot.data()
})
})

Disable visual response of R Plotly click events

I'm building a Shiny app with a plot_ly scatter plot. I'm using a SharedData object (from the crosstalk package) to share information between the plot and a datatable (from DT).
The problem is when you click a point in the plot it dims the color of all of the other points and adds an entry to the legend for the selected point, and once this happens there doesn't seem to be a way to undo it. I would like to disable these visual changes but still be able to detect plot clicks.
This issue does not occur if I just use a reactive data.frame instead of a SharedData object in the data parameter of the plot_ly call, but then the event_data from the plot doesn't have enough information to select a row in the datatable. (The x and y point coordinates are floating point numeric, so matching by coordinates against the data can have unexpected results.)
Here's a demo using mtcars:
library(shiny)
library(DT)
library(plotly)
library(data.table)
library(crosstalk)
### UI function ---------
ui <- fluidPage(
fluidRow(
plotlyOutput('my_graph', height = '400px')
),
fluidRow(
dataTableOutput('my_table')
)
)
### Server function -------
server <- function(input, output, session) {
### SharedData object ----
filtered_data <- reactive({
data.table(mtcars, keep.rownames = TRUE)
})
shared_data <- reactive({
req(filtered_data())
SharedData$new(filtered_data(), ~rn)
})
### my_graph ----
output$my_graph <- renderPlotly({
p <- plot_ly(shared_data(),
x = ~disp,
y = ~mpg,
color = ~factor(carb),
source = 'm')
p
})
### my_table ---------
output$my_table <- renderDataTable({
datatable(shared_data()$data(),
selection = 'single')
})
observe({
click_detect = plotly::event_data('plotly_hover', source = 'm')
str(click_detect)
dataTableProxy('my_table') %>%
selectRows(match(click_detect$key, shared_data()$data()$rn))
})
}
shinyApp(ui, server)

Why that happens beats me but I can see two possible workarounds.
Force Plotly to set the opacity of all markers to 1.
if (click_detect$curveNumber != 0) {
output$my_graph <- renderPlotly({
p <- plot_ly(shared_data(),
x = ~disp,
y = ~mpg,
color = ~factor(carb),
source = 'm',
marker = list(opacity = 1))
p
})
}
Drawback: The graph flickers.
Change your filterRows statement. I don't know your data but for mtcars you can filter by carb (via curveNumber) and then via pointNumber.
dataTableProxy('my_table') %>% selectRows(
which(mtcars$carb == sort(unique(mtcars$carb))[[click_detect$curveNumber + 1]])[[click_detect$pointNumber + 1]])

I came across the same issue and found an approach using the highlight function. https://www.rdocumentation.org/packages/plotly/versions/4.8.0/topics/highlight
The default setting for non-selected points is opacity=0.2 . This is why the other points dim. So all you need to do is add a pipe %>% highlight(opacityDim = 1)
Use any number between 0 and 1 to reduce the opacity of non-selected traces. If you want to disable it completely, then do 1. Otherwise you can try 0.5 and it worked for me.
In your case, you may try
output$my_graph <- renderPlotly({
p <- plot_ly(shared_data(),
x = ~disp,
y = ~mpg,
color = ~factor(carb),
source = 'm')
p <- highlight(p, opacityDim = 1)
p
})
Hopefully, it helps for whoever need it later.

Sub-setting data interactively with plotly or googlevis charts in Shiny App

R Gugus,
Is there any way to sub-set and view data in data.table by clicking on an interactive plotly or googlevis chart in shiny app?
For example, I would like to see the highlighted row in the picture when I click on the related part on plotly chart generated by the following code:
library(shiny)
library(plotly)
library(DT)
library(dplyr)
shinyApp(
ui = shinyUI(fluidPage(
titlePanel("Movie Ratings!"),
mainPanel(
plotlyOutput("chart", width = "100%"),
dataTableOutput("DToutput")
)
)),
server = function(input, output, session) {
df <- structure(c(106487,495681,1597442,2452577,2065141,2271925,4735484,3555352,8056040,4321887,
2463194,347566,621147,1325727,1123492,800368,761550,1359737,1073726,36,53,141,
41538,64759,124160,69942,74862,323543,247236,112059,16595,37028,153249,427642,
1588178,2738157,2795672,2265696,11951,33424,62469,74720,166607,404044,426967,
38972,361888,1143671,1516716,160037,354804,996944,1716374,1982735,3615225,
4486806,3037122,17,54,55,210,312,358,857,350,7368,8443,6286,1750,7367,14092,
28954,80779,176893,354939,446792,33333,69911,53144,29169,18005,11704,13363,
18028,46547,14574,8954,2483,14693,25467,25215,41254,46237,98263,185986),
.Dim=c(19,5),.Dimnames=list(c("1820-30","1831-40","1841-50","1851-60","1861-70",
"1871-80","1881-90","1891-00","1901-10","1911-20",
"1921-30","1931-40","1941-50","1951-60","1961-70",
"1971-80","1981-90","1991-00","2001-06"),
c("Europe","Asia","Americas","Africa","Oceania")))
df.m <- melt(df)
df.m <- rename(df.m, c(Var1 = "Period", Var2 = "Region"))
output$chart <- renderPlotly({
a <- ggplot(df.m, aes(x = Period, y = value/1e+06,fill = Region)) +
ggtitle("Migration to the United States by Source Region (1820-2006), In Millions")
b <- a + geom_bar(stat = "identity", position = "stack")
p <- ggplotly(b)
p
})
output$DToutput <- renderDataTable({df.m})
})
Ultimate aim is to produce an app where the user can navigate easily by between data and charts anywhere in the app. I have a similar app but written in a different code: http://mqasim.me/sw1000/

Current click events in Plotly return all data in the trace so it will be difficult to isolate elements in the stack. Also, will need to build the plot with plot_ly(). One way to deal with the selected table rows being on a different page is to eliminate the need for pagination.
curveNumber: for mutiple traces, information will be returned in a stacked fashion
See this Plotly tutorial for coupled events and section 2.3 of the Shiny page of DT for selecting rows.
library(shiny)
library(plotly)
library(DT)
library(dplyr)
library(reshape2)
shinyApp(
ui = shinyUI(fluidPage(
titlePanel("Movie Ratings!"),
mainPanel(
plotlyOutput("chart", width = "100%"),
DT::dataTableOutput("DToutput")
)
)),
server = function(input, output, session) {
df <- structure(c(106487,495681,1597442,2452577,2065141,2271925,4735484,3555352,8056040,4321887,
2463194,347566,621147,1325727,1123492,800368,761550,1359737,1073726,36,53,141,
41538,64759,124160,69942,74862,323543,247236,112059,16595,37028,153249,427642,
1588178,2738157,2795672,2265696,11951,33424,62469,74720,166607,404044,426967,
38972,361888,1143671,1516716,160037,354804,996944,1716374,1982735,3615225,
4486806,3037122,17,54,55,210,312,358,857,350,7368,8443,6286,1750,7367,14092,
28954,80779,176893,354939,446792,33333,69911,53144,29169,18005,11704,13363,
18028,46547,14574,8954,2483,14693,25467,25215,41254,46237,98263,185986),
.Dim=c(19,5),.Dimnames=list(c("1820-30","1831-40","1841-50","1851-60","1861-70",
"1871-80","1881-90","1891-00","1901-10","1911-20",
"1921-30","1931-40","1941-50","1951-60","1961-70",
"1971-80","1981-90","1991-00","2001-06"),
c("Europe","Asia","Americas","Africa","Oceania")))
df.m <- melt(df)
df.m <- rename(df.m, Period = Var1, Region = Var2)
output$chart <- renderPlotly({
plot_ly(data = df.m, x = Period, y = value/1e+06, color = Region, type = "bar", source = "select") %>%
layout(title = "Migration to the United States by Source Region (1820-2006), In Millions",
xaxis = list(type = "category"),
barmode = "stack")
})
output$DToutput <- DT::renderDataTable({
datatable(df.m, selection = list(target = "row+column"),
options = list(pageLength = nrow(df.m), dom = "ft"))
})
proxy = dataTableProxy('DToutput')
# highlight rows that are selected on plotly output
observe({
event.data = plotly::event_data("plotly_click", source = "select")
if(is.null(event.data)) {
rowNums <- NULL
} else {
rowNums <- row.names(df.m[df.m$Period %in% event.data$x,])
}
proxy %>% selectRows(as.numeric(rowNums))
})
})

Resources