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.
Related
I have an app with a global function that makes a ggvis plot. I use a global function because I recreate the plot many times with slightly different settings. I need the tooltip to respond to some user inputs, but even when reactivity forces a recalculation of the plot, the tooltip does not seem to get recalculated. Here's an example of the issue:
library(shiny)
library(ggvis)
df = mtcars
df$name = row.names(df)
make_plot <- function(data, slider){
hover_values <- function(x) {
gear = data$gear[data$name == x$name]
paste("gear times slider is:", gear*slider)
}
data %>%
ggvis(~mpg, ~hp, key := ~name) %>%
layer_points() %>%
add_tooltip(hover_values, "hover")
}
ui <- fluidPage(
sliderInput("slider", label = "slider:", min = 1, max = 10, value = 1),
ggvisOutput("plot")
)
server <- function(input, output, session) {
output$plot <- eventReactive(input$slider, {
print("remaking plot...")
make_plot(df, input$slider)
}) %>% bind_shiny("plot")
}
shinyApp(ui = ui, server = server)
You can see that the tooltips are calculated using the slider input, but when you run the app, the tooltips do not change when the slider is changed. Can someone explain what is wrong with my approach or what I need to do to get this working?
MrFlick pointed out that I needed to move where bind_shiny() is used. The corrected code for the server function is:
server <- function(input, output, session) {
output$plot <- eventReactive(input$slider, {
print("remaking plot...")
make_plot(df, input$slider) %>%
bind_shiny("plot")
})
}
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!
I'm trying to get the accessibility module to work with highcharter, but I can't seem to figure out how to do it.
I'm trying to integrate it into a shiny app, so here's a very minimal example of where I'm at so far:
library(highcharter)
library(shiny)
x <- c("a", "b", "c", "d")
y <- c(1:4)
z <- c(4:7)
data <- data.frame(x,y,z)
ui <- fluidPage(
fluidRow(
highchartOutput("chart")
)
)
server <- function(input, output, session){
output$chart <- renderHighchart({
hchart(data, "bubble", hcaes(x = x, y = y, size = z))%>%
hc_add_dependency(name = "modules/accessibility.js")
})
}
shinyApp(ui = ui, server = server)
But it still is not allowing me to tab through the bubbles.
Edit:
I can't fix the tab option yet, I will check. sorry.
Previous answer
This was a error from highcharter and it was fixed in the development version. Update and test with:
source("https://install-github.me/jbkunst/highcharter")
Now the accessibility pluging is included by default and you can configure using the hc_accessibility function with options described in the highcharts API documentation.
I tested using the NVDA.
highchart() %>%
hc_add_series(data = 1:3, type = "column") %>%
hc_accessibility(
enabled = TRUE,
keyboardNavigation = list(enabled = FALSE)
)
I try to create shiny app with
rpivotTable and nvd3 rcharts
all works , but when i try to to show any chart from pivot
i get error
An error occurred rendering the PivotTable results.
But if i use only rpivotTable charts works in pivot and i think that there is problem when using rpivotTable and nvd3 rcharts in one shiny app.
Example
UI
library(shiny)
library(rCharts)
library(rpivotTable)
shinyUI(fluidPage(
showOutput('plot1',lib = "nvd3"),
rpivotTableOutput('pivot1', width = "100%", height = "500px"))
)
Server
library(shiny)
library(rCharts)
library(rpivotTable)
df=data.frame(A=c(1:10),B=c(-10:-1),C=c("x",rep(c("x","y","z"),3)))
shinyServer(function(input, output, session) {
output$pivot1 <- renderRpivotTable({
rpivotTable(data =df ,
width="100%", height="500px")
})
output$plot1=renderChart2({
myform <- as.formula(paste('A','~','B'))
n2 <- nPlot(myform, group ="C", data = df, type = 'multiBarChart')
n2$chart(margin = list(left = 100))
n2$chart(reduceXTicks = F)
n2$set(width = 800, height = 500)
print(n2)
})
})
Give me
If i use only rpivotTable charts in pivot works
When i look at inspect i see
TypeError: a.axisTimeFormat.multi is not a function
at e.i.initParams (c3.min.js:1)
at e.i.init (c3.min.js:1)
at new d (c3.min.js:1)
at Object.k.generate (c3.min.js:1)
at Object.renderer (c3_renderers.coffee:129)
at t.fn.pivot (pivot.coffee:546)
at pivot.coffee:835
Is there way to fix it?
Package versions :
rpivotTable_0.1.5.7
rCharts_0.4.2
shiny_0.12.2.9005
Thanks!
As pointed out in the comments, this is due to the double loading of the n3 libraries. To avoid this issue (this is more of a hack than a fix), you could plot the rcharts frame in an iframe to avoid js and css issues.
To do this, you can use uiOutput/renderUI for the shiny part, and show to output the rCharts.
Here's an example:
library(shiny)
library(rCharts)
library(rpivotTable)
df=data.frame(A=c(1:10),B=c(-10:-1),C=c("x",rep(c("x","y","z"),3)))
ui <-shinyUI(fluidPage(
uiOutput('plot1'),
rpivotTableOutput('pivot1')
))
server <- shinyServer(function(input, output, session) {
output$pivot1 <- renderRpivotTable({
rpivotTable(data =df)
})
output$plot1=renderUI({
myform <- as.formula(paste('A','~','B'))
n2 <- nPlot(myform, group ="C", data = df, type = 'multiBarChart')
n2$chart(margin = list(left = 100))
n2$chart(reduceXTicks = F)
HTML(paste(capture.output(n2$show('iframesrc', cdn = TRUE)), collapse = '\n'))
})
})
shinyApp(ui,server)