I have a Shiny app that yields a data table, but I can't freeze the first column and the headers, so the table is hard to read as you go down or across. Is there anyway to freeze the panes? I've tried searching but have found nothing.
Interesting question and now thanks to the recent update of Shiny to data.tables 1.10.2
it is alot easier to use the various plug-ins and extensions. For your question the FixedHeader extension seems ideal. To add this extension we need to include the relevant JavaScript and CSS file (see http://cdn.datatables.net/):
tagList(
singleton(tags$head(tags$script(src='//cdn.datatables.net/fixedheader/2.1.2/js/dataTables.fixedHeader.min.js',type='text/javascript'))),
singleton(tags$head(tags$link(href='//cdn.datatables.net/fixedheader/2.1.2/css/dataTables.fixedHeader.css',rel='stylesheet',type='text/css')))
)
data.tables has an option initComplete which allows us to stipulate a callback once table is drawn etc.
function(settings, json) {
new $.fn.dataTable.FixedHeader(this, {
left: true,
right: true
} );
}
We will use a modified version of the iris data set adding an index and some random data at the end to show left to right scrolling:
library(shiny)
myData <- cbind(list(index = row.names(iris)), iris
, rep(list(row.names(iris)), 10))
names(myData)[7:16] <- paste0("randomData", 1:10)
runApp(
list(ui = fluidPage(
tagList(
singleton(tags$head(tags$script(src='//cdn.datatables.net/fixedheader/2.1.2/js/dataTables.fixedHeader.min.js',type='text/javascript'))),
singleton(tags$head(tags$link(href='//cdn.datatables.net/fixedheader/2.1.2/css/dataTables.fixedHeader.css',rel='stylesheet',type='text/css')))
),
dataTableOutput("mytable")
)
, server = function(input, output, session){
output$mytable <- renderDataTable(myData,
options = list(
pageLength = 50,
initComplete = I("function(settings, json){
new $.fn.dataTable.FixedHeader(this, {
left: true,
right: true
} );
}")
)
)
})
)
so in the image we can see we are scrolled down to record 8 and across some ways but the header and the first column (our added index column) are still visible.
FixedHeader is now (2021) compatible with FixedColumns. See table
library(shiny)
library(DT)
runApp(
list(ui = fluidPage(
dataTableOutput("mytable")
)
, server = function(input, output, session){
Rows <- c(1:30)
for (y in 1:15){
x<-y-1
assign(letters[x+1],runif(5, 0, 1))
}
x <- data.frame(Rows, mget(letters[1:15]), row.names=NULL)
x<- x[2:15]
output$mytable <- renderDataTable(
DT::datatable(x, rownames=FALSE,extensions = c('FixedColumns',"FixedHeader"),
options = list(dom = 't',
scrollX = TRUE,
paging=FALSE,
fixedHeader=TRUE,
fixedColumns = list(leftColumns = 1, rightColumns = 0))
)
)
}
)
)
Implemented:
2021-09-10: FixedColumns 4.0.0
Related
I have a data coming from a server. Now I want to add a free text column ( editable) to add comments to my R shiny application. Once that is done , I want to save it in SQLLite and bring it back once it is refreshed. Please help me with the pointers.
library(shiny)
library(ggplot2) # for the diamonds dataset
ui <- fluidPage(
title = "Examples of DataTables",
sidebarLayout(
sidebarPanel(
conditionalPanel(
'input.dataset === "diamonds"'
)
),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel("diamonds", DT::dataTableOutput("mytable1"))
)
)
)
)
library(DT)
server <- function(input, output) {
# choose columns to display
diamonds2 = diamonds[sample(nrow(diamonds), 1000), ]
diamonds2$test <- ifelse(diamonds2$x > diamonds2$y,TRUE,FALSE)
output$mytable1 <- DT::renderDataTable({
DT::datatable(diamonds2[, drop = FALSE],extensions = 'FixedColumns',options = list(
dom = 't',
scrollX = TRUE,
fixedColumns = list(leftColumns =10)
)) %>%
formatStyle(
'x', 'test',
backgroundColor = styleEqual(c(TRUE, FALSE), c('gray', 'yellow'))
)
})
}
Please guide how can I add free text in the end of the table and save it.
Thanks in advance.
Regards,
R
Here is a solution based on DTs editable option. (See this for more information)
Each time the user edits a cell in the "comment" column it is saved to a sqlite database and loaded again after restarting the app:
library(shiny)
library(DT)
library(ggplot2) # diamonds dataset
library(RSQLite)
library(DBI)
# choose columns to display
diamonds2 = diamonds[sample(nrow(diamonds), 1000),]
diamonds2$test <- ifelse(diamonds2$x > diamonds2$y, TRUE, FALSE)
diamonds2$id <- seq_len(nrow(diamonds2))
diamonds2$comment <- NA_character_
con <- dbConnect(RSQLite::SQLite(), "diamonds.db")
if(!"diamonds" %in% dbListTables(con)){
dbWriteTable(con, "diamonds", diamonds2)
}
ui <- fluidPage(title = "Examples of DataTables",
sidebarLayout(sidebarPanel(
conditionalPanel('input.dataset === "diamonds"')
),
mainPanel(tabsetPanel(
id = 'dataset',
tabPanel("diamonds", DT::dataTableOutput("mytable1"))
))))
server <- function(input, output, session) {
# use sqlInterpolate() for production app
# https://shiny.rstudio.com/articles/sql-injections.html
dbDiamonds <- dbGetQuery(con, "SELECT * FROM diamonds;")
output$mytable1 <- DT::renderDataTable({
DT::datatable(
dbDiamonds,
# extensions = 'FixedColumns',
options = list(
dom = 't',
scrollX = TRUE
# , fixedColumns = list(leftColumns = 10)
),
editable = TRUE,
# editable = list(target = "column", disable = list(columns = which(names(diamonds2) %in% setdiff(names(diamonds2), "comment"))))
) %>% formatStyle('x', 'test', backgroundColor = styleEqual(c(TRUE, FALSE), c('gray', 'yellow')))
})
observeEvent(input$mytable1_cell_edit, {
if(input$mytable1_cell_edit$col == which(names(dbDiamonds) == "comment")){
dbExecute(con, sprintf("UPDATE diamonds SET comment = '%s' WHERE id = %s", input$mytable1_cell_edit$value, input$mytable1_cell_edit$row))
}
})
}
shinyApp(ui, server, onStart = function() {
onStop(function() {
dbDisconnect(con) # close connection on app stop
})
})
Initially I wanted to disable editing for all columns except "comment", however, it seems I've found a bug.
The following example adds a <input type="text"> element to each row of the table, where you can add your free text. A simple JavaScript event listener reacts on changes to the text boxes and stores them in the Shiny variable free_text which you can then process on the shiny side according to your needs (in this toy example it is simply output to a verbatimTextOutput).
As for the storing: I would add a save button, which reads input$free_text and saves it back to the data base. To display the text then again in the text boxes is as easy as adding the value in the mutate statement like this mutate(free_text = sprintf("<input type=\"text\" class = \"free-text\" value = \"%s\" />", free_text_field_name))
library(shiny)
library(DT)
library(dplyr)
ui <- fluidPage(
tags$head(
tags$script(
HTML(
"$(function() {
// input event fires for every change, consider maybe a debounce
// or the 'change' event (then it is only triggered if the text box
// loses focus)
$('#tab').on('input', function() {
const inputs = $(this).find('.free-text').map(function() {
return this.value;
})
Shiny.setInputValue('free_text', inputs.get());
})
})
"
)
)
),
fluidRow(
verbatimTextOutput("out")
),
fluidRow(
dataTableOutput("tab")
)
)
server <- function(input, output, session) {
output$tab <- renderDataTable({
my_dat <- mtcars %>%
mutate(free_text =
sprintf("<input type=\"text\" class = \"free-text\" value = \"\" />"))
datatable(my_dat, escape = FALSE,
options = list(dom = "t", pageLength = nrow(mtcars)))
})
output$out <- renderPrint(input$free_text)
}
shinyApp(ui, server)
You may want to have a look at the handsontable package, which allows editing of (columns of) datatable outputs. In your case, you can create a character column and allow editing through the handsontable.
On the topic of persisting data: you table would need either a separate column with comments, or a separate table that maps observations to comment, which is joined. The best solution depends on the volume of comments you expect: if you expect comment to appears sporadically, a separate table may be the best solution. If you expect comments for nearly every row, direct integration into the table may be more favourable. It then becomes a matter of writing to and loading from an SQL database based on user events.
I have a Shiny app where I try to attach a click listener to a datatable row.
Here's my code:
require(DT)
require(data.table)
ui <- fluidPage(
fluidRow(
titlePanel("Data Explorer")
),
fluidRow(
column(
DT::dataTableOutput("listTable"),
width = 4
),
column(
width = 8
)
)
)
get.data <- function() {
res <- data.table(a = c(1,2,3), b = c(4,5,6))
return(res)
}
server <- function(input, output) {
output$listTable <- DT::renderDataTable({
showModal(modalDialog("Fetching Data..."))
dt <- datatable(get.data(),
rownames = FALSE,
options = list(autoWidth = TRUE,
selection = 'none',
callback = JS("$('#listTable tbody').on('click.dt', 'tr', function() { console.log('foo'); })")))
removeModal()
return(dt)
})
}
shinyApp(ui = ui, server = server)
All the examples I found via googling have used the implicitly provided table variable to find the root element, but when I try to do that, I just get a ReferenceError: table is not defined.
So I've used a direct JQuery search instead. When I use console.log('foo') as the callback, it works fine. But when I try to attach a listener as I do above, it doesn't attach. When I copy-paste that exact same code into my Firefox console on the page, it works.
What's the issue here?
callback is an argument of the datatable function, it does not belong to the options list. So you have to do like this:
dt <- datatable(
get.data(),
rownames = FALSE,
callback = JS("table.on('click', 'tr', function() { alert('foo'); })"),
options = list(
autoWidth = TRUE,
selection = 'none'
)
)
I am developing a shiny app where user can select multiple columns in a big dataset to create a subset of this dataset. I use the package DT to render the table nicely in the shiny app.
I previously used version 0.2 of DT package where the following code was working :
library("DT")
library("shiny")
ui <- fluidPage(
DT::dataTableOutput('table1'),
DT::dataTableOutput("table2")
)
server <- function(input, output) {
output$table1 <- DT::renderDataTable({
datatable(mtcars, extensions = 'Select', selection = 'none', options = list(ordering = FALSE, searching = FALSE, pageLength = 25, select = list(style = 'os', items = 'column')),
callback = JS(
"table.on( 'click.dt', 'tbody td', function (e) {",
"var type = table.select.items();",
"var idx = table[type + 's']({selected: true}).indexes().toArray();",
"var DT_id = table.table().container().parentNode.id;",
"Shiny.onInputChange(DT_id + '_columns_selected', idx);",
"})"
))
})
output$table2 <- DT::renderDataTable({
subset_table <- mtcars[,input$table1_columns_selected]
datatable(subset_table)
})
}
shinyApp(ui = ui, server = server)
Unfortunately, this code is not working anymore (I am now under version 0.4). The input$table1_columns_selected does not render the indices of the selected columns.
According to this https://rstudio.github.io/DT/shiny.html there is now a functionnality to select multiples rows, but I can't figure out how to do the same with columns.
Any idea ?
Thank you very much for your help !
I am not sure why you need to use the callback argument to do this. Here's a simplified approach -
library("DT")
library("shiny")
ui <- fluidPage(
DT::dataTableOutput('table1'),
DT::dataTableOutput("table2")
)
server <- function(input, output) {
output$table1 <- DT::renderDataTable({
datatable(mtcars, extensions = 'Select', selection = list(target = "column"), options = list(ordering = FALSE, searching = FALSE, pageLength = 25))
})
output$table2 <- DT::renderDataTable({
subset_table <- mtcars[, input$table1_columns_selected, drop = F]
datatable(subset_table)
})
}
shinyApp(ui = ui, server = server)
Note the change in the datatable arguments in output$table1. Hope this is what you were looking for.
I have tested your code and its working fine for me (see picture below) and i am also using DT package version 0.4.
So my guess is that, its not DT package problem but something else in your global configuration that is causing the issue.
Fairly new to R - doing OK with big picture stuff, and struggling on cleaning up the edges when I want to present something to other people.
Banging my head against the wall with something that's probably pretty simple - I simply want to add cell borders - to all cells - in a datatable in a shiny app. Here's a relevant chunk of code:
library(ggplot2)
library(shiny)
library(data.table)
library(DT)
library(plotly)
setwd("C:/Users/Will/Desktop/FinalPages")
lister <- read.table("PlayerList.csv", header=TRUE, quote ="", sep=",",fill = TRUE)
totals <- read.table("TotShooting.csv", header=TRUE, quote ="", sep=",",fill = TRUE)
items <- as.character(lister[[1]])
ui <- fluidPage(
sidebarLayout(
sidebarPanel(selectizeInput("players", "Player:", choices = items, multiple = FALSE),
width=2
),
mainPanel(h5("Total Shooting", align = "center"),
div(dataTableOutput("tot"), style = "font-size:80%", class = 'table-condensed cell-border row-border'),
position="center",
width = 10)
)
)
server <- function(input, output) {
output$tot <- DT::renderDataTable({
validate(
need(input$players, ' ')
)
filterone <- subset(totals, Name == input$players)
filterone <- filterone[,-1:-2]
DT::datatable(filterone,
rownames = FALSE,
options=list(iDisplayLength=7,
bPaginate=FALSE,
bLengthChange=FALSE,
bFilter=FALSE,
bInfo=FALSE,
rowid = FALSE,
autoWidth = FALSE,
ordering = FALSE,
scrollX = TRUE,
borders = TRUE,
columnDefs = list(list(className = 'dt-center', targets ="_all"))
))
}
)
I've been trying to track it down via google, but haven't been able to hit on a solution I can get to work. It's probably something very simple with tags, or a correct class name (I hope so, at least), but I'm lost here. Appreciate any help I can get.
The function that you are looking for is : formatStyle("your DT table", "vector of column index", border = '1px solid #ddd').
You can find a reproducible example here :
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
DT::dataTableOutput("test")
),
server = function(input, output, session) {
output$test <- DT::renderDataTable({
datatable(mtcars) %>%
formatStyle(c(1:dim(mtcars)[2]), border = '1px solid #ddd')
})
})
There must be more elegant ways but it works !
The following is a direct replication of the datatable demo provided on the rstudio shiny website. It is quite easy to filter the dataset (e.g. Ideal on the diamond, or setosa on the iris), however is there a way to filter multiple conditions such as 'Ideal' and 'Fair' in the diamond dataset? I have tried the basic 'AND' and '&' syntax, spaces, nothing seems to work. This seems like it should be possible but is this even possible or does it require some roundabout approach?
require(shiny)
runApp(
list(ui = fluidPage(
title = 'Examples of DataTables',
sidebarLayout(
sidebarPanel(
conditionalPanel(
'input.dataset === "diamonds"',
checkboxGroupInput('show_vars', 'Columns in diamonds to show:',
names(diamonds), selected = names(diamonds))
)
),
mainPanel(
tabsetPanel(
id = 'dataset',
tabPanel('diamonds', dataTableOutput('mytable1'))
)
)
)
),
server = shinyServer(function(input, output) {
# a large table, reative to input$show_vars
output$mytable1 <- renderDataTable({
library(ggplot2)
diamonds[, input$show_vars, drop = FALSE]
})
})
)
)
After some further search, I suspect I should be able to use the jquery column filter plugin. To simplify this question, here is a more stripped down version of the above code:
library(shiny)
runApp(
list(ui = basicPage(
h1('Diamonds DataTable with TableTools'),
# added column filter plugin
singleton(tags$head(tags$script(src='https://code.google.com/p/jquery-datatables-column-filter/source/browse/trunk/media/js/jquery.dataTables.columnFilter.js',
type='text/javascript'))),
dataTableOutput("mytable")
)
,server = function(input, output) {
output$mytable = renderDataTable({
diamonds[,1:6]
}, options = list(
pageLength = 10,
columnDefs = I('[{"targets": [0,1],
"searchable": true}]')
)
)
}
))
However, I cannot seem to get the columnFilter plugin to work. The columnDefs statement (commented out) works fine but when I try to do the columnFilter statement, I get only get the table header and filter search boxes. I suspect some syntax must be off to get this to work. As an example of the functionality, please see this website. Please note, this is also using the most recent version of shiny from the rstudio github
Turn off regex escaping
By default, DataTables escapes regex characters in search terms. However, since DataTables 1.10, there's an option to disable the escaping and allow regex searches. We can use options to pass the option to datatable, like this:
library(DT)
datatable(mtcars,
options = list(search = list(regex = TRUE)))
Now your seaches can use regular expressions. For example, to filter the table for Mazda or Chrysler, you could search Mazda|Chrysler.
Here's the official RStudio page on the matter.
Example app
library(shiny)
library(DT)
ui <- fluidPage(
fluidRow(
column(width = 9,
br(),
DT::dataTableOutput("dt")
),
column(width = 3,
br(),
radioButtons("regex", "Enable Regex?", choices = c("yes", "no"), inline = T))
)
)
server <- function(input, output, session) {
output$dt <- DT::renderDataTable({
value <- ifelse(input$regex == "yes", TRUE, FALSE)
datatable(mtcars,
options = list(search = list(regex = value))
)
})
}
shinyApp(ui, server)