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 !
Related
I have created a DT datatable that works, but is currently looking like this:
I would like to: 1) align the header row with the table content and 2) and remove the horizontal line at the bottom of the table.
I have tried the solution to remove the horizontal line: R DT:datatable remove .no-footer border-bottom but it results in the table not displaying.
How do I do this?
My code:
library(shiny)
library(DT)
# Define UI for application that draws a histogram
column_names <- c(toupper(letters[1:26]),tolower(letters[1:26]))
df <- data.frame(replicate(length(column_names),sample(0:1,1000,rep=TRUE)))
# assign column names
colnames(df) = column_names
ui <- fluidPage(
checkboxGroupInput(
"column_selection",
h3("Select fields to display"),
choices = column_names,
inline = TRUE,
selected = c('A','B','C')
),
DT::dataTableOutput("alphabet")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$alphabet <- DT::renderDT({
columns = column_names
if (!is.null(input$column_selection)) {
columns = input$column_selection
}
datatable(
df[, columns, drop = FALSE],
rownames = FALSE,
class = "row-border hover stripe",
extensions = c('Buttons'),
options = list(
# change colour of header row
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': 'black', 'color': 'white'});",
"}"),
dom = 'Brtip',
autoWidth = T,
scrollX = T,
buttons = list(c('copy', 'csv', 'excel'))
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
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.
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 would like to be able to apply a function to a given set of columns from the RLdata10000 dataset. I have been going through shiny tutorials and am attempting to learn how to use observeEvent and actionButton. However, I would like to be able to pick the columns I use so I came across pickerInput. In short, I would like to be able to pick a set of columns from RLdata10000, and apply the function via actionButton.
My problem is that I get an error: Error: unused argument (RLdata10000). My code is below. I would like to be able to do this with two data files eventually. Any help would be appreciated.
library(shiny)
library(DT)
library(shinyWidgets)
library(plyr)
library(dplyr)
library(RecordLinkage)
data(RLdata10000)
cleanup <- function(x){
x <- as.character(x) # convert to character
x <- tolower(x) # make all lowercase
x <- trimws(x, "both") # trim white space
return(x)
}
ui <- basicPage(
h2("Record Linkage Data"),
actionButton(inputId = "clean", label = "Clean Data")
pickerInput(width = "75%",
inputId = "pick_col1",
label = "Select columns to display",
choices = colnames(RLdata10000),
selected = colnames(RLdata10000),
options = list(
`actions-box` = T,
`selected-text-format` = paste("count > ", length(colnames(RLdata10000)) - 1),
`count-selected-text` = "Alle",
liveSearch = T,
liveSearchPlaceholder = T
),
multiple = T)
DT::dataTableOutput("mytable")
)
server <- function(input, output) {
observeEvent(input$clean, {
output$mytable = DT::renderDataTable({
lapply(input$pick_col1, cleanup)
})
}
}
shinyApp(ui, server)
I wasn't actually able to replicate the error you noted, but you had a few issues that were preventing you from getting what (I think) you're after.
First, you were missing commas in the UI after the actionButton and pickerInput elements.
Second, you are only giving lapply the names of columns - not the data - when you use input$pick_col1, so your cleanup function has nothing to work on. Using select from dplyr provides a simple way to name the columns and get the data too.
Last, renderDataTable wants a table format as an input (i.e., either a data frame or a matrix), but lapply produces a list. You need to convert the output of lapply into a workable class.
From these three changes, updated code would look like this:
library(shiny)
library(DT)
library(shinyWidgets)
library(plyr)
library(dplyr)
library(RecordLinkage)
data(RLdata10000)
cleanup <- function(x){
x <- as.character(x) # convert to character
x <- tolower(x) # make all lowercase
x <- trimws(x, "both") # trim white space
return(x)
}
ui <- basicPage(
h2("Record Linkage Data"),
actionButton(inputId = "clean", label = "Clean Data"),
pickerInput(width = "75%",
inputId = "pick_col1",
label = "Select columns to display",
choices = colnames(RLdata10000),
selected = colnames(RLdata10000),
options = list(
`actions-box` = T,
`selected-text-format` = paste("count > ", length(colnames(RLdata10000)) - 1),
`count-selected-text` = "Alle",
liveSearch = T,
liveSearchPlaceholder = T
),
multiple = T),
DT::dataTableOutput("mytable")
)
server <- function(input, output) {
observeEvent(input$clean, {
output$mytable = DT::renderDataTable({
data.frame(lapply(select(RLdata10000, input$pick_col1), cleanup))
})
})
}
shinyApp(ui, server)
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