How to draw gauge chart in R? - r

How can I draw the following plot in R?
Red = 30
Yellow = 40
Green = 30
Needle at 52.

So here's a fully ggplot solution.
Note: Edited from the original post to add numeric indicator and labels at the gauge breaks which seems to be what OP is asking for in their comment. If indicator is not needed, remove the annotate(...) line. If labels are not needed, remove geom_text(...) line.
gg.gauge <- function(pos,breaks=c(0,30,70,100)) {
require(ggplot2)
get.poly <- function(a,b,r1=0.5,r2=1.0) {
th.start <- pi*(1-a/100)
th.end <- pi*(1-b/100)
th <- seq(th.start,th.end,length=100)
x <- c(r1*cos(th),rev(r2*cos(th)))
y <- c(r1*sin(th),rev(r2*sin(th)))
return(data.frame(x,y))
}
ggplot()+
geom_polygon(data=get.poly(breaks[1],breaks[2]),aes(x,y),fill="red")+
geom_polygon(data=get.poly(breaks[2],breaks[3]),aes(x,y),fill="gold")+
geom_polygon(data=get.poly(breaks[3],breaks[4]),aes(x,y),fill="forestgreen")+
geom_polygon(data=get.poly(pos-1,pos+1,0.2),aes(x,y))+
geom_text(data=as.data.frame(breaks), size=5, fontface="bold", vjust=0,
aes(x=1.1*cos(pi*(1-breaks/100)),y=1.1*sin(pi*(1-breaks/100)),label=paste0(breaks,"%")))+
annotate("text",x=0,y=0,label=pos,vjust=0,size=8,fontface="bold")+
coord_fixed()+
theme_bw()+
theme(axis.text=element_blank(),
axis.title=element_blank(),
axis.ticks=element_blank(),
panel.grid=element_blank(),
panel.border=element_blank())
}
gg.gauge(52,breaks=c(0,35,70,100))
## multiple guages
library(gridExtra)
grid.newpage()
grid.draw(arrangeGrob(gg.gauge(10),gg.gauge(20),
gg.gauge(52),gg.gauge(90),ncol=2))
You will likely need to tweak the size=... parameter to geom_text(...) and annotate(...) depending on the actual size of your gauge.
IMO the segment labels are a really bad idea: they clutter the image and defeat the purpose of the graphic (to indicate at a glance if the metric is in "safe", "warning", or "danger" territory).

Here's a very quick and dirty implementation using grid graphics
library(grid)
draw.gauge<-function(x, from=0, to=100, breaks=3,
label=NULL, axis=TRUE, cols=c("red","yellow","green")) {
if (length(breaks)==1) {
breaks <- seq(0, 1, length.out=breaks+1)
} else {
breaks <- (breaks-from)/(to-from)
}
stopifnot(length(breaks) == (length(cols)+1))
arch<-function(theta.start, theta.end, r1=1, r2=.5, col="grey", n=100) {
t<-seq(theta.start, theta.end, length.out=n)
t<-(1-t)*pi
x<-c(r1*cos(t), r2*cos(rev(t)))
y<-c(r1*sin(t), r2*sin(rev(t)))
grid.polygon(x,y, default.units="native", gp=gpar(fill=col))
}
tick<-function(theta, r, w=.01) {
t<-(1-theta)*pi
x<-c(r*cos(t-w), r*cos(t+w), 0)
y<-c(r*sin(t-w), r*sin(t+w), 0)
grid.polygon(x,y, default.units="native", gp=gpar(fill="grey"))
}
addlabel<-function(m, theta, r) {
t<-(1-theta)*pi
x<-r*cos(t)
y<-r*sin(t)
grid.text(m,x,y, default.units="native")
}
pushViewport(viewport(w=.8, h=.40, xscale=c(-1,1), yscale=c(0,1)))
bp <- split(t(embed(breaks, 2)), 1:2)
do.call(Map, list(arch, theta.start=bp[[1]],theta.end=bp[[2]], col=cols))
p<-(x-from)/(to-from)
if (!is.null(axis)) {
if(is.logical(axis) && axis) {
m <- round(breaks*(to-from)+from,0)
} else if (is.function(axis)) {
m <- axis(breaks, from, to)
} else if(is.character(axis)) {
m <- axis
} else {
m <- character(0)
}
if(length(m)>0) addlabel(m, breaks, 1.10)
}
tick(p, 1.03)
if(!is.null(label)) {
if(is.logical(label) && label) {
m <- x
} else if (is.function(label)) {
m <- label(x)
} else {
m <- label
}
addlabel(m, p, 1.15)
}
upViewport()
}
This function can be used to draw one gauge
grid.newpage()
draw.gauge(100*runif(1))
or many gauges
grid.newpage()
pushViewport(viewport(layout=grid.layout(2,2)))
for(i in 1:4) {
pushViewport(viewport(layout.pos.col=(i-1) %/%2 +1, layout.pos.row=(i-1) %% 2 + 1))
draw.gauge(100*runif(1))
upViewport()
}
popViewport()
It's not too fancy so it should be easy to customize.
You can now also add a label
draw.gauge(75, label="75%")
I've added another update to allow for drawing an "axis". You can set it to TRUE to use default values, or you can pass in a character vector to give whatever labels you want, or you can pass in a function that will take the breaks (scaled 0-1) and the from/to values and should return a character value.
grid.newpage()
draw.gauge(100*runif(1), breaks=c(0,30,70,100), axis=T)

Flexdashboard has a simple function for guage chart. For details take a look at https://rdrr.io/cran/flexdashboard/man/gauge.html
You can plot the chart using a simple call like:
gauge(42, min = 0, max = 100, symbol = '%',
gaugeSectors(success = c(80, 100), warning = c(40, 79), danger = c(0, 39)))

