R Shiny: Nested tabPanels disable each other - r

In the attached MWE Shiny example, I have a nested tabsetPanel within a tabPanel for a navbar. If you run the MWE with only one tabPanel within the tabSet you will see that Shiny behaves exactly as it is expected. However, if you run the MWE with two tabPanels, the result is not printed to the main panel of each tab.
Why does this behaviour occur? And how do I resolve this conundrum?
library(shiny)
ui <- shinyUI(navbarPage("tabalicious",
tabPanel("Nav1", value = "nav1",
mainPanel(h2("Hello"),
br(),
p("This is my app.")
)
)
,
tabPanel("Nav2", value = "nav2",
tabsetPanel(
tabPanel("tabsettab1",
sidebarLayout(
sidebarPanel(
helpText("Choose your settings"),
selectInput("zone_type",
label = "Choose a zone type to display",
choices = list("Industrial", "Residential"),
selected = "Industrial")
),
mainPanel(h2("A tab for a tabSet"),
textOutput('zone_type')
)
)
)
# Uncomment this to see the issue
# ,
# tabPanel("tabsettab2",
# sidebarLayout(
# sidebarPanel(
# helpText("Choose your settings"),
# selectInput("zone_type",
# label = "Choose a zone type to display",
# choices = list("Industrial", "Residential"),
# selected = "Industrial")
# ),
# mainPanel(h2("A tab for a tabSet"),
# textOutput('zone_type')
# )
# )
# )
)
)
)
)
server <- shinyServer(function(input, output) {
output$zone_type <- renderText({
paste("You have selected", input$zone_type)
})
})
# Run the application
shinyApp(ui = ui, server = server)

It doesn't have to do with tabs, but multiple calls to output the results of the same render* function. For example, a simplified page (with no tabs) will work fine, but if you uncomment the duplicated call, will fail to display zone_type:
library(shiny)
server <- shinyServer(function(input, output) {
output$zone_type <- renderText({paste("You have selected", input$zone_type)})
})
ui <- shinyUI(fluidPage(
selectInput("zone_type",
label = "Choose a zone type to display",
choices = list("Industrial", "Residential")),
# textOutput('zone_type'),
textOutput('zone_type')
))
runApp(shinyApp(server = server, ui = ui))
While your shinyUI function can only call each output of shinyServer once, within shinyServer you can call the inputs as many times as you like, so it's easy to duplicate outputs:
library(shiny)
server <- shinyServer(function(input, output) {
output$zone_type <- renderText({paste("You have selected", input$zone_type)})
output$zone_type2 <- renderText({paste("You have selected", input$zone_type)})
})
ui <- shinyUI(fluidPage(
selectInput("zone_type",
label = "Choose a zone type to display",
choices = list("Industrial", "Residential")),
textOutput('zone_type'),
textOutput('zone_type2')
))
runApp(shinyApp(server = server, ui = ui))
If you don't want to duplicate work for the server, you can't pass one output to another, but you can just save the render* results to a local variable which you can pass to both outputs:
server <- shinyServer(function(input, output) {
zone <- renderText({paste("You have selected", input$zone_type)})
output$zone_type <- zone
output$zone_type2 <- zone
})

Related

Subset data in R Shiny using Multiple Variables

I am new to R Shiny. I am attempting to create an app that allows a user to subset a data.frame based on multiple variables and then see the resulting data.
Here is a small example data set:
iter,wave,apples
1,1,600
1,1,500
1,1,400
1,2,300
1,2,200
1,2,100
2,1,1000
2,1,1100
2,1,1200
2,2,1300
2,2,1400
2,2,1500
3,1,1100
3,1,2200
3,1,3300
3,2,4400
3,2,5500
3,2,6600
I would like the user to be able to specify the value of iter and of wave and see the resulting data.
Here is my attempt at the Shiny code. I realize I must be making several silly mistakes.
Edit
Here is my revised code. The end result now comes pretty close to what I want. The sidebar is still not being displayed perfectly.
library(shiny)
setwd('C:/Users/mark_/Documents/simple_RShiny_files/explore')
apple.data <- read.csv('subset_data_based_on_multiple_variables.csv',
header = TRUE, stringsAsFactors = FALSE)
ui <- fluidPage(
titlePanel("Subsetting Apple Dataset"),
sidebarLayout(
sidebarPanel(
uiOutput("codePanel")
),
mainPanel(
tableOutput("view")
)
),
selectInput("codeInput", inputId ="data1", label = "Choose Iter", choices = unique(apple.data$iter)),
selectInput("codeInput", inputId ="data2", label = "Choose Wave", choices = unique(apple.data$wave))
)
server <- function(input, output) {
output$codePanel <- renderUI({
})
dataset <- reactive({
subset(apple.data, (iter == input$data1 & wave == input$data2))
})
output$view <- renderTable(dataset())
}
shinyApp(ui = ui, server = server)
The output
The problem is that both selectInputs have the same inputId. This works:
library(shiny)
apple.data <- data.frame(
iter = c(1L,1L,1L,1L,1L,1L,2L,2L,2L,2L,2L,
2L,3L,3L,3L,3L,3L,3L),
wave = c(1L,1L,1L,2L,2L,2L,1L,1L,1L,2L,2L,
2L,1L,1L,1L,2L,2L,2L),
apples = c(600L,500L,400L,300L,200L,100L,1000L,
1100L,1200L,1300L,1400L,1500L,1100L,2200L,3300L,4400L,
5500L,6600L)
)
ui <- fluidPage(
titlePanel("Subsetting Apple Dataset"),
sidebarLayout(
sidebarPanel(
selectInput("codeInput1", label = "Choose Iter", choices = unique(apple.data$iter)),
selectInput("codeInput2", label = "Choose Wave", choices = unique(apple.data$wave))
),
mainPanel(
tableOutput("view")
)
)
)
server <- function(input, output) {
dataset <- reactive({
return(subset(apple.data, (iter == input$codeInput1 & wave == input$codeInput2)))
})
output$view <- renderTable(dataset())
}
shinyApp(ui = ui, server = server)

