Related
A similar question was posted but never answered: r shiny problem with datatable to copy a table with table head (colspan)
When running the below reproducible code, I'd like the DT "copy" button to include ALL table column and row headers, when there are multiple headers. So far DT copy only copies one header.
I have the code to do this using an action button/observeEvent() outside of DT (not shown in below code), but if possible I'd instead like to use DT's native copy clipboard function (like in the code below) because of other benefits it offers including but not limited to simplicity.
The images at the bottom better explain.
Maybe it's not possible. But maybe it is!
Reproducible code:
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","X9")
)
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;}")),
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, {
datatable(
data = results(),
rownames = FALSE,
extensions = c("Buttons", "Select"), # for Copy button
selection = 'none', # for Copy button
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,
buttons = list(list(extend = "copy",text = 'Copy',exportOptions = list(modifier = list(selected = TRUE)))), # for Copy button
dom = 'Bft', # added 'B' for Copy button
lengthChange = T,
pagingType = "numbers",
autoWidth = T,
info = FALSE,
searching = FALSE)
) %>%formatStyle(c(1), `border-right` = "solid 1px")
})
}
shinyApp(ui, server)
Additional example:
Below is another, simpler example of trying to copy/paste all headers using DT, starting with the example used in post How to copy tableOutput to clipboard? (however adding the "sketch" container to datatable for a second column header to illustrate the copy/paste issue I'm trying to address):
library(shiny)
library(dplyr)
library(DT)
library(htmltools)
df <- mtcars
one <- function(.data, var, na = TRUE) {
return({
.data %>%
group_by(.data[[var]]) %>%
filter(!is.na(.data[[var]])) %>%
tally() %>%
mutate(`%` = 100*n/sum(n))
})
}
# ADDED SKETCH TO ORIGINAL EXAMPLE:
sketch = htmltools::withTags(table(
class = 'display',
thead(tr(th(colspan = 3, 'Table')),
tr(lapply(c('Variable','n','%'),th))
)
))
ui <- fluidPage(
selectInput("var", label = "Select Variable", choices = c("", names(df))),
DTOutput("valu", width = "15%")
)
server <- function(input, output) {
output$valu <- renderDT({
if(input$var != '') {
data <- df %>% one(input$var, na = input$check)
DT::datatable(data,
class = 'cell-border stripe',
rownames = FALSE,
extensions = c("Buttons", "Select"),
selection = 'none',
container = sketch, # ADDED SKETCH CONTAINER TO ORIGINAL EXAMPLE
options =
list(
select = TRUE,
dom = "Bt",
buttons = list(
list(
extend = "copy",
text = 'Copy'))
)) %>% formatStyle(
0,
target = "row",
fontWeight = styleEqual(1, "bold")
)
}
}, server = FALSE)
output$value <- renderTable({
if(input$var != '') {
data <- df %>% one(input$var, na = input$check)
return(data)
}
}, spacing = "xs", bordered = TRUE)
}
shinyApp(ui, server)
Hmm... for Copy I don't know yet. But you can export such a table to Excel and then copy from Excel. I agree this is not highly convenient, but I don't know another way. This requires some JS libraries:
tags$script(src = "xlsx.core.min.js"), # https://github.com/SheetJS/sheetjs/blob/master/dist/xlsx.core.min.js
tags$script(src = "FileSaver.min.js"), # https://raw.githubusercontent.com/eligrey/FileSaver.js/master/dist/FileSaver.min.js
tags$script(src = "tableexport.min.js"), # https://github.com/clarketm/TableExport/tree/master/dist
tags$link(rel = "stylesheet", href = "tableexport.min.css")
library(shiny)
library(DT)
library(shinyjs)
js_export <-
"
var $table = $('#DTtable').find('table');
var instance = $table.tableExport({
formats: ['xlsx'],
exportButtons: false,
filename: 'myTable',
sheetname: 'Sheet1'
});
var exportData0 = instance.getExportData();
var exportData = exportData0[Object.keys(exportData0)[0]]['xlsx'];
instance.export2file(exportData.data, exportData.mimeType, exportData.filename,
exportData.fileExtension, exportData.merges,
exportData.RTL, exportData.sheetname);
"
ui <- fluidPage(
useShinyjs(),
tags$head(
# put these files in the www subfolder
tags$script(src = "xlsx.core.min.js"),
tags$script(src = "FileSaver.min.js"),
tags$script(src = "tableexport.min.js")
),
DTOutput("DTtable"),
actionButton("export", "Export table", class = "btn-primary")
)
sketch <- htmltools::withTags(table(
class = "display",
thead(
tr(
th(rowspan = 2, "Species"),
th(colspan = 2, "Sepal"),
th(colspan = 2, "Petal")
),
tr(
lapply(rep(c("Length", "Width"), 2), th)
)
)
))
server <- function(input, output, session){
output[["DTtable"]] <- renderDT({
datatable(
head(iris, 6),
container = sketch, rownames = FALSE
) %>%
formatPercentage("Sepal.Length") %>%
formatCurrency("Sepal.Width")
})
observeEvent(input[["export"]], {
runjs(js_export)
})
}
shinyApp(ui, server)
Note that it also takes the formatting into account, but I'm wondering why there are some dates :-/
I am trying to build a feedback system. Here is a simplified example what I am trying to build. I have a DT:datatable that is rendered with a feedback column, based on a selected input choice.
The feedback is submitted through the observeEvent on a submit button. All the UI and server components are mostly as I want.
library(shiny)
library(shinydashboard)
ui <- ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
fluidPage(
fluidRow(
uiOutput('rec_ui')
))
)
)
server <- function(input, output, session) {
mtcarsData <- reactive({
req(input$cyl)
mtcars %>%
filter(cyl == input$cyl) %>%
select(am, wt, hp, mpg)
})
output$rec_ui <- renderUI({
mtcarsData()
mainPanel(
actionButton(
'feedbackButton', 'Submit Feedback', class = 'btn-primary'
),
dataTableOutput(('rec')),
width = 12
)
})
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
observeEvent(input$feedbackButton, {
mtcars <- mtcarsData()
feedbackInput <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcars), function(row_id)
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcars$mpg[row_id],
recommendation_feedback = feedbackInput[row_id],
feedback_timestamp = as.character(Sys.time())
)
)
)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- DT::renderDataTable({
df <- mtcarsData()
feedbackCol <- lapply(1:nrow(df), function(recnum)
as.character(
radioButtons(
paste0('rec', recnum), '',
choices = c('neutral' = 'Neutral', 'good' = 'Good', 'bad' = 'Bad'),
inline = TRUE
)
)
)
feedbackCol <- tibble(Feedback = feedbackCol)
df <- bind_cols(
df,
feedbackCol
)
df %>%
DT::datatable(
extensions = 'FixedColumns',
rownames = FALSE,
escape = FALSE,
class="compact cell-border",
options = list(
pageLength = 10,
lengthChange = FALSE,
scrollX = TRUE,
searching = FALSE,
dom = 't',
ordering = TRUE,
fixedColumns = list(leftColumns = 2),
preDrawCallback = JS(
'function() { Shiny.unbindAll(this.api().table().node()); }'
),
drawCallback = JS(
'function() { Shiny.bindAll(this.api().table().node()); } '
),
autoWidth = TRUE,
columnDefs = list(
list(width = '250px', targets = -1)
)
)
)
})
}
shinyApp(ui = ui, server = server)
However, upon submission, one of two things happens:
App crashes with the following error in write.table. But, the root causes is that this line of code is returning a list of NULL values instead of my feedback inputs.
Warning: Error in write.table: unimplemented type 'list' in 'EncodeElement'
feedbackInputData <- reactive({
mtcars <- mtcarsData()
recsInput <- sapply(1:nrow(mtcars), function(row_id)
input[[paste0('rec', row_id)]]
)
})
When the app does not crash, and Feedback gets submitted, but the new inputs don't take effect. Only the first ever submission is repeated written to the CSV.
Any idea where I am going wrong with this app?
Additional Info: It is my hunch that the crash happens when I get from a selection from 'fewer rows' DT to more rows, and not the other way. For example, if I select 8 CYL first, which has more cars, and then 4, the app does not crash on submit. But the reverse, it does. BTW - in either case, my feedback does not get updated.
To avoid the app from crashing write the line
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
just before write.table()
Please note that lapply returns a list, hence your first issue.
Next, recycling input IDs in radio buttons is also an issue. By defining unique IDs, you can make it work. Lastly, to ensure that the radio buttons work all the time, it is best to define new IDs. If the IDs are fixed for a given cyl value, it will only work the first time. Subsequent selection of that cyl will display the initial selection, which can be updated via updateradioButtons, but that will not be reactive. Try this and modify display table to your needs.
library(DT)
library(data.table)
library(shiny)
#library(shinyjs)
library(shinydashboard)
options(device.ask.default = FALSE)
ui <- dashboardPage(
header = dashboardHeader(title='Car Recommendations'),
sidebar = dashboardSidebar(
width = 450,
fluidRow(
column(
width = 9,
selectInput(
"cyl", 'Select Cylinder Count:',
choices = c('', sort(unique(mtcars$cyl)))
)
)
)
),
body = dashboardBody(
#useShinyjs(),
fluidPage(
fluidRow(
actionButton('feedbackButton', 'Submit Feedback', class = 'btn-primary'),
DTOutput('rec'),
verbatimTextOutput("sel")
))
)
)
server <- function(input, output, session) {
cntr <- reactiveVal(0)
rv <- reactiveValues()
mtcarsData <- reactive({
mtcar <- mtcars %>% filter(cyl == input$cyl) %>%
select(cyl, am, wt, hp, mpg)
})
observe({
req(input$cyl,mtcarsData())
mtcar <- mtcarsData()
id <- cntr()
m = data.table(
rowid = sapply(1:nrow(mtcar), function(i){paste0('rec',input$cyl,i,id)}),
Neutral = 'Neutral',
Good = 'Good',
Bad = 'Bad',
mtcar
) %>%
mutate(Neutral = sprintf('<input type="radio" name="%s" value="%s" checked="checked"/>', rowid, Neutral),
Good = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Good),
Bad = sprintf('<input type="radio" name="%s" value="%s"/>', rowid, Bad)
)
rv$df <- m
print(id)
})
observeEvent(input$cyl, {
cntr(cntr()+1)
#print(cntr())
},ignoreInit = TRUE)
feedbackInputData <- reactive({
dfa <- req(rv$df)
list_values <- list()
for (i in unique(dfa$rowid)) {
list_values[[i]] <- input[[i]]
}
list_values
})
observeEvent(input$feedbackButton, {
req(input$cyl)
mtcar <- rv$df ## this could be mtcarsData(), if picking columns not in rv$df but only in mtcarsData()
dt <- rv$df
dt$Feedback <- feedbackInputData()
recFeedbackDf <- bind_rows(
lapply(1:nrow(mtcar), function(row_id){
list(
shiny_session_token = session$token,
recommendation_type = 'CAR',
input_cyl = input$cyl,
recommended_mpg = mtcar$mpg[row_id],
recommendation_feedback = dt$Feedback[row_id],
feedback_timestamp = as.character(Sys.time())
)
})
)
recFeedbackDf <- apply(recFeedbackDf,2,as.character)
write.table(
recFeedbackDf, 'feedback.csv', row.names = FALSE,
quote = FALSE, col.names = FALSE, sep = '|',
append = TRUE
)
showModal(
modalDialog(
'Successfully submitted', easyClose = TRUE,
footer = NULL, class = 'success'
)
)
})
output$rec <- renderDT(
datatable(
rv$df,
selection = "none",
escape = FALSE,
options = list(
columnDefs = list(list(visible = FALSE, targets = c(0,4))), ## not displaying rowid and cyl
dom = 't',
paging = FALSE,
ordering = FALSE
),
callback = JS(
"table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-radiogroup');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());"
),
rownames = F
),
server = FALSE
)
### verify if the radio button values are being returned
output$sel = renderPrint({
req(feedbackInputData())
feedbackInputData()
})
}
shinyApp(ui = ui, server = server)
I am building a shiny app with datatables.
What I want is that there are no records (rows) shown on startup. So that you only see the filters at the top of the table. When you start typing the rows are shown.
I can't find an option in Datatables. Is this possible?
An example code is here below.
shinyApp(
ui = navbarPage(
title = 'DataTable',
DT::dataTableOutput('ex2')
),
server = function(input, output, session) {
output$ex2 <- DT::renderDataTable(
DT::datatable(
iris,
options = list(
dom = 'Bfrtip',
lengthMenu = list(c(5, 15, -1), c('5', '15', 'All'))
)
)
)
}
)
You could make your own search functionality:
EDIT: added second character column that is being searched.
shinyApp(
ui = navbarPage(
title = 'DataTable',
textInput('search', 'search'),
DT::dataTableOutput('ex2')
),
server = function(input, output, session) {
require(dplyr)
iris.mut <- iris %>%
mutate(bottom = paste0('v',sapply(Sepal.Width,function(x)paste0(rep('z',x*2),collapse="")),'bx'))
dat <- reactive({
if(input$search!=''){
iris.mut %>%
filter(grepl(input$search,Species)|grepl(input$search,bottom))
} else {
iris.mut %>%
filter(Species == input$search)
}
})
output$ex2 <- DT::renderDataTable(
DT::datatable(
dat(),
options = list(
lengthMenu = list(c(5, 15, -1), c('5', '15', 'All'))
)
))
}
)
Probably not the most efficient way, but I would use a dummy data.frame to show at startup. When you select the filters (e.g. selectizeInput()), the "real" data is shown.
output$ex2 <- renderDT({
myFilter <- input$myFilter
# assuming selectizeInput() is used
if(is.null(myFilter)){
irisDF <- data.frame(Sepal.Length = "",
Sepal.Length = "",
Petal.Length = "",
theREst = "")
} else {
irisDF <- iris
}
DT::datatable(irisDF, options = list(
dom = 'Bfrtip',
lengthMenu = list(c(5, 15, -1), c('5', '15', 'All')))
)
})
The row names of the iris dataframe are "1", "2", "3", ...
When I set the 0-th column as orderable with DT, the ordering behaves as if the row names were numeric:
library(DT)
datatable(iris,
options = list(
columnDefs = list(
list(orderable=TRUE, targets=0)
)
)
)
Nice. Now, when I do the same inside shiny, the behaviour is different: the ordering behaves as if the row names were character strings:
library(shiny)
shinyApp(
ui = fluidPage(fluidRow(column(12, DTOutput('tbl')))),
server = function(input, output) {
output$tbl = renderDT(
iris, options = list(
columnDefs = list(
list(orderable=TRUE, targets=0)
)
)
)
}
)
Not nice. What is the cause of the difference? I'd like to have the first behavior in Shiny. As a workaround, we could set a numeric column at the first position and set rownames=FALSE, but I'm wondering whether there's an easier solution and I'm intrigued by this difference.
EDIT
I've finally proceed in this way:
output$tbl = renderDT({
dt <- datatable(
iris, options = list(
columnDefs = list(
list(orderable=TRUE, targets=0)
)
)
)
dt$x$data[[1]] <- as.numeric(dt$x$data[[1]])
dt
})
SO is telling me I need 50 reputation to comment, so here's my comment in answer form.
Another workaround would be to do the following:
output$tbl = renderDT({
dt <- datatable(
iris %>%
rownames_to_column("UID") %>%
select(UID, everything()),
options = list(
columnDefs = list(
list(orderable=TRUE, targets=0)
)
)
)
dt
It doesn't answer your question of why it happens though.
I am building a shiny app with a timeline and a data table. What I would like to have happen is when the user clicks on an item in the timeline, the corresponding data in the table is highlighted.
I have come up with a solution for this, but it seems very hacky and R is giving me warning messages. Basically what I have done is created a flag in the data table that is 1 if that item is selected and 0 if it's not, then I format the row based on that flag. When I create the "selected" field, I get a warning because initially nothing is selected and mutate doesn't like the fact that input$timeline_selected is NULL. Also for some reason when I try to add the rownames = FALSE argument to datatable all the data in the table is filtered out (not sure what is happening there).
Anyway, I'm wondering if there is a better way to do this perhaps with HTML or CSS. I've tried looking, but I can't figure out how to do it.
Eventually I would also like to know how to highlight the rows in the data table if the user hovers over the item in the timeline rather than selects it.
library(shiny)
library(DT)
library(dplyr)
dataBasic <- data.frame(
id = 1:4,
content = c("Item one", "Item two" ,"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
end = c(NA, NA, "2016-02-04", NA)
)
ui <- fluidPage(
column(wellPanel(timevisOutput("timeline")
), width = 7
),
column(wellPanel(dataTableOutput(outputId = "table")
), width = 5)
)
server <- function(input, output){
# Create timeline
output$timeline <- renderTimevis({
config <- list(
orientation = "top",
multiselect = TRUE
)
timevis(dataBasic, options = config)
})
output$table <- DT::renderDataTable({
input$timeline_data %>%
mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>%
datatable(options = list(pageLength = 10,
columnDefs = list(list(targets = 5, visible = FALSE))
)
) %>%
formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
)
})
}
shinyApp(ui = ui, server = server)
Using Your Code
Your method certainly works -- it's similar to this answer. You could prevent some of the error messages by using if...else and a validation statment:
output$table <- DT::renderDataTable({
validate(need(!is.null(input$timeline_data), ""))
if(is.null(input$timeline_selected)) {
input$timeline_data %>%
datatable(
rownames = FALSE,
options = list(pageLength = 10))
} else {
input$timeline_data %>%
mutate(selected = if_else(id %in% input$timeline_selected, 1, 0)) %>%
datatable(rownames = FALSE,
options = list(pageLength = 10,
columnDefs = list(list(targets = 4, visible = FALSE))
)
) %>%
formatStyle("selected", target = "row", backgroundColor = styleEqual(c(0, 1), c("transparent", "#0092FF"))
)
}
})
I believe your issue with adding rownames = FALSE is because columnDefs uses JS indexing instead of R indexing. R indexes start at 1, whereas JS indexes start at 0.
When rownames = TRUE, your table has column indexes 0-5, where rownames is column 0 and selected is the column 5. So columnDefs works. However, when rownames = FALSE, you only have column indexes 0-4, so targets = 5 is outside the index range of your table. If you change your code to targets = 4, then you will again be specifying the selected column in columnDefs.
Other Options
Here's two other options using JS:
Generate the table on the server-side, as based on this answer. This may be a better option for large data objects.
Generate the table on the client-side as based on this answer. With a smaller object, this seems to update more smoothly.
An example app with both tables is below.
Example Code
library(shiny)
library(DT)
library(dplyr)
library(timevis)
dataBasic <- data.frame(
id = 1:4,
content = c("Item one", "Item two" ,"Ranged item", "Item four"),
start = c("2016-01-10", "2016-01-11", "2016-01-20", "2016-02-14"),
end = c(NA, NA, "2016-02-04", NA)
)
ui <- fluidPage(
column(wellPanel(timevisOutput("timeline")
), width = 7
),
column(
wellPanel(
h3("Client-Side Table"),
DT::dataTableOutput("client_table"),
h3("Server-Side Table"),
DT::dataTableOutput("server_table")
), width = 5)
)
server <- function(input, output, session){
# Create timeline
output$timeline <- renderTimevis({
config <- list(
orientation = "top",
multiselect = TRUE
)
timevis(dataBasic, options = config)
})
## client-side ##
# based on: https://stackoverflow.com/a/42165876/8099834
output$client_table <- DT::renderDataTable({
# if timeline has been selected, add JS drawcallback to datatable
# otherwise, just return the datatable
if(!is.null(input$timeline_selected)) {
# subtract one: JS starts index at 0, but R starts index at 1
index <- as.numeric(input$timeline_selected) - 1
js <- paste0("function(row, data) {
$(this
.api()
.row(", index, ")
.node())
.css({'background-color': 'lightblue'});}")
datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10,
drawCallback=JS(js)))
} else {
datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10))
}
}, server = FALSE)
## server-side ##
# based on: https://stackoverflow.com/a/49176615/8099834
output$server_table <- DT::renderDataTable({
# create the datatable
dt <- datatable(dataBasic,
rownames = FALSE,
options = list(pageLength = 10))
# if timeline has been selected, add row background colors with formatstyle
if(!is.null(input$timeline_selected)) {
index <- as.numeric(input$timeline_selected)
background <- JS(paste0("value == '",
index,
"' ? 'lightblue' : value != 'else' ? 'white' : ''"))
dt <- dt %>%
formatStyle(
'id',
target = 'row',
backgroundColor = background)
}
# return the datatable
dt
})
}
shinyApp(ui = ui, server = server)