modualized shiny app ui renders all plots on top of one another - r

I have a shiny app, fully built, that I had built all in one script. Everything was working, the ui, etc. and I wanted to modularize the app to make the code a bit more readable. Now all the plots render on top of each other and I can't figure out why. I've tried using pageContainer, sidbarLayout, sidePanel and mainPanel, fluidPage, fixedPage, etc. and none have worked. I'm also using pagePiling with my main ui, so not sure if that has sometimes to do with it? Any help would be much appreciated!
Please find the full code here: https://github.com/eoefelein/COVID_Business_Recovery_and_Social_Capital/tree/master/socialCapitalEmployment
Here is what my ui code looks like:
ui <- tagList(
pagePiling(
center = TRUE,
sections.color = c("#3333FF", "#E6E6E6"),
menu = c(
"Home" = "home",
"Map" = "map",
"Series" = "ts",
"PCA" = "pca",
"Predict" = "predict",
"About" = "about"
),
pageSectionImage(
center = TRUE,
img = "",
menu = "home",
h1(("title"), class = "header shadow-dark"),
h3(
class = "light footer",
"by",
tags$a("news-r", href = "https://news-r.org", class = "link")
)
),
pageSection(center = TRUE,
menu = "map",
mod_map_ui("map"),
br()),
pageSection(center = TRUE,
menu = "ts",
mod_ts_ui("ts"),
br()),
pageSection(center = TRUE,
menu = "pca",
mod_pca_ui("pca"),
br()),
pageSection(
center = TRUE,
menu = "predict",
mod_predict_ui("predict"),
),
pageSection(
center = TRUE,
menu = "about",
h1("About", class = "header shadow-dark"),
h2(
class = "shadow-light",
tags$a(
"The code",
href = "https://github.com/news-r/fopi.app",
target = "_blank",
class = "link"
),
"|",
tags$a(
"The API",
href = "https://github.com/news-r/fopi",
target = "_blank",
class = "link"
)
),
h3(
class = "light footer",
"by",
tags$a("news-r", href = "https://news-r.org", class = "link")
)
)
)
)
Here is my first module's ui:
mod_map_ui <- function(id) {
ns <- NS(id)
tagList(
fluidPage(
h1("Employment & Social Capital across the U.S by County"),
center = TRUE,
column(9, leafletOutput(ns("map"), height = "100vh")),
column(
3,
shinyWidgets::radioGroupButtons(
inputId = ns("idx"),
label = "Metric",
choices = c(unique(social_indices$name)),
checkIcon = list(yes = icon("ok",
lib = "glyphicon"))
)
)
))
}
And here is my second module's ui:
mod_ts_ui <- function(id) {
ns <- NS(id)
tagList(
fixedPage(
h2("Employment by County", align = "center"),
fixedRow(
column(
4,
selectizeInput(
inputId = ns("dataset"),
label = "Choose a county:",
choices = c(unique(employment["countyfips"])),
multiple = TRUE,
selected = "Travis County, Texas",
options = list(create = TRUE)
)
),
column(
8, (echarts4r::echarts4rOutput(ns("ts_plot")))
)
)
)
)
}

