Render DT Datatables in Bootstrap Card in R/Shiny - r

Below is a minimal reproducible example of my problem. What I need to do is render a datatable inside of a bootstrap card. In the example below, the rendering of output$somethingMore does just that. However, in my real world example, I have a slightly more complicated scenario where I cannot pass the data table to the card as I have done there.
Instead, I need to create a table rendered as in my output$brokenIdea example and then take that object and put it inside the card. Of course, my brokenIdea example below is indeed broken, or perhaps even more fallible than that in that's conceptually a bad idea.
However, I am looking to see if there is a solution to this idea so that output$brokenIdea can be created and then passed to the card in a renderUI.
For some context for those who might ask why, this is needed because I have an editable DT table in my real world app and (to my knowledge) being able to edit a data table as in this example here requires an observer paying attention to whether the table outputted in the browser is edited.
My code doesn't have those details in it, but the example above does show the context of the overall situation.
library(shiny)
library(bslib)
library(shinyWidgets)
library(DT)
card <- function(body, title) {
div(class = "card",
div(icon("chart-line", style = "color:white"), class = "card-header bg-success text-white text-center font-weight-bold", title),
div(class = "card-body d-flex justify-content-center", body)
)
}
ui <- fluidPage(
navbarPage(
theme = bs_theme(bootswatch = "flatly", version = 4),
title = 'Methods',
tabPanel('One'),
),
mainPanel(
h1('Hello World'),
uiOutput('something'),
br(),
DTOutput('somethingElse'),
br(),
uiOutput('somethingMore'),
#uiOutput('brokenIdea')
)
)
server <- function(input, output) {
output$something <- renderUI({
card('Test', 'Hello')
})
output$somethingElse <- renderDT({
tab <- data.frame(x= rnorm(5), y = rnorm(5))
DT::datatable(tab)
})
### I could do this
output$somethingMore <- renderUI({
tab <- data.frame(x= rnorm(5), y = rnorm(5))
out <- DT::datatable(tab)
card(out, 'Hi')
})
### But what I need is
output$brokenIdea <- renderUI({
card(output$somethingElse, 'Can this work')
})
}
shinyApp(ui, server)

Put your DTOutput('somethingElse')...) inside renderUI
library(shiny)
library(bslib)
library(shinyWidgets)
library(DT)
card <- function(body, title) {
div(class = "card",
div(icon("chart-line", style = "color:white"), class = "card-header bg-success text-white text-center font-weight-bold", title),
div(class = "card-body d-flex justify-content-center", body)
)
}
ui <- fluidPage(
navbarPage(
theme = bs_theme(bootswatch = "flatly", version = 4),
title = 'Methods',
tabPanel('One'),
),
mainPanel(
h1('Hello World'),
uiOutput('something'),
br(),
br(),
uiOutput('somethingMore'),
uiOutput('brokenIdea')
)
)
server <- function(input, output) {
output$something <- renderUI({
card('Test', 'Hello')
})
tab <- reactive({
invalidateLater(3000)
data.frame(x= rnorm(5), y = rnorm(5))
})
output$somethingElse <- renderDT({
DT::datatable(tab())
})
### I could do this
output$somethingMore <- renderUI({
tab <- data.frame(x= rnorm(5), y = rnorm(5))
out <- DT::datatable(tab)
card(out, 'Hi')
})
### But what I need is
output$brokenIdea <- renderUI({
card(DTOutput('somethingElse'), 'Can this work')
})
}
shinyApp(ui, server)
reactive is used in my example to hold the table. To simulate the table changing dynamically, I make it change every 5 seconds.

Related

How to change elements of 'navbarPage' and 'tabPanel' components after loading R Shiny reactive system?