I found this solution from Gaston Sanchez's blog:
library(googleVis)
plot(gvisGauge(data.frame(Label=”UserR!”, Value=80),
options=list(min=0, max=100,
yellowFrom=80, yellowTo=90,
redFrom=90, redTo=100)))
Here is the function created later:
# Original code by Gaston Sanchez http://www.r-bloggers.com/gauge-chart-in-r/
#
dial.plot <- function(label = "UseR!", value = 78, dial.radius = 1
, value.cex = 3, value.color = "black"
, label.cex = 3, label.color = "black"
, gage.bg.color = "white"
, yellowFrom = 75, yellowTo = 90, yellow.slice.color = "#FF9900"
, redFrom = 90, redTo = 100, red.slice.color = "#DC3912"
, needle.color = "red", needle.center.color = "black", needle.center.cex = 1
, dial.digets.color = "grey50"
, heavy.border.color = "gray85", thin.border.color = "gray20", minor.ticks.color = "gray55", major.ticks.color = "gray45") {
whiteFrom = min(yellowFrom, redFrom) - 2
whiteTo = max(yellowTo, redTo) + 2
# function to create a circle
circle <- function(center=c(0,0), radius=1, npoints=100)
{
r = radius
tt = seq(0, 2*pi, length=npoints)
xx = center[1] + r * cos(tt)
yy = center[1] + r * sin(tt)
return(data.frame(x = xx, y = yy))
}
# function to get slices
slice2xy <- function(t, rad)
{
t2p = -1 * t * pi + 10*pi/8
list(x = rad * cos(t2p), y = rad * sin(t2p))
}
# function to get major and minor tick marks
ticks <- function(center=c(0,0), from=0, to=2*pi, radius=0.9, npoints=5)
{
r = radius
tt = seq(from, to, length=npoints)
xx = center[1] + r * cos(tt)
yy = center[1] + r * sin(tt)
return(data.frame(x = xx, y = yy))
}
# external circle (this will be used for the black border)
border_cir = circle(c(0,0), radius=dial.radius, npoints = 100)
# open plot
plot(border_cir$x, border_cir$y, type="n", asp=1, axes=FALSE,
xlim=c(-1.05,1.05), ylim=c(-1.05,1.05),
xlab="", ylab="")
# gray border circle
external_cir = circle(c(0,0), radius=( dial.radius * 0.97 ), npoints = 100)
# initial gage background
polygon(external_cir$x, external_cir$y,
border = gage.bg.color, col = gage.bg.color, lty = NULL)
# add gray border
lines(external_cir$x, external_cir$y, col=heavy.border.color, lwd=18)
# add external border
lines(border_cir$x, border_cir$y, col=thin.border.color, lwd=2)
# yellow slice (this will be used for the yellow band)
yel_ini = (yellowFrom/100) * (12/8)
yel_fin = (yellowTo/100) * (12/8)
Syel = slice2xy(seq.int(yel_ini, yel_fin, length.out = 30), rad= (dial.radius * 0.9) )
polygon(c(Syel$x, 0), c(Syel$y, 0),
border = yellow.slice.color, col = yellow.slice.color, lty = NULL)
# red slice (this will be used for the red band)
red_ini = (redFrom/100) * (12/8)
red_fin = (redTo/100) * (12/8)
Sred = slice2xy(seq.int(red_ini, red_fin, length.out = 30), rad= (dial.radius * 0.9) )
polygon(c(Sred$x, 0), c(Sred$y, 0),
border = red.slice.color, col = red.slice.color, lty = NULL)
# white slice (this will be used to get the yellow and red bands)
white_ini = (whiteFrom/100) * (12/8)
white_fin = (whiteTo/100) * (12/8)
Swhi = slice2xy(seq.int(white_ini, white_fin, length.out = 30), rad= (dial.radius * 0.8) )
polygon(c(Swhi$x, 0), c(Swhi$y, 0),
border = gage.bg.color, col = gage.bg.color, lty = NULL)
# calc and plot minor ticks
minor.tix.out <- ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.89 ), 21)
minor.tix.in <- ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.85 ), 21)
arrows(x0=minor.tix.out$x, y0=minor.tix.out$y, x1=minor.tix.in$x, y1=minor.tix.in$y,
length=0, lwd=2.5, col=minor.ticks.color)
# coordinates of major ticks (will be plotted as arrows)
major_ticks_out = ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.9 ), 5)
major_ticks_in = ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.77 ), 5)
arrows(x0=major_ticks_out$x, y0=major_ticks_out$y, col=major.ticks.color,
x1=major_ticks_in$x, y1=major_ticks_in$y, length=0, lwd=3)
# calc and plot numbers at major ticks
dial.numbers <- ticks(c(0,0), from=5*pi/4, to=-pi/4, radius=( dial.radius * 0.70 ), 5)
dial.lables <- c("0", "25", "50", "75", "100")
text(dial.numbers$x, dial.numbers$y, labels=dial.lables, col=dial.digets.color, cex=.8)
# Add dial lables
text(0, (dial.radius * -0.65), value, cex=value.cex, col=value.color)
# add label of variable
text(0, (dial.radius * 0.43), label, cex=label.cex, col=label.color)
# add needle
# angle of needle pointing to the specified value
val = (value/100) * (12/8)
v = -1 * val * pi + 10*pi/8 # 10/8 becuase we are drawing on only %80 of the cir
# x-y coordinates of needle
needle.length <- dial.radius * .67
needle.end.x = needle.length * cos(v)
needle.end.y = needle.length * sin(v)
needle.short.length <- dial.radius * .1
needle.short.end.x = needle.short.length * -cos(v)
needle.short.end.y = needle.short.length * -sin(v)
needle.side.length <- dial.radius * .05
needle.side1.end.x = needle.side.length * cos(v - pi/2)
needle.side1.end.y = needle.side.length * sin(v - pi/2)
needle.side2.end.x = needle.side.length * cos(v + pi/2)
needle.side2.end.y = needle.side.length * sin(v + pi/2)
needle.x.points <- c(needle.end.x, needle.side1.end.x, needle.short.end.x, needle.side2.end.x)
needle.y.points <- c(needle.end.y, needle.side1.end.y, needle.short.end.y, needle.side2.end.y)
polygon(needle.x.points, needle.y.points, col=needle.color)
# add central blue point
points(0, 0, col=needle.center.color, pch=20, cex=needle.center.cex)
# add values 0 and 100
}
par(mar=c(0.2,0.2,0.2,0.2), bg="black", mfrow=c(2,2))
dial.plot ()
dial.plot (label = "Working", value = 25, dial.radius = 1
, value.cex = 3.3, value.color = "white"
, label.cex = 2.7, label.color = "white"
, gage.bg.color = "black"
, yellowFrom = 73, yellowTo = 95, yellow.slice.color = "gold"
, redFrom = 95, redTo = 100, red.slice.color = "red"
, needle.color = "red", needle.center.color = "white", needle.center.cex = 1
, dial.digets.color = "white"
, heavy.border.color = "white", thin.border.color = "black", minor.ticks.color = "white", major.ticks.color = "white")
dial.plot (label = "caffeine", value = 63, dial.radius = .7
, value.cex = 2.3, value.color = "white"
, label.cex = 1.7, label.color = "white"
, gage.bg.color = "black"
, yellowFrom = 80, yellowTo = 93, yellow.slice.color = "gold"
, redFrom = 93, redTo = 100, red.slice.color = "red"
, needle.color = "red", needle.center.color = "white", needle.center.cex = 1
, dial.digets.color = "white"
, heavy.border.color = "black", thin.border.color = "lightsteelblue4", minor.ticks.color = "orange", major.ticks.color = "tan")
dial.plot (label = "Fun", value = 83, dial.radius = .7
, value.cex = 2.3, value.color = "white"
, label.cex = 1.7, label.color = "white"
, gage.bg.color = "black"
, yellowFrom = 20, yellowTo = 75, yellow.slice.color = "olivedrab"
, redFrom = 75, redTo = 100, red.slice.color = "green"
, needle.color = "red", needle.center.color = "white", needle.center.cex = 1
, dial.digets.color = "white"
, heavy.border.color = "black", thin.border.color = "lightsteelblue4", minor.ticks.color = "orange", major.ticks.color = "tan")

