I want to update the data present in a plot (displayed in plotlyOutput in a Shiny app) using Proxy Interface. Here is a minimal App.R code :
library(shiny)
library(plotly)
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
p <- plot_ly(type="scatter",mode="markers")
p <- layout(p,title="test")
p <- add_trace(p, x=0,y=0,name="ABC_test",mode="lines+markers")
})
observeEvent(input$update, {
proxy <- plotlyProxy("graphe", session) %>%
plotlyProxyInvoke("restyle", list(x=0,y=1),0)
})
}
shinyApp(ui, server)
When I run it, the plot is displayed with a dot at (0,0) (as wanted) but when I click of the button "Test", the dot does not move to (0,1). How can I achieve this ?
Thank you for any answer.
Strangely enough addTracesdoes not work with only one point but works with two points. To make it work you could add the same point twice. So you could try this:
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
p <- plot_ly(type="scatter",mode="markers")
p <- layout(p,title="test")
p <- add_trace(p, x=0,y=0,name="ABC_test",mode="lines+markers")
})
observeEvent(input$update, {
plotlyProxy("graphe", session) %>%
plotlyProxyInvoke("deleteTraces", list(as.integer(1))) %>%
plotlyProxyInvoke("addTraces", list(x=c(0, 0),y=c(1, 1),
type = 'scatter',
mode = 'markers'))
})
}
shinyApp(ui, server)
The restyle API is a bit wonky...I forget the reasoning, but data arrays like x and y need double arrays. I'd do it this way:
library(shiny)
library(plotly)
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
plot_ly() %>%
add_markers(x = 0, y = 0, name = "ABC_test") %>%
layout(title = "test")
})
observeEvent(input$update, {
plotlyProxy("graphe", session) %>%
plotlyProxyInvoke("restyle", "y", list(list(1)), 0)
})
}
shinyApp(ui, server)
library(shiny)
ui <- fluidPage(
actionButton("update", "Test"),
plotlyOutput("graphe")
)
server <- function(input, output, session) {
output$graphe <- renderPlotly({
plot_ly() %>%
layout(title="test") %>%
add_trace(x=runif(2), y=runif(2), name="ABC_test", type="scatter", mode="lines+markers")
})
observeEvent(input$update, {
plotlyProxy("graphe", session, FALSE) %>%
plotlyProxyInvoke("deleteTraces", list(as.integer(0))) %>%
plotlyProxyInvoke("addTraces", list(x=runif(2),
y=runif(2),
name="ABC_test",
type = 'scatter',
mode = 'lines+markers'))
})
}
shinyApp(ui, server)
Related
I'm trying to make an app which shows some data after the user clicks a point. It works, except that when the data is longer than the window the scrollbar shows up, resizing the plot and erasing the data. How to make the data show and stay?
Below the code of a minimal example.
library(shiny)
library(tidyr)
ui <- fluidPage(
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
output$data <- renderTable({
req(input$plot_click)
np <- nearPoints(mtcars, input$plot_click) %>%
pull(gear)
mtcars %>%
filter(gear == np)
})
}
shinyApp(ui = ui, server = server)
The problem here is, that once the vertical scrollbar shows up the plotOutput is resized and therefore re-rendered, this results in input$plot_click being reset to NULL causing an empty table.
We can use req()'s cancelOutput parameter to avoid this behaviour.
Please see ?req:
cancelOutput: If TRUE and an output is being evaluated, stop processing as usual but instead of clearing the output, leave it in
whatever state it happens to be in.
library(shiny)
library(tidyr)
library(dplyr)
library(ggplot2)
ui <- fluidPage(
plotOutput("plot", click = "plot_click"),
tableOutput("data")
)
server <- function(input, output, session) {
output$plot <- renderPlot({
ggplot(mtcars, aes(wt, mpg)) + geom_point()
}, res = 96)
output$data <- renderTable({
req(input$plot_click, cancelOutput = TRUE)
np <- nearPoints(mtcars, input$plot_click) %>% pull(gear)
if(length(np) > 0){
mtcars %>% filter(gear == np)
} else {
NULL
}
})
}
shinyApp(ui = ui, server = server)
I am new to Shiny Modules, and I want to use the input from the sliderInput in (at least) two different elements. Therefore I created a little reprex. I want to have a histogram with a vertical line to display the slider value and a table in the main panel, which should be filtered based on the same slider value.
Because in practice I have a lot of sliders, I thought Shiny Modules would be a good thing way to structure and reduce the amount of code.
Unfortunately, I have a bug, already tried various things but couldn't find a way how to resolve it. I cannot access the slider value in the table and the histogram. Thanks in advance for your help.
library(shiny)
library(tidyverse)
ui_slider <- function(id, height = 140, label = "My Label") {
sliderInput(inputId = NS(id, "slider"), label = label, min = 0, max = 5, value = 1)
}
server_slider <- function(id) {
moduleServer(id, function(input, output, session) {
reactive(get(input$slider))
})
}
ui_hist <- function(id, height = 140) {
plotOutput(outputId = NS(id, "hist_plot"), height = height)
}
server_hist <- function(id, df, col, slider_value) {
stopifnot(is.reactive(slider_value))
moduleServer(id, function(input, output, session) {
output$hist_plot <- renderPlot({
df %>%
ggplot(aes_string(x = col)) +
geom_histogram() +
geom_vline(aes(xintercept = slider_value()))
})
})
}
ui <- fluidPage(
titlePanel("My Dashboard"),
sidebarLayout(
sidebarPanel(
ui_hist("gear"),
ui_slider("gear", label = "Gear"),
ui_hist("carb"),
ui_slider("carb", label = "Carb")
),
mainPanel(
tableOutput("table")
)
)
)
server <- function(input, output, session) {
gear_val <- server_slider("gear")
carb_val <- server_slider("carb")
server_hist(
id = "gear",
df = tibble(mtcars),
col = "gear",
slider_value = gear_val
)
server_hist(
id = "carb",
df = tibble(mtcars),
col = "carb",
slider_value = carb_val
)
output$table <- renderTable({
tibble(mtcars) %>%
filter(gear > gear_val()) %>%
filter(carb > carb_val())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Created on 2022-04-22 by the reprex package (v2.0.1)
You're using get() unnecessarily in your slider module server function. Removing it should resolve the issue.
server_slider <- function(id) {
moduleServer(id, function(input, output, session) {
reactive(input$slider)
})
}
Below is a Shiny app in which a Highcharter map is displayed.
When a user clicks a country, the name of the country is displayed below the map.
The app below works when it does not use modules. When implemented using a module, the country selected does not display anymore.
library(shiny)
library(highcharter)
library(dplyr)
# MODULE UI
module_ui <- function(id){
ns <- NS(id)
div(
highchartOutput(ns("hcmap")),
verbatimTextOutput(ns("country"))
)
}
# SERVER UI
module_server <- function(id){
ns <- NS(id)
moduleServer(id, function(input, output, session){
# Data
data_4_map <- download_map_data("custom/world-robinson-highres") %>%
get_data_from_map() %>%
select(`hc-key`) %>%
mutate(value = round(100 * runif(nrow(.)), 2))
# Map
click_js <- JS("function(event) {Shiny.onInputChange('hcmapclick',event.point.name);}")
output$hcmap <- renderHighchart({
hcmap(map = "custom/world-robinson-highres",
data = data_4_map,
value = "value",
joinBy = "hc-key",
name = "Pop",
download_map_data = F) %>%
hc_colorAxis(stops = color_stops()) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
# Clicked country
output$country <- renderPrint({
print(input$hcmapclick)
})
})
}
# APP UI
ui <- fluidPage(
tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js"),
fluidRow(
module_ui(id = "moduleID")
)
)
# APP SERVER
server <- function(input, output, session) {
module_server(id = "moduleID")
}
shinyApp(ui, server)
EDIT
Adding the module ID to the Shiny.onInputChange function as follows, does not solve the problem.
click_js <- JS("function(event) {console.log(event.point.name); Shiny.onInputChange('moduleID-hcmapclick', event.point.name);}")
You have to add the module ID to your call back function. We can do this programmatically by using the module id in paste0 inside the JS() call:
library(shiny)
library(highcharter)
library(dplyr)
# MODULE UI
module_ui <- function(id){
div(
highchartOutput(ns("hcmap")),
verbatimTextOutput(ns("country"))
)
}
# SERVER UI
module_server <- function(id){
moduleServer(id, function(input, output, session){
# Data
data_4_map <- download_map_data("custom/world-robinson-highres") %>%
get_data_from_map() %>%
select(`hc-key`) %>%
mutate(value = round(100 * runif(nrow(.)), 2))
# Map
click_js <- JS(paste0("function(event) {Shiny.onInputChange('",id,"-hcmapclick',event.point.name);}"))
output$hcmap <- renderHighchart({
hcmap(map = "custom/world-robinson-highres",
data = data_4_map,
value = "value",
joinBy = "hc-key",
name = "Pop",
download_map_data = F) %>%
hc_colorAxis(stops = color_stops()) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
# Clicked country
output$country <- renderPrint({
print(input$hcmapclick)
})
})
}
# APP UI
ui <- fluidPage(
tags$script(src = "https://code.highcharts.com/mapdata/custom/world-robinson-highres.js"),
fluidRow(
module_ui(id = "moduleID")
)
)
# APP SERVER
server <- function(input, output, session) {
module_server(id = "moduleID")
}
shinyApp(ui, server)
I am trying to add a vertical line to an existing plotly plot using the addTraces method. I'd like to understand why the new vertical lines are added two units to the right of where the first trace lays.
Fixing this issue will probably solve my original problem (question title) which is avoiding the plot resizing/moving to the right upon adding the new trace.
Here's an example of what I'm trying to do :
library(shiny)
library(plotly)
ui <- bootstrapPage(
plotlyOutput("plot")
)
myvec <- rnorm(100)
server <- function(input, output, session) {
values <- reactiveValues(idx=1)
output$plot <- renderPlotly({
plot_ly(type='scatter', mode='lines') %>%
add_trace(y=myvec[1])
})
plotproxy <- plotlyProxy("plot", session)
observe({
plotproxy %>%
plotlyProxyInvoke("extendTraces",
list(y=list(list(myvec[values$idx]))),
list(1))
if(!values$idx%%10) {
plotproxy %>% plotlyProxyInvoke("addTraces",
list(x=c(values$idx, values$idx), # + 2 would "fix it"
y=c(0,myvec[values$idx]),
type="line", showlegend=F))
}
})
observe({
invalidateLater(1000)
isolate({
values$idx <- min(values$idx + 1, length(myvec))
})
})
}
shinyApp(ui = ui, server = server)
In short, I'd like the x axis limits to update with extendTraces only, I'm just guessing the 2 units mismatch is the problem.
I've managed to solve the x-axis mismatch, however this didn't solve the autosize issue. The problem was I wasn't using the same type and mode. Now it works :
library(shiny)
library(plotly)
ui <- bootstrapPage(
plotlyOutput("plot")
)
myvec <- rnorm(100)
server <- function(input, output, session) {
values <- reactiveValues(idx=1)
output$plot <- renderPlotly({
plot_ly(type='scatter', mode='lines') %>% # Must match with vertical line
add_trace(x=c(-1,0), y=myvec[1]) # use x values
})
plotproxy <- plotlyProxy("plot", session)
observe({
plotproxy %>%
plotlyProxyInvoke("extendTraces",
list(x=list(list(values$idx)), # match x values
y=list(list(myvec[values$idx]))),
list(1))
if(!values$idx%%10) {
plotproxy %>% plotlyProxyInvoke("addTraces",
list(x=c(values$idx, values$idx), # x limits match
y=c(0,myvec[values$idx]),
type='scatter', mode='lines', showlegend=F)) # must match
}
})
observe({
invalidateLater(1000)
isolate({
values$idx <- min(values$idx + 1, length(myvec))
})
})
}
shinyApp(ui = ui, server = server)
I have the data frame below:
Name<-c("John","Bob","Jack")
Number<-c(3,3,5)
NN<-data.frame(Name,Number)
And a simple shiny app which creates a plotly histogram out of it. My goal is to click on a bar of the histogram and display the Name in a datatable that correspond to this bar. For example if I click on the first bar which is 3 I will take a table with John and Bob names.
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
p <- plot_ly(x = NN$Number, type = "histogram")
})
output$tbl4 <- renderDataTable({
s <- event_data("plotly_click")
if (length(s) == 0) {
"Click on a bar in the histogram to see its values"
} else {
NN[ which(NN$Number==as.numeric(s[2])), 1]
}
})
}
shinyApp(ui, server)
I am adding the solution by modifying your data.frame as mentioned in the comment:
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat")
),
DT::dataTableOutput('tbl4')
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
Name<-c("John","Bob","Jack")
Number<-c(3,3,5)
Count<-c(2,2,1)
NN<-data.frame(Name,Number,Count)
render_value(NN) # You need function otherwise data.frame NN is not visible
p <- plot_ly(x = NN$Number, 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(NN[NN$Count==s$y,]))
})
}
}
shinyApp(ui, server)
Screenshot from solution: