R/plot_icons.R

Defines functions plot_icons

Documented in plot_icons

## 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. ------------------------------------------

Try the riskyr package in your browser

Any scripts or data that you put into this service are public.

riskyr documentation built on Aug. 15, 2022, 9:09 a.m.