library(shiny)
library(reactable)
prismCodeBlock <- function(code, language = "r") {
# Generate a pre-code tag without indentation
html <- as.character(tags$code(class = paste0("language-", language), code))
html <- sprintf("<pre>%s</pre>", html)
tagList(
HTML(html),
tags$script("Prism.highlightAll()")
)
}
prismDependencies <- tags$head(
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.16.0/prism.min.js"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.16.0/components/prism-r.min.js"),
tags$link(rel = "stylesheet", type = "text/css",
href = "https://cdnjs.cloudflare.com/ajax/libs/prism/1.16.0/themes/prism.min.css")
)
themes <- list(
"Light 1" = quote(reactableTheme(
borderColor = "#dfe2e5",
stripedColor = "#f6f8fa",
highlightColor = "#f0f5f9",
cellPadding = "8px 12px"
)),
"Dark 1" = quote(reactableTheme(
color = "hsl(0, 0%, 87%)",
backgroundColor = "hsl(220, 13%, 18%)",
borderColor = "hsl(0, 0%, 22%)",
stripedColor = "rgba(255, 255, 255, 0.04)",
highlightColor = "rgba(255, 255, 255, 0.06)",
inputStyle = list(backgroundColor = "hsl(0, 0%, 24%)"),
selectStyle = list(backgroundColor = "hsl(0, 0%, 24%)"),
pageButtonHoverStyle = list(backgroundColor = "hsl(0, 0%, 24%)"),
pageButtonActiveStyle = list(backgroundColor = "hsl(0, 0%, 28%)")
)),
"Dark 2" = quote(reactableTheme(
color = "hsl(233, 9%, 87%)",
backgroundColor = "hsl(233, 9%, 19%)",
borderColor = "hsl(233, 9%, 22%)",
stripedColor = "hsl(233, 12%, 22%)",
highlightColor = "hsl(233, 12%, 24%)",
inputStyle = list(backgroundColor = "hsl(233, 9%, 25%)"),
selectStyle = list(backgroundColor = "hsl(233, 9%, 25%)"),
pageButtonHoverStyle = list(backgroundColor = "hsl(233, 9%, 25%)"),
pageButtonActiveStyle = list(backgroundColor = "hsl(233, 9%, 28%)")
)),
"Dark 3" = quote(reactableTheme(
color = "hsl(0, 0%, 90%)",
backgroundColor = "hsl(0, 0%, 10%)",
borderColor = "hsl(0, 0%, 18%)",
stripedColor = "hsl(0, 0%, 13%)",
headerStyle = list(
"&:hover[aria-sort]" = list(backgroundColor = "hsl(0, 0%, 14%)")
),
tableBodyStyle = list(color = "hsl(0, 0%, 75%)"),
rowHighlightStyle = list(color = "hsl(0, 0%, 90%)", backgroundColor = "hsl(0, 0%, 14%)"),
selectStyle = list(backgroundColor = "hsl(0, 0%, 20%)"),
inputStyle = list(
backgroundColor = "hsl(0, 0%, 10%)",
borderColor = "hsl(0, 0%, 21%)",
"&:hover, &:focus" = list(borderColor = "hsl(0, 0%, 30%)")
),
pageButtonHoverStyle = list(backgroundColor = "hsl(0, 0%, 20%)"),
pageButtonActiveStyle = list(backgroundColor = "hsl(0, 0%, 24%)")
))
)
ui <- fluidPage(
tags$head(
tags$title("reactable demo"),
includeCSS("assets/styles.css"),
prismDependencies
),
div(class = "main",
div(class = "sidebar",
h1("reactable demo", class = "title"),
checkboxGroupInput(
"options",
"Table Options",
choices = c(
"Column groups" = "columnGroups",
"Footer" = "footer",
Filterable = "filterable",
Searchable = "searchable",
Sortable = "sortable",
Resizable = "resizable",
"Default sorted" = "defaultSorted",
"Show sortable" = "showSortable",
Outlined = "outlined",
Bordered = "bordered",
Borderless = "borderless",
Striped = "striped",
Highlight = "highlight",
Compact = "compact",
"Full width" = "fullWidth"
),
selected = c("sortable", "resizable", "highlight", "fullWidth")
),
selectInput(
"theme",
"Theme",
c("Default", names(themes)),
selectize = FALSE,
width = 170
),
checkboxGroupInput(
"pagination",
"Pagination",
choices = c(
"Enable pagination" = "pagination",
"Show page size options" = "showPageSizeOptions",
"Show page info" = "showPageInfo"
),
selected = c("pagination", "showPageSizeOptions", "showPageInfo")
),
radioButtons(
"paginationType",
"Pagination type",
choices = c("page numbers" = "numbers", "page jump" = "jump", "simple")
),
checkboxGroupInput("groupBy", "Group By", choices = c("Species", "Petal.Width")),
checkboxGroupInput(
"rowDetails",
"Row Details",
choices = c(
"Show row details" = "showRowDetails",
"Multiple row details" = "multiRowDetails",
"Column header" = "columnHeader"
),
selected = "showRowDetails"
),
radioButtons(
"rowSelection",
"Row Selection",
choices = c(
"None" = "none",
"Single" = "single",
"Multiple" = "multiple"
)
),
checkboxGroupInput(
"colOptions",
"Column Options",
choices = c(
Formatting = "format",
"Custom cell renderer" = "cell"
),
selected = c("format", "cell")
)
),
div(class = "content",
tabsetPanel(
tabPanel(
"Table",
reactableOutput("table"),
conditionalPanel(
"input.rowSelection !== 'none'",
hr(),
"Selected rows:",
verbatimTextOutput("selected")
)
),
tabPanel(
"Code",
htmlOutput("code")
)
)
)
)
)
server <- function(input, output, session) {
tblOptions <- reactive({
list(
groupBy = input$groupBy,
columnGroups = if ("columnGroups" %in% input$options) {
quote(list(
colGroup(name = "Sepal", columns = c("Sepal.Length", "Sepal.Width")),
colGroup(name = "Petal", columns = c("Petal.Length", "Petal.Width"))
))
},
filterable = "filterable" %in% input$options,
searchable = "searchable" %in% input$options,
resizable = "resizable" %in% input$options,
sortable = "sortable" %in% input$options,
defaultSorted = if ("defaultSorted" %in% input$options) c("Sepal.Length", "Sepal.Width"),
pagination = "pagination" %in% input$pagination,
paginationType = input$paginationType,
showPageSizeOptions = all(c("showPageSizeOptions", "pagination") %in% input$pagination),
showPageInfo = "showPageInfo" %in% input$pagination,
selection = if (input$rowSelection != "none") input$rowSelection,
onClick = if (input$rowSelection != "none") {
"select"
} else if (any(c("showRowDetails", "multiRowDetails") %in% input$rowDetails)) {
"expand"
},
outlined = "outlined" %in% input$options,
bordered = "bordered" %in% input$options,
borderless = "borderless" %in% input$options,
striped = "striped" %in% input$options,
highlight = "highlight" %in% input$options,
compact = "compact" %in% input$options,
showSortable = "showSortable" %in% input$options,
fullWidth = "fullWidth" %in% input$options,
height = if ("pagination" %in% input$pagination) "auto" else 500,
theme = if (input$theme != "Default") bquote(.(themes[[input$theme]]))
)
})
colOptions <- reactive({
list(
Sepal.Length = list(
format = if ("format" %in% input$colOptions) {
quote(colFormat(suffix = " cm", digits = 1))
}
),
Sepal.Width = list(
format = if ("format" %in% input$colOptions) {
quote(list(aggregated = colFormat(suffix = " (avg)", digits = 2)))
},
cell = if ("cell" %in% input$colOptions) {
function(value) {
if (value >= 3.3) {
classes <- "tag num-high"
} else if (value >= 3) {
classes <- "tag num-med"
} else {
classes <- "tag num-low"
}
value <- format(value, nsmall = 1)
span(class = classes, value)
}
},
footer = if ("footer" %in% input$options) {
function(values) {
div(tags$b("Average: "), round(mean(values), 1))
}
},
details = if ("multiRowDetails" %in% input$rowDetails) {
function(index) {
tagList(
paste("Details for row:", index),
pre(paste(capture.output(iris[index, ]), collapse = "\n"))
)
}
}
)
)
})
rowDetailsOptions <- reactive({
if (!any(c("showRowDetails", "multiRowDetails") %in% input$rowDetails)) {
return(NULL)
}
details <- function(index) {
if (index == 3) {
tabsetPanel(
tabPanel("plot", plotOutput("plot")),
tabPanel("subtable", reactable(iris[1:3, 1:2], fullWidth = FALSE))
)
} else if (index == 5) {
paste("Details for row:", index)
}
}
if (!"columnHeader" %in% input$rowDetails) {
details
} else {
bquote(
colDef(
details = .(details),
name = "More",
width = 70
)
)
}
})
code <- reactive({
opts <- tblOptions()
colOpts <- colOptions()
call <- bquote(reactable(
iris,
columnGroups = .(opts$columnGroups),
filterable = .(opts$filterable),
searchable = .(opts$searchable),
sortable = .(opts$sortable),
resizable = .(opts$resizable),
pagination = .(opts$pagination),
paginationType = .(opts$paginationType),
showPageSizeOptions = .(opts$showPageSizeOptions),
showPageInfo = .(opts$showPageInfo),
selection = .(opts$selection),
onClick = .(opts$onClick),
outlined = .(opts$outlined),
bordered = .(opts$bordered),
borderless = .(opts$borderless),
striped = .(opts$striped),
highlight = .(opts$highlight),
compact = .(opts$compact),
showSortable = .(opts$showSortable),
groupBy = .(opts$groupBy),
defaultSorted = .(opts$defaultSorted),
fullWidth = .(opts$fullWidth),
height = .(opts$height),
columns = list(
Sepal.Length = colDef(
name = .(if (is.null(opts$columnGroups)) "Sepal Length" else "Length"),
aggregate = "max",
format = .(colOpts$Sepal.Length$format)
),
Sepal.Width = colDef(
name = .(if (is.null(opts$columnGroups)) "Sepal Width" else "Width"),
defaultSortOrder = "desc",
aggregate = "mean",
format = .(colOpts$Sepal.Width$format),
cell = .(colOpts$Sepal.Width$cell),
footer = .(colOpts$Sepal.Width$footer),
details = .(colOpts$Sepal.Width$details)
),
Petal.Length = colDef(
name = .(if (is.null(opts$columnGroups)) "Petal Length" else "Length"),
aggregate = "sum"
),
Petal.Width = colDef(
name = .(if (is.null(opts$columnGroups)) "Petal Width" else "Width"),
aggregate = "count"
),
Species = colDef(
aggregate = "frequency"
)
),
details = .(rowDetailsOptions()),
theme = .(if (!is.null(opts$theme)) quote(theme))
))
# Omit default reactable args
defaultArgs <- formals(reactable)
for (argname in names(call)) {
if (argname != "" &&
(is.null(call[[argname]]) || identical(call[[argname]], defaultArgs[[argname]]))) {
call[[argname]] <- NULL
}
}
# Omit default colDef args
defaultArgs <- formals(colDef)
for (colname in names(call$columns)) {
col <- call$columns[[colname]]
for (argname in names(col)) {
if (argname != "" && identical(col[[argname]], defaultArgs[[argname]])) {
call$columns[[colname]][[argname]] <- NULL
}
}
}
code <- gsub("\\n", "\n", deparse(call, control = "useSource"), fixed = TRUE)
if (!is.null(opts$theme)) {
themeCall <- bquote({ theme <- .(opts$theme) })
themeCode <- gsub("\\n", "\n", deparse(themeCall[[2]], control = "useSource"), fixed = TRUE)
code <- c(themeCode, "", code)
}
paste(code, collapse = "\n")
})
output$code <- renderUI({
prismCodeBlock(code())
})
output$table <- renderReactable({
eval(parse(text = code()))
})
output$selected <- renderPrint({
print(getReactableState("table", "selected"))
})
output$plot <- renderPlot({
hist(iris$Sepal.Length)
})
outputOptions(output, "table", suspendWhenHidden = FALSE)
}
shinyApp(ui, server)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.