Use custom local image files as icons in a Shiny Dashboard value box

app.R

#
# This Shiny web application demonstrates the use of custom image files
# in place of icons for value boxes in Shiny Dashboard by overriding two
# functions:
#
# 'icon' from the shiny package and 'valueBox' from the shinydashboard package.
#
# Each function adds minimal, specific additional handling of image files.
# Note: A custom css file must also be included so that value boxes can
# display the icons. For that reason, do not expect images in place of icons to
# work elsewhere in shiny or shinydashboard.

# Motivation: libraries like font awesome and glyphicon cannot be expected to
# provide a substantial suite of icons tailored to probability and statistics
# or many other subjects. Examples here use 13 custom icons for inspiration,
# which are simply tiny png files of native R plots. These png files must be
# placed in the app's www/ directory.
#

library(shiny)
library(shinydashboard)
library(purrr)

ui <- dashboardPage(
  dashboardHeader(title="Custom Icons"),
  dashboardSidebar(
    sidebarMenu(
      menuItem("Light icons", tabName = "light"),
      menuItem("Dark icons", tabName = "dark")
    ),
    div(a(href=post, "Related blog post"), style="width: 80%; padding: 15px"),
    div(a(href=gist, "Github gist"), style="width: 80%; padding: 15px")
  ),
  dashboardBody(
    tags$head( # must include css
      tags$style(HTML("
        .img-local {
        }
        
        .small-box .img-local {
        position: absolute;
        top: auto;
        bottom: 5px;
        right: 5px;
        z-index: 0;
        font-size: 70px;
        color: rgba(0, 0, 0, 0.15);
        }"
      ))
    ),
    tabItems(
      tabItem(tabName = "light",
              fluidRow(valueBoxOutput("distLight", width=3)),
              fluidRow(
                box(plotOutput("hist1"),
                    br(),
                    h4("Some random values for the bottom six value boxes showing delta change:"),
                    verbatimTextOutput("vals1"), status="primary", width=6),
                box(uiOutput("vBoxesLight"), status="primary", width=6)
              )
      ),
      tabItem(tabName = "dark",
              fluidRow(valueBoxOutput("distDark", width=3)),
              fluidRow(
                box(plotOutput("hist2"), 
                    br(),
                    h4("Some random values for the bottom six value boxes\nshowing delta change:"),
                    verbatimTextOutput("vals2"), status="primary", width=6),
                box(uiOutput("vBoxesDark"), status="primary", width=6)
              )
      )
    )
  ),
  title="Custom icons"
)

