In raredd/plotr: More plotting functions and examples

library('plotr')
library('knitr')

knitr::opts_chunk$set(
  fig.align = 'center', fig.path = 'inst/etc/', fig.width = 8
)

plotr

miscellaneous plots and things

---

Installation

# install.packages('devtools')
devtools::install_github('raredd/plotr')

these are actually useful

barplot2

## with arrays
barplot2(with(mtcars, table(cyl, gear, vs)))

set.seed(1)
x <- array(runif(4 * 3 * 3), c(4, 3, 3))
barplot2(x)

## group labels
barplot2(x, names.arg = list(A = 1:3, B = 4:6, C = 7:9))

bp <- barplot2(x)
mtext(1:9, side = 1L, at = bp$at, line = 1)
mtext(1:3, side = 1L, at = bp$group, line = 3)

## simplified space argument
barplot2(
  x, space = c(0.1, 1, 2) / 2, las = 1L, col = 1:4,
  legend.text = sprintf('Factor %s', 1:4),
  args.legend = list(horiz = TRUE, bty = 'n'),
  names.arg = list(A = 1:3, B = 4:6, C = 7:9)
)

## missing arguments from plot.default
barplot2(1:5, panel.first = {grid(0, NULL); abline(h = 4, col = 2)})

methods for tsne, pca, umap

## feature x sample matrix
dat <- t(unique(iris[, 1:4]))
grp <- unique(iris)$Species

l <- list(
  tsne = dimr(dat, type = 'tsne'),
  umap = dimr(dat, type = 'umap'),
  pca  = dimr(dat, type = 'pca'),
  rpca = dimr(dat, type = 'rpca')
)

op <- par(mfrow = c(2, 2), mar = c(4, 5, 2, 1))
for (x in l)
  plot(x)
par(op)

plot(l$tsne, group2 = as.list(data.frame(t(dat))))

n <- 9
d <- as.list(mtcars[, rep_len(c('mpg', 'wt', 'hp'), n)])
par(mfrow = n2mfrow(n), oma = c(5, 5, 4, 2))
plotr:::gridplot(d, mtcars$mpg, mtcars$wt, legend = TRUE)
title(xlab = 'MPG', ylab = 'Weight', outer = TRUE, cex.lab = 2)

loess_smooth

par(mfrow = c(2, 2), mar = c(4, 5, 2, 2))

plot(mpg ~ wt, mtcars)
lo <- loess_smooth(mpg ~ wt, mtcars)
lines(lo$x, lo$y)
lines(lo$x, lo$upper, lty = 2)
lines(lo$x, lo$lower, lty = 2)

plot(lo)
plot(lo, ci = 'lines', col.line = 'red')
plot(lo, ci = 'band', col.ci = 'grey90')

tableplot

plot(mpg ~ wt, mtcars)
tableplot(
  'topright', table = head(mtcars, 3),
  title = 'mtcars data set', cex.title = 2
)
tableplot(
  par('usr')[1], 35, head(mtcars, 3)[, 1:3],
  show.rownames = TRUE, col.rownames = 'red',
  font.colnames = 2, hlines = TRUE
)

scattergram

with(mtcars, {
  scattergram(mpg, wt, cyl, col = rainbow(3), pch = 16)
})

ggplot-style base plots

gplot(1:10, col = ggcols(10), pch = 16, cex = 5)

gmatplot(1:10, matrix(rnorm(100), 10), type = 'l', col = ggcols(10))

see all:

grep('^g[^g]', ls('package:plotr'), value = TRUE)

Some useful and not-so-useful plots and tools

shist

set.seed(1)
x <- lapply(sample(1:10, 4), rpois, n = 500)
shist(x)

propfall

dat <- within(mtcars, {
  disp <- disp / 10
  wt <- wt * 10
})[, c('mpg', 'disp', 'wt')]

dat[] <- t(apply(dat, 1L, function(x) x / sum(x)))

propfall(dat)
propfall(dat, group = colnames(dat)[max.col(dat)],
         col = c('grey', 'lightpink', 'indianred1'))

bibar

set.seed(1)
x <- datasets::ability.cov$cov
x <- x[sample(seq.int(nrow(x)), 20, TRUE), ]

bibar(x, left = 1:3, right = 4:6, xlim = c(-250, 250))

palette(c('grey90', 'cornflowerblue', 'blue', 'tomato', 'tomato3'))
bibar(x, left = 2:3, right = 4:5, sleft = 1, sright = 6)
legend('topleft', inset = c(0, -0.2), xpd = NA, fill = 3:2,
       legend = colnames(x)[3:2], horiz = TRUE, bty = 'n')
legend('topright', inset = c(0, -0.2), xpd = NA, fill = 4:5,
       legend = colnames(x)[4:5], horiz = TRUE, bty = 'n')
palette('default')

dose_esc

d33 <- rep(1:4, c(3, 3, 6, 4))
c33 <- rep(3, length(d33))
c33[c(9, 14, 15)] <- 2

