Create a gist now

Instantly share code, notes, and snippets.

@leonawicz /app.R
Last active Jun 16, 2017

What would you like to do?
Use custom local image files as icons in a Shiny Dashboard value box
#
# 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)
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 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
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment