header direction in shiny data table - css

I've been using DT in my shiny apps for a while. I'm wondering if there is any option (easy way) to change a table header direction when the text is long (like rotate all colnames by 45 degree or something), This is a problem when you have many columns in a table.
Thanks,
Here is a short example:
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Table", br(),
dataTableOutput("myTable"))
), width = 9
)
)
server <- function(input, output) {
output$myTable <- renderDataTable({
test <- data.frame(1:20, letters[1:20], stringsAsFactors = FALSE)
colnames(test) <- c("This is a long name", "This column name is much more longer!")
datatable(test, rownames = FALSE, options = list(autoWidth = TRUE, searching = TRUE, lengthMenu = list(c(5, 10, 25, 50, -1), c('5', '10', '25', '50', 'All')), pageLength = 10)) # %>% formatStyle(names(test))
})
}
shinyApp(ui, server)

Here is a way to rotate the headers by 90 degrees.
library(DT)
library(shiny)
headerCallback <- c(
"function(thead, data, start, end, display){",
" var $ths = $(thead).find('th');",
" $ths.css({'vertical-align': 'bottom', 'white-space': 'nowrap'});",
" var betterCells = [];",
" $ths.each(function(){",
" var cell = $(this);",
" var newDiv = $('<div>', {height: 'auto', width: cell.height()});",
" var newInnerDiv = $('<div>', {text: cell.text()});",
" newDiv.css({margin: 'auto'});",
" newInnerDiv.css({",
" transform: 'rotate(180deg)',",
" 'writing-mode': 'tb-rl',",
" 'white-space': 'nowrap'",
" });",
" newDiv.append(newInnerDiv);",
" betterCells.push(newDiv);",
" });",
" $ths.each(function(i){",
" $(this).html(betterCells[i]);",
" });",
"}"
)
ui <- fluidPage(
DTOutput("table")
)
server <- function(input, output){
output[["table"]] <- renderDT({
datatable(iris,
options = list(
headerCallback = JS(headerCallback),
columnDefs = list(
list(targets = "_all", className = "dt-center")
)
))
})
}
shinyApp(ui, server)

Related

Make a nicer looking dropdown filter label with DataTables DT in R

I'm trying to make a datatable for a shiny dashboard that will have a dropdown filter on a column. I actually have it working, but the appearance is what I'd call subpar.
Here is my simple example
library(DT)
mytable <- data.frame(Col1 = as.factor(LETTERS[1:3]))
datatable(mytable, filter = "top")
When I have the dropdown active, the filter text input looks nice:
However, when I click away, it does not look as nice:
Is there any way to keep that nice looking A with an x in a bubble (sorry I'm sure there's a better term for that), or at least get rid of the bracket and quotation marks? I know that if the column values are characters rather than factors, I can get a nicer looking text input, but them I lose the dropdown functionality (related to this question Factor dropdown filter in DT::datatable in shiny dashboards not working), which I need.
mytable <- data.frame(Col1 = LETTERS[1:3], stringsAsFactors = FALSE)
datatable(mytable, filter = "top")
I'd be happy with a cell dropdown like the one in this post Edit datatable in Shiny with dropdown selection for factor variables, but I need to filter the table, not edit it.
Version info:
R version 3.5.3
DT_0.20
I know how to do that but with the dropdowns in the footer, I don't know how to put them at the top. The code uses the JavaScript library select2.
library(shiny)
library(DT)
dat <- iris
sketch <- htmltools::tags$table(
tableHeader(c("",names(dat))),
tableFooter(rep("", 1+ncol(dat)))
)
js <- c(
"function(){",
" this.api().columns().every(function(i){",
" var column = this;",
" var select = $('<select multiple=\"multiple\"><option value=\"\"></option></select>')",
" .appendTo( $(column.footer()).empty() )",
" .on('change', function(){",
" var vals = $('option:selected', this).map(function(index,element){",
" return $.fn.dataTable.util.escapeRegex($(element).val());",
" }).toArray().join('|');",
" column.search(vals.length > 0 ? '^('+vals+')$' : '', true, false).draw();",
" });",
" var data = column.data();",
" if(i == 0){",
" data.each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }else{",
" data.unique().sort().each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }",
" select.select2({width: '100%', closeOnSelect: false});",
" });",
"}")
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
),
br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(
dat, container=sketch,
options = list(
initComplete = JS(js),
columnDefs = list(
list(targets = "_all", className = "dt-center")
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)
Edit
To have the filters at the top:
library(shiny)
library(DT)
library(htmltools)
dat <- iris
sketch <- tags$table(
tags$thead(
tags$tr(
tags$th(),
lapply(names(dat), tags$th)
),
tags$tr(
tags$th(id = "th0"),
tags$th(id = "th1"),
tags$th(id = "th2"),
tags$th(id = "th3"),
tags$th(id = "th4"),
tags$th(id = "th5")
)
)
)
js <- c(
"function(){",
" this.api().columns().every(function(i){",
" var column = this;",
" var select = $('<select multiple=\"multiple\"><option value=\"\"></option></select>')",
" .appendTo( $('#th'+i).empty() )",
" .on('change', function(){",
" var vals = $('option:selected', this).map(function(index,element){",
" return $.fn.dataTable.util.escapeRegex($(element).val());",
" }).toArray().join('|');",
" column.search(vals.length > 0 ? '^('+vals+')$' : '', true, false).draw();",
" });",
" var data = column.data();",
" if(i == 0){",
" data.each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }else{",
" data.unique().sort().each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }",
" select.select2({width: '100%', closeOnSelect: false});",
" });",
"}")
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
),
br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(
dat, container=sketch,
options = list(
orderCellsTop = TRUE,
initComplete = JS(js),
columnDefs = list(
list(targets = "_all", className = "dt-center")
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)

Update datatable header without refreshing the whole application (R, Shiny) dataTableProxy()

I am trying to make a Shiny app.
(1) I want update data table without refreshing the whole application.
>>> I resolve it with isolate({}) and dataTableProxy().
(2) I want update the header (column name) without refreshing the whole application, for example (If the user choose in the selectInput 2020. The new colname in the table should update to year: 2020 without refreshing the whole application).
How can I do that?
library(DT)
library(data.table)
library(dplyr)
library(shiny)
ui <- fluidPage(
selectInput(inputId = 'choice', label = 'choice', choices = c('A', 'B'), selected = 'A'),
selectInput(inputId = 'country', label = 'country', choices = c('UK', 'USA', 'CANADA'), selected = 'UK'),
selectInput(inputId = 'year', label = 'year', choices = c(2020, 2021), selected = 2020),
uiOutput(outputId = "table")
)
server <- function(input, output, session) {
data_a <- data.frame(year = c(rep(2020,6), rep(2021,6)),
country = c('UK', 'UK', 'USA', 'USA', 'CANADA','CANADA'),
type_a = c('AA', 'BB'),
num = sample(10:22, 12))
dt_a <- reactive({
if (input$choice == 'A'){
return(data_a %>% filter(year == input$year & country == input$country))
}
})
output$rtable_a <- DT::renderDataTable({
if (input$choice == 'A'){
DT <- DT::datatable(isolate({dt_a()}),
rownames = FALSE,
options = list(processing = FALSE),
colnames = c('YEAR', 'COUNTRY', paste('year_a:', input$year), 'NUMBER')
)
return(DT)
}
})
proxy_a <- DT::dataTableProxy('rtable_a')
observe({
DT::replaceData(proxy_a, dt_a(), rownames = FALSE)
})
output$table <- renderUI({
if (input$choice == 'A'){
return(DT::dataTableOutput("rtable_a", width = '75%'))
}
})
}
shinyApp(ui, server)
Here is a solution using the JavaScript library jQuery contextMenu. Right-click on the column header and select the year.
library(shiny)
library(DT)
callback <- c(
"var choices = {1: '2020', 2: '2021'};",
"var id = $(table.table().node()).closest('.datatables').attr('id');",
"$.contextMenu({",
" selector: '#' + id + ' th:eq(3)',",
" trigger: 'right',",
" autoHide: true,",
" items: {",
" select: {",
" name: 'Select year:',",
" type: 'select',",
" options: choices,",
" selected: '1'",
" }",
" },",
" events: {",
" hide: function(opt){",
" var $this = this;",
" var i = $.contextMenu.getInputValues(opt, $this.data()).select;",
" var year = choices[i];",
" Shiny.setInputValue('year', year);",
" var text = 'year_a: ' + year;",
" var $th = opt.$trigger;",
" $th.text(text);",
" }",
" }",
"});"
)
data_a <- data.frame(
"YEAR" = c(rep(2020,6), rep(2021,6)),
"COUNTRY" = c('UK', 'UK', 'USA', 'USA', 'CANADA','CANADA'),
"year_a: 2020" = c('AA', 'BB'),
"NUMBER" = sample(10:22, 12),
check.names = FALSE
)
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.js")
),
DTOutput("dtable")
)
server <- function(input, output){
output[["dtable"]] <- renderDT({
datatable(data_a, callback = JS(callback))
}, server = FALSE)
observe({ # selected year
print(input[["year"]])
})
}
shinyApp(ui, server)
EDIT
With filtering:
library(shiny)
library(DT)
callback <- c(
"Shiny.setInputValue('year', '2020');",
"var choices = {1: '2020', 2: '2021'};",
"var id = $(table.table().node()).closest('.datatables').attr('id');",
"$.contextMenu({",
" selector: '#' + id + ' th:eq(3)',",
" trigger: 'right',",
" autoHide: true,",
" items: {",
" select: {",
" name: 'Select year:',",
" type: 'select',",
" options: choices,",
" selected: '1'",
" }",
" },",
" events: {",
" hide: function(opt){",
" var $this = this;",
" var i = $.contextMenu.getInputValues(opt, $this.data()).select;",
" var year = choices[i];",
" Shiny.setInputValue('year', year);",
" var text = 'year_a: ' + year;",
" var $th = opt.$trigger;",
" $th.text(text);",
" }",
" }",
"});"
)
data_a <- data.frame(
"YEAR" = c(rep(2020,6), rep(2021,6)),
"COUNTRY" = c('UK', 'UK', 'USA', 'USA', 'CANADA','CANADA'),
"year_a: 2020" = c('AA', 'BB'),
"NUMBER" = sample(10:22, 12),
check.names = FALSE
)
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jquery-contextmenu/2.9.2/jquery.contextMenu.min.js")
),
DTOutput("dtable")
)
server <- function(input, output){
output[["dtable"]] <- renderDT({
datatable(data_a, callback = JS(callback))
}, server = TRUE)
proxy <- dataTableProxy("dtable")
observeEvent(input[["year"]], {
replaceData(proxy, subset(data_a, YEAR == input[["year"]]))
})
}
shinyApp(ui, server)

Choose a datatable row either by clicking, actionButton() or shiny widget

I have the shiny app below in which the user is able to choose a row to display its index with 3 ways.
Click on the row and display its index
Click on a row then press Next and display the index of the next row.
Select the rowname of a row,press Assign and display its index.
I know that I can use callback in order to enable datatable to achieve this but I do not know how to combine many callbacks.
library(shiny)
library(DT)
dat <- mtcars
callback <- JS(
"Shiny.addCustomMessageHandler(",
" 'selectRow',",
" function(index) {",
" table.row(index - 1).select();",
" }",
");",
"$('#btn-next').prop('disabled', true);",
"var selected_row = null;",
"table.on('select', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', false);",
" selected_row = indexes[0];",
"});",
"table.on('deselect', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', true);",
"});",
"var nrows = table.rows().count();",
"$('#btn-next').on('click', function() {",
" var next_row = selected_row + 1 < nrows ? selected_row + 1 : 0;",
" table.row(next_row).select();",
"});"
)
ui <- fluidPage(
br(),
DTOutput("dtable"),
br(),
textOutput("selectedRow"),
actionButton("btn-next", "select next row"),
pickerInput(
"rowname",
label = "Choose a row",
choices = setNames(1:nrow(dat), rownames(dat))
),
actionButton("assign", "Assign")
)
server <- function(input, output, session) {
output[["dtable"]] <- renderDT({
datatable(
dat,
extensions = "Select",
selection = "none",
callback = callback,
options = list(
columnDefs = list(
list(className = "dt-center", targets = "_all")
),
select = list(style = "single")
)
)
}, server = FALSE)
output[["selectedRow"]] <- renderText({
i <- input[["dtable_rows_selected"]]
paste0(
"Selected row: ",
ifelse(is.null(i), "none", i)
)
})
observeEvent(input[["rowname"]], {observeEvent(input[["assign"]], {
session$sendCustomMessage("selectRow", isolate(input[["rowname"]]))
})})
}
shinyApp(ui, server)
Full app:
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(shinyjs)
library(shinyWidgets)
attribute_name <- c("Jack", "Bob", "Jack", "Bob")
category_id <- c(7, 7, 7, 7)
candidate_phrase_lemma <- c("apple", "olive", "banana", "tomato")
d <- data.frame(
attribute_name,
category_id,
candidate_phrase_lemma,
stringsAsFactors = FALSE
)
names <- tapply(d$candidate_phrase_lemma, d$attribute_name, I)
candidate_1 <- c("Jack", "Bob", "Jack", "Bob")
candidate_2 <- c("phone", "camera", "micro", "pc")
similarity <- c(4, 5, 6, 7)
category_id <- c(7, 7, 7, 7)
e <- data.frame(candidate_1, candidate_2, similarity, category_id)
selector <- function(id, values, items = values) {
options <- HTML(paste0(mapply(
function(value, item) {
as.character(tags$option(value = value, selected = "selected", item))
}, values, items
), collapse = ""))
as.character(
tags$select(
id = id, multiple = "multiple", options
)
)
}
dat <- data.frame(
attributes = unique(as.character(d$attribute_name)),
attributes_phrases = vapply(
1:length(names),
function(i) {
selector(paste0("slct", i), names[[i]])
},
character(1)
),
Count = lengths(names),
stringsAsFactors = FALSE
)
nrows <- nrow(dat)
initComplete <- c(
"function(settings) {",
" var table = this.api().table();",
" var nrows = table.rows().count();",
" function selectize(i) {",
" var $slct = $('#slct' + i);",
" $slct.select2({",
" width: '100%',",
" closeOnSelect: false",
" });",
" $slct.on('change', function(e) {",
" table.cell(i-1, 2).data($slct.val().length);",
" });",
" }",
" for(var i = 1; i <= nrows; i++) {",
" selectize(i);",
" }",
"}"
)
callback <- JS(
"Shiny.addCustomMessageHandler(",
" 'selectRow',",
" function(index) {",
" table.row(index - 1).select();",
" }",
");",
"$('#btn-next').prop('disabled', true);",
"var selected_row = null;",
"table.on('select', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', false);",
" selected_row = indexes[0];",
"});",
"table.on('deselect', function( e, dt, type, indexes ) {",
" $('#btn-next').prop('disabled', true);",
"});",
"var nrows = table.rows().count();",
"$('#btn-next').on('click', function() {",
" var next_row = selected_row + 1 < nrows ? selected_row + 1 : 0;",
" table.row(next_row).select();",
"});"
)
js <- paste0(c(
"Shiny.addCustomMessageHandler(",
" 'addCandidate',",
" function(row_candidate) {",
" var i = row_candidate.row;",
" var candidate = row_candidate.candidate;",
" var $slct = $('#slct' + i);",
" if($slct.find(\"option[value='\" + candidate + \"']\").length === 0) {",
" var newOption = new Option(candidate, candidate, true, true);",
" $slct.append(newOption).trigger('change');",
" }",
" }",
");"
), collapse = "\n")
shinyApp(
ui = dashboardPagePlus(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js"),
tags$style(HTML(
".select2-selection__choice {background-color: darkblue !important;}"
)),
tags$script(HTML(js))
),
useShinyjs(),
header = dashboardHeaderPlus(),
sidebar = dashboardSidebar(),
body = dashboardBody(
DTOutput("table"),
br(),
fluidRow(
column(
4,
uiOutput("ui-rowselect")
),
column(
2,
actionButton("selectrow", "Select this row")
)
),
br(),
actionButton("btn-next", "Select next row"),
br(), br(),
conditionalPanel(
condition = "input.table_rows_selected.length > 0",
wellPanel(
uiOutput("celltext"),
splitLayout(
actionButton("bc", "Previous candidate"),
actionButton("dec", "Next candidate"),
actionButton("addWord", "Add this candidate", class = "btn-info"),
cellWidths = "auto"
)
)
)
)
),
server = function(input, output, session) {
Text <- reactiveVal()
Data <- reactiveVal()
Candidate <- reactiveVal()
rnum <- reactiveVal()
output[["table"]] <- renderDT({
datatable(
data = dat,
extensions = "Select",
selection = "none",
escape = FALSE,
rownames = FALSE,
callback = callback,
options = list(
pageLength = 5,
columnDefs = list(
list(className = "dt-center", targets = "_all")
),
select = list(style = "single"),
initComplete = JS(initComplete),
preDrawCallback = JS(
"function() { Shiny.unbindAll(this.api().table().node()); }"
),
drawCallback = JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
)
)
)
}, server = FALSE)
output[["ui-rowselect"]] <- renderUI({
selectedRow <- input[["table_rows_selected"]]
choices <- if(is.null(selectedRow)) 1:nrows else (1:nrows)[-selectedRow]
pickerInput(
"rowselect",
label = "Choose a row",
choices = choices
)
})
observeEvent(input[["selectrow"]], {
session$sendCustomMessage("selectRow", input[["rowselect"]])
})
observeEvent(input[["table_rows_selected"]], {
row <- input[["table_rows_selected"]]
dat <- e[e[["candidate_1"]] %in% d[row, 1], ]
Data(dat[order(dat[["similarity"]], decreasing = TRUE), ])
rnum(1)
})
output[["celltext"]] <- renderUI({
HTML(Text())
})
observeEvent(input[["dec"]], {
rnum(rnum() + 1)
})
observeEvent(input[["bc"]], {
rnum(rnum() - 1)
})
observeEvent(list(rnum(), Data()), {
if(rnum() == 1){
disable("bc")
}else{
enable("bc")
}
if(rnum() == nrows){
disable("dec")
}else{
enable("dec")
}
Candidate(Data()[rnum(), 2])
Text(
paste(
"Similarity of <em>", Data()[rnum(), 1], "</em>",
"to candidate <em>", Candidate(), "</em>",
"is <strong>", Data()[rnum(), 3], "</strong>"
)
)
}, ignoreInit = TRUE)
observeEvent(input[["addWord"]], {
session$sendCustomMessage(
"addCandidate",
list(row = input[["table_rows_selected"]], candidate = Candidate())
)
})
}
)

chartJSRadar downloadhandler creating empty png

I would like to create a download button within my shiny app to download a reactive plot created with chartJSRadar. I am not able to solve this problem!
As I have been through the documented problem on the internet, I was not able to solve it, receiving all the time an empty png. As suggested (Save plots made in a shiny app), https://groups.google.com/forum/#!msg/shiny-discuss/u7gwXc8_vyY/IZK_o7b7I8gJ
I built a function ...
So my code is an example code:
ui.R:
library(radarchart)
shinyUI(pageWithSidebar(
headerPanel('Radarchart Shiny Example'),
sidebarPanel(
checkboxGroupInput('selectedPeople', 'Who to include',
names(radarchart::skills)[-1], selected="Rich")
),
mainPanel(
chartJSRadarOutput("plot1", width = "450", height = "300"), width = 7,
radioButtons(inputId = "var3", label = "Select the file type", choices = list("png", "pdf")),
downloadButton('downloadPlot', 'Download Plot')
)
))
server.R
library(radarchart)
shinyServer(function(input, output) {
output$plot1 <- renderChartJSRadar({
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE)
})
plot2 <- function(){
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE)
}
output$downloadPlot <- downloadHandler(
filename = "Shinyplot.png",
content = function(file) {
png(file)
plot2()
print(plot2())
dev.off()
})
})
Here is a JavaScript way which should be faster than webshot, I think.
library(shiny)
library(radarchart)
library(htmlwidgets) # to use the 'onRender' function
js <- c(
"function(el, x){",
" $('#downloadPlot').on('click', function(){",
" // Clone the chart to add a background color.",
" var cloneCanvas = document.createElement('canvas');",
" cloneCanvas.width = el.width;",
" cloneCanvas.height = el.height;",
" var ctx = cloneCanvas.getContext('2d');",
" ctx.fillStyle = '#FFFFFF';",
" ctx.fillRect(0, 0, el.width, el.height);",
" ctx.drawImage(el, 0, 0);",
" // Download.",
" const a = document.createElement('a');",
" document.body.append(a);",
" a.download = 'radarchart.png';",
" a.href = cloneCanvas.toDataURL('image/png');",
" a.click();",
" a.remove();",
" });",
"}"
)
ui <- pageWithSidebar(
headerPanel('Radarchart Shiny Example'),
sidebarPanel(
checkboxGroupInput('selectedPeople', 'Who to include',
names(radarchart::skills)[-1], selected="Rich"),
actionButton('downloadPlot', 'Download Plot')
),
mainPanel(
chartJSRadarOutput("plot1", width = "450", height = "300"), width = 7
)
)
server <- function(input, output) {
output$plot1 <- renderChartJSRadar({
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE) %>%
onRender(js)
})
}
shinyApp(ui, server)
This exports to png only. Use webshot to export to pdf.
EDIT
library(shiny)
library(radarchart)
js <- paste0(c(
"$(document).ready(function(){",
" $('#downloadPlot').on('click', function(){",
" var el = document.getElementById('plot1');",
" // Clone the chart to add a background color.",
" var cloneCanvas = document.createElement('canvas');",
" cloneCanvas.width = el.width;",
" cloneCanvas.height = el.height;",
" var ctx = cloneCanvas.getContext('2d');",
" ctx.fillStyle = '#FFFFFF';",
" ctx.fillRect(0, 0, el.width, el.height);",
" ctx.drawImage(el, 0, 0);",
" // Download.",
" const a = document.createElement('a');",
" document.body.append(a);",
" a.download = 'radarchart.png';",
" a.href = cloneCanvas.toDataURL('image/png');",
" a.click();",
" a.remove();",
" cloneCanvas.remove();",
" });",
"});"
), collapse = "\n")
ui <- pageWithSidebar(
headerPanel('Radarchart Shiny Example'),
sidebarPanel(
checkboxGroupInput('selectedPeople', 'Who to include',
names(radarchart::skills)[-1], selected="Rich"),
actionButton('downloadPlot', 'Download Plot')
),
mainPanel(
tags$head(tags$script(HTML(js))),
chartJSRadarOutput("plot1", width = "450", height = "300"), width = 7
)
)
server <- function(input, output) {
output$plot1 <- renderChartJSRadar({
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE)
})
}
shinyApp(ui, server)
chartJSRadar returns an htmlWidget. To save, try using saveWidget and then webshot of the temporary html file. Add webshot library:
library(webshot)
and try substituting this for downloadHandler in your server function:
output$downloadPlot <- downloadHandler(
filename = "Shinyplot.png",
content = function(file) {
saveWidget(plot2(), "temp.html", selfcontained = TRUE)
webshot("temp.html", file = file)
}
)

