I have a question about conditional generation of navbarMenu based on the variable in the server-side. I created a small demo app to illustrate it.
ui = shinyUI(
navbarPage(title = "Demo app",
navbarMenu("Small numbers",
tabPanel("First small page", uiOutput("firstSmallPage"))
),
navbarMenu("Big numbers",
tabPanel("First big page", uiOutput("firstBigPage"))
)
)
)
server = shinyServer(function(input, output, session) {
rand_num = sample(1:10)[1]
# if rand_num is higher than 5 I dont want Big number navbarMenu to appear
print(rand_num)
output$firstSmallPage <- renderUI({
plotOutput("smallPlot")
})
output$smallPlot <- renderPlot({plot(1:10)})
output$firstBigPage <- renderUI({
plotOutput("bigPlot")
})
output$bigPlot <- renderPlot({plot(990:1000)})
})
app = shinyApp(ui=ui, server=server)
What I am trying to archive is to hide Big Numbers tab if rand_num is higher 5. I tried wrapping navbarMenus in renderUI on the server-side and replacing it with uiOutput in the ui-side but it was unsuccessful. It is crucial for solution to work with more than 2 navbarMenus. Thanks in advance
It seems to work like this:
library(shiny)
library(shinyjs)
ui = shinyUI(
navbarPage(
useShinyjs(),
title = "Demo app",
navbarMenu("Small numbers",
tabPanel("First small page", uiOutput("firstSmallPage"))
),
navbarMenu("Big numbers",
tabPanel("First big page", uiOutput("firstBigPage"))
)
)
)
server = shinyServer(function(input, output, session) {
rand_num = sample(1:10)[1]
# if rand_num is higher than 5 I dont want Big number navbarMenu to appear
print(rand_num)
if(rand_num>5){
hide(selector = ".navbar-nav li:nth-child(3)")
}
output$firstSmallPage <- renderUI({
plotOutput("smallPlot")
})
output$smallPlot <- renderPlot({plot(1:10)})
output$firstBigPage <- renderUI({
plotOutput("bigPlot")
})
output$bigPlot <- renderPlot({plot(990:1000)})
})
app = shinyApp(ui=ui, server=server)
runApp(app)
Related
I want to generate a boxPlus around my DT-Output. Now when I start my APP, the frame of the box is already there. How do I manage that the box is only displayed when the tableoutput is finished? As input I use a text input.
In my UI I use for the Input:
textInput("name", "Insert Number:")
the final box I create with:
uiOutput("box")
On Serverside I do:
output$name <- renderText(input$name)
New_input <- reactive({
list(input$name)
})
and the box I create like this:
output$box <- renderUI({
boxPlus(
div(style = 'overflow-x: scroll;'), dataTableOutput("table")
)
})
I tried it with: Similar Problem but I can not resolve the problem. Without the box everything works fine.
Never use reactive expressions inside a renderText function.
You have to wrap tagList around your two elements to return a SINGLE element (a list in your case).
Here is a reproduceable example.
library(shiny)
library(shinydashboardPlus)
library(dplyr)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Hide box"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
textInput("name", "Insert Number to filter cyl:")
),
mainPanel(
uiOutput("box")
)
)
)
server <- function(input, output) {
resultdf <- reactive({
mtcars %>%
filter(cyl > input$name)
})
output$box <- renderUI({
output$table <- renderDataTable({
resultdf()
})
if(input$name == "") {
return(NULL)
} else {
return(
tagList(
boxPlus(
div(style = 'overflow-x: scroll;'), dataTableOutput("table")
)
)
)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am looking for a way to link from an HTML text (nested in the server part) to a specific Shiny tabPanel (nested in UI). Let's say we have the following app:
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
mainPanel(
tabsetPanel(
type="tabs",
tabPanel("Contents", htmlOutput("contents")),
tabPanel("Plot", plotOutput("plot")) # <- A link to here
)
)
)
))
shinyServer(function(input, output) {
output$contents <- renderText({
HTML("A link to <a href='#Plot'>Plot</a>") # <- from there
})
output$plot({
some ggplot
})
})
How could I create a link within the text that then redirects to a certain tab. I tried anchor tags but they don't seem to work as the id keeps changing upon each start of the app.
Thanks in advance.
I don't know whether this is possible with a link. But you can use a button and updateTabsetPanel.
library(shiny)
library(ggplot2)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(),
mainPanel(
tabsetPanel(
type="tabs",
id = "tabset",
tabPanel("Contents", actionButton("go", "Go to plot")),
tabPanel("Plot", plotOutput("plot"))
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$go, {
updateTabsetPanel(session, "tabset", "Plot")
})
output$plot <- renderPlot({
ggplot(mtcars, aes(x=cyl, y=disp)) + geom_point()
})
}
shinyApp(ui, server)
Thanks to Stéphane Laurent, who pointed me in the right direction, I managed to create the solution I wanted. In order to keep all the HTML text in the server function I used a combination of renderUI and actionLink. The solution now looks as follows:
library(shiny)
shinyUI(fluidPage(
sidebarLayout(
mainPanel(
tabsetPanel(
type="tabs",
id = "tabset", # <- Key element 1
tabPanel("Contents", htmlOutput("contents")),
tabPanel("Plot", plotOutput("plot"))
)
)
)
))
shinyServer(function(input, output, session) {
output$contents <- renderUI({ # <- Key element 2
list(
HTML(<p>Some text..</p>),
actionLink("link", "Link to Plot") # <- Key element 3
)
})
observeEvent(input$link, {updateTabsetPanel(session, "tabset", "Plot")}) # <- Key element 4
output$plot({
some ggplot
})
})
I'm working on a Shiny application that is supposed to handle multiple languages. I managed to dynamically translate almost all elements of the app depending on a selectInput to choose the language. However the "hard stuff" remains the navbarPage tabs as well as the tabPanels inside my pages. I cannot change their names. I tried this, but it does not work:
library(shiny)
ui <- navbarPage("App Title",
tabPanel("tab1",
selectInput("language", "language", c("EN", "FR"), width = '300px'),
textOutput("text")),
uiOutput("render_tab2"))
server <- function(input, output, session) {
output$text = renderText({ switch(input$language, "EN"="hello world", "FR"="bonjour monde") })
output$render_tab2 = renderUI({
tabPanel( title=switch(input$language, "EN"="tab2", "FR"="onglet2") )})}
shinyApp(ui, server)
And the updatenavbarpanel() family of functions are just to set the active tab, not change their characteristics...Is there a way to do it, if possible that does not change the structure of all my app... THanks a lot.
This piece of code set the title dynamically :
library(shiny)
ui <- navbarPage("App Title",
tabPanel(title = uiOutput("title_panel"),
selectInput("language", "language", c("EN", "FR"), width = '300px')
)
)
server <- function(input, output, session) {
output$title_panel = renderText({
switch(input$language, "EN"="hello world", "FR"="bonjour monde")
})
}
shinyApp(ui, server)
Edit : Works with both uiOutput("title_panel") & textOutput("title_panel")
I have a tabbed UI that shows up whenever the user selects rows in a datatable (in the following code, the outputs are random, in real life the calculation is quite involved).
I would like to condition the tabbed UI showing up to the click of a button. Currently every time you select an additional row, it does the calculation all over again for the already selected rows. I would like to limit that to a one-time calculation when the user is done selecting all the rows he wants to see.
library(shiny)
library(DT)
The UI : the table, the action button and the tabbed section.
ui <- fluidPage(
mainPanel(
fluidRow(
column(12,DT::dataTableOutput(outputId = 'tableCurrencies'))
),
actionButton(inputId = 'showSelectedButton',label = 'Show Selec'),
fluidRow(
uiOutput("myTabUI")
)
)
)
The server function : If I remove the output$myTabUI <- eventReactive(input$launchCalcButton, { part and instead do output$myTabUI <- renderUI ({ ... directly it works as intended (minus the calculation following click on the button of course).
server <- function(input,output){
output$tableCurrencies <- DT::renderDataTable({datatable(data.frame(a=rnorm(10),b=rnorm(10),c=rnorm(10)))})
origTable_selected <- reactive({
ids <- input$tableCurrencies_rows_selected
return(ids)
})
output$myTabUI <- eventReactive(input$launchCalcButton, {
selectedTabs <- renderUI({
myTabs <- lapply(origTable_selected(),function(i) {
tabName <- paste0("test",i)
a <- renderPlot({
hist(rnorm(50))
})
output[[paste0(tabName,"rates")]] <- a
return(tabPanel(
tabName,
fluidRow(
column(6,plotOutput(paste0(tabName,"rates")))
)
))
})
return(do.call(tabsetPanel,myTabs))
})
selectedTabs
})
}
app = shinyApp(ui,server)
runApp(app,port=3250,host='0.0.0.0')
Not sure how to go about fixing this. Any help welcome.
You can use isolate() to limit reactive dependencies
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
fluidRow(
column(12,DT::dataTableOutput(outputId = 'tableCurrencies'))
),
actionButton(inputId = 'showSelectedButton',label = 'Show Selec'),
fluidRow(uiOutput("myTabUI"))
)
)
server <- function(input,output){
output$tableCurrencies <- DT::renderDataTable({
data.frame(a=rnorm(10),b=rnorm(10),c=rnorm(10))})
origTable_selected <- reactive({
input$tableCurrencies_rows_selected
})
output$myTabUI <- renderUI({
input$showSelectedButton
myTabs <- lapply(isolate(origTable_selected()),function(i) {
tabName <- paste0("test",i)
a <- renderPlot({hist(rnorm(50))})
output[[paste0(tabName,"rates")]] <- a
return(tabPanel(
tabName,
fluidRow(column(6,plotOutput(paste0(tabName,"rates"))))
))
})
do.call(tabsetPanel,myTabs)
})
}
shinyApp(ui,server)
I am trying to gather user input given a data set. I want to insert a column where the user can determine whether they would want to own one of the cars in the mtdata set. This is completely subjective as opinions differ from person to person so I am not able to program this in. Is there a way to append an extra column that can be a checkbox or dropdown menu to identify cars that a user would "Want to own?
library(shiny)
shinyApp(ui = shinyUI(fluidPage(
titlePanel("Interesting Cars"),
sidebarLayout(
sidebarPanel(
helpText("This is a side bar")),
mainPanel(
tableOutput("view")
)
)
)),
server = function(input, output) {
output$view <- renderTable({
head(mtcars[, 1:4], n = 6)
})
})
How about this, you can use the DT library. By adding the filter option the user can define the different components one wants and see what cars come up.
library(shiny)
library(DT)
shinyApp(ui = shinyUI(fluidPage(
titlePanel("Interesting Cars"),
sidebarLayout(
sidebarPanel(
helpText("This is a side bar")),
mainPanel(
DT::dataTableOutput("view")
)
)
)),
server = function(input, output) {
output$view <- DT::renderDataTable({
datatable(mtcars,
filter = "top"
)
})
})
Edit
If it truly is so important to add another column indicating if it is 'interesting' there will be significantly more code to written if you intend to have users assign it on different conditions. Here is an example with just the mpg. The fundamental idea here is that you assign your data to the reactiveValues function. It can then be modified as you like. This can obviously be improved upon more (as it will continue to add columns) but it demonstrates the concept.
shinyApp(ui = shinyUI(fluidPage(
titlePanel("Interesting Cars"),
sidebarLayout(
sidebarPanel(
helpText("This is a side bar"),
uiOutput("mpg"),
actionButton("add_label", "Mark Interesting")
),
mainPanel(
DT::dataTableOutput("view")
)
)
)),
server = function(input, output) {
values <- reactiveValues(
mydata = mtcars
)
output$mpg <- renderUI({
numericInput("mpg_input", "MPG Cutoff?",
value = 15
)
})
output$view <- DT::renderDataTable({
datatable(values$mydata
)
})
observeEvent(input$add_label, {
validate(
need(!is.null(input$mpg_input), "need mpg value")
)
values$mydata <- data.frame(values$mydata,
Interesting_Flag =
ifelse(values$mydata$mpg > input$mpg_input,
"Interesting",
"Not Interesting"))
})
})