From a58a0b6f8d7f68357e6ee1a17b72c8a8eef59730 Mon Sep 17 00:00:00 2001 From: Bill Denney Date: Sun, 28 Oct 2018 14:37:31 -0400 Subject: [PATCH] Initial commit (hits documentation bug klutometis/roxygen#666) --- .Rbuildignore | 2 + .gitignore | 3 + DESCRIPTION | 10 ++ NAMESPACE | 2 + R/formula_math.R | 237 +++++++++++++++++++++++++++++++++++++++++++++++ formulops.Rproj | 16 ++++ 6 files changed, 270 insertions(+) create mode 100644 .Rbuildignore create mode 100644 .gitignore create mode 100644 DESCRIPTION create mode 100644 NAMESPACE create mode 100644 R/formula_math.R create mode 100644 formulops.Rproj diff --git a/.Rbuildignore b/.Rbuildignore new file mode 100644 index 0000000..91114bf --- /dev/null +++ b/.Rbuildignore @@ -0,0 +1,2 @@ +^.*\.Rproj$ +^\.Rproj\.user$ diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..807ea25 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +.Rproj.user +.Rhistory +.RData diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100644 index 0000000..102f72a --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,10 @@ +Package: formulops +Title: Mathematical Operations on R Formula +Version: 0.0.0.9000 +Authors@R: person("Bill", "Denney", email="wdenney@humanpredictions.com", role=c("aut", "cre"), comment=c(ORCID="0000-0002-5759-428X")) +Description: Perform mathematical operations on R formula (add, subtract, multiply, etc.). +Depends: R (>= 3.5.1) +License: GPL-3 +Encoding: UTF-8 +LazyData: true +RoxygenNote: 6.1.0 diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000..6ae9268 --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,2 @@ +# Generated by roxygen2: do not edit by hand + diff --git a/R/formula_math.R b/R/formula_math.R new file mode 100644 index 0000000..f614fb4 --- /dev/null +++ b/R/formula_math.R @@ -0,0 +1,237 @@ +#' Modify a formula by finding some part of it and replacing it with a new +#' value. +#' +#' @details Replacement occurs at the first match, so if the replacement list +#' would modify something in the find list, that change will not occur (make +#' two calls to the function for that effect). See the "Replacement is not +#' sequential" examples below. +#' +#' @param formula The formula to modify (may also be a call) +#' @param find A call or name (or list thereof) to search for within the formula +#' @param replace A call or name (or list thereof) to replace the \code{find} +#' values +#' @return \code{formula} modified +#' @examples +#' modify_formula(a~b, find=quote(a), replace=quote(c)) +#' modify_formula(a~b, find=quote(a), replace=quote(c+d)) +#' modify_formula(a~b/c, find=quote(b/c), replace=quote(d)) +#' # Replacement is not sequential +#' modify_formula(a~b/c, find=list(quote(b/c), quote(d)), replace=list(quote(d), quote(e))) +#' modify_formula(a~b/c+d, find=list(quote(b/c), quote(d)), replace=list(quote(d), quote(e))) +#' @export +modify_formula <- function(formula, find, replace) { + if (xor(is.list(find), is.list(replace))) { + stop("Both or neither of `find` and `replace` must be a list.") + } + if (!is.list(find)) { + find <- list(find) + replace <- list(replace) + } + if (length(find) != length(replace)) { + stop("`find` and `replace` lists must be the same length.") + } + if (length(find) == 0) { + stop("`find` and `replace` lists must have length > 0.") + } + + replaced <- FALSE + for (idx in seq_along(find)) { + if (identical(formula, find[[idx]])) { + formula <- replace[[idx]] + replaced <- TRUE + } + if (replaced) { + break + } + } + if (!replaced && length(formula) > 1) { + for (idx in seq_along(formula)) { + formula[[idx]] <- modify_formula(formula[[idx]], find, replace) + } + } + formula +} + +#' Add parentheses to a base formula to ensure clarify for order of operations +#' +#' @param base_formula A formula or name to modify with parts to be replaced +#' named `a` and `b` for \code{e1} and {e2}. +#' @param e1,e2 a name or call +#' @return \code{base_formula} revised such that `a` and `b` have parentheses +#' around them if \code{e1} and \code{e2} have lengths > 1, respectively. +#' @examples +#' add_parens_base_formula(a~b, quote(c+d), quote(e)) +#' @noRd +add_parens_base_formula <- function(base_formula, e1, e2) { + if (length(e1) > 1) { + base_formula <- modify_formula(base_formula, find=quote(a), replace=quote((a))) + } + if (!missing(e2)) { + if (length(e2) > 1) { + base_formula <- modify_formula(base_formula, find=quote(b), replace=quote((b))) + } + } + base_formula +} + +#' Perform a mathematical operation on two formula +#' +#' @details The method for combination depends if the two formula are one- or +#' two-sided. +#' +#' If both formula are one-sided, the right hand side (RHS) of both are added +#' together with additional parentheses added, if parentheses appear to be +#' needed. If both formula are two-sided, the left hand side (LHS) and RHS are +#' separately added. If one formula is one-sided and the other is two-sided, +#' the LHS is selected from the two-sided formula and the RHS follows rules as +#' though two one-sided formula were added. +#' +#' @param op The operation to perform either as a name or something that can be +#' coerced into a name. +#' @param e1,e2 The formulae to combine +#' @return \code{e1} and \code{e2} combined by the operation with the +#' environment from \code{e1}. See Details. +#' @examples +#' op_formula("+", a~b, c~d) +#' op_formula("+", a~b, ~d) +#' op_formula("+", ~b, c~d) +#' op_formula("+", ~b, ~d) +#' op_formula("-", a~b) +#' op_formula("-", -a~b) # Dumb, but accurate +#' op_formula("-", -a~b, c~-d) # Dumb, but accurate +#' +#' log(a~b) +#' @export +op_formula <- function(op, e1, e2) { + if (!is.name(op)) { + op <- as.name(op) + } + if (!(length(e1) %in% 2:3)) { + # is this possible? + stop("`e1` must be a one- or two-sided formula.") # nocov + } + if (!missing(e2) && !(length(e2) %in% 2:3)) { + # is this possible? + stop("`e2` must be a one- or two-sided formula.") # nocov + } + if (missing(e2)) { + # unary operator + base_formula <- + modify_formula(quote(-a), find=as.name("-"), replace=op) + out <- e1 + out[[2]] <- + modify_formula( + add_parens_base_formula(base_formula, e1=e1[[2]]), + find=quote(a), + replace=e1[[2]] + ) + if (length(e1) == 3) { + out[[3]] <- + modify_formula( + add_parens_base_formula(base_formula, e1=e1[[3]]), + find=quote(a), + replace=e1[[3]] + ) + } + } else if (length(e1) != length(e2)) { + if ((length(e1) == 2) & + (length(e2) == 3)) { + out <- e2 + other <- e1 + environment(out) <- environment(e1) + } else if ((length(e1) == 3) & + (length(e2) == 2)) { + out <- e1 + other <- e2 + } else { + stop("Unknown how to handle a formula with different lengths that are != 2 or 3") # nocov + } + out[[3]] <- op_formula(op, out[c(1, 3)], other)[[2]] + } else if (length(e1) == length(e2)) { + out <- e1 + # they are both one- or two-sided + base_formula <- + modify_formula( + quote(a+b), + find=as.name("+"), + replace=op + ) + if (length(e1) == 2) { + # one-sided + out[[2]] <- + modify_formula( + formula=add_parens_base_formula(base_formula, e1[[2]], e2[[2]]), + find=list(quote(a), quote(b)), + replace=list(e1[[2]], e2[[2]]) + ) + } else if (length(e1) == 3) { + # two-sided + out[[2]] <- + modify_formula( + formula=add_parens_base_formula(base_formula, e1[[2]], e2[[2]]), + find=list(quote(a), quote(b)), + replace=list(e1[[2]], e2[[2]]) + ) + out[[3]] <- + modify_formula( + formula=add_parens_base_formula(base_formula, e1[[3]], e2[[3]]), + find=list(quote(a), quote(b)), + replace=list(e1[[3]], e2[[3]]) + ) + } + } + out +} + +#' @describeIn op_formula Multiply two formula (identical to \code{(a~b) * (c~d)} +#' @export +multiply_formula <- function(e1, e2) { + op_formula("*", e1, e2) +} + +#' @describeIn op_formula Divide two formula (identical to \code{(a~b) / (c~d)} +#' @export +divide_formula <- function(e1, e2) { + op_formula("/", e1, e2) +} + +#' @describeIn op_formula Add two formula (identical to \code{(a~b) + (c~d)} +#' @export +add_formula <- function(e1, e2) { + op_formula("+", e1, e2) +} + +#' @describeIn op_formula Multiply two formula (identical to \code{(a~b) - (c~d)} +#' @export +subtract_formula <- function(e1, e2) { + op_formula("-", e1, e2) +} + +#' @describeIn op_formula Support generic binary operators and a couple of unary +#' operators (see ?Ops). +#' @export +Ops.formula <- function(e1, e2) { + if (missing(e2)) { + # Unary operators + op_formula(.Generic, e1) + } else { + op_formula(.Generic, e1, e2) + } +} + +#' @describeIn op_formula Support generic unary operators (see ?Math). +#' @export +Math.formula <- function(x, ...) { + base_formula <- + modify_formula(quote(a(b)), find=quote(a), replace=as.name(.Generic)) + out <- x + if (length(out) == 2) { + out[[2]] <- modify_formula(base_formula, find=quote(b), replace=out[[2]]) + } else if (length(out) == 3) { + out[[2]] <- modify_formula(base_formula, find=quote(b), replace=out[[2]]) + out[[3]] <- modify_formula(base_formula, find=quote(b), replace=out[[3]]) + } else { + stop("Can only work with one- or two-sided formula") + } + out +} diff --git a/formulops.Rproj b/formulops.Rproj new file mode 100644 index 0000000..d848a9f --- /dev/null +++ b/formulops.Rproj @@ -0,0 +1,16 @@ +Version: 1.0 + +RestoreWorkspace: No +SaveWorkspace: No +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +Encoding: UTF-8 + +AutoAppendNewline: Yes +StripTrailingWhitespace: Yes + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source +PackageRoxygenize: rd,collate,namespace