I am trying to clear what ever is written in the text area but looks like it not working. Based on the below applications, when the user clicks on "click" button, the contents (if written) should get cleared. But it is not. Can anyone help me here please........................................
data(mtcars)
library(shiny)
library(shinydashboard)
library(dplyr)
library(DT)
library(shinyjs)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenu(id = "menu", sidebarMenuOutput("menu"))),
dashboardBody(tabItems
(
tabItem
(tabName = "plots", h2("Dashboard plots"),
fluidRow(column(width = 12, class = "well",
h4("Boxplot"),
plotOutput("bxp")))
),
tabItem(tabName = "dashboard", h2("Dashboard tab content"),
dataTableOutput(outputId = "subdt"),textAreaInput("sd","label1"),textAreaInput("sd1","label2") ,
actionButton("idff","click"))
)
)
)
server <- function(input, output, session) {
output$menu <- renderMenu({
sidebarMenu(
# menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),
menuItem("Table Menu", icon = icon("info"),
menuSubItem(
"Dashboard", tabName = "dashboard", icon = icon("calendar")
),
selectInput(
inputId = "mcm", label = "Some label", multiple = TRUE,
choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)
)
)
)
})
observe({
print(input$menu)
})
datsub <- reactive({
mtcars %>%
filter_at(vars("cyl"), all_vars(. %in% input$mcm))
})
output$subdt <- renderDataTable({
datatable(datsub(),selection = if(input$menu == "dashboard"){'single'} else {'none'})
# print(datatable.selection())
})
# datatable(datsub(),selection = if(input$menu == "dashboard"){'single'} else {'none'})
output$bxp <- renderPlot({
hist(rnorm(100))
})
observeEvent(input$idff,{
print("cjec")
shinyjs::reset('sd')
shinyjs::reset('sd1')
})
}
shinyApp(ui, server)
I'd suggest to update the textAreaInput as suggested in the comments. Update the event handler as follows:
observeEvent(input$idff, {
updateTextAreaInput(session = session, inputId = 'sd', value = "")
updateTextAreaInput(session = session, inputId = 'sd1', value = "")
})
Related
I have moved over to the new bs4dash and I am having some issues with updating the control bar.
For each different tab on my sidebar i would like a corresponding control bar. For example, if the sidebar tab is "Home", I would like to the controlbar to consist of multiple selectizeInputs. If however, the sidebar tab is "News", I would like the Control Bar to have different textOutputs.
Here is some of the code I am using
##UI
controlbar = dashboardControlbar(
id = "controlbar",
collapsed = T
)
##Server
observeEvent(input$current_tab,{
if(input$current_tab == "home"){
updateControlbar(id = "controlbar", session = session,
selectizeInput("one", "one", choices = c(1,2,3)
),
selectizeIntput("two", "two", choices = c(1,2,3)
} else if(input$current_tab == "News"){
updateControlbar(id = "controlbar", session = session,
textInput("news1"),
textInput("news2")
}
})
I have also tried many other combos but nothing seems to work.
Thank you for your help
You can combine conditional panels with reactive functions. This code snippet show a very trivial case.
library(shiny)
library(bs4Dash)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(uiOutput("sidebar")),
body = dashboardBody(),
controlbar = dashboardControlbar(uiOutput("controlbar"))
),
server = function(input, output, session) {
output$sidebar <- renderMenu({
sidebarMenu(id = "main_menu",
menuItem(text = "First page", tabName = "tab1"),
menuItem(text = "Second page", tabName = "tab2")
)
})
output$show_tab1 <- reactive({
!is.null(input$main_menu) && input$main_menu == "tab1"
})
output$show_tab2 <- reactive({
!is.null(input$main_menu) && input$main_menu == "tab2"
})
outputOptions(output, "show_tab1", suspendWhenHidden = FALSE)
outputOptions(output, "show_tab2", suspendWhenHidden = FALSE)
output$controlbar <- renderUI({
div(
conditionalPanel(
condition = "output.show_tab1",
p("Widgets for the first page")
),
conditionalPanel(
condition = "output.show_tab2",
p("Widgets for the second page")
)
)
})
}
)
I am unable to create a conditional sidebar menu via renderMenu because the if statement fails. "Warning: Error in if: argument is of length zero".
I found conditional RenderUI R shiny and Conditional panel in Shiny dashboard but neither are what I am looking for. A conditional panel might work in this instance but in the long run I will need to be able to do this server side.
if (interactive()) {
library(ggplot2)
library(shiny)
library(shinydashboard)
library(shinipsum)
ui <- dashboardPage(
header = dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("plotDataVHA"),
sidebarMenuOutput("tabSelector")
),
dashboardBody(tabItems(
tabItem(tabName = "facilities",
fluidRow(box(
uiOutput("selectedFacilityTime")
))),
tabItem(tabName = "service",
fluidRow(box(
uiOutput("selectedFacilityYyCases")
)))
))
)
server <- function(input, output) {
output$renderedSelectedFacilityTime <- renderPlot({
random_ggplot(type = "line")
})
output$selectedFacilityTime <- renderUI({
plotOutput("renderedSelectedFacilityTime")
})
output$renderedFacilityYyCases <- renderPlot({
random_ggplot(type = "bar")
})
output$selectedFacilityYyCases <- renderUI({
plotOutput("renderedFacilityYyCases")
})
output$tabSelector <- renderMenu({
sidebarMenu(id = "test",
menuItem(
text = "Chart data",
menuSubItem(
text = "Facilities",
tabName = "facilities",
selected = TRUE
),
menuSubItem(
text = "Service & Specialty",
tabName = "service",
icon = NULL
)
))
})
output$plotDataVHA <- renderMenu({
if (input$test == "facilities") {
sidebarMenu(
menuItem(
text = "VHA data",
menuSubItem(
text = "None",
selected = TRUE,
icon = NULL
),
menuSubItem(text = "Mean", icon = NULL)
)
)
}
})
}
shinyApp(ui, server)
}
When working properly the menu "VHA data" should only be visible when the submenu "facilities" is selected.
Interesting question. The reason you were getting the argument is of length zero error is because you are rendering both menus on the server side through renderMenu(). So when the app starts, input$test doesn't have a value assigned to it. You can avoid this by using req() which will evaluate the test input$test == "facilities" only after input$test has been initiated.
Now for the menu to only appear when another submenu is selected, you want to create the menu independently of renderMenu(). It is better to evaluate the condition in a normal reactive() and then pass this reactive function as input to renderMenu(). Finally, to remove the menu when input$test == "facilities" is FALSE, you can render an empty html container.
Here is the updated code:
library(ggplot2)
library(shiny)
library(shinydashboard)
library(shinipsum)
ui <- dashboardPage(
header = dashboardHeader(),
dashboardSidebar(
sidebarMenuOutput("plotDataVHA"),
sidebarMenuOutput("tabSelector")
),
dashboardBody(tabItems(
tabItem(tabName = "facilities",
fluidRow(box(
uiOutput("selectedFacilityTime")
))),
tabItem(tabName = "service",
fluidRow(box(
uiOutput("selectedFacilityYyCases")
)))
))
)
server <- function(input, session, output) {
output$renderedSelectedFacilityTime <- renderPlot({
random_ggplot(type = "line")
})
output$selectedFacilityTime <- renderUI({
plotOutput("renderedSelectedFacilityTime")
})
output$renderedFacilityYyCases <- renderPlot({
random_ggplot(type = "bar")
})
output$selectedFacilityYyCases <- renderUI({
plotOutput("renderedFacilityYyCases")
})
output$tabSelector <- renderMenu({
sidebarMenu(id = "test",
menuItem(
text = "Chart data",
menuSubItem(
text = "Facilities",
tabName = "facilities",
selected = TRUE
),
menuSubItem(
text = "Service & Specialty",
tabName = "service",
selected = FALSE,
icon = NULL
)
))
})
make_menu <- reactive({
cat("Current submenu selected: ", input$test, "\n\n")
if (req(input$test) == "facilities") {
sidebarMenu(
menuItem(
text = "VHA data",
menuSubItem(
text = "None",
selected = TRUE,
icon = NULL
),
menuSubItem(text = "Mean", icon = NULL)
)
)
} else {
# return an empty HTML container
div()
}
})
output$plotDataVHA <- renderMenu({
make_menu()
})
}
shinyApp(ui, server)
hi i im trying to have the 'choices' in my pickerInput be dependent on what the user types in the search bar above. im using a spotify r package and if you search a certain artist the api returns a table of artists of the similar name and you need to choose which artist you want. anyways i want that table to go into the pickerInput and i can't seem to get it work.
ui <- dashboardPage(skin = "green",
dashboardHeader(title = "Lyric Prediction"),
dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "Overview", icon = icon("search")),
menuItem("Analysis", tabName = "Analysis", icon = icon("bar-chart-o"))
)
),
dashboardBody(
tags$head(
tags$style(HTML(".fa { font-size: 18px; }"))
),
tabItems(
# First tab content
tabItem(tabName = "Overview",
fluidRow(
column(12,
searchInput(
inputId = "search", label = "Search Artist on Spotify",
placeholder = "Search",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"
)
), align = "center"
),
#HERE - how can i have pickerInput take in the output
#of "res" from the server?
fluidRow(pickerInput(choices = "res")
)),
)
)
server <- function(input, output) {
#function to take search input
#output list of possible artists
output$res <- renderTable({
#Rspotify
possibleArtists <- searchArtist(input$search,token=my_oauth)
possibleArtists <- as_tibble(possibleArtists)
myCols <- c("display_name","id")
colNums <- match(myCols,names(possibleArtists))
possibleArtists <- possibleArtists %>%
select(colNums)
possibleArtists
})
}
shinyApp(ui, server)
Use update method in an observeEvent like this:
observeEvent(input$search, {
#Rspotify
possibleArtists <- searchArtist(input$search,token=my_oauth)
possibleArtists <- as_tibble(possibleArtists)
myCols <- c("display_name","id")
colNums <- match(myCols,names(possibleArtists))
possibleArtists <- possibleArtists %>%
select(colNums)
updatePickerInput(
session = session,
inputId = "picker",
choices = possibleArtists
)
}, ignoreInit = TRUE)
Full example:
library(shiny)
library(shinydashboard)
library(shinyWidgets)
ui <- dashboardPage(
skin = "green",
dashboardHeader(title = "Lyric Prediction"),
dashboardSidebar(
sidebarMenu(
menuItem("Overview", tabName = "Overview", icon = icon("search")),
menuItem("Analysis", tabName = "Analysis", icon = icon("bar-chart-o"))
)
),
dashboardBody(
tags$head(
tags$style(HTML(".fa { font-size: 18px; }"))
),
tabItems(
# First tab content
tabItem(
tabName = "Overview",
fluidRow(
column(12,
searchInput(
inputId = "search", label = "Search Artist on Spotify",
placeholder = "Search",
btnSearch = icon("search"),
btnReset = icon("remove"),
width = "500px"
)
), align = "center"
),
pickerInput(inputId = "picker", label = "Choose an artist:", choices = NULL)
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$search, {
updatePickerInput(
session = session,
inputId = "picker",
choices = c("The Beatles",
"The Beatles Recovered Band",
"Yesterday - A Tribute To The Beatles",
"The Beatles Revival Band & Orchestra")
)
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
I am trying to build a shiny application using sidebarMenu with menuItems. Currently the menu items are duplicated,
enter image description here
Clicking the first and second menu items are not showing the table or the plot. Only the last two shows the output. How can I modify it to have only two items - 1) Plots Menu, 2) Table Menu (with sub items) and clicking on it show the respective output. Used the mtcars dataset and the code ispasted below
data(mtcars)
ibrary(shiny)
library(shinydashboard)
library(dplyr)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(
sidebarMenu(
menuItem("Plots Menu", tabName = "plot_page", icon = icon("line-chart")),
menuItem("Table Menu", tabName="intro_page", icon = icon("info"),
selectInput(inputId = "mcm", label = "Some label",
multiple = TRUE, choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)))
),
sidebarMenuOutput("menu")
),
dashboardBody(tabItems(
tabItem(tabName = "plots", h2("Dashboard plots"),
fluidRow(column(width = 12, class = "well",
h4("Boxplot"),
plotOutput("bxp")))
),
tabItem(tabName = "dashboard", h2("Dashboard tab content"),
dataTableOutput(outputId = "subdt"))
)
)
)
server <- function(input, output, session) {
output$menu <- renderMenu({
sidebarMenu(
menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),
menuItem("Table Menu", tabName="dashboard", icon = icon("calendar"))
)
})
datsub <- reactive({
mtcars %>%
filter_at(vars("cyl"), all_vars(. %in% input$mcm))
})
output$subdt <- renderDataTable({
datsub()
})
output$bxp <- renderPlot({
hist(rnorm(100))
})
}
shinyApp(ui, server)
I put the code together.
-Ian
data(mtcars)
library(shiny)
library(shinydashboard)
library(dplyr)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic sidebar"),
dashboardSidebar(sidebarMenu(id = "menu", sidebarMenuOutput("menu"))),
dashboardBody(tabItems
(
tabItem
(tabName = "plots", h2("Dashboard plots"),
fluidRow(column(width = 12, class = "well",
h4("Boxplot"),
plotOutput("bxp")))
),
tabItem(tabName = "dashboard", h2("Dashboard tab content"),
dataTableOutput(outputId = "subdt"))
)
)
)
server <- function(input, output, session) {
output$menu <- renderMenu({
sidebarMenu(
menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),
menuItem("Table Menu", icon = icon("info"),
menuSubItem(
"Dashboard", tabName = "dashboard", icon = icon("calendar")
),
selectInput(
inputId = "mcm", label = "Some label", multiple = TRUE,
choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)
)
)
)
})
datsub <- reactive({
mtcars %>%
filter_at(vars("cyl"), all_vars(. %in% input$mcm))
})
output$subdt <- renderDataTable({
datsub()
})
output$bxp <- renderPlot({
hist(rnorm(100))
})
}
shinyApp(ui, server)
You have both the standard and reactive sidebar options running in tandem. If you need a reactive sidebar, just put the contents in the server function and call all of it with sidebarMenuOutput in ui.
ui.R
dashboardSidebar(sidebarMenu(id = "menu", sidebarMenuOutput("menu")))
server.R
output$menu <- renderMenu({
sidebarMenu(
menuItem("Plots Menu", tabName = "plots", icon = icon("line-chart")),
menuItem("Table Menu", icon = icon("info"),
menuSubItem(
"Dashboard", tabName = "dashboard", icon = icon("calendar")
),
selectInput(
inputId = "mcm", label = "Some label", multiple = TRUE,
choices = unique(mtcars$cyl), selected = unique(mtcars$cyl)
)
)
)
})
I am using the following dataset: https://docs.google.com/spreadsheets/d/1C_P5xxzYr7HOkaZFfFiDhanqDSuSIrd2UkiC-6_G2q0/edit#gid=0
I am using ShinyDashboard and I have a selectInput that allows me to choose a specific type of Candy bar (in the Candy column in my data set).
How do I take that Candy selection, and then make a graph that contains the frequency for that selected candy bar for each purchase month? In my server.R, I am not sure what to have in that CandyCount reactive element.
My code is as follows:
## ui.R ##
library(shinydashboard)
library(rCharts)
dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
width = 150,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("bar-chart"))
)
),
dashboardBody(
sidebarPanel(
htmlOutput("candy")
),
mainPanel(
showOutput("plot2", "polycharts")
)))
##server.R##
server <- function(input, output, session) {
output$candy<- renderUI({
selectInput(
inputId = "candy",
label = "Candy: ",
choices = as.character(unique(dataset$Candy)),
selected = "Twix"
)
})
output$plot2 <- renderChart2({
candySelect<- input$candy
df <- dataset[dataset$candy == candySelect,]
p2 <- rPlot(freq~purchase_month, data = df, type = 'line')
p2$guides(y = list(min = 0, title = ""))
p2$guides(y = list(title = ""))
p2$addParams(height = 300, dom = 'chart2')
return(p2)
})
}
If your okay with using ggplot you could do something like this:
Edited to have dynamic tooltip
## ui.R ##
library(shinydashboard)
library(shinyBS)
require(ggplot2)
dataset <- read.csv("Sample Dataset - Sheet1.csv")
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
width = 150,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("bar-chart"))
)
),
dashboardBody(
sidebarPanel(
htmlOutput("candy")
),
mainPanel(
uiOutput("plotUI")
)
))
##server.R##
server <- function(input, output, session) {
output$candy<- renderUI({
selectInput(
inputId = "candy",
label = "Candy: ",
choices = as.character(unique(dataset$Candy)),
selected = "Twix"
)
})
output$plotUI <- renderUI({
if(is.null(input$candy)) return(NULL)
local({
candySelect <- input$candy
str1 <- sprintf("The candybar you selected is: %s",candySelect)
str2 <- sprintf("More about %s <a>here</a>",candySelect)
print (str1)
popify(plotOutput('plot'),str1,str2)
})
})
observeEvent(input$candy,{
if(is.null(input$candy)) return(NULL)
candySelect<- input$candy
print ('plot')
# Assuming only one entry for each mont per candybar
d <- dataset[dataset$Candy==candySelect,]
output$plot <- renderPlot({
ggplot(data=d, aes(x=purchase_month,y=freq,group=Candy)) +
geom_line() +
ggtitle(candySelect)
})
})
}
shinyApp(ui = ui, server = server)
I guess this should work otherwise you can bind tooltips using jQuery.