Add / superimpose CSS to shiny app on the fly when running the app

Question

I want to run a local shiny app, for example with shinyAppDir. I have a CSS file that I want to add to the app "on the fly". I want to avoid changing the app.R file by adding the CSS manually, but instead somehow superimpose the CSS when running shinyAppDir.

Are there any existing options or packages that have this kind of functionality? Maybe {golem}? Or would I need to read in the source file, add the needed code via regex and then run the app (which seems to be a very ugly workaround)?

Here is a minimal example:

Lets say this is my app:

library(shiny)

shinyApp(ui = fluidPage(
  sliderInput("bins", "Number of bins:", min = 1, max = 50, value = 30)
  ),
  server = function(input, output) {}
) 

And this would be the CSS file called custom.css. This CSS code should be integrated into the app when it is called:

.control-label {
   color: #ff0000;
}

I’d like to call this app with a function like shinyAppDir. Any other function that allows this kind of argument is fine as well.

shinyAppDir(
  file.path("/somepath/goeshere/"),
  options=list(
    add_css = "custom.css" # this argument does not exist 
  )
)

The result should be the same as:

library(shiny)

shinyApp(ui = fluidPage(
  
  tags$head(
    tags$style(HTML("
      .control-label {
        color: #ff0000;
      }"))
  ),
  sliderInput("bins", "Number of bins:", min = 1, max = 50, value = 30)
  ),
  server = function(input, output) { }
)

Answer 1

I found one way to do it by rewriting the shiny:::sourceUTF8 function:

# this is the function that needs to be rewritten

dressSourceUTF8 <- function (file, css_string, envir = globalenv()) {
  lines <- shiny:::readUTF8(file)
  enc <- if (any(Encoding(lines) == "UTF-8")) "UTF-8" else "unknown"
  src <- srcfilecopy(file, lines, isFile = TRUE)
  if (shiny:::isWindows() && enc == "unknown") {
    file <- tempfile()
    on.exit(unlink(file), add = TRUE)
    writeLines(lines, file)
  }
  exprs <- try(parse(file, keep.source = FALSE, srcfile = src, 
                     encoding = enc))
  
  ## this part is new ##
  if (!is.null(css_string)) {
    idx <- vapply(exprs,
                  FUN = function(x) grepl("^shinyApp", x[1], perl = TRUE),
                  FUN.VALUE = logical(1))
    
    # if ui argument is unnamed
    if (is.null((exprs[idx][[1]][["ui"]]))) {
      ui_idx <- 2
      # if named
    } else {
      ui_idx <- "ui"
    }
    
    ui_len <- length(exprs[idx][[1]][[ui_idx]])
    
    # workaround for `append` 
    for (i in seq_len(ui_len)[-1]){
    exprs[idx][[1]][[ui_idx]][[1 + i]] <- exprs[idx][[1]][[ui_idx]][[i]]
  }
  
  exprs[idx][[1]][[ui_idx]][[2]] <- bquote(tags$style(.(css_string)))
  }
  ## rest unchanged ##
  
  if (inherits(exprs, "try-error")) {
    shiny:::diagnoseCode(file)
    stop("Error sourcing ", file)
  }
  exprs <- shiny:::makeCall(`{`, exprs)
  exprs <- shiny:::makeCall(..stacktraceon.., list(exprs))
  eval(exprs, globalenv())
}

Then we need to update all functions up the tree:

dressShinyAppDir <- function(appDir, css_string = NULL, options = list()) {
  if (!utils::file_test("-d", appDir)) {
    stop("No Shiny application exists at the path \"", appDir, 
         "\"")
  }
  appDir <- normalizePath(appDir, mustWork = TRUE)
  if (shiny:::file.exists.ci(appDir, "server.R")) {
    shiny:::shinyAppDir_serverR(appDir, options = options)
  }
  else if (shiny:::file.exists.ci(appDir, "app.R")) {
    # for now this only works for shinyApp files:
    dressShinyAppDir_appR("app.R", appDir, .css_string = css_string, options = options) 
  }
  else {
    stop("App dir must contain either app.R or server.R.")
  }
}

dressShinyAppDir_appR <- function (fileName, appDir, .css_string, options = list()) {
  fullpath <- shiny:::file.path.ci(appDir, fileName)
  if (getOption("shiny.autoload.r", TRUE)) {
    sharedEnv <- new.env(parent = globalenv())
  }
  else {
    sharedEnv <- globalenv()
  }
  appObj <- shiny:::cachedFuncWithFile(appDir, fileName, case.sensitive = FALSE, 
                               function(appR) {
                                 # here the new sourceUTF8 function is added, the rest is unchanced:
                                 result <- dressSourceUTF8(fullpath, css_string = .css_string, envir = new.env(parent = sharedEnv))
                                 if (!is.shiny.appobj(result)) 
                                   stop("app.R did not return a shiny.appobj object.")
                                 shiny:::unconsumeAppOptions(result$appOptions)
                                 return(result)
                               })
  dynHttpHandler <- function(...) {
    appObj()$httpHandler(...)
  }
  dynServerFuncSource <- function(...) {
    appObj()$serverFuncSource(...)
  }
  wwwDir <- shiny:::file.path.ci(appDir, "www")
  if (shiny:::dirExists(wwwDir)) {
    staticPaths <- list(`/` = httpuv::staticPath(wwwDir, indexhtml = FALSE, 
                                         fallthrough = TRUE))
  }
  else {
    staticPaths <- list()
  }
  fallbackWWWDir <- system.file("www-dir", package = "shiny")
  oldwd <- NULL
  monitorHandle <- NULL
  onStart <- function() {
    oldwd <<- getwd()
    setwd(appDir)
    if (getOption("shiny.autoload.r", TRUE)) {
      shiny:::loadSupport(appDir, renv = sharedEnv, globalrenv = NULL)
    }
    if (!is.null(appObj()$onStart)) 
      appObj()$onStart()
    monitorHandle <<- shiny:::initAutoReloadMonitor(appDir)
    invisible()
  }
  onStop <- function() {
    setwd(oldwd)
    if (is.function(monitorHandle)) {
      monitorHandle()
      monitorHandle <<- NULL
    }
  }
  structure(list(staticPaths = staticPaths, httpHandler = shiny:::joinHandlers(c(dynHttpHandler, 
                                                                         wwwDir, fallbackWWWDir)), serverFuncSource = dynServerFuncSource, 
                 onStart = onStart, onStop = onStop, options = options), 
            class = "shiny.appobj")
}

This allows us to do the following:

dressShinyAppDir(
  file.path("/somepath/here"),
  css_string = ".control-label {color: #00ff00;}"
)

The app will be called and the CSS string in css_string will be added inline.