I have an output table being displayed in shiny. I would like to have a column attached to the table which would take in text input (comments) from the user for each row.
Can this be done in R shiny?
Yes you can do some thing like this
library(shiny)
library(DT)
library(dplyr)
shinyApp(
ui <- fluidPage(DT::dataTableOutput("ruless"),
fluidRow(column(4, offset = 1, actionButton("save", "Save", width = 200)))),
server <- function(input, output) {
values <- reactiveValues(data = NULL)
values$data <- as.data.frame(
cbind(c("a", "d", "b", "c", "e", "f"),
c(1463, 159, 54, 52, 52, 220),
c(0.7315, 0.0795, 0.027, 0.026, 0.026, 0.11)
)
)
shinyInput = function(FUN, len, id, ...) {
#validate(need(character(len)>0,message=paste("")))
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
output$ruless <- DT::renderDataTable({
datatable(
data.frame(delete=shinyInput(textInput,nrow(values$data),"cbox_"), values$data),
selection="multiple",
escape = FALSE,
filter = list(position = 'top', clear = FALSE),
extensions = list("ColReorder" = NULL, "Buttons" = NULL),
options = list(
dom = 'BRrltpi',
autoWidth=TRUE,
lengthMenu = list(c(10, 50, -1), c('10', '50', 'All')),
ColReorder = TRUE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
buttons = list(
'copy',
'print',
list(
extend = 'collection',
buttons = c('csv', 'excel', 'pdf'),
text = 'Download',
selected = TRUE
)
)
)
)
})
}
)
Related
I'm trying to update row-wise filter in datatable basis on the inputs we receive from user on every row, so that only relevant values in sub-sequent inputs can be selected.
I have tried to replicate my scenario using below code, where in if User selects "setosa" as "spieces_selector" hence only "1-50" values should appear in "New_Data_selector". Similarly if a User selects "versicolor" in 2nd row hence for 2nd row "New_Data_selector" should have the values from "51-100".
Would appreciate your help on this.
library(shiny)
library(DT)
iris$New_Data <- c(1:150)
ui <- fluidPage(
title = 'Selectinput column in a table',
h3("Source:", tags$a("Yihui Xie", href = "https://yihui.shinyapps.io/DT-radio/")),
numericInput('num', "enter a number", value = 5, min = 1, max = 10, step = 1),
DT::dataTableOutput('foo'),
verbatimTextOutput('sel'),
actionButton(
"saveBtn",
"Submit Request",
style = "color: #fff; background-color: #282364;
border-color: #2e6da4",
class = "btn btn-primary"
)
)
server <- function(input, output, session) {
data <- reactive({
df <- head(iris, input$num)
for (i in 1:nrow(df)) {
df$species_selector[i] <- as.character(selectInput(paste0("sel1", i),
"",
choices = unique(iris$Species),
width = "100px"))
df$New_Data_selector[i] <- as.character(selectInput(paste0("sel2", i),
"",
choices = unique(iris$New_Data),
width = "100px"))
}
df
})
output$foo = DT::renderDataTable(
data(), escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE),
callback = JS("table.rows().every(function(i, tab, row) {
var $this = $(this.node());
$this.attr('id', this.data()[0]);
$this.addClass('shiny-input-container');
});
Shiny.unbindAll(table.table().node());
Shiny.bindAll(table.table().node());")
)
output$sel = renderPrint({
str(sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]]))
})
observeEvent(input$saveBtn, {
Test_Data <- sapply(1:nrow(data()), function(i) input[[paste0("sel", i)]])
Test_Data <- as.data.frame(Test_Data)
print(Test_Data)})
}
shinyApp(ui, server)
The following works (based on my earlier answer) - but it's pretty slow. Will need to investigate further.
library(DT)
library(shiny)
library(datasets)
library(data.table)
myIris <- copy(iris)
setDT(myIris)
myIris[, Index := seq_len(.N)]
selectInputIDs_A <- paste0("sel_A", myIris$Index)
selectInputIDs_B <- paste0("sel_B", myIris$Index)
myIris[, selectInputs_A := sapply(selectInputIDs_A, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(myIris$Species), selected = "setosa"))})]
myIris[, selectInputs_B := sapply(selectInputIDs_B, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(myIris[Species == "setosa"]$Index), selected = "setosa"))})]
initTbl <- copy(myIris)
ui <- fluidPage(
DT::dataTableOutput(outputId = 'my_table')
)
server <- function(input, output, session) {
displayTbl <- reactive({
myIris[, selectInputs_A := sapply(selectInputIDs_A, function(x){as.character(selectInput(inputId = x, label = "", choices = unique(Species), selected = input[[x]]))}),]
myIris[, selectInputs_B := sapply(seq_along(selectInputs_B), function(x){as.character(selectInput(inputId = selectInputIDs_B[x], label = "", choices = unique(myIris[Species == input[[selectInputIDs_A[x]]]]$Index), selected = input[[selectInputIDs_A[x]]]))})]
})
output$my_table = DT::renderDataTable({
DT::datatable(
initTbl, escape = FALSE, selection = 'none', rownames = FALSE,
options = list(paging = FALSE, ordering = FALSE, scrollx = TRUE, dom = "t",
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
}, server = TRUE)
my_table_proxy <- dataTableProxy(outputId = "my_table", session = session)
observeEvent({sapply(selectInputIDs_A, function(x){input[[x]]})}, {
replaceData(proxy = my_table_proxy, data = displayTbl(), rownames = FALSE) # must repeat rownames = FALSE see ?replaceData and ?dataTableAjax
}, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)
I am working on below code definition:
If first column value is 'Modified' and second column contains column names which's values has been changed
based on this the data cell needs to be highlighted
I am referring to the code as reference : formatStyle over multiple columns DT R
Below is the definition of table
*
input_data1 <- data.frame(Record_Status = c("Modified","Modified","Modified","Modified","Modified","Modified","Modified","Modified","Modified"),
Field_Changed = c("Brand,ratio","cost","Name","ratio,Name","cost","Brand,cost","ratio,cost","cost","Name"),
Brand = c(3,6,9,12,15,18,21,24,27),
ratio = c (1,2,3,4,5,6,7,8,9),
cost = c(3,6,9,12,15,18,21,24,27),
Name = c("A","B","C","A","B","C","A","B","C"),
stringsAsFactors = FALSE)
hepl_1=tapply(1:ncol( input_data1),function(i) ifelse(( input_data1[[1]]=="Modified" &
str_detect( input_data1[[2]], names( input_data1)[i])),
"red","white"))
help_3=as.matrix( input_data1[1:ncol( input_data1)])
My datatable definition is as below:
output$mod_table <- DT::renderDataTable({
DT::datatable(input_data,selection = 'single',
escape=F, plugins = "ellipsis",
class = 'white-space: nowrap',
filter = list(position = 'top', clear = FALSE) , editable = TRUE,
extensions = c('Buttons','AutoFill','FixedHeader', 'KeyTable','ColReorder'),
rownames = F,
options = list(
keys = TRUE, colReorder = list(realtime = FALSE),
fixedHeader = TRUE, autoFill = list(focus = 'click', horizontal = FALSE) ,
autoWidth=TRUE, pageLength = 7 ,list(target = 'cell'),
lengthMenu = list(c(2, 50, -1), c('2', '50', 'All')), dom = 'lBfrtip',buttons = list(
c('colvis','pdf','excel'),
list(
extend = "collection",
text = 'Show All',
action = DT::JS("function ( e, dt, node, config ) { dt.page.len(-1);
dt.ajax.reload();
}"))))) %>% formatStyle(names(input_data), backgroundColor = styleEqual(help_3, hepl_1))
})
click here for image definition of Hepl1
click here for o/p datatable image - which is not giving me correct highlights
### Libraries
library(shiny)
library(dplyr)
library(DT)
### Data
input_data <- data.frame(Record_Status = c("Modified","Modified","Modified","Modified","Modified","Modified","Modified","Modified","Modified"),
Field_Changed = c("Brand,ratio","cost","Name","ratio,Name","cost","Brand,cost","ratio,cost","cost","Name"),
Brand = c(3,6,9,12,15,18,21,24,27),
ratio = c (1,2,3,4,5,6,7,8,9),
cost = c(3,6,9,12,15,18,21,24,27),
Name = c("A","B","C","A","B","C","A","B","C"),
stringsAsFactors = FALSE)
### Module
modFunction <- function(input, output, session, data,reset) {
v <- reactiveValues(data = data)
proxy = dataTableProxy("mod_table")
### Reset Table
observeEvent(reset(), {
v$data <- data # your default data
})
hepl_1=sapply(1:ncol(input_data),function(i) ifelse(input_data[[1]]=="Modified" &
str_detect(input_data[[2]], names(input_data)[i]),
"yellow","white"))
help_3=as.matrix(input_data)
#print(isolate(colnames(v$data)))
output$mod_table <- DT::renderDataTable({
DT::datatable(input_data,selection = 'single',
escape=F, plugins = "ellipsis",
class = 'white-space: nowrap',
filter = list(position = 'top', clear = FALSE) , editable = TRUE,
extensions = c('Buttons','AutoFill','FixedHeader', 'KeyTable','ColReorder'),
rownames = F,
options = list(
keys = TRUE, colReorder = list(realtime = FALSE),
fixedHeader = TRUE, autoFill = list(focus = 'click', horizontal = FALSE) ,
autoWidth=TRUE, pageLength = 7 ,list(target = 'cell'),
lengthMenu = list(c(2, 50, -1), c('2', '50', 'All')), dom = 'lBfrtip',buttons = list(
c('colvis','pdf','excel'),
list(
extend = "collection",
text = 'Show All',
action = DT::JS("function ( e, dt, node, config ) { dt.page.len(-1);
dt.ajax.reload();
}"))))) %>% formatStyle(names(input_data), backgroundColor = styleEqual(help_3, hepl_1))
})
}
modFunctionUI <- function(id) {
ns <- NS(id)
DT::dataTableOutput(ns("mod_table"))
}
### Shiny App
shinyApp(
ui = basicPage(
mainPanel(
actionButton("reset", "Reset"),
tags$hr(),
modFunctionUI("editable")
)
),
server = function(input, output) {
demodata<-input_data
callModule(modFunction,"editable", demodata,
reset = reactive(input$reset))
}
)
I have a dataTableOutput that includes a column of textInputs, following the instructions from this question:
Text Input Column in a table in shiny
I modified the code, so that the save button writes the data to a local csv file. However, I'm unable do get the content of the textInput. The column entries contain this kind of information:
<div class="form-group shiny-input-container">
<label class="control-label shiny-label-null" for="cbox_1"></label>
<input id="cbox_1" type="text" class="form-control" value=""/>
</div>
How do I get the actual value of the user input from cbox_1 and the other textInputs? Here is my complete code:
library(shiny)
library(DT)
library(dplyr)
shinyApp(
ui <- fluidPage(DT::dataTableOutput("ruless"),
fluidRow(column(4, offset = 1, actionButton("save", "Save", width = 200),))),
server <- function(input, output) {
values <- reactiveValues(data = NULL)
values$data <- as.data.frame(
cbind(c("a", "d", "b", "c", "e", "f"),
c(1463, 159, 54, 52, 52, 220),
c(0.7315, 0.0795, 0.027, 0.026, 0.026, 0.11)
)
)
shinyInput = function(FUN, len, id, ...) {
#validate(need(character(len)>0,message=paste("")))
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
dataExpTable <- reactive({
data.frame(delete=shinyInput(textInput,nrow(values$data),"cbox_"), values$data)
})
output$ruless <- DT::renderDataTable({
datatable(
dataExpTable(),
selection="multiple",
escape = FALSE,
filter = list(position = 'top', clear = FALSE),
extensions = list("ColReorder" = NULL, "Buttons" = NULL),
options = list(
dom = 'BRrltpi',
autoWidth=TRUE,
lengthMenu = list(c(10, 50, -1), c('10', '50', 'All')),
ColReorder = TRUE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
buttons = list(
'copy',
'print',
list(
extend = 'collection',
buttons = c('csv', 'excel', 'pdf'),
text = 'Download',
selected = TRUE
)
)
)
)
})
observeEvent(input$save, {
write.csv2(dataExpTable(), "test.csv", row.names = FALSE)
})
}
)
A colleauge helped me with the solution. The content of the textInputs can be accessed via the Ids that are created by the shinyInput function. It combines a prefix with the row number of the given data frame. A csv output via the save button could look like this:
observeEvent(
eventExpr = input$save,
handlerExpr = {
out_col <- character(nrow(values$data))
for (i in seq_len(nrow(values$data))) {
out_col[i] <- input[[paste0("cbox_", i)]]
}
out_df <- cbind(out_col, values$data)
write.csv2(out_df, "test.csv", row.names = FALSE)
}
)
I tried a similar approach before, but it did not work. I removed these options when creating the datatable:
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }')
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
However, they are mandatory to access the textInputs via their Ids.
I am trying to implement 'selectInput' in each row of data.frame using shiny and DT package. This post help me a lot to do that.
The following code should take inputs from each rows and update the Update_Select column for each click on 'Change' button.The problem is it updates the column once and become idle.
library(shiny)
library(DT)
ui <- fluidPage(
fluidRow(
fluidRow(column(6, actionButton("act", "Change:")),
column(6, verbatimTextOutput("txt", placeholder = T))),
fluidRow(column(12, DTOutput("react_tbl")))
)
)
server <- function(input, output, session) {
# Helper function for making checkbox
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
# Helper function for reading checkbox
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
alld <- reactiveValues(react_tbl = data.frame(cars, Rating = shinyInput(selectInput,
nrow(cars),
"selecter_",
choices=1:5,
width="60px"),
Update_Action = NA,
Update_Select = NA))
output$react_tbl = DT::renderDataTable(
alld$react_tbl,
selection = 'none',
server = FALSE,
escape = FALSE,
options = list(
dom = "t",
paging = TRUE,
pageLength = 20,
lengthMenu = c(5, 10, 20, 100, 1000, 10000),
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } '))
)
observeEvent(input$act,{
alld$react_tbl["Update_Action"] <- input$act
alld$react_tbl["Update_Select"] <- shinyValue("selecter_", nrow(alld$react_tbl))
})
output$txt <- renderText(shinyValue("selecter_", nrow(alld$react_tbl)))
}
shinyApp(ui, server)
You need to unbind when the data change.
ui <- fluidPage(
tags$head(tags$script(
HTML(
"Shiny.addCustomMessageHandler('unbindDT', function(id) {
var $table = $('#'+id).find('table');
if($table.length > 0){
Shiny.unbindAll($table.DataTable().table().node());
}
})")
)),
fluidRow(......
and in the server function:
observeEvent(alld$react_tbl, {
session$sendCustomMessage("unbindDT", "react_tbl")
})
I have DT where I added checkboxes as a first column. Their idea is to give the user the option of removing selected rows and placing them in a file. After pressing the button cold "delete", the data is sent to the file, but I do not know how to update DT, to get data without those deleted rows.
Code:
library(shiny)
library(DT)
library(dplyr)
shinyApp(
ui <- fluidPage(DT::dataTableOutput("ruless"),
fluidRow(column(4, offset = 1, actionButton("delete", "Delete", width = 200)))),
server <- function(input, output) {
values <- reactiveValues(data = NULL)
values$data <- as.data.frame(
cbind(c("a", "d", "b", "c", "e", "f"),
c(1463, 159, 54, 52, 52, 220),
c(0.7315, 0.0795, 0.027, 0.026, 0.026, 0.11)
)
)
shinyInput = function(FUN, len, id, ...) {
#validate(need(character(len)>0,message=paste("")))
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, ...))
}
inputs
}
output$ruless <- DT::renderDataTable({
datatable(
data.frame(delete=shinyInput(checkboxInput,nrow(values$data),"cbox_"), values$data),
selection="multiple",
escape = FALSE,
filter = list(position = 'top', clear = FALSE),
extensions = list("ColReorder" = NULL, "Buttons" = NULL),
options = list(
dom = 'BRrltpi',
autoWidth=TRUE,
lengthMenu = list(c(10, 50, -1), c('10', '50', 'All')),
ColReorder = TRUE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } '),
buttons = list(
'copy',
'print',
list(
extend = 'collection',
buttons = c('csv', 'excel', 'pdf'),
text = 'Download',
selected = TRUE
)
)
)
)
})
shinyValue = function(id, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
}
observeEvent(input$delete, {
checkbox_rules <- data.frame(selected=shinyValue("cbox_",nrow(values$data)))
marked_rules <- as.data.frame(values$data[(which(checkbox_rules == TRUE)),])
if (file.exists("delete_file.csv")){
delete_file <- as.data.frame(read_csv2("delete_file.csv", col_names = TRUE))
delete_file <- as.data.frame(rbind(delete_file, marked_rules))
delete_file <- delete_file[!duplicated(delete_file), ]
write.csv2(delete_file, file = "delete_file.csv", sep=";", row.names = FALSE)
}
else{
write.csv2(marked_rules, file = "delete_file.csv", sep=";", row.names = FALSE)
}
})
}
)
I would like also to replace delete button and rename rest of buttons above DT. I am thinking about something like that:
I it possible to do? Thank in advance!
Is it possible?
You can update the data.frame in the observer like this
values$data <- values$data[!checkbox_rules,]
At the end it should look something like this
observeEvent(input$delete, {
checkbox_rules <- data.frame(selected=shinyValue("cbox_",nrow(values$data)))
marked_rules <- as.data.frame(values$data[(which(checkbox_rules == TRUE)),])
values$data <- values$data[!checkbox_rules,]
if (file.exists("delete_file.csv")){
delete_file <- as.data.frame(read_csv2("delete_file.csv", col_names = TRUE))
delete_file <- as.data.frame(rbind(delete_file, marked_rules))
delete_file <- delete_file[!duplicated(delete_file), ]
write.csv2(delete_file, file = "delete_file.csv", sep=";", row.names = FALSE)
}
else{
write.csv2(marked_rules, file = "delete_file.csv", sep=";", row.names = FALSE)
}
})
hope this helps!