From 9542c3215a8f8cfee4a313b6c2fd03320e38e1de Mon Sep 17 00:00:00 2001 From: ripley Date: Fri, 29 Mar 2019 18:11:36 +0000 Subject: [PATCH] back out c76285: 10% failure rate on CRAN git-svn-id: https://svn.r-project.org/R/trunk@76298 00db46b3-68df-0310-9c12-caf00c1e9a41 --- src/library/grid/NAMESPACE | 21 +- src/library/grid/R/unit.R | 727 ++++++++----- src/library/grid/inst/doc/changes.txt | 8 - src/library/grid/man/unit.c.Rd | 3 +- src/library/grid/man/unit.pmin.Rd | 2 - src/library/grid/src/grid.c | 3 +- src/library/grid/src/grid.h | 33 +- src/library/grid/src/register.c | 9 - src/library/grid/src/unit.c | 1366 ++++++++++++------------- src/library/grid/tests/bugs.R | 4 +- tests/Examples/grid-Ex.Rout.save | 47 +- 11 files changed, 1170 insertions(+), 1053 deletions(-) diff --git a/src/library/grid/NAMESPACE b/src/library/grid/NAMESPACE index ebb56f0ccec..39fd464e2e9 100644 --- a/src/library/grid/NAMESPACE +++ b/src/library/grid/NAMESPACE @@ -33,8 +33,7 @@ export( "unit", "is.unit", - "unit.c", "unit.length", "unit.pmax", "unit.pmin", "unit.psum", "unit.rep", - + "unit.c", "unit.length", "unit.pmax", "unit.pmin", "unit.rep", "stringWidth", "stringHeight", "stringAscent", "stringDescent", "grobX", "grobY", "grobWidth", "grobHeight", "grobAscent", "grobDescent", @@ -133,6 +132,8 @@ S3method("[", "arrow") S3method("[", "gList") S3method("[", "gpar") S3method("[", "unit") +S3method("[", "unit.arithmetic") +S3method("[", "unit.list") S3method("[", "vpPath") S3method("[<-", "unit") S3method("Ops", "unit") @@ -141,15 +142,15 @@ S3method("as.character", "grob") S3method("as.character", "gList") S3method("as.character", "path") S3method("as.character", "unit") +S3method("as.character", "unit.arithmetic") +S3method("as.character", "unit.list") S3method("as.character", "viewport") S3method("as.character", "vpList") S3method("as.character", "vpStack") S3method("as.character", "vpTree") -S3method("as.double", "unit") -S3method("as.vector", "unit") -S3method("as.double", "simpleUnit") -S3method("as.vector", "simpleUnit") S3method("format", "unit") +S3method("format", "unit.arithmetic") +S3method("format", "unit.list") S3method("print", "grob") S3method("print", "gList") S3method("print", "unit") @@ -359,6 +360,10 @@ S3method("forceGrob", "default") S3method("forceGrob", "grob") S3method("forceGrob", "gTree") +S3method("absolute.units", "unit") +S3method("absolute.units", "unit.list") +S3method("absolute.units", "unit.arithmetic") + # S3 methods for internal generics that are used in calls to external fns S3method("depth", "viewport") S3method("depth", "vpList") @@ -402,9 +407,13 @@ S3method("rep", "unit") S3method("rep", "arrow") # S3 method for generic length (in base) +S3method("length", "unit") +S3method("length", "unit.arithmetic") +S3method("length", "unit.list") S3method("length", "arrow") # S3 method for generic str (in utils) +S3method("str", "unit.arithmetic") S3method("str", "arrow") S3method("makeContent", "default") diff --git a/src/library/grid/R/unit.R b/src/library/grid/R/unit.R index 74ab8190256..2da785b0c24 100644 --- a/src/library/grid/R/unit.R +++ b/src/library/grid/R/unit.R @@ -22,29 +22,24 @@ # 'unit(c(1,3,6), c("cm", "inch", "npc"))' # More complicated units are of the form 'unit(1, "string", "a string")' # or 'unit(1, "grob", a.grob)' -unit <- function(x, units, data = NULL) { - x <- as.numeric(x) - units <- as.character(units) - if (length(x) == 0 || length(units) == 0) - stop("'x' and 'units' must have length > 0") - if (is.null(data)) { - data <- list(NULL) - } else if (is.character(data) || is.language(data) || - is.grob(data) || inherits(data, "gPath")) { - data <- list(data) - } - .Call(C_constructUnits, x, data, units) +unit <- function(x, units, data=NULL) { + # Used to throw error if !is.numeric(x), but this way + # user can specify unit(NA, "npc") rather than + # having to specify unit(as.numeric(NA), "npc") + x <- as.numeric(x) + units <- as.character(units) + if (length(x) == 0 || length(units) == 0) + stop("'x' and 'units' must have length > 0") + valid.unit(x, units, recycle.data(data, FALSE, length(x), units)) } -single_unit <- function(x, data, valid_units) { - `class<-`(list( - list( - x, - data, - valid_units - ) - ), 'unit') +valid.unit <- function(x, units, data) { + structure(x, class = "unit", + "valid.unit" = valid.units(units), + "data" = valid.data(rep(units, length.out=length(x)), data), + "unit" = units) } + grid.convert <- function(x, unitTo, axisFrom="x", typeFrom="location", axisTo=axisFrom, typeTo=typeFrom, valueOnly=FALSE) { @@ -150,198 +145,258 @@ calcStringMetric <- function(text) { "vplayoutwidth", "vplayoutheight", "char", "grobx", "groby", "grobwidth", "grobheight", "grobascent", "grobdescent", - "mylines", "mychar", "mystrwidth", "mystrheight", - "sum", "min", "max") + "mylines", "mychar", "mystrwidth", "mystrheight") + +stringUnit <- function(unit) { + unit %in% c("strwidth", "strheight", "strascent", "strdescent") +} + +grobUnit <- function(unit) { + unit %in% c("grobx", "groby", "grobwidth", "grobheight", + "grobascent", "grobdescent") +} + +dataUnit <- function(unit) { + stringUnit(unit) | grobUnit(unit) +} + +recycle.data <- function(data, data.per, max.n, units) { + # FIRST STEP: check that data needs to be recycled + if (any(dataUnit(units))) { + # VERY IMPORTANT: Even if there is only one data specified + # and/or only one data needed, we want this to be a LIST of + # data values so that a single data and several data can be + # handled equivalently + # The test for whether it is only a single value currently + # consists of a check for mode="character" (i.e., a single + # string) or mode="expression" (i.e., a single expression) + # or class="grob" (i.e., a single grob) or class="gPath" + if (is.character(data) || is.language(data) || + is.grob(data) || inherits(data, "gPath")) + data <- list(data) + if (data.per) + n <- max.n + else + n <- length(data) + original <- data + length(data) <- n + n.o <- length(original) + if (n.o < n) + for (i in (n.o + 1L):n) + data[[i]] <- original[[(i - 1L) %% n.o + 1L]] + } + data +} + +# Make sure that and "str*" and "grob*" units have data +valid.data <- function(units, data) { + n <- length(units) + str.units <- stringUnit(units) + if (any(str.units)) + for (i in (1L:n)[str.units]) + if (!(length(data) >= i && + (is.character(data[[i]]) || is.language(data[[i]])))) + stop("no string supplied for 'strwidth/height' unit") + # Make sure that a grob has been specified + grob.units <- grobUnit(units) + if (any(grob.units)) + for (i in (1L:n)[grob.units]) { + if (!(length(data) >= i && + (is.grob(data[[i]]) || inherits(data[[i]], "gPath") || + is.character(data[[i]])))) + stop("no 'grob' supplied for 'grobwidth/height' unit") + if (is.character(data[[i]])) + data[[i]] <- gPath(data[[i]]) + if (inherits(data[[i]], "gPath")) + if (depth(data[[i]]) > 1) + stop("'gPath' must have depth 1 in 'grobwidth/height' units") + } + # Make sure that where no data is required, the data is NULL + if (!all(sapply(data[!(str.units | grob.units)], is.null))) + stop("non-NULL value supplied for plain unit") + data +} valid.units <- function(units) { .Call(C_validUnits, units) } -# Printing, formating, and coercion -unitDesc <- function(x, format = FALSE, ...) { - amount <- if (format) format(x[[1]], ...) else x[[1]] - unit <- units[as.character(x[[3]])] - if (unit %in% c('sum', 'min', 'max')) { - paste0(if (amount == 1) '' else paste0(amount, '*'), - unit, '(', paste(lapply(x[[2]], unitDesc, format = format, ...), collapse = ', '), ')') - } else { - paste0(amount, unit) - } -} as.character.unit <- function(x, ...) { - vapply(as.unit(x), unitDesc, character(1)) -} -as.double.unit <- function(x, ...) { - vapply(unclass(x), `[[`, numeric(1), 1L) + class(x) <- NULL + paste0(x, attr(x, "unit")) } -as.vector.unit <- as.double.unit -format.unit <- function(x, ...) { - vapply(as.unit(x), unitDesc, character(1), format = TRUE, ...) -} -print.unit <- function(x, ...) { - print(as.character(x), quote = FALSE, ...) - invisible(x) -} -as.double.simpleUnit <- function(x, ...) as.double(unclass(x), ...) -as.vector.simpleUnit <- function(x, ...) as.double(unclass(x), ...) -is.unit <- function(x) inherits(x, 'unit') -is.simpleUnit <- function(x) inherits(x, 'simpleUnit') -identicalUnits <- function(x) .Call(C_conformingUnits, x) - -as.unit <- function(x) { - .Call(C_asUnit, x) +format.unit <- function(x, ...) { + paste0(format(unclass(x), ...), attr(x, "unit")) } -str.unit <- function(object, ...) { - object <- as.unit(object) - for (i in seq_along(object)) { - unit <- object[[i]] - cat('[[', i, ']] Amount: ', unit[[1]], '; Unit: ', units[[as.character(unit[[3]])]], '; Data: ', if (is.null(unit[[2]])) 'none' else as.character(unit[[2]]), '\n', sep = '') - } -} ######################### # UNIT ARITHMETIC STUFF ######################### -Summary.unit <- function(..., na.rm=FALSE) { - units <- list(...) - ok <- switch(.Generic, "sum" = 201L, "min" = 202L, "max" = 203L, 0L) - if (ok == 0) - stop(gettextf("'Summary' function '%s' not meaningful for units", - .Generic), domain = NA) - # Optimise for simple units - identicalSimple <- identicalUnits(units) - if (!is.null(identicalSimple)) { - res <- switch( - .Generic, - "sum" = sum(unlist(units)), - "min" = min(unlist(units)), - "max" = max(unlist(units)), - ) - return(`attributes<-`(res, list( - class = c("simpleUnit", "unit"), - unit = identicalSimple - ))) - } - # NOTE that this call to unit.c makes sure that arg1 is - # a single unit object - x <- unlist(lapply(units, as.unit), recursive = FALSE) - - matchUnits <- .Call(C_matchUnit, x, ok) - nMatches <- length(matchUnits) - if (nMatches != 0) { - data <- lapply(x, `[[`, 2L) - amount <- vapply(x, .subset2, numeric(1), 1L)[matchUnits] - matchData <- unlist(data[matchUnits], recursive = FALSE) - for (i in seq_along(amount)) { - if (amount[i] != 1) matchData[[i]] <- matchData[[i]] * amount[i] - } - if (nMatches == length(x)) { - data <- matchData - } else { - data <- c(x[-matchUnits], matchData) - } - } else { - data <- x - } - single_unit(1, `class<-`(data, 'unit'), ok) +unit.arithmetic <- function(func.name, arg1, arg2=NULL) { + ua <- list(fname=func.name, arg1=arg1, arg2=arg2) + class(ua) <- c("unit.arithmetic", "unit") + ua } + Ops.unit <- function(e1, e2) { - ok <- switch(.Generic, "+"=TRUE, "-"=TRUE, "*"=TRUE, "/"=TRUE, FALSE) + ok <- switch(.Generic, "+"=TRUE, "-"=TRUE, "*"=TRUE, FALSE) if (!ok) stop(gettextf("operator '%s' not meaningful for units", .Generic), domain = NA) - # Unary - if (missing(e2)) { - if (.Generic %in% c('*', '/')) stop("'*' or '/' cannot be used as a unary operator") - if (.Generic == '-') { - if (is.simpleUnit(e1)) { - attr <- attributes(e1) - e1 <- -as.vector(e1) - attributes(e1) <- attr - } else { - e1 <- .Call(C_flipUnits, e1) - } - } - return(e1) - } - # Multiply - if (.Generic %in% c("*", "/")) { + if (.Generic == "*") # can only multiply a unit by a scalar if (nzchar(.Method[1L])) { - if (nzchar(.Method[2L])) stop("only one operand may be a unit") - if (!is.numeric(e2)) stop("non-unit operand must be numeric") - unit <- e1 - value <- e2 + if (nzchar(.Method[2L])) + stop("only one operand may be a unit") + else if (is.numeric(e2)) + # NOTE that we always put the scalar first + # Use as.numeric to force e2 to be REAL + unit.arithmetic(.Generic, as.numeric(e2), e1) + else + stop("non-unit operand must be numeric") } else { - if (!is.numeric(e1)) stop("non-unit operand must be numeric") - if (.Generic == "/") stop("can't divide with a unit") - unit <- e2 - value <- e1 + if (is.numeric(e1)) + # Use as.numeric to force e1 to be REAL + unit.arithmetic(.Generic, as.numeric(e1), e2) + else + stop("non-unit operand must be numeric") } - if (.Generic == "/") value <- 1 / value - if (is.simpleUnit(unit)) { - attr <- attributes(unit) - unit <- value * as.vector(unit) - attributes(unit) <- attr - } else { - unit <- .Call(C_multUnits, unit, value) - } - return(unit) - } - # Add and sub remains - if (!nzchar(.Method[1L]) && !nzchar(.Method[2L])) { - stop("both operands must be units") - } - if ((is.simpleUnit(e1) && is.simpleUnit(e2)) && (attr(e1, 'unit') == attr(e2, 'unit'))) { - attr <- attributes(e1) - unit <- switch( - .Generic, - "-" = as.vector(e1) - as.vector(e2), - "+" = as.vector(e1) + as.vector(e2) - ) - return(`attributes<-`(unit, attr)) - } - # Convert subtraction to addition - if (.Generic == '-') { - e2 <- -e2 - } - .Call(C_addUnits, as.unit(e1), as.unit(e2)) + else + # Check that both arguments are units + if (nzchar(.Method[1L]) && nzchar(.Method[2L])) + unit.arithmetic(.Generic, e1, e2) + else + stop("both operands must be units") } -unit.pmin <- function(...) { - pSummary(..., op = 'min') +## +## The na.rm arg is ignored here, and the S3 groupGeneric is +## Summary(x, ...) +## +Summary.unit <- function(..., na.rm=FALSE) { + # NOTE that this call to unit.c makes sure that arg1 is + # a single unit object + x <- unit.c(...) + ok <- switch(.Generic, "max"=TRUE, "min"=TRUE, "sum"=TRUE, FALSE) + if (!ok) + stop(gettextf("'Summary' function '%s' not meaningful for units", + .Generic), domain = NA) + unit.arithmetic(.Generic, x) +} + +is.unit.arithmetic <- function(x) { + inherits(x, "unit.arithmetic") +} + +as.character.unit.arithmetic <- function(x, ...) { + # bit too customised for my liking, but whatever ... + # NOTE that paste coerces arguments to mode character hence + # this will recurse. + fname <- x$fname + if (fname == "+" || fname == "-" || fname == "*") + paste0(x$arg1, fname, x$arg2) + else + paste0(fname, "(", paste(x$arg1, collapse=", "), ")") +} + +format.unit.arithmetic <- function(x, ...) { + fname <- x$fname + if (fname == "+" || fname == "-" || fname == "*") + paste0(format(x$arg1, ...), fname, format(x$arg2, ...)) + else + paste0(fname, "(", paste(format(x$arg1, ...), collapse=", "), ")") } unit.pmax <- function(...) { - pSummary(..., op = 'max') -} - -unit.psum <- function(...) { - pSummary(..., op = 'sum') -} - -pSummary <- function(..., op) { - units <- list(...) - # optimisation for simple units - identicalSimple <- identicalUnits(units) - if (!is.null(identicalSimple)) { - res <- switch( - op, - "sum" = Reduce(`+`, lapply(units, unclass)), - "min" = do.call(pmin, lapply(units, unclass)), - "max" = do.call(pmax, lapply(units, unclass)) - ) - return(`attributes<-`(res, list( - class = c("simpleUnit", "unit"), - unit = identicalSimple - ))) + + select.i <- function(unit, i) { + `[`(unit, i, top=FALSE) } - op <- switch(op, sum = 201L, min = 202L, max = 203L) - .Call(C_summaryUnits, units, op) + + x <- list(...) + numargs <- length(x) + if (numargs == 0L) + stop("no arguments where at least one expected") + # how long will the result be? + maxlength <- 0L + for (i in seq_len(numargs)) + if (length(x[[i]]) > maxlength) + maxlength <- length(x[[i]]) + # maxlength guaranteed >= 1 + result <- max(unit.list.from.list(lapply(x, select.i, 1L))) + if (maxlength > 1L) + for (i in 2L:maxlength) + result <- unit.c(result, max(unit.list.from.list(lapply(x, select.i, i)))) + result } +unit.pmin <- function(...) { + + select.i <- function(unit, i) { + `[`(unit, i, top=FALSE) + } + + x <- list(...) + numargs <- length(x) + if (numargs == 0L) + stop("Zero arguments where at least one expected") + # how long will the result be? + maxlength <- 0L + for (i in seq_len(numargs)) + if (length(x[[i]]) > maxlength) + maxlength <- length(x[[i]]) + # maxlength guaranteed >= 1 + result <- min(unit.list.from.list(lapply(x, select.i, 1L))) + if (maxlength > 1L) + for (i in 2L:maxlength) + result <- unit.c(result, min(unit.list.from.list(lapply(x, select.i, i)))) + result +} + +######################### +# UNIT LISTS +# The idea with these is to allow arbitrary combinations +# of unit objects and unit arithmetic objects +######################### + +# create a unit list from a unit, unit.arithmetic, or unit.list object +unit.list <- function(unit) { + if (is.unit.list(unit)) + unit + else + structure(class = c("unit.list", "unit"), + lapply(seq_along(unit), function(i) unit[i])) +} + +is.unit.list <- function(x) { + inherits(x, "unit.list") +} + +as.character.unit.list <- function(x, ...) { + ## *apply cannot work on 'x' directly because of "wrong" length()s + vapply(seq_along(x), function(i) as.character(x[[i]]), "") +} + +format.unit.list <- function(x, ...) { + vapply(seq_along(x), function(i) format(x[[i]], ...), "") +} + +######################### +# These work on any sort of unit object +######################### + +is.unit <- function(unit) { + inherits(unit, "unit") +} + +print.unit <- function(x, ...) { + print(as.character(x), quote=FALSE, ...) + invisible(x) +} + + ######################### # Unit subsetting ######################### @@ -352,39 +407,119 @@ pSummary <- function(..., op) { # this allows recycling beyond the end of the unit object # except at the top level -`[.unit` <- function(x, index, top = TRUE) { - attr <- attributes(x) - x <- unclass(x) - n <- length(x) - if (is.numeric(index) && any(index > n)) { - if (top) stop('index out of bounds ("unit" subsetting)', call. = FALSE) - index <- (seq_len(n)[index] - 1L) %% n + 1L +# NOTE that "unit" and "data" attributes will be recycled +`[.unit` <- function(x, index, top=TRUE, ...) { + this.length <- length(x) + if (is.logical(index)) + index <- which(index) + else { # Allow for negative integer index + if (any(index < 0)) { + if (any(index > 0)) + stop("cannot mix signs of indices") + else + index <- (1L:this.length)[index] + } + if (top && any(index > this.length)) + stop("index out of bounds ('unit' subsetting)") + } + cl <- class(x) + units <- attr(x, "unit") + valid.units <- attr(x, "valid.unit") + data <- attr(x, "data") + class(x) <- NULL + i_1 <- index - 1L + # The line below may seem slightly odd, but it should only be + # used to recycle values when this method is called to + # subset an argument in a unit.arithmetic object + x <- x[i_1 %% this.length + 1L] + attr(x, "unit") <- units[i_1 %% length(units) + 1L] + attr(x, "valid.unit") <- valid.units[i_1 %% length(valid.units) + 1L] + data.list <- data[i_1 %% length(data) + 1L] + attr(x, "data") <- data.list + class(x) <- cl + x +} + +# NOTE that units will be recycled to the length of the largest +# of the arguments +`[.unit.arithmetic` <- function(x, index, top=TRUE, ...) { + this.length <- length(x) + if (is.logical(index)) + index <- which(index) + else { # Allow for negative integer index + if (any(index < 0)) { + if (any(index > 0)) + stop("cannot mix signs of indices") + else + index <- (1L:this.length)[index] + } + if (top && any(index > this.length)) + stop("index out of bounds (unit arithmetic subsetting)") + } + repSummaryUnit <- function(x, n) { + val <- get(x$fname)(x$arg1) + newUnits <- lapply(integer(n), function(z) val) + class(newUnits) <- c("unit.list", "unit") + newUnits + } + + switch(x$fname, + "+"=`[`(x$arg1, (index - 1L) %% this.length + 1L, top=FALSE) + + `[`(x$arg2, (index - 1L) %% this.length + 1L, top=FALSE), + "-"=`[`(x$arg1, (index - 1L) %% this.length + 1L, top=FALSE) - + `[`(x$arg2, (index - 1L) %% this.length + 1L, top=FALSE), + # Recycle multiplier if necessary + "*"=`[`(x$arg1, (index - 1L) %% length(x$arg1) + 1L) * + `[`(x$arg2, (index - 1L) %% this.length + 1L, top=FALSE), + "min"=repSummaryUnit(x, length(index)), + "max"=repSummaryUnit(x, length(index)), + "sum"=repSummaryUnit(x, length(index))) +} + +`[.unit.list` <- function(x, index, top=TRUE, ...) { + this.length <- length(x) + if (is.logical(index)) + index <- which(index) + else { # Allow for negative integer index + if (any(index < 0)) { + if (any(index > 0)) + stop("cannot mix signs of indices") + else + index <- (1L:this.length)[index] } - x <- x[index] - `attributes<-`(x, attr) + if (top && any(index > this.length)) + stop("index out of bounds (unit list subsetting)") + } + structure(class = class(x), + unclass(x)[(index - 1L) %% this.length + 1L]) } + +# `[<-.unit` methods +# +# The basic approach is to convert everything to a unit.list, +# unclass (so everything is list), rely on list subassignment, reclass + `[<-.unit` <- function(x, i, value) { - if (!is.unit(value)) stop('value must be a unit object') - attr <- attributes(x) - simpleResult <- FALSE - if (is.simpleUnit(x)) { - if (!(is.simpleUnit(value) && attr(x, 'unit') == attr(value, 'unit'))) { - x <- as.unit(x) - value <- as.unit(value) - } else { - simpleResult <- TRUE - } - } else { - value <- as.unit(value) - } - x <- unclass(x) - x[i] <- value - if (simpleResult) { - attributes(x) <- attr - } else { - class(x) <- "unit" - } - x + if (!is.unit(value)) + stop("Value being assigned must be a unit") + valueList <- unclass(unit.list(value)) + xList <- unclass(unit.list(x)) + xList[i] <- valueList + class(xList) <- c("unit.list", "unit") + xList +} + +######################### +# str() method +######################### + +# Should work fine on atomic units and on unit.list +# The problem arises with unit.arithmetic, which are stored as lists +# but act like vectors +# (e.g., report length greater than number of list components) +str.unit.arithmetic <- function(object, ...) { + cat("Class 'unit.arithmetic' [1:", length(object), "] ", sep="") + str(unclass(object), ...) } ######################### @@ -402,24 +537,51 @@ pSummary <- function(..., op) { # If any arguments are unit.arithmetic or unit.list, then the result will be # unit.list - -unit.c <- function(..., check = TRUE) { - x <- list(...) - identicalSimple <- identicalUnits(x) - if (!is.null(identicalSimple)) { - `attributes<-`(unlist(x), list(class = c('simpleUnit', 'unit'), unit = identicalSimple)) - } else { - `class<-`(unlist(lapply(x, as.unit), recursive = FALSE), 'unit') - } +unit.c <- function(...) { + x <- list(...) + if (!all(sapply(x, is.unit))) + stop("it is invalid to combine 'unit' objects with other types") + listUnit <- function(x) { + inherits(x, "unit.list") || + inherits(x, "unit.arithmetic") + } + ual <- any(sapply(x, listUnit)) + if (ual) + unit.list.from.list(x) + else { + values <- unlist(x) + unitUnits <- function(x) { + rep(attr(x, "unit"), length.out=length(x)) + } + units <- unlist(lapply(x, unitUnits)) + unitData <- function(x) { + data <- attr(x, "data") + if (is.null(data)) + vector("list", length(x)) + else + recycle.data(data, TRUE, length(x), unitUnits(x)) + } + data <- do.call("c", lapply(x, unitData)) + unit(values, units, data=data) + } } +unit.list.from.list <- function(x) + structure(class = c("unit.list", "unit"), + do.call("c", lapply(x, unit.list))) + + ######################### # rep'ing unit objects ######################### -rep.unit <- function(x, times = 1, length.out = NA, each = 1, ...) { - index <- rep(seq_along(x), times = times, length.out = length.out, each = each) - x[index] +rep.unit <- function(x, times=1, length.out=NA, each=1, ...) { + if (length(x) == 0) + stop("invalid 'unit' object") + + # Determine an approprite index, then call subsetting code + repIndex <- rep(seq_along(x), times=times, length.out=length.out, each=each) + x[repIndex, top=FALSE] } # Vestige from when rep() was not generic @@ -433,7 +595,25 @@ unit.rep <- function (x, ...) # Length of unit objects ######################### -# Vestige of when length was not generic and a custom length method was needed +length.unit <- function(x) { + length(unclass(x)) +} + +length.unit.list <- function(x) { + length(unclass(x)) +} + +length.unit.arithmetic <- function(x) { + switch(x$fname, + "+"=max(length(x$arg1), length(x$arg2)), + "-"=max(length(x$arg1), length(x$arg2)), + "*"=max(length(x$arg1), length(x$arg2)), + "min" = 1L, + "max" = 1L, + "sum" = 1L) +} + +# Vestige of when length was not generic unit.length <- function(unit) { warning("'unit.length' has been deprecated in favour of a unit method for the generic length function", domain = NA) length(unit) @@ -636,59 +816,48 @@ grobDescent.default <- function(x) { # on parent's drawing context or size) ######################### +# Only deals with unit of length() 1 +absolute <- function(unit) { + !is.na(match(attr(unit, "unit"), + c("cm", "inches", "lines", "null", + "mm", "points", "picas", "bigpts", + "dida", "cicero", "scaledpts", + "strwidth", "strheight", "strascent", "strdescent", "char", + "mylines", "mychar", "mystrwidth", "mystrheight", + # pseudonyms (from unit.c) + "centimetre", "centimetres", "centimeter", "centimeters", + "in", "inch", + "line", + "millimetre", "millimetres", "millimeter", "millimeters", + "point", "pt"))) +} + +# OLD absolute.unit absolute.units <- function(unit) { - .Call(C_absoluteUnits, unit) -} - -# Lookup table for unit ids -# This table MUST correspond to the enumeration in grid.h -units <- list( - '0' = "npc", - '1' = "cm", - '2' = "inches", - '3' = "lines", - '4' = "native", - '5' = "null", - '6' = "snpc", - '7' = "mm", - '8' = "points", - '9' = "picas", - '10' = "bigpts", - '11' = "dida", - '12' = "cicero", - '13' = "scaledpts", - '14' = "strwidth", - '15' = "strheight", - '16' = "strascent", - '17' = "strdescent", - '18' = "char", - '19' = "grobx", - '20' = "groby", - '21' = "grobwidth", - '22' = "grobheight", - '23' = "grobascent", - '24' = "grobdescent", - - '103' = "mylines", - '104' = "mychar", - '105' = "mystrwidth", - '106' = "mystrheight", - - '201' = "sum", - '202' = "min", - '203' = "max", - - '1001' = "centimetre", - '1001' = "centimetres", - '1001' = "centimeter", - '1001' = "centimeters", - '1002' = "in", - '1002' = "inch", - '1003' = "line", - '1007' = "millimetre", - '1007' = "millimetres", - '1007' = "millimeter", - '1007' = "millimeters", - '1008' = "point", - '1008' = "pt" -) + UseMethod("absolute.units") +} + +absolute.units.unit <- function(unit) { + n <- length(unit) + new.unit <- if (absolute(unit[1L])) unit[1L] else unit(1, "null") + if(n > 1) for(i in 2L:n) + new.unit <- unit.c(new.unit, absolute.units(unit[i])) + new.unit +} + +absolute.units.unit.list <- function(unit) { + structure(class = class(unit), + lapply(unit, absolute.units)) +} + +absolute.units.unit.arithmetic <- function(unit) { + switch(unit$fname, + "+"=unit.arithmetic("+", absolute.units(unit$arg1), + absolute.units(unit$arg2)), + "-"=unit.arithmetic("-", absolute.units(unit$arg1), + absolute.units(unit$arg2)), + "*"=unit.arithmetic("*", unit$arg1, absolute.units(unit$arg2)), + "min"=unit.arithmetic("min", absolute.units(unit$arg1)), + "max"=unit.arithmetic("max", absolute.units(unit$arg1)), + "sum"=unit.arithmetic("sum", absolute.units(unit$arg1))) +} diff --git a/src/library/grid/inst/doc/changes.txt b/src/library/grid/inst/doc/changes.txt index 107464c6a5a..b22e7a9f79c 100644 --- a/src/library/grid/inst/doc/changes.txt +++ b/src/library/grid/inst/doc/changes.txt @@ -41,14 +41,6 @@ Changes from grid_3.5.* to grid_3.6.0: Contributed by Thomas Lin Pedersen. -9. Change to internal representation of "unit" objects, to obtain - noticeable speed improvements. - - "unit arithmetic" units print differently, but otherwise there - should be no impact at user level. - - Contributed by Thomas Lin Pedersen. - Changes from grid_3.4.* to grid_3.5.0: ------------------------------------- diff --git a/src/library/grid/man/unit.c.Rd b/src/library/grid/man/unit.c.Rd index 8761e028dae..f20c894cb05 100644 --- a/src/library/grid/man/unit.c.Rd +++ b/src/library/grid/man/unit.c.Rd @@ -11,11 +11,10 @@ unit objects specified as arguments. } \usage{ -unit.c(..., check = TRUE) +unit.c(...) } \arguments{ \item{\dots}{An arbitrary number of unit objects.} - \item{check}{Should input be checked? If you are certain all arguments are unit objects this can be set to \code{FALSE}} } \value{ An object of class \code{unit}. diff --git a/src/library/grid/man/unit.pmin.Rd b/src/library/grid/man/unit.pmin.Rd index aa0573043e5..a31365fa78a 100644 --- a/src/library/grid/man/unit.pmin.Rd +++ b/src/library/grid/man/unit.pmin.Rd @@ -6,7 +6,6 @@ \name{unit.pmin} \alias{unit.pmin} \alias{unit.pmax} -\alias{unit.psum} \title{ Parallel Unit Minima and Maxima } \description{ Returns a unit object whose i'th value is the minimum (or maximum) @@ -15,7 +14,6 @@ \usage{ unit.pmin(...) unit.pmax(...) -unit.psum(...) } \arguments{ \item{\dots}{ One or more unit objects. } diff --git a/src/library/grid/src/grid.c b/src/library/grid/src/grid.c index 3711af6a6cd..5c354abaa3d 100644 --- a/src/library/grid/src/grid.c +++ b/src/library/grid/src/grid.c @@ -1137,7 +1137,8 @@ SEXP L_convert(SEXP x, SEXP whatfrom, * In these cases do NOT transform thru INCHES * (to avoid divide-by-zero, but still do something useful) */ - relConvert = ((unitUnit(x, i) == L_NATIVE || unitUnit(x, i) == L_NPC) && + relConvert = (!isUnitArithmetic(x) && !isUnitList(x) && + (unitUnit(x, i) == L_NATIVE || unitUnit(x, i) == L_NPC) && (TOunit == L_NATIVE || TOunit == L_NPC) && ((FROMaxis == TOaxis) || (FROMaxis == 0 && TOaxis == 2) || diff --git a/src/library/grid/src/grid.h b/src/library/grid/src/grid.h index cf23e5d4d26..ef7e8e98f38 100644 --- a/src/library/grid/src/grid.h +++ b/src/library/grid/src/grid.h @@ -138,13 +138,6 @@ #define GRID_ARROWENDS 2 #define GRID_ARROWTYPE 3 -/* - * Helpers for unit types - */ -#define uValue(X) REAL(VECTOR_ELT(X, 0))[0] -#define uData(X) VECTOR_ELT(X, 1) -#define uUnit(X) INTEGER(VECTOR_ELT(X, 2))[0] - typedef double LTransform[3][3]; typedef double LLocation[3]; @@ -201,20 +194,9 @@ typedef enum { L_MYLINES = 103, L_MYCHAR = 104, L_MYSTRINGWIDTH = 105, - L_MYSTRINGHEIGHT = 106, - /* - * Arithmetic units - */ - L_SUM = 201, - L_MIN = 202, - L_MAX = 203 + L_MYSTRINGHEIGHT = 106 } LUnit; -#define isAbsolute(X) ((X > 1000 || (X >= L_MYLINES && X <= L_MYSTRINGHEIGHT) || (X < L_GROBX && X > L_NPC && X != L_NATIVE && X != L_SNPC))) -#define isArith(X) (X >= L_SUM && X <= L_MAX) -#define isStringUnit(X) (X >= L_STRINGWIDTH && X <= L_STRINGDESCENT) -#define isGrobUnit(X) (X >= L_GROBX && X <= L_GROBDESCENT) - typedef enum { L_LEFT = 0, L_RIGHT = 1, @@ -353,6 +335,10 @@ void location(double x, double y, LLocation v); void trans(LLocation vin, LTransform m, LLocation vout); /* From unit.c */ +int isUnitArithmetic(SEXP ua); + +int isUnitList(SEXP ul); + SEXP unit(double value, int unit); double unitValue(SEXP unit, int index); @@ -652,15 +638,6 @@ SEXP L_xsplinePoints(SEXP x, SEXP y, SEXP s, SEXP o, SEXP a, SEXP rep, /* From unit.c */ SEXP validUnits(SEXP units); -SEXP constructUnits(SEXP amount, SEXP data, SEXP unit); -SEXP asUnit(SEXP simpleUnit); -SEXP conformingUnits(SEXP unitList); -SEXP matchUnit(SEXP units, SEXP unit); -SEXP addUnits(SEXP u1, SEXP u2); -SEXP multUnits(SEXP units, SEXP values); -SEXP flipUnits(SEXP units); -SEXP absoluteUnits(SEXP units); -SEXP summaryUnits(SEXP units, SEXP op_type); /* From gpar.c */ SEXP L_getGPar(void); diff --git a/src/library/grid/src/register.c b/src/library/grid/src/register.c index 8b1a7984340..41d8cffb815 100644 --- a/src/library/grid/src/register.c +++ b/src/library/grid/src/register.c @@ -87,15 +87,6 @@ static const R_CallMethodDef callMethods[] = { LCALLDEF(xsplinePoints, 8), LCALLDEF(stringMetric, 1), {"validUnits", (DL_FUNC) &validUnits, 1}, - {"constructUnits", (DL_FUNC) &constructUnits, 3}, - {"asUnit", (DL_FUNC) &asUnit, 1}, - {"conformingUnits", (DL_FUNC) &conformingUnits, 1}, - {"matchUnit", (DL_FUNC) &matchUnit, 2}, - {"addUnits", (DL_FUNC) &addUnits, 2}, - {"multUnits", (DL_FUNC) &multUnits, 2}, - {"flipUnits", (DL_FUNC) &flipUnits, 1}, - {"absoluteUnits", (DL_FUNC) &absoluteUnits, 1}, - {"summaryUnits", (DL_FUNC) &summaryUnits, 2}, { NULL, NULL, 0 } }; diff --git a/src/library/grid/src/unit.c b/src/library/grid/src/unit.c index c2140e943c7..ff0f09ab38c 100644 --- a/src/library/grid/src/unit.c +++ b/src/library/grid/src/unit.c @@ -23,63 +23,148 @@ #include #include +int isUnitArithmetic(SEXP ua) { + return inherits(ua, "unit.arithmetic"); +} + +int isUnitList(SEXP ul) { + return inherits(ul, "unit.list"); +} + /* Function to build a single-value unit SEXP internally. * Cannot build units requiring data as yet. */ SEXP unit(double value, int unit) { - SEXP units = PROTECT(allocVector(VECSXP, 1)); - SEXP u = SET_VECTOR_ELT(units, 0, allocVector(VECSXP, 3)); - SET_VECTOR_ELT(u, 0, ScalarReal(value)); - SET_VECTOR_ELT(u, 1, R_NilValue); - SET_VECTOR_ELT(u, 2, ScalarInteger(unit)); - SEXP cl = PROTECT(mkString("unit")); - classgets(units, cl); - UNPROTECT(2); - return units; -} - -int isSimpleUnit(SEXP unit) { - return inherits(unit, "simpleUnit"); + SEXP u, units, classname; + PROTECT(u = ScalarReal(value)); + PROTECT(units = ScalarInteger(unit)); + /* NOTE that we do not set the "unit" attribute */ + setAttrib(u, install("valid.unit"), units); + setAttrib(u, install("data"), R_NilValue); + PROTECT(classname = mkString("unit")); + classgets(u, classname); + UNPROTECT(3); + return u; } /* Accessor functions for unit objects */ -/* - * This extracts the underlying scalar unit list structure from the unit vector - */ -SEXP unitScalar(SEXP unit, int index) { - int i = index % LENGTH(unit); - if (isSimpleUnit(unit)) { - SEXP newUnit = PROTECT(allocVector(VECSXP, 3)); - SET_VECTOR_ELT(newUnit, 0, Rf_ScalarReal(REAL(unit)[i])); - SET_VECTOR_ELT(newUnit, 1, R_NilValue); - SET_VECTOR_ELT(newUnit, 2, Rf_ScalarInteger(INTEGER(getAttrib(unit, install("unit")))[0])); - UNPROTECT(1); - return newUnit; - } - return VECTOR_ELT(unit, i); -} +/* + * This is an attempt to extract a single numeric value from + * a unit. This is ONLY designed for use on "simple" units + * (i.e., NOT unitLists or unitArithmetics) + */ double unitValue(SEXP unit, int index) { - if (isSimpleUnit(unit)) return REAL(unit)[index % LENGTH(unit)]; - return uValue(unitScalar(unit, index)); + /* Recycle values if necessary (used in unit arithmetic) + */ + int n = LENGTH(unit); + return numeric(unit, index % n); } int unitUnit(SEXP unit, int index) { - if (isSimpleUnit(unit)) return INTEGER(getAttrib(unit, install("unit")))[0]; - return uUnit(unitScalar(unit, index)); + SEXP units = getAttrib(unit, install("valid.unit")); + /* Recycle units if necessary + */ + int n = LENGTH(units); + return INTEGER(units)[index % n]; } SEXP unitData(SEXP unit, int index) { - if (isSimpleUnit(unit)) return R_NilValue; - return uData(unitScalar(unit, index)); + SEXP result; + SEXP data = getAttrib(unit, install("data")); + if (isNull(data)) + result = R_NilValue; + else if(TYPEOF(data) == VECSXP) { + /* Recycle data if necessary + */ + int n = LENGTH(data); + result = VECTOR_ELT(data, index % n); + } else { + warning("unit attribute 'data' is of incorrect type"); + return R_NilValue; + } + return result; } -/* Old alternative to LENGTH when using that didn't work on all unit struct +/* Accessor functions for unit arithmetic object */ -int unitLength(SEXP u) { - return LENGTH(u); +const char* fName(SEXP ua) { + return CHAR(STRING_ELT(getListElement(ua, "fname"), 0)); +} + +SEXP arg1(SEXP ua) { + return getListElement(ua, "arg1"); +} + +SEXP arg2(SEXP ua) { + return getListElement(ua, "arg2"); +} + +int fNameMatch(SEXP ua, char *aString) { + return !strcmp(fName(ua), aString); +} + +int addOp(SEXP ua) { + return fNameMatch(ua, "+"); +} + +int minusOp(SEXP ua) { + return fNameMatch(ua, "-"); +} + +int timesOp(SEXP ua) { + return fNameMatch(ua, "*"); +} + +int fOp(SEXP ua) { + return addOp(ua) || minusOp(ua) || timesOp(ua); +} + +int minFunc(SEXP ua) { + return fNameMatch(ua, "min"); +} + +int maxFunc(SEXP ua) { + return fNameMatch(ua, "max"); +} + +int sumFunc(SEXP ua) { + return fNameMatch(ua, "sum"); +} + +/* Functions in lattice.c should use this to determine the length + * of a unit/unitArithmetic object rather than just LENGTH. + */ +int unitLength(SEXP u) +{ + int result = 0; + if (isUnitList(u)) { + result = LENGTH(u); + } else if (isUnitArithmetic(u)) { + if (fOp(u)) { + if (timesOp(u)) { + /* + * arg1 is always the numeric vector + */ + int n1 = LENGTH(arg1(u)); + int n2 = unitLength(arg2(u)); + result = (n1 > n2) ? n1 : n2; + } else { /* must be "+" or "-" */ + int n1 = unitLength(arg1(u)); + int n2 = unitLength(arg2(u)); + result = (n1 > n2) ? n1 : n2; + } + } else { /* must be "min" or "max" or "sum" */ + result = 1; /* unitLength(arg1(u)); */ + } + } else if (inherits(u, "unit")) { /* a "plain" unit object */ + result = LENGTH(u); + } else { + error(_("object is not a unit, unit.list, or unitArithmetic object")); + } + return result; } @@ -126,65 +211,83 @@ static double evaluateNullUnit(double value, double thisCM, /* * Evaluate a "null" _unit_ * This is used by layout code to get a single "null" _value_ - * from a pureNullUnit + * from a pureNullUnit (which may be a unitList or a unitArithmetic) * * This must ONLY be called on a unit which has passed the * pureNullUnit test below. */ double pureNullUnitValue(SEXP unit, int index) { - double result = 0; - int i, n, u = unitUnit(unit, index); - double temp, value = unitValue(unit, index); - SEXP data; - switch(u) { - case L_SUM: - data = unitData(unit, index); - n = unitLength(data); - for (i = 0; i < n; i++) { - result += pureNullUnitValue(data, i); - } - result *= value; - break; - case L_MIN: - data = unitData(unit, index); - n = unitLength(data); - result = DBL_MAX; - for (i = 0; i < n; i++) { - temp = pureNullUnitValue(data, i); - if (temp < result) result = temp; - } - result *= value; - break; - case L_MAX: - data = unitData(unit, index); - n = unitLength(data); - result = DBL_MIN; - for (i = 0; i < n; i++) { - temp = pureNullUnitValue(data, i); - if (temp > result) result = temp; - } - result *= value; - break; - default: - result = value; - break; - } - return result; + double result = 0; + if (isUnitArithmetic(unit)) { + int i; + if (addOp(unit)) { + result = pureNullUnitValue(arg1(unit), index) + + pureNullUnitValue(arg2(unit), index); + } + else if (minusOp(unit)) { + result = pureNullUnitValue(arg1(unit), index) - + pureNullUnitValue(arg2(unit), index); + } + else if (timesOp(unit)) { + result = REAL(arg1(unit))[index] * + pureNullUnitValue(arg2(unit), index); + } + else if (minFunc(unit)) { + int n = unitLength(arg1(unit)); + double temp = DBL_MAX; + result = pureNullUnitValue(arg1(unit), 0); + for (i=1; i result) + result = temp; + } + } + else if (sumFunc(unit)) { + int n = unitLength(arg1(unit)); + result = 0.0; + for (i=0; i result) - result = temp; - } - result *= value; - break; - default: - nullamode = nullAMode ? nullAMode : L_plain; - result = transformLocation(value, unit, data, - vpc.xscalemin, vpc.xscalemax, gc, - widthCM, heightCM, - nullLMode, - nullamode, - dd); - } - - return result; + double result; + int unit; + SEXP data; + if (isUnitArithmetic(x)) + result = transformXArithmetic(x, index, vpc, gc, + widthCM, heightCM, nullLMode, dd); + else if (isUnitList(x)) { + int n = unitLength(x); + result = transformX(VECTOR_ELT(x, index % n), 0, vpc, gc, + widthCM, heightCM, nullLMode, nullAMode, dd); + } else { /* Just a plain unit */ + int nullamode; + if (nullAMode == 0) + nullamode = L_plain; + else + nullamode = nullAMode; + result = unitValue(x, index); + unit = unitUnit(x, index); + PROTECT(data = unitData(x, index)); + result = transformLocation(result, unit, data, + vpc.xscalemin, vpc.xscalemax, gc, + widthCM, heightCM, + nullLMode, + nullamode, + dd); + UNPROTECT(1); + } + return result; } +double transformYArithmetic(SEXP y, int index, + LViewportContext vpc, + const pGEcontext gc, + double widthCM, double heightCM, + int nullLMode, pGEDevDesc dd); + double transformY(SEXP y, int index, LViewportContext vpc, const pGEcontext gc, double widthCM, double heightCM, int nullLMode, int nullAMode, pGEDevDesc dd) { - double result; - int i, n, nullamode, unit = unitUnit(y, index); - double temp, value = unitValue(y, index); - SEXP data = unitData(y, index); - switch (unit) { - case L_SUM: - n = unitLength(data); - result = 0.0; - for (i = 0; i < n; i++) { - result += transformY(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_summing, dd); - } - result *= value; - break; - case L_MIN: - n = unitLength(data); - result = DBL_MAX; - for (i = 0; i < n; i++) { - temp = transformY(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_minimising, - dd); - if (temp < result) result = temp; - } - result *= value; - break; - case L_MAX: - n = unitLength(data); - result = DBL_MIN; - for (i = 0; i < n; i++) { - temp = transformY(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_maximising, - dd); - if (temp > result) - result = temp; - } - result *= value; - break; - default: - nullamode = nullAMode ? nullAMode : L_plain; - result = transformLocation(value, unit, data, - vpc.yscalemin, vpc.yscalemax, gc, - heightCM, widthCM, - nullLMode, - nullamode, - dd); - } - - return result; + double result; + int unit; + SEXP data; + if (isUnitArithmetic(y)) + result = transformYArithmetic(y, index, vpc, gc, + widthCM, heightCM, nullLMode, dd); + else if (isUnitList(y)) { + int n = unitLength(y); + result = transformY(VECTOR_ELT(y, index % n), 0, vpc, gc, + widthCM, heightCM, nullLMode, nullAMode, dd); + } else { /* Just a unit object */ + int nullamode; + if (nullAMode == 0) + nullamode = L_plain; + else + nullamode = nullAMode; + result = unitValue(y, index); + unit = unitUnit(y, index); + PROTECT(data = unitData(y, index)); + result = transformLocation(result, unit, data, + vpc.yscalemin, vpc.yscalemax, gc, + heightCM, widthCM, + nullLMode, + nullamode, + dd); + UNPROTECT(1); + } + return result; } double transformDimension(double dim, int unit, SEXP data, @@ -955,122 +1050,409 @@ double transformDimension(double dim, int unit, SEXP data, } return result; } + +double transformWidthArithmetic(SEXP width, int index, + LViewportContext vpc, + const pGEcontext gc, + double widthCM, double heightCM, + int nullLMode, pGEDevDesc dd); + double transformWidth(SEXP width, int index, LViewportContext vpc, const pGEcontext gc, double widthCM, double heightCM, int nullLMode, int nullAMode, pGEDevDesc dd) { - double result; - int i, n, nullamode, unit = unitUnit(width, index); - double temp, value = unitValue(width, index); - SEXP data = unitData(width, index); - switch (unit) { - case L_SUM: - n = unitLength(data); - result = 0.0; - for (i = 0; i < n; i++) { - result += transformWidth(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_summing, dd); - } - result *= value; - break; - case L_MIN: - n = unitLength(data); - result = DBL_MAX; - for (i = 0; i < n; i++) { - temp = transformWidth(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_minimising, - dd); - if (temp < result) result = temp; - } - result *= value; - break; - case L_MAX: - n = unitLength(data); - result = DBL_MIN; - for (i = 0; i < n; i++) { - temp = transformWidth(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_maximising, - dd); - if (temp > result) - result = temp; - } - result *= value; - break; - default: - nullamode = nullAMode ? nullAMode : L_plain; - result = transformDimension(value, unit, data, - vpc.xscalemin, vpc.xscalemax, gc, - widthCM, heightCM, - nullLMode, - nullamode, - dd); - } - - return result; + double result; + int unit; + SEXP data; + if (isUnitArithmetic(width)) + result = transformWidthArithmetic(width, index, vpc, gc, + widthCM, heightCM, nullLMode, dd); + else if (isUnitList(width)) { + int n = unitLength(width); + result = transformWidth(VECTOR_ELT(width, index % n), 0, vpc, gc, + widthCM, heightCM, nullLMode, nullAMode, dd); + } else { /* Just a unit object */ + int nullamode; + if (nullAMode == 0) + nullamode = L_plain; + else + nullamode = nullAMode; + result = unitValue(width, index); + unit = unitUnit(width, index); + PROTECT(data = unitData(width, index)); + result = transformDimension(result, unit, data, + vpc.xscalemin, vpc.xscalemax, gc, + widthCM, heightCM, + nullLMode, + nullamode, + dd); + UNPROTECT(1); + } + return result; } +double transformHeightArithmetic(SEXP height, int index, + LViewportContext vpc, + const pGEcontext gc, + double widthCM, double heightCM, + int nullLMode, pGEDevDesc dd); + double transformHeight(SEXP height, int index, LViewportContext vpc, const pGEcontext gc, double widthCM, double heightCM, int nullLMode, int nullAMode, pGEDevDesc dd) { - double result; - int i, n, nullamode, unit = unitUnit(height, index); - double temp, value = unitValue(height, index); - SEXP data = unitData(height, index); - switch (unit) { - case L_SUM: - n = unitLength(data); - result = 0.0; - for (i = 0; i < n; i++) { - result += transformHeight(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_summing, dd); - } - result *= value; - break; - case L_MIN: - n = unitLength(data); - result = DBL_MAX; - for (i = 0; i < n; i++) { - temp = transformHeight(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_minimising, - dd); - if (temp < result) result = temp; - } - result *= value; - break; - case L_MAX: - n = unitLength(data); - result = DBL_MIN; - for (i = 0; i < n; i++) { - temp = transformHeight(data, i, vpc, gc, - widthCM, heightCM, - nullLMode, L_maximising, - dd); - if (temp > result) - result = temp; - } - result *= value; - break; - default: - nullamode = nullAMode ? nullAMode : L_plain; - result = transformDimension(value, unit, data, - vpc.yscalemin, vpc.yscalemax, gc, - heightCM, widthCM, - nullLMode, - nullamode, - dd); + double result; + int unit; + SEXP data; + if (isUnitArithmetic(height)) + result = transformHeightArithmetic(height, index, vpc, gc, + widthCM, heightCM, nullLMode, dd); + else if (isUnitList(height)) { + int n = unitLength(height); + result = transformHeight(VECTOR_ELT(height, index % n), 0, vpc, gc, + widthCM, heightCM, nullLMode, nullAMode, dd); + } else { /* Just a unit object */ + int nullamode; + if (nullAMode == 0) + nullamode = L_plain; + else + nullamode = nullAMode; + result = unitValue(height, index); + unit = unitUnit(height, index); + PROTECT(data = unitData(height, index)); + result = transformDimension(result, unit, data, + vpc.yscalemin, vpc.yscalemax, gc, + heightCM, widthCM, + nullLMode, + nullamode, + dd); + UNPROTECT(1); + } + return result; +} + +double transformXArithmetic(SEXP x, int index, + LViewportContext vpc, + const pGEcontext gc, + double widthCM, double heightCM, + int nullLMode, pGEDevDesc dd) +{ + int i; + double result = 0; + if (addOp(x)) { + result = transformX(arg1(x), index, vpc, gc, + widthCM, heightCM, + nullLMode, L_adding, + dd) + + transformX(arg2(x), index, vpc, gc, + widthCM, heightCM, + nullLMode, L_adding, + dd); + } + else if (minusOp(x)) { + result = transformX(arg1(x), index, vpc, gc, + widthCM, heightCM, + nullLMode, L_subtracting, + dd) - + transformX(arg2(x), index, vpc, gc, + widthCM, heightCM, + nullLMode, L_subtracting, + dd); + } + else if (timesOp(x)) { + result = REAL(arg1(x))[index % LENGTH(arg1(x))] * + transformX(arg2(x), index, vpc, gc, + widthCM, heightCM, + nullLMode, L_multiplying, dd); + } + else if (minFunc(x)) { + int n = unitLength(arg1(x)); + double temp = DBL_MAX; + result = transformX(arg1(x), 0, vpc, gc, + widthCM, heightCM, + nullLMode, L_minimising, + dd); + for (i=1; i result) + result = temp; } - - return result; + } + else if (sumFunc(x)) { + int n = unitLength(arg1(x)); + result = 0.0; + for (i=0; i result) + result = temp; + } + } + else if (sumFunc(y)) { + int n = unitLength(arg1(y)); + result = 0.0; + for (i=0; i result) + result = temp; + } + } + else if (sumFunc(width)) { + int n = unitLength(arg1(width)); + result = 0.0; + for (i=0; i result) + result = temp; + } + } + else if (sumFunc(height)) { + int n = unitLength(arg1(height)); + result = 0.0; + for (i=0; i 0) { if (isString(units)) { PROTECT(answer = allocVector(INTSXP, n)); - for (int i = 0; i 1; - UNPROTECT(2); - if (tooDeep) { - error(_("'gPath' must have depth 1 in 'grobwidth/height' units")); - } - } - } - if (!unitIsString && !unitIsGrob && singleData != R_NilValue) { - error(_("non-NULL value supplied for plain unit")); - } - } - UNPROTECT(dataCopied); - return data; -} -void makeSimpleUnit(SEXP values, SEXP unit) { - setAttrib(values, install("unit"), unit); - SEXP classes = PROTECT(allocVector(STRSXP, 2)); - SET_STRING_ELT(classes, 0, mkChar("simpleUnit")); - SET_STRING_ELT(classes, 1, mkChar("unit")); - classgets(values, classes); - UNPROTECT(1); -} -SEXP constructUnits(SEXP amount, SEXP data, SEXP unit) { - int nAmount = LENGTH(amount); - int nData = LENGTH(data); - int nUnit = LENGTH(unit); - SEXP valUnits = PROTECT(validUnits(unit)); - if (nUnit == 1) { - int u = INTEGER(valUnits)[0]; - if (!(isStringUnit(u) || isGrobUnit(u))) { - int referenced = MAYBE_REFERENCED(amount); - if (referenced) amount = PROTECT(duplicate(amount)); - makeSimpleUnit(amount, valUnits); - UNPROTECT(1 + referenced); - return amount; - } - } - int n = nAmount < nUnit ? nUnit : nAmount; - SEXP units = PROTECT(allocVector(VECSXP, n)); - - data = validData(data, valUnits, n); - - double* pAmount = REAL(amount); - int *pValUnits = INTEGER(valUnits); - for (int i = 0; i < n; i++) { - SEXP unit = SET_VECTOR_ELT(units, i, allocVector(VECSXP, 3)); - SET_VECTOR_ELT(unit, 0, Rf_ScalarReal(pAmount[i % nAmount])); - SET_VECTOR_ELT(unit, 1, VECTOR_ELT(data, i % nData)); - SET_VECTOR_ELT(unit, 2, Rf_ScalarInteger(pValUnits[i % nUnit])); - } - SEXP cl = PROTECT(mkString("unit")); - classgets(units, cl); - UNPROTECT(3); - return units; -} -SEXP asUnit(SEXP simpleUnit) { - if (inherits(simpleUnit, "unit")) { - if (!inherits(simpleUnit, "simpleUnit")) { - return simpleUnit; - } - } else { - error(_("object is not coercible to a unit")); - } - int n = LENGTH(simpleUnit); - SEXP units = PROTECT(allocVector(VECSXP, n)); - double* pAmount = REAL(simpleUnit); - SEXP valUnit = getAttrib(simpleUnit, install("unit")); - for (int i = 0; i < n; i++) { - SEXP unit = SET_VECTOR_ELT(units, i, allocVector(VECSXP, 3)); - SET_VECTOR_ELT(unit, 0, Rf_ScalarReal(pAmount[i])); - SET_VECTOR_ELT(unit, 1, R_NilValue); - SET_VECTOR_ELT(unit, 2, valUnit); - } - SEXP cl = PROTECT(mkString("unit")); - classgets(units, cl); - UNPROTECT(2); - return units; -} -SEXP conformingUnits(SEXP unitList) { - int n = LENGTH(unitList); - int unitType; - SEXP uAttrib = install("unit"); - for (int i = 0; i < n; i++) { - SEXP unit = VECTOR_ELT(unitList, i); - if (!inherits(unit, "unit")) error(_("object is not a unit")); - if (!inherits(unit, "simpleUnit")) return R_NilValue; - int tempUnit = INTEGER(getAttrib(unit, uAttrib))[0]; - if (i == 0) unitType = tempUnit; - else if (unitType != tempUnit) return R_NilValue; - } - return Rf_ScalarInteger(unitType); -} - -SEXP matchUnit(SEXP units, SEXP unit) { - int n = unitLength(units); - int unitInt = INTEGER(unit)[0]; - int count = 0; - SEXP matches = PROTECT(allocVector(INTSXP, n)); - for (int i = 0; i < n; i++) { - if (unitUnit(units, i) == unitInt) { - INTEGER(matches)[count] = i + 1; - count++; - } - } - SETLENGTH(matches, count); - UNPROTECT(1); - return matches; -} - -int allAbsolute(SEXP units) { - int all = 1; - int n = unitLength(units); - - for (int i = 0; i < n; i++) { - int u = unitUnit(units, i); - if (isArith(u)) { - all = allAbsolute(unitData(units, i)); - } else { - all = isAbsolute(u); - } - if (!all) break; - } - - return all; -} - -SEXP absoluteUnits(SEXP units) { - int n = unitLength(units); - if (isSimpleUnit(units)) { - if (isAbsolute(INTEGER(getAttrib(units, install("unit")))[0])) { - return units; - } - units = PROTECT(allocVector(REALSXP, n)); - double *pVal = REAL(units); - for (int i = 0; i < n; i++) pVal[i] = 1.0; - makeSimpleUnit(units, Rf_ScalarInteger(5)); - UNPROTECT(1); - return units; - } - int unitIsAbsolute[n]; - int unitsAllAbsolute = 1; - for (int i = 0; i < n; i++) { - int u = unitUnit(units, i); - if (isArith(u)) { - unitIsAbsolute[i] = allAbsolute(unitData(units, i)); - } else { - unitIsAbsolute[i] = isAbsolute(u); - } - if (!unitIsAbsolute[i]) unitsAllAbsolute = 0; - } - // Early exit avoiding a copy - if (unitsAllAbsolute) return units; - - SEXP absolutes = PROTECT(allocVector(VECSXP, n)); - SEXP nullUnit = PROTECT(allocVector(VECSXP, 3)); - SET_VECTOR_ELT(nullUnit, 0, Rf_ScalarReal(1.0)); - SET_VECTOR_ELT(nullUnit, 1, R_NilValue); - SET_VECTOR_ELT(nullUnit, 2, Rf_ScalarInteger(5)); - for (int i = 0; i < n; i++) { - SEXP unit; - if (unitIsAbsolute[i]) { - unit = PROTECT(shallow_duplicate(unitScalar(units, i))); - } else if (isArith(unitUnit(units, i))) { - unit = PROTECT(allocVector(VECSXP, 3)); - SET_VECTOR_ELT(unit, 0, VECTOR_ELT(VECTOR_ELT(units, i), 0)); - SET_VECTOR_ELT(unit, 1, absoluteUnits(unitData(units, i))); - SET_VECTOR_ELT(unit, 2, VECTOR_ELT(VECTOR_ELT(units, i), 2)); - } else { - unit = PROTECT(shallow_duplicate(nullUnit)); - } - SET_VECTOR_ELT(absolutes, i, unit); - UNPROTECT(1); - } - SEXP cl = PROTECT(mkString("unit")); - classgets(absolutes, cl); - UNPROTECT(3); - return absolutes; -} -SEXP multUnit(SEXP unit, double value) { - SEXP mult = PROTECT(shallow_duplicate(unit)); - SET_VECTOR_ELT(mult, 0, Rf_ScalarReal(value * uValue(mult))); - UNPROTECT(1); - return mult; -} -SEXP multUnits(SEXP units, SEXP values) { - int nValues = LENGTH(values); - int n = LENGTH(units) < nValues ? nValues : LENGTH(units); - SEXP multiplied = PROTECT(allocVector(VECSXP, n)); - double *pValues = REAL(values); - - for (int i = 0; i < n; i++) { - SEXP unit = PROTECT(unitScalar(units, i)); - SET_VECTOR_ELT(multiplied, i, multUnit(unit, pValues[i % nValues])); - UNPROTECT(1); - } - SEXP cl = PROTECT(mkString("unit")); - classgets(multiplied, cl); - UNPROTECT(2); - return multiplied; -} -SEXP addUnit(SEXP u1, SEXP u2) { - SEXP result = PROTECT(allocVector(VECSXP, 3)); - - double amount1 = uValue(u1); - double amount2 = uValue(u2); - int type1 = uUnit(u1); - int type2 = uUnit(u2); - SEXP data1 = uData(u1); - SEXP data2 = uData(u2); - - if (type1 == type2 && R_compute_identical(data1, data2, 15)) { - // Two units are of same type and amount can just be added - SET_VECTOR_ELT(result, 0, Rf_ScalarReal(amount1 + amount2)); - SET_VECTOR_ELT(result, 1, data1); - SET_VECTOR_ELT(result, 2, Rf_ScalarInteger(type1)); - UNPROTECT(1); - return result; - } - // Otherwise we construct a summation - SET_VECTOR_ELT(result, 0, Rf_ScalarReal(1.0)); - SET_VECTOR_ELT(result, 2, Rf_ScalarInteger(L_SUM)); - int isSum1 = type1 == L_SUM; - int isSum2 = type2 == L_SUM; - int lengthData1 = isSum1 ? LENGTH(data1) : 1; - int lengthData2 = isSum2 ? LENGTH(data2) : 1; - SEXP data = SET_VECTOR_ELT(result, 1, allocVector(VECSXP, lengthData1 + lengthData2)); - // If u1 is a sum unit, add all internal units to final data, otherwise add the unit itself - if (isSum1) { - // No need to modify data as value is 1 - if (amount1 == 1.0) { - for (int j = 0; j < lengthData1; j++) { - SET_VECTOR_ELT(data, j, unitScalar(data1, j)); - } - } else { // Multiply the data with the value of the summation unit - for (int j = 0; j < lengthData1; j++) { - SEXP dataUnit = PROTECT(unitScalar(data1, j)); - SET_VECTOR_ELT(data, j, multUnit(dataUnit, amount1)); - UNPROTECT(1); - } - } - } else { - SET_VECTOR_ELT(data, 0, u1); - } - // Same as above but for u2 - if (isSum2) { - if (amount2 == 1.0) { - for (int j = 0; j < lengthData2; j++) { - SET_VECTOR_ELT(data, j + lengthData1, unitScalar(data2, j)); - } - } else { - for (int j = 0; j < lengthData2; j++) { - SEXP dataUnit = PROTECT(unitScalar(data2, j)); - SET_VECTOR_ELT(data, j + lengthData1, multUnit(dataUnit, amount2)); - UNPROTECT(1); - } - } - } else { - SET_VECTOR_ELT(data, lengthData1, u2); - } - SEXP cl = PROTECT(mkString("unit")); - classgets(data, cl); - - UNPROTECT(2); - return result; -} -SEXP addUnits(SEXP u1, SEXP u2) { - int n = LENGTH(u1) < LENGTH(u2) ? LENGTH(u2) : LENGTH(u1); - SEXP added = PROTECT(allocVector(VECSXP, n)); - for (int i = 0; i < n; i++) { - SEXP unit1 = PROTECT(unitScalar(u1, i)); - SEXP unit2 = PROTECT(unitScalar(u2, i)); - SET_VECTOR_ELT(added, i, addUnit(unit1, unit2)); - UNPROTECT(2); - } - SEXP cl = PROTECT(mkString("unit")); - classgets(added, cl); - UNPROTECT(2); - return added; -} -SEXP flipUnits(SEXP units) { - return multUnits(units, Rf_ScalarReal(-1.0)); -} -SEXP summaryUnits(SEXP units, SEXP op_type) { - int n = 0; - int m = LENGTH(units); - for (int i = 0; i < m; i++) { - int nTemp = LENGTH(VECTOR_ELT(units, i)); - n = n < nTemp ? nTemp : n; - } - int type = INTEGER(op_type)[0]; - SEXP out = PROTECT(allocVector(VECSXP, n)); - SEXP cl = PROTECT(mkString("unit")); - - int is_type[m]; - int all_type = 1; - - for (int i = 0; i < n; i++) { - int k = 0; - int first_type, current_type; - SEXP unit = SET_VECTOR_ELT(out, i, allocVector(VECSXP, 3)); - SEXP first_data; - for (int j = 0; j < m; j++) { - SEXP unit_temp = PROTECT(unitScalar(VECTOR_ELT(units, j), i)); - current_type = uUnit(unit_temp); - if (j == 0) { - first_type = current_type; - first_data = uData(unit_temp); - } - is_type[j] = current_type == type; - all_type = j == 0 || (current_type == first_type && R_compute_identical(uData(unit_temp), first_data, 15)); - k += is_type[j] ? LENGTH(uData(unit_temp)) : 1; - UNPROTECT(1); - } - if (all_type) { - // The units are of same type and amount can just collapsed - double amount = unitValue(VECTOR_ELT(units, 0), i); - for (int j = 0; j < m; j++) { - double amount_temp = unitValue(VECTOR_ELT(units, j), i); - switch(type) { - case L_SUM: - amount += amount_temp; - break; - case L_MIN: - amount = amount < amount_temp ? amount : amount_temp; - break; - case L_MAX: - amount = amount > amount_temp ? amount : amount_temp; - break; - } - } - SET_VECTOR_ELT(unit, 0, Rf_ScalarReal(amount)); - SET_VECTOR_ELT(unit, 1, unitData(VECTOR_ELT(units, 0), i)); - SET_VECTOR_ELT(unit, 2, Rf_ScalarInteger(current_type)); - continue; - } - SET_VECTOR_ELT(unit, 0, Rf_ScalarReal(1.0)); - SET_VECTOR_ELT(unit, 2, Rf_ScalarInteger(type)); - SEXP data = SET_VECTOR_ELT(unit, 1, allocVector(VECSXP, k)); - k = 0; - for (int j = 0; j < m; j++) { - SEXP unit_temp = PROTECT(unitScalar(VECTOR_ELT(units, j), i)); - if (is_type[j]) { - SEXP current_data = uData(unit_temp); - double amount = uValue(unit_temp); - for (int jj = 0; jj < LENGTH(current_data); jj++) { - SEXP inner_data = SET_VECTOR_ELT(data, jj + k, shallow_duplicate(VECTOR_ELT(current_data, jj))); - SET_VECTOR_ELT(inner_data, 0, Rf_ScalarReal(amount * uValue(inner_data))); - } - k += LENGTH(current_data); - } else { - SET_VECTOR_ELT(data, k, unit_temp); - k++; - } - UNPROTECT(1); - } - classgets(data, cl); - } - classgets(out, cl); - UNPROTECT(2); - return out; -} diff --git a/src/library/grid/tests/bugs.R b/src/library/grid/tests/bugs.R index 01e87ea3769..d491c63db02 100644 --- a/src/library/grid/tests/bugs.R +++ b/src/library/grid/tests/bugs.R @@ -1,8 +1,8 @@ library(grid) # Physical units in viewport of height 0 -pushViewport(viewport(height = 0)) -stopifnot(is.finite(convertHeight(unit(72, "bigpts"), "inches", valueOnly = TRUE))) +pushViewport(viewport(h=0)) +stopifnot(is.finite(convertHeight(unit(72, "bigpts"), "inches"))) popViewport() # The gpar font settings for a grob should affect the grob itself diff --git a/tests/Examples/grid-Ex.Rout.save b/tests/Examples/grid-Ex.Rout.save index bfc856cedaa..d186b22cfc8 100644 --- a/tests/Examples/grid-Ex.Rout.save +++ b/tests/Examples/grid-Ex.Rout.save @@ -1,5 +1,5 @@ -R Under development (unstable) (2019-03-26 r76272) -- "Unsuffered Consequences" +R Under development (unstable) (2019-03-28 r76280) -- "Unsuffered Consequences" Copyright (C) 2019 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) @@ -241,10 +241,10 @@ viewport[C]->(viewport[D]) > pushViewport(viewport()) > deviceLoc(unit(1, "inches"), unit(1, "inches")) $x -[1] 1inches +[1] 1in $y -[1] 1inches +[1] 1in > > ## Something less obvious @@ -257,10 +257,10 @@ $y > loc <- deviceLoc(x, y) > loc $x -[1] 2.7inches +[1] 2.7in $y -[1] 2.75inches +[1] 2.75in > upViewport() > grid.circle(loc$x, loc$y, r=unit(1, "mm"), gp=gpar(fill="black")) @@ -275,10 +275,10 @@ $y > loc <- deviceLoc(x, y) > loc $x -[1] 2.39165408813987inches +[1] 2.39165408813987in $y -[1] 3.20650635094611inches +[1] 3.20650635094611in > upViewport() > grid.circle(loc$x, loc$y, r=unit(1, "mm"), gp=gpar(fill="black")) @@ -1845,13 +1845,13 @@ List of 6 > unit(1:3/4, "npc") [1] 0.25npc 0.5npc 0.75npc > unit(1:3/4, "npc") + unit(1, "inches") -[1] sum(0.25npc, 1inches) sum(0.5npc, 1inches) sum(0.75npc, 1inches) +[1] 0.25npc+1inches 0.5npc+1inches 0.75npc+1inches > min(unit(0.5, "npc"), unit(1, "inches")) [1] min(0.5npc, 1inches) > unit.c(unit(0.5, "npc"), unit(2, "inches") + unit(1:3/4, "npc"), + unit(1, "strwidth", "hi there")) -[1] 0.5npc sum(2inches, 0.25npc) sum(2inches, 0.5npc) -[4] sum(2inches, 0.75npc) 1strwidth +[1] 0.5npc 2inches+0.25npc 2inches+0.5npc 2inches+0.75npc +[5] 1strwidth > x <- unit(1:5, "npc") > x[2:4] [1] 2npc 3npc 4npc @@ -1895,7 +1895,7 @@ List of 6 > > ### Name: unit.pmin > ### Title: Parallel Unit Minima and Maxima -> ### Aliases: unit.pmin unit.pmax unit.psum +> ### Aliases: unit.pmin unit.pmax > ### Keywords: dplot > > ### ** Examples @@ -1925,21 +1925,20 @@ List of 6 > rep(unit(1:3, "npc"), 1:3) [1] 1npc 2npc 2npc 3npc 3npc 3npc > rep(unit(1:3, "npc") + unit(1, "inches"), 3) -[1] sum(1npc, 1inches) sum(2npc, 1inches) sum(3npc, 1inches) sum(1npc, 1inches) -[5] sum(2npc, 1inches) sum(3npc, 1inches) sum(1npc, 1inches) sum(2npc, 1inches) -[9] sum(3npc, 1inches) +[1] 1npc+1inches 2npc+1inches 3npc+1inches 1npc+1inches 2npc+1inches +[6] 3npc+1inches 1npc+1inches 2npc+1inches 3npc+1inches > rep(max(unit(1:3, "npc") + unit(1, "inches")), 3) -[1] max(sum(1npc, 1inches), sum(2npc, 1inches), sum(3npc, 1inches)) -[2] max(sum(1npc, 1inches), sum(2npc, 1inches), sum(3npc, 1inches)) -[3] max(sum(1npc, 1inches), sum(2npc, 1inches), sum(3npc, 1inches)) +[1] max(1npc+1inches, 2npc+1inches, 3npc+1inches) +[2] max(1npc+1inches, 2npc+1inches, 3npc+1inches) +[3] max(1npc+1inches, 2npc+1inches, 3npc+1inches) > rep(max(unit(1:3, "npc") + unit(1, "strwidth", "a"))*4, 3) -[1] 4*max(sum(1npc, 1strwidth), sum(2npc, 1strwidth), sum(3npc, 1strwidth)) -[2] 4*max(sum(1npc, 1strwidth), sum(2npc, 1strwidth), sum(3npc, 1strwidth)) -[3] 4*max(sum(1npc, 1strwidth), sum(2npc, 1strwidth), sum(3npc, 1strwidth)) +[1] 4*max(1npc+1strwidth, 2npc+1strwidth, 3npc+1strwidth) +[2] 4*max(1npc+1strwidth, 2npc+1strwidth, 3npc+1strwidth) +[3] 4*max(1npc+1strwidth, 2npc+1strwidth, 3npc+1strwidth) > rep(unit(1:3, "npc") + unit(1, "strwidth", "a")*4, 3) -[1] sum(1npc, 4strwidth) sum(2npc, 4strwidth) sum(3npc, 4strwidth) -[4] sum(1npc, 4strwidth) sum(2npc, 4strwidth) sum(3npc, 4strwidth) -[7] sum(1npc, 4strwidth) sum(2npc, 4strwidth) sum(3npc, 4strwidth) +[1] 1npc+4*1strwidth 2npc+4*1strwidth 3npc+4*1strwidth 1npc+4*1strwidth +[5] 2npc+4*1strwidth 3npc+4*1strwidth 1npc+4*1strwidth 2npc+4*1strwidth +[9] 3npc+4*1strwidth > > > @@ -2162,7 +2161,7 @@ vp1::vp2 > cleanEx() > options(digits = 7L) > base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n") -Time elapsed: 1.824 0.032 1.859 0 0 +Time elapsed: 1.684 0.03 1.723 0 0 > grDevices::dev.off() null device 1