I am trying to create two tabs and for each tab in shiny I want to have different UI for each tab.
I am able to create two tabs and the problems i face is the UI is not specific for each tab and when I add the second tab, the UI in the first tab doesn't work. Any idea how to resolve these issues?
The code looks like this:
#Library
library(shiny)
library(shinydashboard)
#Run the Source
pdf(NULL)
#Shiny Header/Sidebar/Body
header=dashboardHeader(title = "FTA Risk Center")
sidebar=dashboardSidebar(sidebarMenu(id = "sidebarmenu",
menuItem("Risk Dashboard", tabName = "Flow", icon = icon("dashboard")),
menuItem("HKJAP", tabName = "HKJAP", icon = icon("th")),
menuItem("HKKOR", tabName = "HKKOR", icon = icon("th"))
))
body=dashboardBody(
tabItems(tabItem(tabName = "HKJAP",uiOutput('output1'),
fluidRow(column(width = 3,box(title = "Summary of EQ Delta", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",tableOutput("EOD"))),column(width = 3,box(title = "Summary of FX Delta", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",tableOutput("FX"))),column(width = 3,box(title = "Unmapped Tickers", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",tableOutput("UnmappedTickers")))),
fluidRow(column(width = 8,box(title = "Exposures by Indices", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",plotOutput("Chart1"))))),
tabItem(tabName = "HKKOR",uiOutput('output2'),
fluidRow(column(width = 3,box(title = "Summary of EQ Delta", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",tableOutput("EOD"))),column(width = 3,box(title = "Summary of FX Delta", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",tableOutput("FX"))),column(width = 3,box(title = "Unmapped Tickers", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",tableOutput("UnmappedTickers")))),
fluidRow(column(width = 8,box(title = "Exposures by Indices", width = NULL, collapsible = TRUE, solidheader = TRUE,status = "primary",plotOutput("Chart2")))))
)
)
ui <- dashboardPage(header,sidebar,body)
#Shiny Server
server <- function(input, output,session) {
observeEvent(input$sidebarmenu,{
if(input$sidebarmenu == "HKJAP")
{
obsJAP <- observeEvent(reactiveTimer(30000)(),{ # Trigger every 30 seconds
source("HKJAP_Live_monitor_v1.R")
obsJAP$destroy()
})
output$output1 <- renderUI({
invalidateLater(30000, session)
h1(paste("Risk Exposures as of ",Sys.time()))
})
output$EOD=renderTable({
invalidateLater(30000, session)
EQ_delta_summary_Live})
output$FX=renderTable({
invalidateLater(30000, session)
FX_delta_summary_Live})
output$UnmappedTickers=renderTable({
invalidateLater(30000, session)
unmapped_tickers})
output$Chart1=renderPlot({
invalidateLater(30000, session)
plot(NIKKEI$trade_time,cumsum(NIKKEI$EQ_Delta),type='l',xlim=time_scale,ylim=c(-30,30), main=paste("Main Indices"),lwd=2)
grid(10,10,lty=5)
lines(TOPIX$trade_time,cumsum(TOPIX$EQ_Delta),type='l',col="red",lwd=3)
lines(NIKKEI_400$trade_time,cumsum(NIKKEI_400$EQ_Delta),type='l',col="orange",lwd=3)
lines(MXJ$trade_time,cumsum(MXJ$EQ_Delta),type='l',col="green",lwd=3)
lines(TSE_MOTHERS$trade_time,cumsum(TSE_MOTHERS$EQ_Delta),type='l',col="blue",lwd=3)
lines(REITS$trade_time,cumsum(REITS$EQ_Delta),type='l',col="pink",lwd=3)
legend("topright",c("TOPIX","NIKKEI","NIKKEI 400","MXJ","TSE_M","REITS"),lty = c(1,1),col = c("red","black","orange","green","blue","pink"),,bty = 'n',cex = 0.8)
})
}else if(input$sidebarmenu == "HKKOR"){
obsKOR <- observeEvent(reactiveTimer(30000)(),{ # Trigger every 30 seconds
source("HKKOR_Live_monitor_v1.R")
obsKOR$destroy()
})
output$output2 <- renderUI({
invalidateLater(30000, session)
h1(paste("Risk Exposures as ",Sys.time()))
})
output$EOD=renderTable({
invalidateLater(30000, session)
EQ_delta_summary_Live})
output$FX=renderTable({
invalidateLater(30000, session)
FX_delta_summary_Live})
output$UnmappedTickers=renderTable({
invalidateLater(30000, session)
unmapped_tickers})
output$Chart2=renderPlot({
invalidateLater(30000, session)
plot(KOSPI_DIV$trade_time,cumsum(KOSPI_DIV$EQ_Delta),type='l',xlim=time_scale,ylim=c(-30,30), main=paste("Main Indices"),lwd=2)
grid(10,10,lty=5)
lines(KOSPI$trade_time,cumsum(KOSPI$EQ_Delta),type='l',col="red",lwd=3)
lines(KOSDAQ$trade_time,cumsum(KOSDAQ$EQ_Delta),type='l',col="orange",lwd=3)
lines(KRX$trade_time,cumsum(KRX$EQ_Delta),type='l',col="green",lwd=3)
lines(MSCI_KOR$trade_time,cumsum(MSCI_KOR$EQ_Delta),type='l',col="blue",lwd=3)
lines(SPX_HKKOR$trade_time,cumsum(SPX_HKKOR$EQ_Delta),type='l',col="pink",lwd=3)
legend("topright",c("KOSPI_DIV","KOSPI","KOSDAQ","KRX","MSCI_KOR","SPX"),lty = c(1,1),col = c("black","red","orange","green","blue","pink"),,bty = 'n',cex = 0.8)
})
}
}
)
}
shinyApp(ui, server)
Related
I tried to make dynamic Tab using argonDash package. However, I met some trouble with my code.
I guess argonDash seems to get different behavior than native shiny because argonDash uses Bootstrap 4 (instead of 3).
My code is composed of two key features:
The first widget uiOutput(outputId = "new_argonSidebarItem") works well.
The second widget uiOutput(outputId = "new_argonTabItem") doesn't work properly. I expect that the argonBadge() toggle with the second tab.
library(shiny)
library(argonDash)
library(argonR)
ui <- argonDashPage(
sidebar = argonDashSidebar(
id = "sidebar01",
vertical = FALSE,
size = "md",
background = "white",
argonSidebarMenu(
style = "display:-webkit-inline-box;",
argonSidebarItem(
tabName = "Tab1",
icon = NULL,
"Dashboard"
),
# New Tab
uiOutput(outputId = "new_argonSidebarItem")
)
),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "Tab1",
actionButton("add_more", "Add a new btn")
),
# Body
uiOutput(outputId = "new_argonTabItem")
)
)
)
server <- function(input, output, session) {
observeEvent(input$add_more, {
tabId <- sample.int(n = 1000000, size = 1)
tabName <- paste0("Tab_", tabId)
insertUI(
selector = "#tab-Tab1",
where = "afterEnd",
ui = argonSidebarItem(
tabName = tabName,
tabName
)
)
output$new_argonTabItem <- renderUI({
argonTabItem(
tabName = tabName,
argonBadge(
text = tabName,
src = "#",
pill = FALSE,
status = "success"
)
)
})
})
}
shinyApp(ui, server)
Thank you for your time!
To update your badge you need to track which tab is selected. This is done accordingly to this solution : https://github.com/RinteRface/argonDash/issues/7
But your badge can not be modified, so I replaced it with a button from {shinyWidgets}.
I hope this is what you ask for, I'm not really sure to understand what you want to happen.
library(shiny)
library(argonDash)
library(argonR)
library(shinyWidgets)
ui <- argonDashPage(
sidebar = argonDashSidebar(
id = "sidebar01",
vertical = FALSE,
size = "md",
background = "white",
argonSidebarMenu(
style = "display:-webkit-inline-box;",
argonSidebarItem(
tabName = "Tab1",
icon = NULL,
"Dashboard"
),
# New Tab
uiOutput(outputId = "new_argonSidebarItem")
)
),
body = argonDashBody(
argonTabItems(
argonTabItem(
tabName = "Tab1",
actionButton("add_more", "Add a new btn")
),
# Body
uiOutput(outputId = "new_argonTabItem")
),
tags$script( "$(document).on('click', function(event) {
Shiny.onInputChange('activeTab', $('.active').data().value);});")
)
)
server <- function(input, output, session) {
x <- reactiveValues(tabs = NULL)
observeEvent(input$add_more, {
tabId <- sample.int(n = 1000000, size = 1)
tabName <- paste0("Tab_", tabId)
insertUI(
selector = "#tab-Tab1",
where = "afterEnd",
ui = argonSidebarItem(
tabName = tabName,
tabName
)
)
output$new_argonTabItem <- renderUI({
argonTabItem(
tabName = tabName,
actionBttn(
inputId = paste0(input$activeTab,"_b"),
label = tabName,
style = "float",
color = "success"
)#,
# argonBadge(
# text = tabName,
# src = "#",
# pill = FALSE,
# status = "success"
# )
)
})
})
observeEvent(input$activeTab, {
updateActionButton(session,
paste0(input$activeTab,"_b"),
input$activeTab)
})
}
shinyApp(ui, server)
I am trying to create a dynamic left menu (header), but the items are listed downward instead of to the right. I guess it has to do with the tagList wrapper when defining the UI.
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyWidgets)
library(stringr)
ui = dashboardPage(
dashboardHeader(
leftUi = tagList(uiOutput("filter"))
),
dashboardSidebar(
pickerInput(
"inputParameters",
"Parameters:",
choices = c("a", "b", "c"),
multiple = TRUE,
options = list(
`actions-box` = TRUE,
size = 10,
`selected-text-format` = "count > 1"
)
)
),
dashboardBody(),
title = "DashboardPage"
)
server = function(input, output) {
params <- reactive(input$inputParameters)
output$filter = renderUI(
lapply(seq_along(params()), function(i) {
dropdownButton(
inputId = paste0("mydropdown", i),
label = params()[i],
icon = icon("sliders"),
status = "primary",
circle = FALSE,
selectizeInput(
paste0("input", paste0(str_to_title(params()[i]))),
paste0(paste0(str_to_title(params()[i]), ":")),
choices = 1:3,
multiple = TRUE,
selected = 1:3
)
)
})
)
}
shinyApp(ui, server)
Not tested, I would try:
output$filter = renderUI({
ddbuttons <- lapply(seq_along(params()), function(i) {
dropdownButton(
inputId = paste0("mydropdown", i),
label = params()[i],
icon = icon("sliders"),
status = "primary",
circle = FALSE,
selectizeInput(
paste0("input", paste0(str_to_title(params()[i]))),
paste0(paste0(str_to_title(params()[i]), ":")),
choices = 1:3,
multiple = TRUE,
selected = 1:3
)
)
})
do.call(splitLayout, ddbuttons)
})
And don't use tagList, just uiOutput("filter").
I am trying to pass a reactive value derived from the selectizeInput select1 to a plotting function. The reactive value itself is dependent on input from awesomeRadio radio1.
Unfortunately, passing this value to the plot function does not work, although it's accessible by renderText(). Here is an example:
library(shiny)
library(shinydashboard)
##### plot function ------------------------
plot_function <- function(highlight){
plot(1:9)
points(x=c(1:9)[highlight],
y=c(1:9)[highlight],
col="red")
}
##### ui ------------------------
header <- dashboardHeader(
title = "Title",
titleWidth = 500
)
body <- dashboardBody(
fluidRow(
column(width = 4,
box(title = "Plot 1",
plotOutput("plot1", height = 300)
),
box(width = NULL, status = "warning",
awesomeRadio(inputId = "radio1",
label = "Radio1",
choices = c("Option1","Option2"),
inline = TRUE,
status="primary"
),br(),
uiOutput("select1"))
),
column(width = 3,
box(width = NULL, status = "warning",
textOutput(outputId = "option1")),
box(width = NULL, status = "warning",
textOutput(outputId = "option2")))
)
)
ui = dashboardPage(
header,
dashboardSidebar(disable = TRUE),
body
)
##### server ------------------------
server = function(input, output) {
onSessionEnded(stopApp)
choices = reactive({
if (input$radio1=="Option1") {
1:4
} else if (input$radio1=="Option2") {
5:8
}
})
output$select1 <- renderUI({
selectizeInput("select1", label="Select1",
choices=choices())
})
tmp = reactive({input$radio1})
tmp2 = reactive({input$select1})
output$plot1 <- renderPlot(plot_function(highlight = tmp2()))
output$option1 = renderText(paste(tmp()))
output$option2 = renderText(paste(tmp2()))
}
##### ui ------------------------
shinyApp(ui,server)
Also, I don't quite understand the different behavior of tmp and tmp2, since passing tmp to the plot function would work.
Thank you for any help!
After few changes in your code
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
fluidRow(
column(width = 4,
box(title = "Plot 1",
plotOutput("plot1", height = 300)
),
box(width = NULL, status = "warning",
awesomeRadio(inputId = "radio1",
label = "Radio1",
choices = c("Option1","Option2"),
inline = TRUE,
status = "primary"
),br(),
uiOutput("select1"))
),
column(width = 3,
box(width = NULL, status = "warning",
textOutput(outputId = "option1")),
box(width = NULL, status = "warning",
textOutput(outputId = "option2")))
)
)
##### server ------------------------
server <- function(input, output) {
onSessionEnded(stopApp)
choices <- reactive({
if (input$radio1 == "Option1") {
1:4
} else if (input$radio1 == "Option2") {
5:8
}
})
output$select1 <- renderUI({
selectizeInput("sel", label = "Select1",
choices = choices())
})
output$plot1 <- renderPlot({
plot(1:9)
points(x = c(1:9)[as.numeric(input$sel)],
y = c(1:9)[as.numeric(input$sel)],
col = "red")
})
output$option1 <- renderText(input$radio1)
output$option2 <- renderText(input$sel)
}
shinyApp(ui,server)
Below is some code for a very simple shiny dashboard. On tab 1 "Select" I have a radio button selector and on tab 2 "Food" I have a selectizeInput.
When the dashboard initially loads the first tab is loaded and "Fruits" is selected by default. When I move to tab 2 however, nothing displays in the selectizeInput drop down menu dispite having an observe event linked to the radio buttons.
If I then go back to the Select tab and click on Meats, the selectizeInput populates. If I then select Fruits again on the Select tab, the selectizeInput populates with a list of fruits.
How do I make the selectizeInput populate on first load with the list of fruits?
Thanks
library(shinydashboard)
library(data.table)
menu <- data.table(numb = c(rep(1,4), rep(2,4)),
item = c("Apple", "Orange", "Grape", "Lemon", "Steak", "Chicken", "Pork", "Venison"))
ui <- dashboardPage(skin = "blue",
dashboardHeader(),
dashboardSidebar(
sidebarMenu(id = "initalTab",
sidebarMenuOutput("menuSidebar"))
),
dashboardBody(
tabItems(
tabItem("select",
uiOutput("selectType")),
tabItem("food",
uiOutput("selectFood"))
)
)
)
server <- (function(input, output, session) {
output$menuSidebar <- renderMenu({
sidebarMenu(
menuItem("Select", tabName = "select", icon = icon("home")),
menuItem("Food", tabName = "food", icon = icon("sort"))
)
})
isolate({updateTabItems(session, "initalTab", "select")})
output$selectType <- renderUI({
fluidRow(
box(width = 3, status = "primary", solidHeader = TRUE,
radioButtons("foodFilter", label = h4("Filter by Food Type"),
choices = c("Fruits" = 1, "Meats" = 2),
selected = 1,
inline = TRUE)
)
)
})
output$selectFood <- renderUI({
fluidRow(
box(width = 6, status = "primary", solidHeader = TRUE,
h4("Select Your Food"),
selectizeInput("group",
choices = NULL,
width ="100%",
NULL,
NULL,
multiple = TRUE,
options = list(plugins = list("drag_drop", "remove_button"),
placeholder = "Please select you food"))
)
)
})
observeEvent(input$foodFilter, {
updateSelectizeInput(session,
"group",
choices = menu[numb == input$foodFilter,`item`],
selected = menu[numb == input$foodFilter,`item`][1],
server = TRUE)
})
})
shinyApp(ui, server)
Building up on my comment try adding this line outputOptions(output, "selectFood", suspendWhenHidden = FALSE)
library(shinydashboard)
library(data.table)
library(shiny)
menu <- data.table(numb = c(rep(1,4), rep(2,4)),
item = c("Apple", "Orange", "Grape", "Lemon", "Steak", "Chicken", "Pork", "Venison"))
ui <- dashboardPage(skin = "blue",
dashboardHeader(),
dashboardSidebar(
sidebarMenu(id = "initalTab",
sidebarMenuOutput("menuSidebar"))
),
dashboardBody(
tabItems(
tabItem("select",
uiOutput("selectType")),
tabItem("food",
uiOutput("selectFood"))
)
)
)
server <- (function(input, output, session) {
output$menuSidebar <- renderMenu({
sidebarMenu(
menuItem("Select", tabName = "select", icon = icon("home")),
menuItem("Food", tabName = "food", icon = icon("sort"))
)
})
isolate({updateTabItems(session, "initalTab", "select")})
output$selectType <- renderUI({
fluidRow(
box(width = 3, status = "primary", solidHeader = TRUE,
radioButtons("foodFilter", label = h4("Filter by Food Type"),
choices = c("Fruits" = 1, "Meats" = 2),
selected = 1,
inline = TRUE)
)
)
})
output$selectFood <- renderUI({
fluidRow(
box(width = 6, status = "primary", solidHeader = TRUE,
h4("Select Your Food"),
selectizeInput("group",
choices = NULL,
width ="100%",
NULL,
NULL,
multiple = TRUE,
options = list(plugins = list("drag_drop", "remove_button"),
placeholder = "Please select you food"))
)
)
})
outputOptions(output, "selectFood", suspendWhenHidden = FALSE)
observeEvent(input$foodFilter,{
updateSelectizeInput(session,
"group",
choices = menu[numb == input$foodFilter,`item`],
selected = menu[numb == input$foodFilter,`item`][1],
server = TRUE)
})
})
shinyApp(ui, server)
I am a newbie to shiny dashboard. I want to know how to print str() of the table which i have imported in shiny dashboard. my code is not working. When i print str(), i get the below output,
str()
Please check the code which i have written,
library(shiny)
library(shinydashboard)
library(DT)
ui <- dashboardPage(
dashboardHeader(title = "Analytics Workbench 2.0", titleWidth = 250,
dropdownMenuOutput("msgs")),
dashboardSidebar(
sidebarMenu(
fileInput("Table1", "Train Data"),
fileInput("Table2", "Test Data"),
menuItem("Variable Analysis", icon = icon("edit"),
menuSubItem("Uni-Variate Analysis"),
menuSubItem("Multi-Variate Analysis"))
)
),
dashboardBody(
fluidRow(
column(12, box(title = "Train Data", width = 6, solidHeader = TRUE, status = "warning",
collapsible = TRUE, DT::DTOutput("Train")),
box(title = "Test Data", width = 6, solidHeader = TRUE, status = "warning",
collapsible = TRUE, DT::DTOutput("Test")))),
fluidRow(
column(12, box(title = "Structure", width = 6, solidHeader = TRUE, status = "warning",
collapsible = TRUE, verbatimTextOutput("str1")),
box(title = "Structure", width = 6, solidHeader = TRUE, status = "warning",
collapsible = TRUE, verbatimTextOutput("str2"))))
)
)
server <- function(input, output) {
output$msgs <- renderMenu({
msg <- apply(read.csv("messages.csv"), 1, function(row){
messageItem(from = row[["from"]], message = row[["message"]]) })
dropdownMenu(type = "messages", .list = msg)
})
output$Train <- DT::renderDT({
if (is.null(input$Table1)) return(NULL)
data1 <- read.table(input$Table1$datapath, fill = TRUE, header=T, sep=",")
DT::datatable(data1, options = list(scrollX = TRUE))
})
output$Test <- DT::renderDT({
if (is.null(input$Table2)) return(NULL)
data2 <- read.table(input$Table2$datapath, fill = TRUE, header=T, sep=",")
DT::datatable(data2, options = list(scrollX = TRUE))
})
output$str1 <- renderText({
paste(capture.output(str(input$Table1)), collapse = "\n")
})
output$str2 <- renderText({
paste(capture.output(str(input$Table1)), collapse = "\n")
})
}
I am not able to find out the input to be given for str()
Thanks
Balaji
Switch out your textOutput for verbatimTextOutput. Also, you require a reactive to treat the fileInput... specifically take note that you should trap the case when the input value is NULL.
app.R
library(shiny)
write.csv(mtcars, "mtcars.csv") # file created to test file input
ui <- fluidPage(
mainPanel(
verbatimTextOutput("strfile"),
fileInput("file1", "File")
)
)
server <- function(input, output) {
df <- reactive({
if (is.null(input$file1)) {
return(NULL)
} else {
read.csv(input$file1$datapath, row.names = 1) # note the row.names are dependent on your input requirements
}
})
output$strfile <- renderPrint({str(df())})
}
shinyApp(ui = ui, server = server)
To get this output...