Shiny: Conditional format for reactive expressions (modules involved)

Question

I would like to set the format of an expression depending on the input. E.g. when it is a negative value I want it to be red. There are probably multiple ways to achieve this. I tried to create an ifelse statement in the UI part and depending on the condition I would display the value with the desired styling. However, the if-condition does not work, because I seem not be able to access the actual value (see substr(kpiModuleUI_Test("calledName")[2],1,25), what I get when I want to look inside the expression).

How can I access the reactive value in the UI? Do you know a better way than to do logical operations in the UI in order to have conditional formatting on reactive expressions?

Reproducible example Main file:

packages <- c( "data.table","ggthemes","ggExtra","grid","gridExtra","extrafont","stringi","plyr","dplyr","reshape2","shiny","shinydashboard","shinythemes","shinyjs","stats","plotly","ggplot2","lattice","cowplot","lubridate","rstudioapi","zoo")
for (i in packages){
  if (!is.element(i,installed.packages()[,1])) {
    install.packages(i,dependencies = TRUE)
  }
}
lapply(packages, require, character.only = TRUE)

# Set directory to file location
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
getwd()

source("Modules_Test_1.R")

server <- function(input,output,session) {
  val1<-reactive({input$testinput})
  callModule(kpiModule_Test,"calledName",val1)
}



header<-dashboardHeader(title = "Module Test",titleWidth = 280)

sidebar<-dashboardSidebar(width = 280,sidebarMenu(id="sidebar_tabs",
                                                  menuItem("AAA", tabName = "AAA"),
                                                  menuItem("BBB", tabName = "BBB")))


body<-dashboardBody(title="Main",
                    tabItem(tabName = "Overview",h1("Overview"),
                      fluidPage(
                      box(sliderInput(inputId = "testinput",label="testinput",min=1,max=20,value=5)),
                      box(title="KPIs",tags$p(kpiModuleUI_Test("calledName")[2],style="color:#ff5733"),br(),
                          class(kpiModuleUI_Test("calledName")[2]),br(),
                          substr(kpiModuleUI_Test("calledName")[2],1,25))
                      # ,
                      # box(title="KPIs",if(kpiModuleUI_Test("calledName")[2]>20){tags$p(kpiModuleUI_Test("calledName")[2],style="color:#ff5733")}
                      # else{tags$p(kpiModuleUI_Test("calledName")[2],style="color:#1E90FF")})
                    )                  
                    )
                    )

sdb_ui <- dashboardPage(skin = "black",
                        header,
                        sidebar,
                        body
)

shinyApp(ui = sdb_ui, server = server)

File with modules ():

kpiModule_Test <- function(input, output, session,show1) {
  output$kpi1a <- renderText({show1()})
  output$kpi1b <- renderText({(show1()+20)})
}

kpiModuleUI_Test <- function(id) {
  # Create a namespace function using the provided id
  ns <- NS(id)

  tagList(
    textOutput(ns("kpi1a"),inline=TRUE),
    textOutput(ns("kpi1b"),inline=TRUE)
  )      
}

So far I could not find this problem on Stackoverflow. The closest threads cover formatting in tables. In my real problem the reactive value is not a simple value anymore (-5$). That's why I tried to extract the first character with substr() in order to create a condition.

Your help is very much appreciated!

score 0 · Accepted Answer · answered Nov 05 '18 at 09:45

I found two ways that solve the problem, which I wanted to share. One was derived from this thread, the other from the rstudio community:

In the sample codes, both solutions work - once for testinput 1 and once for testinput 2:

coloring <- function(x) {
  testinput <- x
  if(is.numeric(as.numeric(testinput)) & !is.na(as.numeric(testinput))) {
    ## Clean up any previously added color classes
    removeClass("elementcolor", "blue")
    removeClass("elementcolor", "red")
    ## Add the appropriate class
    cols <- c("red", "blue") # Order of colors according to intervals
    col <- cols[cut(testinput, breaks=c(-Inf, -0.00001, Inf))]
    addClass("elementcolor", col)
  } else  {}
  }

server <- function(input,output,session) {

  output$testinput1<-renderText({input$testinput1})

  # observeEvent(input$testinput, setColor(id = "testinput", val = input$testinput))

  observeEvent(input$testinput1, {

    coloring(input$testinput1)

    output$testinput2<-renderUI({
      if(input$testinput2 >=0 ) { 
        a <- paste("<span style=color:#1E90FF>", input$testinput2, "-  my number is blue", "</span>")
      } else{
        a <- paste0("<span style=color:#ff5733>", input$testinput2, "-  my number is red", "</span>")
      }
      HTML(a)
    })


  })

}



header<-dashboardHeader(title = "Coloring_Test",titleWidth = 280)

sidebar<-dashboardSidebar(width = 280,sidebarMenu(id="sidebar_tabs",
                                                  menuItem("AAA", tabName = "AAA")
                                                  ))


body<-dashboardBody(title="Main",useShinyjs(),  ## Set up shinyjs
                    # extendShinyjs(text = jsCode),
                    ## Add CSS instructions for three color classes
                    inlineCSS(list(.blue   = "color: blue",
                                   .red  = "color: red")),
                      tabItem(tabName = "Overview",h1("Overview"),
                      fluidPage(
                      box(sliderInput(inputId = "testinput1",label="testinput1",min=-30,max=20,value=5)),
                      box(sliderInput(inputId = "testinput2",label="testinput2",min=-30,max=20,value=5)),
                      box(title="Output1",span(id="elementcolor",textOutput(outputId="testinput1", inline=TRUE))),
                      box(title="Output2",uiOutput("testinput2"))
{tags$p("IF",style="color:#1E90FF")}else{tags$p("ELSE",style="color:#ff5733")})  # does not work :
                    )                  
                    )
                    )

ui <- dashboardPage(skin = "black",
                        header,
                        sidebar,
                        body
)

shinyApp(ui = ui, server = server)

Thanks for everybody who tried to solve the problem.

Shiny: Conditional format for reactive expressions (modules involved)

1 Answers1