I am trying to render different shinyinputs (in the example below I have checkboxes, but I am also rendering dropdowns) in a datatable on DT with R Shiny, using the shinyInput function below.
It works great, I was able to render all the components that I wanted inside the cells.
Unfortunately now I am trying to make the whole table readable and I am facing this issue.
Without the checkboxes the table is rendered properly and the column width are taken from the coldef, where I have a list of lists containing targets and widths.
As soon as I include checkboxes or any other shiny component, the columndef is not working anymore, not only for the columns containing checkboxes but for ALL of the columns, it just seems that the columndef is not present.
I trying solving my way around and I am not sure if this is a bug or if there even is any workaround for this issue. I spent so much time on this table that I would feel quite bad dropping it just because it's looking so bad with the checkboxes column rendered with 300px width.
In the example below you can keep or drop the variable newvar from the dataframe to see the behaviour changing on the inclusion of checkboxes, even though the first 3 columns aren't changing.
library(DT)
ui <- basicPage(
h2("The mtcars data"),
DT::dataTableOutput("mytable")
)
server <- function(input, output) {
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
mtcarsx <- data.frame(mtcars, newvar=paste0(shinyInput(checkboxInput,nrow(mtcars),"mychbx",label="",value=FALSE,width=NULL)))
colDef <- list(
list(
targets=0,
width="150px"
),
list(
targets=1,
width="300px"
),
list(
targets=2,
width="500px"
)
)
output$mytable = DT::renderDataTable({
DT::datatable(mtcarsx,
escape = FALSE,
selection = 'none',
rownames = FALSE,
options = list(searching = FALSE,
ordering = FALSE,
columnDefs = colDef,
autoWidth = FALSE
))
})
}
shinyApp(ui, server)
I used the information from #K-Rhode from this answer: https://stackoverflow.com/a/49513444/4375992
From what I can tell, your primary issue is that the column width of the checkbox is too wide, yes? Well this should do it. Add a classname to the columnDefs for the checkbox column, then in css adjust the width of that class
library(DT)
library(shiny)
ui <- basicPage(
h2("The mtcars data"),
DT::dataTableOutput("mytable"),
tags$head( #CSS added to shrink the column with
tags$style('td.small .shiny-input-container{width:auto;}
td.small{width:30px;}
')
)
)
server <- function(input, output) {
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
mtcarsx <- data.frame(mtcars, newvar=paste0(shinyInput(checkboxInput,nrow(mtcars),"mychbx",label=NULL,value=FALSE,width=NULL)))
colDef <- list(
list(
targets=0,
width="150px"
),
list(
targets=1,
width="300px"
),
list(
targets=2,
width="500px"
),
list(
targets = 11,
className = "small" #Class name added so we can adjust the width of the checkbox element above in CSS
)
)
output$mytable = DT::renderDataTable({
DT::datatable(mtcarsx,
escape = FALSE,
selection = 'none',
rownames = FALSE,
options = list(searching = FALSE,
ordering = FALSE,
columnDefs = colDef,
autoWidth = FALSE
))
})
}
shinyApp(ui, server)
Related
I have created a DT datatable that works, but is currently looking like this:
I would like to: 1) align the header row with the table content and 2) and remove the horizontal line at the bottom of the table.
I have tried the solution to remove the horizontal line: R DT:datatable remove .no-footer border-bottom but it results in the table not displaying.
How do I do this?
My code:
library(shiny)
library(DT)
# Define UI for application that draws a histogram
column_names <- c(toupper(letters[1:26]),tolower(letters[1:26]))
df <- data.frame(replicate(length(column_names),sample(0:1,1000,rep=TRUE)))
# assign column names
colnames(df) = column_names
ui <- fluidPage(
checkboxGroupInput(
"column_selection",
h3("Select fields to display"),
choices = column_names,
inline = TRUE,
selected = c('A','B','C')
),
DT::dataTableOutput("alphabet")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$alphabet <- DT::renderDT({
columns = column_names
if (!is.null(input$column_selection)) {
columns = input$column_selection
}
datatable(
df[, columns, drop = FALSE],
rownames = FALSE,
class = "row-border hover stripe",
extensions = c('Buttons'),
options = list(
# change colour of header row
initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': 'black', 'color': 'white'});",
"}"),
dom = 'Brtip',
autoWidth = T,
scrollX = T,
buttons = list(c('copy', 'csv', 'excel'))
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I 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 used the directions in this other question to create a datatable with buttons inside.
I added some formatting to the renderTable() call to highlight in yellow motivation == 3
output$data <- DT::renderDataTable(
datatable(df$data) %>% formatStyle(
'Motivation',
target = 'row',
backgroundColor = styleEqual(c(3), c('yellow'))
),
server = FALSE, escape = FALSE, selection = 'none'
)
This highlights the correct row:
The problem is that color formatting messes up with the buttons. I find the same problem when trying to format dates (datatable automatically shows them in UTC and I want them on local time). Are both formatting and buttons inside the table incompatible?
I get the following warning
renderDataTable ignores ... arguments when expr yields a datatable object; see ?renderDataTable
Here's the code for the app:
library(shiny)
library(DT)
shinyApp(
ui <- fluidPage(
DT::dataTableOutput("data"),
textOutput('myText')
),
server <- function(input, output) {
myValue <- reactiveValues(employee = '')
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
df <- reactiveValues(data = data.frame(
Name = c('Dilbert', 'Alice', 'Wally', 'Ashok', 'Dogbert'),
Motivation = c(62, 73, 3, 99, 52),
Actions = shinyInput(actionButton, 5, 'button_', label = "Fire", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' ),
stringsAsFactors = FALSE,
row.names = 1:5
))
output$data <- DT::renderDataTable(
datatable(df$data) %>% formatStyle(
'Motivation',
target = 'row',
backgroundColor = styleEqual(c(3), c('yellow'))
),
server = FALSE, escape = FALSE, selection = 'none'
)
observeEvent(input$select_button, {
selectedRow <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
myValue$employee <<- paste('click on ',df$data[selectedRow,1])
})
output$myText <- renderText({
myValue$employee
})
}
)
You should look at this answer. Applying his advice to your problem, I move escape = FALSE, selection = 'none' in datatable(df$data) and it works (you need to remove server = FALSE, which is not accepted in datatable):
output$data <- DT::renderDataTable(
datatable(df$data, escape = FALSE, selection = 'none') %>% formatStyle(
'Motivation',
target = 'row',
backgroundColor = styleEqual(c(3), c('yellow'))
)
)
In case the answer I refer above is deleted (don't know if it can be), I also put it here:
You are getting this error because you are returning a DT::datatable AND you are also specifying filter='top' as one of the ... arguments to DT::renderDataTable. As the message is trying to tell you ... arguments are ignored since you are returning a DT::datatable. This is because the ... arguments are intended to be passed through to the DT:datatable constructor.
Either move filter='top' inside the DT::datatable constructor or return a data.frame and the filter='top will be used when DT::renderDataTable constructs a DT::datatable with your specified data.frame.
I have a leaflet map & datatable in a shiny app and have various input boxes to select what is being mapped.
Currently the data is processed on the server based on a set of shiny inputs, and that data is passed to both leaflet and datatable.
I'd also like to have a button on the datatable (or read double clicks on the datatable) and update a shiny input (i.e., call shiny::updateSelectizeInput) based on the users interaction with the datatable.
minimal code example:
if (interactive()) {
library(shiny)
library(DT)
shinyApp(
ui = fluidPage(
selectInput("species_selection", "Select species",
choices = c("all", as.character(iris$Species)))
, dataTableOutput("dt")
)
, server = function(input, output) {
output$dt <- renderDataTable({
if ( input$species_selection != "all" ) {
for_table <- iris %>%
filter(Species == input$species_selection)
} else {
for_table <- iris
}
for_table
# but also you can click a button or double-click a row on this datatable
# to update input$species_selection above
})
}
)
}
I'm aware there's no reason for this in this minimal example but I do want to do so for in the context of my larger app.
I've seen examples (for example, superzip) where buttons on the datatable are linked to html, and I know the datatable shiny tutorials tell you how to catch selected rows with an observer. Catching the selected rows is my backup plan but I would prefer a button on the row or a double-click.
Sure, but its a bit fiddly. I used mtcars as it has more variety:
library(shiny)
library(DT)
shinyApp(
#UI
ui <- fluidPage(
selectInput('carb_selection', 'Select carb', choices = c('all', as.character(mtcars$carb))),
DT::dataTableOutput('dt'),
),
#Server
server <- function(input, output, session) {
#Function to create buttons
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
#Add buttons to the mtcars dataframe
mtcars_btn <- reactiveValues(
data = data.frame(
mtcars,
carb_selector = shinyInput(actionButton, nrow(mtcars), 'button_', label = "Select", onclick = 'Shiny.onInputChange(\"select_button\", this.id)'),
stringsAsFactors = FALSE
)
)
#Output datatable
output$dt <- DT::renderDataTable(
if (input$carb_selection == 'all'){
DT::datatable(mtcars_btn$data, escape = FALSE, selection = 'none', options = list(searching = FALSE, ordering = FALSE))
} else {
DT::datatable(mtcars_btn$data[mtcars_btn$data$carb == input$carb_selection, ], escape = FALSE, selection = 'none', options = list(searching = FALSE, ordering = FALSE))
}
)
#Observe a button being clicked
observeEvent(input$select_button, {
carb_selected <- mtcars_btn$data[as.numeric(strsplit(input$select_button, "_")[[1]][2]),]$carb
print(paste0('clicked on ', carb_selected))
updateSelectInput(session, 'carb_selection', selected = carb_selected)
})
}
)
Note that you may wish to switch between local and server processing when using large dataframes.
I'd like to have a datatable display information based on another table with a single row of numericInputs below it. I'm trying to get the numericInput boxes appear in the table so that a user can type in values, then press submit when they are ready.
This worked before I added the numericInput code from R Shiny selectedInput inside renderDataTable cells. However I am getting an error message:
Warning: Error in force: argument "value" is missing, with no default
Stack trace (innermost first):
49: force
48: restoreInput
47: FUN
46: shinyInput [#34]
45: server [#53]
4: <Anonymous>
3: do.call
2: print.shiny.appobj
1: <Promise>
Error in force(default) : argument "value" is missing, with no default
ShinyApp reproducible code:
library(shiny)
library(DT)
data(mtcars)
if (interactive()) {
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(6, checkboxGroupInput("dsnamesGrp", "Variable name")),
column(6, uiOutput("dsordsGrp"), inline= FALSE)
)
),
mainPanel(
tabsetPanel(
tabPanel("contents", DT::dataTableOutput('contents')),
tabPanel("binnedtable", DT::dataTableOutput('binnedtable'))
),
DT::dataTableOutput('interface_table'),
actionButton("do", "Apply")
)
)
)
server <- function(input, output, session) {
output$contents <- DT::renderDataTable(
{mtcars}, options = list(autoWidth = TRUE,
scrollX = TRUE, dom = 't', ordering = FALSE),
rownames = FALSE)
# helper function for making input number values
shinyInput <- function(FUN, len, id, ...) {
inputs <- numeric(len)
for (i in seq_len(len)) {
inputs[i] <- as.numeric(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
# helper function for reading numeric inputs
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value <- input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
temp_m <- matrix(data = NA, nrow = 2, ncol = length(names(mtcars)))
colnames(temp_m) <- names(mtcars)
rownames(temp_m) <- c("Ordinality","Bins")
temp_m[1,] <- lengths(lapply(mtcars, unique))
bin_value <- list() #tags$input(bin_value)
temp_m[2,] <- shinyInput(numericInput, ncol(mtcars),
"bin_values")
output$interface_table <- DT::renderDataTable({
temp_m
colnames = names(mtcars)
rownames = FALSE
options = list(
autoWidth = TRUE, scrollX = TRUE, dom = 't',
ordering = FALSE)
})
}
}
shinyApp(ui, server)
There might have been some misunderstandings with the solution you were trying to adapt.
At first, the error you got was kind of trivial, but somehow masked by the wrapper functions. The tag numericInput needs an argument value, which is not optional. You don't provide it in your call to shinyInput. (It is part of the ... you reference.)
Correcting that, you get the error
Error : (list) object cannot be coerced to type 'double'
This is because, inside shinyInput you want to convert to numeric. Here you misinterpreted the post you linked. What shinyInput does is: it creates a number of shiny-specific web elements, which you in turn want to pack into your table. But, since those web elements are more than just HTML (including i.e. dependencies), you want to convert them down to just plain HTML. This is why in the linked post, the author used as.character. This has nothing to do with the kind of input you expect the widgets to deliver. So, as.numeric is wrong here.
Since we are adding HTML to the data.frame, we are about to include in a renderDataTable, we have to specify escape = FALSE, so that our HTML is actually interpreted as HTML and not converted to boring text. (Corrected some syntax in this call as well.)
Now you got at least your input fields showing correctly.
library(shiny)
library(DT)
data(mtcars)
if (interactive()) {
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(6, checkboxGroupInput("dsnamesGrp", "Variable name")),
column(6, uiOutput("dsordsGrp"), inline= FALSE)
)
),
mainPanel(
tabsetPanel(
tabPanel("contents", DT::dataTableOutput('contents')),
tabPanel("binnedtable", DT::dataTableOutput('binnedtable'))
),
DT::dataTableOutput('interface_table'),
actionButton("do", "Apply")
)
)
)
server <- function(input, output, session) {
output$contents <- DT::renderDataTable(mtcars,
rownames = FALSE,
options = list(
autoWidth = TRUE,
scrollX = TRUE,
dom = 't',
ordering = FALSE
)
)
# helper function for making input number values
shinyInput <- function(FUN, len, id, ...) {
inputs <- numeric(len)
for (i in seq_len(len)) {
# as.character to make a string of HTML
inputs[i] <- as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
# helper function for reading numeric inputs
shinyValue <- function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value <- input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
temp_m <- matrix(data = NA, nrow = 2, ncol = length(names(mtcars)))
colnames(temp_m) <- names(mtcars)
rownames(temp_m) <- c("Ordinality","Bins")
temp_m[1,] <- lengths(lapply(mtcars, unique))
bin_value <- list() #tags$input(bin_value)
# Since numericInput needs a value parameter, add this here!
temp_m[2,] <- shinyInput(numericInput, ncol(mtcars), "bin_values", value = NULL)
output$interface_table <- DT::renderDataTable(temp_m,
colnames = names(mtcars),
rownames = FALSE,
# Important, so this is not just text, but HTML elements.
escape = FALSE,
options = list(
autoWidth = TRUE, scrollX = TRUE, dom = 't',
ordering = FALSE)
)
}
}
shinyApp(ui, server)