everyone. I want to use two actionButtons in shiny to control the values of a project. The code is like below:
ui <- fluidPage(
actionButton(
inputId = "bt2",
label = "BT2",
styleclass = "info"
),
actionButton(
inputId = "bt1",
label = "BT1",
styleclass = "info"
),
textOutput(outputId = "test")
)
server <- function(input, output, session) {
test <- eventReactive(eventExpr = input$bt1, {
"1"
})
observeEvent(eventExpr = input$bt2, {
test <- reactive({"2"})
})
output$test <- renderText({
test()
})
}
shinyApp(ui = ui, server = server)
However, it didn't work!
Anybody can help me？
Thank your very much!!!
I added reactiveValues to help you here as you want to change it using different methods such as observeEvent
library(shiny)
ui <- fluidPage(
actionButton(
inputId = "bt2",
label = "BT2",
styleclass = "info"
),
actionButton(
inputId = "bt1",
label = "BT1",
styleclass = "info"
),
textOutput(outputId = "test")
)
server <- function(input, output, session) {
v <- reactiveValues()
observeEvent(input$bt1,{
v$test <- "1"
})
observeEvent(input$bt2, {
v$test <- "2"
})
output$test <- renderText({
v$test
})
}
shinyApp(ui = ui, server = server)
Related
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)
Any tips to solve encoding problem. I am not able to generate the up (↑) and down (↓) arrows in the code below. When running, the following warning message appears:
Warning messages:
1: unable to translate 'Maximize <U+2191>' to native encoding
2: unable to translate 'Minimize <U+2193>' to native encoding
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(
width = 6,
selectInput("maxmin", label = h5("Maximize or Minimize"),
choices = list("Maximize \u2191" = 1, "Minimize \u2193" = 2), selected = "")
)
)),
mainPanel(
))
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
You can use HTML code for the arrows and proceed like this:
library(shiny)
choicesNames <- list("Minimize", "Maximize")
choicesHTML <- list("Minimize ↓", "Maximize ↑")
choices <- setNames(choicesNames, choicesHTML)
ui <- fluidPage(
selectizeInput("select", label = "Select", choices = NULL),
textOutput("txt")
)
server <- function(input, output, session) {
updateSelectizeInput(
session, "select",
choices = choices,
options = list(render = I("
{
item: function(item, escape) { return '<div>' + item.label + '</div>'; },
option: function(item, escape) { return '<div>' + item.label + '</div>'; }
}
"))
)
output$txt <- renderText({
paste("You chose", input$select)
})
}
shinyApp(ui, server)
Another option is to use my package shinySelect and fontawesome icons for the arrows.
library(shiny)
library(shinySelect)
library(bslib)
library(fontawesome)
choices <- HTMLchoices(
labels = list(
tags$span("Minimize", fa_i("arrow-alt-circle-down")),
tags$span("Maximize", fa_i("arrow-alt-circle-up"))
),
values = list("minimize", "maximize")
)
styles <- list(
borderBottom = "5px solid orange",
color = list(selected = "lime", otherwise = "pink"),
backgroundColor = list(selected = "cyan", otherwise = "seashell")
)
ui <- fluidPage(
theme = bs_theme(version = 4),
titlePanel("shinySelect example"),
selectControlInput(
"inputid",
label = tags$h1("Make a choice", style = "color: red;"),
optionsStyles = styles,
choices = choices,
selected = "minimize",
multiple = FALSE,
animated = TRUE
),
br(),
verbatimTextOutput("textOutput")
)
server <- function(input, output, session) {
output$textOutput <- renderPrint({
sprintf("You selected: %s", input$inputid)
})
}
shinyApp(ui, server)
This is an alternate solution. Solutions provided by #Stephane Laurent are great. To translate unicode points to UTF-8, you can use chr_unserialise_unicode() from rlang package. Try this
library(shiny)
library(rlang)
ll <- chr_unserialise_unicode("<U+2193>")
uu <- chr_unserialise_unicode("<U+2191>")
choicesNames <- list(1,2)
choiceValues <- list(sprintf("Minimize %s",ll),sprintf("Maximize %s",uu))
choices <- setNames(choicesNames, choiceValues)
ui <- fluidPage(
selectInput("maxmin", label = h5("Maximize or Minimize"), choices = NULL),
textOutput("mytxt")
)
server <- function(input, output, session) {
updateSelectInput(session, "maxmin", choices = choices )
output$mytxt <- renderText({
paste("You chose", input$maxmin)
})
}
shinyApp(ui = ui, server = server)
I want to build an app in which the user can add as many as input slots as he wants. I could only build an app that let the user to add only one more input slot. Here is my code:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput("a", "Something", choices = "blah blah"),
uiOutput("b"),
actionButton(inputId = "rm", label = "-"),
actionButton(inputId = "add", label = "+"),
),
mainPanel(
textOutput("test")
)
)
)
server <- function(input, output) {
observeEvent(input$add ,{
output$b <- renderUI({
selectizeInput("b", "Another thing", choices = "blah blah")
})
})
observeEvent(input$rm ,{
output$b <- renderUI({
NULL
})
})
}
shinyApp(ui = ui, server = server)
I have no idea how I can extend this to let the user add as many as input slots as he wants. Is this even possible?
We can try this approach:
We can access new added inputs with input$a1, input$a2 ... input$ax
Edit: added an observer to see the new inputs generated in the console. The first input created after pressing + button will be called input$a1.
observe({
print(names(input))
print(input$a1)
})
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput("a", "Something", choices = "blah blah"),
actionButton(inputId = "rm", label = "-"),
actionButton(inputId = "add", label = "+"),
),
mainPanel(
textOutput("test")
)
)
)
server <- function(input, output) {
input_counter <- reactiveVal(0)
observeEvent(input$add, {
input_counter(input_counter() + 1)
insertUI(
selector = "#rm", where = "beforeBegin",
ui = div(id = paste0("selectize_div", input_counter()), selectizeInput(paste0("a", input_counter()), label = "Another thing", choices = c("bla", "blabla")))
)
})
observeEvent(input$rm, {
removeUI(
selector = paste0("#selectize_div", input_counter())
)
input_counter(input_counter() - 1)
})
observe({
print(names(input))
print(input$a1)
})
}
shinyApp(ui, 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 want to add the input text to a vector in a Shiny app every time a button is clicked. This is the example I'm working with:
library(shiny)
ui <- fluidPage(
textInput(inputId = "inquiry", label = "enter text"),
actionButton(inputId = "searchButton", label = "Run"),
verbatimTextOutput("queryList", placeholder = FALSE)
)
server <- function(input, output, session) {
queryList <- c()
observeEvent(input$searchButton, {
queryList[length(queryList)+1] <- input$inquiry
output$queryList <- renderPrint({
queryList
})
})
}
shinyApp(ui = ui, server = server)
So if "item1" is entered and the button is clicked, then "item2" is entered and the button is clicked again, queryList should look like c("item1", "item2"), but it seems to just be replacing "item1" with "item2". I'm sure I'm missing something very simple...queryList[length(queryList)+1] looks a little strange, but it works in a non-reactive environment.
Making queryList reactive fixed it for me:
library(shiny)
ui <- fluidPage(
textInput(inputId = "inquiry", label = "enter text"),
actionButton(inputId = "searchButton", label = "Run"),
verbatimTextOutput("queryList", placeholder = FALSE)
)
server <- function(input, output, session) {
queryList <- reactiveValues()
queryList$values <- c()
observeEvent(input$searchButton, {
queryList$values[length(queryList$values) + 1] <- input$inquiry
})
output$queryList <- renderPrint({
if (!is.null(queryList$values)) {
queryList$values
}
})
}
shinyApp(ui = ui, server = server)