server <- function(input, output) {
  source("override.R", local = TRUE) # override 'icon' and 'valueBox'
  clrs <- c("yellow", "orange", "purple", "red", "blue", "navy",
            "light-blue", "teal", "olive", "green", "fuchsia", "maroon")
  
  pTextSize <- function(x, value) tags$p(x, style=paste0("font-size: ", value, "%;"))
  
  vbox <- function(vb){ # taglist around all 12 value boxes
    tagList(
      fluidRow(
        tags$head(tags$style(HTML(".small-box {height: 100px}"))),
        column(6, vb[[1]], vb[[5]], vb[[3]]),
        column(6, vb[[2]], vb[[6]], vb[[4]])
      ),
      fluidRow(
        column(6, vb[[7]], vb[[8]], vb[[9]]),
        column(6, vb[[10]], vb[[11]], vb[[12]])
      )
    )
  }
  
  # image files
  fileparts1 <- c(paste0("normal_", c("mean", "sd", "min", "max", "median"), "_"), "boxplot_iqr_")
  files_white <- paste0("stat_icon_", fileparts1, "white.png")
  files_black <- paste0("stat_icon_", fileparts1, "black.png")
  fileparts2 <- c(
    paste0("ts_", c("deltaDec_", "deltaInc_")), "bar_deltaNeg_",
    paste0("ts_", c("deltaPctDec_", "deltaPctInc_")), "bar_deltaPos_")
  files_white <- c(files_white, paste0("stat_icon_", fileparts2, "white.png"))
  files_black <- c(files_black, paste0("stat_icon_", fileparts2, "black.png"))
  
  # data
  set.seed(1)
  x <- rnorm(1000, 100, 10)
  del <- c(-154, 47, -81, "-12%", "114%", 60) # values for delta change example icons
  del.lab <- c("Total change", "Total change", "Max loss", "% change", "% change", "Max growth")
  val <- round(c(mean(x), sd(x), min(x), max(x), median(x)))
  val <- c(val, paste(round(quantile(x, probs = c(0.25, 0.75))), collapse=" - "), del)
  val <- map2(val, c(rep(100, 5), 75, rep(100, 6)), ~pTextSize(.x, .y))
  text <- map(c("Mean", "Std Dev", "Min", "Max", "Median", "IQR", del.lab), ~pTextSize(.x, 150))
  

  output$vBoxesLight <- renderUI({
    vb <- map(1:12, ~valueBox(
      val[[.x]], text[[.x]],
      icon=icon(list(src=files_white[.x], width="80px"), lib="local"),
      color=clrs[.x], width=NULL)
    )
    vbox(vb)
  })
  
  output$vBoxesDark <- renderUI({
    vb <- map(1:12, ~valueBox(
      val[[.x]], text[[.x]],
      icon=icon(list(src=files_black[.x], width="80px"), lib="local"),
      color=clrs[.x], width=NULL)
    )
    vbox(vb)
  })
  
  output$distLight <- renderValueBox({
    x <- "stat_icon_normal_dist_white.png"
    valueBox("Data", "light image icon color",
             icon=icon(list(src=x, width="80px"), lib="local"),
             color="black", width=NULL)
  })
  
  output$distDark <- renderValueBox({
    x <- "stat_icon_normal_dist_black.png"
    valueBox("Data", "dark image icon color",
             icon=icon(list(src=x, width="80px"), lib="local"),
             color="aqua", width=NULL)
  })
  
  output$hist1 <- renderPlot({ hist(x) })
  output$hist2 <- renderPlot({ hist(x) })
  output$vals1 <- renderText({ del })
  output$vals2 <- renderText({ del })
}

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

icons.R

library(Cairo) # better anti-aliasing
library(showtext) # required
font.add("cam", "cambriaz.TTF")
showtext.auto()

set.seed(1)
xlm <- c(-4.5, 4.5)
x <- seq(xlm[1], xlm[2], length=1000)
y <- dnorm(x)
x2 <- rnorm(500000)
x2 <- x2[x2 > xlm[1] & x2 < xlm[2]]
mar <- c(0.1, 0.1, 0.1 ,0.1)

# Code is repetetive and includes hardcoded values because each icon is uniquely tailored,
# for example, for proper text placement.
# To run accompanying Shiny app, run this script to generate the icons and place them in the app's
# www/ directory.
makeIcons <- function(primary_color="#FFFFFF", secondary_color="#FFFFFF75", color_theme="white"){
  # distribution icons
  CairoPNG(paste0("stat_icon_normal_dist_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(x, y, type="n", axes=FALSE, xlab="", ylab="", xlim=xlm)
  hist(x2, breaks=seq(xlm[1], xlm[2], by=1), freq=FALSE, add=TRUE, border=primary_color)
  lines(x, y, col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_normal_mean_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(x, y, type="n", axes=FALSE, xlab="", ylab="", xlim=xlm)
  hist(x2, breaks=seq(xlm[1], xlm[2], by=1), freq=FALSE, add=TRUE, border=secondary_color)
  lines(x, y, col=secondary_color)
  abline(v=0, lwd=3, lty=2, col=primary_color)
  legend("topright", legend=expression(bolditalic(bar(x))), bty ="n", pch=NA, cex=3,  yjust=1, adj=c(-0.5, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_normal_min_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(x, y, type="n", axes=FALSE, xlab="", ylab="", xlim=xlm)
  hist(x2, breaks=seq(xlm[1], xlm[2], by=1), freq=FALSE, add=TRUE, border=secondary_color)
  lines(x, y, col=secondary_color)
  abline(v=xlm[1], lwd=3, lty=2, col=primary_color)
  legend("topright", legend=expression(bolditalic(x[(1)])), bty ="n", pch=NA, cex=1.8, adj=c(-0.275, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_normal_max_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(x, y, type="n", axes=FALSE, xlab="", ylab="", xlim=xlm)
  hist(x2, breaks=seq(xlm[1], xlm[2], by=1), freq=FALSE, add=TRUE, border=secondary_color)
  lines(x, y, col=secondary_color)
  abline(v=xlm[2], lwd=3, lty=2, col=primary_color)
  legend("topleft", legend=expression(bolditalic(x[(n)])), bty ="n", pch=NA, cex=1.8,  adj=c(1, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_normal_median_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(x, y, type="n", axes=FALSE, xlab="", ylab="", xlim=xlm)
  hist(x2, breaks=seq(xlm[1], xlm[2], by=1), freq=FALSE, add=TRUE, border=secondary_color)
  lines(x, y, col=secondary_color)
  abline(v=0, lwd=3, lty=2, col=primary_color)
  legend("topright", legend=expression(bolditalic(tilde(x))), bty ="n", pch=NA, cex=3,  adj=c(-0.5, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_normal_sd_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(x, y, type="n", axes=FALSE, xlab="", ylab="", xlim=xlm)
  hist(x2, breaks=seq(xlm[1], xlm[2], by=1), freq=FALSE, add=TRUE, border=secondary_color)
  lines(x, y, col=secondary_color)
  abline(v=c(-1,1), lwd=3, lty=2, col=primary_color)
  legend("topright", legend=expression(bolditalic(s)), bty="n", pch=NA, cex=3, adj=c(-0.5, 0), text.col=primary_color)
  dev.off()
  
  showtext.auto(enable=FALSE)
  
  CairoPNG(paste0("stat_icon_boxplot_iqr_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  boxplot(x2, outline=FALSE, axes=FALSE, frame=FALSE,  lty=1, border=secondary_color, boxcol=primary_color)
  text(1.35, -0.05, expression("}"), cex=2, col=primary_color)
  showtext.begin()
  text(1.35, 1.5, expression("IQR"), cex=1.5, col=primary_color)
  showtext.end()
  dev.off()
  
  showtext.auto()
  
  # time series icons
  y <- scale(c(0.3,0.4,2,0.7,2,1.5,3.5,2.75,4))
  x <- scale(seq_along(y))
  
  CairoPNG(paste0("stat_icon_ts_deltaDec_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(0,0, type="n", axes=FALSE, xlab="", ylab="", xlim=range(x), ylim=range(y))
  lines(x, rev(y), lty=2, col=secondary_color)
  arrows(x[1], y[length(y)], x[length(x)], y[1], lwd=3, col=primary_color)
  legend("topright", legend=expression(bolditalic(Delta)), bty ="n", pch=NA, cex=1.8, adj=c(-0.75, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_ts_deltaInc_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(0,0, type="n", axes=FALSE, xlab="", ylab="", xlim=range(x), ylim=range(y))
  lines(x, y, lty=2, col=secondary_color)
  arrows(x[1], y[1], x[length(x)], y[length(y)], lwd=3, col=primary_color)
  legend("topleft", legend=expression(bolditalic(Delta)), bty ="n", pch=NA, cex=1.8,  adj=c(2.5, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_ts_deltaPctDec_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(0,0, type="n", axes=FALSE, xlab="", ylab="", xlim=range(x), ylim=range(y))
  lines(x, rev(y), lty=2, col=secondary_color)
  arrows(x[1], y[length(y)], x[length(x)], y[1], lwd=3, col=primary_color)
  legend("topright", legend=expression(bolditalic(symbol("\045")~Delta)), bty ="n", pch=NA, cex=1.8, adj=c(-0.25, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_ts_deltaPctInc_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  plot(0,0, type="n", axes=FALSE, xlab="", ylab="", xlim=range(x), ylim=range(y))
  lines(x, y, lty=2, col=secondary_color)
  arrows(x[1], y[1], x[length(x)], y[length(y)], lwd=3, col=primary_color)
  legend("topleft", legend=expression(bolditalic(symbol("\045")~Delta)), bty ="n", pch=NA, cex=1.8,  adj=c(0.9, 0), text.col=primary_color)
  dev.off()
  
  # bar icons
  CairoPNG(paste0("stat_icon_bar_deltaNeg_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  barplot(c(4,1), axes=FALSE, lty=1, border=primary_color, col=secondary_color)
  arrows(1.6, 4, 1.6, 1.2, lwd=3, col=primary_color)
  legend("topright", legend=expression(bolditalic(Delta)), bty ="n", pch=NA, cex=1.8, adj=c(-0.5, 0), text.col=primary_color)
  dev.off()
  
  CairoPNG(paste0("stat_icon_bar_deltaPos_", color_theme, ".png"), width=96, height=96, bg="transparent")
  par(lwd=2, mar=mar, family="cam")
  barplot(c(1,4), axes=FALSE, lty=1, border=primary_color, col=secondary_color)
  arrows(1, 1.2, 1, 4, lwd=3, col=primary_color)
  legend("topleft", legend=expression(bolditalic(Delta)), bty ="n", pch=NA, cex=1.8, adj=c(2.5, 0), text.col=primary_color)
  dev.off()
}

makeIcons()
makeIcons("black", "gray30", "black")

override.R

# override shinydashboard function
valueBox <- function (value, subtitle, icon = NULL, color = "aqua", width = 4, href = NULL){
  shinydashboard:::validateColor(color)
  if (!is.null(icon)) 
    shinydashboard:::tagAssert(icon, type = icon$name)
  if(!is.null(icon)){
    if(!icon$name %in% c("i", "img")) stop("'icon$name' must be 'i' or 'img'.")
    iconClass <- if(icon$name=="i") "icon-large" else "img"
  }
  boxContent <- div(class = paste0("small-box bg-", color), 
                    div(class = "inner", h3(value), p(subtitle)), if (!is.null(icon)) 
                      div(class = iconClass, icon))
  if (!is.null(href)) 
    boxContent <- a(href = href, boxContent)
  div(class = if (!is.null(width)) 
    paste0("col-sm-", width), boxContent)
}

# override shiny function
icon <- function (name, class = NULL, lib = "font-awesome"){
  if(lib=="local"){
    if(is.null(name$src))
      stop("If lib='local', 'name' must be a named list with a 'src' element
           and optionally 'width' (defaults to 100%).")
    if(is.null(name$width)) name$width <- "100%"
    return(tags$img(class="img img-local", src=name$src, width=name$width))
  }
  
  prefixes <- list(`font-awesome` = "fa", glyphicon = "glyphicon")
  prefix <- prefixes[[lib]]
  if (is.null(prefix)) {
    stop("Unknown font library '", lib, "' specified. Must be one of ", 
         paste0("\"", names(prefixes), "\"", collapse = ", "))
  }
  iconClass <- ""
  if (!is.null(name)) 
    iconClass <- paste0(prefix, " ", prefix, "-", name)
  if (!is.null(class)) 
    iconClass <- paste(iconClass, class)
  iconTag <- tags$i(class = iconClass)
  if (lib == "font-awesome") {
    htmltools::htmlDependencies(iconTag) <- htmltools::htmlDependency("font-awesome", 
      "4.6.3", c(href = "shared/font-awesome"), stylesheet = "css/font-awesome.min.css")
  }
  iconTag
}