I want a pop-up when I click over the bar chart for plotly.
library(shiny)
library(shinymaterial)
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = c(rep('a', 10), rep('b', 10)),
y = c(rnorm(10), rnorm(10, 3, 1)))
ui <- material_page(title = "Material Design",
tags$br(),
font_color = "cyan darken-5",
nav_bar_color = "cyan darken-5",
plotlyOutput('scatter')
)
server <- function(input, output) {
output$scatter <- renderPlotly({
plot_ly(df1, x = df1$x, y = df1$y, type = 'bar', source = 'scatter')
})
}
shinyApp(ui = ui, server = server)
I am struck at a point where I need a help; I want a pop-up when I click
over the bar chart the respective contents to be displayed.
Please help me on the same.
You can use an observer and the event_data from your scatterchart to accomplish that. Working example below, hope this helps!
library(shiny)
library(plotly)
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = c(rep('a', 10), rep('b', 10)),
y = c(rnorm(10), rnorm(10, 3, 1)))
ui <- fluidPage(
plotlyOutput('scatter')
)
server <- function(input, output) {
output$scatter <- renderPlotly({
plot_ly(df1, x = df1$x, y = df1$y, type = 'bar', source = 'scatter')
})
observeEvent(event_data("plotly_click", source = "scatter"),
{
event_data = event_data("plotly_click", source = "scatter")
showModal(modalDialog(
title = "Important message",
paste0('x: ', event_data$x, ', y: ', event_data$y)
))
}
)
}
shinyApp(ui = ui, server = server)
Related
I have a simple application in shiny and I would like to add to the trend lines. I know how to add a linear trend line using the lm and abline functions in ggplot, but how do I add trend lines in R Using only Plotly.
library(shiny)
library(plotly)
library(shinyWidgets)
set.seed(666)
df1 <- data.frame(Date = rep(seq(as.Date("2020-01-03"), by="day", len=12),10,replace = TRUE),
Product = rep(LETTERS[1:10], each = 12),
Value = sample(c(0:300),120, replace = T))
ui <- fluidPage(
pickerInput("All", "Choose", multiple = F, choices = unique(df1$Product) ,
options = list(`max-options` = 4,size = 10)),
plotlyOutput('plot')
)
server <- function(input, output) {
trend<- reactive({
df1 %>%
filter(Product %in% input$All) %>%
arrange(Date) %>%
droplevels()
})
output$plot <- renderPlotly({
plot_ly(data=trend(), x=~Date, y = ~Value,
type = 'scatter', mode = 'lines+markers')
})
}
shinyApp(ui = ui, server = server)
How about adding a line using linear regression?
library(shiny)
library(plotly)
library(shinyWidgets)
set.seed(666)
df1 <- data.frame(Date = rep(seq(as.Date("2020-01-03"), by="day", len=12),10,replace = TRUE),
Product = rep(LETTERS[1:10], each = 12),
Value = sample(c(0:300),120, replace = T))
ui <- fluidPage(
pickerInput("All", "Choose", multiple = F, choices = unique(df1$Product) ,
options = list(`max-options` = 4,size = 10)),
plotlyOutput('plot')
)
server <- function(input, output) {
trend<- reactive({
df1 %>%
filter(Product %in% input$All) %>%
arrange(Date) %>%
droplevels()
})
output$plot <- renderPlotly({
t <- trend()
m <- lm(Value~Date,data = t)
p <-plot_ly(data=t, x=~Date, y = ~Value,
type = 'scatter', mode = 'lines+markers')
p = add_lines(p, x=~Date, y=predict(m), name="Linear")
})
}
shinyApp(ui = ui, server = server)
I want to make an animation in R Shiny where my scatter plot is progressively updated at each iteration, here is my current plot
library(shiny)
library(plotly)
ui <- fluidPage(
titlePanel(""),
sidebarLayout(
sidebarPanel(
actionButton("launch", "Launch Simulation"),
radioButtons("display","Show every iteration", selected = 10,
choices = c(1,5,10,50),inline = FALSE),
numericInput("iter","Maximum number of iterations", value = 2000,
min = 500,max = 5000, step = 500)
),
mainPanel(
plotlyOutput('plot')
)
)
)
server <- function(input, output) {
rv <- reactiveValues(i = 0,
df = data.frame(x = -1,y = -1))
observeEvent(input$launch,{
rv$i = 0
rv$df = data.frame(x = runif(5000, min = -1,max = 1),
y = runif(5000, min = -1,max = 1))
})
observe({
isolate({
rv$i = rv$i + as.numeric(input$display)
})
if ((rv$i < input$iter)&input$launch){
invalidateLater(0)
}
})
output$plot <- renderPlotly({
df = data.frame(x = 0,y = -1)
df = rbind(df,rv$df)
plot_ly(df[1:(rv$i + 1),], x = ~x, y = ~y,
type = 'scatter', mode = 'markers',
marker = list(size = 4), hoverinfo="none") %>%
layout(showlegend = FALSE)
})
}
shinyApp(ui = ui, server = server)
The code is working fine at the beginning but after around 1000 iterations, the animation becomes very slow. I think the main problem is that because in my code, I have to re-make the plot all over again at each iteration, is there a smoother way to do what I want to do?
(Not necessarily with Plotly but it is important to me that I keep track of the number of the iterations outside of the plot (here rv$i))
I want a plotly plot to change an annotation if the user clicks a button in a shiny app.
I have no idea why this does not work:
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("button", "toggle visibility"))
server <- function(input, output) {
output$plot <- renderPlotly({
plot_ly(d)%>%
add_lines(y=d$y, x= d$x)%>%
layout(annotations = list(x = 2, y= 99 , text = "hi"))})
observeEvent(input$button, {
plotlyProxy("plot", session= shiny::getDefaultReactiveDomain()) %>%
plotlyProxyInvoke("relayout", list(annotations= list(x = 2, y= 99 ,
text = "ho")))})}
shinyApp(ui, server)
That is not the way to use relayout in plotly. See below for your example using relayout.
I prefer using native shiny buttons for this purpose because of the greater flexibility it offers. Here is how one might go about achieving the hi-ho toggle.
shiny way
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("button", "toggle visibility"))
server <- function(input, output) {
output$plot <- renderPlotly({
p <- plot_ly(d)%>%
add_lines(y=d$y, x= d$x)
if (is.null(input$button) | (input$button%%2 == 0)) {
p <- p %>% layout(annotations = list(x = 2, y= 99 , text = "hi"))
} else {
p <- p %>% layout(annotations = list(x = 2, y= 99 , text = "ho"))
}
p
})
}
shinyApp(ui, server)
In this case though, it is simple enough to make the relayout feature work, although it does require an extra button.
plotly relayout way
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot")
)
server <- function(input, output) {
output$plot <- renderPlotly({
updatemenus <- list(
list(
active = -1,
type = 'buttons',
buttons = list(
list(
label = "hi",
method = "relayout",
args = list(list(annotations = list(list(x = 2, y= 99 , text = "hi"))))),
list(
label = "ho",
method = "relayout",
args = list(list(annotations = list(list(x = 2, y= 99 , text = "ho")))))
)
)
)
p <- plot_ly(d) %>%
add_lines(y=d$y, x= d$x) %>%
layout(updatemenus = updatemenus)
p
})
}
shinyApp(ui, server)
I believe all that needs to change in your code in order to get this to work is wrapping another list around the defined annotation list in your plotly proxy relayout code. I recently discovered that this recursive list structure is all that's needed in order to manipulate annotations using relayout - you can check out my answer to another SO question related to the same issue, but with slightly different context: https://stackoverflow.com/a/70610374/17852464
library(shiny)
library(plotly)
d <- data.frame(x = c(1,2,3), y = c(9,99,999))
ui <- fluidPage(
plotlyOutput("plot"),
actionButton("button", "toggle visibility"))
server <- function(input, output) {
output$plot <- renderPlotly({
plot_ly(d)%>%
add_lines(y=d$y, x= d$x)%>%
layout(annotations = list(x = 2, y= 99 , text = "hi"))
})
observeEvent(input$button, {
plotlyProxy("plot", session= shiny::getDefaultReactiveDomain()) %>%
plotlyProxyInvoke("relayout", list(annotations= list(list(x = 2, y= 99 ,
text = "ho"))))})}
}
shinyApp(ui, server)
I would like to preselect some points in a ggiraph::renderggiraph() output.
I can make the following shiny app which allows me to select points and then use those selected points elsewhere like so:
dat <- data.table(x = 1:6, y = 1:6 %% 3, id = 1:6, status = rep(c('on','off'),3))
ui <- fluidPage( ggiraphOutput("plot"),
verbatimTextOutput("choices"))
server <- function(input, output, session){
output$plot <- renderggiraph({
p <- ggplot(dat ) +
geom_point_interactive(aes(x = x, y = y, data_id = id), size = 5) +
scale_color_manual(limits = c('on','off'),values = c('red','black'))
ggiraph(code = print(p),
hover_css = "fill:red;cursor:pointer;",
selection_type = "multiple",
selected_css = "fill:red;")
})
output$choices <- renderPrint({
input$plot_selected
})
}
shinyApp(ui = ui, server = server)
But sometimes I want to have certain points selected before I initialize the app.
For example, if the points 1, 3, and 5 are already "on" orginally, I would like the user to be able to turn them "off".
So my question is, is it possible to achieve something like this?
Yes, by using session$sendCustomMessage in session$onFlushed:
library(shiny)
library(ggiraph)
library(data.table)
library(magrittr)
dat <- data.table(x = 1:6, y = 1:6 %% 3, id = 1:6, status = rep(c('on','off'),3))
ui <- fluidPage( fluidRow(
column(width = 7,
ggiraphOutput("ggobj") ),
column(width = 5, verbatimTextOutput("choices"))
) )
server <- function(input, output, session){
output$ggobj <- renderggiraph({
p <- ggplot(dat ) +
geom_point_interactive(aes(x = x, y = y, data_id = id), size = 5) +
scale_color_manual(limits = c('on','off'),values = c('red','black'))
ggiraph(code = print(p),
hover_css = "fill:red;cursor:pointer;",
selection_type = "multiple",
selected_css = "fill:red;")
})
session$onFlushed(function(){
session$sendCustomMessage(type = 'ggobj_set', message = 1:3)
})
output$choices <- renderPrint({
input$ggobj_selected
})
}
shinyApp(ui = ui, server = server)
I am using shiny, plotly and shinyBS as follows to generate a modal pop up with a new plot when a plotly_click event happens on the plot. It works perfectly find when I run locally, and also in the local browser.
However, when I deploy it on the Shiny server, I get this error, and have no idea what it means. Any thoughts?
library(shiny)
library(plotly)
library(shinyBS)
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = c(rep('a', 10), rep('b', 10)),
y = c(rnorm(10), rnorm(10, 3, 1)))
ui <- fluidPage(
column(6, plotlyOutput('scatter')),
bsModal('boxPopUp', '', '', plotlyOutput('box'))
)
server <- function(input, output, session) {
output$scatter <- renderPlotly({
plot_ly(df1, x = ~x, y = ~y, mode = 'markers',
type = 'scatter', source = 'scatter')
})
observeEvent(event_data("plotly_click", source = "scatter"), {
toggleModal(session, "boxPopUp", toggle = "toggle")
})
output$box <- renderPlotly({
eventdata <- event_data('plotly_click', source = 'scatter')
validate(need(!is.null(eventdata),
'Hover over the scatter plot to populate this boxplot'))
plot_ly(df2, x = ~x, y = ~y, type = 'box')
})
}
shinyApp(ui = ui, server = server)
Error message is as follows (shown in the Shiny server log for the app):
Warning: Error in event_data: attempt to apply non-function
Stack trace (innermost first):
59: event_data
58: observeEventExpr
1: runApp
This is a modified version using the modal dialog available in Shiny 0.14.
Tested in RStudio, local browser, shinyapps and on my local instalation of shiny server open source version.
This is the code:
library(shiny)
library(plotly)
library(shinyBS)
df1 <- data.frame(x = 1:10, y = 1:10)
df2 <- data.frame(x = c(rep('a', 10), rep('b', 10)),
y = c(rnorm(10), rnorm(10, 3, 1)))
ui <- fluidPage(
column(6, plotlyOutput('scatter'))
)
server <- function(input, output, session) {
output$scatter <- renderPlotly({
plot_ly(df1, x = x, y = y, mode = 'markers',
type = 'scatter', source = 'scatter')
})
observeEvent(event_data("plotly_click", source = "scatter"), {
showModal(modalDialog(
renderPlotly({
plot_ly(df2, x = x, y = y, type = 'box')
}),
easyClose = TRUE
))
})
}
shinyApp(ui = ui, server = server)