R DT Horizontal scroll bar at top of the table - r

I have a wide and lengthy DT in shiny. By default I would like to show the horizontal scroll bar on top of the table. Is there a way to do this? My current DT definition looks like below:
DT::datatable(dt, rownames = FALSE,
filter = fbox,
style = "bootstrap",
options = list(
dom = dom,
scrollX = TRUE,
columnDefs = list(list(orderSequence = c('desc', 'asc'), targets = "_all")),
processing = FALSE,
pageLength = 500,
lengthMenu = list(c(500, 1000, 5000), c("500","1000","5000"))
),
callback = DT::JS("$(window).unload(function() { table.state.clear(); })")
) %>% DT::formatStyle(., cn_cat, color = "black", backgroundColor = "#dee6ea",fontWeight = "bold")
Thanks in advance.

Flip Scrollbar for All DataTables in App
You could add some css to flip the div containing the scrollbar/table and then flip back the table content, as per this answer:
.dataTables_scrollBody {
transform:rotateX(180deg);
}
.dataTables_scrollBody table {
transform:rotateX(180deg);
}
Flip Scrollbar for Specific DataTable
If you only want to flip the scroll bar on one table, you could select the specific table:
#flipped > .dataTables_wrapper.no-footer > .dataTables_scroll > .dataTables_scrollBody {
transform:rotateX(180deg);
}
#flipped > .dataTables_wrapper.no-footer > .dataTables_scroll > .dataTables_scrollBody table{
transform:rotateX(180deg);
}
Example
library(shiny)
library(DT)
css <- HTML(
"#flipped > .dataTables_wrapper.no-footer > .dataTables_scroll > .dataTables_scrollBody {
transform:rotateX(180deg);
}
#flipped > .dataTables_wrapper.no-footer > .dataTables_scroll > .dataTables_scrollBody table{
transform:rotateX(180deg);
}"
)
ui <- fluidPage(
tags$head(tags$style(css)),
fluidRow(column(width = 6,
h4("Flipped Scrollbar"),
br(),
DT::dataTableOutput("flipped")
),
column(width = 6,
h4("Regular Scrollbar"),
br(),
DT::dataTableOutput("regular")
)
)
)
server <- function(input, output, session) {
output$flipped <- DT::renderDataTable({
DT::datatable(mtcars, rownames = FALSE,
options = list(
scrollX = TRUE
)
)
})
output$regular <- DT::renderDataTable({
DT::datatable(mtcars, rownames = FALSE,
options = list(
scrollX = TRUE
)
)
})
}
shinyApp(ui, server)

I managed to get the Scrollbar on top using what #HallieSwam suggested, but looked into the source HTML code to understand what parts needed to be rotated.
What worked for me:
tags$head(tags$style(HTML(
"#Table1 .dataTables_scrollBody {transform:rotate(180deg);}
#Table1 .dataTables_scrollHead {transform:rotate(180deg);}
#Table1 .dataTables_scroll table {transform:rotate(180deg);}
"
)))
scrollBody turns the whole table, including the scrolling bar, then scrollHead is required to align the scrolling bar with the header in the final table. Scroll table will turn just the content in the table, leaving the scrolling bar on top.

Related

How to add a horizontal scrollbar to a fixedHeader in renderDataTable in R Shiny?