Format a vector of rows in italic and red font in R DT (datatable)

A bit similar to this question: How to give color to a given interval of rows of a DT table?
but in my case I would like to let the user select rows in the table, then on click of a button deselect the rows, and turn the previously selected rows that are now part of the list of rows submitted for removal grayed out font (color: light gray) and in italic. This to indicate that these will be excluded from further analysis.
Secondly a button to undo the entire selection should change all rows back to normal format
I've gotten as far as recording the selected rows and adding the deselect feature, but to then restyle the rows before resetting them escapes me....
Output that I hope to achieve:
Not sure whether it is the right approach, but my thought was to use both
values$selected_rows and values$removed_rows, where the first holds the selection until it is submitted, and removed holds the potentially growing list of rows selected for removal if the user decides to remove more rows on another submit
removed_rows is then also the list of rows that need to be styled (grayed out in italic)
library(shiny)
library(DT)
ui <- fluidPage(
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
verbatimTextOutput('Printresult'),
DT::dataTableOutput('mytable')
)
server <- function(input, output,session) {
values <- reactiveValues()
observe({
values$selected_rows <- input$mytable_rows_selected
})
observeEvent(input$SubmitRemoval, {
values$removed_rows <- c(values$removed_rows,input$mytable_rows_selected)
dataTableProxy('mytable') %>% selectRows(NULL)
values$selected_rows <- NULL
removeTab("tabs", "mytable")
})
Remaining_mtcars <- reactive({
req( values$removed_rows)
mtcarsR <- mtcars[-c(values$removed_rows), ]
mtcarsR
})
output$Printresult <- renderText({ nrow(Remaining_mtcars()) })
observeEvent(input$UndoRemoval, {
values$removed_rows <- NULL
})
output$mytable <- DT::renderDataTable({
DT::datatable(mtcars,
extensions = c('Buttons', 'ColReorder', 'FixedHeader', 'Scroller'),
options = list(pageLength = 25,
selection = c('multiple'),
dom = 'frtipB'
)
)
})
}
runApp(list(ui = ui, server = server))
UPDATE
#SL: I tried to move your javascript functions for submit and undo inside the DT::JS() part of embedded buttons, but I could not get it to work. I guess i'm close, but no idea where the problem is.
The table output code would follow this structure:
output[["mytable"]] <- renderDT({
datatable(dat,
escape = -2,
extensions = c('Buttons', 'ColReorder', 'FixedHeader', 'Scroller'),
callback = JS(callback),
options = list(
dom = 'frtipB',
initComplete = JS(initComplete),
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all")
),
buttons = list('copy', 'csv',
list(
extend = "collection",
text = 'Deselect',
action = DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('SubmitRemoval', true, {priority: 'event'});
}")
## move the submit javascript here
),
list(
extend = "collection",
text = 'Restore',
action = DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('UndoRemoval', true, {priority: 'event'});
## move the undo removal javascript here
}")
)
)
)
)
})
Here is a better solution (it took me several hours). This one does not redraw the table when one clicks the button, and it doesn't go wrong when one sorts the table by a column.
library(shiny)
library(DT)
initComplete <- c(
"function(settings) {",
" var table=settings.oInstance.api();",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x');",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x');",
" });",
"}"
)
callback <- "
var xrows = [];
table.on('preDraw', function(e, settings) {
var tbl = settings.oInstance.api();
var nrows = tbl.rows().count();
var rows = tbl.$('tr');
var some = false; var r = 0;
while(!some && r<nrows){
if($(rows[r]).hasClass('x')){
some = true
}
r++;
}
if(some){
xrows = [];
for(var i = 0; i < nrows; i++){
if($(rows[i]).hasClass('x')){
xrows.push(rows[i].getAttribute('id'));
}
}
}
}).on('draw.dt', function(){
for(var i=0; i<xrows.length; i++){
var row = $('#' + xrows[i]);
row.addClass('x');
}
xrows = [];
});
"
ui <- fluidPage(
tags$head(
tags$style(HTML(
".x { background-color: rgb(211,211,211) !important; font-style: italic}
table.dataTable tr.selected.x td { background-color: rgb(211,211,211) !important;}"
))
),
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(mtcars[1:6,], id=1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
callback = JS(callback),
options = list(
initComplete = JS(initComplete),
rowId = JS(sprintf("function(a){return a[%d];}", ncol(dat))),
columnDefs = list(list(visible=FALSE, targets=ncol(dat)))
)
)
})
proxy <- dataTableProxy("mytable")
observeEvent(input[["UndoRemoval"]], {
proxy %>% selectRows(NULL)
})
}
shinyApp(ui, server)
Update
Here is the version including icons:
library(shiny)
library(DT)
initComplete <- c(
"function(settings) {",
" var table = settings.oInstance.api();",
" var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'",
" var checkmark = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-ok\"></i></span>'",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x');",
" table.$('tr.selected')",
" .each(function(){$(this).find('td').eq(1).html(cross);});",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x');",
" table.$('tr')",
" .each(function(i){$(this).find('td').eq(1).html(checkmark);});",
" });",
"}"
)
callback <- "
var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'
var xrows = [];
table.on('preDraw', function(e, settings) {
var tbl = settings.oInstance.api();
var nrows = tbl.rows().count();
var rows = tbl.$('tr');
var some = false; var r = 0;
while(!some && r<nrows){
if($(rows[r]).hasClass('x')){
some = true
}
r++;
}
if(some){
xrows = [];
for(var i = 0; i < nrows; i++){
if($(rows[i]).hasClass('x')){
xrows.push(rows[i].getAttribute('id'));
}
}
}
}).on('draw.dt', function(){
for(var i=0; i<xrows.length; i++){
var row = $('#' + xrows[i]);
row.addClass('x').find('td').eq(1).html(cross);
}
xrows = [];
});
"
ui <- fluidPage(
tags$head(
tags$style(HTML(
".x { background-color: rgb(211,211,211) !important; font-style: italic}
table.dataTable tr.selected.x td { background-color: rgb(211,211,211) !important;}"
))
),
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(Selected = '<span style="color:red; font-size:18px"><i class="glyphicon glyphicon-ok"></i></span>',
mtcars[1:6,], id = 1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
escape = -2,
callback = JS(callback),
options = list(
initComplete = JS(initComplete),
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all")
)
)
)
})
proxy <- dataTableProxy("mytable")
observeEvent(input[["UndoRemoval"]], {
proxy %>% selectRows(NULL)
})
}
shinyApp(ui, server)
Update
To get the indices of the excluded rows in input$excludedRows:
initComplete <- c(
"function(settings) {",
" var table = settings.oInstance.api();",
" var cross = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-remove\"></i></span>'",
" var checkmark = '<span style=\"color:red; font-size:18px\"><i class=\"glyphicon glyphicon-ok\"></i></span>'",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x');",
" table.$('tr.selected')",
" .each(function(){$(this).find('td').eq(1).html(cross);});",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x');",
" table.$('tr')",
" .each(function(i){$(this).find('td').eq(1).html(checkmark);});",
" Shiny.setInputValue('excludedRows', null);",
" });",
"}"
)
Update
This is easier with the option server = FALSE of renderDT:
library(shiny)
library(DT)
initComplete <- c(
"function(settings) {",
" var table = settings.oInstance.api();",
" $('#SubmitRemoval').on('click', function(){",
" table.$('tr.selected').addClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('remove');",
" });",
" table.draw(false);",
" table.rows().deselect();",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('x')){excludedRows.push(parseInt($(row).attr('id')));}",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
" });",
" $('#UndoRemoval').on('click', function(){",
" table.$('tr').removeClass('x').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('ok');",
" });",
" Shiny.setInputValue('excludedRows', null);",
" });",
"}"
)
render <- c(
'function(data, type, row, meta){',
' if(type === "display"){',
' return "<span style=\\\"color:red; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" + data + "\\\"></i></span>";',
' } else {',
' return data;',
' }',
'}'
)
ui <- fluidPage(
tags$head(
tags$style(HTML(
".x { color: rgb(211,211,211); font-style: italic; }"
))
),
verbatimTextOutput("excludedRows"),
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(Selected = "ok", mtcars[1:6,], id = 1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
extensions = "Select",
options = list(
initComplete = JS(initComplete),
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all"),
list(
targets = 1,
render = JS(render)
)
)
)
)
}, server = FALSE)
proxy <- dataTableProxy("mytable")
observeEvent(input[["UndoRemoval"]], {
proxy %>% selectRows(NULL)
})
output$excludedRows <- renderPrint({
input[["excludedRows"]]
})
}
shinyApp(ui, server)
Here is an attempt.
library(shiny)
library(DT)
rowCallback <- function(rows){
c(
"function(row, data, num, index){",
sprintf(" var rows = [%s];", paste0(rows-1, collapse = ",")),
" if(rows.indexOf(index) > -1){",
" for(var i=1; i<data.length; i++){",
" $('td:eq('+i+')', row)",
" .css({'background-color': 'rgb(211,211,211)', 'font-style': 'italic'});",
" }",
" }",
"}"
)
}
ui <- fluidPage(
actionButton('SubmitRemoval', 'Exclude selected rows'),
actionButton('UndoRemoval', 'Include full data'),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
output[["mytable"]] <- renderDT({
input[["SubmitRemoval"]]
input[["UndoRemoval"]]
rows <- isolate(input[["mytable_rows_selected"]])
datatable(mtcars,
options = list(
rowCallback = JS(rowCallback(rows))
)
)
})
proxy <- dataTableProxy("mytable")
observeEvent(input[["UndoRemoval"]], {
proxy %>% selectRows(NULL)
})
}
shinyApp(ui, server)
Here is a variant. Instead of using a button to mark the selected rows as removed, the user clicks on the icons.
library(shiny)
library(DT)
callback <- c(
"table.on('click', 'td:nth-child(2)', function(){",
" var td = this;",
" var cell = table.cell(td);",
" if(cell.data() === 'ok'){",
" cell.data('remove');",
" } else {",
" cell.data('ok');",
" }",
" var $row = $(td).closest('tr');",
" $row.toggleClass('excluded');",
" var excludedRows = [];",
" table.$('tr').each(function(i, row){",
" if($(this).hasClass('excluded')){",
" excludedRows.push(parseInt($(row).attr('id')));",
" }",
" });",
" Shiny.setInputValue('excludedRows', excludedRows);",
"})"
)
restore <- c(
"function(e, table, node, config) {",
" table.$('tr').removeClass('excluded').each(function(){",
" var td = $(this).find('td').eq(1)[0];",
" var cell = table.cell(td);",
" cell.data('ok');",
" });",
" Shiny.setInputValue('excludedRows', null);",
"}"
)
render <- c(
'function(data, type, row, meta){',
' if(type === "display"){',
' return "<span style=\\\"color:red; font-size:18px\\\"><i class=\\\"glyphicon glyphicon-" + data + "\\\"></i></span>";',
' } else {',
' return data;',
' }',
'}'
)
ui <- fluidPage(
tags$head(
tags$style(HTML(
".excluded { color: rgb(211,211,211); font-style: italic; }"
))
),
fluidRow(
column(
6,
tags$label("Excluded rows"),
verbatimTextOutput("excludedRows")
),
column(
6,
tags$label("Included rows"),
verbatimTextOutput("includedRows")
)
),
br(),
DTOutput('mytable')
)
server <- function(input, output,session) {
dat <- cbind(Selected = "ok", mtcars[1:6,], id = 1:6)
output[["mytable"]] <- renderDT({
datatable(dat,
extensions = c("Select", "Buttons"),
selection = "none",
callback = JS(callback),
options = list(
rowId = JS(sprintf("function(data){return data[%d];}", ncol(dat))),
columnDefs = list(
list(visible = FALSE, targets = ncol(dat)),
list(className = "dt-center", targets = "_all"),
list(className = "notselectable", targets = 1),
list(targets = 1, render = JS(render))
),
dom = "Bt",
buttons = list("copy", "csv",
list(
extend = "collection",
text = 'Select all rows',
action = JS(restore)
)
),
select = list(style = "single", selector = "td:not(.notselectable)")
)
)
}, server = FALSE)
output$excludedRows <- renderPrint({
input[["excludedRows"]]
})
output$includedRows <- renderPrint({
setdiff(1:nrow(dat), input[["excludedRows"]])
})
}
shinyApp(ui, server)

Resources