The R Project SVN R

#  File src/library/grid/R/unit.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2016 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/


# Create an object of class "unit"
# Simple units are of the form 'unit(1, "cm")' or 'unit(1L:3, "cm")' or
# '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) {
    # 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))
}

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) {
    .Defunct("convertUnit")
}

convertUnit <- function(x, unitTo, axisFrom="x", typeFrom="location",
                        axisTo=axisFrom, typeTo=typeFrom,
                        valueOnly=FALSE) {
  whatfrom <- match(axisFrom, c("x", "y")) - 1L +
    2L*(match(typeFrom, c("location", "dimension")) - 1L)
  whatto <- match(axisTo, c("x", "y")) - 1L +
    2L*(match(typeTo, c("location", "dimension")) - 1L)
  if (!is.unit(x))
    stop("'x' argument must be a unit object")
  if (is.na(whatfrom) || is.na(whatto))
    stop("invalid 'axis' or 'type'")
  value <- grid.Call(C_convert, x, as.integer(whatfrom),
                 as.integer(whatto), valid.units(unitTo))
  if (!valueOnly)
    unit(value, unitTo)
  else
    value
}

grid.convertX <- function(x, unitTo, valueOnly=FALSE) {
  .Defunct("convertX")
}

convertX <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "x", "location", "x", "location",
              valueOnly=valueOnly)
}

grid.convertY <- function(x, unitTo, valueOnly=FALSE) {
  .Defunct("convertY")
}

convertY <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "y", "location", "y", "location",
              valueOnly=valueOnly)
}

grid.convertWidth <- function(x, unitTo, valueOnly=FALSE) {
  .Defunct("convertWidth")
}

convertWidth <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "x", "dimension", "x", "dimension",
              valueOnly=valueOnly)
}

grid.convertHeight <- function(x, unitTo, valueOnly=FALSE) {
  .Defunct("convertHeight")
}

convertHeight <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "y", "dimension", "y", "dimension",
              valueOnly=valueOnly)
}

convertNative <- function(unit, dimension="x", type="location") {
  .Defunct("convertUnit")
}

deviceLoc <- function(x, y, valueOnly=FALSE) {
    result <- grid.Call(C_devLoc, x, y)
    names(result) <- c("x", "y")
    if (!valueOnly)
        list(x=unit(result$x, "in"), y=unit(result$y, "in"))
    else
        result
}

deviceDim <- function(w, h, valueOnly=FALSE) {
    result <- grid.Call(C_devDim, w, h)
    names(result) <- c("w", "h")
    if (!valueOnly)
        list(w=unit(result$w, "in"), h=unit(result$h, "in"))
    else
        result
}

# This is like the "convert" functions:  it evaluates units (immediately)
# in the current context
calcStringMetric <- function(text) {
    # .Call rather than .Call.graphics because it is a one-off calculation
    metric <- grid.Call(C_stringMetric, text)
    names(metric) <- c("ascent", "descent", "width")
    metric
}

# NOTE: the order of the strings in these conversion functions must
# match the order of the enums in ../src/grid.h
# AND in ../src/unit.c (see UnitTable)
# NOTE: ../src/unit.c also allows some pseudonyms (e.g., "in" for "inches")
.grid.unit.list <- c("npc", "cm", "inches", "lines",
                     "native", "null", "snpc", "mm",
                     "points", "picas", "bigpts",
                     "dida", "cicero", "scaledpts",
                     "strwidth", "strheight",
                     "strascent", "strdescent",
                     "vplayoutwidth", "vplayoutheight", "char",
                     "grobx", "groby", "grobwidth", "grobheight",
                     "grobascent", "grobdescent",
                     "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)
}

unitType <- function(x) {
    UseMethod("unitType")
}
unitType.unit <- function(x) {
    rep(attr(x, "unit"), length.out=length(x))
}
unitType.unit.arithmetic <- function(x) {
    rep(switch(x$fname,
               "+"=,
               "-"=,
               "*"=,
               sum="sum",
               min="min",
               max="max"),
        length.out=length(x))
}
unitType.unit.list <- function(x) {
    sapply(x, unitType)
}
    
as.character.unit <- function(x, ...) {
  class(x) <- NULL
  paste0(x, attr(x, "unit"))
}

format.unit <- function(x, ...) {
    paste0(format(unclass(x), ...), attr(x, "unit"))
}

#########################
# UNIT ARITHMETIC STUFF
#########################

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, FALSE)
  if (!ok)
    stop(gettextf("operator '%s' not meaningful for units", .Generic),
         domain = NA)
  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")
      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))
        # Use as.numeric to force e1 to be REAL
        unit.arithmetic(.Generic, as.numeric(e1), e2)
      else
        stop("non-unit operand must be numeric")
    }
  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")
}

## <FIXME>
## The na.rm arg is ignored here, and the S3 groupGeneric is
## Summary(x, ...)
## </FIXME>
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(...) {

  select.i <- function(unit, i) {
    `[`(unit, i, top=FALSE)
  }

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

# The idea of the "top" argument is to allow the function to
# know if it has been called from the command-line or from
# a previous (recursive) call to "[.unit" or "[.unit.arithmetic"
# this allows recycling beyond the end of the unit object
# except at the top level

# 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]
    }
    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 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), ...)
}

#########################
# "c"ombining unit objects
#########################