I am building a datatable in R Shiny to display data with many columns and rows. I had two problems at first:
When the user was scrolling down the table, the header of the table disappeared. This has been fixed thanks to this SO post.
When a user wishes to go left or right of the table, he has to scroll to the bottom of the page (or top depending on where you display the scrollbar). This is an inconvenience to repeat this task especially when displaying many rows. So, my aim is to add a horizontal scrollbar to the fixed header. Would this be possible?
I searched the internet and I found this post that may contain the answer but not sure how to implement it in my case.
The following reproducible code will spawn a table with 50 rows and 30 columns:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(dplyr)
library(data.table)
library(tidyverse)
library(DT)
myFun <- function(n = 5000) {
a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE))
paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE))
}
dt <- setDT(data.frame(replicate(30,sample(myFun(50),50,rep=TRUE))))
ui <- fluidPage(theme = "slate",
navbarPage(title = "Test",
header = tagList(
useShinydashboard(),
),
tabPanel(
"Table",
fluidRow(
box(dataTableOutput("mytable"),
width = 12,
collapsible = FALSE,
title = "",
solidHeader = T
)
)
)
)
)
# server
server <- function(input, output) {
output$mytable <-
renderDataTable(
dt,
filter = list(position = "top", clear = FALSE, plain = TRUE),
extensions = c("FixedHeader"),
options = list(
scrollX = T,
fixedHeader=T,
pageLength = 50,
autoWidth = F,
search = list(regex = TRUE),
# the following is used to cut the string if its too long
columnDefs = list(
list(
targets = "_all",
render = JS(
"function(data, type, row, meta) {",
"return type === 'display' && data != null && data.length > 5 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 5) + '...</span>' : data;",
"}"
)
)
)
),
rownames = FALSE
)
}
# app
shinyApp(ui, server)
Will generate a Shiny app:
Any help is kindly appreciated. Thanks in advance.
The vertical scrollbar that appears is actually for the whole page, not the datatable. You need to restrict the height of your datatable, so it doesn't overflow the page, and add the vertical bar. You can do that by adding
scrollY = 300
to your table options, where "300" is the height of your datatable. Depending on your userbase, what devices they are using etc. you will need to adjust this number or find an appropriate way of setting it automatically.
The above would also fix the problem with disappearing header, since you are actually scrolling table body instead of the whole page.

Print indices of columns that are selected on click using the DT package in Shiny app

