# Similar to single picto but has more flexibility with text labels.
# Arguments are designed to match with PrettyNumber
#' @importFrom verbs Sum
iconsWithText <- function (x,
total.icons = NA,
image = "star",
base.image = "",
is.custom.url = FALSE,
number.rows = NA,
number.cols = NA,
width.height.ratio = 1,
layout = NA,
scale = 1,
maximum.value = NA,
hide.base.image = FALSE,
fill.direction = "fromleft",
fill.icon.color = "black",
base.icon.color = "",
background.color = "transparent", # background.fill.opacity not supported
auto.size = TRUE,
icon.width = 50,
pad.row = 0,
pad.col = 0,
margin = 0,
margin.top = margin, # not used
margin.right = margin,
margin.bottom = margin,
margin.left = margin,
global.font.family = "Arial",
global.font.color = rgb(44, 44, 44, maxColorValue = 255),
text.overlay = "",
text.overlay.halign = "center",
text.overlay.valign = "middle",
text.overlay.pad = 0.0,
test.overlap.xpad = 0.0,
text.overlay.font.family = global.font.family,
text.overlay.font.color = global.font.color,
text.overlay.font.size = 10,
text.overlay.font.weight = "normal",
text.below = "",
text.below.halign = "center",
text.below.pad = 0.0,
text.below.xpad = 0.0,
text.below.font.family = global.font.family,
text.below.font.color = global.font.color,
text.below.font.size = 10,
text.below.font.weight = "normal",
text.above = "",
text.above.halign = "center",
text.above.pad = 0.0,
text.above.xpad = 0.0,
text.above.font.family = global.font.family,
text.above.font.color = global.font.color,
text.above.font.size = 10,
text.above.font.weight = "normal",
print.config = FALSE,
x.limit = 1000,
...)
{
if (!(length(x) == 1 && x >= 0))
stop("Input data must be a single positive number\n")
if (scale <= 0 && is.na(maximum.value))
stop("Scale must be greater than zero\n")
if (isTRUE(grepl("%", attr(scale, "statistic"))))
scale <- scale/100
if (!is.na(maximum.value) && scale != 1)
warning("Parameter scale overridden by maximum value\n")
if (!is.na(total.icons) && total.icons <= 0)
stop("Total icons must be greater than zero\n")
if (!is.na(maximum.value))
{
if (maximum.value <= 0)
stop("Maximum value must be greater than zero\n")
if (maximum.value < x)
stop("Input data cannot be greater than 'Maximum value'. ",
"Change 'Display' to 'Pictograph (repeated icons)' to show more than 1 icon.\n")
if (is.na(total.icons))
total.icons <- maximum.value
scale <- maximum.value/total.icons
}
# Some parameter substitutions for R GUI Controls
if (is.custom.url)
{
fill.icon.color <- ""
base.icon.color <- ""
hide.base.image <- nchar(base.image) == 0
} else
{
image <- gsub(" ", "", tolower(image))
}
fill.direction <- gsub(" ", "", tolower(fill.direction))
if (auto.size)
icon.width <- 50
if (!is.na(total.icons) && total.icons == 1)
{
# Parameters not supplied in Pictographs - Single
layout <- "Width-to-height ratio"
pad.row <- 0
pad.col <- 0
}
if (!is.na(layout))
{
if (layout != "Width-to-height ratio")
width.height.ratio = 1
if (layout != "Number of rows")
number.rows = NA
if (layout != "Number of columns")
number.cols = NA
}
# Determine plot values
if (!is.na(x.limit) && x/scale > x.limit)
{
scale <- scale * 10^{floor(log10(x/scale)) - 1}
warning("The input value is too large to plot, and the Scale has been set to ", scale, ". Consider entering a larger Scale value in the inputs.\n")
}
x <- x/scale
if (is.na(total.icons))
total.icons <- ceiling(x)
if (length(total.icons) != 1 && total.icons > 0)
stop("The total icons must be a single numeric value and greater than zero\n")
if (!is.na(number.rows) && (number.rows <= 0 || number.rows != ceiling(number.rows)))
stop("The number of rows must be a positive integer\n")
if (!is.na(number.rows))
number.rows <- min(number.rows, total.icons)
if (!is.na(number.cols) && (number.cols <= 0 || number.cols != ceiling(number.cols)))
stop("The number of columns must be a positive integer\n")
if (!is.na(number.cols))
number.cols <- min(number.cols, total.icons)
if (width.height.ratio <= 0)
stop("The width-height ratio must be greater than zero\n")
if (icon.width <= 0)
stop("icon width must be greater than zero\n")
prop <- x/total.icons
if (prop < 0 | prop > 1)
stop("Input data must be between 0 and total icons\n")
if (round(total.icons) != total.icons)
stop("The number of total icons must be an integer\n")
# Determine layout based on which parameters are supplied
layout.str <- ""
icon.WHratio <- if (is.custom.url) getWidthHeightRatio(image) * (1 + pad.col) / (1 + pad.row)
else imageWHRatio[image] * (1 + pad.col) / (1 + pad.row)
if (!is.na(number.rows) && is.na(number.cols))
{
layout.str <- paste(",\"numRows\":", number.rows, sep="")
number.cols <- ceiling(total.icons/number.rows)
} else if (!is.na(number.cols))
{
layout.str <- paste(",\"numCols\":", number.cols, sep="")
number.rows <- ceiling(total.icons/number.cols)
} else
{
number.rows <- max(1, round(sqrt(icon.WHratio/width.height.ratio * total.icons)))
if (number.rows > total.icons)
number.rows <- total.icons
number.cols <- ceiling(total.icons/number.rows)
layout.str <- paste(",\"numRows\":", number.rows, sep="")
}
image.type <- "url"
if (image %in% c("circle", "square"))
image.type <- image
base.image.str <- ""
if (!hide.base.image)
{
if (nchar(base.icon.color) > 0)
base.icon.color <- paste(base.icon.color, ":", sep="")
base.image.url <- if (is.custom.url)
{
checkImageUrl(base.image)
base.image
}
else
imageURL[image]
base.image.str <- if (nchar(base.image.url) == 0 && is.custom.url) ""
else paste(",\"baseImage\":\"", image.type, ":", base.icon.color, base.image.url, "\"", sep="")
}
image.url <- if (is.custom.url) image else imageURL[image]
variable.image <- if (is.custom.url)
paste(image.type, ":", fill.direction, ":", image.url, sep="")
else
paste(image.type, ":", fill.direction, ":", fill.icon.color, ":", image.url, sep="")
# size of pictograph output
dim.str <- ""
icon.size.str <- ""
if (auto.size)
dim.str <- "\"rowHeights\":[\"proportion:1\"], \"colWidths\":[\"flexible:graphic\"]"
else
{
dim.str <- "\"rowHeights\":[\"fixedsize:graphic\"], \"colWidths\":[\"fixedsize:graphic\"]"
icon.size.str <- paste0(",\"imageWidth\":", icon.width)
}
# Text labels
label.overlay.str <- ""
label.above.str <- ""
label.below.str <- ""
# Adjust margins to fit text labels
# padding format: top right bottom left
pad.above.left <- pad.above.right <- pad.above.top <- pad.above.bottom <- 0
pad.below.left <- pad.below.right <- pad.below.top <- pad.below.bottom <- 0
if (any(nzchar(text.above)))
{
if (text.above.halign == "left")
pad.above.left <- text.above.xpad
if (text.above.halign == "right")
pad.above.right <- text.above.xpad
}
if (any(nzchar(text.below)))
{
if (text.below.halign == "left")
pad.below.left <- text.below.xpad
if (text.below.halign == "right")
pad.below.right <- text.below.xpad
}
margin.left <- margin.left + max(0, -pad.above.left, -pad.below.left)
margin.right <- margin.right + max(0, pad.above.right, pad.below.right)
if (any(nzchar(text.above)))
label.above.str <- sprintf(paste0(", \"table-header\":{\"padding\": \"%f %f %f %f\", ",
"\"text\":\"%s\", \"font-size\":\"%fpx\", \"font-family\":\"%s\", ",
"\"font-color\":\"%s\", \"font-weight\":\"%s\", ",
"\"horizontal-align\":\"%s\", \"vertical-align\":\"top\"}"),
margin.top + 1, margin.right - pad.above.right + 1,
max(0, text.above.pad) + 1, margin.left + pad.above.left + 1,
cleanPictographLabels(text.above), text.above.font.size, text.above.font.family,
text.above.font.color, text.above.font.weight, text.above.halign)
if (any(nzchar(text.below)))
label.below.str <- sprintf(paste0(", \"table-footer\":{\"padding\": \"%f %f %f %f\", ",
"\"text\":\"%s\", \"font-size\":\"%fpx\", \"font-family\":\"%s\", ",
"\"font-color\":\"%s\", \"font-weight\":\"%s\", ",
"\"horizontal-align\":\"%s\", \"vertical-align\":\"bottom\"}"),
max(text.below.pad, 0) + 1, margin.right - pad.below.right + 1,
margin.bottom + 1, margin.left + pad.below.left + 1,
cleanPictographLabels(text.below), text.below.font.size, text.below.font.family,
text.below.font.color, text.below.font.weight, text.below.halign)
if (any(nzchar(text.overlay)))
{
xpos <- if (text.overlay.halign == "left") 0
else if (text.overlay.halign == "right") number.cols
else number.cols/2
ypos <- if (text.overlay.valign == "top") 0
else if (text.overlay.valign == "bottom") number.rows
else number.rows/2
label.overlay.str <- sprintf(paste0(",\"floatingLabels\":[{\"position\":\"%f:%f\", ",
"\"text\":\"%s\", \"font-size\":\"%fpx\", \"font-family\":\"%s\", ",
"\"font-color\":\"%s\", \"font-weight\":\"%s\", \"horizontal-align\":\"%s\"}]"),
ypos, xpos, cleanPictographLabels(text.overlay), text.overlay.font.size, text.overlay.font.family,
text.overlay.font.color, text.overlay.font.weight, text.overlay.halign)
}
pad.around.icons <- sprintf(",\"padding\":\"%f %f %f %f\"",
margin.top, margin.right, margin.bottom, margin.left)
json.string <- paste0("{\"table\": {", dim.str,
",\"rows\":[[{\"type\":\"graphic\", \"value\":{",
"\"proportion\":", prop, pad.around.icons,
",\"numImages\":", total.icons,
label.overlay.str,
icon.size.str,
layout.str,
",\"rowGutter\":", pad.row,
",\"columnGutter\":", pad.col,
",\"variableImage\":\"", variable.image, "\"", base.image.str, "}}]]}",
label.above.str, label.below.str,
",\"background-color\":\"", background.color, "\"}")
if (print.config)
cat(json.string)
res <- graphic(json.string)
class(res) <- c(class(res), "visualization-selector")
return(res)
}
cleanPictographLabels <- function(x)
{
# New line characters were causing errors in the JSON
# Note these can be coded as \n or \r
x <- gsub("\\s", " ", x)
# Escape backslashes in labels
x <- gsub("\\", "\\\\", x, fixed = TRUE)
# These characters used to be shown as text but that is
# probably not what the user wants to see
x <- gsub(" ", " ", x)
x <- gsub('"', '\\"', x, fixed = TRUE)
return(x)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.