I'm trying to create an dynamic amount of datatables inside a tabsetPanel argument. Thanks to various different posts here I came to this 'not working solution'.
The tables are rendered and accesed correctly but the tabsetPanel fails to create and I'm wondering how I can make this work, any help appreciated:
library(DT)
# for simplification this is not dynamic but created without hardcoded variable calls.
portalData <- lapply(1:10,function(x)data.frame(rnorm(5,1))
names(portalData) <- 1:10
shinyApp(
ui = pageWithSidebar(
headerPanel("Dynamic number of tables inside tabpanels"),
sidebarPanel(
),
mainPanel(
uiOutput("tables")
)
),
server = function(input, output) {
observe({
output$tables <- renderUI({
names_list <- lapply(seq_along(portalData), function(i){
tablename <- paste(names(portalData)[i])
tabPanel(dataTableOutput(tablename))
})
do.call(tabsetPanel,do.call(tagList, names_list))
})
for(i in 1:length(portalData)){
local({
i2 <- i
output[[names(portalData)[i2]]] <- renderDataTable({portalData[[i2]]})
})
}
})
})
Related
In a Shiny app, I would like to be able to use check boxes or radio buttons to toggle on and off the visible output.
Currently, I can achieve this only by creating separate check box ui items and observe conditions for each element I would like to toggle.
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
uiOutput('select1'),
uiOutput('select2'),
div(id='table1',tableOutput('data1')),
div(id='table2',tableOutput('data2'))
)
server <- function(input, output){
data1 <- data.frame(X1=1:5,
X2=6:10)
data2 <- data.frame(Y1=1:5,
Y2=6:10)
output$data1 <- renderTable(data1)
output$data2 <- renderTable(data2)
output$select1 <- renderUI({
checkboxGroupInput('select1', 'Select T1',
choices = 'table1',
selected = 'table1')
})
output$select2 <- renderUI({
checkboxGroupInput('select2', 'Select T2',
choices = 'table2'
)
})
observe({
toggle(id='table1', condition = input$select1)
})
observe({
toggle(id='table2', condition = input$select2)
})
}
shinyApp(ui, server)
Question 1
When the app loads both tables are displayed despite only one being selected. Toggling the second on and then off is required to hide it. Can this be changed so it isn't displayed on first load?
Question 2
I realise my approach is inefficient and it is likely possible to achieve the same with a single checkBoxGroupInput containing the various options and a single observe condition. I'm really inexperienced here and cannot figure it out.
Your help is appreciated.
toggle expects a boolean but input$select returns a character, which might explain the unexpected behaviour.
With a single checkboxGroupInput, using %in% to get booleans:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
uiOutput('select'),
div(id='table1',tableOutput('data1')),
div(id='table2',tableOutput('data2'))
)
server <- function(input, output){
data1 <- data.frame(X1=1:5,
X2=6:10)
data2 <- data.frame(Y1=1:5,
Y2=6:10)
output$data1 <- renderTable(data1)
output$data2 <- renderTable(data2)
output$select <- renderUI({
checkboxGroupInput('select', 'Select table',
choices = list('table1','table2'),
selected = 'table1')
})
observe({
toggle(id='table1', condition = "table1" %in% input$select)
toggle(id='table2', condition = "table2" %in% input$select)
})
}
shinyApp(ui, server)
I try to make a shiny module to present data from dataframes using the DT package. I would like to use a module to have a standard set up of DT-table options like language and others.
I want the user to be able to select different subsets of the data interactively and thereafter be able to see the data as a DT-table. The selection of the subset will be generated outside the module because I would like the subset to be available for other uses, for example to be exported to a csv-file.
This works as intended when I don't use a module for making the DT table. When I put the code inside a module, a table is produced when the app starts. But when the selection criteria are changed, the table don't update.
I have included an app illustrating the problem. Table 1 is generated without using shiny module and updates as expected when the selection changes. Table 2 is output using the module and don't update when the selection is changed.
I'm running R-studio 1.1.463, R version 3.5.2 and DT version 0.5.
require("DT")
require("shiny")
# module for presenting data using DT
showDTdataUI <- function(id) {
ns <- NS(id)
tagList(
DT::dataTableOutput(ns("table"))
)
}
showDTdata <- function(input, output, session, DTdata) {
output$table <- renderDataTable({
DT::datatable(DTdata)
})
}
# User interface
ui <-
fluidPage(
sidebarLayout(
sidebarPanel(id="DT",
width = 4,
helpText(h4("Select")),
selectInput("selectedSpecies", label = "Species",
choices = c("setosa","versicolor","virginica"),
selected = "versicolor")
),
mainPanel(
h3("Table 1. Presenting selected data from Iris" ),
DT::dataTableOutput("table"),
h5(br("")),
h3("Table 2. Presenting selected data from Iris using shiny module"),
showDTdataUI(id="testDTModule")
)
)
)
# Define server logic ----
server <- function(session, input, output) {
selectedIris <- reactive ( {
selected <- iris[which(iris$Species==input$selectedSpecies),]
selected
})
output$table <- renderDataTable({
DT::datatable(selectedIris())
})
callModule(showDTdata, id="testDTModule", DTdata=selectedIris())
}
# Run the app ----
shinyApp(ui = ui, server = server)
You have to pass the reactive conductor in showDTdata:
showDTdata <- function(input, output, session, DTdata) {
output$table <- renderDataTable({
DT::datatable(DTdata()) # not datatable(DTdata)
})
}
callModule(showDTdata, id="testDTModule", DTdata=selectedIris) # not DTdata=selectedIris()
Does this do what you want? I removed your functions and added the selection ='multiple' to table 1 (tableX) so that we can then listen to tableX_rows_selected
P.S.: I have noticed that if you first load DT and then shiny, that the whole app won't work anymore. This is a bit weird since we call all datatable functions with DT::... but, you do get a warning message that some parts of DT are masked by shiny or viceversa.
require("shiny")
require('DT')
# User interface
ui <-
fluidPage(
sidebarLayout(
sidebarPanel(id="DT",
width = 4,
helpText(h4("Select")),
selectInput("selectedSpecies", label = "Species",
choices = c("setosa","versicolor","virginica"),
selected = "versicolor")
),
mainPanel(
h3("Table 1. Presenting selected data from Iris" ),
DT::dataTableOutput("tablex"),
br(),
h3("Table 2. Presenting selected data from Iris using shiny module"),
DT::dataTableOutput("table2")
)
)
)
# Define server logic ----
server <- function(session, input, output) {
values <- reactiveValues(rowselect = numeric())
selectedIris <- reactive ( {
selected <- iris[which(iris$Species==input$selectedSpecies),]
selected
})
output$tablex <- renderDataTable({
DT::datatable(selectedIris(), selection = 'multiple')
})
IrisSelected <- reactive({
df <- iris[c(input$tablex_rows_selected), ]
df
})
output$table2 <- renderDataTable({
req(nrow(IrisSelected()) > 0)
DT::datatable( IrisSelected())
})
}
# Run the app ----
shinyApp(ui = ui, server = server)
Without knowing of the shiny module approach, I would have probably written it like a normal function. The app below works but I am curious now after seeing the answer by #Stephane what the advantages are of using callModule approach over regular function approach
require("DT")
require("shiny")
makeTable <- function(dataframe) { DT::datatable(dataframe) %>%
formatStyle(names(dataframe), background = '#fff')
}
# User interface
ui <-
fluidPage(
sidebarLayout(
sidebarPanel(id="DT",
width = 4,
helpText(h4("Select")),
selectInput("selectedSpecies", label = "Species",
choices = c("setosa","versicolor","virginica"),
selected = "versicolor")
),
mainPanel(
dataTableOutput('Table1')
)
)
)
# Define server logic ----
server <- function(session, input, output) {
selectedIris <- reactive ( {
selected <- iris[which(iris$Species==input$selectedSpecies),]
selected
})
output$Table1 <- renderDataTable(makeTable(selectedIris()))
}
# Run the app ----
shinyApp(ui = ui, server = server)
In an R shiny app I'm attempting to render a varying number of tables based on user input. As an example, I've created the following app:
# ui.R
fluidPage(
numericInput("numeric.input", "Select Number of Tables:", 0, min = 0),
tableOutput("table")
)
# server.R
data(iris)
function(input, output) {
output$table <- renderTable({
head(iris)
})
}
What I'd like for this app to do is to generate a number of tables dependent on the value selected for numeric.input. Currently numeric.input doesn't influence the app and is only shown for example. If numeric.input is set to zero, I'd like for the app to display no copies of the table, if numeric.input is set to one, I'd like for the app to display one copy of the table, etc.
Is something like this possible in R Shiny?
I've solved the issue by using the R Shiny Gallery app on creating UI in a loop, but rendering the UI loop within the R Shiny server. The following code works correctly:
# ui.R
fluidPage(
numericInput("numeric.input", "Select Number of Tables:", 1, min = 1),
uiOutput("tables")
)
# server.R
data(iris)
function(input, output) {
# Rendering tables dependent on user input.
observeEvent(input$numeric.input, {
lapply(1:input$numeric.input, function(i) {
output[[paste0('table', i)]] <- renderTable({
head(iris)
})
})
})
# Rendering UI and outputtign tables dependent on user input.
output$tables <- renderUI({
lapply(1:input$numeric.input, function(i) {
uiOutput(paste0('table', i))
})
})
}
Your approach is simple and straightforward. Just putting out the usage of the insertUI and removeUI for this purpose based on the link provided in comments by #r2evans.
ui <- fluidPage(
numericInput("numericinput", "Select Number of Tables:", 0, min = 0),
tags$div(id = 'tabledisplay')
)
server <- function(input, output) {
inserted <- c()
observeEvent(input$numericinput, {
tablenum <- input$numericinput
id <- paste0('table', tablenum)
if (input$numericinput > length(inserted)) {
insertUI(selector = '#tabledisplay',
ui = tags$div(h4(
paste0("Table number ", input$numericinput)
), tags$p(renderTable({
head(iris)
})),
id = id))
inserted <<- c(id, inserted)
}
else {
inserted <- sort(inserted)
removeUI(selector = paste0('#', inserted[length(inserted)]))
inserted <<- inserted[-length(inserted)]
}
})
}
shinyApp(ui, server)
I'm trying to make a dynamically generated navbar based on the session user id.
I have a data table that maps the session user to a list of that user's clients. I want the app to produce a navbar where each tabPanel is for each client that user has. I'm not sure how I can easily do that since navbarPage() doesn't take a list argument.
Below is my example
library(shiny)
data <- data.frame(user=c("emily", "emily"), clients=c("client1", "client2"))
CreateCustomNavbarContent <- function(data) {
l <- lapply(data$clients, function(client) {
tabPanel(client,
h2(client))
})
renderUI({
l
})
}
shinyApp(
ui <- fluidPage(
uiOutput("custom_navbar")
),
server <- function(input, output) {
output$custom_navbar <- renderUI({
## commented below doesn't work
# navbarPage(
# CreateCustomNavbarContent(data)
# )
navbarPage("",
tabPanel("client1",
h2("client1")
),
tabPanel("client2",
h2("client2")
)
)
})
}
)
You could achieve what you want with do.call, so we can pass a list of arguments as separate arguments. Below is a working example, I gave emily a companion called John so you can validate that the code does what you want ;)
Hope this helps!
library(shiny)
data <- data.frame(user=c("Emily", "Emily","John","John"), clients=c("client1", "client2","client3","client4"))
ui = fluidPage(
selectInput('select_user','Select user:',unique(data$user)),
uiOutput('mytabsetpanel')
)
server = function(input, output, session){
output$mytabsetpanel = renderUI({
myTabs = lapply(data$clients[data$user==input$select_user], tabPanel)
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui,server)
I've got an issue with my current shiny code.
I have to generate a dynamic number of tabs depending on the results of a given function (that part works fine). Then, I want to generate the input of these tabs in other loops of for example renderText. However, the final output of the textOutput for my generated renderText is always the one of the last renderText of the loops.
Here is a small example of the idea:
library(shiny)
library(shinydashboard)
ui <- pageWithSidebar(
headerPanel("xxx"),
sidebarPanel(),
mainPanel(
uiOutput("multipleUI")
)
)
server <- function(input, output) {
output$multipleUI <- renderUI({
tabs <- list(NULL)
for(i in 1:5){
tabs[[i]] <- tabPanel(title = paste0("tab ",i),
textOutput(paste0("out",i)), # prints j as 5 in all tabs
paste0("local out ",i)) # prints i as current loop value for each tab)
}
do.call(tabBox,tabs)
})
observe({
for(j in 1:5){
txt = paste0("generated out ", j)
print(txt) # print with current j
output[[paste0("out",j)]] <- renderText({txt})
}
})
}
shinyApp(ui, server)
While it might not be that important for renderText where I can just work around the issue, I intend to render a lot of plots and tables and couldn't think of a workaround there.
I'd appreciate any help!
EDIT: I've updated the code to show a small working example
Here's a solution that seems to work. I'm using lapply to create the tabs. Let me know if it works for what you need.
library(shiny)
ui <- pageWithSidebar(
headerPanel("xxx"),
sidebarPanel(),
mainPanel(
do.call(tabsetPanel, c(id='tab',lapply(1:5, function(i) {
tabPanel(
title=paste0('tab ', i),
textOutput(paste0('out',i))
)
})))
)
)
server <- function(input, output) {
lapply(1:5, function(j) {
output[[paste0('out',j)]] <- renderPrint({
paste0('generated out ', j)
})
})
}
shinyApp(ui, server)