par(mfrow = c(2, 1), mar = c(2, 2, 2, 2))
dose_esc(d33, c33, dose.exp = rep(4, 10), col.exp = rep(3, 10))
dose_esc(d33, c33, dose.exp = rep(3, 10), col.exp = rep(3, 4))

boxline

set.seed(1)
x <- lapply(0:10, function(x) rnorm(25, x / 2, sd = 0.5))
boxplot(x)
boxline(x, add = TRUE)

inbar

set.seed(1)
tbl <- sapply(1:3, function(x) sort(rpois(3, 10), decreasing = TRUE))
inbar(tbl, col = 1:3)

tracebar

set.seed(1)
tbl <- sapply(1:3, function(x) sort(rpois(3, 10), decreasing = TRUE))

tracebar(tbl)
tracebar(replace(tbl, 5, 0), col = 1:3, space = 0.5)

toxplot

set.seed(1)
f <- function(x, ...) sample(x, 100, replace = TRUE, ...)
tox <- data.frame(
  id = rep(1:10, 10), phase = 1:2,
  code = f(rawr::ctcae_v4$tox_code[1:100]),
  grade = f(1:3, prob = c(.6, .3, .1)),
  stringsAsFactors = FALSE
)
tox <- cbind(tox, rawr::match_ctc(tox$code)[, c('tox_cat', 'tox_desc')])

t1 <- ftable(
  Category = tox$tox_cat,
  Description = tox$tox_desc,
  Grade = tox$grade
)
t2 <- ftable(
  Description = tox$tox_desc,
  Grade = tox$grade
)
n <- 25


## basic usage
toxplot(t1, n) ## three column
toxplot(t2, n, widths = c(1, 3)) ## two column

spider

with(airquality, spider(Day, Temp, group = Month))

with(airquality, {
  spider(Day, Temp - mean(Temp), group = Month, start = 0,
         labels = month.abb[unique(Month)],
         at.labels = par('usr')[2], col.labels = 1:5)
})

dotplot

# https://twitter.com/RandyRenstrom/status/1318053323828756480/photo/1
x <- c(
  39, 55, 36, 47, 32, 58, 57, 17, 14, 17, 43, 49, 40, 38, 28,
  60, 57, 56, 52, 49, 46, 45, 43, 43, 42, 40, 36, 36, 33, 23,
  85, 68, 73, 58, 69, 48, 43, 68, 64, 62, 44, 35, 31, 36, 19
)
y <- c(
  'The coronavirus pandemic',
  'Fairness of presidential elections',
  'Health care',
  'Jobs and employment',
  'Foreign interference in presidential elections',
  'Crime',
  'Terrorism',
  'Racial inequality',
  'Climate change',
  'Growing gap between rich and poor',
  'Appointment of U.S. Supreme Court Justices',
  'Abortion',
  'The federal deficit',
  'Immigration',
  'Trade agreements with other countries'
)
x <- matrix(x, ncol = 3L, dimnames = list(y, c('R', 'All', 'D')))

dotplot(x, col = c('blue4', 'darkgrey', 'tomato2'))
box('outer')

not so useful

prettypie2

prettypie2(mtcars$mpg, group = mtcars$gear)

barmap

barmap(c(1, 1, 1) / 3, region = 'Germany', cols = c('gold', 'red', 'black'))

voteGermany2013 <- structure(
  list(
    Party = c("CDU/CSU", "SPD", "LINKE", "GRUENE"),
    Result = c(49.4, 30.5, 10.2, 10)
  ), class = "data.frame", row.names = c("1", "2", "3", "4")
)

with(voteGermany2013, {
  barmap(Result / 100, region = 'Germany',
         labels = sprintf('%s (%s%%)', Party, Result))
})

bump

set.seed(1)
mat <- replicate(5, sample(1:10))
dimnames(mat) <- list(rownames(mtcars)[1:nrow(mat)],
                      paste0('time', 1:ncol(mat)))
bump(mat, mar = c(2, 0, 2, 9))

minbars

set.seed(1)

layout(matrix(c(1, 1, 1, 2:4), 3), widths = c(1, 1.5))
op <- par(las = 1L, mar = c(1, 1, 2, 2))

minbars(table(rbinom(500, 15, 0.5)), unit = 'Billion',
        col = adjustcolor('tomato4', alpha.f = 0.5))
mtext('Group 1', at = par('usr')[1L], adj = 0)
for (ii in 1:3) {
  minbars(table(rbinom(500, 15, 0.5)), unit = 'Million', min = 10,
          horiz = FALSE, col = adjustcolor(ii, alpha.f = 0.5))
  if (ii == 2L)
    abline(h = grconvertY(0:1, 'nfc'), xpd = TRUE)
  text(0, mean(par('usr')[3:4]), paste('Group', ii + 1L),
       xpd = NA, srt = 90, adj = c(0.5, -1), cex = 1.5)
}
par(op)

Session info

within.list(sessionInfo(), loadedOnly <- NULL)

raredd/plotr documentation built on Nov. 19, 2023, 4:09 a.m.