Related
I am trying to insert additional information into a reactable in R - one which has about 3600 rows. I've tried nesting a plot under each row (similar to this, but with nested plots instead of sub-tables). The only way I could make this work was to use plotly within reactable, like so:
library(reactable)
library(magrittr)
library(plotly)
my_diamonds <- diamonds
my_diamonds$cats <- cut(my_diamonds$price, 850)
my_diamonds <- my_diamonds[ order(my_diamonds$cut, my_diamonds$cats), ]
data <- unique(my_diamonds[, c("cut", "cats")])
reactable(data,
details = function(index) {
diam_data <- my_diamonds[my_diamonds$cut == data$cut[index] & my_diamonds$cats == data$cats[index], ]
plot_ly(diam_data,
x = ~1:nrow(diam_data),
y = ~y,
type = 'scatter',
mode = 'lines') # %>% toWebGL()
}
)
But sadly, for this amount of data, this takes forever to output the table, and anything I've tried to make it faster (such as toWebGL()) changes nothing. All I really care about is the speed, and having some sort of visualisation associated with each row - I don't particularly care if it's plotly or something else.
A second option would be to use an in-line HTML widget for each row (shown here). In my example, this could be done if adding:
data_parcels <- split(my_diamonds, list(my_diamonds$cats, my_diamonds$cut), drop = T)
data$nested_points <- sapply(data_parcels, '[[', 'y')
data$sparkline <- NA
library(sparkline)
reactable(data,
columns = list(
sparkline = colDef(cell = function(value, index) {
sparkline(data$nested_points[[index]])
})
))
This isn't quite as slow as the plotly option, but still very slow in the larger scheme of things. Any ideas on how to speed up either example, anyone?
PaulM and I have worked on a solution together, and managed to speed up one of the options: the one involving in-line sparklines. As it turned out based on some profiling work, what was making the process particularly slow wasn't drawing the sparklines in itself, rather the subsequent work of translating them from R so that they could be incorporated into the HTML reactable table.
So to bypass that slow translation process entirely, we wrote a code template that would get wrapped around the data points to be plotted. This is what we then served directly to reactable, alongside an html = TRUE argument, for the code to be interpreted as such, rather than as regular text.
The final hurdle after that was to ensure that the sparklines (one per row) were still on display even if a user sorted a column or navigated to a different page of results - normally the sparklines would disappear on interacting with the table in this way. For this, we ensured that that the reactable would be redrawn 10ms after any click.
Here is an example wrapped in shiny that shows all this in action, alongside the old (slow) version. For me, the sped up version renders in about 0.5s roughly, whereas the old one - about 13s.
library(reactable)
library(magrittr)
library(plotly)
library(sparkline)
library(shiny)
library(shinycssloaders)
library(shinyWidgets)
if (interactive()) {
# Init objects
t0 <- NULL
t1 <- NULL
my_diamonds <- diamonds
my_diamonds$cats <- cut(my_diamonds$price, 850)
my_diamonds <- my_diamonds[ order(my_diamonds$cut, my_diamonds$cats), ]
data <- unique(my_diamonds[, c("cut", "cats")])
data_parcels <- split(my_diamonds, list(my_diamonds$cats, my_diamonds$cut), drop = T)
data$nested_points <- sapply(data_parcels, '[[', 'y')
data$sparkline <- NA
ui <- shinyUI(
basicPage(
br(),
radioGroupButtons(
inputId = "speedChoice",
label = "Speed",
choices = c("Fast", "Slow"),
status = "danger"
),
br(),
verbatimTextOutput("timeElapsed"),
br(),
shinycssloaders::withSpinner(
reactableOutput("diamonds_table")
),
# Small JS script to re-render a reactable table so that the sparklines show
# after the user has modified the table (sorted a col or navigated to a given page of results)
tags$script('document.getElementById("diamonds_table").addEventListener("click", function(event){
setTimeout(function(){
console.log("rerender")
HTMLWidgets.staticRender()
}, 10);
})
')
)
)
server <- function(input, output, session) {
output$diamonds_table <- renderReactable({
if (input$speedChoice == "Fast") {
t0 <<- Sys.time()
part1 <- '<span id="htmlwidget-spark-' # + ID
part2 <- '" class="sparkline html-widget"></span><script type="application/json" data-for="htmlwidget-spark-' # + ID
part3 <- '">{"x":{"values":[' # + values
part4 <- '],"options":{"height":20,"width":60},"width":60,"height":20},"evals":[],"jsHooks":[]}</script>'
out <- list(length = nrow(data))
for (i in 1:nrow(data)) {
vals <- paste0(data$nested_points[[i]], collapse = ',')
out[[i]] <- paste0(part1, i, part2, i, part3, vals, part4)
}
data$sparkline <- out
tab <- reactable(data,
columns = list(
sparkline = colDef(html = TRUE,
cell = function(value, index) {
return(htmltools::HTML(value))
}
)
)
) %>%
spk_add_deps() %>%
htmlwidgets::onRender(jsCode = "
function(el, x) {
HTMLWidgets.staticRender();
console.log('render happening')
}")
t1 <<- Sys.time()
return(tab)
} else {
# Classic, but slow version:
t0 <<- Sys.time()
tab <- reactable(data,
columns = list(
sparkline = colDef(cell = function(value, index) {
data$nested_points[[index]] %>%
sparkline::sparkline()
}
)
)
)
t1 <<- Sys.time()
return(tab)
}
})
output$timeElapsed <- renderText({
input$speedChoice # Connect to reactable update cycle
return(t1 - t0)
})
}
shinyApp(ui = ui, server = server)
}
I'm making a Shiny app in which the user can generate a column in a table by clicking on a checkboxInput. The column I would like to create contains the lagged value of the column already present in the table.
The code below shows a reproducible example: there are two individuals (A and B) and three time periods (1, 2 and 3).
library(dplyr)
library(shiny)
data <- head(mtcars)
data$time <- rep(seq(1:3))
data$ID <- rep(c("A", "B"), each = 3)
ui <- fluidPage(
selectInput("choice", "Select a column", choices = c("mpg", "drat", "hp"), multiple = F),
checkboxInput("lag", "Compute lag value"),
tableOutput("table")
)
server <- function(input, output, session) {
data2 <- reactive({
lagged_name <- paste0(input$choice, "_lagged")
if (input$lag){
data %>%
select(ID, time, input$choice) %>%
group_by(ID) %>%
mutate(!!all_of(lagged_name) := lag(data[, input$choice]))
}
else {
data %>%
select(ID, time, input$choice)
}
})
output$table <- renderTable({
data2()
})
}
shinyApp(ui, server)
When I run this code and click on the checkbox, I have the error:
Warning: Error in : Column mpg_lagged must be length 3 (the group size) or one, not 6
Thanks to this answer, I corrected it by adding order_by = ID in the lag function but now there is another problem: for individual 1, it creates the right lagged values, but then those values are repeated for individual 2 as well whereas they do not correspond.
I tried a similar example without the Shiny environment and the right output is produced so I suppose this problem comes from the inputs or reactive environment.
Does anybody have a solution?
There are some (minor) issues with non-standard evaluation (NSE) inside your reactive data object. Fixing these gives
library(dplyr)
library(shiny)
data <- head(mtcars)
data$time <- rep(seq(1:3))
data$ID <- rep(c("A", "B"), each = 3)
ui <- fluidPage(
selectInput("choice", "Select a column", choices = c("mpg", "drat", "hp"), multiple = F),
checkboxInput("lag", "Compute lag value"),
tableOutput("table")
)
server <- function(input, output, session) {
data2 <- reactive({
lagged_name <- paste0(input$choice, "_lagged")
if (input$lag){
data %>%
select(ID, time, input$choice) %>%
group_by(ID) %>%
mutate(!!lagged_name := lag(!!sym(input$choice)))
}
else {
data %>%
select(ID, time, input$choice)
}
})
output$table <- renderTable({
data2()
})
}
shinyApp(ui, server)
resulting in
Explanation:
select takes both evaluated symbols and strings as arguments, so we can directly pass input$choice as an argument to select.
To construct a new column with a name from a variable we need to evaluate the variable as !!lagged_name; we then must use := (instead of =) to do the assignment, as R's grammar does not allow expressions as argument names (the lhs of the assignment). Finally, inside the lag function we first must convert input$choice to a symbol with sym and then evaluate the symbol with !!. That's because of dplyr's NSE, where you would write e.g. mtcars %>% mutate(col = lag(wt)) and not mtcars %>% mutate(col = lag("wt")).
I'm aware of https://plot.ly/r/shinyapp-plotly-events/ and have been using it as a guide. But the ggplot element I'm converting to plotly is the output from the fviz_dend function of the factoextra package. Here's a minimum shiny app example I'm working with:
library(factoextra)
library(plotly)
library(shiny)
library(DT)
ui <- fluidPage(
plotlyOutput("ggp"),
verbatimTextOutput("selected_points"),
DT::dataTableOutput("filtered_table")
)
server <- function(input, output, session) {
## ggplot output
fviz <- fviz_dend(
x = hclust(dist(mtcars)),
k = 5,
show_labels = TRUE,
type = "phylogenic",
phylo_layout = "layout_as_tree",
color_labels_by_k = TRUE,
palette = "igv"
)
## convert to ggplotly
ggfviz <- ggplotly(fviz)
## add keys
for (i in seq(7, 11)) {
ggfviz[["x"]][["data"]][[i-5]][["key"]] <-
as.character(ggfviz[["x"]][["data"]][[i]][["text"]])
}
output$ggp <- renderPlotly({
ggfviz
})
output$selected_points <- renderPrint({
event_data("plotly_selected")[5]
})
output$filtered_table <- DT::renderDataTable(
mtcars[which(rownames(mtcars) == event_data("plotly_selected")[5]), ],
)
}
shinyApp(ui, server)
So I'm trying to use the key accessed with event_data("plotly_selected")[5] in order to filter the data table, and while event_data("plotly_selected")[5] does show the key per output$selected_points, it is somehow not passed to the datatable filter.
It looks like event_data will return a data frame with multiple rows. Instead of filtering with == you will need %in% instead to see which multiple cars are contained within the multiple possible selections from plotly_selected. In addition, even though you subset by column 5, you still have a data frame, and need to include the column key only for filtering (containing a vector of cars). This should work:
mtcars[which(rownames(mtcars) %in% event_data("plotly_selected")$key), ]
Or
mtcars[which(rownames(mtcars) %in% event_data("plotly_selected")[["key"]]), ]
PROBLEM SYNOPSIS: I have a shiny app I am building where I am trying to support database calls that drive dynamic lists of choices for selectInputs and where that dynamic input drives what a ggvis plot shows. The dynamic selectInput is not correctly selected and filtering the ggvis plot
QUESTION: How can I support dynamic drop down lists while still ensuring my ggvis plot filters based on the chosen item?
PROBLEM DETAIL:
Within my Server.R file I have a reactive that grabs a slice of data from the database. The get_chunk function is a call to NEO4J that I know works:
shinyServer( function(input, output, session) {
CURRENT_CHUNK <- reactive({
#call NEO4J
chunk <- get_chunk(some_list = input$chunk)
return(chunk)
})
I also have a reactive that simply filters down the data based on the ui choices on the front end. The input$A value is the chosen value from a dynamically built dropdown list. The filter_reactive is below. NOTE: I've separated these two so I don't have to call the database all the time; only when I choose a different CHUNK. The filter reactive looks like the following:
NO_DB_REACTIVE <- reactive({
#react to current_chunk and pull back a chunk.
filter_down <- CURRENT_CHUNK()
#check for nulls
if (!is.null(chunk)) {
if (input$A != "All") {filter_down <- filter_down %>% filter(A == input$A)}
return(filter_down)
}
return(filter_down)
})
The input$A value is generated dynamically as follows within the server.R file:
# reactively /dynamically generated the choices for the channel owners
output$owner_choices <- renderUI({ selectInput("A", "FOR Owner"
, as.list(c("All",unique(CURRENT_CHUNK()[,'owner'] )))
, "All") })
I also have a reactive that generates my GGVIS plot that looks like the following:
#All of the visualizations
MY_VIS <- reactive({
# Lables for axes
yvar_name <- names(display_choices)[display_choices == input$yvar]
xvar_name <- names(cat_choices)[cat_choices == input$xvar]
#retrieving
yvar <- prop("y", as.symbol(input$yvar))
xvar <- prop("x", as.symbol(input$xvar))
CURRENT_CHUNK %>%
ggvis(x = xvar, y = yvar) %>%
layer_bars() %>%
add_axis("x", title = xvar_name, properties = axis_props(labels = list(angle = 45, align = "left", fontSize = 10))) %>%
add_axis("y", title = yvar_name) %>%
set_options(width = 900, height = 300)
})
I tried to slim this down as much as possible. There is some dynamic choosing of axes there but you get the point. Notice I currently call CURRENT CHUNK within the MY_VIS reactive. And the end of the file has these:
output$table <- renderDataTable({ NO_DB_REACTIVE() })
MY_VIS %>% bind_shiny("my_vis")
When I filter items this way I get no errors. My table filters on input$A changes and the vis does not; I want the vis to change based on what input$A is as well.
I originally tried having MY_VIS depend on NO_DB_REACTIVE. This fails as input$A is never generated. I guess because CURRENT_CHUNK never runs as it doesn't have to. Notice the output$owner_choices is generated by reacting to CURRENT_CHUNK() not NO_DB_REACTIVE().
KEY QUESTION: How can I set this up so my input$A value is available when I want to filter my ggvis plot?
I'm trying to use a slider to control year in a longitudinal spatial data set, essentially a set of scatter plots. I can't figure out how to assign the slider to this variable - can you do this in ggvis?
A simplified data set:
data <- data.frame(year=rep(2000:2002, each=23),
x=rnorm(23*3,10), y=rnorm(23*3,10),
count=c(rnorm(23,2), rnorm(23,4), rnorm(23,6)))
What I've tried:
### This is what is looks like in ggplot2, I'm aiming to be able to toggle
### between these panels
ggplot(data, aes(x, y, size=count)) + geom_point() + facet_grid(~year)
### Here is where I'm at with ggvis
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points()
# I'm not sure how to assign a variable (year) to a slider, I've been trying
# within the layer_points() function
### I also tried using the props() function, but I don't fully understand
### how to use it.
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points() %>%
props(prop("fill", input_slider(min(data$year), max(data$year)))) #error message
Any help is appreciated!
I'm not sure if you want to use the slider to filter the data points (i.e. only show those points from the year selected on the slider), or to show the years in different colors according to the slider's value.
Case 1 (only display the points from a specific year)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity=input_slider(min(data$year), max(data$year), step=1,
map=function(x) ifelse(data$year == x, 1, 0)))
Case 2 (highlight the selected years)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(fill=input_slider(min(data$year), max(data$year), step=1,
map=function(x) factor(x == data$year)))
EDIT2: How to simply wrap a left_right() function.
In the first edit I presented a solution that is not properly considered as wrapping.
I was interested in creating a wrapper of the reactive object returned by left_right(), avoiding modifying create_keyboard_event all together.
After reading the source code of ggvis more thoroughly and more on S4 objects in R,
I realized that yes, you can simply wrap a reactive object, as long as you preserve the broker class and its broker attribute appropriately.
This allows us to write more elegant code, like:
year_lr <- left_right(1997, 2002, value=2000, step=1)
year_wrapper <- reactive({
as.numeric(year_lr() == data$year)
})
class(year_wrapper) <- c("broker", class(year_wrapper))
attr(year_wrapper, "broker") <- attr(year_lr, "broker")
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity:=year_wrapper)
EDIT: How to create your own (modified) left_right() function
user3389288 asked me a good question, that since you don't have a map argument for left_right() function, how can you actually bind keyboard event to generate custom parameters. For example, in the context of this question, how can we tailor left_right() as a year filter?
If you dig into the source code of ggvis, you can see that left_right() is simply a thin wrapper function calling create_keyboard_event.
Hence we can create our own version of left_right(), or even h_j_k_l() say if you are fanatic about Vi.
But, here is a big but, if you dig one layer further to look at the implementation of create_keyboard_event, you will find that it is not quite suitable for our task.
This is because in order to show some of the dots, while hide others, we have to let left_right return a vector (that equals to the number of rows in data).
However, both left_right and create_keyboard_event are created with the assumption that the returned value (which is also the current state of the value modified by Left/Right key presses) is a scalar.
In order to separate the return value (vector) from the cached current state (scalar, i.e. the year), we have to create a slightly modified version of left_right() and create_keyboard_event.
Below is the source code that would work.
data <- data.frame(year=rep(1997:2002, each=12),
x=rnorm(24*3,10), y=rnorm(24*3,10),
count=c(rnorm(24,2), rnorm(24,4), rnorm(24,6)))
create_keyboard_event2 <- function(map, default.x = NULL, default.res = NULL) {
# A different version of ggvis::create_keyboard_event function:
# the major different is that the map function returns a list,
# list$x is the current value and list$res the result (returned to a ggvis prop).
# this seperation allows us to return a vector of different
# values instead of a single scalar variable.
if (!is.function(map)) stop("map must be a function")
vals <- shiny::reactiveValues()
vals$x <- default.x
vals$res <- default.res
# A reactive to wrap the reactive value
res <- reactive({
vals$res
})
# This function is run at render time.
connect <- function(session, plot_id) {
key_press_id <- paste0(plot_id, "_key_press")
shiny::observe({
key_press <- session$input[[key_press_id]]
if (!is.null(key_press)) {
# Get the current value of the reactive, without taking a dependency
current_value <- shiny::isolate(vals$x)
updated <- map(key_press, current_value)
vals$x <- updated$x
vals$res <- updated$res
}
})
}
ggvis:::connector_label(connect) <- "key_press"
spec <- list(type = "keyboard")
ggvis:::create_broker(res, connect = connect, spec = spec)
}
# a modified version of left_right. this closure encapsulates the
# data "year", allowing us to perform comparison of the current state of
# left_right (numeric year number) to the year vector.
left_right_year <- function(min, max, value = (min + max) / 2,
step = (max - min) / 40, year) {
# Given the key_press object and current value, return the next value
map <- function(key_press, current_value) {
key <- key_press$value
print(current_value)
if (key == "left") {
new_value <- pmax(min, current_value - step)
} else if (key == "right") {
new_value <- pmin(max, current_value + step)
} else {
new_value = current_value
}
list(x=new_value, res=as.numeric(year == new_value))
}
create_keyboard_event2(map, value, as.numeric(value==year))
}
# now with an additional argument, the data$year
alpha_by_year <- left_right_year(1997, 2002, value=2000, step=1, data$year)
data %>%
ggvis(~x, ~y, size=~count) %>%
layer_points(opacity:=alpha_by_year) # if you let left_right_year return
# a factor vector, you can use fill:=... as well
You can compare left_right_year and create_keyboard_event2 with their vanilla version counterparts.
For example, the original create_keyboard_event is:
create_keyboard_event <- function(map, default = NULL) {
if (!is.function(map)) stop("map must be a function")
vals <- shiny::reactiveValues()
vals$x <- default
# A reactive to wrap the reactive value
res <- reactive({
vals$x
})
# This function is run at render time.
connect <- function(session, plot_id) {
key_press_id <- paste0(plot_id, "_key_press")
shiny::observe({
key_press <- session$input[[key_press_id]]
if (!is.null(key_press)) {
# Get the current value of the reactive, without taking a dependency
current_value <- shiny::isolate(vals$x)
vals$x <- map(key_press, current_value)
}
})
}
connector_label(connect) <- "key_press"
spec <- list(type = "keyboard")
create_broker(res, connect = connect, spec = spec)
}
You can see that our modified version will not only cache the current state vals$x, but also the return vector vals$res.
The variable vals is a reactive value. The concept is borrowed from Shiny. You can check out this document about a high-level overview of reactive values and reactivity in general.
A question yet to be answered
Since vals$x is itself a reactive value. Intuitively, if
x <- left_right(1, 100, value=20, step=10)
then
y <- reactive(x() * 2)
should allow us to implement a quick map function.
However it doesn't work as expected. I am yet to figure out why exactly. If you know the answer, please kindly let me know!
UPDATED: c.f. EDIT2
The answers above are great. Definitively worth study. This is what I came up with for the original question for a quick fix.
Global.R:
library(shiny)
library(ggvis)
data<-data.frame(year=rep(2000:2002, each=23), x=rnorm(23*3,10), y=rnorm(23*3,10),
count=c(rnorm(23,2),rnorm(23,4),rnorm(23,6)))
ui.R:
shinyUI(bootstrapPage(
h3("Ploting Diferent Years Using a Slider",align="center"),
br(),
fluidRow(column(4,ggvisOutput("yearPlot"),offset=3)),
fluidRow(column(3,sliderInput("YearSelect", "Year: ",min=2000,max=2002,step=1,value=2000),offset=5))
))
Server.R:
shinyServer(function(input, output,session) {
plotdata <- reactive({
chosendat <- data[data$year==input$YearSelect, ]
names(chosendat) <- c("year","xvar","yvar","count")
return(chosendat)
})
vis1% ggvis(~xvar, ~yvar, size=~count) %>% layer_points()
})
vis1 %>% bind_shiny("yearPlot")
})