Nothing
## plot_icons.R | riskyr
## 2022 08 09
## plot_icons: Plot a variety of icon arrays.
## -----------------------------------------------
# Preparation: -----------------------------------
# Note: The final function needs:
# - A vector of identities (colors).
# This can be obtained in different ways (e.g., calculation by respective function):
# - the vector of positions (generated according to version)
# - the number of blocks
# - the size for the icons (cex)
# Plotting symbols: -----
# Note: An icon array is equivalent to an ordered (position constrained) scatterplot.
# All variants display the population concerning some property.
# (A) 4 types:
# 1. random position, random colors (typical scatterplot)
# 2. random position, clustered colors (clustered scatterplot?)
# 3. fixed positions (sample of positions constrained), random colors (random icon array)
# 4. fixed positions, clustered colors (typical icon array)
# (B) 2 dimensions:
# 1. position
# 2. identity
# (C) Code:
## plot_icons Documentation: ----------
#' Plot an icon array of a population.
#'
#' \code{plot_icons} plots a population of which individual's
#' condition has been classified correctly or incorrectly as icons
#' from a sufficient and valid set of 3 essential probabilities
#' (\code{\link{prev}}, and
#' \code{\link{sens}} or its complement \code{\link{mirt}}, and
#' \code{\link{spec}} or its complement \code{\link{fart}})
#' or existing frequency information \code{\link{freq}}
#' and a population size of \code{\link{N}} individuals.
#'
#' If probabilities are provided, a new list of
#' natural frequencies \code{\link{freq}} is computed by \code{\link{comp_freq}}.
#' By contrast, if no probabilities are provided,
#' the values currently contained in \code{\link{freq}} are used.
#' By default, \code{\link{comp_freq}} rounds frequencies to nearest integers
#' to avoid decimal values in \code{\link{freq}}.
#'
#' @param prev The condition's prevalence \code{\link{prev}}
#' (i.e., the probability of condition being \code{TRUE}).
#'
#' @param sens The decision's sensitivity \code{\link{sens}}
#' (i.e., the conditional probability of a positive decision
#' provided that the condition is \code{TRUE}).
#' \code{sens} is optional when its complement \code{mirt} is provided.
#'
#' @param mirt The decision's miss rate \code{\link{mirt}}
#' (i.e., the conditional probability of a negative decision
#' provided that the condition is \code{TRUE}).
#' \code{mirt} is optional when its complement \code{sens} is provided.
#'
#' @param spec The decision's specificity value \code{\link{spec}}
#' (i.e., the conditional probability
#' of a negative decision provided that the condition is \code{FALSE}).
#' \code{spec} is optional when its complement \code{fart} is provided.
#'
#' @param fart The decision's false alarm rate \code{\link{fart}}
#' (i.e., the conditional probability
#' of a positive decision provided that the condition is \code{FALSE}).
#' \code{fart} is optional when its complement \code{spec} is provided.
#'
#' @param N The number of individuals in the population.
#' A suitable value of \code{\link{N}} is computed, if not provided.
#' If N is 100,000 or greater it is reduced to 10,000
#' for the array types if the frequencies allow it.
#'
#' @param sample Boolean value that determines whether frequency values
#' are sampled from \code{N}, given the probability values of
#' \code{prev}, \code{sens}, and \code{spec}.
#' Default: \code{sample = FALSE}.
#'
#' @param arr_type The icons can be arranged in different ways
#' resulting in different types of displays:
#'
#' \enumerate{
#'
#' \item \code{arr_type = "array"}: Icons are plotted in a
#' classical icon array (default).
#' Icons can be arranged in blocks using \code{block_d}.
#' The order of filling the array can be customized using
#' \code{fill_array} and \code{fill_blocks}.
#'
#' \item \code{arr_type = "shuffledarray"}: Icons are plotted in an
#' icon array, but positions are shuffled (randomized).
#' Icons can be arranged in blocks using \code{block_d}.
#' The order of filling the array can be customized using
#' \code{fill_array} and \code{fill_blocks}.
#'
#' \item \code{arr_type = "mosaic"}: Icons are ordered like in a mosaic plot.
#' The area size displays the relative proportions of their frequencies.
#'
#' \item \code{arr_type = "fillequal"}: Icons are positioned into equally sized blocks.
#' Thus, their density reflects the relative proportions of their frequencies.
#'
#' \item \code{arr_type = "fillleft"}: Icons are randomly filled from the left.
#'
#' \item \code{arr_type = "filltop"}: Icons are randomly filled from the top.
#'
#' \item \code{arr_type = "scatter"}: Icons are randomly scattered into the plot.
#'
#' }
#'
#' @param by A character code specifying a perspective to split the population into subsets,
#' with 4 options:
#'
#' \enumerate{
#' \item \code{"all"}: by condition (cd) and by decision (dc):
#'
#' \code{\link{hi}}, \code{\link{mi}}, \code{\link{fa}}, \code{\link{cr}} cases (default);
#'
#' \item \code{"cd"}: by condition (cd) only:
#'
#' \code{\link{cond_true}} vs. \code{\link{cond_false}} cases;
#'
#' \item \code{"dc"}: by decision (dc) only:
#'
#' \code{\link{dec_pos}} vs. \code{\link{dec_neg}} cases;
#'
#' \item \code{"ac"}: by accuracy (ac) only:
#'
#' \code{\link{dec_cor}} vs. \code{\link{dec_err}} cases.
#' }
#'
#' @param ident_order The order in which icon identities
#' (i.e., hi, mi, fa, and cr) are plotted.
#' Default: \code{ident_order = c("hi", "mi", "fa", "cr")}
#'
#' @param icon_types specifies the appearance of the icons as a vector.
#' Default: \code{icon_types = 11} (i.e., squares with border).
#' Accepts values from 1 to 25 (see \code{?points}).
#'
#' @param icon_size specifies the size of the icons via \code{cex}
#' Default: \code{icon_size = NULL} for automatic calculation.
#'
#' @param icon_brd_lwd specifies the border width of icons (if applicable).
#' Default: \code{icon_brd_lwd = 1.5}. Set to \code{NA} for no border.
#'
#' @param block_d The distance between blocks.
#' Default: \code{block_d = NULL} for automatic calculation;
#' (does not apply to "filleft", "filltop", and "scatter")
#'
#' @param border_d The distance of icons to the border.
#' Default: \code{border_d = 0.1}.
#'
#' Additional options for controlling the arrangement of arrays
#' (for \code{arr_type = "array"} and \code{"shuffledarray"}):
#'
#' @param block_size_row specifies how many icons should be in each block row.
#' Default: \code{block_size_row = 10}.
#'
#' @param block_size_col specifies how many icons should be in each block column.
#' Default: \code{block_size_col = 10}.
#'
#' @param nblocks_row Number of blocks per row.
#' Default: \code{nblocks_row = NULL} for automatic calculation.
#'
#' @param nblocks_col Number of blocks per column.
#' Default: \code{nblocks_col = NULL} for automatic calculation.
#'
#' @param fill_array specifies how the blocks are filled into the array.
#' Options: \code{fill_array = "left"} (default) vs. \code{"top"}.
#'
#' @param fill_blocks specifies how icons within blocks are filled.
#' Options: \code{fill_blocks = "rowwise"} (default) and \code{"colwise"}.
#'
#' Generic text and color options:
#'
#' @param lbl_txt Default label set for text elements.
#' Default: \code{lbl_txt = \link{txt}}.
#'
#' @param main Text label for main plot title.
#' Default: \code{main = txt$scen_lbl}.
#'
#' @param sub Text label for plot subtitle (on 2nd line).
#' Default: \code{sub = "type"} shows information on current plot type.
#'
#' @param title_lbl \strong{Deprecated} text label for current plot title.
#' Replaced by \code{main}.
#'
#' @param cex_lbl Scaling factor for text labels.
#' Default: \code{cex_lbl = .90}.
#'
#' @param col_pal Color palette.
#' Default: \code{col_pal = \link{pal}}.
#'
#' @param transparency Specifies the transparency for overlapping icons
#' (not for \code{arr_type = "array"} and \code{"shuffledarray"}).
#'
#' @param mar_notes Boolean option for showing margin notes.
#' Default: \code{mar_notes = FALSE}.
#'
#' @param ... Other (graphical) parameters.
#'
#' @return Nothing (NULL).
#'
#' @examples
#' # Basics:
#' plot_icons(N = 1000) # icon array with default settings (arr_type = "array")
#' plot_icons(arr_type = "shuffledarray", N = 1000) # icon array with shuffled IDs
#'
#' # Sampling:
#' plot_icons(N = 1000, prev = 1/2, sens = 2/3, spec = 6/7, sample = TRUE)
#'
#' # array types:
#' plot_icons(arr_type = "mosaic", N = 1000) # areas as in mosaic plot
#' plot_icons(arr_type = "fillequal", N = 1000) # areas of equal size (probability as density)
#' plot_icons(arr_type = "fillleft", N = 1000) # icons filled from left to right (in columns)
#' plot_icons(arr_type = "filltop", N = 1000) # icons filled from top to bottom (in rows)
#' plot_icons(arr_type = "scatter", N = 1000) # icons randomly scattered
#'
#' # by:
#' plot_icons(N = 1000, by = "all") # hi, mi, fa, cr (TP, FN, FP, TN) cases
#' plot_icons(N = 1000, by = "cd", main = "Cases by condition") # (hi + mi) vs. (fa + cr)
#' plot_icons(N = 1000, by = "dc", main = "Cases by decision") # (hi + fa) vs. (mi + cr)
#' plot_icons(N = 1000, by = "ac", main = "Cases by accuracy") # (hi + cr) vs. (fa + mi)
#'
#' # Custom icon types and colors:
#' plot_icons(N = 800, arr_type = "array", icon_types = c(21, 22, 23, 24),
#' block_d = 0.5, border_d = 0.5, col_pal = pal_vir)
#'
#' plot_icons(N = 800, arr_type = "shuffledarray", icon_types = c(21, 23, 24, 22),
#' block_d = 0.5, border_d = 0.5)
#'
#' plot_icons(N = 800, arr_type = "fillequal", icon_types = c(21, 22, 22, 21),
#' icon_brd_lwd = .5, cex = 1, cex_lbl = 1.1)
#'
#' # Text and color options:
#' plot_icons(N = 1000, prev = .5, sens = .5, spec = .5, arr_type = "shuffledarray",
#' main = "My title", sub = NA, lbl_txt = txt_TF, col_pal = pal_vir, mar_notes = TRUE)
#'
#' plot_icons(N = 1000, prev = .5, sens = .5, spec = .5, arr_type = "shuffledarray",
#' main = "Green vs. red", col_pal = pal_rgb, transparency = .5)
#'
#' @family visualization functions
#'
#' @importFrom graphics plot
#' @importFrom graphics axis
#' @importFrom graphics grid
#' @importFrom graphics points
#' @importFrom graphics text
#' @importFrom graphics title
#' @importFrom graphics mtext
#' @importFrom graphics legend
#'
#' @export
## plot_icons Definition: ----------
plot_icons <- function(prev = num$prev, # probabilities
sens = num$sens, mirt = NA,
spec = num$spec, fart = NA, # was: num$fart,
N = freq$N, # ONLY freq used
# round = TRUE, # round freq values to integers? When not rounded: n_digits = 2 (currently fixed).
sample = FALSE, # sample freq values from probabilities?
# Key option:
arr_type = "array", # needs to be specified if random position but nonrandom ident.
# valid types include: array, shuffled array, mosaic, equal, fillleft, filltop, scatter.
by = "all",
# Icon settings:
ident_order = c("hi", "mi", "fa", "cr"),
icon_types = 22, # plotting symbols; default: 22 (i.e., square with border)
icon_size = NULL, # size of icons
icon_brd_lwd = 1.5, # line width of icons
block_d = NULL, # distance between blocks (where applicable).
border_d = 0.1, # distance of icons to border.
# Classic icon arrays only:
block_size_row = 10,
block_size_col = 10,
nblocks_row = NULL,
nblocks_col = NULL,
fill_array = "left",
fill_blocks = "rowwise",
# Text and color:
lbl_txt = txt, # labels and text elements
main = txt$scen_lbl, # main title
sub = "type", # subtitle ("type" shows generic plot type info)
title_lbl = NULL, # DEPRECATED plot title, replaced by main
# type_lbls = lbl_txt[c("hi_lbl", "mi_lbl", "fa_lbl", "cr_lbl")], # 4 SDT cases/combinations
cex_lbl = .90, # size of text labels
col_pal = pal, # color palette
transparency = .50, # alpha level for icons and icon_brd_col
# icon_col = col_pal[ident_order], # use one color for each usual arr_type.
# icon_brd_col = col_pal["brd"], # border color of icons [was: grey(.10, .50)]
# Generic options:
mar_notes = FALSE, # show margin notes?
# show_accu = TRUE, # Option for showing current accuracy metrics.
# w_acc = 0.50,
... # other (graphical) parameters (passed to plot_link and plot_ftype_label)
) {
## (1) Prepare parameters: ----------
opar <- par(no.readonly = TRUE) # all par settings that can be changed.
on.exit(par(opar)) # par(opar) # restore original settings
show_legend <- TRUE # default
# show_legend <- FALSE # debugging
## (2) Define plot and margin areas: ----------
# Moved down (see "par(mar" below)!
## (3) Key options and parameters: ----------
# (a) Get current SDT case labels from lbl_txt: ----
type_lbls = lbl_txt[c("hi_lbl", "mi_lbl", "fa_lbl", "cr_lbl")] # 4 SDT cases/combinations
# Set default of by perspective:
if (!(by %in% c("all", "cd", "dc", "ac"))) {
by <- "all" # default
}
# (b) Get current colors from col_pal: ----
if (by == "all") {
icon_col <- col_pal[ident_order] # use one color for each usual arr_type.
} else if (by == "dc") {
ident_order <- c("hi", "fa", "mi", "cr") # order by (positive) decision.
icon_col <- c(col_pal["dec_pos"], col_pal["dec_pos"],
col_pal["dec_neg"], col_pal["dec_neg"])
names(icon_col) <- ident_order
if (length(unique(icon_types)) < 2) { icon_types <- c(22, 22, 23, 23) } # square vs. diamond
} else if (by == "cd") {
ident_order <- c("hi", "mi", "cr", "fa") # order by (positive) condition.
icon_col <- c(col_pal["cond_true"], col_pal["cond_true"],
col_pal["cond_false"], col_pal["cond_false"])
names(icon_col) <- ident_order
if (length(unique(icon_types)) < 2) { icon_types <- c(22, 22, 21, 21) } # square vs. circle
} else if (by == "ac") {
ident_order <- c("hi", "cr", "mi", "fa") # order by accuracy/correctness.
icon_col <- c(col_pal["dec_cor"], col_pal["dec_cor"],
col_pal["dec_err"], col_pal["dec_err"])
names(icon_col) <- ident_order
if (length(unique(icon_types)) < 2) { icon_types <- c(22, 22, 25, 25) } # square vs. downwards triangle
}
icon_brd_col <- col_pal["brd"] # border color of icons [was: grey(.10, .50)]
icon_brd_col <- make_transparent(icon_brd_col, alpha = (1 - transparency)) # OR: alpha = 2/3
## Increase robustness by anticipating and correcting common entry errors: ------
## 1. arr_type: ----
if ( !is.null(arr_type) && !is.na(arr_type) ) {
arr_type <- tolower(arr_type) # express arr_type in lowercase
}
if ( arr_type == "def" || arr_type == "default" || is.null(arr_type) || is.na(arr_type) ) { arr_type <- "array" } # default/null
if ( arr_type == "shuffled" || arr_type == "shuffle" ) { arr_type <- "shuffledarray" }
if ( arr_type == "scattered" ) { arr_type <- "scatter" }
if ( arr_type == "left" ) { arr_type <- "fillleft" }
if ( arr_type == "top" ) { arr_type <- "filltop" }
if ( arr_type == "equal" ) { arr_type <- "fillequal" }
## 2. Colors / color palettes: ----
# Set plot background color:
par(bg = col_pal[["bg"]]) # col_pal[["bg"]] / "white" / NA (for transparent background)
# (+) Detect and handle special case of color equality (e.g., pal_bwp):
if (all_equal(c(col_pal[["hi"]], col_pal[["mi"]])) && (length(unique(icon_types)) < 4)) {
if (by == "all") {
icon_types <- c(22, 25, 23, 21)
icon_col <- c("white", "grey20", "black", "grey90") # (white dark black bright)
} else { # by cd/dc/ac:
icon_types <- c(22, 22, 25, 25) # square vs. downwards triangle
icon_col <- c("white", "white", "black", "black")
names(icon_col) <- ident_order
} # by.
# icon_brd_col <- "black"
}
## 3. Plot title: ----
# Default main and subtitle labels:
if (is.null(main)) { main <- txt$scen_lbl }
if (is.na(main)) { main <- "" }
if (is.null(sub) || is.na(sub)) { sub <- "" }
## 4. Additional parameters (currently fixed): ----
xlim = c(0, 1) # xlim and ylim should currently remain fixed
ylim = c(0, 1)
cex = icon_size # if NULL, cex will be calculated on demand
# #' @param cex Size of the icons (calculated by default).
## Reconstruct logical values from arr_type:
if (arr_type %in% c("mosaic", "fillequal", "fillleft", "filltop", "scatter")) {
random.position <- TRUE
} else {
if (arr_type %in% c("array", "shuffledarray")) {
random.position <- FALSE
} else {
stop('Invalid "arr_type" argument in plot_icons. ')
}
}
if (arr_type %in% c("mosaic", "fillequal", "fillleft", "filltop", "array")) {
random.identities <- FALSE
} else {
random.identities <- TRUE
}
## A0.1: Check entered parameters for plausibility ------
# Check whether random.position and random.identities are logical:
if ( !(is.logical(random.position) | is.logical(random.identities)) ) {
stop("random.position and random.identities must be logical!")
}
## A0.2: Check entered parameters for usabililty ------
# TODO: Either check for missing N or use other comparison.
## A0.3: Different routes to col_vec and pch.vec ------
## A0.3.1: Calculation from probabilities ------
## (A) If a valid set of probabilities was provided:
if (is_valid_prob_set(prev = prev, sens = sens, mirt = mirt,
spec = spec, fart = fart, tol = .01)) {
# (a) Compute the complete quintet of probabilities:
prob_quintet <- comp_complete_prob_set(prev, sens, mirt, spec, fart)
sens <- prob_quintet[2] # gets sens (if not provided)
mirt <- prob_quintet[3] # gets mirt (if not provided)
spec <- prob_quintet[4] # gets spec (if not provided)
fart <- prob_quintet[5] # gets fart (if not provided)
# (b) Compute cur_freq and popu based on current parameters (N and probabilities):
cur_freq <- comp_freq(prev = prev, sens = sens, spec = spec, N = N,
round = TRUE, sample = sample) # key freq (with round = TRUE).
} else { # A0.3.2: Using existing frequencies:
cur_freq <- freq
} # if (is_valid_prob_set(etc.
# Check size of N. Is scaling needed? Scale down if greater than 100.000:
## Specify N:
N <- cur_freq$N
ind_lbl <- ""
if (N >= 100000) {
# get the minimal N:
min_N <- riskyr::comp_min_N(prev = prev, sens = sens, spec = spec)
if (min_N <= 10000) { # only, if 10.000 icons are sufficient:
exponent <- ((N %/% 100000) %/% 10) + 1 # get exponent dependent on size.
ind_per_icon <- 10 ^ exponent # individuals per icon.
# ind_lbl <- paste0("Icons have been scaled: Each icon represents ", ind_per_icon, " individuals.")
ind_lbl <- paste0("Each icon represents ", ind_per_icon, " individuals.")
N <- N / (10^exponent)
cur_freq <- lapply(cur_freq, function(x) {x / (10^exponent)}) # adjust cur_freq and N.
}
} # if (N >= 100000) etc.
# DO SOME CHECKS HERE!?
## Determine order:
if (is.null(names(icon_col))) {
names(icon_col) <- ident_order
}
if (is.null(names(icon_types))) {
if (length(icon_types) < length(icon_col)) {
if (length(icon_types) > 1) {warning("Icon types are recycled to number of colors.")}
icon_types <- rep(icon_types, length.out = length(icon_col))
}
names(icon_types) <- names(icon_col)
}
## (c) Compute icon_col from frequencies:
col_vec <- rep(icon_col[ident_order], times = cur_freq[ident_order])
## (d) Compute pch.vec from frequencies:
pch.vec <- rep(icon_types[ident_order], times = cur_freq[ident_order])
## A1 Random position, random colors ------
if (random.position & random.identities) {
# 1) Define positions:
# 1a) draw random positions within plot dimensions:
posx_vec <- runif(n = N, min = xlim[1], max = xlim[2])
posy_vec <- runif(n = N, min = ylim[1], max = ylim[2])
# 2) Randomize vectors:
rand_ix <- sample(1:length(col_vec), replace = FALSE) # create random vector.
col_vec <- col_vec[rand_ix] # randomize colors and
if (length(pch.vec) == length(posx_vec)) {
pch.vec <- pch.vec[rand_ix] # characters accordingy.
} else {
pch.vec <- pch.vec[1]
warning("pch.vec was not of length N. Only first element used. ")
}
} # end A1: (random position & random colors)
## A2 Random position, clustered colors ------
if (random.position & !random.identities) {
# 1b) sort dependent on parameter:
# options:
# right: from left to right, top: from top to bottom,
# equal: in equal spaces of the plot, mosaic: relative to area.
if (arr_type %in% c("fillleft", "filltop")) {
# 1a) draw random positions:
posx_vec <- runif(n = N, min = xlim[1], max = xlim[2])
posy_vec <- runif(n = N, min = ylim[1], max = ylim[2])
# Then sort one of the vectors accordingly (presupposes ordered color vector).
# arr_type: from left to right:
if (arr_type == "fillleft") {
posx_vec <- sort(posx_vec)
}
# arr_type: from top to bottom:
if(arr_type == "filltop"){
posy_vec <- sort(posy_vec)
}
} else { # if in equal or mosaic:
# Initialize positions:
posx_vec <- NULL
posy_vec <- NULL
# create n = "ident_type" compartments of the plot:
block_n <- length(unique(col_vec)) # number of blocks for x and y.
# TODO: not final; they should be distributed.
## message(paste0("Note: block_n = ", block_n))
##
## Note: Potential source of error for
## plot_icons(by = "cd", arr_type = "mosaic") ???
# calculate number of observations in each block retaining original order:
type_n <- sapply(unique(col_vec), function(x) sum(col_vec == x))
# equal compartments:
if (arr_type == "fillequal") { # density varies, area is constant.
if (is.null(block_d)) {
block_d <- 0.05
}
# determine breakpoints:
# !!!Currently for square numbers only:
# TODO: include non-square points (e.g., by enlarging the plot area).
block_sq <- sqrt(block_n) # take square root.
# create list of breakpoints including color types:
seq_min <- (0:(block_sq - 1)) / block_sq # of minimal coordinates.
seq_max <- (1:block_sq) / block_sq
min_ranges <- expand.grid(x_min = seq_min, y_min = seq_min) # all combinations of minima.
max_ranges <- expand.grid(x_max = seq_max, y_max = seq_max) # all combinations of maxima.
# add distance between icon blocks:
global_min <- min(min_ranges) # get global minimum of minima.
global_max <- max(max_ranges) # get global maximum of maxima.
min_ranges[min_ranges != global_min] <- min_ranges[min_ranges != global_min] + block_d
# we don't want distance at the global minima nad maxima.
max_ranges[max_ranges != global_max] <- max_ranges[max_ranges != global_max] - block_d
# TODO: flipping by swapping x and y or by changing vector of frequencies?
# TODO: Bind ranges into one object?
# TODO: notice the overlap! Use cut?
# sample the coordinates from the deterimined ranges:
for(i in 1:nrow(min_ranges)){ # TODO: avoid for-loop!
minx <- min_ranges$x_min[i]
maxx <- max_ranges$x_max[i]
miny <- min_ranges$y_min[i]
maxy <- max_ranges$y_max[i]
# TODO: This only holds for equal compartments.
# sample vectors from compartments:
posx_vec_i <- runif(n = type_n[i], min = minx, max = maxx)
posy_vec_i <- runif(n = type_n[i], min = miny, max = maxy)
posx_vec <- c(posx_vec, posx_vec_i)
posy_vec <- c(posy_vec, posy_vec_i)
}
}
# mosaic style:
if (arr_type == "mosaic") {
block_prop <- type_n / sum(type_n) # proportion in each compartment.
prev <- block_prop[1] + block_prop[2] # TODO: Does this still hold for switched types?
# define boundaries:
b1 <- block_prop[1] / (block_prop[1] + block_prop[2])
b2 <- block_prop [4] / (block_prop[4] + block_prop[3])
# TODO: This depends on our typical order! Might be made more transparent and customizable.
# Quadrant dimensions (with prevalence in y-direction):
block1 <- c(0, b1, 0, prev)
block2 <- c(b1, 1, 0, prev)
block3 <- c(b2, 1, prev, 1)
block4 <- c(0, b2, prev, 1)
# TODO: Allow to shuffle components around (using a list?).
# TODO: not general yet! How to make it general? Calculation of area proportions?
# bind vectors together.
blocks <- rbind(block1, block2, block3, block4)
# set distance parameter:
# block_d may not be half the size of the distance between min and max.
# for the example of prevalence == 0.15 it may not exceed 0.075.
diff_dx <- apply(X = blocks[, c(1, 2)], MARGIN = 1, FUN = diff)
diff_dy <- apply(X = blocks[, c(3, 4)], MARGIN = 1, FUN = diff)
boundary_d <- min(c(abs(diff_dx), abs(diff_dy))) / 2
if (is.null(block_d)){
block_d <- 0.01 # a little messy though...
}
if ( block_d >= boundary_d ) {
block_d <- boundary_d - 0.0001 # a little messy though...
}
blocks[, c(1, 3)] <- blocks[, c(1, 3)] + block_d
blocks[, c(2, 4)] <- blocks[, c(2, 4)] - block_d
block_n <- sapply(unique(col_vec), function(x) sum(col_vec == x))
# calculate number of observations in each compartment.
blocks <- cbind(blocks, block_n) # bind to matrix.
for(i in 1:nrow(blocks)){
minx <- blocks[i, 1]
maxx <- blocks[i, 2]
miny <- blocks[i, 3]
maxy <- blocks[i, 4]
# TODO: This only holds for equal blocks.
# sample vectors from blocks:
posx_vec_i <- runif(n = blocks[i, 5], min = minx, max = maxx)
posy_vec_i <- runif(n = blocks[i, 5], min = miny, max = maxy)
posx_vec <- c(posx_vec, posx_vec_i)
posy_vec <- c(posy_vec, posy_vec_i)
}
}
}
} # end: valid arr_type
# end A2: (random.position & !random.identities)
if (random.position) {
if (is.null(cex)) {
# TODO: How to covary cex with device size & point number?
cex1 <- ((par("pin")[1] * 10) + 3) / sqrt(length(posx_vec)) # ad hoc formula.
cex2 <- ((par("pin")[2] * 10) + 3) / sqrt(length(posx_vec)) # ad hoc formula.
cex <- min(c(cex1, cex2))
}
} # end (random.position)
## A3 and A4: Fixed positions ----------
if (!random.position) {
# 0. Check arrangement parameters ------
if (is.null(block_d)) {
block_d <- 0.4 # set to a default value.
}
transparency <- NULL # set transparency to zero.
#given:
# block_size_row
# block_size_col
# calculate icons per block:
icons_per_block <- block_size_row * block_size_col
# If no number of blocks or cols is given:
if (is.null(nblocks_row) & is.null(nblocks_col)) {
# calculate number of blocks required:
n_blocks <- ceiling(N / icons_per_block)
blocking_dim <- factors_min_diff(n_blocks) # get the dimensions.
# dependent on pin:
dim_in <- par("pin") # get dimensions of plotting region.
if( dim_in[1] >= dim_in[2] ) { # if x greater y:
nblocks_row <- blocking_dim[2] # larger in x dimension (cols).
nblocks_col <- blocking_dim[1] # smaller in y dimension (rows).
} else {
nblocks_row <- blocking_dim[1] # smaller in x dimension (cols).
nblocks_col <- blocking_dim[2] # larger in y dimension (rows).
}
} else { # if at least one of both is given:
# TODO: Provide some testing, whether given numbers of blocks are valid!
test_N <- nblocks_row * nblocks_col * icons_per_block
if ( test_N < N) {
stop("The number of blocks and columns is too small to accomodate the population.")
}
if (is.null(nblocks_row)) { # if nblocks_row is not given:
nblocks_row <- n_blocks / nblocks_col # calculate number of blocks per row.
}
if (is.null(nblocks_col)) { # if ncol_rows is not given:
nblocks_col <- n_blocks / nblocks_row # calculate number of blocks per column.
# TODO: Change naming scheme!
}
# calculate number of blocks required:
n_blocks <- nblocks_row * nblocks_col
}
# calculate total ncols and nrows:
ncols <- block_size_row * nblocks_row
nrows <- block_size_col * nblocks_col
# Given a default of 10x10 blocks:
#N / (block_size_row * block_size_col)
# 1. Define positions:
# find maximum for the positions given the units icons are moved:
# find a monotonically increasing sequence, resulting in exactly the endpoint of xlim/ylim.
# For x:
max_posx <- ((ncols - 1) * xlim[2]) - (block_d * (nblocks_row - 1)) - border_d
min_posx <- xlim[1] + border_d
adj_posx <- seq(min_posx, max_posx, length.out = ncols)
# For y:
max_posy <- ((nrows - 1) * ylim[2]) - (block_d * (nblocks_col - 1)) - border_d
min_posy <- ylim[1] + border_d
adj_posy <- seq(max_posy, min_posy, length.out = nrows)
# create position matrices:
pos_mx <- matrix(adj_posx, nrow = nrows, ncol = ncols, byrow = TRUE)
pos_my <- matrix(adj_posy, nrow = nrows, ncol = ncols)
# add a sequence to the x matrix:
# For x:
seqx_off <- seq(0, (nblocks_row - 1) * block_d, by = block_d)
# get the sequence of offsets for icons in each block.
seqx <- rep(seqx_off, each = block_size_row)
# repeat this sequence by block size so every icon is affected.
pos_mx <- pos_mx + rep(seqx, each = nrow(pos_mx))
# do so for every row in the matrix.
# For y:
seqy_off <- seq((nblocks_col - 1) * block_d, 0, by = -block_d) # create sequence of number to add.
seqy <- rep(seqy_off, each = block_size_col) # repeat to number of rows.
pos_my <- pos_my + seqy # will be repeated for each column anyways.
# Plotting preparations: ------
# save into respective vectors and norm on 0,1 space.
posx_vec <- pos_mx / (ncols - 1)
posy_vec <- pos_my / (nrows - 1)
## TODO: Not in region anymore --> change plot dimensions or decrease standard distance.
## Plotting dimensions for testing:
# plotx_dim <- c(-0.1, 1.1)
# ploty_dim <- c(-0.1, 1.1)
if (!random.identities) { # sort colors according to input.
## For A4 (fixed positions and clustered identities) only:
## 2. Color sorting:
## Create block information:
seq_block <- 1:n_blocks # create sequence of block positions.
## Determine, whether blocks are used colwise or rowwise:
# fill_array <- "left" # alternatively: "rowwise"
## If blocks are to be filled in x direction:
if (fill_array == "left"){
seq_blockx <- rep(seq_block, each = block_size_row)
# create sequence repeted to the number of cols (can be changed to number of rows).
mat_block <- matrix(seq_blockx, ncol = ncols, byrow = TRUE)
# create a matrix from it.
ind_block <- rep(1:nrow(mat_block), each = block_size_col) # create index to repeat matrix.
mat_block <- mat_block[ind_block, ]
# repeat each row of the matrix to the number of rows.
}
## If blocks are to be filled in y direction:
if (fill_array == "top"){
seq_blocky <- rep(seq_block, each = block_size_col)
# create sequence repeted to the number of cols (can be changed to number of rows).
mat_block <- matrix(seq_blocky, nrow = nrows, byrow = FALSE)
# create a matrix from it.
ind_block <- rep(1:ncol(mat_block), each = block_size_row) # create index to repeat matrix.
mat_block <- mat_block[ , ind_block]
# repeat each row of the matrix to the number of columns.
}
## Determine, whether blocks (within) are filled col- or rowwise:
# fill_blocks <- "colwise"
## Sort colors accordingly:
## TODO: Find out WHY ON EARTH order(order()) works!
if (fill_blocks == "rowwise"){
order_mat <- order(order(t(mat_block))) # matrix has to be transposed to get the rows.
m <- matrix(order_mat, nrow = nrows, ncol = ncols, byrow = TRUE) # This is the "rowwise witin blocks" version.
# if (fill_array == "top") { m <- t(m) }
}
if (fill_blocks == "colwise") {
order_mat <- order(order(mat_block))
m <- matrix(order_mat, nrow = nrows, ncol = ncols, byrow = FALSE) # This is the "colwise within blocks" version.
# if (fill_array == "top") { m <- t(m) }
}
## If the color vector already has the appropriate length:
if (length(col_vec) == length(m)) {
col_vec <- col_vec[m] # order the color vector.
}
if (length(pch.vec) == length(m)) {
pch.vec <- pch.vec[m] # order the character vector.
}
## If the color vector is too short:
## TODO: what to do if too long?
if (length(col_vec) < length(m)) {
len_diff <- length(pos_mx) - length(col_vec) # calculate difference.
col_vec <- c(col_vec, rep(NA, len_diff)) # enlarge the color vector.
col_vec <- col_vec[m] # order this color vector.
## Mute the respective positions:
posx_vec[is.na(col_vec)] <- NA # set NA x positions...
posy_vec[is.na(col_vec)] <- NA # ... and y positions.
}
if (length(pch.vec) < length(m) & length(pch.vec) > 1) {
len_diff <- length(pos_mx) - length(pch.vec) # calculate difference.
pch.vec <- c(pch.vec, rep(NA, len_diff)) # enlarge the color vector.
## Mute the respective positions:
pch.vec <- pch.vec[m] # order character vector.
posx_vec[is.na(pch.vec)] <- NA # set NA x positions...
posy_vec[is.na(pch.vec)] <- NA # ... and y positions.
}
} # end fixed identities (A4).
## For A3:
if (random.identities) {
rand_ix <- sample(1:length(col_vec), replace = FALSE) # random index.
col_vec <- col_vec[rand_ix] # sample from the vector of colors.
if (length(pch.vec) > 1) {
pch.vec <- pch.vec[rand_ix] # analog sample from character vector.
}
## If the color vector is too short.
if (length(col_vec) < (ncols * nrows) & length(col_vec) > 1) {
## for colors:
len_diff <- (ncols * nrows) - length(col_vec)
if (length(icon_brd_col) > 1) {
icon_brd_col <- c(icon_brd_col, rep(NA, len_diff))
}
col_vec <- c(col_vec, rep(NA, len_diff))
}
## If the character vector is too short:
if (length(pch.vec) < (ncols * nrows) & length(pch.vec) > 1) {
## for colors:
len_diff <- (ncols * nrows) - length(pch.vec)
pch.vec <- c(pch.vec, rep(NA, len_diff))
}
} # end random identities (A3).
## Adjust cex dynamically:
if (is.null(cex)) {
## TODO: How to covary cex with device size & point number?
cex1 <- ((par("pin")[1] * 10) + 3) / ncols
cex2 <- ((par("pin")[2] * 10) + 3) / nrows
cex <- min(c(cex1, cex2))
# still not optimal...
# cex <- 1.5 - (min(par("pin")) / N) # this latter term likely plays some role...
}
} # end A3 and A4 (fixed positions).
## B. Plotting ----------
## TODO: Add text!
if (any(!pch.vec %in% c(NA, 21:25))) {# if any symbol is NOT in the set of symbols with a border:
icon_brd_col <- col_vec # use fill color for border color
}
if (is.na(icon_brd_lwd) | (icon_brd_lwd == 0)){# if border color is set to NA or 0:
icon_brd_col <- col_vec # use fill color for border color
icon_brd_lwd <- 1 # (to keep original symbol size)
}
## Plot setup: ------
## (a) Define margin areas: ----
# Beware: Values DIFFER from those in other plot_ functions:
if (nchar(main) > 0 | nchar(sub) > 0) { n_lines_top <- 3 } else { n_lines_top <- 1 }
if (mar_notes) { n_lines_bot <- 3 } else { n_lines_bot <- 0 }
# Accomodate legend:
if (show_legend){ n_lines_bot <- n_lines_bot + 2 }
par(mar = c(n_lines_bot, 1, n_lines_top, 1) + 0.1) # margins; default: par("mar") = 5.1 4.1 4.1 2.1.
par(oma = c(0, 0, 0, 0) + 0.1) # outer margins; default: par("oma") = 0 0 0 0.
## (b) Plot setup: ----
plot(x = 1,
xlim = xlim, ylim = ylim,
type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n",
bty = "o", fg = "grey")
## 3a) Set plotting character:
# pch <- 22 # filled square as default.
# cex <- 0.5
if (!is.null(transparency)) {
col_vec <- adjustcolor(col_vec, alpha.f = (1 - transparency))
}
## Additional information:
points(x = posx_vec, y = posy_vec, # positions.
## visual details:
pch = pch.vec, col = icon_brd_col, bg = col_vec, lwd = icon_brd_lwd, cex = cex)
## Legend: -----
if (show_legend){
if (sum(nchar(type_lbls)) > 0) {
# reorder labels:
names(type_lbls) <- c("hi", "mi", "fa", "cr")
type_lbls <- type_lbls[ident_order]
}
if(by == "all") {
legend_col <- icon_col
legend_ico <- icon_types
legend_lbls <- type_lbls
} else {
legend_col <- icon_col[c(1, 3)]
legend_ico <- icon_types[c(1, 3)]
if (by == "dc") {
legend_lbls <- c(txt$dec_pos_lbl, txt$dec_neg_lbl)
}
if (by == "cd") {
legend_lbls <- c(txt$cond_true_lbl, txt$cond_false_lbl)
}
if (by == "ac") {
legend_lbls <- c(txt$dec_cor_lbl, txt$dec_err_lbl)
}
}
legend(x = xlim[2] / 2, y = ylim[1] - (ylim[2] / 20),
legend = legend_lbls,
horiz = TRUE, bty = "n",
pt.bg = legend_col, pch = legend_ico,
cex = cex_lbl, xjust = 0.5, xpd = TRUE)
## TODO: fixed order of legend?
}
## Title: -----
# Main title: Handle deprecated "title_lbl" argument: ----
if (is.null(title_lbl) == FALSE){
message("Argument 'title_lbl' is deprecated. Please use 'main' instead.")
main <- title_lbl
}
# Subtitle (2nd line): ----
if (sub == "type"){ # show default plot type info:
sub <- paste0(lbl["plot_icons_lbl"]) # , "(N = ", N, ")") # plot name: icon array / waffle plot / Zahlengitter.
}
# Combine title + subtitle: ----
if ( (main != "") & (sub == "") ){ # only main title:
cur_title_lbl <- main
} else if ( (main == "") & (sub != "") ){ # only subtitle:
cur_title_lbl <- sub
} else { # combine both:
cur_title_lbl <- paste0(main, ":\n", sub) # add ":" and line break
}
# Plot title: ----
# Beware: Values DIFFER from those in other plot_ functions:
title(cur_title_lbl, adj = 0, line = 1, font.main = 1, cex.main = 1.2) # (left, HERE: raised (by +1), normal font)
## Margins: ------
if (mar_notes) {
# Determine current probabilities cur_prob:
cur_prob <- comp_prob(prev = prev, sens = sens, spec = spec)
# Note:
note_lbl <- "" # initialize
if (ind_lbl != "") {
note_lbl <- ind_lbl
}
plot_mar(show_freq = TRUE, show_cond = TRUE, show_dec = TRUE,
show_accu = TRUE, accu_from_freq = FALSE, # TRUE,
note = note_lbl,
cur_freq = cur_freq, cur_prob = cur_prob, lbl_txt = lbl_txt)
} # if (mar_notes)
## Finish: ---------
# on.exit(par(opar)) # par(opar) # restore original settings
invisible() # restores par(opar)
} # plot_icons().
## Check: -------
# plot_icons() # => plots icon array for default population (with default arr_type = "array")
# plot_icons(arr_type = "shuffledarray") # => icon array with shuffled IDs
#
# plot_icons(icon_types = c(21, 23, 24, 23),
# block_size_row = 5, block_size_col = 5, #nblocks_row = 2, nblocks_col = 2,
# block_d = 0.5, border_d = 0.9)
# plot_icons(arr_type = "mosaic", N = 1000) # => areas as in mosaic plot
# plot_icons(arr_type = "fillequal", N = 1000) # => areas of equal size (density reflects probability)
# plot_icons(arr_type = "fillleft", N = 1000) # => icons filled from left to right (in columns)
# plot_icons(arr_type = "filltop", N = 1000) # => icons filled from top to bottom (in rows)
#
# plot_icons(arr_type = "scatter", N = 1000) # => icons randomly scattered.
# plot_icons(N = 1250, sens = 0.9, spec = 0.9, prev = 0.9,
# icon_types = c(21,23,24,23),
# block_size_row = 10, block_size_col = 5,
# nblocks_row = 5, nblocks_col = 5,
# block_d = 0.8,
# border_d = 0.2,
# fill_array = "top")
# # pretty variants:
# plot_icons(N = 800, arr_type = "array", icon_types = c(21,22,23,24),
# block_d = 0.5, border_d = 0.5)
#
# plot_icons(N = 800, arr_type = "shuffledarray", icon_types = c(21,23,24,22),
# block_d = 0.5, border_d = 0.5)
#
# plot_icons(N = 800, arr_type = "shuffledarray", icon_types = c(21,23,24,22),
# icon_brd_col = grey(.33, .99), icon_brd_lwd = 3)
#
# plot_icons(N = 800, arr_type = "fillequal", icon_types = c(21,22,22,21),
# icon_brd_lwd = .5, cex = 2)
## (*) Done: ----------
## - etc.
## (+) ToDo: ----------
## - Add by = "cd", "dc", "ac" arguments (default: "cddc").
## - Provide area = "icons" functionality to other plots.
## - Show as 4 distinct clusters (rectangles?) of icons.
## - Hybrid plots: Combine icons with fnet/ftree/prism.
## - Add borders to left and top type of sorting.
## - More modular: Different plot types as separate (sub-)functions?
## - Understand cex: how does it work, when does it (not) change size?
## - Check out the R package personograph
## at https://CRAN.R-project.org/package=personograph
## eof. ------------------------------------------
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.