Updating selecInput with more than 1,000 items in Shiny

I want to update a selectInput item on a Shiny app with more than 1,000 items but it obviously don't accept more than 1,000.
Is there a method to add more values or load it from server, as user start typing? server parameter also doesn't work.
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
tags$head(tags$script(src = "message-handler.js")),
# Application title
titlePanel("Large selectInput"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
selectInput("Names",
"List of Names",
choices = c("A")
)
),
mainPanel("Empty")
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
names <- 1:5000
observe({
updateSelectInput(session, "Names", label = "Updated", choices = names, server = TRUE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
selectizeInput() can handle more than 1,000 records.

R shiny code to get output which takes input from ui

I am trying to write a script in shiny, which has two inputs and stores the inputs in two different variables and runs a code using these input variables.But i am getting an error which says :Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
The following is my ui code:
ui <- fluidPage(
titlePanel("Network Model"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "origin",
label = "Origin:",
choices = milk_runs$Origin),
selectInput(inputId = "destination",
label = "Destination:",
choices = milk_runs$Dest),
actionButton("go", "")
),
mainPanel(
tableOutput(
"view"))
)
)
server code :
server<- function(input, output){
origin <- input$origin
destination <- input$destination
observeEvent(input$go,source("nr9.R"))
output$summary <- renderPrint({
#dataset <- datasetInput()
summary(Tnetwork)
})
Can you please tell me how to get correct results.
I think (it would help if you provided a fully reproducible example) that the error is occurring because you are trying to run input$origin without reactive(). The input$origin will not invalidate and update based on user input unless put inside reactive. Based on the example you provided:
library(shiny)
ui <- fluidPage(
titlePanel("Network Model"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "origin", label = "Origin:", choices = c("A","B","C","D","E","F")),
selectInput(inputId = "destination", label = "Destination:", choices = c("A","B","C","D","E","F")),
actionButton("go", "GO")
),
mainPanel( tableOutput( "view"))
)
)
server<- function(input, output){
origin <- reactive(input$origin)
destination<-reactive(input$destination)
observeEvent(input$go,{
cat(origin(),'nextword',destination(),sep="-")
})
output$view <- renderTable({data.frame(origin=origin(),destination=destination())})
}
shinyApp(ui, server)
should print 'origin-nextword-destination' to the console when 'go' is activated, and the table should update. I changed a few bits in your example because it was not reproducible but hopefully it helps.

r shiny - Get radio button value as variable

I am new with r shiny and I am trying to get selected value of a radio button as variable and then concatenate it with something else. Here is my code:
ui.R
library(shiny)
shinyUI(fluidPage(
titlePanel("This is test app"),
sidebarLayout(
sidebarPanel(
radioButtons("rd",
label="Select window size:",
choices=list("100","200","500","1000"),
selected="100")
),
mainPanel(
//Something
)
)
))
server.R
library(shiny)
shinyServer(function(input, output) {
ncount <- reactive({input$rd})
print(ncount)
my_var <- paste(ncount,"100",sep="_")
})
Now when I print ncount it prints out "ncount" rather than the value stored in the variable. Is there anything that I'm missing here.
Thanks
UI
library(shiny)
shinyUI(fluidPage(
titlePanel("This is test app"),
sidebarLayout(
sidebarPanel(
radioButtons("rd",
label = "Select window size:",
choices = list("100" = 100,"200" = 200,"500" = 500,"1000" = 1000),
selected = 100)
),
mainPanel(
verbatimTextOutput("ncount_2")
)
)
))
Server
library(shiny)
shinyServer(function(input, output) {
# The current application doesnt need reactive
output$ncount_2 <- renderPrint({
ncount <- input$rd
paste(ncount,"100",sep="_")
})
# However, if you need reactive for your actual data, comment the above part
# and use this instead
# ncount <- reactive({input$rd})
#
# output$ncount_2 <- renderPrint({
# paste(ncount(),"100",sep="_")
# })
})

Add user input column to Shiny

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"))
})
})

Resources