I am researching how to change elements 'navbarPage' and 'tabPanel' components after loading R Shiny reactive system. Here is a code
library(shiny)
# How to change these elements after loading R Shiny reactive system
str_title <- "Title"
str_window_title <- "Window title"
str_cars <- "Cars"
str_iris <- "Iris"
# UI
ui <- fluidPage(
navbarPage(
title = str_title,
windowTitle = str_window_title,
tabPanel(title = str_cars, fluidPage(fluidRow(dataTableOutput("dt_mtcars")))),
tabPanel(title = str_iris, fluidPage(fluidRow(dataTableOutput("dt_iris"))))
))
# SERVER
server <- function(input, output) {
output$dt_mtcars <- renderDataTable(datatable(mtcars))
output$dt_iris <- renderDataTable(datatable(iris))
}
# RUN APP
shinyApp(ui = ui, server = server)
The question is how to change values of 'title', 'window_title' for 'navbarPage' component, and 'title' for 'tabPanel' component AFTER loading the Shiny app. For example, add to these names the prefix 'New ' and have the values 'New Title', 'New Window title', 'New Cars', 'New Iris'.
Thanks for sharing your ideas!
I couldn't find a solution for windowTitle, but for the 3 others elements you can use a textOutput and reactive values to make the elements change.
Here is an example of changing the elements names after clicking on an action button.
EDIT : found a way to change windowTitle too, based on this answer
library(shiny)
library(DT)
# UI
ui <- fluidPage(
actionButton("btn", "Change components' names"),
#javascript code to change window title
tags$script(HTML('Shiny.addCustomMessageHandler("changetitle", function(x) {document.title=x});')),
navbarPage(
title = textOutput("str_title"),
windowTitle = "Window title",
tabPanel(title = textOutput("str_cars"), fluidPage(fluidRow(dataTableOutput("dt_mtcars")))),
tabPanel(title = textOutput("str_iris"), fluidPage(fluidRow(dataTableOutput("dt_iris"))))
))
# SERVER
server <- function(input, output, session) {
# initialize names
rv <- reactiveValues(str_title = "Title",
str_window_title = "Window title",
str_cars ="Cars",
str_iris = "Iris")
output$dt_mtcars <- renderDataTable(datatable(mtcars))
output$dt_iris <- renderDataTable(datatable(iris))
output$str_title <- renderText({
rv$str_title
})
output$str_window_title <- renderText({
rv$str_window_title
})
output$str_cars <- renderText({
rv$str_cars
})
output$str_iris <- renderText({
rv$str_iris
})
#change names when button is clicked
observeEvent(input$btn,{
print("Change names")
rv$str_title <- paste0(rv$str_title,"+")
rv$str_window_title <- paste0(rv$str_window_title,"+")
rv$str_cars <- paste0(rv$str_cars,"+")
rv$str_iris <- paste0(rv$str_iris,"+")
session$sendCustomMessage("changetitle", rv$str_window_title )
})
}
# RUN APP
shinyApp(ui = ui, server = server)

Generate UI elements side-by-side in R Shiny app

I'm developing an R Shiny app and am trying to append two output objects side-by-side as part of the same UI element. However, when I use splitLayout() Shiny creates a space between the two objects highlighted below:
Is there a way to get the two objects to appear immediately side-by-side without the space in between? Please see code behind stylized example below:
# define mapping table
col1 <- c("AAAA" , "BBBB" , "CCCC" , "DDDD")
col2 <- c(1:4)
map <- as.data.frame(cbind(col1, col2))
# define and execute app
ui <- fluidPage(
selectInput(inputId = "object_A", label = "Select Object A",
choices = c("AAAA", "BBBB" , "CCCC"), selected = NULL, multiple = FALSE),
actionButton("go","Run Output"),
tags$br(),
fluidRow(
column(width = 4,
uiOutput(outputId = "select_object")
)
)
)
server <- function(input, output) {
observeEvent(input$go, output$select_object <-
renderUI({
splitLayout(
input$object_A,
map[which(map["col1"]==input$object_A),"col2"]
)
})
)
}
shinyApp(ui = ui, server = server)
You can use a flexbox:
observeEvent(input$go, {
output$select_object <-
renderUI({
div(
style = "display:-webkit-flex; display:-ms-flexbox; display:flex;",
div(input$object_A),
div(style = "width: 30px;"), # white space
div(map[which(map["col1"]==input$object_A),"col2"])
)
})
})
To center the flexbox items:
style = "display:-webkit-flex; display:-ms-flexbox; display:flex; justify-content:center;"
More info on flexbox: guide to flexbox.
For text only, you could use paste instead of splitLayout :
observeEvent(input$go, output$select_object <-
renderUI({
paste(
input$object_A,
map[which(map["col1"]==input$object_A),"col2"]
)
})
)