# NOTE that I have not written methods for c()
# because method dispatch occurs on the first argument to
# "c" so c(unit(...), ...) would come here, but c(whatever, unit(...), ...)
# would go who-knows-where.
# A particularly nasty example is:  c(1, unit(1, "npc")) which will
# produce the same result as c(1, 1)
# Same problem for trying to control c(<unit>, <unit.arithmetic>)
# versus c(<unit.arithmetic>, <unit>), etc ...

# If any arguments are unit.arithmetic or unit.list, then the result will be
# unit.list
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, ...) {
    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
unit.rep <- function (x, ...)
{
  warning("'unit.rep' has been deprecated in favour of a unit method for the generic rep function", domain = NA)
  rep(x, ...)
}

#########################
# Length of unit objects
#########################

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)
}

#########################
# Convenience functions
#########################

stringWidth <- function(string) {
    n <- length(string)
    if (is.language(string)) {
        data <- vector("list", n)
        for (i in 1L:n)
            data[[i]] <- string[i]
    } else {
        data <- as.list(as.character(string))
    }
    unit(rep_len(1, n), "strwidth", data=data)
}

stringHeight <- function(string) {
    n <- length(string)
    if (is.language(string)) {
        data <- vector("list", n)
        for (i in 1L:n)
            data[[i]] <- string[i]
    } else {
        data <- as.list(as.character(string))
    }
    unit(rep_len(1, n), "strheight", data=data)
}

stringAscent <- function(string) {
    n <- length(string)
    if (is.language(string)) {
        data <- vector("list", n)
        for (i in 1L:n)
            data[[i]] <- string[i]
    } else {
        data <- as.list(as.character(string))
    }
    unit(rep_len(1, n), "strascent", data=data)
}

stringDescent <- function(string) {
    n <- length(string)
    if (is.language(string)) {
        data <- vector("list", n)
        for (i in 1L:n)
            data[[i]] <- string[i]
    } else {
        data <- as.list(as.character(string))
    }
    unit(rep_len(1, n), "strdescent", data=data)
}

convertTheta <- function(theta) {
    if (is.character(theta))
        # Allow some aliases for common angles
        switch(theta,
               east=0,
               north=90,
               west=180,
               south=270,
               stop("invalid 'theta'"))
    else
        # Ensure theta in [0, 360)
        theta <- as.numeric(theta) %% 360
}

# grobX
grobX <- function(x, theta) {
    UseMethod("grobX", x)
}

grobX.grob <- function(x, theta) {
  unit(convertTheta(theta), "grobx", data=x)
}

grobX.gList <- function(x, theta) {
  unit(rep(convertTheta(theta), length(x)), "grobx", data=x)
}

grobX.gPath <- function(x, theta) {
  unit(convertTheta(theta), "grobx", data=x)
}

grobX.default <- function(x, theta) {
  unit(convertTheta(theta), "grobx", data=gPath(as.character(x)))
}

# grobY
grobY <- function(x, theta) {
    UseMethod("grobY", x)
}

grobY.grob <- function(x, theta) {
  unit(convertTheta(theta), "groby", data=x)
}

grobY.gList <- function(x, theta) {
  unit(rep(convertTheta(theta), length(x)), "groby", data=x)
}

grobY.gPath <- function(x, theta) {
  unit(convertTheta(theta), "groby", data=x)
}

grobY.default <- function(x, theta) {
  unit(convertTheta(theta), "groby", data=gPath(as.character(x)))
}

# grobWidth
grobWidth <- function(x) {
  UseMethod("grobWidth")
}

grobWidth.grob <- function(x) {
  unit(1, "grobwidth", data=x)
}

grobWidth.gList <- function(x) {
  unit(rep_len(1, length(x)), "grobwidth", data=x)
}

grobWidth.gPath <- function(x) {
  unit(1, "grobwidth", data=x)
}

grobWidth.default <- function(x) {
  unit(1, "grobwidth", data=gPath(as.character(x)))
}

# grobHeight
grobHeight <- function(x) {
  UseMethod("grobHeight")
}

grobHeight.grob <- function(x) {
  unit(1, "grobheight", data=x)
}

grobHeight.gList <- function(x) {
  unit(rep_len(1, length(x)), "grobheight", data=x)
}

grobHeight.gPath <- function(x) {
  unit(1, "grobheight", data=x)
}

grobHeight.default <- function(x) {
  unit(1, "grobheight", data=gPath(as.character(x)))
}

# grobAscent
grobAscent <- function(x) {
  UseMethod("grobAscent")
}

grobAscent.grob <- function(x) {
  unit(1, "grobascent", data=x)
}

grobAscent.gList <- function(x) {
  unit(rep_len(1, length(x)), "grobascent", data=x)
}

grobAscent.gPath <- function(x) {
  unit(1, "grobascent", data=x)
}

grobAscent.default <- function(x) {
  unit(1, "grobascent", data=gPath(as.character(x)))
}

# grobDescent
grobDescent <- function(x) {
  UseMethod("grobDescent")
}

grobDescent.grob <- function(x) {
  unit(1, "grobdescent", data=x)
}

grobDescent.gList <- function(x) {
  unit(rep_len(1, length(x)), "grobdescent", data=x)
}

grobDescent.gPath <- function(x) {
  unit(1, "grobdescent", data=x)
}

grobDescent.default <- function(x) {
  unit(1, "grobdescent", data=gPath(as.character(x)))
}

#########################
# Function to decide which values in a unit are "absolute" (do not depend
# 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) {
  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)))
}