Context
I'm building an app whith Rshiny. I created a dynamic navbar. Now, i would like to insert a datatable at each navbar's item (tabPanel). But i don't want to create a table per item in navbar. So i would like to know if it's possible to create only 1 table which update itself with the navbar's selected item ??
Code to create dynamical navbar
runApp(list(
ui = fluidPage(
navbarPage(theme=shinytheme("paper"),title="test",
tabPanel(uiOutput('mytabs'))
)
),
server = function(input, output, session){
output$mytabs = renderUI({
nTabs = length(unique(iris$Species))
myTabs = lapply(unique(iris$Species)[1:nTabs], tabPanel)
do.call(tabsetPanel, myTabs)
})
}
))
Now i woulk like to display datatable(subset(iris,Species=="value of navbar")) at each navbar's item
Can someone explain me how to do ?
Using question here, you can define a function and call it as below. Note that csv button will only work in a browser.
library(shiny)
library(shinythemes)
runApp(list(
ui = fluidPage(
navbarPage(theme=shinytheme("paper"),title="test",
tabPanel(uiOutput('mytabs'))
)
),
server = function(input, output, session){
createTabs <- function(species_r){
tabPanel(title = paste("Data", species_r, sep=" "),
datatable(subset(iris,Species==species_r),rownames = FALSE,
extensions = 'Buttons', options = list(dom = 'Bfrtip', buttons = c('copy', 'csv',I('colvis'))))
)
}
output$mytabs = renderUI({
nTabs = length(unique(iris$Species))
myTabs = lapply(unique(iris$Species)[1:nTabs], createTabs)
do.call(tabsetPanel, myTabs)
})
}
))
Related
I have the following app which allows for text to be entered and it is then saved as VALUE and printed on a panel.
Although it looks like I can only do this with one text input at a time - even if I click add (so I don't believe this button is working). On top of that I would like for the user to be able to add multiple inputs (like I have below).
And then my VALUE function should be list with multiple inputs.
code below
library(shiny)
ui <- fluidPage(
headerPanel("R Package App"),
sidebarPanel(
# selectInput("options", "options", choices=c('abc','def')),
textInput("textbox", "Enter R Package Name", ""),
actionButton("add","Add")
),
mainPanel(
textOutput("caption")
)
)
server <- function(input, output, session) {
observe({
VALUE <- ''
if(input$add>0) {
isolate({
VALUE <- input$textbox
})
}
updateTextInput(session, inputId = "textbox", value = VALUE)
})
output$caption <- renderText({
input$textbox
})
}
shinyApp(ui = ui, server = server)
Have you considered using selectizeInput with it's create option?
library(shiny)
packagesDF <- as.data.frame(installed.packages())
ui <- fluidPage(
headerPanel("R Package App"),
sidebarPanel(
selectizeInput(
inputId = "selectedPackages",
label = "Enter R Package Name",
choices = packagesDF$Package,
selected = NULL,
multiple = TRUE,
width = "100%",
options = list(
'plugins' = list('remove_button'),
'create' = TRUE,
'persist' = TRUE
)
)
),
mainPanel(textOutput("caption"))
)
server <- function(input, output, session) {
output$caption <- renderText({
paste0(input$selectedPackages, collapse = ", ")
})
}
shinyApp(ui = ui, server = server)
Is there a way to fix the top section of the dashboard here. Right now, the widgets (selectinput) are fixed, but when the user scroll down, it gets covered by the datatable. Can we not make sure this does not get covered and only datatable moves down?
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:fixed; width:inherit;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
dataTableOutput("uioutput", height = "2000px")
))
server <- function(input, output, session) {
output$uioutput <- renderDataTable({
datatable(iris)
})
}
shinyApp(ui, server)
You can use the CSS z-index property to control the stack order the HTML elements:
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:fixed; width:inherit; z-index: 1; background-color: white;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
dataTableOutput("uioutput", height = "2000px")
))
server <- function(input, output, session) {
output$uioutput <- renderDataTable({
datatable(iris)
})
}
shinyApp(ui, server)
Another approach is using position: sticky;.
Changing the style line to position:absolute makes it so that the selection boxes scroll up and out of the page when you scroll down, if that's what you were looking for.
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:absolute; width:inherit;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
dataTableOutput("uioutput", height = "2000px")
))
server <- function(input, output, session) {
output$uioutput <- renderDataTable({
datatable(iris)
})
}
shinyApp(ui, server)
If you're trying to make the table stay in place and scroll down through the table, use DTOutput() and renderDataTable() instead of dataTableOutput() and renderDataTable(). Then, get rid of datatable() inside renderDT() and just use 'iris'. Finally, you can add the Scroller extension and an options list with scrollY and scroller. Others may be able to explain the difference between DT and DataTable (this page might help as well: https://rstudio.github.io/DT/shiny.html), but I believe DTOutput and renderDT are more flexible. Note: you can add horizontal scrollbars as well with scrollX if you use a table with more fields in the future.
Updated code is below.
Hope either of these helps!
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:absolute; width:inherit;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
DTOutput("uioutput", height = "600px")
))
server <- function(input, output, session) {
output$uioutput <- renderDT({
iris
},
extensions = c('Scroller'),
fillContainer = T,
options = list(deferRender = T,
scrollY = 400,
scroller = T)
)
}
shinyApp(ui, server)
I want to display a spreadsheet with some information in shinyWidgets dropdown, sometimes spanning multiple pages.
If you click on the next page, the dropdown closes again.
How can I avoid this?
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
br(),br(),br(),
p("How to go to the next page, without collapsing?"),
uiOutput("irisdrop", inline = TRUE)
)
server <- function(input, output, session) {
output$irisdrop <- renderUI({
dropdown(circle = FALSE, inputId = "iris",
label = "iris", status = "primary",
datatable(iris, rownames = NULL,
height = "100%",
selection = "none"
)
)
})
}
shinyApp(ui, server)
You can do something like this -
library(shiny)
library(shinyWidgets)
library(DT)
ui <- fluidPage(
dropdownButton(
inputId = "iris",
label = "iris",
icon = icon("sliders"),
status = "primary",
circle = FALSE,
DT::dataTableOutput("iris_tb")
)
)
server <- function(input, output, session) {
output$iris_tb <- DT::renderDataTable({
datatable(iris, rownames = NULL,
height = "100%",
selection = "none"
)
})
}
shinyApp(ui, server)
Note: You can even use dropdown() instead of dropdownButton() from shinyWidgets package.
dropdown() is similar to dropdownButton() but it don't use Bootstrap, so you can put pickerInput in it. Moreover you can add animations on the appearance / disappearance of the dropdown with animate.css.
For more detail, you can look at the page 30 of the following document -
https://cran.r-project.org/web/packages/shinyWidgets/shinyWidgets.pdf
I'm trying to create a tabset where tabs are dynamically added. Each new tab has the same carousel with images. The carousel is loaded from a module.
This would be the desired end result, but that works for multiple dynamically added tabs:
Reading other SO questions leads me to believe that I might need a nested module. Alternatively I've made a mistake with insertUI. Help much appreciated!
Here is a MVE where you need to place a single png in the same folder as the code:
library(shiny)
library(slickR)
my_module_UI <- function(id) {
ns <- NS(id)
slickROutput(ns("slickr"), width="100%")
}
my_module <- function(input, output, session) {
output$slickr <- renderSlickR({
imgs <- list.files("", pattern=".png", full.names = TRUE)
slickR(imgs)
})
}
ui <- fluidPage(
tabItem(tabName = "main_tab_id",
tabsetPanel(id = "test_tabs",
tabPanel(
title = "First tab",
value = "page1",
fluidRow(textInput('new_tab_name', 'New tab name'),
actionButton('add_tab_button','Add'))
)
)
)
)
server <- function(input, output, session) {
tab_list <- NULL
observeEvent(input$add_tab_button,
{
tab_title <- input$new_tab_name
if(tab_title %in% tab_list == FALSE){
appendTab(inputId = "test_tabs",
tabPanel(
title=tab_title,
div(id="placeholder") # Content
)
)
# A "unique" id based on the system time
new_id <- gsub("\\.", "", format(Sys.time(), "%H%M%OS3"))
insertUI(
selector = "#placeholder",
where = "beforeBegin",
ui = my_module_UI(new_id)
)
callModule(my_module, new_id)
tab_list <<- c(tab_list, tab_title)
}
updateTabsetPanel(session, "test_tabs", selected = tab_title)
})
}
shinyApp(ui, server)
This is an interesting exercise in modules.
carousel_module simply renders the carousel
my_tab module, creates a tab and an observeEvent for each tab which listens to tab clicks
library(shiny)
library(slickR)
carousel_ui <- function(id){
ns <- NS(id)
slickROutput(ns("slickr"), width="100%")
}
carousel_module <- function(input, output, session) {
output$slickr <- renderSlickR({
imgs <- list.files("~/Desktop/imgs", pattern=".png", full.names = TRUE)
slickR(imgs)
})
}
my_tab <- function(input,output,session,parent_session,tab_element,tab_name){
ns = session$ns
appendTab(inputId = "test_tabs",
tabPanel(
title = tab_name,
value = tab_name,
carousel_ui(ns("carousel")) # Operating in the parent session so explicitly supply the namespace
),
session = parent_session
)
updateTabsetPanel(parent_session, "test_tabs", selected = tab_name) # Refer to test_tabs from the parent namespace
# Need to update the carousel every time the user clicks on a tab
# Else the carousel is only updated on the latest tab created
observeEvent(tab_element(),{
req(tab_element())
if(tab_element() == tab_name){
cat("Running\n")
callModule(carousel_module,"carousel")# This module knows the namespace so no need to supply the namespace
}
})
}
ui <- fluidPage(
tabsetPanel(id = "test_tabs",
tabPanel(
title = "First tab",
value = "page1",
fluidRow(textInput('new_tab_name', 'New tab name'),
actionButton('add_tab_button','Add'))
)
)
)
)
server <- function(input, output, session) {
tab_list <- NULL
observeEvent(input$add_tab_button,{
tab_title <- input$new_tab_name
callModule(my_tab,tab_title,session,reactive(input$test_tabs),input$new_tab_name)
})
}
shinyApp(ui, server)
I am currently trying to limit my selection in a DataTable in Shiny to just two rows - I want the table to not allow the user to click on more than rows (but also to have the ability to deselect them afterwards).
library(DT)
shinyApp(
ui = fluidPage(
fluidRow(
column(12,
dataTableOutput('table')
)
)
),
server = function(input, output) {
output$table <- DT::renderDataTable(iris,
options = list(selection = "multiple")
)
}
)
The row selection is currently on multiple mode, which works, but I don't want the selection to exceed two rows.
Update: Does not seem to work anymore, since 04.2022 or earlier.
You could either solve it via javascript, which you may have seen already:
Limit row selection to 3 in datatables
Or you update the datatable in Shiny:
library(DT)
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
column(12,dataTableOutput('tbl'))
)
),
server = function(input, output) {
reset <- reactiveValues(sel = "")
output$tbl <- DT::renderDataTable({
input$tbl_rows_selected
datatable(iris, selection = list(mode = 'multiple', selected = reset$sel))
})
observe({
if(length(input$tbl_rows_selected) > 2){
reset$sel <- setdiff(input$tbl_rows_selected, input$tbl_row_last_clicked)
}else{
reset$sel <- input$tbl_rows_selected
}
})
}
)
This solution might be less clean, but a bit easier to understand.
It's not exactly what you want but I've changed a bit Tonio's answer, it may help someone else.
library(DT)
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
column(12,dataTableOutput('tbl'))
),
textOutput('selected_rows')
),
server = function(input, output) {
reset <- reactiveValues(sel = "")
output$tbl <- DT::renderDataTable({
datatable(iris, selection = list(mode = 'multiple', selected = reset$sel))
})
observe({
if(length(input$tbl_rows_selected) > 2){
reset$sel <- NULL
}else{
reset$sel <- input$tbl_rows_selected
}
})
output$selected_rows <- renderText({input$tbl_rows_selected})
}
)