How can I refer an action button to an inserted plot (insertUI/removeUI) in shiny

I have asked this question in the RStudio community and didn't get help, so I try it here:
I am trying to add the following functionality to my app: When the user inserts a plot, a remove button should appear that specifically removes the plot that was inserted at the same time. The app is based on insertUI and removeUI.
This would be the example app.
library(shiny)
library(shinydashboard)
# Example data
a<-(letters)
b<-rnorm(length(letters), 4,2)
c<-rnorm(length(letters), 10,15)
d<-c(1:10,20:30,45:49)
data<-data.frame(a,b,c,d)
names(data)<-c("name","v1","v2","v3")
# UI
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
actionButton("add", "Add"),
radioButtons("add_elements","", c("Element1", "Element2"))
),
dashboardBody(
fluidRow( tags$div(id="placeholder")
)
))
# Server Logic
server <- function(input, output, session) {
# Initialize empty vector
inserted<- c()
# Observer
observeEvent(input$add, {
id_add <- paste0(input$add, input$add_elements)
insertUI(selector = '#placeholder', where = "afterEnd",
ui= switch(input$add_elements,
'Element1'= plotOutput(id_add),
'Element2' = plotOutput(id_add))
)
output[[id_add]] <-
if (input$add_elements == "Element1")
renderPlot({
plot(data[,1],data[,2])
}) else if (input$add_elements == "Element2")
renderPlot({
plot(data[,1],data[,4])
})
inserted <<- c(id_add,inserted)
insertUI(
selector = "#placeholder",
where = "afterEnd",
ui = tags$div(actionButton("remove_button", "Remove"))
)})
## Remove Elements ###
observeEvent(input$remove_button, {
removeUI(
selector = paste0('#', inserted[length(inserted)])
)
inserted <<- inserted[-length(inserted)]
})
}
shinyApp(ui = ui, server = server)
When a plot is inserted, it gets an ID, such as 1Element1 or 2Element2. I am now wondering how could a remove button only refer to a plot with this exact ID?
So far, I have worked with a single remove button that removes the last inserted plot by defining a vector that stores the IDs.
selector = paste0('#', inserted[length(inserted)])
This is not very useful when a user needs to compare many plots. I have a limited understanding in using these selectors and absolutely no idea how could incorporate a remove button for every plot that only removes the respective plot. Any help would be highly appreciated.
Also, this link may help since it shows a similar functionality (that I was obviously not able to implement).
In this kind of situation I always use 'list' with 'reactiveValues' like below:
library(shiny)
library(shinydashboard)
# Example data
a<-(letters)
b<-rnorm(length(letters), 4,2)
c<-rnorm(length(letters), 10,15)
d<-c(1:10,20:30,45:49)
data<-data.frame(a,b,c,d)
names(data)<-c("name","v1","v2","v3")
# UI
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
actionButton("add", "Add"),
radioButtons("add_elements","", c("Element1", "Element2"))
),
dashboardBody(
uiOutput("myUI")
))
# Server Logic
server <- function(input, output, session) {
alld <- reactiveValues()
alld$ui <- list()
output$myUI <- renderUI({
alld$ui
})
# Observer
observeEvent(input$add, {
id_add <- length(alld$ui)+1
alld$ui[[id_add]] <- list(
plotOutput(paste0("plt",id_add)),
actionButton(paste0("remove_button", id_add), "Remove")
)
if (input$add_elements == "Element1"){
output[[paste0("plt",id_add)]] <- renderPlot(plot(data[,1],data[,2]))
} else {
output[[paste0("plt",id_add)]] <- renderPlot(plot(data[,1],data[,4]))
}
})
## Remove Elements (for all plots) ###
observe({
lapply(seq_len(length(alld$ui)), function(i){
id_add <- i
observeEvent(input[[paste0("remove_button", id_add)]], {
alld$ui[[id_add]][1] <- NULL
})
})
})
}
shinyApp(ui = ui, server = server)

