in source/src/library/graphics/src/plot.c [738:1277]
SEXP C_axis(SEXP args)
{
/* axis(side, at, labels, tick, line, pos,
outer, font, lty, lwd, lwd.ticks, col, col.ticks,
hadj, padj, ...)
*/
SEXP at, lab, padj, label;
int font, lty, npadj;
rcolor col, colticks;
int i, n, nint = 0, ntmp, side, *ind, outer, lineoff = 0;
int istart, iend, incr;
Rboolean dolabels, doticks, logflag = FALSE;
Rboolean create_at;
double x, y, temp, tnew, tlast;
double axp[3], usr[2], limits[2];
double gap, labw, low, high, line, pos, lwd, lwdticks, hadj;
double axis_base, axis_tick, axis_lab, axis_low, axis_high;
pGEDevDesc dd = GEcurrentDevice();
/* Arity Check */
/* This is a builtin function, so it should always have */
/* the correct arity, but it doesn't hurt to be defensive. */
args = CDR(args);
if (length(args) < 15)
error(_("too few arguments"));
GCheckState(dd);
PrintDefaults(); /* prepare for labelformat */
/* Required argument: "side" */
/* Which side of the plot the axis is to appear on. */
/* side = 1 | 2 | 3 | 4. */
side = asInteger(CAR(args));
if (side < 1 || side > 4)
error(_("invalid axis number %d"), side);
args = CDR(args);
/* Required argument: "at" */
/* This gives the tick-label locations. */
/* Note that these are coerced to the correct type below. */
at = CAR(args); args = CDR(args);
/* Required argument: "labels" */
/* Labels can be a logical, indicating whether or not */
/* to label the axis; or it can be a vector of character */
/* strings or expressions which give the labels explicitly. */
/* The expressions are used to set mathematical labelling. */
dolabels = TRUE;
lab = CAR(args);
if (isLogical(lab) && length(lab) > 0) {
i = asLogical(lab);
if (i == 0 || i == NA_LOGICAL)
dolabels = FALSE;
PROTECT(lab = R_NilValue);
} else if (TYPEOF(lab) == LANGSXP || TYPEOF(lab) == SYMSXP) {
PROTECT(lab = coerceVector(lab, EXPRSXP));
} else if (isExpression(lab)) {
PROTECT(lab);
} else {
PROTECT(lab = coerceVector(lab, STRSXP));
}
args = CDR(args);
/* Required argument: "tick" */
/* This indicates whether or not ticks and the axis line */
/* should be plotted: TRUE => show, FALSE => don't show. */
doticks = asLogical(CAR(args));
doticks = (doticks == NA_LOGICAL) ? TRUE : (Rboolean) doticks;
args = CDR(args);
/* Optional argument: "line" */
/* Specifies an offset outward from the plot for the axis.
* The values in the par value "mgp" are interpreted
* relative to this value. */
line = asReal(CAR(args));
/* defer processing until after in-line pars */
args = CDR(args);
/* Optional argument: "pos" */
/* Specifies a user coordinate at which the axis should be drawn. */
/* This overrides the value of "line". Again the "mgp" par values */
/* are interpreted relative to this value. */
pos = asReal(CAR(args));
/* defer processing until after in-line pars */
args = CDR(args);
/* Optional argument: "outer" */
/* Should the axis be drawn in the outer margin. */
/* This only affects the computation of axis_base. */
outer = asLogical(CAR(args));
if (outer == NA_LOGICAL || outer == 0)
outer = NPC;
else
outer = NIC;
args = CDR(args);
/* Optional argument: "font" */
font = asInteger(FixupFont(CAR(args), NA_INTEGER));
args = CDR(args);
/* Optional argument: "lty" */
lty = asInteger(FixupLty(CAR(args), 0));
args = CDR(args);
/* Optional argument: "lwd" */
lwd = asReal(FixupLwd(CAR(args), 1));
args = CDR(args);
lwdticks = asReal(FixupLwd(CAR(args), 1));
args = CDR(args);
/* Optional argument: "col" */
col = asInteger(FixupCol(CAR(args), gpptr(dd)->fg));
args = CDR(args);
colticks = asInteger(FixupCol(CAR(args), col));
args = CDR(args);
/* Optional argument: "hadj" */
if (length(CAR(args)) != 1)
error(_("'hadj' must be of length one"));
hadj = asReal(CAR(args));
args = CDR(args);
/* Optional argument: "padj" */
PROTECT(padj = coerceVector(CAR(args), REALSXP));
npadj = length(padj);
if (npadj <= 0) error(_("zero-length '%s' specified"), "padj");
/* Now we process all the remaining inline par values:
we need to do it now as x/yaxp are retrieved next.
That will set gpptr, so we update that first - do_plotwindow
clobbered the gpptr settings. */
GSavePars(dd);
gpptr(dd)->xaxp[0] = dpptr(dd)->xaxp[0];
gpptr(dd)->xaxp[1] = dpptr(dd)->xaxp[1];
gpptr(dd)->xaxp[2] = dpptr(dd)->xaxp[2];
gpptr(dd)->yaxp[0] = dpptr(dd)->yaxp[0];
gpptr(dd)->yaxp[1] = dpptr(dd)->yaxp[1];
gpptr(dd)->yaxp[2] = dpptr(dd)->yaxp[2];
ProcessInlinePars(args, dd);
/* Retrieve relevant "par" values. */
switch(side) {
case 1:
case 3:
axp[0] = gpptr(dd)->xaxp[0];
axp[1] = gpptr(dd)->xaxp[1];
axp[2] = gpptr(dd)->xaxp[2];
usr[0] = dpptr(dd)->usr[0];
usr[1] = dpptr(dd)->usr[1];
logflag = dpptr(dd)->xlog;
nint = dpptr(dd)->lab[0];
break;
case 2:
case 4:
axp[0] = gpptr(dd)->yaxp[0];
axp[1] = gpptr(dd)->yaxp[1];
axp[2] = gpptr(dd)->yaxp[2];
usr[0] = dpptr(dd)->usr[2];
usr[1] = dpptr(dd)->usr[3];
logflag = dpptr(dd)->ylog;
nint = dpptr(dd)->lab[1];
break;
}
/* Deferred processing */
if (!R_FINITE(line)) {
/* Except that here mgp values are not relative to themselves */
line = gpptr(dd)->mgp[2];
lineoff = (int) line;
}
if (!R_FINITE(pos)) pos = NA_REAL; else lineoff = 0;
/* Determine the tickmark positions. Note that these may fall */
/* outside the plot window. We will clip them in the code below. */
create_at = isNull(at);
if (create_at) {
PROTECT(at = CreateAtVector(axp, usr, nint, logflag));
}
else {
if (isReal(at)) PROTECT(at = duplicate(at));
else PROTECT(at = coerceVector(at, REALSXP));
}
n = length(at);
/* Check/setup the tick labels. This can mean using user-specified */
/* labels, or encoding the "at" positions as strings. */
if (dolabels) {
if (length(lab) == 0)
lab = labelformat(at);
else {
if (create_at)
error(_("'labels' is supplied and not 'at'"));
if (!isExpression(lab)) lab = labelformat(lab);
}
if (length(at) != length(lab))
error(_("'at' and 'labels' lengths differ, %d != %d"),
length(at), length(lab));
}
PROTECT(lab);
/* Check there are no NA, Inf or -Inf values for tick positions. */
/* The code here is long-winded. Couldn't we just inline things */
/* below. Hmmm - we need the min and max of the finite values ... */
ind = (int *) R_alloc(n, sizeof(int));
for(i = 0; i < n; i++) ind[i] = i;
rsort_with_index(REAL(at), ind, n);
ntmp = 0;
for(i = 0; i < n; i++) {
if(R_FINITE(REAL(at)[i])) ntmp = i+1;
}
if (n > 0 && ntmp == 0)
error(_("no locations are finite"));
n = ntmp;
/* Ok, all systems are "GO". Let's get to it. */
/* At this point we know the value of "xaxt" and "yaxt",
* so we test to see whether the relevant one is "n".
* If it is, we just bail out at this point. */
if ((n == 0) ||
((side == 1 || side == 3) && gpptr(dd)->xaxt == 'n') ||
((side == 2 || side == 4) && gpptr(dd)->yaxt == 'n')) {
GRestorePars(dd);
UNPROTECT(4);
return R_NilValue;
}
gpptr(dd)->lty = lty;
gpptr(dd)->lwd = lwd;
gpptr(dd)->adj = R_FINITE(hadj) ? hadj : 0.5;
gpptr(dd)->font = (font == NA_INTEGER)? gpptr(dd)->fontaxis : font;
gpptr(dd)->cex = gpptr(dd)->cexbase * gpptr(dd)->cexaxis;
/* Draw the axis */
GMode(1, dd);
switch (side) {
case 1: /*--- x-axis -- horizontal --- */
case 3:
/* First set the clipping limits */
getxlimits(limits, dd);
/* Now override par("xpd") and force clipping to device region. */
gpptr(dd)->xpd = 2;
GetAxisLimits(limits[0], limits[1], logflag, &low, &high);
axis_low = GConvertX(fmin2(high, fmax2(low, REAL(at)[0])), USER, NFC, dd);
axis_high = GConvertX(fmin2(high, fmax2(low, REAL(at)[n-1])), USER, NFC, dd);
if (side == 1) {
if (R_FINITE(pos))
axis_base = GConvertY(pos, USER, NFC, dd);
else
axis_base = GConvertY(0.0, outer, NFC, dd)
- GConvertYUnits(line, LINES, NFC, dd);
if (R_FINITE(gpptr(dd)->tck)) {
double len, xu, yu;
if(gpptr(dd)->tck > 0.5)
len = GConvertYUnits(gpptr(dd)->tck, NPC, NFC, dd);
else {
xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
xu = (fabs(xu) < fabs(yu)) ? xu : yu;
len = GConvertYUnits(xu, INCHES, NFC, dd);
}
axis_tick = axis_base + len;
} else
axis_tick = axis_base +
GConvertYUnits(gpptr(dd)->tcl, LINES, NFC, dd);
}
else {
if (R_FINITE(pos))
axis_base = GConvertY(pos, USER, NFC, dd);
else
axis_base = GConvertY(1.0, outer, NFC, dd)
+ GConvertYUnits(line, LINES, NFC, dd);
if (R_FINITE(gpptr(dd)->tck)) {
double len, xu, yu;
if(gpptr(dd)->tck > 0.5)
len = GConvertYUnits(gpptr(dd)->tck, NPC, NFC, dd);
else {
xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
xu = (fabs(xu) < fabs(yu)) ? xu : yu;
len = GConvertYUnits(xu, INCHES, NFC, dd);
}
axis_tick = axis_base - len;
} else
axis_tick = axis_base -
GConvertYUnits(gpptr(dd)->tcl, LINES, NFC, dd);
}
if (doticks) {
gpptr(dd)->col = col;
if (lwd > 0.0)
GLine(axis_low, axis_base, axis_high, axis_base, NFC, dd);
gpptr(dd)->col = colticks;
gpptr(dd)->lwd = lwdticks;
if (lwdticks > 0) {
for (i = 0; i < n; i++) {
x = REAL(at)[i];
if (low <= x && x <= high) {
x = GConvertX(x, USER, NFC, dd);
GLine(x, axis_base, x, axis_tick, NFC, dd);
}
}
}
}
/* Tickmark labels. */
gpptr(dd)->col = gpptr(dd)->colaxis;
gap = GStrWidth("m", -1, NFC, dd); /* FIXUP x/y distance */
tlast = -1.0;
if (!R_FINITE(hadj)) {
if (gpptr(dd)->las == 2 || gpptr(dd)->las == 3) {
gpptr(dd)->adj = (side == 1) ? 1 : 0;
}
else gpptr(dd)->adj = 0.5;
}
if (side == 1) {
axis_lab = - axis_base
+ GConvertYUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
+ GConvertY(0.0, NPC, NFC, dd);
}
else { /* side == 3 */
axis_lab = axis_base
+ GConvertYUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
- GConvertY(1.0, NPC, NFC, dd);
}
axis_lab = GConvertYUnits(axis_lab, NFC, LINES, dd);
/* The order of processing is important here. */
/* We must ensure that the labels are drawn left-to-right. */
/* The logic here is getting way too convoluted. */
/* This needs a serious rewrite. */
if (gpptr(dd)->usr[0] > gpptr(dd)->usr[1]) {
istart = n - 1;
iend = -1;
incr = -1;
}
else {
istart = 0;
iend = n;
incr = 1;
}
for (i = istart; i != iend; i += incr) {
double padjval = REAL(padj)[i % npadj];
padjval = ComputePAdjValue(padjval, side, gpptr(dd)->las);
x = REAL(at)[i];
if (!R_FINITE(x)) continue;
temp = GConvertX(x, USER, NFC, dd);
if (dolabels) {
/* Clip tick labels to user coordinates. */
if (x > low && x < high) {
if (isExpression(lab)) {
GMMathText(VECTOR_ELT(lab, ind[i]), side,
axis_lab, 0, x, gpptr(dd)->las,
padjval, dd);
}
else {
label = STRING_ELT(lab, ind[i]);
if(label != NA_STRING) {
const char *ss = CHAR(label);
labw = GStrWidth(ss, 0, NFC, dd);
tnew = temp - 0.5 * labw;
/* Check room for perpendicular labels. */
if (gpptr(dd)->las == 2 ||
gpptr(dd)->las == 3 ||
tnew - tlast >= gap) {
GMtext(ss, getCharCE(label),
side, axis_lab, 0, x,
gpptr(dd)->las, padjval, dd);
tlast = temp + 0.5 *labw;
}
}
}
}
}
}
break;
case 2: /*--- y-axis -- vertical --- */
case 4:
/* First set the clipping limits */
getylimits(limits, dd);
/* Now override par("xpd") and force clipping to device region. */
gpptr(dd)->xpd = 2;
GetAxisLimits(limits[0], limits[1], logflag, &low, &high);
axis_low = GConvertY(fmin2(high, fmax2(low, REAL(at)[0])), USER, NFC, dd);
axis_high = GConvertY(fmin2(high, fmax2(low, REAL(at)[n-1])), USER, NFC, dd);
if (side == 2) {
if (R_FINITE(pos))
axis_base = GConvertX(pos, USER, NFC, dd);
else
axis_base = GConvertX(0.0, outer, NFC, dd)
- GConvertXUnits(line, LINES, NFC, dd);
if (R_FINITE(gpptr(dd)->tck)) {
double len, xu, yu;
if(gpptr(dd)->tck > 0.5)
len = GConvertXUnits(gpptr(dd)->tck, NPC, NFC, dd);
else {
xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
xu = (fabs(xu) < fabs(yu)) ? xu : yu;
len = GConvertXUnits(xu, INCHES, NFC, dd);
}
axis_tick = axis_base + len;
} else
axis_tick = axis_base +
GConvertXUnits(gpptr(dd)->tcl, LINES, NFC, dd);
}
else {
if (R_FINITE(pos))
axis_base = GConvertX(pos, USER, NFC, dd);
else
axis_base = GConvertX(1.0, outer, NFC, dd)
+ GConvertXUnits(line, LINES, NFC, dd);
if (R_FINITE(gpptr(dd)->tck)) {
double len, xu, yu;
if(gpptr(dd)->tck > 0.5)
len = GConvertXUnits(gpptr(dd)->tck, NPC, NFC, dd);
else {
xu = GConvertXUnits(gpptr(dd)->tck, NPC, INCHES, dd);
yu = GConvertYUnits(gpptr(dd)->tck, NPC, INCHES, dd);
xu = (fabs(xu) < fabs(yu)) ? xu : yu;
len = GConvertXUnits(xu, INCHES, NFC, dd);
}
axis_tick = axis_base - len;
} else
axis_tick = axis_base -
GConvertXUnits(gpptr(dd)->tcl, LINES, NFC, dd);
}
if (doticks) {
gpptr(dd)->col = col;
if (lwd > 0.0)
GLine(axis_base, axis_low, axis_base, axis_high, NFC, dd);
gpptr(dd)->col = colticks;
gpptr(dd)->lwd = lwdticks;
if (lwdticks > 0) {
for (i = 0; i < n; i++) {
y = REAL(at)[i];
if (low <= y && y <= high) {
y = GConvertY(y, USER, NFC, dd);
GLine(axis_base, y, axis_tick, y, NFC, dd);
}
}
}
}
/* Tickmark labels. */
gpptr(dd)->col = gpptr(dd)->colaxis;
gap = GStrWidth("m", CE_ANY, INCHES, dd);
gap = GConvertYUnits(gap, INCHES, NFC, dd);
tlast = -1.0;
if (!R_FINITE(hadj)) {
if (gpptr(dd)->las == 1 || gpptr(dd)->las == 2) {
gpptr(dd)->adj = (side == 2) ? 1 : 0;
}
else gpptr(dd)->adj = 0.5;
}
if (side == 2) {
axis_lab = - axis_base
+ GConvertXUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
+ GConvertX(0.0, NPC, NFC, dd);
}
else { /* side == 4 */
axis_lab = axis_base
+ GConvertXUnits(gpptr(dd)->mgp[1]-lineoff, LINES, NFC, dd)
- GConvertX(1.0, NPC, NFC, dd);
}
axis_lab = GConvertXUnits(axis_lab, NFC, LINES, dd);
/* The order of processing is important here. */
/* We must ensure that the labels are drawn left-to-right. */
/* The logic here is getting way too convoluted. */
/* This needs a serious rewrite. */
if (gpptr(dd)->usr[2] > gpptr(dd)->usr[3]) {
istart = n - 1;
iend = -1;
incr = -1;
}
else {
istart = 0;
iend = n;
incr = 1;
}
for (i = istart; i != iend; i += incr) {
double padjval = REAL(padj)[i % npadj];
padjval = ComputePAdjValue(padjval, side, gpptr(dd)->las);
y = REAL(at)[i];
if (!R_FINITE(y)) continue;
temp = GConvertY(y, USER, NFC, dd);
if (dolabels) {
/* Clip tick labels to user coordinates. */
if (y > low && y < high) {
if (isExpression(lab)) {
GMMathText(VECTOR_ELT(lab, ind[i]), side,
axis_lab, 0, y, gpptr(dd)->las,
padjval, dd);
}
else {
label = STRING_ELT(lab, ind[i]);
if(label != NA_STRING) {
const char *ss = CHAR(label);
labw = GStrWidth(ss, getCharCE(label), INCHES, dd);
labw = GConvertYUnits(labw, INCHES, NFC, dd);
tnew = temp - 0.5 * labw;
/* Check room for perpendicular labels. */
if (gpptr(dd)->las == 1 ||
gpptr(dd)->las == 2 ||
tnew - tlast >= gap) {
GMtext(ss, getCharCE(label),
side, axis_lab, 0, y,
gpptr(dd)->las, padjval, dd);
tlast = temp + 0.5 *labw;
}
}
}
}
}
}
break;
} /* end switch(side, ..) */
GMode(0, dd);
GRestorePars(dd);
UNPROTECT(4); /* lab, at, lab, padj again */
return at;
} /* Axis */