conditionally output different colored text in Shiny

Question

I would like Shiny to print out some different color text depending on the size of a vector. I was thinking something like:

  output$some_text <- renderText({ 
    if(length(some_vec) < 20){
      paste("This is red text")
      <somehow make it red>
    }else{
    paste("This is blue text")
      <somehow make it blue>

...but then I realized, I'm doing this in the server, not the UI.

And, as far as I know, I can't move this conditional logic into the UI.

For example, something like this won't work in the UI:

    if(length(some_vec)< 20){
         column(6, tags$div(
         HTML(paste("This text is ", tags$span(style="color:red", "red"), sep = ""))
      )}
    else{
         tags$div(HTML(paste("This text is ", tags$span(style="color:blue", "blue"), sep = ""))
)}

Does anyone have any creative ideas?

Answer 1

Came hunting for an answer to a similar question. Tried a simple approach that worked for my need. It uses inline html style, and htmlOutput.

library(shiny)

ui <- fluidPage(
 mainPanel(
 htmlOutput("some_text")
 )
)

and

server <- function(input, output) {

   output$some_text <- renderText({ 

     if(length(some_vec) < 20){
     return(paste("<span style=\"color:red\">This is red text</span>"))

     }else{
     return(paste("<span style=\"color:blue\">This is blue text</span>"))
     }
   })
 }

Conditionals run server side--it wasn't precisely clear to me from opening question that the author needed the conditional to run in UI. I didn't. Perhaps a simple way to address the issue in common situations.

Answer 2

Inspired by jenesaisquoi's answer I tried the following and it worked for me. It is reactive and requires no additional packages. In particular look at output$text3

library(shiny)

ui <- shinyUI(fluidPage(
  titlePanel("Reactive"),
  sidebarLayout(
    sidebarPanel(
      helpText("Variables!"),
      selectInput("var", 
                  label = "Choose Variable",
                  choices = c("red", "blue",
                              "green", "black"),
                  selected = "Rojo"),
      sliderInput("range", 
                  label = "Range:",
                  min = 0, max = 100, value = c(0, 100))
    ),
    mainPanel(
      textOutput("text1"),
      textOutput("text2"),
      htmlOutput("text3"),
      textOutput("text4")
    )
  )
))

server <- function(input, output) {
  output$text1 <- renderText({ 
    paste("You have selected variable:", input$var)
  })

  output$text2 <- renderText({ 
    paste("You have selected range:", paste(input$range, collapse = "-"))
  })

  output$text3 <- renderText({
    paste('<span style=\"color:', input$var, 
          '\">This is "', input$var, 
          '" written ', input$range[2], 
          ' - ', input$range[1], 
          ' = ', input$range[2] - input$range[1], 
          ' times</span>', sep = "")
  })

  output$text4 <- renderText({ 
    rep(input$var, input$range[2] - input$range[1])
  })
}

# Run the application 
shinyApp(ui = ui, server = server)

Answer 3

Here's a more flexible answer that uses shinyjs::extendShinyjs() to give R a way to produce some parameterized JavaScript code. Compared to my other answer, the advantage of this one is that the same function can be used to reactively colorize multiple numeric outputs.

library(shiny)
library(shinyjs)

jsCode <-
"shinyjs.setCol = function(params){
     var defaultParams = {
         id: null,
         color : 'red'
     };
     params = shinyjs.getParams(params, defaultParams);
     $('.shiny-text-output#' + params.id).css('color', params.color);
 }"
setColor <- function(id, val) {
    if(is.numeric(as.numeric(val)) & !is.na(as.numeric(val))) {
        cols <- c("green", "orange", "red")
        col <- cols[cut(val, breaks=c(-Inf,3.5, 6.5, Inf))]
        js$setCol(id, col)
    }
}

shinyApp(
    ui = fluidPage(
        useShinyjs(),  ## Set up shinyjs
        extendShinyjs(text = jsCode),
        numericInput("n", "Enter a number", 1, 1, 10, 1),
        "The number is: ", textOutput("n", inline=TRUE),
        br(),
        "Twice the number is: ", textOutput("n2", inline=TRUE)
        ),
    server = function(input, output) {
        output$n  <- renderText(input$n)
        output$n2 <- renderText(2 *  input$n)
        observeEvent(input$n, setColor(id = "n", val = input$n))
        observeEvent(input$n, setColor(id = "n2", val = 2 * input$n))
    })

Answer 4

It sounds like you are trying to keep it all on the client side, so you could just use a couple of conditionalPanels, which accept javascript as conditional code. For example, coloring the text in response to the current value in a numericInput box with id "len",

library(shiny)
ui <- shinyUI(
    fluidPage(
        fluidRow(
            numericInput('len', "Length", value=19),
            conditionalPanel(
                condition = "$('#len').val() > 20",
                div(style="color:red", "This is red!")),
            conditionalPanel(
                condition = "$('#len').val() <= 20",
                div(style="color:blue", "This is blue!"))
        )
    )
)

server <- function(input, output, session) {}
shinyApp(ui = ui, server=server)

You could also add an event listener to update the text with javascript. It's kinda ugly inline (and I don't know much javascript), but you could just move the script to a file in wwww/ and use includeScript. As in the previous example, the server does nothing.

ui <- shinyUI(bootstrapPage(
    numericInput('len', "Length", value=19),
    div(id="divvy", style="color:blue", "This is blue!"),
    tags$script(HTML("
        var target = $('#len')[0];
        target.addEventListener('change', function() {
            var color = target.value > 20 ? 'red' : 'blue';
            var divvy = document.getElementById('divvy');
            divvy.style.color = color;
            divvy.innerHTML = divvy.innerHTML.replace(/red|blue/g, color);
        });
    "))
))

Answer 5

Well, I have the kernel of an idea, but I'm fairly new to anything HTML/CSS/JavaScript-related, so I'm sure it could be improved quite a bit. That said, this seems to work fairly well, as far as it goes.

The key functions are removeClass() and addClass(), which are well documented in their respective help files in shinyjs:

library(shiny)
library(shinyjs)

shinyApp(
    ui = fluidPage(
        useShinyjs(),  ## Set up shinyjs
        ## Add CSS instructions for three color classes
        inlineCSS(list(.red   = "color: red",
                       .green = "color: green",
                       .blue  = "color: blue")),
        numericInput("nn", "Enter a number",
                     value=1, min=1, max=10, step=1),
        "The number is: ", span(id = "element", textOutput("nn", inline=TRUE))
        ),
    server = function(input, output) {
        output$nn <- renderText(input$nn)
        observeEvent(input$nn, {
            nn <- input$nn
            if(is.numeric(as.numeric(nn)) & !is.na(as.numeric(nn))) {
                ## Clean up any previously added color classes
                removeClass("element", "red")
                removeClass("element", "green")
                removeClass("element", "blue")
                ## Add the appropriate class
                cols <- c("blue", "green", "red")
                col <- cols[cut(nn, breaks=c(-Inf,3.5, 6.5, Inf))]
                addClass("element", col)
            } else  {}
        })
    })