Related
I want to copy values from a selectInput and paste it to a reactive table. Below is an example.
library(shiny)
library(tidyverse)
library(DT)
df<-data.frame("Name" = c("apple","cherry"),
"Value" = c(5,6))
ui <- fluidPage(
uiOutput("fruit"),
fluidRow(DT::DTOutput("table1")))
server <- function(input, output, session) {
df1 <- reactiveValues(data = {df})
output$table1 = DT::renderDT({
DT::datatable(df1$data, editable = T)
})
output$fruit <- renderUI({
selectInput(
inputId = "fruit_name",
label = "Name",
multiple = TRUE,
choices = c("apple","cherry","pear", "peach","banana"),
selected = "apple"
)
})
}
shinyApp(server = server, ui = ui)
I hope to be able to choose a fruit name from selectInput, copy it, and paste it to the table under column "Name". It seems shinyApp doesn't support regular copy and paste. Anyway to do it? Thanks!
It's impossible to select the text inside an item. With the code below, you can select an item and use Ctrl-C and Ctrl-V to copy and paste it.
js <- '
document.addEventListener("copy", (event) => {
const anchorNode = document.getSelection().anchorNode;
if (anchorNode instanceof HTMLElement &&
anchorNode.classList.contains("selectize-input")) {
const items = Array.from(anchorNode.getElementsByClassName("item active"));
const string = items.map(i => i.innerText).join(", ");
event.clipboardData.setData("text/plain", string);
event.preventDefault();
}
})
'
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
uiOutput("fruit"),
fluidRow(DTOutput("table1"))
)
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 am trying to create a shiny code that is able to filter a table non pre-determined number of times. When the user uploads a different (new) table, unfortunately the code breaks as I need to restart a lapply loop somehow, throwing out the previously stored column names.
I would like to create an non pre-defined filtering options for a table within Shiny. The user can select a column and filter a table choosing different categorical variables within that column. It is possible to add additional selection fields by pressing the 'Add' button.
the UI:
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- shinyUI(
pageWithSidebar(
headerPanel("testing of dynamic number of selection"),
sidebarPanel(
uiOutput("buttons")),
mainPanel(
uiOutput("drops")
,tableOutput("table")
)
))
The server:
A table (test.csv) is automatically stored in a reactive values and a first searching field appears with 3 buttons (Add = to add a new searching field by reading in the colnames and a multiselect that stores the unique variables from that columns. The filtering function is activated by the Calculate button)
server<-function(input, output, session) {
###### read in test file
values<-reactiveValues(number = 1,
upload = NULL,
input = NULL)
values$upload<-read.csv("test.csv")
#just the "add" button, in this instance it shouldn't be a uiOutput
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"), actionButton(inputId = "calc", label = "Calculate"),
actionButton(inputId = "new", label = "new table")
)
})
#pressing the add button
observeEvent(input$add, {
cat("i adding a new record\n")
values$number <- values$number + 1L })
daStuff <- function(i){
inputName<-paste0("drop", i)
inputName2<-paste0("select", i)
inputText<-if(values$number>0){input[[paste0("drop",i)]]}else{F} # previously selected value for dropdown
inputSelect <- if(values$number>1){input[[paste0("select",i)]]}else{F} # previously selected value for dropdown
fluidRow(
column(6,selectInput(inputName, inputName, c(colnames(values$upload)), selected = inputText)),
column(6,selectInput(inputName2, inputName2,
na.omit(unique(as.vector(values$upload[,input[[paste0("drop",i)]]]))),
multiple=TRUE, selectize=TRUE, selected=inputSelect)) )}
output$drops<- renderUI({
lapply(seq_len(values$number), daStuff)})
By pressing the Calculate button, the uploaded table is subjected to filtering, depending on the selected unique values and shown in the output$table
observeEvent(input$calc, {
values$input<-NULL
for (i in 1:values$number){
if(!is.null(input[[paste0("select",i)]])){
if(is.null(values$input)){
values$input<- filter(values$upload,values$upload[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
else{
values$input<- filter(values$input,values$input[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])}
} }
if (is.null(values$input)){values$input<-values$upload}
output$table <- renderTable({values$input})
})
My problem is when I upload a new table (test2.csv), I don't know how to erase the previously stored selections (drop* and select* values) and gives back an error message.
observeEvent(input$new,{
values$upload<-read.csv("test2.csv")
})
}
shinyApp(ui=ui, server = server)
I suppose I should stop somehow the lapply loop and restart it over, so the previously stored values are replaced depending on the new selection, but I am a bit stuck on how I could achieve that.
Just in case you might still be looking for solutions, I wanted to share something that was similar and could potentially be adapted for your needs.
This uses observeEvent for all select inputs. If it detects any changes, it will update all inputs, including the possibilities for select based on drop.
In addition, when a new file is read, the selectInput for drop and select are reset to first value.
Edit: I forgot to keep selected = input[[paste0("drop",i)]] in place for the dropdown (see revised code). It seems to keep the values now when new filters are added - let me know if this is what you had in mind.
library(shiny)
library(shinydashboard)
library(dplyr)
myDataFrame <- read.csv("test.csv")
ui <- shinyUI(
pageWithSidebar(
headerPanel("Testing of dynamic number of selection"),
sidebarPanel(
fileInput("file1", "Choose file to upload", accept = ".csv"),
uiOutput("buttons")
),
mainPanel(
uiOutput("inputs"),
tableOutput("table")
)
)
)
server <- function(input, output, session) {
myInputs <- reactiveValues(rendered = c(1))
myData <- reactive({
inFile <- input$file1
if (is.null(inFile)) {
d <- myDataFrame
} else {
d <- read.csv(inFile$datapath)
}
d
})
observeEvent(lapply(paste0("drop", myInputs$rendered), function(x) input[[x]]), {
for (i in myInputs$rendered) {
updateSelectInput(session,
paste0('select', i),
choices = myData()[input[[paste0('drop', i)]]],
selected = input[[paste0("select",i)]])
}
})
output$buttons <- renderUI({
div(
actionButton(inputId = "add", label = "Add"),
actionButton(inputId = "calc", label = "Calculate")
)
})
observeEvent(input$add, {
myInputs$rendered <- c(myInputs$rendered, max(myInputs$rendered)+1)
})
observeEvent(input$calc, {
showData <- NULL
for (i in 1:length(myInputs$rendered)) {
if(!is.null(input[[paste0("select",i)]])) {
if(is.null(showData)) {
showData <- filter(myData(), myData()[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
else {
showData <- filter(showData, showData[,input[[paste0("drop",i)]]] %in% input[[paste0("select",i)]])
}
}
}
if (is.null(showData)) { showData <- myData() }
output$table <- renderTable({showData})
})
observe({
output$inputs <- renderUI({
rows <- lapply(myInputs$rendered, function(i){
fluidRow(
column(6, selectInput(paste0('drop',i),
label = "",
choices = colnames(myData()),
selected = input[[paste0("drop",i)]])),
column(6, selectInput(paste0('select',i),
label = "",
choices = myData()[1],
multiple = TRUE,
selectize = TRUE))
)
})
do.call(shiny::tagList, rows)
})
})
}
shinyApp(ui, server)
I am trying to select a specific tab of my navbarPage and at the same time selecting a row of my datatable. This works fine for the first tab but not for a different tab. Can anyone help me on this?
library(DT)
library(shiny)
ui <- navbarPage(
id = "tabs",
'URL GET test',
tabPanel(
'welcome',
value='welcome',
h2('hi'),
DT::dataTableOutput("mytable2")
),
tabPanel(
"mtcars",
value='mtcars',
textInput("text", "Text", ""),
DT::dataTableOutput("mytable1")
)
)
server <- function(input, output, session) {
observe({
query <- parseQueryString(session$clientData$url_search)
print(query)
if (!is.null(query[['data']])) {
text_string <- query[['data']]
updateNavbarPage(session, inputId="tabs", selected=query[['data']])
}
if (!is.null(query[['text']])) {
text_string <- query[['text']]
updateTextInput(session, "text", value = text_string)
}
if (!is.null(query[['row']])) {
DT::selectRows(mytable_proxy1, as.numeric(query[['row']]))
DT::selectRows(mytable_proxy2, as.numeric(query[['row']]))
}
})
output$mytable1 = DT::renderDataTable({mtcars})
mytable_proxy1 = DT::dataTableProxy('mytable1')
output$mytable2 = DT::renderDataTable({mtcars})
mytable_proxy2 = DT::dataTableProxy('mytable2')
}
shinyApp(ui, server)
So by using the following URL (IP and port might be different), I can select a row on the first tab http://127.0.0.1:6583/?row=2 (working), with http://127.0.0.1:6583/?data=mtcars&text=bla (working) I can directly select the second tab and also update the text field.
But my goal is to select the second tab and select a specific row like I did for the first tab http://127.0.0.1:6583/?data=mtcars&row=2 (not working).
For example explicitly selecting the first tab and a row http://127.0.0.1:6583/?data=welcome&row=2 (works).
I suspect that the issue here is the order of operations in which Shiny executes the statements. In this case, when you try http://127.0.0.1:6583/?data=mtcars&row=2, the observer for the query first selects the mtcars tab and immediately tries to set the selected row through the DT proxy. However, the second table has not been rendered yet, it is only rendered after the observer finishes running. This is also why http://127.0.0.1:6583/?data=welcome&row=2 runs fine, since the app opens on the welcome tab and it renders the datatable before the observer fires.
One work around would be to store the selected row value in a reactiveVal, and use this value while rendering the datatable. A working example is given below, hope this helps!
library(DT)
library(shiny)
ui <- navbarPage(
id = "tabs",
'URL GET test',
tabPanel(
'welcome',
value='welcome',
h2('hi'),
DT::dataTableOutput("mytable2")
),
tabPanel(
"mtcars",
value='mtcars',
textInput("text", "Text", ""),
DT::dataTableOutput("mytable1")
)
)
server <- function(input, output, session) {
observe({
query <- parseQueryString(session$clientData$url_search)
print(query)
if (!is.null(query[['data']])) {
text_string <- query[['data']]
updateNavbarPage(session, inputId="tabs", selected=query[['data']])
}
if (!is.null(query[['text']])) {
text_string <- query[['text']]
updateTextInput(session, "text", value = text_string)
}
if (!is.null(query[['row']])) {
selected_row(as.numeric(query[['row']]))
}
})
selected_row <- reactiveVal()
output$mytable1 = DT::renderDataTable({
datatable(mtcars ,selection = list(mode = 'multiple', selected = selected_row()))
})
mytable_proxy1 = DT::dataTableProxy('mytable1')
output$mytable2 = DT::renderDataTable({
datatable(mtcars ,selection = list(mode = 'multiple', selected = selected_row()))
})
mytable_proxy2 = DT::dataTableProxy('mytable2')
}
shinyApp(ui, server)
I would like to have a working example similar to this:
https://demo.shinyapps.io/029-row-selection/
I tried the example in my Shiny server running Shiny Server v1.1.0.10000, packageVersion: 0.10.0 and Node.js v0.10.21, but it is not working even if I load the js and css files from the website. It simply does not select rows from the table:
# ui.R
library(shiny)
shinyUI(fluidPage(
title = 'Row selection in DataTables',
tagList(
singleton(tags$head(tags$script(src='//cdn.datatables.net/1.10.2/js/jquery.dataTables.js',type='text/javascript'))),
singleton(tags$head(tags$script(src='//cdn.datatables.net/1.10.2/css/jquery.dataTables.min.css',type='text/css')))
),
sidebarLayout(
sidebarPanel(textOutput('rows_out')),
mainPanel(dataTableOutput('tbl')),
position = 'right'
)
))
# server.R
library(shiny)
shinyServer(function(input, output) {
output$tbl <- renderDataTable(
mtcars,
options = list(pageLength = 10),
callback = "function(table) {
table.on('click.dt', 'tr', function() {
$(this).toggleClass('selected');
Shiny.onInputChange('rows',
table.rows('.selected').indexes().toArray());
});
}"
)
output$rows_out <- renderText({
paste(c('You selected these rows on the page:', input$rows),
collapse = ' ')
})
})
I then tried to do this from a different example that was using radio buttons to re-sort the rows.
In my modified example, I want to produce a list of ids from the selected checkbox buttons of the dataTables table shown in the webpage. E.g., selecting some rows from the first 5, I want my textbox to be: 1,3,4 corresponding to the mymtcars$id column I added to mtcars. I then plan to link an action to the values of the textbox.
I have it almost there in this example, but checking the boxes does not update the list in the textbox. Differently to the example shinyapp, I would like my checkboxes to keep the selection status if the table is resorted. This may be the tricky part, and I am not sure how to do it. I would also like to add a "Select/Unselect all" textbox on the top left corner of the table, that selects/unselects all boxes in the table. Any ideas?
# server.R
library(shiny)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
shinyServer(function(input, output, session) {
rowSelect <- reactive({
if (is.null(input[["row"]])) {
paste(sort(unique(rep(0,nrow(mymtcars)))),sep=',')
} else {
paste(sort(unique(input[["row"]])),sep=',')
}
})
observe({
updateTextInput(session, "collection_txt",
value = rowSelect()
,label = "Foo:"
)
})
# sorted columns are colored now because CSS are attached to them
output$mytable = renderDataTable({
addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
#Display table with checkbox buttons
cbind(Pick=addCheckboxButtons, mymtcars[, input$show_vars, drop=FALSE])
}, options = list(bSortClasses = TRUE, aLengthMenu = c(5, 25, 50), iDisplayLength = 25))
})
# ui.R
library(shiny)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
shinyUI(pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
selected = names(mymtcars))
),
mainPanel(
dataTableOutput("mytable")
,textInput("collection_txt",label="Foo")
)
)
)
For the first problem you need the dev version of shiny and htmltools >= 0.2.6 installed:
# devtools::install_github("rstudio/htmltools")
# devtools::install_github("rstudio/shiny")
library(shiny)
runApp(list(ui = fluidPage(
title = 'Row selection in DataTables',
sidebarLayout(
sidebarPanel(textOutput('rows_out')),
mainPanel(dataTableOutput('tbl')),
position = 'right'
)
)
, server = function(input, output) {
output$tbl <- renderDataTable(
mtcars,
options = list(pageLength = 10),
callback = "function(table) {
table.on('click.dt', 'tr', function() {
$(this).toggleClass('selected');
Shiny.onInputChange('rows',
table.rows('.selected').indexes().toArray());
});
}"
)
output$rows_out <- renderText({
paste(c('You selected these rows on the page:', input$rows),
collapse = ' ')
})
}
)
)
for your second example:
library(shiny)
mymtcars = mtcars
mymtcars$id = 1:nrow(mtcars)
runApp(
list(ui = pageWithSidebar(
headerPanel('Examples of DataTables'),
sidebarPanel(
checkboxGroupInput('show_vars', 'Columns to show:', names(mymtcars),
selected = names(mymtcars))
,textInput("collection_txt",label="Foo")
),
mainPanel(
dataTableOutput("mytable")
)
)
, server = function(input, output, session) {
rowSelect <- reactive({
paste(sort(unique(input[["rows"]])),sep=',')
})
observe({
updateTextInput(session, "collection_txt", value = rowSelect() ,label = "Foo:" )
})
output$mytable = renderDataTable({
addCheckboxButtons <- paste0('<input type="checkbox" name="row', mymtcars$id, '" value="', mymtcars$id, '">',"")
#Display table with checkbox buttons
cbind(Pick=addCheckboxButtons, mymtcars[, input$show_vars, drop=FALSE])
}, options = list(orderClasses = TRUE, lengthMenu = c(5, 25, 50), pageLength = 25)
, callback = "function(table) {
table.on('change.dt', 'tr td input:checkbox', function() {
setTimeout(function () {
Shiny.onInputChange('rows', $(this).add('tr td input:checkbox:checked').parent().siblings(':last-child').map(function() {
return $(this).text();
}).get())
}, 10);
});
}")
}
)
)
This answer has been rendered broken in shiny 0.11.1, but can easily be fixed. Here is the update that did it (link):
Added an escape argument to renderDataTable() to escape the HTML entities
in the data table for security reasons. This might break tables from previous
versions of shiny that use raw HTML in the table content, and the old behavior
can be brought back by escape = FALSE if you are aware of the security
implications. (#627)
Thus, to make the previous solutions work, one must specify escape = FALSE as an option to renderDataTable().
I have made an alternative for check boxes in tables based on the previous Answer code and some tweaking of the JQuery / JavaScript.
For anyone who prefers actual data over row numbers i wrote this code that extracts data from the table and shows that as selection. You can deselect by clicking again. It builds on the former Answers that were very helpful to me (THANKS) so i want to share this as well.
It needs a session object to keep the vector alive (scoping). Actually you can get whatever information you want from the table, just dive into JQuery and change the $row.find('td:nth-child(2)') (number is the column number).I needed the info from the Second column but it is up to you. Selection colors is a bit odd if you also change the visible column amount.... selection colors tend to disappear...
I hope this is helpful, works for me (needs to be optimized but no time for that now)
output$tbl <- renderDataTable(
mtcars,
options = list(pageLength = 6),
callback = "function(table) {
table.on('click.dt', 'tr', function() {
if ( $(this).hasClass('selected') ) {
$(this).removeClass('selected');
} else {
table.$('tr.selected').removeClass('selected');
$(this).addClass('selected');
}
var $row = $(this).closest('tr'),
$tdsROW = $row.find('td'),
$tdsUSER = $row.find('td:nth-child(2)');
$.each($tdsROW, function() {
console.log($(this).text());
});
Shiny.onInputChange('rows',table.rows('.selected').indexes().toArray());
Shiny.onInputChange('CELLselected',$tdsUSER.text());
Shiny.onInputChange('ROWselected',$(this).text());
});
}"
)
output$rows_out <- renderUI({
infoROW <- input$rows
if(length(input$CELLselected)>0){
if(input$CELLselected %in% session$SelectedCell){
session$SelectedCell <- session$SelectedCell[session$SelectedCell != input$CELLselected]
}else{
session$SelectedCell <- append(session$SelectedCell,input$CELLselected)
}
}
htmlTXT <- ""
if(length(session$SelectedCell)>0){
for(i in 1:length(session$SelectedCell)){
htmlTXT <- paste(htmlTXT,session$SelectedCell[i],sep="<br/>")
}
}else{htmlTXT <- "please select from the table"}
HTML(htmlTXT)
})
The answers above are outdated. I received error "Error in datatable: The 'callback' argument only accept a value returned from JS()".
Instead, This one works for me.