Hello This chart bellow is a part of my dashboard but its making the dashboard have a bad performance.
It takes time do update.
Is there any alternative to the functions htmlOutput()+ renderUI() ?
How can I improve the performance? Is it the case to create and generate the charts outside the server?
library(shiny)
library(highcharter)
library(tidyverse)
df <-tibble(months = month.abb, value = ts(cumsum(rnorm(100)))[1:12] )
ui <- fluidPage(
h1("Highcharts"),
htmlOutput('chart_grid')
)
server <- function(input, output, session) {
output$chart_grid<- renderUI({
charts <- lapply(1:9, function(x) {
highchart() %>%
hc_add_series(type = 'spline',data = df, hcaes(x = months,y = value))%>%
hc_xAxis(categories = df$months)
})
hw_grid(charts, rowheight = 300,add_htmlgrid_css = TRUE)%>%
htmltools::browsable()
})
}
shinyApp(ui, server)
TL;DR highcharts JS boost module for many data points, static HTML for a plot if there is one or a few plot versions, own grid and highcharter::highchartOutput
Static HTML
Strategy is to create the needed plot before the shiny app is started, but we have to assume that the plot have one or a few versions as a huge collection of html's could be a wrong direction too.
Usually we are using htmlwidgets::saveWidget to save any shiny widgets so we could get its html representation. As the hw_grid is not returning a shiny widgets I save it as a regular html but we have to take care of the dependencies.
Here I use the hchart (not highchart) as it persists labels on the plots.
You do not have to leave the code for html creation in the app.R file. But in my example you need still leave the dependencies list.
Then you could add dependencies in the DOM head with htmltools::renderDependencies(htmltools::resolveDependencies(DEPS)).
Remember that when you deploy the shiny app you have to add static files with e.g. addResourcePath https://shiny.rstudio.com/reference/shiny/1.0.2/addResourcePath.html
library(shiny)
library(highcharter)
library(tidyverse)
library(magrittr)
df <- tibble::tibble(months = month.abb, value = ts(cumsum(rnorm(100)))[1:12])
charts <- lapply(1:9, function(x) {
hchart(df, type = "spline", hcaes(x = months, y = value)) %>%
hc_xAxis(categories = df$months) %>%
hc_boost(enabled = TRUE)
})
hc_test <- hw_grid(charts, rowheight = 300, add_htmlgrid_css = TRUE, browsable = TRUE)
# get HTML of the plot
# we could not use htmlwidgets::saveWidget as it is not a widget
writeLines(as.character(hc_test), "hc_test.html")
# get the dependencies of the plot
hc_deps <- htmltools::findDependencies(hc_test)
# unique dependencies in the HTML format, could be added in the head
# htmltools::renderDependencies(htmltools::resolveDependencies(hc_deps))
ui <- fluidPage(
h1("Highcharts"),
htmlOutput("chart_grid")
)
server <- function(input, output, session) {
output$chart_grid <- renderUI({
# Load HTML with proper dependencies
htmltools::attachDependencies(
shiny::HTML(readLines("hc_test.html")),
htmltools::resolveDependencies(hc_deps)
)
})
}
shinyApp(ui, server)
Boost module
The source highcharts JS library offers a boost module which could boost the performance. From the perspective of R it is as easy as adding hc_boost(enabled = TRUE) to your pipeline.
https://www.highcharts.com/docs/advanced-chart-features/boost-module
As I understand the hc_boost could improve performance only in specific scenarios and for the cost of losing some functionality. I did not test if it truly works as expected.
library(shiny)
library(highcharter)
library(tidyverse)
df <- tibble(months = month.abb, value = ts(cumsum(rnorm(100)))[1:12])
ui <- fluidPage(
h1("Highcharts"),
htmlOutput("chart_grid")
)
server <- function(input, output, session) {
output$chart_grid <- renderUI({
charts <- lapply(1:9, function(x) {
highchart() %>%
hc_add_series(type = "spline", data = df, hcaes(x = months, y = value)) %>%
hc_xAxis(categories = df$months) %>%
hc_boost(enabled = TRUE)
})
hw_grid(charts, rowheight = 300, add_htmlgrid_css = TRUE, browsable = TRUE)
})
}
shinyApp(ui, server)
Highcharts and own grid
library(shiny)
library(highcharter)
library(tidyverse)
df <- tibble(months = month.abb, value = ts(cumsum(rnorm(100)))[1:12])
ui <- fluidPage(
h1("Highcharts"),
shiny::tags$div(
style = "display:flex;flex-wrap: wrap;",
lapply(1:9, function(x) shiny::tags$div(
style = "flex: 1 1 30%;",
highcharter::highchartOutput(sprintf("hplot%s", x)))
)
)
)
server <- function(input, output, session) {
charts <- lapply(1:9, function(x) {
output[[sprintf("hplot%s", x)]] <- highcharter::renderHighchart(
highchart(width = 600) %>%
hc_add_series(type = "spline", data = df, hcaes(x = months, y = value)) %>%
hc_xAxis(categories = df$months)
)
})
}
shinyApp(ui, server)
BTW.
My personal opinion is that the highcharter package need much work regarding the code quality and documentation, e.g. hw_grid does not even have documented the return value.
I'm trying to develop a part of a shiny app that makes an interactive visualization between a pie chart and a world map. So I want the users to click on the pie chart and then I can get the selected slice and the color code of the corresponding slice. I'm able to take the the slice that has been selected by the following code:
library(shiny)
library(highcharter)
ui <- fluidPage(
column(3,
highchartOutput("hcontainer",height = "300px")
),
column(3,
textOutput("clicked")
)
)
server <- function(input, output){
click_js <- JS("function(event) {Shiny.onInputChange('pieclick',event.point.name);}")
output$hcontainer <- renderHighchart({
highchart() %>%
hc_chart(type = "pie") %>%
hc_add_series(data = list(
list(y = 3, name = "cat 1"),
list(y = 4, name = "dog 11"),
list(y = 6, name = "cow 55"))) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
output$clicked <- renderText({
input$pieclick
})
}
shinyApp(ui, server)
But I can't see any way on how I can get the corresponding color of the selected slice ?
A possible solution for that is if I can get a vector of all the slice and a vector of all the corresponding color-codes then I can make a comparison between the value I got from the selection and the colors of each value. I also couldn't find a way to get all the values and color-codes used automatically in the pei chart generation.
Hey, the event.point has loads of other data, one of which is the event.point.color which we can take out. Do print out the object or event using console.log(event) so you can see what other things you can use from the event...
We can also ask for the hex color code from the point you're clicking within the same event. I couldn't find it how to use it seamlessly using purely JS, so going to do it on the R side...
Then we are going to convert the hex to human readable color using plotrix package. May need to remove digits of some colors like: grey27 and so on, so will just gsub and remove the digits
library(shiny)
library(plotrix)
library(highcharter)
ui <- fluidPage(
column(3,
highchartOutput("hcontainer",height = "300px")
),
column(3,
textOutput("clicked")
)
)
server <- function(input, output){
click_js <- JS("function(event) {Shiny.onInputChange('pieclick',[event.point.name,event.point.color]);}")
output$hcontainer <- renderHighchart({
highchart() %>%
hc_chart(type = "pie") %>%
hc_add_series(data = list(
list(y = 3, name = "cat 1"),
list(y = 4, name = "dog 11"),
list(y = 6, name = "cow 55"))) %>%
hc_plotOptions(series = list(events = list(click = click_js)))
})
output$clicked <- renderText({
req(input$pieclick)
d <- input$pieclick
mycolor <- gsub("[[:digit:]]", "", color.id(d[2])[1])
paste0(d[1],"-",mycolor)
})
}
shinyApp(ui, server)
I am trying to use shiny controls to modify the data underlying a plotly chloropleth map.
Whenever I change the data the entire plot re-renders, which is quite slow. I'm guessing the bottleneck is redrawing the geojson polygons. Because the geojson never changes, I'm wondering if there is a way to keep the rendered widget intact but modify the z values only.
It looks like using plotlyProxy and plotlyProxyInvoke might be the right direction, but I can only see examples of an entire trace (which includes the geojson data) being replaced.
Sorry if I'm missing something or have been unclear - I have not used plotly very much, and even less so the js side of things.
See below for example code:
library(shiny)
library(dplyr)
library(plotly)
library(readr)
library(rjson)
zip_geojson <- fromJSON(file="https://raw.githubusercontent.com/hms1/testData/main/zip3_2.json")
plot_data <- read_csv(file="https://raw.githubusercontent.com/hms1/testData/main/plot_data.csv")
mapboxToken <- "pk.eyJ1IjoiaG1vcmdhbnN0ZXdhcnQiLCJhIjoiY2tmaTg5NDljMDBwbDMwcDd2OHV6cnd5dCJ9.8eLR4FtlO079Gq0NeSNoeg" #burner token
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("multip",
"n:",
min = 1,
max = 10,
value = 1)
),
mainPanel(
plotlyOutput("cPlot")
)
)
)
server <- function(input, output) {
output$cPlot <- renderPlotly({
plot_data_i <- plot_data%>%
mutate(log_count = case_when(log_count <= input$multip ~ log_count * input$multip,
TRUE ~ log_count))
plot_ly() %>%
add_trace(
type = "choroplethmapbox",
geojson = zip_geojson,
locations = plot_data_i$zip,
z = plot_data_i$log_count
) %>%
layout(
mapbox = list(
style = "light",
zoom = 3,
center = list(lon = -95.7129, lat = 37.0902)
)
) %>%
config(mapboxAccessToken = mapboxToken)
})
}
shinyApp(ui = ui, server = server)
For anyone else who comes across this post later, I found a solution.
It turns out that you can change data using the restyle method in plotlyProxyInvoke, as shown below.
library(shiny)
library(dplyr)
library(plotly)
library(readr)
library(rjson)
zip_geojson <- fromJSON(file="https://raw.githubusercontent.com/hms1/testData/main/zip3_2.json")
plot_data <- read_csv(file="https://raw.githubusercontent.com/hms1/testData/main/plot_data.csv")
mapboxToken <- "pk.eyJ1IjoiaG1vcmdhbnN0ZXdhcnQiLCJhIjoiY2tmaTg5NDljMDBwbDMwcDd2OHV6cnd5dCJ9.8eLR4FtlO079Gq0NeSNoeg"
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("multip",
"n:",
min = 1,
max = 10,
value = 1),
actionButton("Remove", "Remove Trace")
),
mainPanel(
plotlyOutput("cPlot")
)
)
)
server <- function(input, output, session) {
output$cPlot <- renderPlotly({
plot_ly(type = "choroplethmapbox", geojson = zip_geojson) %>%
layout(
mapbox = list(
style = "light",
zoom = 3,
center = list(lon = -95.7129, lat = 37.0902)
)
) %>%
config(mapboxAccessToken = mapboxToken)
})
plotproxy <- plotlyProxy("cPlot", session, deferUntilFlush = FALSE)
observeEvent(input$multip, {
plot_data_i <- plot_data %>%
mutate(log_count = case_when(log_count <= input$multip ~ log_count * input$multip,
TRUE ~ log_count))
plotproxy %>%
plotlyProxyInvoke("restyle", list(z = list(plot_data_i$log_count),
locations = list(plot_data_i$zip)))
})
}
shinyApp(ui = ui, server = server)
I have created a shiny app to show a correlation heatmap for a large dataset. When the heatmap tiles are pressed, the corresponding scatterplots are displayed.
However, I need to make several of these apps and this exceeds my limit of publishing on shinyapps.io. My company is unwilling to upgrade to a paying plan. I have tried using alternative methods to publish the app such as RInno, to no avail (I think the app is too complex?).
If someone could please tell me how I could produce the same with plotly alone and NOT with shiny, I would be forever grateful. I believe something like crosstalk might be the path to take in order to link the heat map tiles to the scatter plots?
Thank you
Example from here.
library(plotly)
library(shiny)
# compute a correlation matrix
correlation <- round(cor(mtcars), 3)
nms <- names(mtcars)
ui <- fluidPage(
mainPanel(
plotlyOutput("heat"),
plotlyOutput("scatterplot")
),
verbatimTextOutput("selection")
)
server <- function(input, output, session) {
output$heat <- renderPlotly({
plot_ly(x = nms, y = nms, z = correlation,
key = correlation, type = "heatmap", source = "heatplot") %>%
layout(xaxis = list(title = ""),
yaxis = list(title = ""))
})
output$selection <- renderPrint({
s <- event_data("plotly_click")
if (length(s) == 0) {
"Click on a cell in the heatmap to display a scatterplot"
} else {
cat("You selected: \n\n")
as.list(s)
}
})
output$scatterplot <- renderPlotly({
s <- event_data("plotly_click", source = "heatplot")
if (length(s)) {
vars <- c(s[["x"]], s[["y"]])
d <- setNames(mtcars[vars], c("x", "y"))
yhat <- fitted(lm(y ~ x, data = d))
plot_ly(d, x = ~x) %>%
add_markers(y = ~y) %>%
add_lines(y = ~yhat) %>%
layout(xaxis = list(title = s[["x"]]),
yaxis = list(title = s[["y"]]),
showlegend = FALSE)
} else {
plotly_empty()
}
})
}
shinyApp(ui, server)
The best answer would likely be to use crosstalk in conjunction with flexdashboard https://rmarkdown.rstudio.com/flexdashboard/.
A live example of using both be found here: http://rstudio-pubs-static.s3.amazonaws.com/209203_02f14fea3274448bbbf8d04c99c6051b.html.
The end result is just an html page which is easy to share and use. Based on your example you shouldn't need shiny and it you should be able to use crosstalk for this use case. You'd need to step outside of R to get that functionality otherwise. Best of luck!
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))
})
})