I am developing a shiny app where user can select multiple columns in a big dataset to create a subset of this dataset. I use the package DT to render the table nicely in the shiny app.
I previously used version 0.2 of DT package where the following code was working :
library("DT")
library("shiny")
ui <- fluidPage(
DT::dataTableOutput('table1'),
DT::dataTableOutput("table2")
)
server <- function(input, output) {
output$table1 <- DT::renderDataTable({
datatable(mtcars, extensions = 'Select', selection = 'none', options = list(ordering = FALSE, searching = FALSE, pageLength = 25, select = list(style = 'os', items = 'column')),
callback = JS(
"table.on( 'click.dt', 'tbody td', function (e) {",
"var type = table.select.items();",
"var idx = table[type + 's']({selected: true}).indexes().toArray();",
"var DT_id = table.table().container().parentNode.id;",
"Shiny.onInputChange(DT_id + '_columns_selected', idx);",
"})"
))
})
output$table2 <- DT::renderDataTable({
subset_table <- mtcars[,input$table1_columns_selected]
datatable(subset_table)
})
}
shinyApp(ui = ui, server = server)
Unfortunately, this code is not working anymore (I am now under version 0.4). The input$table1_columns_selected does not render the indices of the selected columns.
According to this https://rstudio.github.io/DT/shiny.html there is now a functionnality to select multiples rows, but I can't figure out how to do the same with columns.
Any idea ?
Thank you very much for your help !
I am not sure why you need to use the callback argument to do this. Here's a simplified approach -
library("DT")
library("shiny")
ui <- fluidPage(
DT::dataTableOutput('table1'),
DT::dataTableOutput("table2")
)
server <- function(input, output) {
output$table1 <- DT::renderDataTable({
datatable(mtcars, extensions = 'Select', selection = list(target = "column"), options = list(ordering = FALSE, searching = FALSE, pageLength = 25))
})
output$table2 <- DT::renderDataTable({
subset_table <- mtcars[, input$table1_columns_selected, drop = F]
datatable(subset_table)
})
}
shinyApp(ui = ui, server = server)
Note the change in the datatable arguments in output$table1. Hope this is what you were looking for.
I have tested your code and its working fine for me (see picture below) and i am also using DT package version 0.4.
So my guess is that, its not DT package problem but something else in your global configuration that is causing the issue.
Related
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.
Let's say that I have a shiny app displaying a data table like the following:
library(shiny)
library(tidyverse)
library(datasets)
library(DT)
data<- as.data.frame(USArrests)
#data<- cbind(state = rownames(data), data)
ui <- fluidPage(
dataTableOutput("preview")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$preview<- renderDataTable(
datatable(data, options = list(searching = T, pageLength = 10, lengthMenu = c(5,10,15, 20), scrollY = "600px", scrollX = T ))
)
}
# Run the application
shinyApp(ui = ui, server = server)
Let's say I then type in "Iowa" into the search box. I would like to save that filtered datatable into a seperate dataframe within the app. I would like it to be dynamic as well so if I typed "Kentucky", it would save Kentucky's filtered data into the dataframe instead. Is there a way to do this?
NOTE: this is a DT datatable
Maybe this type of solution. It is possible to add further conditions like checking the first letter in upper case, but the main idea is to check each column and search for the pattern entered inside the datatable searchbox. This may or may not result in more than one dataset to print (depending if the string is partially matched in multiple columns (this is also solvable with rbind function.
code:
library(shiny)
library(tidyverse)
library(datasets)
library(DT)
data <- as.data.frame(USArrests)
data <- cbind(state = rownames(data), data)
ui <- fluidPage(
dataTableOutput("preview"),
tableOutput('filtered_df')
)
# Define server logic required to draw a histogram
server <- function(input, output) {
df <- reactiveValues()
output$preview<- renderDataTable(
datatable(data, options = list(searching = T, pageLength = 10, lengthMenu = c(5,10,15, 20), scrollY = "600px", scrollX = T ))
)
observeEvent(input$preview_search, {
searched_string <- map(data, ~str_subset(.x, input$preview_search)) %>% discard(~length(.x) == 0)
df$filtered <- syms(names(data)) %>%
map(~ filter(data, !!.x %in% searched_string)) %>%
discard(~ nrow(.x) == 0)
})
output$filtered_df <- renderTable({df$filtered})
}
# Run the application
shinyApp(ui = ui, server = server)
I want to creat an shiny app where users have to edit datatable.
There is the code contains reproductible exemple:
library(shiny)
library(dplyr)
library(DT)
line<-c(1,1,1,1,1)
op<-c(155,155,155,156,156)
batch<-c(1,2,3,1,2)
voile<-c(1,NA,NA,NA,NA)
depot<-c(2,NA,2,NA,NA)
boe<-data.frame(line,op,batch)
ui <- fluidPage(
# Application title
titlePanel("test dust"),
actionButton("refresh", label = "refresh"),
DT::dataTableOutput("mytable"),
actionButton("save", label = "save"),
)
# Define server logic required to draw a histogram
server <- function(input, output) {
DTdust<- eventReactive(input$refresh, {
DTdust <-data.frame(line,op,batch,voile,depot)
})
merged<-reactive({
merged<-merge(boe,DTdust(),all.x = TRUE)
})
mergedfiltred<-reactive({
mergedfiltred<- filter(merged(),is.na(voile)|is.na(depot) )
})
output$mytable = DT::renderDataTable( mergedfiltred(),editable = list(target = 'cell',
disable = list(columns = c(1:3))),selection = 'none'
)
}
# Run the application
shinyApp(ui = ui, server = server)
I wish this works like this —>
When user clic on refresh button. Dtdust.csv (here simulated) is read , then it merged with boe.csv (simulated too) an filter to get only rows without resulta for voile and depot col.
And display this merged filtred ino editable datatable .
This part works.
After i want to extract the data from edited datatable to make some processing on it (extract rows completed, rbind it on dtdust and save as dtdust.csv. But that’s ok i think.)
I’ m in trouble to extract edited datatable.
I see some exemple to do it with classic dataframe but it not work with reactive one.
I’m beeginner so if you can comment a lot your answers i can learn how to and not just ctrl+c ctrl+v your code :)
Thanks
You need to define a reactiveValues data frame. Then you need to update it via observeEvent whenever any cell is modified via mytable_cell_edit. The updated dataframe is now available in the server side, and part of it is now printed in the second table. You can use DF1$data for further analysis or subsetting. Full updated code is below.
library(shiny)
library(dplyr)
library(DT)
line<-c(1,1,1,1,1)
op<-c(155,155,155,156,156)
batch<-c(1,2,3,1,2)
voile<-c(1,NA,NA,NA,NA)
depot<-c(2,NA,2,NA,NA)
boe<-data.frame(line,op,batch)
ui <- fluidPage(
# Application title
titlePanel("test dust"),
actionButton("refresh", label = "refresh"),
DTOutput("mytable"), DTOutput("tb2"),
actionButton("save", label = "save"),
)
# Define server logic required to draw a histogram
server <- function(input, output) {
DF1 <- reactiveValues(data=NULL)
DTdust<- eventReactive(input$refresh, {
req(input$refresh)
DTdust <-data.frame(line,op,batch,voile,depot)
})
merged<-reactive({
req(DTdust())
merged<-merge(boe,DTdust(),all.x = TRUE)
})
mergedfiltred<-reactive({
mergedfiltred <- filter(merged(),is.na(voile)|is.na(depot) )
DF1$data <- mergedfiltred
mergedfiltred
})
output$mytable = renderDT(
mergedfiltred(),
editable = list(target = 'cell', disable = list(columns = c(1:3))), selection = 'none'
)
observeEvent(input$mytable_cell_edit, {
info = input$mytable_cell_edit
str(info)
i = info$row
j = info$col
v = info$value
DF1$data[i, j] <<- DT::coerceValue(v, DF1$data[i, j])
})
output$tb2 <- renderDT({
df2 <- DF1$data[,2:5]
plen <- nrow(df2)
datatable(df2, class = 'cell-border stripe',
options = list(dom = 't', pageLength = plen, initComplete = JS(
"function(settings, json) {",
"$(this.api().table().header()).css({'background-color': '#000', 'color': '#fff'});",
"}")))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Hi thanks for your solution #YBS.
I finaly find a solution by myself half an hour after asking here... (i previously turning arround hours and hours).
There is what i do :
output$x2 = DT::renderDataTable({
req(dat$x2)
DT::datatable(dat$x2)
})
dat <- reactiveValues()
# update edited data
observeEvent(input$mytable_cell_edit, {
data_table <- dat$x2
data_table[input$mytable_cell_edit$row, input$mytable_cell_edit$col] <- as.numeric(input$mytable_cell_edit$value)
dat$x2 <- data_table
})
Have a good day
I have simple Shiny app with DT table
library(shiny)
library(DT)
iris2 = head(iris, 30)
server <- function(input, output) {
output$tb <-DT::renderDataTable(server=FALSE,{
datatable(
iris2,
colnames = c(colnames(iris2)), extensions = 'RowReorder',
options = list(rowReorder = TRUE))
})
}
ui <- fluidPage(dataTableOutput('tb', width = '200px', height = '200px'))
shinyApp(ui, server)
However, when I try to adjust the table row only the first column changes the position. It is probably related to the configuration of the ReorderRow, as described here. Unfortunately, I don't know how to implement JavaScript into the Shiny app, especially datatable options.
One has to add the row names and sort the table on them, as mentioned in the github issue. The working solutions requires only adding order = list(list(0, 'asc')) in the DT options:
library(shiny)
library(DT)
iris2 = head(iris, 30)
server <- function(input, output) {
output$tb <-DT::renderDataTable(server=FALSE,{
datatable(
iris2,
colnames = c(colnames(iris2)), extensions = 'RowReorder',
options = list(order = list(list(0, 'asc')), rowReorder = TRUE))
})
}
ui <- fluidPage(dataTableOutput('tb', width = '200px', height = '200px'))
shinyApp(ui, server)
The answer is probably obvious but i've been looking into using the backgroundColor attribute in the DT package to change the color of the full row instead of only the value that i use to select the row and I didn't manage to do it.
So basically in my Shiny app, I have a DataTable output in my server file where i wrote this :
output$tableMO <- DT::renderDataTable({
datatable(DFSurvieMO,
options =
list( displayStart= numerMO()-2,
pageLength = 15,
lengthChange = FALSE, searching =FALSE),rownames= FALSE) %>% formatStyle(
c(1:2),
backgroundColor =
if(numerMO()>1) {
styleInterval(c(DFSurvieMO[,1][numerMO()-1],DFSurvieMO[,1][numerMO()]), c('blank','lightblue', 'blank'))
}
else {
styleInterval(DFSurvieMO[,1][numerMO()], c('lightblue', 'blank'))}
)
})
And what i get in my app is a DataTable with only a single cell colored. I tried using target = 'row' but either I didn't put it in the right place or it does not work. So how can i get it to color the whole row ?
Thank You.
You can write some custom JS function using rowCallback. Below I have written a reactive which will listen to the slider and if the slider values in the mtcars dataset are bigger than your value it will repaint the row. Note that the aData[1] is the column called cyl within the mtcars dataset.
Apologies for not using your code as I wanted to make a more generic example
rm(list = ls())
library(shiny)
library(DT)
ui <- basicPage(
sliderInput("trigger", "Trigger",min = 0, max = 10, value = 6, step= 1),
mainPanel(DT::dataTableOutput('my_table'))
)
server <- function(input, output,session) {
my_callback <- reactive({
my_callback <- 'function(nRow, aData, iDisplayIndex, iDisplayIndexFull) {if (parseFloat(aData[1]) >= TRIGGER)$("td", nRow).css("background-color", "#9BF59B");}'
my_callback <- sub("TRIGGER",input$trigger,my_callback)
my_callback
})
output$my_table = DT::renderDataTable(
datatable(mtcars,options = list(
rowCallback = JS(my_callback()),searching = FALSE,paging = FALSE),rownames = FALSE)
)
}
runApp(list(ui = ui, server = server))