I am trying to render icons in my shiny dashboard based on a particular condition. Below is the code I am using to get the if else working . Since my code base is too big to share I am just posting the code for that particular portion:
output$cost_compare <-renderUI( ifelse(
last_week$cost < kpi_table$cost,
as.character(icon("angle-up")),
as.character(icon("angle-down"))
))
compareCostUI <- function(id) {
ns <- NS(id)
( uiOutput(ns("cost_compare")))
}
And I am using this in the ui inside a descriptionblock. Below is the code for it
descriptionBlock(
number = compareCostUI("pacing"))
What I am missing here due to which I can see the icon rendered
Ignore my last comment:
Using renderText is what you want to use if you are passing html strings to the UI. Returning character values in renderUI returns literal strings. Seems unintuitive.
I'm not sure if your compareCostUI function is causing any issues and I also didn't know the namespace of descriptionBlock but I made a small reproducible example of rendering an icon.
I'm also assuming that your two values last_week and kpi_table are reactive in some way? otherwise the output$cost_compare would actually never update.
ui <- shinyUI(
fluidPage(
actionButton("Press","press", icon = icon("refresh")),
uiOutput("cost_compare")
)
)
server <- function(input, output, session) {
output$cost_compare <- renderText({
if(input$Press%%2==0){
condition <- T
} else{
condition <-F
}
ifelse(condition,
as.character(icon("angle-up")), as.character(icon("angle-down")))
}
)
}
shinyApp(ui, server)
Related
I build a shiny app that need to add pieces of UI dynamically based on some parameter I'll know only in real time. I created a simplistic reconstruction of my needs, and encountered a problem I describe below
so in my example I have a module called mblock. for the sake of this example it only displays a text. the actual text to display is decided at run time, and so is the number of texts (and hence blocks) will be decided at runtime
for the specific example I set texts to be a fixed vector containing all the texts to be shown, but in reality it will be computed as a reactive object. the code is below:
library(shiny)
#block module
mblockUI = function(id) {
ns = NS(id)
fluidRow(
textOutput(ns("text"))
)
}
mblock = function(input,output,session,actual_text) {
output$text = renderText({actual_text})
}
# Define the main ui
ui <- fluidPage(
uiOutput("all_blocks"),
actionButton("submit","submit")
)
# Define server logic
server <- function(input, output) {
texts = c("aaaa","bbbb","cccc") #this is a sample vector of texts to be shown in blocks
output$all_blocks = renderUI({
for(i in 1:length(texts)) {
mname = paste0("block",i) #block name to be created (the name of the module)
#print(mname)
insertUI("#submit","beforeBegin",mblockUI(mname)) #adding the ui
#now adding the server side of each block
#also passing the text to be shown
callModule(mblock,mname,texts[i])
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
The problem is that all the blocks show the same text (the last one). and I don't understand why
any ideas how to fix the code? what do I miss
(shiny version 1.4.0)
First of all, insertUI is able to work "on its own" and doesn't need renderUI. You can put it in an observe environment instead. However, be careful of the output of insertUI since it is persistent, as explained in the documentation of this function:
Unlike renderUI(), the UI generated with insertUI() is persistent: once it's created, it stays there until removed by removeUI(). Each new call to insertUI() creates more UI objects, in addition to the ones already there (all independent from one another). To update a part of the UI (ex: an input object), you must use the appropriate render function or a customized reactive function.
I don't know why but the for loop doesn't work (as your example shows) whereas lapply does (see this answer for example).
Here's your example with these corrections:
library(shiny)
#block module
mblockUI = function(id) {
ns = NS(id)
fluidRow(
textOutput(ns("text"))
)
}
mblock = function(input,output,session,actual_text) {
output$text = renderText({actual_text})
}
# Define the main ui
ui <- fluidPage(
actionButton("submit","submit")
)
# Define server logic
server <- function(input, output) {
texts = c("aaaa","bbbb","cccc") #this is a sample vector of texts to be shown in blocks
observe({
lapply(1:length(texts), function(i) {
mname = paste0("block",i) #block name to be created (the name of the module)
#print(mname)
insertUI("#submit","beforeBegin",mblockUI(mname)) #adding the ui
#now adding the server side of each block
#also passing the text to be shown
callModule(mblock,mname,texts[i])
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am trying to write a Shiny module which shows a conditionalPanel based on input from the global UI. In the minimal example below the conditionalPanel should show a radioButtons widget when a checkbox in the global UI is clicked, but I can't get it to work.
What am I doing wrong?
library(shiny)
conditional <- function(input, output, session, check){
output$check <- reactive({check()})
outputOptions(output, "check", suspendWhenHidden = FALSE)
output$conditional <- renderUI({
ns <- session$ns
conditionalPanel(
condition = 'output.check',
radioButtons(ns('radioItem'),
'Select option',
choices = c('option 1','option 2'))
)
})
}
conditionalUI <- function(id){
ns <- NS(id)
uiOutput(ns('conditional'))
}
ui <- fluidPage(
fluidRow(checkboxInput('check','Show')),
fluidRow(conditionalUI('mymod'))
)
server <- function(input, output, session) {
check <- reactive({input$check})
callModule(conditional, 'mymod', check = check)
}
shinyApp(ui = ui, server = server)
Simple fix - The condition should be condition = input.check instead of condition = output.check.
You are having a problem with the naming conventions that shiny modules enforce.
Although you have a similar output object in your module, it is not the same as in server. If you specify an output
func <- function(input, output, session) {
output$something <- (...)
}
inside a module, that you called with
callModule(func, 'someIdentifier')
then your output id, which shiny uses to reference all the elements, becomes
someIdentifier-something
You can test this by writing uiOutput("mymod-conditional") instead of uiOutput(ns('conditional')).
Normally, this shouldn't bother you, since modules work the way that all references are resolved within a module. But the conditionalPanel condition, being in JavaScript ("on the other side" so to say), must use global references.
So the fix for your problem would be to change the condition to
condition = 'output["mymod-check"]'
Note that dashes cant be used with JavaScript dot notation, so bracket notation has to be used.
A trick that helped me identify the problem, was to inject JavaScript into the condition in order to show the current value of output on the client side. I placed condition = 'console.log(output)' inside the conditionalPanel so you can inspect the available object in the browser console.
Let's say we have a set of widgets each with their own input label. How do we create a reactive object whose value is the character that represents the input ID of the last widget that was modified?
For example, if we have
ui.R
shinyUI(fluidPage(
textInput('txt_a', 'Input Text A'),
textInput('txt_b', 'Input Text B")
))
server.R
shinyServer(function(input, output) {
last_updated_widget <- reactive({
#hypothetical code that indicates ID value of last updated widget
})
})
The desired result is as follows. If the user modifies the first text box, then the value of last_updated_widget() would be "txt_a". If they modify the second box, the value of last_updated_widget() becomes "txt_b". I'm in search of a result that extends to the obvious generalization of setting the value to be the ID of any of the widgets that was adjusted last.
I'd like this to work for an arbitrary number of widget inputs, including the case that they were generated by a renderUI() statement. So making a separate reactive() statement for each widget isn't an option. However, if the reactive statement requires a loop over all the widget names (or something like that) I can certainly work with that. And multiple reactive statements is okay, as long as it's a fixed amount, and not a function of the number of widgets.
It seems like a pretty simple problem, so I was surprised when it became a roadblock for me. I feel like the solution would be really obvious and I'm just not seeing, so if it is, I apologize for making it a new question. But any help would be greatly appreciated.
Here's a solution that works, though it looks a little awkward because of a nested observe(). I'm not sure what a better way would be, but there could be something nicer.
Basically, use an observe() to loop over all the available inputs, and for each input, use another observe() that will only trigger when that input is changed and set a variable to the id of the input.
runApp(shinyApp(
ui = shinyUI(
fluidPage(
textInput('txt_a', 'Input Text A'),
textInput('txt_b', 'Input Text B'),
uiOutput('txt_c_out'),
verbatimTextOutput("show_last")
)
),
server = function(input, output, session) {
output$txt_c_out <- renderUI({
textInput('txt_c', 'Input Text C')
})
values <- reactiveValues(
lastUpdated = NULL
)
observe({
lapply(names(input), function(x) {
observe({
input[[x]]
values$lastUpdated <- x
})
})
})
output$show_last <- renderPrint({
values$lastUpdated
})
}
))
You can use a reactive value created with reactiveValues() to store the name of the last used widget. Later use an observer to keep track of the activity of each widget and update the reactive value with the name of the last used widget.
In the folowing example, the name of the last used widget is stored in last_updated_widget$v and will active the verbatimTextOutput each time it changes. You can use last_updated_widget$v at any place in the server.
library(shiny)
runApp(list(
ui = shinyUI(
fluidPage(
textInput('txt_a', 'Input Text A'),
textInput('txt_b', 'Input Text B'),
verbatimTextOutput("showLast")
)
),
server = function(input, output, session) {
last_updated_widget <- reactiveValues( v = NULL)
observe ({
input$txt_a
last_updated_widget$v <- "txt_a"
})
observe ({
input$txt_b
last_updated_widget$v <- "txt_b"
})
output$showLast <- renderPrint({
last_updated_widget$v
})
}
))
I'm creating an web-app with Shiny in R. I have a dataset which I plot on the map. Using a checkboxGroupInput widget users are able to select categories they want to see on the map (or not). However, the dataset changes over time and not all categories are always available. To make clear which are available in the current set and which are not, I want to format the available categories as bold.
So far I've not been able to get a checkboxGroupInput widget to show with bold labels by the checkboxes. Is there a way to do that? I want some labels to be bold and others not. Also, using updateCheckboxGroupInput I'm able to change the options (i.e. show only available categories), but that not what I want/need.
I have tried for example:
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
But such an approach only displays the formatting tags as text in the user interface. Solutions using the HTML() function of Shiny doesn't seem to work either, or... I'm doing it wrong.
Any ideas?
Here is a simple Shiny interface example using the approach described above (which does not work):
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
server = function(input, output) {}
ui = fluidPage(
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
)
runApp(list(ui = ui, server = server))
The next example DOES work, but it is a solution when initializing the checkbox group. Enabling the observe function in the server part shows that the same solution does not work for updateCheckboxGroupInput. That makes sense, since that function does not return HTML code. I don't know how to access the output of that update function, or how to solve it otherwise.
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3)
server = function(input, output, session) {
# observe({
# input$test
# gsub(">", ">", gsub("<", "<", updateCheckboxGroupInput(session, "test", choices=y)))
# })
}
ui = fluidPage(
gsub(">", ">", gsub("<", "<", checkboxGroupInput(inputId="test", label="this is a test", choices=x)))
)
runApp(list(ui = ui, server = server))
For now I found a solution. Not really elegant, and probably prone to errors, but it works. I found out that the < and > characters are escaped for HTML purposes by the htmltools function called escapeHtml. By temporarily replacing that function before the updateCheckboxGroupInput is called, by a dummy function, the text is not escaped. After the updateCheckboxGroupInput is called, htmlEscape of course needs to be restored.
An example that works. After launching the app, you need to check the first box to see it work:
library("shiny")
x <- list("<b>A</b>"=1, "<b>B</b>"=2, "C"=3)
y <- list("<b>D</b>"=1, "<b>E</b>"=2, "F"=3)
server = function(input, output, session) {
observe({
value <- input$test
if (length(value) > 0 && value == 1) {
## save htmlEscape function and replace htmlEscape
saved.htmlEscape <- htmltools::htmlEscape
assignInNamespace("htmlEscape", function(x, attribute) return(x), "htmltools")
updateCheckboxGroupInput(session, "test", label="OK", choices=y)
## restore htmlEscape function
assignInNamespace("htmlEscape", saved.htmlEscape, "htmltools")
}
})
}
ui = fluidPage(
checkboxGroupInput(inputId="test", label="this is a test", choices=x)
)
runApp(list(ui = ui, server = server))
I would like to check if a textInput has been completed, and then run an operation based on this. For some reason, the following simplified code does not work. Is there something wrong ?
library(shiny)
ui <- pageWithSidebar(
headerPanel("TEST"),
sidebarPanel(
textInput('C1', "","C1")
),
mainPanel(uiOutput("value"))
)
server <- function(input,output){
output$value <- renderUI({
#input$C1
if (is.null(input$C1)){
value <- 0}
else{
value <- 1
}
})
}
runApp(list(ui=ui,server=server))
Any suggestion highly appreciated.
Cheers
The code inside renderUI must return a "tags" object, that is, a valid html. your code returns 0 or 1, neither of which is a valid return value in that context.
all you need is to enclose the return value in something that creates such code, for example, instead of
value<-0
try
h4("0")
and everything will be fine.