Columns in reactable (R package reactable) can be styled with a list of styles, a function or javascript - which works if I want to use one way only. How can these be combined (without rewriting the list, function or javascript code?
Example:
library(reactable)
list_style <- list(background = "#eee")
js_style <- JS("
function(rowInfo) {
return {fontWeight: 'bold' }
}
")
fn_style <- function(value) {
color <- "#008000"
list(color = color)
}
df <- data.frame(x = 1:10, y = 11:20)
reactable(
df,
columns = list(
x = colDef(
style = c(list_style, js_style, fn_style) # This generates the below error
)
)
)
Error:
Error in colDef(style = c(list_style, js_style, fn_style)) :
`style` must be a named list, character string, JS function, or R function
reactable(
df,
columns = list(
x = colDef(
style = list(list_style, js_style, fn_style)
)
)
)
it seems that your style out of list, please replace those code with this reactable
Related
I have some data I'm trying to present using reactable. I am styling the background of cells based on the value. There are a number of groups in the data which are useful, but the groups themselves do not have an aggregated value that is useful.
The issue I'm facing is that when the data is grouped with the custom grouping select, the table will retain the style of the first few rows of data so the background is coloured. I would like it to be blank for the grouped row.
In the example below, when grouping by group you'll notice that A and C have the background coloured, inheriting the style from rows 1 and 3 in the data. I could imagine a hacky way of organizing the data so only non-stylized rows come first, but that is not really appropriate as the data would be too disorganized at initial presentation.
Is there a way to strip the style when grouped, but retain it for the rows with values?
library(reactable)
library(htmltools)
set.seed(1)
data <- data.frame(
group = rep(c("A", "B", "C"), each = 5),
value = rnorm(15)
)
htmltools::browsable(
tagList(
div(tags$label("Group by", `for` = "tab")),
tags$select(
id = "tab",
onchange = "Reactable.setGroupBy('tab', this.value ? [this.value] : [])",
tags$option("None", value = ""),
tags$option("Group", value = "group"),
),
reactable(
data,
columns = list(
value = colDef(style = function(value){
if (value < 0) list(background = "#ffa500")
})
),
defaultPageSize = 15,
elementId = "tab"
)
)
)
I found a way using JavaScript. I've changed the variable value to num in the example below so it's more clear how to apply the function.
The grouping is done via JavaScript in the browser, so there isn't a way to control group styling in R as far as I'm aware.
library(reactable)
library(htmltools)
set.seed(1)
data <- data.frame(
group = rep(c("A","B","C"), each = 5),
num = rnorm(15)
)
htmltools::browsable(
tagList(
div(tags$label("Group by", `for` = "tab")),
tags$select(
id = "tab",
onchange = "Reactable.setGroupBy('tab', this.value ? [this.value] : [])",
tags$option("None", value = ""),
tags$option("Group", value = "group"),
),
reactable(
data,
columns = list(
num = colDef(style = JS("function(rowInfo) {
var value = rowInfo.row['num']
if (value < 0) {
var background = '#ffa500'
}
return {background: background}
}"))
),
defaultPageSize = 15,
elementId = "tab"
)
)
)
I am trying to create a function for DT table where just specifying the columns name in the parameter, the column should get hidden
dt_table <- function(data,
colhidden = c(a)){
datatable(data,
options = list(
columnDefs = list(
list(visible=FALSE, targets=colhidden)
)
))
}
dt_table(iris,colhidden = c('Species'))
But unfortunately, the column is not getting hidden. Can anyone help me?
targets needs the column number which you can get with match. Try -
library(DT)
dt_table <- function(data, colhidden) {
datatable(data,
options = list(
columnDefs = list(
list(visible=FALSE, targets=match(colhidden, colnames(data))))
)
)
}
dt_table(iris,colhidden = c('Species'))
dt_table(iris,colhidden = c('Species', 'Sepal.Length'))
I would like to create a gt table where I display numeric values from two columns together in a single cell, but color the cells based on just one of the column's values.
For example using the ToothGrowth example data I'd like to put the len and dose columns together in a single cell but color the cell backgrounds by the value of dose.
I tried to manually create a vector of colors to color the len_dose column but this does not work because it seems like it is reapplying the color vector to each different level of len_dose, not dose. I guess you could manually format the cells with tab_style() but that seems inefficient and does not give you the nice feature where the text color changes to maximize contrast with background. I don't know an efficient way to do this.
What I tried:
library(gt)
library(dplyr)
library(scales)
library(glue)
# Manually map dose to color
dose_colors <- col_numeric(palette = 'Reds', domain = range(ToothGrowth$dose))(ToothGrowth$dose)
ToothGrowth %>%
mutate(len_dose = glue('{len}: ({dose})')) %>%
gt(rowname_col = 'supp') %>%
cols_hide(c(len, dose)) %>%
data_color(len_dose, colors = dose_colors)
Output (not good because not colored by dose):
Not sure if you found a solution to this yet but here is what I did:
If you use tab_style() you don't need to try and create the vector of colors and can instead set the background color you want based on the dose column. If you want to color values differently based on dose, in addition to what I've colored here, then create another tab_style() for the desired value.
library(gt)
library(dplyr)
library(scales)
library(glue)
ToothGrowth %>%
mutate(len_dose = glue('{len}: ({dose})')) %>%
gt(rowname_col = 'supp') %>%
tab_style(
style = cell_fill(color = "palegreen"),
location = cells_body(
columns = len_dose,
rows = dose >= 1.0
)
) %>%
cols_hide(c(len, dose))
I faced the same issue and adjusted the gt::data_color function to accept separate source and target columns - with that, the following should work to produce your desired output.
# Distinguish SOURCE_columns and TARGET_columns
my_data_color <- function (data, SOURCE_columns, TARGET_columns, colors, alpha = NULL, apply_to = c("fill",
"text"), autocolor_text = TRUE)
{
stop_if_not_gt(data = data)
apply_to <- match.arg(apply_to)
colors <- rlang::enquo(colors)
data_tbl <- dt_data_get(data = data)
colors <- rlang::eval_tidy(colors, data_tbl)
resolved_source_columns <- resolve_cols_c(expr = {
{
SOURCE_columns
}
}, data = data)
resolved_target_columns <- resolve_cols_c(expr = {
{
TARGET_columns
}
}, data = data)
rows <- seq_len(nrow(data_tbl))
data_color_styles_tbl <- dplyr::tibble(locname = character(0),
grpname = character(0), colname = character(0), locnum = numeric(0),
rownum = integer(0), colnum = integer(0), styles = list())
for (i in seq_along(resolved_source_columns)) {
data_vals <- data_tbl[[resolved_source_columns[i]]][rows]
if (inherits(colors, "character")) {
if (is.numeric(data_vals)) {
color_fn <- scales::col_numeric(palette = colors,
domain = data_vals, alpha = TRUE)
}
else if (is.character(data_vals) || is.factor(data_vals)) {
if (length(colors) > 1) {
nlvl <- if (is.factor(data_vals)) {
nlevels(data_vals)
}
else {
nlevels(factor(data_vals))
}
if (length(colors) > nlvl) {
colors <- colors[seq_len(nlvl)]
}
}
color_fn <- scales::col_factor(palette = colors,
domain = data_vals, alpha = TRUE)
}
else {
cli::cli_abort("Don't know how to map colors to a column of class {class(data_vals)[1]}.")
}
}
else if (inherits(colors, "function")) {
color_fn <- colors
}
else {
cli::cli_abort("The `colors` arg must be either a character vector of colors or a function.")
}
color_fn <- rlang::eval_tidy(color_fn, data_tbl)
color_vals <- color_fn(data_vals)
color_vals <- html_color(colors = color_vals, alpha = alpha)
color_styles <- switch(apply_to, fill = lapply(color_vals,
FUN = function(x) cell_fill(color = x)), text = lapply(color_vals,
FUN = function(x) cell_text(color = x)))
data_color_styles_tbl <- dplyr::bind_rows(data_color_styles_tbl,
generate_data_color_styles_tbl(column = resolved_target_columns[i], rows = rows,
color_styles = color_styles))
if (apply_to == "fill" && autocolor_text) {
color_vals <- ideal_fgnd_color(bgnd_color = color_vals)
color_styles <- lapply(color_vals, FUN = function(x) cell_text(color = x))
data_color_styles_tbl <- dplyr::bind_rows(data_color_styles_tbl,
generate_data_color_styles_tbl(column = resolved_target_columns[i],
rows = rows, color_styles = color_styles))
}
}
dt_styles_set(data = data, styles = dplyr::bind_rows(dt_styles_get(data = data),
data_color_styles_tbl))
}
# Add function into gt namespace (so that internal gt functions can be called)
library(gt)
tmpfun <- get("data_color", envir = asNamespace("gt"))
environment(my_data_color) <- environment(tmpfun)
library(dplyr)
#>
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#>
#> filter, lag
#> The following objects are masked from 'package:base':
#>
#> intersect, setdiff, setequal, union
library(glue)
# Map dose to color
ToothGrowth %>%
mutate(len_dose = glue('{len}: ({dose})')) %>%
gt(rowname_col = 'supp') %>%
cols_hide(c(len, dose)) %>%
my_data_color(SOURCE_columns = "dose", TARGET_columns = "len_dose",
colors = scales::col_numeric(palette = c("red", "green"), domain = c(min(ToothGrowth$dose), max(ToothGrowth$dose))))
Created on 2022-11-03 with reprex v2.0.2
Most of the included code serves reproducibility,my question is regarding the export of results from an imap() function.
I have written some functions that aggregate and summarize my data, as below. It creates a list, with multiple lists - one list for every gears.
splitCars <- split(mtcars, mtcars$cyl)
summarizeMtcarsYearly <- function(x)
{
#Ngears
v1 <- length(unique(x$gear))
v2 <- paste0(unique(levels(as.factor(x$gear))),collapse = ', ')
#Build data
y <- data.frame(Ngears=v1,gears=v2,stringsAsFactors = F)
return(y)
}
summarizeMtcars <-function(){
splitCars <- split(mtcars, mtcars$cyl)
splitCars <- lapply(splitCars,summarizeMtcarsYearly)
}
splitCars <- summarizeMtcars()
for every gear in the list, i want to create the summary table. I have also written a function for this (below). The details are not important, this is just for reproducibility. The important part of this function is where I export the table to a results folder - last 5 lines.
createSummaryTable <- function(x, y){
tab <- plot_ly(
type = 'table',
header = list(
values = c(paste0("Gears = "), y, ""),
align = c('left', rep('center')),
line = list(width = 1, color = 'black'),
fill = list(color = 'rgb(235, 100, 230)'),
font = list(family = "Arial", size = 14, color = "white")
),
cells = list(
values = rbind(c('number of gears', 'list of gears'),
c(x$Ngears, x$gears)),
align = c('left', rep('center')),
line = list(color = "black", width = 1),
fill = list(color = c('rgb(235, 193, 238)', 'rgba(228, 222, 249, 0.65)')),
font = list(family = "Arial", size = 12, color = c("black"))
))
test_dir <- "/Users/testFolder"
tab <- plotly_json(tab, FALSE)
tabName <- paste0("summaryVariables_gear_TEST", y, ".json" )
write(tab, paste0(test_dir, "/", tabName))
}
I pretend not to know how many gears my data will have i am then using imap() function to apply a createSummaryTable to every element of the list, and exported it directly to a predefined folder:
splitCars <- summarizeMtcars()
imap(splitCars, function(x, y) createSummaryTable(x,y))
which was working exactly the way i wanted to have it. However, now, i need to return all the tables for every single gear inside a list, something like this:
createSummaryTable <- function(x, y){
tab <- ... # this is the same as before
tabname <- paste0("summary_", y)
assign(tabname, tab)
}
analysis.summaryTables <- function(){
# create tables
splitCars <- summarizeMtcars()
imap(splitCars, function(x, y) createSummaryTable(x,y))
# append all tables to one list
tables <- ls(patter = "summary_")
out <- do.call(c,list(tables))
}
however when i run this
summaryTables <- analysis.summaryTables()
summaryTable is just an empty character string.
How can i store all the output from imap() in a single list in R ??
how can i access the elements from the function createSummaryTable environment and append them together in R?
If I understood correctly, you have a function createSummaryTable that creates an object, a table to be specific.
You have a list of named dataframe and you want to map this list into your function to return a list of objects (a list of tables to be specific) where their names will be the same but "summary_" has to appear before.
Therefore:
createSummaryTable <- function(x, y){
# do something here
return(tbl)
}
# map your list
out <- purrr::imap(list_of_named_dataframes, createSummaryTable)
names(out) <- paste("summary", names(out), sep = "_")
and out is what you're looking for.
My problem is that I have a given data frame and I have to search for different patterns. When the pattern matches the given character vector the content of the same row, but of a different column should update a textInput.
I created a little shiny app as an example, because my original code is too big. The example works, but I'm using for loops and I don't want to do this. Do anyone know a better solution? Is there a solution with a vectorised function? I really would appreciate if someone knows a dplyr solution.
Example:
library(shiny)
ui <- fluidPage(
textInput(inputId="wave1", label="wavelength"),
textInput(inputId="wave2", label="wavelength")
)
server <- name <- function(input,output,session) {
df <- data.frame("color" = c("red","blue","green"), "wavelength" = c("700 nm","460 nm","520 nm"))
for (i in 1:nrow(df)) {
if(grepl("lue",df$color[i],fixed=TRUE) == TRUE){updateTextInput(session, inputId="wave1", label = NULL, value = df$wavelength[i],placeholder = NULL)}
}
for (i in 1:nrow(df)) {
if(grepl("ee",df$color[i],fixed=TRUE) == TRUE){updateTextInput(session, inputId="wave2", label = NULL, value = df$wavelength[i],placeholder = NULL)}
}
}
shinyApp(ui = ui, server = server)
Any help would be appreciated.
Instead of looping, you can index the dataframe directly from the result of grep:
server <- name <- function(input,output,session) {
df <- data.frame("color" = c("red","blue","green"), "wavelength" = c("700 nm","460 nm","520 nm"))
updateTextInput(session, inputId="wave1", label = NULL,
value = df$wavelength[grep("lue", df$color, fixed=TRUE)],
placeholder = NULL)
updateTextInput(session, inputId="wave2", label = NULL,
value = df$wavelength[grep("ee", df$color, fixed=TRUE)],
placeholder = NULL)
}
And one way to do this using dplyr is:
server <- name <- function(input,output,session) {
df <- data.frame("color" = c("red","blue","green"), "wavelength" = c("700 nm","460 nm","520 nm"))
updateTextInput(session, inputId="wave1", label = NULL,
value = dplyr::filter(df, grepl("lue", color, fixed=TRUE)) %>% dplyr::pull(wavelength),
placeholder = NULL)
updateTextInput(session, inputId="wave2", label = NULL,
value = dplyr::filter(df, grepl("ee", color, fixed=TRUE)) %>% dplyr::pull(wavelength),
placeholder = NULL)
}