Related

How to change the position of the zoomed area from facet_zoom()?

With facet_zoom() from the ggforce package one can create nice zooms to highlight certain regions of a plot. Unfortunately, when zooming in on the y axis the original plot is always on the right side.
Is there a way to place the original plot on the left?
This would feel more intuitive to first look at the main plot and then at the zoomed region. As an example I would like to swap the position of the two facets in this plot:
(No reproducible example added, since I believe this is a question about the existence of a certain functionality.)
I've tweaked the current code for FacetZoom on GitHub to swop the horizontal order from [zoom, original] to [original, zoom]. The changes aren't complicated, but they are scattered throughout draw_panels() function's code, so the full code is rather long.
Result:
# example 1, with split = FALSE, horizontal = TRUE (i.e. default settings)
p1 <- ggplot(mtcars, aes(x = mpg, y = disp, colour = factor(cyl))) +
geom_point() +
theme_bw()
p1 + ggtitle("Original") + facet_zoom(y = disp > 300)
p1 + ggtitle("Modified") + facet_zoom2(y = disp > 300)
# example 2, with split = TRUE
p2 <- ggplot(iris, aes(Petal.Length, Petal.Width, colour = Species)) +
geom_point() +
theme_bw()
p2 + ggtitle("Original") +
facet_zoom(xy = Species == "versicolor", split = TRUE)
p2 + ggtitle("Modified") +
facet_zoom2(xy = Species == "versicolor", split = TRUE)
Code used (I've commented out the original code, where modified code is used, & indicated the packages for functions from other packages):
library(ggplot)
library(ggforce)
library(grid)
# define facet_zoom2 function to use FacetZoom2 instead of FacetZoom
# (everything else is the same as facet_zoom)
facet_zoom2 <- function(x, y, xy, zoom.data, xlim = NULL, ylim = NULL,
split = FALSE, horizontal = TRUE, zoom.size = 2,
show.area = TRUE, shrink = TRUE) {
x <- if (missing(x)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(x)
y <- if (missing(y)) if (missing(xy)) NULL else lazyeval::lazy(xy) else lazyeval::lazy(y)
zoom.data <- if (missing(zoom.data)) NULL else lazyeval::lazy(zoom.data)
if (is.null(x) && is.null(y) && is.null(xlim) && is.null(ylim)) {
stop("Either x- or y-zoom must be given", call. = FALSE)
}
if (!is.null(xlim)) x <- NULL
if (!is.null(ylim)) y <- NULL
ggproto(NULL, FacetZoom2,
shrink = shrink,
params = list(
x = x, y = y, xlim = xlim, ylim = ylim, split = split, zoom.data = zoom.data,
zoom.size = zoom.size, show.area = show.area,
horizontal = horizontal
)
)
}
# define FacetZoom as a ggproto object that inherits from FacetZoom,
# with a modified draw_panels function. the compute_layout function references
# the version currently on GH, which is slightly different from the CRAN
# package version.
FacetZoom2 <- ggproto(
"FacetZoom2",
ggforce::FacetZoom,
compute_layout = function(data, params) {
layout <- rbind( # has both x & y dimension
data.frame(name = 'orig', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'x', SCALE_X = 2L, SCALE_Y = 1L),
data.frame(name = 'y', SCALE_X = 1L, SCALE_Y = 2L),
data.frame(name = 'full', SCALE_X = 2L, SCALE_Y = 2L),
data.frame(name = 'orig_true', SCALE_X = 1L, SCALE_Y = 1L),
data.frame(name = 'zoom_true', SCALE_X = 1L, SCALE_Y = 1L)
)
if (is.null(params$y) && is.null(params$ylim)) { # no y dimension
layout <- layout[c(1,2, 5:6),]
} else if (is.null(params$x) && is.null(params$xlim)) { # no x dimension
layout <- layout[c(1,3, 5:6),]
}
layout$PANEL <- seq_len(nrow(layout))
layout
},
draw_panels = function(panels, layout, x_scales, y_scales, ranges, coord,
data, theme, params) {
if (is.null(params$x) && is.null(params$xlim)) {
params$horizontal <- TRUE
} else if (is.null(params$y) && is.null(params$ylim)) {
params$horizontal <- FALSE
}
if (is.null(theme[['zoom']])) {
theme$zoom <- theme$strip.background
}
if (is.null(theme$zoom.x)) {
theme$zoom.x <- theme$zoom
}
if (is.null(theme$zoom.y)) {
theme$zoom.y <- theme$zoom
}
axes <- render_axes(ranges, ranges, coord, theme, FALSE)
panelGrobs <- ggforce:::create_panels(panels, axes$x, axes$y)
panelGrobs <- panelGrobs[seq_len(length(panelGrobs) - 2)]
if ('full' %in% layout$name && !params$split) {
panelGrobs <- panelGrobs[c(1, 4)]
}
# changed coordinates in indicator / lines to zoom from
# the opposite horizontal direction
if ('y' %in% layout$name) {
if (!inherits(theme$zoom.y, 'element_blank')) {
zoom_prop <- scales::rescale(
y_scales[[2]]$dimension(ggforce:::expansion(y_scales[[2]])),
from = y_scales[[1]]$dimension(ggforce:::expansion(y_scales[[1]])))
indicator <- polygonGrob(
x = c(0, 0, 1, 1), # was x = c(1, 1, 0, 0),
y = c(zoom_prop, 1, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.y$fill, 0.5)))
lines <- segmentsGrob(
x0 = c(1, 1), x1 = c(0, 0), # was x0 = c(0, 0), x1 = c(1, 1)
y0 = c(0, 1), y1 = zoom_prop,
gp = gpar(col = theme$zoom.y$colour,
lty = theme$zoom.y$linetype,
lwd = theme$zoom.y$size,
lineend = 'round'))
indicator_h <- grobTree(indicator, lines)
} else {
indicator_h <- zeroGrob()
}
}
if ('x' %in% layout$name) {
if (!inherits(theme$zoom.x, 'element_blank')) {
zoom_prop <- scales::rescale(x_scales[[2]]$dimension(ggforce:::expansion(x_scales[[2]])),
from = x_scales[[1]]$dimension(ggforce:::expansion(x_scales[[1]])))
indicator <- polygonGrob(c(zoom_prop, 1, 0), c(1, 1, 0, 0),
gp = gpar(col = NA, fill = alpha(theme$zoom.x$fill, 0.5)))
lines <- segmentsGrob(x0 = c(0, 1), y0 = c(0, 0), x1 = zoom_prop, y1 = c(1, 1),
gp = gpar(col = theme$zoom.x$colour,
lty = theme$zoom.x$linetype,
lwd = theme$zoom.x$size,
lineend = 'round'))
indicator_v <- grobTree(indicator, lines)
} else {
indicator_v <- zeroGrob()
}
}
if ('full' %in% layout$name && params$split) {
space.x <- theme$panel.spacing.x
if (is.null(space.x)) space.x <- theme$panel.spacing
space.x <- unit(5 * as.numeric(convertUnit(space.x, 'cm')), 'cm')
space.y <- theme$panel.spacing.y
if (is.null(space.y)) space.y <- theme$panel.spacing
space.y <- unit(5 * as.numeric(convertUnit(space.y, 'cm')), 'cm')
# change horizontal order of panels from [zoom, original] to [original, zoom]
# final <- gtable::gtable_add_cols(panelGrobs[[3]], space.x)
# final <- cbind(final, panelGrobs[[1]], size = 'first')
# final_tmp <- gtable::gtable_add_cols(panelGrobs[[4]], space.x)
# final_tmp <- cbind(final_tmp, panelGrobs[[2]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space.x)
final <- cbind(final, panelGrobs[[3]], size = 'first')
final_tmp <- gtable::gtable_add_cols(panelGrobs[[2]], space.x)
final_tmp <- cbind(final_tmp, panelGrobs[[4]], size = 'first')
final <- gtable::gtable_add_rows(final, space.y)
final <- rbind(final, final_tmp, size = 'first')
final <- gtable::gtable_add_grob(final, list(indicator_h, indicator_h),
c(2, 6), 3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
final <- gtable::gtable_add_grob(final, list(indicator_v, indicator_v),
3, c(2, 6), 5,
z = -Inf, name = "zoom-indicator")
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[3]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[3]]$bottom)), 'cm'),
space.y,
unit(max_height(list(axes$x[[2]]$top, axes$x[[4]]$top)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$x[[2]]$bottom, axes$x[[4]]$bottom)), 'cm')
)
# swop panel width specifications according to the new horizontal order
widths <- unit.c(
# unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
# unit(params$zoom.size, 'null'),
# unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm'),
# space.x,
# unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
# unit(1, 'null'),
# unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm'),
space.x,
unit(max_width(list(axes$y[[3]]$left, axes$y[[4]]$left)), 'cm'),
unit(params$zoom.size, 'null'),
unit(max_height(list(axes$y[[3]]$right, axes$y[[4]]$right)), 'cm')
)
final$heights <- heights
final$widths <- widths
} else {
if (params$horizontal) {
space <- theme$panel.spacing.x
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
heights <- unit.c(
unit(max_height(list(axes$x[[1]]$top, axes$x[[2]]$top)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$x[[1]]$bottom, axes$x[[2]]$bottom)), 'cm')
)
# change horizontal order of panels from [zoom, original] to [original, zoom]
# first <- gtable::gtable_add_cols(panelGrobs[[2]], space)
# first <- cbind(final, panelGrobs[[1]], size = 'first')
final <- gtable::gtable_add_cols(panelGrobs[[1]], space)
final <- cbind(final, panelGrobs[[2]], size = "first")
final$heights <- heights
# swop panel width specifications according to the new horizontal order
# unit(c(params$zoom.size, 1), 'null')
final$widths[panel_cols(final)$l] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_h, 2, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
} else {
space <- theme$panel.spacing.y
if (is.null(space)) space <- theme$panel.spacing
space <- unit(5 * as.numeric(convertUnit(space, 'cm')), 'cm')
widths <- unit.c(
unit(max_width(list(axes$y[[1]]$left, axes$y[[2]]$left)), 'cm'),
unit(1, 'null'),
unit(max_height(list(axes$y[[1]]$right, axes$y[[2]]$right)), 'cm')
)
final <- gtable::gtable_add_rows(panelGrobs[[1]], space)
final <- rbind(final, panelGrobs[[2]], size = 'first')
final$widths <- widths
final$heights[panel_rows(final)$t] <- unit(c(1, params$zoom.size), 'null')
final <- gtable::gtable_add_grob(final, indicator_v, 3, 2, 5,
z = -Inf, name = "zoom-indicator")
}
}
final
}
)
Note: create_panels and expansion are un-exported functions from the ggforce package, so I referenced them with triple colons. This isn't robust for writing packages, but should suffice as a temporary workaround.
Update 30 Oct 2019: A suggestion for those seeing errors like Invalid 'type' (list) of argument after trying to use this solution as-is. The issue is likely due to updates made to the ggforcepackage since this solution was developed. To get the code in this solution working again, install the version of ggforce that was available when the solution was developed. This can be done with the devtools package pointing to the 4008a2e commit:
devtools::install_github("thomasp85/ggforce", ref = '4008a2e')

