Shiny: Merge cells in DT::datatable
It is possible with the help of the datatables-rowsgroup library. Here is an example:
library(shiny)
library(DT)
dat <- iris[c(1,2,3,51,52,53,101,102,103), c(5,1,2,3,4)]
ui <- fluidPage(
DTOutput("table")
)
server <- function(input, output){
output[["table"]] <- renderDT({
dtable <- datatable(dat, rownames = FALSE,
options = list(
rowsGroup = list(0) # merge cells of column 1
))
path <- "U:/Data/shiny/DT/www" # folder containing dataTables.rowsGroup.js
dep <- htmltools::htmlDependency(
"RowsGroup", "2.0.0",
path, script = "dataTables.rowsGroup.js")
dtable$dependencies <- c(dtable$dependencies, list(dep))
dtable
})
}
shinyApp(ui, server)
Shiny merge cells in DT::table on two or more columns
All you need to do is use the answer you linked (with the datatables-rowsgroup plugin) and specify extra columns to merge on duplicate results:
dtable <- datatable(
dat,
rownames = FALSE,
options = list(
rowsGroup = list(0,4))) # merge cells of column 1 and 5
How to merge 2 row cells in data table?
The first cell text should be in the upper header, not in the second.
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
h4(strong("Base data frame:")),
tableOutput("data"),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
req(results())
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(rowspan = 2, colnames(results())[1], style = "border-right: solid 1px;"),
tags$th(colspan = 10, sprintf('From state where initial period = %s', input$transFrom))
),
tags$tr(
mapply(tags$th, colnames(results())[-1], style = sprintf("border-right: solid %spx;", rep(0, ncol(results()) - 1L)), SIMPLIFY = FALSE)
)
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers" # hides Next and Previous buttons
, autoWidth = T
, info = FALSE # hide the "Showing 1 of 2..." at bottom of table
, searching = FALSE # removes search box
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
}
shinyApp(ui, server)
Merge columns in DT::datatable
This may work for you, using htmltools
library(shiny)
library(DT)
library(htmltools)
tbl <- data.frame("A" = c( 1L, "question"),
"B" = c( 2L, "answer"))
container_dt= withTags(table(
class = 'display',
thead(
tr(
th(class = 'dt-center',colspan = 2, 'AB')),
tr(
lapply((c('foo', 'bar')), th)))))
ui <- fluidPage(
dataTableOutput("table")
)
server <- function(input, output) {
output$table <- renderDT({
datatable(tbl, container = container_dt, rownames = F, class = "",
options = list(autoWidth = T,
columnDefs = list(list(className = "dt-center", targets = "_all"),
list(width = "40px", targets = "_all"))))
})
}
shinyApp(ui = ui, server = server)
Editing multiple cells in a datatable in shiny
See below, this will allow multiple changes and each one is tracked.
library(shiny)
library(shinydashboard)
library(tidyverse)
library(DT)
header <- dashboardHeader(title = "demo")
sidebar <- dashboardSidebar(
sidebarMenu(id = 'sidebarmenu',
menuItem("admin", tabName = "admin", icon = icon("adjust")),
downloadButton("downloadResults","Download Results")
)
)
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'admin', class = 'active',
fluidRow(
box(
dataTableOutput('userTable'), width = 6
)
)
)
)
)
ui <- dashboardPage(title = 'admin function test', header, sidebar, body, skin='blue')
server <- function(input, output, session){
dat <- data.frame(userName = c("John","Mary","Mike"), start = c("06/08/2019","01/01/2019","23/10/2019"), stringsAsFactors = FALSE)
output$userTable <- renderDataTable({
DT::datatable(isolate(dat),
editable = TRUE,
rownames = FALSE)
})
###Tracking Changes###
rvs <- reactiveValues(
data = NA #dynamic data object
)
observe({
rvs$data <- dat
})
proxy = dataTableProxy('userTable')
observe({
DT::replaceData(proxy, rvs$data, rownames = FALSE, resetPaging = FALSE)
})
observeEvent(input$userTable_cell_edit, {
rvs$data <<- editData(rvs$data, input$userTable_cell_edit, rownames = FALSE)
})
# observeEvent(
# input$do,{
# write.csv(rvs$data,'userTest.csv', row.names = FALSE)
# })
output$downloadResults <- downloadHandler(
filename = function(){paste("userTest.csv.csv", sep = "")},
content = function(file){write.csv(rvs$data, file, row.names = FALSE)}
)
}
shinyApp(ui = ui, server = server)
If you want multiple cells to be editable at the same time, add this line to your datatable:
editable = list(target = "all") #can be all, row, or column
Few tips when posting in the future:
- Create a reproducible example, having it pull data/save data from a file on your computer can't be reproduced
- Keep the code simple as possible to focus on your issue. Throwing
renderUI's for the body and sidebar just clutters your code.
How to extend a table cell across multiple columns when rendered in R Shiny?
We could use a custom container to add the column group names as real column headers:
# ui.R
ui <- fluidPage(
DT::dataTableOutput("table")
)
# server.R
library(DT)
df <- data.frame(A = c(1, 1, 1), B = c(1, 1, 1), C = c(1, 1, 1),
D = c(2, 2, 2), E = c(2, 2, 2), F = c(2, 2, 2),
G = c(3, 3, 3), H = c(3, 3, 3), I = c(3, 3, 3))
myContainer <- htmltools::withTags(table(
class = 'display',
thead(
tr(
th(),
th(colspan = 3, 'Trial 1', class = "dt-center"),
th(colspan = 3, 'Trial 2', class = "dt-center"),
th(colspan = 3, 'Trial 3', class = "dt-center")
),
tr(
th(),
lapply(names(df), th)
)
)
))
server <- function(input, output) {
output$table <- DT::renderDataTable({
DT::datatable(df, container = myContainer,
options = list(dom = "t", ordering = FALSE,
columnDefs = list(list(className = "dt-center", targets = "_all"))
))
})
}
runApp(list(ui = ui, server = server))
Output:
Alternativly, if you really want that first row to have colspans we can use the initComplete option to call a JavaScript function when the table is rendered. Here is the server part only:
jsc <- '
function(settings, json) {
$("td:contains(\'Trial\')").attr("colspan", "3").css("text-align", "center");
$("tbody > tr:first-child > td:empty").remove();
}'
server <- function(input, output) {
output$table <- DT::renderDataTable({
df <- data.frame(A = c("Trial 1", 1, 1, 1), B = c("", 1, 1, 1), C = c("", 1, 1, 1),
D = c("Trial 2", 2, 2, 2), E = c("", 2, 2, 2), F = c("", 2, 2, 2),
G = c("Trial 3", 3, 3, 3), H = c("", 3, 3, 3), I = c("", 3, 3, 3))
DT::datatable(df, options = list(dom = "t", ordering = FALSE, initComplete = JS(jsc)))
})
}
In the first row of the JS function we select all cells that contain the word Trial and add the corresponding attributes and styles. Afterwards we select all empty cells, that are a direct descendant of a row element which in turn is the first child of the body of the table and remove them from the DOM. Here you find a general reference on CSS selectors like >.
Output:
How to merge 2 row headers in a single column in a data table and insert a reactive object?
Please reference these related posts that lead to the solution shown at the bottom. The posts that built up to this solution are How to merge to row cells in data table?, How to add a vertical line to the first column header in a data table?, and How to add reactive object to secondary column header in output table?
Solution:
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X0")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")), # < left-align the table
h4(strong("Base data frame:")),
tableOutput("data"),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
req(results())
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(rowspan = 2, sprintf('To state where end period = %s', input$transTo), style = "border-right: solid 1px;"),
tags$th(colspan = 10, sprintf('From state where initial period = %s', input$transFrom))
),
tags$tr(
mapply(tags$th, colnames(results())[-1], style = sprintf("border-right: solid %spx;", rep(0, ncol(results()) - 1L)), SIMPLIFY = FALSE)
)
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers" # hides Next and Previous buttons
, autoWidth = T
, info = FALSE # hide the "Showing 1 of 2..." at bottom of table
, searching = FALSE # removes search box
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
}
shinyApp(ui, server)
Combining selectInput and DT::datatable editing in Shiny
A few modifications to achieve expected behavior :
dtProxyshould be created only once at server launchobserveEvent(input$dt_cell_edit,...)should be independent ofobserveEvent(input$s_internal_idNew,...)df_showed()should also be updated, asdf()
library(tidyverse); library(DT); library(shiny)
df <- data.frame(internal_idNew=c(1, 2, 3, 4), col_1=c("this", "is", "a", "column"))
ui <- fluidPage(
#filter df
selectInput("s_internal_idNew", "Record id (new)", choices=c(1:nrow(df))),
#dt output
dataTableOutput("dt")
)
server <- function(input, output) {
#reactive df
df <- reactiveVal({df})
#reactive df filtered
df_showed <- reactiveVal({})
#create proxy dt once
dt_proxy <- dataTableProxy("dt")
observeEvent(input$s_internal_idNew, {
#filter a row matching the internal id
df_showed(df() %>% filter(internal_idNew==input$s_internal_idNew))
#render dt
output$dt <- DT::renderDataTable(df_showed(), editable=list(target = "cell", disable = list(columns =c(0))), options=list(dom = 't', bSort=FALSE, pageLength=1), rownames = FALSE, selection = "none")
})
#edit dt - separate from previous reactive
observeEvent(input$dt_cell_edit, {
this <- df()
showed <- df_showed()
#extract edited value to edit df
col_name <- showed %>% names() %>% .[input$dt_cell_edit$col+1]
row_name <- input$s_internal_idNew %>% as.numeric()
value_name <- coerceValue(input$dt_cell_edit$value, showed[row_name, col_name])
#store edited values in reactive df
this[row_name, col_name] <- value_name
df(this)
df_showed(this[row_name, ]) # Also updated
#replace data in datatable
replaceData(dt_proxy, df_showed(), resetPaging = TRUE, rownames = FALSE)
})
}
shinyApp(ui = ui, server = server)
How to change color of cells in a DT::dataTable in shiny, based on cells in another column?
Your code gives the following error:
renderDataTable ignores ... arguments when expr yields a datatable object;
Since you now return a DT::datatable object to renderDT and not a dataframe. This is a bit similar to this Q/A. So now you have to move all arguments to the DT::datatable constructor:
render_dt = function(data) {
renderDT(data)
}
and
dt_d9 <- datatable(d9, editable = 'cell', rownames = FALSE, extensions = 'Buttons', options = list(dom = 'Bfrtip', buttons = I('colvis'))) %>% formatStyle(
'R/Y/G', 'Y', #'R/Y/G' is the column cell I'm trying to change values for based on column 'Y'
backgroundColor = styleEqual(c(0, 1), c('red', 'yellow'))
)
output$x9 = render_dt(dt_d9)
Related Topics
Can't Loop with R's Leaflet Package to Produce Multiple Maps
Counting Non Nas in a Data Frame; Getting Answer as a Vector
Make R Exit with Non-Zero Status Code
Get Date Difference in Years (Floating Point)
Calculating Time Difference Between Two Columns
Shiny Renderui Selectinput Returned Null
Correctly Specifying "Logical Conditions" (In R)
Control the Size of Points in an R Scatterplot
Dplyr - Groupby on Multiple Columns Using Variable Names
Change the Position of the Strip Label in Ggplot from the Top to the Bottom
R Data.Table Apply Function to Rows Using Columns as Arguments
What Does the Function Invisible() Do
Output in R, Avoid Writing "[1]"
Assign a Value, If a Number Is in Between Two Numbers
Row-Wise Sort Then Concatenate Across Specific Columns of Data Frame
Dplyr Replacing Na Values in a Column Based on Multiple Conditions