#' Define a macro
#'
#' \code{defmacro} define a macro that uses R expression replacement
#'
#' \code{strmacro} define a macro that uses string replacement
#'
#'
#' \code{defmacro} and \code{strmacro} create a macro from the expression given
#' in \code{expr}, with formal arguments given by the other elements of the
#' argument list.
#'
#' A macro is similar to a function definition except for handling of formal
#' arguments. In a function, formal arguments are simply variables that
#' contains the result of evaluating the expressions provided to the function
#' call. In contrast, macros actually modify the macro body by
#' \emph{replacing} each formal argument by the expression (\code{defmacro}) or
#' string (\code{strmacro}) provided to the macro call.
#'
#' For \code{defmacro}, the special argument name \code{DOTS} will be replaced
#' by \code{...} in the formal argument list of the macro so that \code{...} in
#' the body of the expression can be used to obtain any additional arguments
#' passed to the macro. For \code{strmacro} you can mimic this behavior
#' providing a \code{DOTS=""} argument. This is illustrated by the last
#' example below.
#'
#' Macros are often useful for creating new functions during code execution.
#'
#' @aliases defmacro strmacro
#' @param \dots macro argument list
#' @param expr R expression defining the macro body
#' @param strexpr character string defining the macro body
#' @return A macro function.
#'
#' @note Note that because [the defmacro code] works on the parsed expression,
#' not on a text string, defmacro avoids some of the problems of traditional
#' string substitution macros such as \code{strmacro} and the C preprocessor
#' macros. For example, in \preformatted{ mul <- defmacro(a, b, expr={a*b}) } a
#' C programmer might expect \code{mul(i, j + k)} to expand (incorrectly) to
#' \code{i*j + k}. In fact it expands correctly, to the equivalent of
#' \code{i*(j + k)}.
#'
#' For a discussion of the differences between functions and macros, please
#' Thomas Lumley's R-News article (reference below).
#' @author Thomas Lumley wrote \code{defmacro}. Gregory R. Warnes
#' \email{greg@@warnes.net} enhanced it and created \code{strmacro}.
#' @seealso \code{\link[base]{function}} \code{\link[base]{substitute}},
#' \code{\link[base]{eval}}, \code{\link[base]{parse}},
#' \code{\link[base]{source}}, \code{\link[base]{parse}},
#'
#'
#' @references
#' This code was taken from the gtools package on 20 June 2022
#' on account of a package orphaning problem.
#' Note that gtools is licensed under GPL-2.
#'
#' The original version of the \code{defmacro} actually originated from:
#'
#' Lumley T. "Programmer's Niche: Macros in R", R News, 2001, Vol 1, No. 3, pp
#' 11--13, \url{https://cran.r-project.org/doc/Rnews/}
#' @Article{Rnews:Lumley:2001,
#' author = {Thomas Lumley},
#' title = {Programmer's Niche: Macros in {R}},
#' journal = {R News},
#' year = 2001,
#' volume = 1,
#' number = 3,
#' pages = {11--13},
#' month = {September},
#' url = {https://cran.r-project.org/doc/Rnews/}
#' }
#' @keywords programming
#' ## Code from
#' @examples
#'
#' ####
#' # macro for replacing a specified missing value indicator with NA
#' # within a dataframe
#' ###
#' setNA <- defmacro(df, var, values,
#' expr = {
#' df$var[df$var %in% values] <- NA
#' }
#' )
#'
#' # create example data using 999 as a missing value indicator
#' d <- data.frame(
#' Grp = c("Trt", "Ctl", "Ctl", "Trt", "Ctl", "Ctl", "Trt", "Ctl", "Trt", "Ctl"),
#' V1 = c(1, 2, 3, 4, 5, 6, 999, 8, 9, 10),
#' V2 = c(1, 1, 1, 1, 1, 2, 999, 2, 999, 999),
#' stringsAsFactors = TRUE
#' )
#' d
#'
#' # Try it out
#' setNA(d, V1, 999)
#' setNA(d, V2, 999)
#' d
#'
#'
#' ###
#' # Expression macro
#' ###
#' plot.d <- defmacro(df, var, DOTS,
#' col = "red", title = "", expr =
#' plot(df$var ~ df$Grp, type = "b", col = col, main = title, ...)
#' )
#'
#' plot.d(d, V1)
#' plot.d(d, V1, col = "blue")
#' plot.d(d, V1, lwd = 4) # use optional 'DOTS' argument
#'
#' ###
#' # String macro (note the quoted text in the calls below)
#' #
#' # This style of macro can be useful when you are reading
#' # function arguments from a text file
#' ###
#' plot.s <- strmacro(DF, VAR,
#' COL = "'red'", TITLE = "''", DOTS = "", expr =
#' plot(DF$VAR ~ DF$Grp, type = "b", col = COL, main = TITLE, DOTS)
#' )
#'
#' plot.s("d", "V1")
#' plot.s(DF = "d", VAR = "V1", COL = '"blue"')
#' plot.s("d", "V1", DOTS = "lwd=4") # use optional 'DOTS' argument
#'
#'
#'
#' #######
#' # Create a macro that defines new functions
#' ######
#' plot.sf <- defmacro(
#' type = "b", col = "black",
#' title = deparse(substitute(x)), DOTS, expr =
#' function(x, y) plot(x, y, type = type, col = col, main = title, ...)
#' )
#'
#' plot.red <- plot.sf(col = "red", title = "Red is more Fun!")
#' plot.blue <- plot.sf(col = "blue", title = "Blue is Best!", lty = 2)
#'
#' plot.red(1:100, rnorm(100))
#' plot.blue(1:100, rnorm(100))
#' @export
defmacro <- function(..., expr) # , DOTS=FALSE)
{
expr <- substitute(expr)
a <- substitute(list(...))[-1]
## process the argument list
nn <- names(a)
if (is.null(nn)) {
nn <- rep("", length(a))
}
for (i in 1:length(a))
{
if (nn[i] == "") {
nn[i] <- paste(a[[i]])
msg <- paste(a[[i]], "not supplied")
a[[i]] <- substitute(
stop(foo),
list(foo = msg)
)
}
if (nn[i] == "DOTS") {
nn[i] <- "..."
a[[i]] <- formals(function(...) {})[[1]]
}
}
names(a) <- nn
a <- as.list(a)
## this is where the work is done
ff <- eval(substitute(
function() {
tmp <- substitute(body)
eval(tmp, parent.frame())
},
list(body = expr)
))
## add the argument list
formals(ff) <- a
## create a fake source attribute
mm <- match.call()
mm$expr <- NULL
mm[[1]] <- as.name("macro")
attr(ff, "source") <- c(
deparse(mm),
deparse(expr)
)
## return the 'macro'
ff
}
#' @rdname defmacro
#' @export
strmacro <- function(..., expr, strexpr) {
if (!missing(expr)) {
strexpr <- deparse(substitute(expr))
}
a <- substitute(list(...))[-1]
nn <- names(a)
if (is.null(nn)) {
nn <- rep("", length(a))
}
for (i in 1:length(a))
{
if (nn[i] == "") {
nn[i] <- paste(a[[i]])
msg <- paste(a[[i]], "not supplied")
a[[i]] <- substitute(
stop(foo),
list(foo = msg)
)
}
else {
a[[i]] <- a[[i]]
}
}
names(a) <- nn
a <- as.list(a)
## this is where the work is done
ff <-
function(...) {
## build replacement list
reptab <- a # copy defaults first
reptab$"..." <- NULL
args <- match.call(expand.dots = TRUE)[-1]
for (item in names(args)) {
reptab[[item]] <- args[[item]]
}
## do the replacements
body <- strexpr
for (i in 1:length(reptab))
{
pattern <- paste("\\b",
names(reptab)[i],
"\\b",
sep = ""
)
value <- reptab[[i]]
if (missing(value)) {
value <- ""
}
body <- gsub(
pattern,
value,
body
)
}
fun <- parse(text = body)
eval(fun, parent.frame())
}
## add the argument list
formals(ff) <- a
## create a fake source attribute
mm <- match.call()
mm$expr <- NULL
mm[[1]] <- as.name("macro")
attr(ff, "source") <- c(deparse(mm), strexpr)
## return the 'macro'
ff
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.