My issue is when showing my new modal. As soon as a user clicks on the modal, it disappears.
Is there a way to resolve this? I have tried to call all functions shown in the code below.
header <- dashboardHeader(title = "Example")
body <- dashboardBody(mainPanel(DT::dataTableOutput("mytable"),
uiOutput("sd")))
ui <- dashboardPage(header, sidebar, body, skin = "red")
server = function(input, output, session)
{
mymtcars <<- mtcars
mymtcars$id <<- 1:nrow(mtcars)
output$sd <- renderUI({
lapply(seq_len(nrow(mymtcars)),
function(i)
{
bsModal(paste0("myModal", i), "Your plot", paste0("btn", i), size = "large",
dataTableOutput(paste0("plot", i)))
})
})
iris$new <- paste0("<a href=\'https://r-studio.vip.ebay.com/shiny/map-analytics/qa/app_topics/',\ target='_blank'>Click Here for Reviews</a>")
output$mytable = DT::renderDataTable({
btns <- shinyInput(actionButton, nrow(mymtcars), "btn", label = "Show modal")
DT::datatable(cbind(Pick = btns, mymtcars), escape = F,
options = list(orderClasses = TRUE,
preDrawCallback = JS("function() {
Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = JS("function() {
Shiny.bindAll(this.api().table().node()); } ")))
},server = FALSE)
lapply(seq_len(nrow(mymtcars)), function(i)
{
output[[paste0("plot", i)]] <- renderDataTable(datatable(iris,escape = F, rownames = F))
observeEvent(input[[paste0("btn", i)]], {
toggleModal(session, paste0("myModal", i), "open")
print("Pressed")
})
})
}
runApp(list(ui = ui, server = server))
Related
I want to create a table in RShiny with numericInput so that user-supplied values can be used immediately. I followed the code HERE, but as the variables (car models) changes, it stops printing the new values. It works fine until the user changes the input.
Here is the code:
library(shiny)
library(DT)
library(tidyverse)
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());
}
})")
)),
title = 'selectInput or numericInput column in a table',
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "cars", label = "Car model", choices = rownames(mtcars), selected = rownames(mtcars)[1:6], multiple = T )
),
mainPanel(
DT::dataTableOutput('carTable'),
verbatimTextOutput('price')
)
)
)
server <- function(input, output, session) {
rvar <- reactiveValues(
DF = mtcars
)
observeEvent(input$cars,{
for (i in 1:nrow(rvar$DF)) {
rvar$DF$price[i] <- as.character(numericInput(paste0("price", i), "", 0, width = "100px"))
}
rvar$data <- rvar$DF[rownames(mtcars) %in% input$cars, ] %>% select(-price)
})
output$carTable = DT::renderDT({
data <- rvar$DF[rownames(mtcars) %in% input$cars, ] %>% mutate(carmodel = input$cars) %>% relocate(carmodel)
datatable(
data, escape = FALSE, selection = 'none',
options = list(
dom = 't',
paging = FALSE,
ordering = FALSE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); }')
),
rownames = FALSE
)
}, server = FALSE)
output$price = renderPrint({
str(sapply(1:nrow(rvar$data), function(i) input[[paste0("price", i)]]))
})
observe({
updatedPrice <- sapply(1:nrow(rvar$DF), function(i) input[[paste0("price", i)]]) %>% Reduce(c,.)
if(is.null(updatedPrice) | length(updatedPrice) != nrow(rvar$data)){
updatedPrice <- 0
}
isolate({
rvar$data$price <- updatedPrice
})
print(sapply(1:nrow(rvar$data), function(i) input[[paste0("price", i)]]) %>% Reduce(c,.))
print(rvar$data)
})
observeEvent(input$cars, {
session$sendCustomMessage("unbindDT", "carTable")
})
}
shinyApp(ui, server)
Works like this. It took me several trials and I don't exactly remember what were the problems...
library(shiny)
library(DT)
library(tidyverse)
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());
}
})")
)),
title = "selectInput or numericInput column in a table",
sidebarLayout(
sidebarPanel(
selectizeInput(
inputId = "cars", label = "Car model",
choices = rownames(mtcars), selected = rownames(mtcars)[1:6],
multiple = TRUE
)
),
mainPanel(
DTOutput("carTable"),
verbatimTextOutput("price")
)
)
)
server <- function(input, output, session) {
rvar <- reactiveValues(
DF = mtcars
)
observeEvent(input$cars, {
rvar$DF <- rvar$DF[rownames(mtcars) %in% input$cars, ]
for(i in 1:nrow(rvar$DF)) {
rvar$DF$price[i] <-
as.character(numericInput(paste0("price", i), "", 0, width = "100px"))
}
rvar$data <- rvar$DF %>% select(-price)
rvar$DTdata <- rvar$DF %>%
mutate(carmodel = input$cars) %>%
relocate(carmodel)
session$sendCustomMessage("unbindDT", "carTable")
})
output$carTable <- renderDT({
data <- rvar$DTdata
datatable(
data,
escape = FALSE, selection = "none",
options = list(
dom = "t",
paging = FALSE,
ordering = FALSE,
preDrawCallback =
JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback =
JS('function() { Shiny.bindAll(this.api().table().node()); }')
),
rownames = FALSE
)
},
server = FALSE
)
output$price <- renderPrint({
str(sapply(1:nrow(rvar$data), function(i) input[[paste0("price", i)]]))
})
observe({
updatedPrice <-
sapply(1:nrow(rvar$DF), function(i) input[[paste0("price", i)]]) %>%
Reduce(c, .)
if(is.null(updatedPrice) || length(updatedPrice) != nrow(rvar$data)) {
updatedPrice <- 0
}
isolate({
rvar$data$price <- updatedPrice
})
print(
sapply(1:nrow(rvar$data), function(i) input[[paste0("price", i)]]) %>%
Reduce(c, .)
)
print(rvar$data)
})
}
shinyApp(ui, server)
I would like to obtain the row number and choice selected each time an input is changed in one of the selectInput. The following is a test code. So in short if I change the species in row three, using observeEvent I would like the output to tell me what row was it in and what was picked.
Is there a way of doing this.
library(shiny)
library(DT)
ui <- fluidPage(
DT::dataTableOutput('foo'),
textOutput("text")
)
server <- function(input, output, session) {
data <- head(iris, 5)
for (i in 1:nrow(data)) {
data$species_selector[i] <- as.character(selectInput(paste0("change", i), label = paste0("change", i), choices = unique(iris$Species), width = "100px"))
}
output$foo = DT::renderDataTable(
data, escape = FALSE, selection = 'none', server = FALSE,
options = list(dom = 't', paging = FALSE, ordering = FALSE))
observeEvent$...
}
shinyApp(ui, server)
First, you have to use these options preDrawCallback and drawCallback, otherwise Shiny is not aware of the selectors:
output[["foo"]] <- renderDT(
data, escape = FALSE, selection = 'none', server = FALSE,
options = list(
dom = 't',
paging = FALSE,
ordering = FALSE,
preDrawCallback = JS(
"function() { Shiny.unbindAll(this.api().table().node()); }"
),
drawCallback = JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
)
)
)
Now, you can use two reactive values to store the row and the species:
row <- reactiveVal()
species <- reactiveVal()
And then, define an observer for each row:
lapply(1:nrow(data), function(i){
selector <- paste0("change", i)
observeEvent(input[[selector]], {
row(i)
species(input[[selector]])
})
})
Full app:
library(shiny)
library(DT)
ui <- fluidPage(
br(),
DTOutput('foo'),
br(),
wellPanel(
textOutput("text")
)
)
server <- function(input, output, session) {
data <- head(iris, 5)
data$species_selector <- vapply(1:nrow(data), function(i){
as.character(selectInput(
paste0("change", i),
label = paste0("change", i),
choices = unique(iris$Species),
width = "100px"
))
}, character(1))
output[["foo"]] <- renderDT(
data, escape = FALSE, selection = 'none', server = FALSE,
options = list(
dom = 't',
paging = FALSE,
ordering = FALSE,
preDrawCallback = JS(
"function() { Shiny.unbindAll(this.api().table().node()); }"
),
drawCallback = JS(
"function() { Shiny.bindAll(this.api().table().node()); }"
)
)
)
row <- reactiveVal()
species <- reactiveVal()
lapply(1:nrow(data), function(i){
selector <- paste0("change", i)
observeEvent(input[[selector]], {
row(i)
species(input[[selector]])
})
})
output[["text"]] <- renderText({
sprintf("Row %d --- Species %s", row(), species())
})
}
shinyApp(ui, server)
I am trying to add a column of buttons in my datatable that when clicked will pull up a modal but I am having trouble using the examples I found online here and here.
Some of my requirements:
Needs to work with an unknown number of rows in the dataset (could be 5, could be 10, could be 500)
Each button needs to be unique id which I can use to reference the row (in the example you can see I am pulling in the row number into the modal - real life I am using the row number to subset my data and actually put information in the modal)
Code:
library(shiny)
library(shinydashboard)
library(DT)
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
DTOutput('x1'),
verbatimTextOutput("test")
)
)
server = function(input, output) {
##DATA TABLE WHERE I NEED A BUTTON##
output$x1 = renderDT(
iris,
selection = 'single',
options = list(
)
)
##MODAL CALLED BASED ON BUTTON CLICK
observeEvent(input$x1_cell_clicked, {
row = input$x1_cell_clicked$row
if (is.null(row) || row == '') {} else{
showModal(modalDialog(
title = paste0("Timeline!",row),
size = "s",
easyClose = TRUE,
footer = NULL
))
}
})
output$test <- renderPrint({
input$x1_cell_clicked$row
})
}
shinyApp(ui, server)
In your comment, you asked for the case of multiple datatables. Is it what you want ?
library(shiny)
library(DT)
button <- function(tbl){
function(i){
sprintf(
'<button id="button_%s_%d" type="button" onclick="%s">Click me</button>',
tbl, i, "Shiny.setInputValue('button', this.id);")
}
}
dat1 <- cbind(iris,
button = sapply(1:nrow(iris), button("tbl1")),
stringsAsFactors = FALSE)
dat2 <- cbind(mtcars,
button = sapply(1:nrow(mtcars), button("tbl2")),
stringsAsFactors = FALSE)
ui <- fluidPage(
fluidRow(
column(
width = 6,
DTOutput("tbl1", height = "500px")
),
column(
width = 6,
DTOutput("tbl2", height = "500px")
)
)
)
server <- function(input, output){
output[["tbl1"]] <- renderDT({
datatable(dat1, escape = ncol(dat1)-1, fillContainer = TRUE)
})
output[["tbl2"]] <- renderDT({
datatable(dat2, escape = ncol(dat2)-1, fillContainer = TRUE)
})
observeEvent(input[["button"]], {
splitID <- strsplit(input[["button"]], "_")[[1]]
tbl <- splitID[2]
row <- splitID[3]
showModal(modalDialog(
title = paste0("Row ", row, " of table ", tbl, " clicked"),
size = "s",
easyClose = TRUE,
footer = NULL
))
})
}
shinyApp(ui, server)
Was able to figure it out using this.
library(shiny)
library(shinydashboard)
library(DT)
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
DTOutput('x1'),
verbatimTextOutput("test")
)
)
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
}
iris_rows <- nrow(iris)
iris$Timeline = shinyInput(actionButton, iris_rows, 'button_', label = "Timeline", onclick = 'Shiny.setInputValue(\"select_button\", this.id, {priority: \"event\"})' )
##DATA TABLE WHERE I NEED A BUTTON##
output$x1 = renderDT(
iris,
selection = 'single',
escape = FALSE,
options = list(
)
)
##MODAL CALLED BASED ON BUTTON CLICK
observeEvent(input$select_button, {
row <- as.numeric(strsplit(input$select_button, "_")[[1]][2])
if (is.null(row) || row == '') {} else{
showModal(modalDialog(
title = paste0("Timeline!",row),
size = "s",
easyClose = TRUE,
footer = NULL
))
}
})
output$test <- renderPrint({
as.numeric(strsplit(input$select_button, "_")[[1]][2])
})
}
shinyApp(ui, server)
Code with multiple data tables to show a separate answer than the one chosen.
library(shiny)
library(shinydashboard)
library(DT)
ui = dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
DTOutput('x1'),
DTOutput('x2'),
verbatimTextOutput("test")
)
)
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
}
iris2 <- iris
iris_rows <- nrow(iris)
iris$Timeline = shinyInput(actionButton, iris_rows, 'button_x1_', label = "Timeline", onclick = 'Shiny.setInputValue(\"select_button1\", this.id, {priority: \"event\"})' )
iris2_rows <- nrow(iris2)
iris2$Timeline = shinyInput(actionButton, iris2_rows, 'button_x2_', label = "Timeline", onclick = 'Shiny.setInputValue(\"select_button2\", this.id, {priority: \"event\"})' )
##DATA TABLE WHERE I NEED A BUTTON##
output$x1 = renderDT(
iris,
selection = 'single',
escape = FALSE,
options = list(
)
)
output$x2 = renderDT(
iris2,
selection = 'single',
escape = FALSE,
options = list(
)
)
##MODAL CALLED BASED ON BUTTON CLICK
observeEvent(input$select_button1, {
row <- as.numeric(strsplit(input$select_button1, "_")[[1]][3])
if (is.null(row) || row == '') {} else{
showModal(modalDialog(
title = paste0("Timeline!",row),
size = "s",
easyClose = TRUE,
footer = NULL
))
}
})
observeEvent(input$select_button2, {
row <- as.numeric(strsplit(input$select_button2, "_")[[1]][3])
if (is.null(row) || row == '') {} else{
showModal(modalDialog(
title = paste0("Timeline!",row),
size = "s",
easyClose = TRUE,
footer = NULL
))
}
})
output$test <- renderPrint({
as.numeric(strsplit(input$select_button1,"_")[[1]][3])
})
}
shinyApp(ui, server)
I'm trying to create a datatable with Shiny input elements (checkboxInput or textInput). This works well until I update the datatable. If I add more rows with more input elements, only the new elements work. I thought the table would be recreated every time I update it and the ids would be associated with the new input elements. The code example below illustrates the problem. It creates a table with one row first. If I then create a table with two rows using the dropdown on the left, I can only read the values of the second row in the output table. Any change to the inputs of the first row has no impact on the ouput table.
library(DT)
library(shiny)
server <- function(input, output) {
updateTable <- reactive({
num <- as.integer(input$num)
df <- data.frame(check = unlist(lapply(1:num, function(i) as.character(checkboxInput(paste0("check_", i), label = paste0("check", i), value = 0)))),
text = unlist(lapply(1:num, function(i) as.character(textInput(paste0("text_",i), label = paste0("text", i), value = "")))))
})
output$input_ui <- DT::renderDataTable(
updateTable(),
server = FALSE, escape = FALSE, selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,lengthChange = TRUE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
)
)
output$table <- renderTable({
num <- as.integer(input$num)
data.frame(lapply(1:num, function(i) {
paste(input[[paste0("check_", i)]], input[[paste0("text_",i)]], sep = " : ")
}))
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("num", "select number of inputs", choices = seq(1,10,1))
),
mainPanel(
DT::dataTableOutput("input_ui"),
tableOutput("table")
)
)
)
shinyApp(ui = ui, server = server)
A possible solution is provided here:
https://groups.google.com/d/msg/shiny-discuss/ZUMBGGl1sss/7sdRQecLBAAJ
As far as I understand, it allows to "force" a complete unbind of all checkbox/textinpts before redrawing the table thanks to the use of:
session$sendCustomMessage('unbind-DT', 'input_ui')
. I do not pretend to really understsand it, but apparently it works. See below for a possible implementation.
library(shiny)
library(DT)
server <- function(input, output,session) {
updateTable <- reactive({
num <- as.integer(input$num)
session$sendCustomMessage('unbind-DT', 'input_ui')
df <- data.frame(
check = unlist(lapply(1:num, function(i) as.character(checkboxInput(paste0("check_", i), label = paste0("check", i), value = 0)))),
text = unlist(lapply(1:num, function(i) as.character(textInput(paste0("text_",i), label = paste0("text", i), value = "")))))
tbl <- DT::datatable(df, escape = FALSE,
selection = "none",
options = list(
dom = 't', paging = FALSE, ordering = FALSE,lengthChange = TRUE,
preDrawCallback = JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))
})
output$input_ui <- DT::renderDataTable(
updateTable(),
server = FALSE
)
output$table <- renderTable({
num <- as.integer(input$num)
data.frame(lapply(1:num, function(i) {
paste(input[[paste0("check_", i)]], input[[paste0("text_",i)]], sep = " : ")
}))
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("num", "select number of inputs", choices = seq(1,10,1))
),
mainPanel(
DT::dataTableOutput("input_ui"),
tags$script(HTML(
"Shiny.addCustomMessageHandler('unbind-DT', function(id) {
Shiny.unbindAll($('#'+id).find('table').DataTable().table().node());
})")),
tableOutput("table")
)
)
)
shinyApp(ui = ui, server = server)
HTH!
I have a column with TRUE or FALSE values
data("mtcars")
mtcars$Favorite <- "FALSE"
I am interested in displaying this column (Favorite) as a checkbox on shiny.
runApp(list(
ui = basicPage(
h2('The mtcars data'),
dataTableOutput('mytable')
),
server = function(input, output) {
output$mytable = renderDataTable({
mtcars
})
}
))
Source : http://shiny.rstudio.com/articles/datatables.html
Not sure how to make it work, any help is much appreciated.
Is this what you're looking for?
library(shiny)
library(DT) # dev from github
runApp(list(
ui = basicPage(
h2('The mtcars data'),
DT::dataTableOutput('mytable'),
h2("Selected"),
tableOutput("checked")
),
server = function(input, output) {
# 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
}
# datatable with checkbox
output$mytable = DT::renderDataTable({
data.frame(mtcars,Favorite=shinyInput(checkboxInput,nrow(mtcars),"cbox_"))
}, server = FALSE, escape = FALSE, options = list(
paging=FALSE,
preDrawCallback = JS('function() {
Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {
Shiny.bindAll(this.api().table().node()); } ')
) )
# 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
}))
}
# output read checkboxes
output$checked <- renderTable({
data.frame(selected=shinyValue("cbox_",nrow(mtcars)))
})
}
))