okay, so I fixed it and what I think fixed it was specifying a color for each section:
pagePiling(
center = TRUE,
sections.color = c("#7b959c", "#445768","#b9bdc9","#f6e7ea","#e2e2e2","#1e4356"),
menu = c(
"Home" = "home",
"Map" = "map",
"Series" = "ts",
"PCA" = "pca",
"Predict" = "predict",
"About" = "about"
),
Very strange, but after I did that, each plot presented as it should, in it's own section. Hope this helps someone in the future!

Related

How to bring 4 boxes into one row, with golem shiny app?

I am trying to bring 4 boxes per row, into my shiny app. BioTuring and Scope I want aligned on the same row as FLAT and GTEx. This is how it looks now:
One remark, this app is done with golem structure. Thus, please bear in mind when helping and go with the structure I have.
Having said that I have thumbnail_label
thumbnail_label <- function(url, image, label="", content="", tool="misc",
category = "tool") {
tags$a(
href = url,
onclick = paste0("gtag('event', 'click', { 'event_category': '", category,
"', 'event_label': '", tool, "'});"),
target = "_blank",
div(class = "row",
div(class = "col-sm-14 col-md-12",
div(class = "thumbnail",
img(src = image, alt = "...", height = 200, width = 100,
div(class = "caption", h5(label), p(content))
)
)
)
)
)
}
thumnail_label is brought into a module (as per golem). This is my module for gene expressions. I have the feeling this is where I can correct to bring the 2 boxes aligned into one row, alongside FLAT and GTEx.
mod_gene_expressions_sign_path_ui <- function(id){
ns <- NS(id)
tagList(
shinydashboard::tabItem(
tabName = "gene_app",
fluidRow(
shiny::headerPanel(h2("Gene Analysis")),
br(),
column(
3,
thumbnail_label(
url = "https://rstudio-connect.RStudio_FLAT/",
image = "www/Fluidigm.v2.png",
tool = "Fludigm_Browser",
label = "Fludigm Browser",
content = "Perform Fluidigm data analysis"
)
),
br())))
Then gene module above is going into app_ui (as golem structure) see bellow. However, to bring 4 boxes onto the row should not happen in the bellow code, but above.
app_ui <- function(request) {
tagList(
# Leave this function for adding external resources
golem_add_external_resources(),
# Your application UI logic
shinyUI(
navbarPage(
windowTitle = "Page",
title = div(img(src = ".png", height = "30px"), "Toolbox"),
theme = shinythemes::shinytheme("cerulean"),
tabPanel("Toolbox", icon = icon("wrench"),
shinydashboard::dashboardPage(
header = shinydashboard::dashboardHeader(title = " ", titleWidth = 300),
shinydashboard::dashboardSidebar(
width = 300 ,
shinydashboard::sidebarMenu(
shinydashboard::menuItem(
"Tools",
tabName = "tools_app",
icon = icon("wrench"),
shinydashboard::menuSubItem(
"Gene /Pathways",
tabName = "gene_app",
icon = icon("chart-line")
),
shinydashboard::menuSubItem(
"Genomic",
tabName = "genomic_app",
icon = icon("universal-access")
),
shinydashboard::dashboardBody(
shinydashboard::tabItems(
shinydashboard::tabItem("tools_app", mod_tools_path_ui("tools_path_ui_1")),
shinydashboard::tabItem("gene_app",mod_gene_expressions_sign_path_ui("gene_expression_sign_path_ui_1")),
shinydashboard::tabItem("genomic_app", mod_genomic_ui("genomic_ui_1")),
tabPanel(
"Tutorials", icon = icon("graduation-cap")),
tabPanel("Worflows", icon = icon("list"))
)))
}
Can someone help me, please?
Keeping golem structure, I have managed to bring the 4 boxes into a row by getting rid of shiny::headerPanel(h2("")),
and this is the final code:
mod_gene_expressions_sign_path_ui <- function(id){
ns <- NS(id)
tagList(
shinydashboard::tabItem(
tabName = "gene_app",
# column(width = 9,
fluidRow(
shiny::headerPanel(h2("Gene Expression Analysis")),
br(),
column(
3,
thumbnail_label(
url = "https://rstudio-connect.scp.astrazeneca.net/RStudio_FLAT/",
image = "www/FluidigmAnalysisToolkit.v2.png",
tool = "Fludigm_Browser",
label = "Fludigm Browser",
content = "Perform Fluidigm data analysis"
)
),
column(
3,
thumbnail_label(
url = "https://gtexportal.org/home",
image = "www/gtex.png",
tool = "GTEx",
label = "GTEx Portal",
content = "Gene expression in normal tissue"
)
),
# shiny::headerPanel(h2("")),
column(
3,
thumbnail_label(
url = "https://azcollaboration.sharepoint.com/:b:/r/sites/BioinformaticsfortheBench/Shared%20Documents/Tools/BioTuring/BioTuring_Installation_Instructions.v2021.5.17.pdf?csf=1&web=1&e=TVpy8S",
image = "www/bioturing.svg",
content = "Platform for single-cell analysis and spatial transcriptomics exploration",
label = "BioTuring",
tool = "BioTuring"
)
),
column(
3,
thumbnail_label(
url = "http://informatics.medimmune.com/shiny/scope/",
image = "www/scope.svg",
content = "Explore available single cell RNA-Seq studies",
label = "SCOPE",
tool = "SCOPE"
)
),
br(),
shiny::headerPanel(h2("Pathway Analysis")),
br(),
column(
3,
thumbnail_label(
url = "https://clarivate.com/cortellis/learning/clarivate-for-astrazeneca1796/",
image = "www/clarivate.png",
tool = "clarivate",
label = "Clarivate",
content = "Pathway analysis tools from Cortellis including MetaCore"
)
),
column(
3,
thumbnail_label(
url = "https://analysis.ingenuity.com/pa/launch.jsp",
image = "www/ipa.png",
tool = "IPA",
label = "Ingenuity Pathway Analysis",
content = "Analyze data using manually curated gene sets"
)
),
column(
3,
thumbnail_label(
url = "https://astrazeneca.onramp.bio",
image = "www/onramp.png",
tool = "OnRamp",
label = "OnRamp - Rosalind",
content = "Interactively explore RNA-seq and ChIP-Seq data"
)
),
br(),
column(
3,
thumbnail_label(
url = "http://software.broadinstitute.org/gsea/msigdb/index.jsp",
image = "www/gsea.png",
tool = "GSEA",
label = "GSEA",
content = "Gene set enrichment analysis"
)
)
)
)
)
}

Can I create Submit button with observeEvent in R?

i just stuck in observeEvent when i want to create submit button , the event doesn't make any action when i got to clicked, for the example here my code for the modal:
column(width = 6,
bs4Card(width = 12, collapsible = FALSE, title = "Follow Up",
selectInput("cara_fu", "Cara Follow up",
choices = c('Call','Whatsapp', 'Visit')),
selectInput("hasil_fu", "Hasil Follow up",
choices = c('Survey', 'Batal', 'Unreachable')),
textAreaInput("ket_fu", "Keterangan",height = '100px'),
footer = actionButton("submit_fu", "Submit", status = "success")
)
)
then when the form has been input by the value, the observeEvent will be generate by this code :
# IF USER CLICKS SUBMIT FOLLOWUP, SAVE THE DATA IN DATABASE
observeEvent(input$submit_fu, {
text = tagList(
selectInput("cara_fu", "Cara Follow up",
choices = c('Call','Whatsapp', 'Visit'), selected = df$cara_fu),
selectInput("hasil_fu", "Hasil Follow up",
choices = c('Survey','Batal', 'Unreachable'), selected = df$hasil_fu),
textInput("ket_fu", "Keterangan")
)
}) # End observe submit button
and when this button cliked nothing happen , im glad when all of u can find whats wrong here thanks
and here for the full code :
shiny::observeEvent(input$current_id, {
shiny::req(!is.null(input$current_id) &
stringr::str_detect(input$current_id,
pattern = "followup"
))
rv$dt_row <- which(stringr::str_detect(rv$df$Buttons,
pattern = paste0("\\b", input$current_id, "\\b")
))
showModal(
modalDialog(title = "Followup", easyClose = TRUE, size = "l",
fluidPage(
fluidRow(
column(width = 6,
bs4Card(width = 12, collapsible = FALSE, title = "Profile Summary",
boxProfile(
image = "https://adminlte.io/themes/AdminLTE/dist/img/user4-128x128.jpg",
title = (rv$df$nama_customer[rv$dt_row]),
subtitle =(rv$df$no_hp_customer[rv$dt_row]),
bordered = TRUE,
boxProfileItem(
title = "Jadwal Followup",
description =rv$df$scheduled_followup[rv$dt_row]),
boxProfileItem(
title = "Produk",
description = rv$df$produk[rv$dt_row]),
boxProfileItem(
title = "Status",
description = rv$df$status[rv$dt_row])
)
),
bs4Card(width = 12, collapsible = FALSE, title = "History Followup",
timelineBlock(
width = 12,
timelineLabel(as.Date(Sys.Date()), color = "primary"),
timelineItem(
title = "Followup 1",
icon = icon("book"),
color = "secondary",
time = "now",
"This is the body"
),
timelineLabel(as.Date(Sys.Date()), color = "primary"),
timelineItem(
title = "Followup 3",
icon = icon("book"),
color = "secondary"
)
)
)
),
column(width = 6,
bs4Card(width = 12, collapsible = FALSE, title = "Follow Up",
selectInput("cara_fu", "Cara Follow up",
choices = c('Call','Whatsapp', 'Visit')),
selectInput("hasil_fu", "Hasil Follow up",
choices = c('Survey', 'Batal', 'Unreachable')),
textAreaInput("ket_fu", "Keterangan",height = '100px'),
footer = actionButton("submit_fu", "Submit", status = "success")
)
)
)
),
footer = tagList(
modalButton("Cancel"),
actionButton("ok", "OK")
)
)
)
observeEvent(input$submit_fu, {
text = tagList(
selectInput("cara_fu", "Cara Follow up",
choices = c('Call','Whatsapp', 'Visit'), selected = df$cara_fu),
selectInput("hasil_fu", "Hasil Follow up",
choices = c('Survey','Batal', 'Unreachable'), selected = df$hasil_fu),
textInput("ket_fu", "Keterangan")
)
}) # End observe submit button
}) # End observe followup button
}
# Run the application
shinyApp(ui = ui, server = server)

Leaflet not working in R Shiny Package fullPage

I am having trouble getting a leaflet map to display in R Shiny when using the fullPage package/theme. Anyone have any idea what could be going on here? Code works in all the othe Shiny themes I use, so I'm guessing it's something specific to fullPage? I only started playing around with this theme yesterday so certainly possible I'm missing something.
Full Example Below:
#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com/
#
library(shiny)
library(fullPage)
library(leaflet)
library(highcharter)
library(glue)
library(tidyverse)
img1 <- "https://live.staticflickr.com/8081/8312400018_f53f23dac9_b.jpg"
# Define UI for application that draws a histogram
options <- list(
sectionsColor = c('#F5F5F5'),
parallax = TRUE
)
ui <- fullPage(
menu = c("Home" = "home",
"About" = "about",
"Analytics" = "analytics",
"Buy" = "section3",
"Sell" = "section4",
"Rent" = "section5",
"Contact" = "contact"),
opts = options,
fullSectionImage(
img = img1,
menu = "home"
),
fullSection(
center = FALSE,
menu = "about",
br(),
br(),
fullContainer(
tags$h1("Example")
),
fullContainer(
fullRow(
fullColumn(
p('Some text.'),
br(),
p('More text.')
)
)
),
fullRow(
pre(
code(
img(src = 'https://pics.harstatic.com/office/395001.png', width = '50%', height = 'auto')
)
)
)
),
fullSection(
menu = "analytics",
fullRow(
fullColumn(
h3("Column 1"),
selectInput(
"dd",
"data points",
choices = c(10, 20, 30)
)
),
fullColumn(
plotOutput("hist")
),
fullColumn(
plotOutput("plot")
)
)
),
fullSection(
menu = "section3",
fullSlide(
fullContainer(
center = TRUE,
h3("With container"),
plotOutput("slideplot2"),
shiny::verbatimTextOutput("containerCode")
)
),
fullSlide(
center = TRUE,
h3("Without container"),
plotOutput("slideplot1")
)
),
fullSectionPlot(
menu = "section4",
center = TRUE,
"fp",
h3("Background plots"),
fullContainer(
sliderInput(
"fpInput",
label = "Input",
min = 10,
max = 100,
value = 74
)
)
),
fullSection(
menu = "section5",
fullSlidePlot(
"slideSectionPlot1",
center = TRUE,
h1("Slide background plot")
),
fullSlidePlot(
"slideSectionPlot2"
)
),
fullSection(
menu = "contact",
fullContainer(
leaflet::leafletOutput('map')
)
)
)
server <- function(input, output, session){
output$map <- leaflet::renderLeaflet({
leaflet() %>%
addTiles(group = "OSM (default)")
}
)
}
shinyApp(ui, server)

Shiny radio button not getting rendered initially when the app starts

I am doing some timeseries analysis and have created a shiny app where when the app starts sample timeseries data is uploaded or the user can upload csv dataset from his local directory....
Sample Dataset:
df
month passengers
1 01-01-2000 2072798
2 01-02-2000 2118150
3 01-03-2000 2384907
4 01-04-2000 2260620
5 01-05-2000 2386165
6 01-06-2000 2635018
7 01-07-2000 2788843
8 01-08-2000 2942082
9 01-09-2000 2477000
10 01-10-2000 2527969
11 01-11-2000 2161170
12 01-12-2000 2175314
13 01-01-2001 2307525
14 01-02-2001 2196415
15 01-03-2001 2545863
library(signal)
library(shiny)
library(AnomalyDetection) #devtools::install_github("twitter/AnomalyDetection")
library(ggplot2)
# Define UI for application that draws a histogram
library(shinydashboard)
library(shinycssloaders)
library(googleVis)
shinyUI(dashboardPage(skin = "green",
dashboardHeader(title = "Anomaly Detection in Time series",
titleWidth = 350),
dashboardSidebar(
sidebarUserPanel("Nishant Upadhyay",
image = "nishantcofyshop.jpg"
),
sidebarMenu(
menuItem("Data", tabName = "data", icon = icon("database")),
menuItem("Filters", tabName = "filter", icon = icon("filter")),
menuItem("Anomalies", tabName = "anomaly", icon = icon("check")),
#menuItem("Save Data", tabName = "save", icon = icon("save"))
menuItem("About The App", tabName = "Help", icon = icon("info-circle"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "data",
fluidRow(
box(
title = "Data scatter Chart",
status = "primary",
solidHeader = T,
collapsible = T,
width = 12,
shinycssloaders::withSpinner(htmlOutput("dataChart"),type = getOption("spinner.type", default = 8),color = "red")
)
),
fluidRow(
box(
radioButtons(
"data_input","",
choices = list("Load sample data" = 1,
"Upload csv file" = 2
)
),
conditionalPanel(
condition = "input.data_input=='1'",
h5("Sample dataset of Lebron James basketball shots over the years")
),
conditionalPanel(
condition = "input.data_input=='2'",
fileInput('file1', 'Choose file to upload',
accept = c(
'text/csv',
'text/comma-separated-values',
'text/tab-separated-values',
'text/plain',
'.csv',
'.tsv'
)),
checkboxInput('header', 'Header', TRUE),
radioButtons('sep', 'Separator',
c(Comma=',',
Semicolon=';',
Tab='\t'),','),
radioButtons('quote', 'Quote',
c('None'='',
'Double Quote'='"',
'Single Quote'="'"),
'')
),
title = "Select Dataset",
status = "info",
solidHeader = T,
collapsible = T
),
box(
title = "Data",
status = "info",
solidHeader = T,
collapsible = T,
shinycssloaders::withSpinner(htmlOutput('contents'),type = getOption("spinner.type", default = 8),color = "red")
)# end of box
)## end of Fluid row
), ## end of tab item
tabItem(
tabName = "filter",
fluidRow(
box(
title = "Data Chart",
status = "primary",
solidHeader = T,
collapsible = T,
width = 12,
shinycssloaders::withSpinner(htmlOutput('dataChartFiltered'),type = getOption("spinner.type", default = 8),color = "red")
)
),
fluidRow(
box(
title = "Filters",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
radioButtons("filt", NULL,
c("None" = "none",
"Butterworth" = "butt",
"Type-II Chebyshev" = "cheby2")),
submitButton("Filter")
),
box(
title = "Butterworth",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
textInput("buttern", label = "Filter Order", value = "3"),
textInput("butterf", label = "Critical Frequencies", value = "0.1"),
radioButtons("buttert", "Type",
c("Low-Pass" = "low",
"High-Pass" = "high"))
),
box(
title = "Chebyshev",
status = "info",
solidHeader = T,
collapsible = T,
width = 4,
textInput("chebyn", label = "Filter Order", value = "5"),
textInput("chebyd", label = "dB of Pass Band", value = "20"),
textInput("chebyf", label = "Critical Frequencies", value = "0.2"),
radioButtons("chebyt", "Type",
c("Low-Pass" = "low",
"High-Pass" = "high"))
)
)
)
) ## end of tab items
) ## end of Dashboard
)
)
shinyServer(function(input, output){
dataframe<-reactive({
if (input$data_input == 1) {
tab <- read.csv("df.csv",header = T,stringsAsFactors = F)
} else if (input$data_input == 2) {
inFile <- input$file1
if (is.null(inFile))
return(data.frame(x = "Select your datafile"))
tab = read.csv(inFile$datapath, header = input$header,
sep = input$sep, quote = input$quote)
}
tt <- tryCatch(as.POSIXct(tab[,1]),error=function(e) e, warning=function(w) w)
if (is(tt,"warning") | is(tt,"error")) {
tab$Old = tab[,1]
tab[,1] = as.POSIXct(1:nrow(tab), origin = Sys.time())
} else {
tab[,1] = as.POSIXct(tab[,1])
}
tab
})
output$dataChart <- renderGvis({
if (!is.null(dataframe()))
gvisLineChart(dataframe()[,c(1,2)], xvar = colnames(dataframe())[1], yvar = colnames(dataframe())[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
})
output$contents <- renderGvis({
if (!is.null(dataframe()))
gvisTable(dataframe(),
options = list(page='enable'))
})
output$dataChartFiltered <- renderGvis({
if (input$filt == "none") {
return(NULL)
} else if (input$filt == "butt") {
bf <- butter(as.numeric(input$buttern), as.numeric(input$butterf), type = input$buttert)
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(bf, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
} else if (input$filt == "cheby2") {
ch <- cheby2(as.numeric(input$chebyn), as.numeric(input$chebyd),
as.numeric(input$chebyf), type = input$chebyt)
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(ch, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
}
})
})
The problem i am facing is that once the shiny app is executed , the sample data is loaded properly as the this data is placed in the app folder in the directory (one can use R inbuilt data set or use the data i gave in the start) and subsequently all steps gets executed properly.
But if i want to upload some other csv file from local directory, the upload button selection does not get activated even after selecting it.But,in fact, if one goes to the second menu item in the sidebar panel i.e. filter tab and clicks on the filter button (under Filters box ) and then if i go back to Data menu in the sidebar panel again, i can see that now my upload csv file button has got activated and now i can browse the csv file in local directory and upload the same into the app and now everything works fine.
It seems somewhere the condition that makes the upload file button is not getting active initially when the app opens....
Need help to sort out the issue...Sorry for posting large chunk of code....
conditionalPanel and submitButton do not work well together. Replace your submitButton("Filter") with actionButton("Filter", "").
EDIT:
As per the comment, for the plot to be generated only after the actionButton is clicked you can put output$dataChartFiltered inside observeEvent of Filter with isolate for `input objects as follows:
observeEvent(input$Filter,{
output$dataChartFiltered <- renderGvis({
if (isolate(input$filt) == "none") {
return(NULL)
} else if (isolate(input$filt) == "butt") {
bf <- butter(as.numeric(isolate(input$buttern)), as.numeric(isolate(input$butterf)), type = isolate(input$buttert))
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(bf, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
} else if (isolate(input$filt) == "cheby2") {
ch <- cheby2(as.numeric(isolate(input$chebyn)), as.numeric(isolate(input$chebyd)),
as.numeric(isolate(input$chebyf)), type = isolate(input$chebyt))
filtered = data.frame(timestamp = dataframe()[,1],
count = as.numeric(filter(ch, dataframe()[,2])))
gvisLineChart(filtered, xvar = colnames(filtered)[1], yvar = colnames(filtered)[2],
options = list(
crosshair.trigger = 'selection',
enableInteractivity = TRUE,
hAxis.maxTextLines = 10,
tooltip.trigger = 'none'
))
}
})
})

Navbar/Tabset with reactive Panel number but NOT rendering everything

This question might seem to be a duplicate, but let me explain why it's not.
I want to create a shiny navbarPage that has fixed elements and a reactive number of tabPanels, that reacts to other input elements. There are many questions about how to create reactive tabsetPanels/navbarPages but they mostly aim for what it has to look like. The most common answer (and the answer i don't seek) is to render the whole navbarPage with updated set of tabPanels. I am aware of that concept and I used it in the code below.
Here is what I want my app to look like:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
uiOutput("navPage")
)
),
server = function(input, output, session){
MemoryValue1 <- 1
MemoryValue2 <- 1
makeReactiveBinding("MemoryValue1")
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
observeEvent(input$insidepanels, {
MemoryValue1 <<- input$insidepanels
})
observeEvent(input$number, {
MemoryValue2 <<- input$number
})
output$navPage <- renderUI({
OutsidePanel1 <- tabPanel("Outside1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = isolate(MemoryValue1), step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = isolate(MemoryValue2), min = 1),
actionButton("button", label = "Add Output-Element")
)
OutsidePanel2 <- tabPanel("Ouside2", "Outside 2")
InsidePanels <- lapply(1:MemoryValue1, function(x){tabPanel(paste0("Inside", x), plotOutput(paste0("plot_", x)))})
do.call(navbarPage, list("Nav", OutsidePanel1, OutsidePanel2, do.call(navbarMenu, c("Menu", InsidePanels))))
})
}
)
)
As you might have seen, it takes a lot of effort to store your input values if they are inside other panels and will be re-rendered = reset all the time. I find this solution to be illegible and slow, because of unnecessary rendering. It also interrupts the user who is clicking through values of input$insidepanels.
What I want the app to be like is that the Outside Panels are fixed and dont re-render. The main problem is that inside shiny, navbarPage on rendering distributes HTML elements to two different locations. Inside the navigation panel and to the body as tab content. That means a-posteori added elements will not be properly embedded.
So far, I have tried to create the navbarPage with custom tags and have dynamic output alter only parts of it. That works pretty well with the navigation panel, but not with tab contents. The reason is that all tabs (their div containers) are listed one after another and as soon as I want to inject multiple at once, I am offthrown by htmlOutput, since it (seemingly) has to have a container and cannot just deliver plain HTML. Thus, all custom tabs are not recongnized properly.
Here my code so far:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
htmlOutput("dropdownmenu", container = tags$ul, class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 1, step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = 1, min = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2"),
htmlOutput("tabcontents")
)
)
)
),
server = function(input, output, session){
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
output$dropdownmenu <- renderUI({
lapply(1:input$insidepanels, function(x){tags$li(tags$a(href = paste0("#tab-menu-", x), "data-toggle" = "tab", "data-value" = paste0("Inside", x), paste("Inside", x)))})
})
output$tabcontents <- renderUI({
tagList(
lapply(1:input$insidepanels, function(x){div(class = "tab-pane", "data-value" = paste("Inside", x), id = paste0("tab-menu-", x), plotOutput(paste0("plot_", x)))})
)
})
}
)
)
Note: I also tried to create HTML with JavaScript-Chunks that is triggered from inside server. This works for simple tab content, but I want my tabPanels to still have shiny output elements. I don't see how I can fit that in with JavaScript. That is why I included the plotOutput content in my code.
Thanks to anybody who can help solve this issue!
Finally came up with an own answer. I hope this can be a useful reference to others who try to understand shiny reactiveness. The answer is JavaScript for custom elements (rebuilding standard shiny elements) and using Shiny.unbindAll() / Shiny.bindAll() to achieve the reactivity.
Code:
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$script('
Shiny.addCustomMessageHandler("createTab",
function(nr){
Shiny.unbindAll();
var dropdownContainer = document.getElementById("dropdown-menu");
var liNode = document.createElement("li");
liNode.setAttribute("id", "dropdown-element-" + nr);
var aNode = document.createElement("a");
aNode.setAttribute("href", "#tab-menu-" + nr);
aNode.setAttribute("data-toggle", "tab");
aNode.setAttribute("data-value", "Inside" + nr);
var textNode = document.createTextNode("Inside " + nr);
aNode.appendChild(textNode);
liNode.appendChild(aNode);
dropdownContainer.appendChild(liNode);
var tabContainer = document.getElementById("tabContent");
var tabNode = document.createElement("div");
tabNode.setAttribute("id", "tab-menu-" + nr);
tabNode.setAttribute("class", "tab-pane");
tabNode.setAttribute("data-value", "Inside" + nr);
var plotNode = document.createElement("div");
plotNode.setAttribute("id", "plot-" + nr);
plotNode.setAttribute("class", "shiny-plot-output");
plotNode.setAttribute("style", "width: 100% ; height: 400px");
tabNode.appendChild(document.createTextNode("Content Inside " + nr));
tabNode.appendChild(plotNode);
tabContainer.appendChild(tabNode);
Shiny.bindAll();
}
);
Shiny.addCustomMessageHandler("deleteTab",
function(nr){
var dropmenuElement = document.getElementById("dropdown-element-" + nr);
dropmenuElement.parentNode.removeChild(dropmenuElement);
var tabElement = document.getElementById("tab-menu-" + nr);
tabElement.parentNode.removeChild(tabElement);
}
);
'),
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
tags$ul(id = "dropdown-menu", class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 0, step = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 0, step = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2")
)
)
)
),
server = function(input, output, session){
allOpenTabs <- NULL
observeEvent(input$insidepanels, {
if(!is.na(input$insidepanels)){
localList <- 0:input$insidepanels
lapply(setdiff(localList, allOpenTabs), function(x){
session$sendCustomMessage(type = "createTab", message = x)
})
lapply(setdiff(allOpenTabs, localList), function(x){
session$sendCustomMessage(type = "deleteTab", message = x)
})
allOpenTabs <<- localList
}
})
observeEvent(input$button, {
output[[paste0("plot-", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
}
), launch.browser = TRUE
)
It is basically adding the HTML Elements "by hand" and linking them to shiny listeners.

Resources