Shiny Datatable Click ID not working

Back again. Working on a project and I'm stuck. My click isn't working. I've tried every iteration and can't figure it out. Basically I want to select multiple lines in a datatable via a click, at which point I'll do some more filtering. The click I'm having issues with. Here's my code... Do you see anything I'm missing? Thanks.
library(forecast)
library(shiny)
library(shinythemes)
library(ggplot2)
library(dplyr)
library(scales)
library(DT)
library(forecast)
library(shiny)
library(shinythemes)
library(ggplot2)
library(dplyr)
library(scales)
library(DT)
source("NEW.R", local = TRUE)
branch1 <- unique(distinctlineitems$BRANCH)
ui <- navbarPage(
theme = shinytheme("cosmo"),
title = "EXPENDITURES",
tabPanel("TAB1",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("branches",label = NULL,choices = branch1 ,selected = NULL),
actionButton('selectallB','Select All'),
textInput("words", "Search"),
h5("Separate keywords with commas."),
plotOutput("plot", width = "100%"),
plotOutput("season", width = "100%")),
# Show a plot of the generated distribution
mainPanel(
fluidRow(csvDownloadUI("dwnld", "DOWNLOAD"), style = "padding:10px"),
DT::dataTableOutput("table")
server <- function(input, output, session) {
branchfilter <- reactive({
filt <- distinctlineitems[distinctlineitems$BRANCH %in% input$branches,]
return(filt)
})
graphids <- reactive({
if(length(input$table_rows_selected) < 1) return(NULL)
id <- input$table_rows_selected
x <- branchfilter()$REMARKS[id]
})
output$table <- renderDataTable({
test <- DT::datatable(branchfilter(),
filter = "top",
rownames = FALSE,
selection = "multiple")
})
Turns out I was able to answer my own question on this one. Because I was trying to test it under a Reactive I was unable to see the output. In order to test, I had to wrap in an observe statement. So easy. After the fact. Thanks tobiaseli_te.
observe(print(graphids()))

SelectInput and if loop plot R Shiny

I know this is a basic question, but I'm really new at Shiny...
How can I combine plotlyOutput with an if loop from a SelectInput box?
I mean something like this:
vars <- data.frame(location = c("AP LIGUA",
"ESCUELA CHALACO"),
lat = c(-32.45,
-32.183333),
lon = c(-71.216667,
-70.802222)
)
selectInput(inputId = "myLocations", label = "EstaciĆ³n",
choices = vars$location),
if (vars$location=="AP LIGUA") {
plotlyOutput("apligua", height = "100%")
fluidRow(
DT::dataTableOutput("table")
)
}
But it does not work.
I suppose you truncated your code? It doesn't look very much like a shiny app. This is what a shiny app should look like.
vars <- data.frame(location = c("AP LIGUA",
"ESCUELA CHALACO"),
lat = c(-32.45,
-32.183333),
lon = c(-71.216667,
-70.802222)
)
ui <- fluidPage(
selectInput(inputId = "myLocations", label = "EstaciĆ³n",
choices = vars$location),
plotlyOutput("apligua", height = "100%"),
dataTableOutput("table")
)
server <- function(input, output,session) {
output$apligua <- renderPlotly({
if(is.null(input$myLocations)) return() #react to the user's choice if there's one
plot_ly(...)
})
output$table <- renderDataTable({
if(is.null(input$myLocations)) return() #same thing, react to the user's choice
data.table(...)
})
}
shinyApp(ui, server)

Resources