I'd like to use shinyWidgets::materialSwitch instead of a checkbox in my app for an improved UI.
However, I can't seem to get materialSwitch to work when used with renderUI/uiOutput. The input displays properly but doesn't seem to register a click to "switch".
For the purposes of my app - I need this to be inside a renderUI.
Pkg Versions:
shinyWidgets_0.7.2
shiny_1.7.2
library(shiny)
library(shinyWidgets)
# library(shinyjs)
ui <- fluidPage(
div(class="row",
column(width = 3,
uiOutput("switch")
)
)
)
server <- function(input, output, session) {
output$switch = renderUI({
materialSwitch(
inputId = "switch",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE
)
})
}
shinyApp(ui = ui, server = server)
Why is this happening, and how can the problem be fixed?
The issue is that you give same name "switch" to both uiOutput.outputId and materiaSwitch.inputId.
It works OK when they get different ids:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
div(class="row",
column(width = 3,
uiOutput("switch"),
textOutput("result")
)
)
)
server <- function(input, output, session) {
output$switch = renderUI({
materialSwitch(
inputId = "switchButton",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE
)
})
output$result = renderText(input$switchButton)
}
shinyApp(ui = ui, server = server)
Here is how it should work:
library(shiny)
library(shinyWidgets)
# library(shinyjs)
ui <- fluidPage(
div(style = 'position: absolute;left: 50px; top:100px; width:950px;margin:auto',
materialSwitch(inputId = "switch",
label = "Show Count",
right = TRUE,
status = "primary",
value = FALSE)
)
)
server <- function(input, output, session) {
output$value1 <- renderText({ input$switch })
}
shinyApp(ui = ui, server = server)
Related
I want to develop a feature that when opening the switch the image can show outside of the page and when closing the switch, the image is hidden. Here is my sample code for showing/hiding the image in the page but if we can make the image be a floating window and can be moved around the exiting app page?
library("shinydashboard")
library("shinyWidgets")
ui <- fluidPage(
h4("Embedded image"),
uiOutput("img"),
fluidRow(
tags$h4("Show and Hide Image"),
materialSwitch(
inputId = "get_image",
label = "Show Image",
value = FALSE,
status = "success"
),
),
)
server <- function(input, output, session) {
observeEvent(input$get_image, {
if(input$get_image == TRUE){
output$img <- renderUI({
tags$img(src = "https://www.r-project.org/logo/Rlogo.png")
})
}else{
output$img <- NULL
}
})
}
shinyApp(ui, server)
Something like this?
library(shiny)
library("shinydashboard")
library("shinyWidgets")
ui <- fluidPage(
h4("Embedded image"),
uiOutput("img"),
fluidRow(
tags$h4("Show and Hide Image"),
materialSwitch(
inputId = "get_image",
label = "Show Image",
value = FALSE,
status = "success"
),
),
)
server <- function(input, output, session) {
output$img <- renderUI({
if(input$get_image)
absolutePanel(
tags$img(src = "https://www.r-project.org/logo/Rlogo.png", width = "512"),
draggable = TRUE
)
})
}
shinyApp(ui, server)
I have the following app which allows for text to be entered and it is then saved as VALUE and printed on a panel.
Although it looks like I can only do this with one text input at a time - even if I click add (so I don't believe this button is working). On top of that I would like for the user to be able to add multiple inputs (like I have below).
And then my VALUE function should be list with multiple inputs.
code below
library(shiny)
ui <- fluidPage(
headerPanel("R Package App"),
sidebarPanel(
# selectInput("options", "options", choices=c('abc','def')),
textInput("textbox", "Enter R Package Name", ""),
actionButton("add","Add")
),
mainPanel(
textOutput("caption")
)
)
server <- function(input, output, session) {
observe({
VALUE <- ''
if(input$add>0) {
isolate({
VALUE <- input$textbox
})
}
updateTextInput(session, inputId = "textbox", value = VALUE)
})
output$caption <- renderText({
input$textbox
})
}
shinyApp(ui = ui, server = server)
Have you considered using selectizeInput with it's create option?
library(shiny)
packagesDF <- as.data.frame(installed.packages())
ui <- fluidPage(
headerPanel("R Package App"),
sidebarPanel(
selectizeInput(
inputId = "selectedPackages",
label = "Enter R Package Name",
choices = packagesDF$Package,
selected = NULL,
multiple = TRUE,
width = "100%",
options = list(
'plugins' = list('remove_button'),
'create' = TRUE,
'persist' = TRUE
)
)
),
mainPanel(textOutput("caption"))
)
server <- function(input, output, session) {
output$caption <- renderText({
paste0(input$selectedPackages, collapse = ", ")
})
}
shinyApp(ui = ui, server = server)
Consider the following example application:
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
)
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
div(
numericInput(ns("new_option_input"), label = "Add a new option:"),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
#does not work as intended
updateSelectInput(session = session, inputId = "selection", selected = input$new_option_input)
})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
}
# Run the application
shinyApp(ui = ui, server = server)
Basically, the module should do two things:
Allow user to select a pre-existing option --> return that value from module
Allow user to create their own, new option --> return that value from module
I have #1 working, but am struggling on #2. Specifically, where I have the "does not work" comment. How can I achieve this functionality? What are/is the best practice(s) for returning server-side created values from a Shiny module? This is an example app; the real one involves reading the selectInput options from a database, as well as saving the newly created options in the database. Appreciate any help on this! A lot of SO answers regarding Shiny modules have the older callModule(...) syntax, which makes researching this topic a bit more confusing.
You just need to provide the default value in numericInput. Perhaps you are looking for this.
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
ns <- NS(id)
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
),
DTOutput(ns("t1"))
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL,myiris = iris)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
tagList(
numericInput(ns("new_option_input"), label = "Add a new option:",10, min = 1, max = 100),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
return_values$myiris <- iris[1:input$new_option_input,]
#does work as intended
updateSelectInput(session = session, inputId = "selection", choices= c(1:input$new_option_input), selected = input$new_option_input)
})
output$t1 <- renderDT({return_values$myiris})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen"),
DTOutput("t2")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
output$t2 <- renderDT({picker$myiris[,c(3:5)]})
}
# Run the application
shinyApp(ui = ui, server = server)
I have a weird issue with conditionalPanel in shiny dashboard.
I modularized my chart UI components as I need to call it multiple times.
The conditional Panel seems to work fine if I call it only once. However, if I attempted to call more than once, it stopped working.
Below is the reproducible code:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
library(highcharter)
library(lubridate)
chartUI <- function(id) {
ns <- NS(id)
tagList(
verbatimTextOutput(ns("group")),
selectInput(ns("freq"),"Select frequency:",
choices = list("Yearly" = "Y","Half yearly" = "H","Quarterly" = "Q",
"Monthly"="M"), selected = "Yearly", multiple = FALSE),
dateInput(ns("dates"), "Select start date:",format = "yyyy-mm-dd", startview = "month", value = dmy("1/1/2014")),
selectInput(ns("link"),"Select link ratio:",choices = list("All" = "all", "Standard" = "std"),selected = "all"),
conditionalPanel("input.link == 'std'", ns=ns, sliderInput(ns("std.month"),"No of months:",min=1,max=119,value=60))
)
}
ui <- shinyUI(
ui = dashboardPagePlus(skin = "red",
header = dashboardHeaderPlus(
title = "TITLE",
titleWidth = 700
),
dashboardSidebar(),
body = dashboardBody(
# boxPlus(
# width = NULL,title = "CHART",closable = TRUE,enable_sidebar = TRUE,
# sidebar_width = 15,sidebar_start_open = FALSE,sidebar_content = chartUI("chartui1"),
# highchartOutput("")
# ),
boxPlus(
width = NULL,title = "CHART",closable = TRUE,enable_sidebar = TRUE,
sidebar_width = 15,sidebar_start_open = FALSE,sidebar_content = chartUI("chartui2"),
highchartOutput("")
)
),
title = "DashboardPage"
)
)
server <- shinyServer(function(input, output) {
})
shinyApp(ui, server)
If I only call chartui2, conditional panel works fine. But if I call both chartui1 and chartui2, both of them no longer work.
A minimal example with uiOutput / renderUI would be:
library(shiny)
dyn_ui <- function(id) {
ns <- NS(id)
tagList(selectInput(ns("show"), "show or not", choices = c("hide", "show")),
uiOutput(ns("dyn")))
}
dyn_server <- function(input, output, session) {
output$dyn <- renderUI({
ns <- session$ns
if (input$show == "show") {
sliderInput(
inputId = ns("std_month"),
"No of months:",
min = 1,
max = 119,
value = 60
)
}
})
}
ui <- basicPage(dyn_ui("test"))
server <- function(input, output, session) {
callModule(module = dyn_server, id = "test")
}
runApp(list(ui = ui, server = server))
Edit:
In fact, a minimal example works well with conditionalPanel too (see below). So something else about your app is causing a conflict. Not sure what it is, but I would start adding components one by one and see when these minimal examples start misbehaving.
library(shiny)
dyn_ui <- function(id) {
ns <- NS(id)
tagList(
selectInput(ns("show"), "show or not", choices = c("hide", "show")),
conditionalPanel(
ns = ns,
condition = "input.show == 'show'",
sliderInput(
inputId = ns("std_month"),
"No of months:",
min = 1,
max = 119,
value = 60
)
)
}
ui <- basicPage(
dyn_ui("test"),
dyn_ui("test2")
)
server <- function(input, output, session) {
}
runApp(list(ui = ui, server = server))
Is there a way to close the context menu of a dropdownButton in a shiny app after clicking on a button? I was looking for an attribute like closed/opened in the dropdownButton-documentation and couldn't find anything but I believe there must be a way to do this.
This is an example app:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
dropdownButton(
actionButton("button", "Press this Button to close the dropdownButton!"),
circle = TRUE, status = "primary", icon = icon("user-circle")
)
)
server <- function(input, output) {
observeEvent(
input$button, {
# Set dropdownButton closed
print("Test")
}
)
}
shinyApp(ui = ui, server = server)
Do you mean something like this?
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
uiOutput('help')
)
server <- function(input, output) {
observeEvent(
input$button, {
shinyjs::hide("button")
#output$help <- renderUI({} )
}
)
output$help <- renderUI(dropdownButton(
actionButton("button", "Press this Button to close the dropdownButton!"),
circle = TRUE, status = "primary", icon = icon("user-circle")
) )
}
shinyApp(ui = ui, server = server)
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
uiOutput('help')
)
server <- function(input, output) {
observeEvent(
input$button, {
shinyjs::hideElement("dropdown-menu")
}
)
output$help <- renderUI(dropdownButton(
actionButton("button", "Press this Button to close the dropdownButton!"),
circle = TRUE, status = "primary", icon = icon("user-circle")
) )
}
shinyApp(ui = ui, server = server)
By dropping "sw-show" class from your dropdown menu, its context will be disappeared.
Use shinyjs::removeClass to do it.
Don't forget to add sw-content- prefix to the menu's ID.
`
library(shiny)
library(shinyjs)
library(shinyWidgets)
ui <- fluidPage(
useShinyjs(),
uiOutput('drop_down_output')
)
server <- function(input, output) {
output$drop_down_output <- renderUI({
dropdown(
inputId = 'drop_down_1',
actionButton("button", "Run!")
)
})
observeEvent(input$button,{
shinyjs::removeClass(id = 'sw-content-drop_down_1', class = 'sw-show')
})
}
shinyApp(ui = ui, server = server)
`