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)
Related
I have data table output that I want users to be able to create their own custom table by using checkboxes to select which row/element they want. In the example below is a mtcars output. For example I want users to be able to pick say A Mazda, Fiat, Toyota, and a Dodge model using a check box. As far as trying any code, I haven't found any examples that come close.
library(shiny)
if (interactive()) {
# basic example
shinyApp(
ui = fluidPage(
selectInput("variable", "Variable:",
c("Cylinders" = "cyl",
"Transmission" = "am",
"Gears" = "gear"), multiple = T),
tableOutput("data")
),
server = function(input, output) {
output$data <- renderTable({
mtcars[, c("mpg", input$variable), drop = FALSE]
}, rownames = TRUE)
}
)
}
The general approach below is 1) create a checkbox group input listing the car names (i.e. rownames) as the names, having the corresponding values be the row numbers and 2) using those row numbers to filter your data.frame on the server.
Using the reactive rowsToUse will update every time the selection changes. It also allows the handling of the case when no rows are selecting (default to all rows in the example below).
shinyApp(
ui = fluidPage(
checkboxGroupInput(
inputId = "variable",
label = "Cars:",
choiceNames = rownames(mtcars),
choiceValues = seq(NROW(mtcars))
),
tableOutput("data")
),
server = function(input, output) {
rowsToUse <- reactive(
if(is.null(input$variable)) {
seq(NROW(mtcars))
} else{
as.numeric(input$variable)
}
)
output$data <- renderTable({
mtcars[rowsToUse(), , drop = FALSE]
}, rownames = TRUE)
}
)
I have a shiny dashboard where the tables are created with the reactable package. I have simple and nested tables and as far as I can see, there is only a download option for csv:
library(htmltools)
library(fontawesome)
data <- MASS::Cars93[1:15, c("Manufacturer", "Model", "Type", "Price")]
htmltools::browsable(
tagList(
tags$button(
tagList(fontawesome::fa("download"), "Download as CSV"),
onclick = "Reactable.downloadDataCSV('cars-download-table', 'cars.csv')"
),
reactable(
data,
searchable = TRUE,
defaultPageSize = 5,
elementId = "cars-download-table"
)
)
)
I want to create one Excel download file with the following attributes:
the tables to download are selected via a checkboxGroupInput
one Excel sheet per selected item
the name of the sheet corresponds to selected item
if there is more than one table in the selected item, all those tables should be in one sheet (divided by some empty rows)
some captions (read from another file) should be inserted above the tables
The problem is, that I want to use the data shown in the reactable (e.g. the selected columns), therefore I can not use the raw data. Is there some kind of package I can use?
So far, I only have a slow solution where I put the reactable into an additional variable before I render the table and then I read the data from this variable and use the package openxlsx to write the Excel.
Here is a clue. You can get the current state of the table with Reactable.getState, and the current display is in the field sortedData. This is demonstrated by the app below.
library(shiny)
library(reactable)
library(jsonlite)
registerInputHandler(
"xx",
function(data, ...){
fromJSON(toJSON(data))
},
force = TRUE
)
ui <- fluidPage(
fluidRow(
column(
7,
tags$button(
"Get data",
onclick = '
var state = Reactable.getState("cars");
Shiny.setInputValue("dat:xx", state.sortedData);
'
),
reactableOutput("cars")
),
column(
5,
verbatimTextOutput("data")
)
)
)
server <- function(input, output){
output$cars <- renderReactable({
reactable(MASS::Cars93[, 1:5], filterable = TRUE)
})
output$data <- renderPrint({
input$dat
})
}
shinyApp(ui, server)
EDIT
Here is an example of downloading the current display:
library(shiny)
library(shinyjs)
library(reactable)
library(jsonlite)
registerInputHandler(
"xx",
function(data, ...){
fromJSON(toJSON(data))
},
force = TRUE
)
ui <- fluidPage(
useShinyjs(),
br(),
conditionalPanel(
"false", # always hide the download button, because we will trigger it
downloadButton("downloadData") # programmatically with shinyjs
),
actionButton(
"dwl", "Download", class = "btn-primary",
onclick = paste0(
'var state = Reactable.getState("cars");',
'Shiny.setInputValue("dat:xx", state.sortedData);'
)
),
br(),
reactableOutput("cars")
)
server <- function(input, output, session){
output$cars <- renderReactable({
reactable(MASS::Cars93[, 1:5], filterable = TRUE)
})
observeEvent(input$dat, {
runjs("$('#downloadData')[0].click();")
})
output$downloadData <- downloadHandler(
filename = function() {
paste0("data-", Sys.Date(), ".xlsx")
},
content = function(file) {
openxlsx::write.xlsx(input$dat, file)
}
)
}
shinyApp(ui, server)
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 with a datatable. I would like to implement a button at the top of this datatable (but below its title) so that, when I click on it, the LaTeX code necessary to build this table is copied to clipboard.
Basically, this button would work the same way that the "copy" or "csv" buttons (see here part 2) but with LaTeX code.
Here's a reproducible example :
library(DT)
library(shiny)
library(shinydashboard)
library(data.table)
library(stargazer)
library(clipr)
ui <- dashboardPage(
dashboardHeader(title = "test with mtcars", titleWidth = 1000),
dashboardSidebar(
selectizeInput("var.cor", label = "Correlation",
choices = names(mtcars),
selected = c("mpg", "cyl"),
multiple = TRUE)
),
dashboardBody(
tabsetPanel(
tabPanel("test with mtcars",
br(),
box(dataTableOutput("cor"),
width = NULL),
actionButton("copy.latex", label = "Copy to LaTeX")
)
)
)
)
server <- function(input, output) {
var.selected <- reactive({
out <- input$var.cor
out
})
user.selection <- reactive({
mtcars <- mtcars[, var.selected()]
})
output$cor <- renderDataTable({
dtable <- user.selection()
tmp <- datatable(cor(dtable),
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
buttons = list(
"copy",
list(
extend = "collection",
text = 'test',
action = DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('test', true, {priority: 'event'});
}")
)
)
)
)
observeEvent(input$test, {
write_clip(stargazer(tmp),
object_type = "auto")
})
tmp
})
observeEvent(input$copy.latex, {
write_clip(stargazer(input$cor),
object_type = "character")
})
}
shinyApp(ui, server)
I tested two things in this code :
firstly, I inspired from here. This is the code of observeEvent nested in renderDataTable. However, either the text in the clipboard is % Error: Unrecognized object type, either I have an error : Error in : Clipboard on X11 requires that the DISPLAY envvar be configured.
secondly, I created a button outside the datatable but it doesn't work because I have Error in : $ operator is invalid for atomic vectors
Does somebody know how to do it ?
To copy the dataframe to clipboard in server:
library(shiny)
library(shinyjs)
library(DT)
table <- iris[1:10,]
ui <- fluidPage(
useShinyjs(),
actionButton("latex","Copy Latex to Clipboard"),
DT::dataTableOutput("table")
)
server <- function(input, output, session) {
output$table <- DT::renderDT(table)
observeEvent(input$latex,{
writeClipboard(paste0(capture.output(xtable(table))[-c(1:2)],collapse = "\n"))
shinyjs::alert("table copied to latex")
})
}
shinyApp(ui, server)
I won't recommend you to do it using DT's button. In order to do it using DT, there are at least 3 steps:
read entire table in the UI of datatable by writing Javascript in action, use Shiny.setInputValue to send the value from UI to server.
use R to parse the list(json) into data frame.
convert the data frame to latex string.
It's much easier to just do the conversion using the source data for datatable.
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