biwavelet package: "cex.axis" not working in plot.biwavelet(); A bug?

I am using biwavelet package to conduct wavelet analysis. However, when I want to adjust the label size for axis using cex.axis, the label size does not changed. On the other hand, cex.lab and cex.main are working well. Is this a bug? The following gives a reproducible example.
library(biwavelet)
t1 <- cbind(1:100, rnorm(100))
t2 <- cbind(1:100, rnorm(100))
# Continuous wavelet transform
wt.t1 <- wt(t1)
par(oma = c(0, 0.5, 0, 0), mar = c(4, 2, 2, 4))
plot(wt.t1,plot.cb = T,plot.phase = T,type = 'power.norm',
xlab = 'Time(year)',ylab = 'Period(year)',mgp=c(2,1,0),
main='Winter station 1',cex.main=0.8,cex.lab=0.8,cex.axis=0.8)
Edit
There was a previous question on this site a month ago: Wavelets plot: changing x-, y- axis, and color plot, but not solved. Any help this time? Thank you!
Yeah, it is a bug. Here is patched version: my.plot.biwavelet()
This version accepts argument cex.axis (defaults to 1), and you can change it when needed. I will briefly explain to you what the problem is, in the "explanation" section in the end.
my.plot.biwavelet <- function (x, ncol = 64, fill.cols = NULL, xlab = "Time", ylab = "Period",
tol = 1, plot.cb = FALSE, plot.phase = FALSE, type = "power.corr.norm",
plot.coi = TRUE, lwd.coi = 1, col.coi = "white", lty.coi = 1,
alpha.coi = 0.5, plot.sig = TRUE, lwd.sig = 4, col.sig = "black",
lty.sig = 1, bw = FALSE, legend.loc = NULL, legend.horiz = FALSE,
arrow.len = min(par()$pin[2]/30, par()$pin[1]/40), arrow.lwd = arrow.len *
0.3, arrow.cutoff = 0.9, arrow.col = "black", xlim = NULL,
ylim = NULL, zlim = NULL, xaxt = "s", yaxt = "s", form = "%Y", cex.axis = 1,
...) {
if (is.null(fill.cols)) {
if (bw) {
fill.cols <- c("black", "white")
}
else {
fill.cols <- c("#00007F", "blue", "#007FFF",
"cyan", "#7FFF7F", "yellow", "#FF7F00", "red",
"#7F0000")
}
}
col.pal <- colorRampPalette(fill.cols)
fill.colors <- col.pal(ncol)
types <- c("power.corr.norm", "power.corr", "power.norm",
"power", "wavelet", "phase")
type <- match.arg(tolower(type), types)
if (type == "power.corr" | type == "power.corr.norm") {
if (x$type == "wtc" | x$type == "xwt") {
x$power <- x$power.corr
x$wave <- x$wave.corr
}
else {
x$power <- x$power.corr
}
}
if (type == "power.norm" | type == "power.corr.norm") {
if (x$type == "xwt") {
zvals <- log2(x$power)/(x$d1.sigma * x$d2.sigma)
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
else if (x$type == "wtc" | x$type == "pwtc") {
zvals <- x$rsq
zvals[!is.finite(zvals)] <- NA
if (is.null(zlim)) {
zlim <- range(zvals, na.rm = TRUE)
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
else {
zvals <- log2(abs(x$power/x$sigma2))
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
}
else if (type == "power" | type == "power.corr") {
zvals <- log2(x$power)
if (is.null(zlim)) {
zlim <- range(c(-1, 1) * max(zvals))
}
zvals[zvals < zlim[1]] <- zlim[1]
locs <- pretty(range(zlim), n = 5)
leg.lab <- 2^locs
}
else if (type == "wavelet") {
zvals <- (Re(x$wave))
if (is.null(zlim)) {
zlim <- range(zvals)
}
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
else if (type == "phase") {
zvals <- x$phase
if (is.null(zlim)) {
zlim <- c(-pi, pi)
}
locs <- pretty(range(zlim), n = 5)
leg.lab <- locs
}
if (is.null(xlim)) {
xlim <- range(x$t)
}
yvals <- log2(x$period)
if (is.null(ylim)) {
ylim <- range(yvals)
}
else {
ylim <- log2(ylim)
}
image(x$t, yvals, t(zvals), zlim = zlim, xlim = xlim,
ylim = rev(ylim), xlab = xlab, ylab = ylab, yaxt = "n",
xaxt = "n", col = fill.colors, ...)
box()
if (class(x$xaxis)[1] == "Date" | class(x$xaxis)[1] ==
"POSIXct") {
if (xaxt != "n") {
xlocs <- pretty(x$t) + 1
axis(side = 1, at = xlocs, labels = format(x$xaxis[xlocs],
form))
}
}
else {
if (xaxt != "n") {
xlocs <- axTicks(1)
axis(side = 1, at = xlocs, cex.axis = cex.axis)
}
}
if (yaxt != "n") {
axis.locs <- axTicks(2)
yticklab <- format(2^axis.locs, dig = 1)
axis(2, at = axis.locs, labels = yticklab, cex.axis = cex.axis)
}
if (plot.coi) {
polygon(x = c(x$t, rev(x$t)), lty = lty.coi, lwd = lwd.coi,
y = c(log2(x$coi), rep(max(log2(x$coi), na.rm = TRUE),
length(x$coi))), col = adjustcolor(col.coi,
alpha.f = alpha.coi), border = col.coi)
}
if (plot.sig & length(x$signif) > 1) {
if (x$type %in% c("wt", "xwt")) {
contour(x$t, yvals, t(x$signif), level = tol,
col = col.sig, lwd = lwd.sig, add = TRUE, drawlabels = FALSE)
}
else {
tmp <- x$rsq/x$signif
contour(x$t, yvals, t(tmp), level = tol, col = col.sig,
lwd = lwd.sig, add = TRUE, drawlabels = FALSE)
}
}
if (plot.phase) {
a <- x$phase
locs.phases <- which(zvals < quantile(zvals, arrow.cutoff))
a[locs.phases] <- NA
phase.plot(x$t, log2(x$period), a, arrow.len = arrow.len,
arrow.lwd = arrow.lwd, arrow.col = arrow.col)
}
box()
if (plot.cb) {
fields::image.plot(x$t, yvals, t(zvals), zlim = zlim, ylim = rev(range(yvals)),
xlab = xlab, ylab = ylab, col = fill.colors,
smallplot = legend.loc, horizontal = legend.horiz,
legend.only = TRUE, axis.args = list(at = locs,
labels = format(leg.lab, dig = 2)), xpd = NA)
}
}
Test
library(biwavelet)
t1 <- cbind(1:100, rnorm(100))
t2 <- cbind(1:100, rnorm(100))
# Continuous wavelet transform
wt.t1 <- wt(t1)
par(oma = c(0, 0.5, 0, 0), mar = c(4, 2, 2, 4))
my.plot.biwavelet(wt.t1,plot.cb = T,plot.phase = T,type = 'power.norm',
xlab = 'Time(year)',ylab = 'Period(year)',mgp=c(2,1,0),
main='Winter station 1',cex.main=0.8,cex.lab=0.8,cex.axis=0.8)
As expected, it is working.
Explanation
In plot.biwavelet(), why passing cex.axis via ... does not work?
plot.biwavelet() generates the your final plot mainly in 3 stages:
image(..., xaxt = "n", yaxt = "n") for generating basic plot;
axis(1, at = atTicks(1)); axis(2, at = atTicks(2)) for adding axis;
fields::image.plot() for displaying colour legend strip.
Now, although this function takes ..., they are only fed to the first image() call, while the following axis(), (including polygon(), contour(), phase.plot()) and image.plot() take none from .... When later calling axis(), no flexible specification with respect to axis control are supported.
I guess during package development time, problem described as in: Giving arguments from “…” argument to right function in R had been encountered. Maybe the author did not realize this potential issue, leaving a bug here. My answer to that post, as well as Roland's comments, points toward a robust fix.
I am not the package author so can not decide how he will fix this. My fix is brutal, but works for you temporary need: just add the cex.axis argument to axis() call. I have reached Tarik (package author) with an email, and I believe he will give you a much better explanation and solution.
I fixed this issue by passing the ... argument to axis in plot.biwavelet. Your code should now work as desired. Note that changes to cex.axis and other axis arguments will affect all three axes (x, y, z).
You can download the new version (0.20.8) of biwavelet from GitHub by issuing the following command at the R console (this assumes that you have the package devtools already installed): devtools::install_github("tgouhier/biwavelet")
Thanks for pointing out the bug!

adehabitat package plot manipulation

I am relatively new in R and its packages. I am using the adehabitatHS package to compute and plot some selectivity data. Nevertheless I am having some troubles, mainly while plotting.
The first one is that by default the program uses the name "habitat" for the x-axis and I need to use "Msp" instead.
The second one is that I need to edit the first (top left) and specially the third (bottom left) plots. Since the legend for the third plot is too big and also I would like to sort the values. Does anyone know how to handle this kind of plots, is it possible to do it?
Please find attached my code, a copy of the dataset and the plot.
Dataset
Code:
library(adehabitatHS)
pse<-read.table("pseudos.txt", header=T)
attach(pse)
names(pse)
head(pse)
(wiRatio <- widesI(Diet, Dis))
png(filename = "plotpseudos3.png", width = 500, height = 500)
opar <- par(mfrow=c(2,2))
plot(wiRatio)
par(opar)
dev.off()
You have several options. You can look at the structure of your wiRatio object using str() function and extract the appropriate elements for plotting.
Or, you can modify the source pretty easily. The labels in the plot method for object of class wi uses names of values from that object (names(wi)) so this is where you need to dig. Here is the modified function, which I renamed to distinguish it from the original.
plotWi <- function (x, caxis = 0.7, clab = 1, ylog = FALSE, errbar = c("CI", "SE"),
main = "Manly selectivity measure", noorder = TRUE,
my.labels, ...)
{
errbar <- match.arg(errbar)
opar <- par(ask = TRUE)
on.exit(par(opar))
if (!inherits(x, "wi"))
stop("x should be of class wi")
eb <- ifelse(errbar == "SE", 1, abs(qnorm(x$alpha/length(x$wi))))
if (noorder)
wi <- sort(x$wi, decreasing = TRUE)
else wi <- x$wi
if ((any(wi == 0)) & (ylog)) {
warning("zero values in x, ylog has been set to FALSE")
ylog <- FALSE
}
logy <- ifelse(ylog, "y", "")
if (noorder)
sewi <- x$se.wi[order(x$wi, decreasing = TRUE)]
else sewi <- x$se.wi
sewi[is.na(sewi)] <- 0
nwi <- names(wi)
rgy <- range(c(wi, wi + eb * sewi, wi - eb * sewi))
textleg <- paste("Selection ratios (+/-", errbar, ")")
if (inherits(x, "wiII") | inherits(x, "wiIII"))
textleg <- paste("Global Selection ratios (+/-", errbar,
")")
if (!ylog)
rgy[1] <- 0
plot(wi, axes = FALSE, ylim = rgy, ty = "n", xlab = "", ylab = textleg,
cex.lab = clab, log = logy, main = main, ...)
axis(side = 1, at = c(1:length(wi)), labels = my.labels,
cex.axis = caxis, las = 2)
axis(side = 2, cex.axis = caxis)
box()
points(c(1:length(wi)), wi, pch = 16)
lines(1:length(wi), wi)
abline(h = 1, lwd = 2)
for (i in 1:length(wi)) {
lines(c(i, i), c(wi[i] - eb * sewi[i], wi[i] + eb * sewi[i]))
lines(c(i - 0.1, i + 0.1), c(wi[i] - eb * sewi[i], wi[i] -
eb * sewi[i]))
lines(c(i - 0.1, i + 0.1), c(wi[i] + eb * sewi[i], wi[i] +
eb * sewi[i]))
}
if (inherits(x, "wiI")) {
if (noorder)
Bi <- x$Bi[order(x$wi, decreasing = TRUE)]
else Bi <- x$Bi
plot(Bi, axes = FALSE, ty = "n", xlab = "", cex.lab = clab,
main = "Scaled selection ratios", ...)
axis(side = 1, at = c(1:length(wi)), labels = my.labels,
cex.axis = caxis, las = 2)
axis(side = 2, cex.axis = caxis)
lines(1:length(wi), Bi)
points(c(1:length(wi)), Bi, pch = 16)
box()
if (noorder) {
ut <- x$used.prop[order(x$wi, decreasing = TRUE)]
seu <- x$se.used[order(x$wi, decreasing = TRUE)]
sea <- x$se.avail[order(x$wi, decreasing = TRUE)]
av <- x$avail.prop[order(x$wi, decreasing = TRUE)]
}
else {
ut <- x$used.prop
seu <- x$se.used
sea <- x$se.avail
av <- x$avail.prop
}
rgy <- range(c(av, ut - eb * seu, ut + eb * seu, av -
eb * sea, av + eb * sea))
rgy <- c(rgy[1], rgy[2] + (rgy[2] - rgy[1])/4)
plot(ut, axes = FALSE, ty = "n", xlab = "", cex.lab = clab,
ylim = rgy, main = "Used and available proportions",
ylab = paste("Porportion (+/-", errbar, ")"), ...)
points(1:length(wi) - 0.05, av, pch = 16)
points(1:length(wi) + 0.05, ut, pch = 2)
for (i in 1:length(wi)) {
lines(c(i, i) + 0.05, c(ut[i] - eb * seu[i], ut[i] +
eb * seu[i]))
lines(c(i - 0.02, i + 0.02) + 0.05, c(ut[i] - eb *
seu[i], ut[i] - eb * seu[i]))
lines(c(i - 0.02, i + 0.02) + 0.05, c(ut[i] + eb *
seu[i], ut[i] + eb * seu[i]))
}
if (!x$avknown) {
for (i in 1:length(wi)) {
lines(c(i, i) - 0.05, c(av[i] - eb * sea[i],
av[i] + eb * sea[i]))
lines(c(i - 0.02, i + 0.02) - 0.05, c(av[i] -
eb * sea[i], av[i] - eb * sea[i]))
lines(c(i - 0.02, i + 0.02) - 0.05, c(av[i] +
eb * sea[i], av[i] + eb * sea[i]))
}
}
axis(side = 1, at = c(1:length(wi)), labels = my.labels,
cex.axis = caxis, las = 2)
axis(side = 2, cex.axis = caxis)
box()
legend(1, rgy[2], c("Available", "Used"), pch = c(16,
2), cex = clab)
}
else {
if (noorder)
wij <- x$wij[, order(x$wi, decreasing = TRUE)]
else wij <- x$wij
iii <- as.vector(wij)
rgy <- range(iii[!is.na(iii)])
plot(1, ty = "n", ylim = rgy, xlim = c(1, ncol(wij)),
xlab = "", ylab = paste("Selection ratios"), cex.lab = clab,
log = logy, axes = FALSE, main = main, ...)
axis(side = 1, at = c(1:length(wi)), labels = names(wi),
cex.axis = caxis, las = 2)
axis(side = 2, cex.axis = caxis)
box()
pt <- seq(-0.1, 0.1, by = 0.2/nrow(wij))
for (j in 1:nrow(wij)) {
points(c(1:length(wi)), wij[j, ], pch = 16, col = j)
lines(1:length(wi), wij[j, ], col = j)
abline(h = 1, lwd = 2)
}
rgx <- ncol(wij)/5
legend(ncol(wij) - rgx, rgy[1] + 19 * (rgy[2] - rgy[1])/20,
legend = row.names(wij), pch = 16, col = 1:nrow(wij),
lwd = 1, cex = clab)
}
}
I pass custom labels to the my.labels argument.
ploWi(wiRatio, noorder = FALSE, my.labels = paste("bugabuga", 1:16, sep = ""))
I will leave you as an exercise to modify the above function to tweak the legend.
Regarding the sorting of values, just use noorder = FALSE (as in my above example).

Major and minor axis ticks for dates in base R

I want to create major and minor ticks in my date-formatted x-axis, so that for every 3rd tick (representing every 3 months) I have a major tick and a label.
This is a reproducible example of what I have so far, which currently has uniform ticks.
month<-c("2010-08-01", "2010-09-01", "2010-10-01", "2010-12-01", "2011-01-01", "2011-02-01",
"2011-03-01", "2011-04-01", "2011-05-01", "2011-06-01", "2011-07-01", "2011-09-01",
"2011-11-01", "2012-01-01", "2012-02-01", "2012-03-01", "2012-05-01", "2012-07-01",
"2012-08-01")
prevalence<-c(10,7.5,5.2,3.5,6.4,2.7,5.8,13.2,4.3,4.7,6.4,4.4,5.2,3.3,1.0,3.1,9.9,33.3,1.0)
df<-data.frame(month, prevalence)
df$month<-as.Date(df$month)
plot(df$month, df$prevalence,lwd = 1.8, ylim=c(0,40),pch=16, bty='n', xaxt='n',
ylab="Prevalence (%)", xlab="Month",col='black',cex=1,cex.lab=1.0,cex.axis=1.0)
at <- seq(from = min(df$month), to = max(df$month), by = "month") # produces a regular sequence of dates
axis.Date(side = 1, at = at, labels = FALSE, tck=-0.04)
axis(side=2, at=c(0,10,20,30,40,50), labels=c("", "", "", "", "", ""), tck=-0.04)
lines(df$month, df$prevalence, col='black', lwd=1.8)
I have tried using the package magicaxis, but it does not seem to allow for date-formatted axes.
As a quick fix you could use repeat axis.Date calls.
at1 <- at[c(TRUE, TRUE, FALSE)]
axis.Date(side = 1, at = at1, labels = FALSE, tck=-0.02)
at2 <- at[c(FALSE, FALSE, TRUE)]
axis.Date(side = 1, at = at2, labels = TRUE, tck=-0.04)
The TRUE and FALSE are used to subset the vector at
I don't know if this is still a problem for someone, but I made a general purpose function for axes with minor ticks, based on the base axis() function, and with similar arguments. It's available in the StratigrapheR package under minorAxis()
minorAxis <- function(side, n = NULL, at.maj = NULL, at.min = NULL, range = NULL,
tick.ratio = 0.5, labels.maj = TRUE, line = NA, pos = NA,
outer = FALSE, font = NA, lty = "solid", lwd = 1,
lwd.ticks = lwd, col = NULL, col.ticks = NULL, hadj = NA,
padj = NA, extend = FALSE, tcl = NA, ...)
{
if(side == 1 | side == 3){
tick.pos <- par("xaxp")
} else if (side == 2 | side == 4) {
tick.pos <- par("yaxp")
}
# Define the positions of major ticks ----
if(is.null(at.maj)) {
# nat.int <- (tick.pos[2] - tick.pos[1])/tick.pos[3]
at.maj <- seq(tick.pos[1], tick.pos[2],
by = (tick.pos[2] - tick.pos[1])/tick.pos[3])
}
# Define range, exclude at.maj values if necessary ----
if(length(range) != 0){
eff.range <- range
r1 <- at.maj - min(range)
r2 <- at.maj - max(range)
p1 <- which.min(abs(r1))
p2 <- which.min(abs(r2))
if(!(abs(r1[p1]/min(range)) < 1.5e-8) & r1[p1] < 0) p1 <- p1 + 1
if(!(abs(r2[p2]/max(range)) < 1.5e-8) & r2[p2] > 0) p2 <- p2 - 1
at.maj <- at.maj[p1:p2]
} else {
if(side == 1 | side == 3){
eff.range <- par("usr")[1:2]
} else if (side == 2 | side == 4) {
eff.range <- par("usr")[3:4]
}
}
# Define limits ----
if(!extend) {
if(!is.null(at.min) & length(range) == 0){
limits <- c(min(c(at.min, at.maj)), max(c(at.min, at.maj)))
} else {
limits <- c(min(at.maj), max(at.maj))
}
} else {
limits <- eff.range
}
# Standard axis when n and at.min are not given ----
if(is.null(n) & is.null(at.min)){
axis(side, at = limits, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lty = lty, lwd = lwd, lwd.ticks = 0,
col = col,...)
axis(side, at = at.maj, labels = labels.maj, tick = TRUE, line = line,
pos = pos, outer = outer, font = font, lty = lty,
lwd = 0, lwd.ticks = lwd.ticks, col = col, col.ticks = col.ticks,
hadj = hadj, padj = padj, tcl = tcl,...)
} else {
# Work the minor ticks: check regularity ----
mina <- min(at.maj)
maxa <- max(at.maj)
difa <- maxa - mina
na <- difa / (length(at.maj) - 1)
if(is.null(at.min))
{
# n realm ----
# Checks----
sia <- seq(mina,maxa,by = na)
if(!isTRUE(all.equal(sort(sia),sort(at.maj)))) {
stop("at.maj is irregular, use at.min for minor ticks (not n)")
}
if(!(is.numeric(n) & length(n) == 1)){
stop("n should be a numeric of length one")
}
# Work it ----
tick.pos <- c(mina,maxa,difa/na)
nat.int <- (tick.pos[2] - tick.pos[1])/tick.pos[3]
# Define the position of minor ticks ----
distance.between.minor <- nat.int/n
p <- seq(min(at.maj), max(at.maj), by = distance.between.minor)
q <- sort(every_nth(p,n,empty=FALSE))
# Extend outside of major ticks range if necessary ----
if(!extend) {
tick.seq <- q
} else {
possible.low.minors <- min(at.maj) - (n:1) * distance.between.minor
possible.hi.minors <- max(at.maj) + (1:n) * distance.between.minor
r3 <- possible.low.minors - min(eff.range)
r4 <- possible.hi.minors - max(eff.range)
p3 <- which.min(abs(r3))
p4 <- which.min(abs(r4))
if(!(abs(r3[p3]/min(eff.range)) < 1.5e-8) & r3[p3] < 0) p3 <- p3 + 1
if(!(abs(r4[p4]/max(eff.range)) < 1.5e-8) & r4[p4] > 0) p4 <- p4 - 1
if(p3 < length(possible.low.minors + 1)){
low.candidates <- seq(p3, length(possible.low.minors), 1)
low.laureates <- possible.low.minors[low.candidates]
} else {
low.laureates <- NULL
}
if(p4 > 0){
hi.candidates <- seq(1, p4, 1)
hi.laureates <- possible.hi.minors[ hi.candidates]
} else {
hi.laureates <- NULL
}
tick.seq <- c(low.laureates,q,hi.laureates)
}
} else {
# at.min realm ----
tick.pos <- c(mina,maxa,na)
tick.seq <- sort(at.min)
if(length(range) != 0){
r3 <- tick.seq - min(eff.range)
r4 <- tick.seq - max(eff.range)
p3 <- which.min(abs(r3))
p4 <- which.min(abs(r4))
if(!(abs(r3[p3]/min(eff.range)) < 1.5e-8) & r3[p3] < 0) p3 <- p3 + 1
if(!(abs(r4[p4]/max(eff.range)) < 1.5e-8) & r4[p4] > 0) p4 <- p4 - 1
tick.seq <- tick.seq [p3:p4]
}
}
# Define the length of ticks ----
if(is.na(tcl)) maj.tcl <- par()$tcl else if (!is.na(tcl)) maj.tcl <- tcl
min.tcl <- maj.tcl*tick.ratio
# Plot the axes ----
axis(side, at = limits, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lty = lty, lwd = lwd, lwd.ticks = 0,
col = col,...)
axis(side, at = at.maj, labels = labels.maj, tick = TRUE, line = line,
pos = pos, outer = outer, font = font, lty = lty,
lwd = 0, lwd.ticks = lwd.ticks, col = col, col.ticks = col.ticks,
hadj = hadj, padj = padj, tcl = maj.tcl,...)
axis(side, at = tick.seq, labels = FALSE, tick = TRUE, line = line,
pos = pos, outer = outer, lwd = 0, lwd.ticks = lwd.ticks, col = col,
col.ticks = col.ticks, tcl = min.tcl,...)
}
}
# Run this as example:
plot(c(0,1), c(0,1), axes = FALSE, type = "n", xlab = "", ylab = "")
minorAxis(1, n = 10, range = c(0.12,0.61))
minorAxis(3, n = 10, extend=FALSE)

labeling points on an archetype archmap

How might one add labels to an archmap from the archetypes package? Or alternatively, would it be possible to recreate the archmap output in ggplot?
Using code from the SportsAnalytics demo (I hope this isn't bad form)
library("SportsAnalytics")
library("archetypes")
data("NBAPlayerStatistics0910")
dat <- subset(NBAPlayerStatistics0910,
select = c(Team, Name, Position,
TotalMinutesPlayed, FieldGoalsMade))
mat <- as.matrix(subset(dat, select = c(TotalMinutesPlayed, FieldGoalsMade)))
a3 <- archetypes(mat, 3)
archmap(a3)
I'd like the player names ( NBAPlayerStatistics0910$Name ) over the points on the chart. Something like below but more readable.
If you don't mind tweaking things a bit, you can start with the archmap() function base, toss in an extra parameter and add a text() call:
amap2 <- function (object, a.names, projection = simplex_projection, projection_args = list(),
rotate = 0, cex = 1.5, col = 1, pch = 1, xlab = "", ylab = "",
axes = FALSE, asp = TRUE, ...)
{
stopifnot("archetypes" %in% class(object))
stopifnot(is.function(projection))
k <- object$k
if (k < 3) {
stop("Need at least 3 archetypes.\n")
}
cmds <- do.call(projection, c(list(parameters(object)), projection_args))
if (rotate != 0) {
a <- pi * rotate/180
A <- matrix(c(cos(a), -sin(a), sin(a), cos(a)), ncol = 2)
cmds <- cmds %*% A
}
hmds <- chull(cmds)
active <- 1:k %in% hmds
plot(cmds, type = "n", xlab = xlab, ylab = ylab, axes = axes,
asp = asp, ...)
points(coef(object) %*% cmds, col = col, pch = pch)
######################
# PLAY WITH THIS BIT #
######################
text(coef(object) %*% cmds, a.names, pos=4)
######################
rad <- ceiling(log10(k)) + 1.5
polygon(cmds[hmds, ])
points(cmds[active, ], pch = 21, cex = rad * cex, bg = "grey")
text(cmds[active, ], labels = (1:k)[active], cex = cex)
if (any(!active)) {
points(cmds[!active, , drop = FALSE], pch = 21, cex = rad *
cex, bg = "white", fg = "grey")
text(cmds[!active, , drop = FALSE], labels = (1:k)[!active],
cex = cex, col = "grey20")
}
invisible(cmds)
}
amap2(a3, dat$Name)
Obviously, my completely quick stab is not the end result you're looking for, but it should help you get on your way (if I read what you want to do correctly).

Resources