I have a selectable DT and a radio button that changes the orientation of the selection. I am able to print the index of the selections when the radio button is set to rows, but I don't know how to show the indices when the radio button is set to columns. Is there a way of printing the column indices instead of printing a NULL when the radio buttons are set to columns?
Here is my MRE:
library(shiny)
library(glue)
library(dplyr)
library(DT)
library(shinyWidgets)
library(tibble)
####Create the matrix and organization for the 96 well plate####
plate96 <- function(id) {
div(
style = "position: relative; height: 500px",
tags$style(HTML('
.wells {
transform: translateX(50%);
}
.wells tbody tr td:not(:first-of-type) {
border: 1px solid black;
height: 15px;
width: 15px;
padding: 15px;
font-size: 0;
}
')),
div(
style = "position: absolute; left: 50%; transform: translateX(-100%);",
div(
class = "wells",
DTOutput(id, width = "90%", height= "100%")
)
)
)
}
renderPlate96 = function(id, colors = rep("white", 96)) {
stopifnot(is.character(colors) && length(colors) == 96)
plate <- matrix(1:96,
nrow = 8,
ncol = 12,
byrow = TRUE,
dimnames = list(LETTERS[1:8], 1:12))
colnames (plate) = stringr::str_pad(colnames(plate), 2, "left", "0")
return(plate_return1 <-
datatable(
plate,
options = list(dom = 't', ordering = F),
selection = {if (id == "Horizontal") {list(target = "row")}
else if (id == "Vertical") {list(target = "column")}},
class = 'cell-border compact'
) %>%
formatStyle(
1:12,
cursor = 'pointer',
backgroundColor = styleEqual(1:96, colors, default = NULL)
)
)
}
ui <- fluidPage(
br(),
plate96("plate"),
tags$b("Wells Selected:"),
verbatimTextOutput("plateWells_selected"),
####Horizontal vs Vertical orientation radio buttons####
radioButtons("orientation_radio",
label = h3("Horizontal vs Vertical"),
c("Horizontal, counted down rows" = "Horizontal",
"Vertical, counted down columns" = "Vertical")),
)
server <- function(input, output, session){
####Create the 96 well plate image####
output$plate <- renderDT({
renderPlate96({as.character(input$orientation_radio)})
})
output$plateWells_selected <- renderPrint({
input$plate_rows_selected
})
}
shinyApp(ui = ui, server = server)
After more Googling, I found the answer.
The answer is given here:
https://rstudio.github.io/DT/shiny.html
2.1.2 Column Selection
Row selection is the default mode in DT. You can turn on column selection using datatable(..., selection = list(target = 'column')). In this case, you can click on any cell to select a column, and the (numeric) indices of the selected columns will be available in input$tableId_columns_selected.
You may also select rows and columns simultaneously using target = 'row+column'. In this case, column selection is achieved by clicking on the table footer. Clicking on the table body will select/deselect rows.

How I can center the header columns on reactable (r-package)?

Hi and thanks for reading me
I am working on some tables with the "reactable" package in r, but I would like to center only the headings of each column. For example:
library(reactable)
reactable(iris,
defaultColDef = colDef(
header = function(value) gsub(".", " ", value, fixed = TRUE),
cell = function(value) format(value, nsmall = 1),
align = "center",
minWidth = 70,
headerStyle = list(background = "#12a09a")
))
Apparently the option colDef(align = "center") centers the entire column, but is there an option to only center the title?
i assume that you are using this tables in an R markdown document or a shiny app. In both you can override the css in order to left align the table text or let the default table and center the title.
In the first case you just need to add this line .rt-align-center{text-align: left;}.
In shiny you just need to add that to your custom css or use the style tag to add it inline like the example below:
library(shiny)
library(reactable)
ui <- fluidPage(
# inline style tag to define table row text alignment
tags$style(HTML(".rt-align-center {text-align: left;}")),
titlePanel("Iris react table"),
sidebarLayout(
sidebarPanel(
helpText("Nothing to see here")
),
mainPanel(
reactableOutput("table")
)
)
)
server <- function(input, output) {
output$table <- renderReactable({
reactable(iris,
defaultColDef = colDef(
header = function(value) gsub(".", " ", value, fixed = TRUE),
cell = function(value) format(value, nsmall = 1),
align = "center",
minWidth = 70,
headerStyle = list(background = "#12a09a")
))
})
}
shinyApp(ui = ui, server = server)
If you are working with an Rmarkdown document just add it to the html in the style tag like this:
<style> .rt-align-center {text-align: left;} </style>
and the result:

RShiny: Reducing bootstrap table cell padding when using `bs_theme()`

# Header
## Load packages
library(shiny)
library(tidyverse)
library(DT)
library(bslib)
ui <- navbarPage("Test",
inverse = T,
collapsible = T,
theme = bs_theme(
version = 4,
bootswatch = "lux",
"font-size-base" = "1rem",
"table-cell-padding" = ".4rem"
),
tabPanel(
title = "Data Tables",
id = "data",
icon = icon("flask"),
fluidRow(
dataTableOutput("DT1")
)
)
)
server <- function(input, output, session) {
output$DT1 <- renderDataTable({
datatable(mtcars,
style = "bootstrap4",
options = list(info = F,
searching = T,
paging = T,
autoWidth = T,
scrollX = T),
filter = list(position = 'top', clear = FALSE),
class = 'cell-border stripe compact',
rownames = F)
})
}
##
shinyApp(ui, server)
I am trying to create a table using the bs_theme() function from the bslib package, specifically using the theme lux. The tables are very large and the cells have massive padding. Adding the "table-cell-padding" argument in bs_theme() doesn't change the cell sizes. How do I make the table compact and the cells tight around the numbers/column names?
Just add tags$style('#DT1 td {padding: 0}'), how simple is that.
# Header
## Load packages
library(shiny)
library(tidyverse)
library(DT)
library(bslib)
ui <- navbarPage("Test",
inverse = T,
collapsible = T,
theme = bs_theme(
version = 4,
bootswatch = "lux",
"font-size-base" = "1rem",
"table-cell-padding" = ".4rem"
),
tabPanel(
title = "Data Tables",
id = "data",
icon = icon("flask"),
fluidRow(
tags$style('#DT1 td {padding: 0}'),
# style = "width: 50%",
dataTableOutput("DT1")
)
)
)
server <- function(input, output, session) {
output$DT1 <- renderDataTable({
datatable(mtcars,
style = "bootstrap4",
options = list(info = F,
searching = T,
paging = T,
autoWidth = T,
scrollX = T),
filter = list(position = 'top', clear = FALSE),
class = 'cell-border stripe compact',
rownames = F)
})
}
##
shinyApp(ui, server)
Change the padding: 0 to any valid css unit you want, here I changed to 0, no padding. It will seem that it doesn't work on left and right, that's because you have autoWidth, it will always use the full width of the parent node. So, if you want the width to be smaller, uncomment the style line above, you should see is't only half of the screen.

Shiny with DT Select rows, keep cell color

I have a DT datatable that has cells colored according to a different variable. When you click on a row, it highlights values in a corresponding plot, exactly like in the example here. However, when you select a row, the new color that highlights the row overrides my existing colors. I'd like for the row to be highlighted, but the individual cell to maintain its color if it was already colored.
The screenshots below show what I'm getting and what I want. I modified Yihui's code to make a reproducible example below the screenshots. Any help would be appreciated!
library(shiny)
library(DT)
ui <- fluidPage(
title = 'Select Table Rows',
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, plotOutput('x2', height = 500))
)
)
server <- function(input, output) {
cars <- cars %>%
mutate(low_speed = ifelse(speed < 5, 1, 0))
output$x1 <- renderDataTable({
datatable(cars,
options = list(columnDefs = list(list(targets = 3,
visible = FALSE)))) %>%
formatStyle("speed", "low_speed",
backgroundColor = styleEqual(c(0, 1),
c("transparent", "#E34755")))
})
# highlight selected rows in the scatterplot
output$x2 <- renderPlot({
s <- input$x1_rows_selected
par(mar = c(4, 4, 1, .1))
plot(cars[ ,-3])
if (length(s)) points(cars[s, , drop = FALSE], pch = 19, cex = 2)
})
}
shinyApp(ui, server)
You can define a CSS class for the background color (red below) and add it to the desired cells with a rowCallback. Then add this CSS:
.red {
background-color: #e34755;
}
table.dataTable tr.selected td.red {
background-color: #e34755 !important;
}
The app:
library(shiny)
library(DT)
rowCallback <- c(
"function(row, dat, displayNum, index){",
" if(dat[1] < 5){",
" $('td:eq(1)', row).addClass('red');",
" }",
"}"
)
css <- "
.red {
background-color: #e34755;
}
table.dataTable tr.selected td.red {
background-color: #e34755 !important;
}
"
ui <- fluidPage(
tags$head(
tags$style(HTML(css))
),
title = 'Select Table Rows',
fluidRow(
column(6, DTOutput('x1')),
column(6, plotOutput('x2', height = 500))
)
)
server <- function(input, output) {
output$x1 <- renderDT({
datatable(cars,
options = list(
columnDefs = list(list(targets = 3,visible = FALSE)),
rowCallback = JS(rowCallback)
)
)
})
# highlight selected rows in the scatterplot
output$x2 <- renderPlot({
s <- input$x1_rows_selected
par(mar = c(4, 4, 1, .1))
plot(cars[ ,-3])
if (length(s)) points(cars[s, , drop = FALSE], pch = 19, cex = 2)
})
}
shinyApp(ui, server)
You can make this happen with some custom CSS. Add this code block to your fluidPage:
tags$head(
tags$style(
HTML(
"table.dataTable tbody tr.selected td {
color: white !important;
background-color: #E34755 !important;}"
)
)
),
You could also drop that CSS snippet into a standalone file and place it in the www directory alongside your app file(s). See here for more Shiny CSS info.
Live Demo

Resources