在运行应用程序时动态添加/叠加 CSS 到闪亮的应用程序

Question

我想运行一个本地闪亮的应用程序，例如shinyAppDir。我有一个 CSS 文件，我想“即时”添加到应用程序中。我想通过手动添加 CSS 来避免更改 app.R 文件，而是在运行 shinyAppDir 时以某种方式叠加 CSS。

是否有任何现有的选项或包具有这种功能？也许是{魔像}？或者我需要读入源文件，通过正则表达式添加所需的代码，然后运行应用程序（这似乎是一个非常难看的解决方法）？

这是一个最小的例子：

假设这是我的应用：

library(shiny)

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

这就是名为 custom.css 的 CSS 文件。此 CSS 代码应在调用时集成到应用程序中：

.control-label {
   color: #ff0000;
}

我想用shinyAppDir 之类的函数调用这个应用程序。任何其他允许这种参数的函数也可以。

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

结果应该是一样的：

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

我通过重写shiny:::sourceUTF8 函数找到了一种方法：

# 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())
}

然后我们需要更新树上的所有函数：

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")
}

这使我们能够做到以下几点：

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

应用程序将被调用，css_string 中的 CSS 字符串将被内联添加。