reformulas/0000755000176200001440000000000014711605143012433 5ustar liggesusersreformulas/tests/0000755000176200001440000000000014675010660013600 5ustar liggesusersreformulas/tests/tinytest.R0000644000176200001440000000013514675010660015605 0ustar liggesusersif ( requireNamespace("tinytest", quietly=TRUE) ){ tinytest::test_package("reformulas") } reformulas/MD50000644000176200001440000000270114711605143012743 0ustar liggesuserse66bd961bcf9aff2579b5c1020b5e94c *DESCRIPTION 0d5a87f25db98d025d87d693f3042396 *NAMESPACE d653eada3d21dbf7a5b6e1b7748ecc7a *NEWS.md 6aa4b1edbca492f7b252c6c7b81f758f *R/mkReTrms.R 6a4c8fea23367a2956a772e8e5949946 *R/nobars.R 3981e8adf76f45e9b0919d1e0b95dbca *R/utils.R 2f33bf4559117b14a3fc18174e154314 *README.md b58ceab946e22c9fd9f59a0f05191e03 *build/partial.rdb 49410fb0c89dfa9203db6228a2964510 *inst/REFERENCES.bib 8244acf2da9df678417d82719b9034cc *inst/tinytest/test_anySpecial.R 21960b35e8135fb4e8736d712c838dc4 *inst/tinytest/test_doubleVertNotation.R fee2a8d05ede7d8e984a27838e31623d *inst/tinytest/test_noSpecial.R e2b734a625b787b4a92308ca72723efc *inst/tinytest/test_nobar.R 0d2680a03e8a7f2b387602a1c1956be7 *inst/tinytest/test_utils.R d9345f3c9d3a6910778e34ef607de392 *man/RHSForm.Rd 58a16db5b324dbc4a155a19eac493791 *man/anySpecial.Rd 3c6bc90e7b664eab21dbe066ca01a39b *man/expandDoubleVerts.Rd 23cbc542bc1a65b2d6434cb4661be150 *man/expandGrpVar.Rd f28f22e3c741f23b32a4815ea0aa7f30 *man/findReTrmClasses.Rd d4f3c1806cf421c275bcbd2fc1ff8548 *man/formfuns.Rd fb5ff8c35c4107fb5a2f2c1b0958876c *man/isNested.Rd 0746157f67598e4c6802769b69473d49 *man/mkReTrms.Rd be8b6d7b81362f79355b5f9b848811c0 *man/no_specials.Rd 7acc9edecb23aea30c04951bff6d7fd7 *man/nobars.Rd 60fd2e65d4262f74fb930f3b72c87669 *man/splitForm.Rd 5cbbf8d75bc33deb76ecfa521a2731bd *man/sub_specials.Rd 8428ebd2fff700032749819307323a9c *man/subbars.Rd be6ef5f4fdf4db63765631620a778b22 *tests/tinytest.R reformulas/.aspell/0000755000176200001440000000000014675010660013774 5ustar liggesusersreformulas/.aspell/reformulas.rds0000644000176200001440000000006614675010660016667 0ustar liggesusersb```b`a@& srsC|\T0reformulas/.aspell/defaults.R0000644000176200001440000000023714675010660015730 0ustar liggesusersRd_files <- vignettes <- R_files <- description <- list(encoding = "UTF-8", language = "en", dictionaries = c("en_stats", "reformulas")) reformulas/R/0000755000176200001440000000000014711311002012620 5ustar liggesusersreformulas/R/mkReTrms.R0000644000176200001440000002624614675010660014540 0ustar liggesusers##' From the result of \code{\link{findbars}} applied to a model formula and ##' and the evaluation frame, create the model matrix, etc. associated with ##' random-effects terms. See the description of the returned value for a ##' detailed list. ##' ##' @title Create list of structures needed for models with random effects ##' @param bars a list of parsed random-effects terms ##' @param fr a model frame in which to evaluate these terms ##' @param drop.unused.levels (logical) drop unused factor levels? ##' @param reorder.terms arrange random effects terms in decreasing order of number of groups (factor levels)? ##' @param reorder.vars arrange columns of individual random effects terms in alphabetical order? ##' @param calc.lambdat (logical) compute \code{Lambdat} and \code{Lind} components? (At present these components ##' are needed for \code{lme4} machinery but not for \code{glmmTMB}, and may be large in some cases; see Bates \emph{et al.} 2015 ##' @return a list with components ##' \item{Zt}{transpose of the sparse model matrix for the random effects} ##' \item{Ztlist}{list of components of the transpose of the ##' random-effects model matrix, separated by random-effects term} ##' \item{Lambdat}{transpose of the sparse relative covariance factor} ##' \item{Lind}{an integer vector of indices determining the mapping of the ##' elements of the \code{theta} to the \code{"x"} slot of \code{Lambdat}} ##' \item{theta}{initial values of the covariance parameters} ##' \item{lower}{lower bounds on the covariance parameters} ##' \item{flist}{list of grouping factors used in the random-effects terms} ##' \item{cnms}{a list of column names of the random effects according to ##' the grouping factors} ##' \item{Gp}{a vector indexing the association of ##' elements of the conditional mode vector ##' with random-effect terms; if \code{nb} is the vector of numbers ##' of conditional modes per term (i.e. number of groups times number ##' of effects per group), \code{Gp} is \code{c(0,cumsum(nb))} ##' (and conversely \code{nb} is \code{diff(Gp)})} ##' \item{nl}{names of the terms (in the same order as \code{Zt}, ##' i.e. reflecting the \code{reorder.terms} argument)} ##' @importFrom Matrix sparseMatrix drop0 ## (no methods found in package 'Matrix' for rbind ... ???) ##' @importMethodsFrom Matrix coerce t diag ##' @importFrom Rdpack reprompt ##' @family utilities ##' @references \insertRef{lme4}{reformulas}) ##' @export mkReTrms <- function(bars, fr, drop.unused.levels=TRUE, reorder.terms=TRUE, reorder.vars=FALSE, calc.lambdat = TRUE) { if (!length(bars)) stop("No random effects terms specified in formula",call.=FALSE) stopifnot(is.list(bars), vapply(bars, is.language, NA), inherits(fr, "data.frame")) names(bars) <- barnames(bars) term.names <- vapply(bars, deparse1, "") ## get component blocks blist <- lapply(bars, mkBlist, fr, drop.unused.levels, reorder.vars = reorder.vars) nl <- vapply(blist, `[[`, 0L, "nl") # no. of levels per term # (in lmer jss: \ell_i) ## order terms stably by decreasing number of levels in the factor if (reorder.terms) { if (any(diff(nl) > 0)) { ord <- rev(order(nl)) blist <- blist [ord] nl <- nl [ord] term.names <- term.names[ord] } } Ztlist <- lapply(blist, `[[`, "sm") Zt <- do.call(rbind, Ztlist) ## eq. 7, JSS lmer paper names(Ztlist) <- term.names q <- nrow(Zt) ## Create and install Lambdat, Lind, etc. This must be done after ## any potential reordering of the terms. cnms <- lapply(blist, `[[`, "cnms") # list of column names of the # model matrix per term nc <- lengths(cnms) # no. of columns per term # (in lmer jss: p_i) nth <- as.integer((nc * (nc+1))/2) # no. of parameters per term # (in lmer jss: ??) nb <- nc * nl # no. of random effects per term # (in lmer jss: q_i) ## eq. 5, JSS lmer paper if (sum(nb) != q) { stop(sprintf("total number of RE (%d) not equal to nrow(Zt) (%d)", sum(nb),q)) } boff <- cumsum(c(0L, nb)) # offsets into b thoff <- cumsum(c(0L, nth)) # offsets into theta ## FIXME: should this be done with cBind and avoid the transpose ## operator? In other words should Lambdat be generated directly ## instead of generating Lambda first then transposing? if (calc.lambdat) { mk_b <-function(i) { mm <- matrix(seq_len(nb[i]), ncol = nc[i], byrow = TRUE) dd <- diag(nc[i]) ltri <- lower.tri(dd, diag = TRUE) ii <- row(dd)[ltri] jj <- col(dd)[ltri] ## unused: dd[cbind(ii, jj)] <- seq_along(ii) data.frame(i = as.vector(mm[, ii]) + boff[i], j = as.vector(mm[, jj]) + boff[i], x = as.double(rep.int(seq_along(ii), rep.int(nl[i], length(ii))) + thoff[i])) } Lambdat <- t(do.call(sparseMatrix, do.call(rbind, lapply(seq_along(blist), mk_b)))) Lind <- as.integer(Lambdat@x) } else { Lambdat <- Lind <- NULL } thet <- numeric(sum(nth)) ll <- list(Zt = drop0(Zt), theta = thet, Lind = Lind, Gp = unname(c(0L, cumsum(nb)))) ## lower bounds on theta elements are 0 if on diagonal, else -Inf ll$lower <- -Inf * (thet + 1) if (calc.lambdat) { ll$lower[unique(diag(Lambdat))] <- 0 Lambdat@x[] <- ll$theta[ll$Lind] # initialize elements of Lambdat } ll$theta[] <- is.finite(ll$lower) # initial values of theta are 0 off-diagonal, 1 on ll$Lambdat <- Lambdat # massage the factor list fl <- lapply(blist, `[[`, "ff") # check for repeated factors fnms <- names(fl) if (length(fnms) > length(ufn <- unique(fnms))) { fl <- fl[match(ufn, fnms)] asgn <- match(fnms, ufn) } else asgn <- seq_along(fl) names(fl) <- ufn ## DON'T need fl to be a data.frame ... ## fl <- do.call(data.frame, c(fl, check.names = FALSE)) attr(fl, "assign") <- asgn ll$flist <- fl ll$cnms <- cnms ll$Ztlist <- Ztlist ll$nl <- nl ll } ## {mkReTrms} ##' @param x a language object of the form effect | groupvar ##' @param frloc model frame ##' @param drop.unused.levels (logical) ##' @return list containing grouping factor, sparse model matrix, number of levels, names ##' @importFrom Matrix KhatriRao fac2sparse sparse.model.matrix ##' @importFrom stats model.matrix ##' @noRd mkBlist <- function(x,frloc, drop.unused.levels=TRUE, reorder.vars=FALSE) { frloc <- factorize(x,frloc) ## try to evaluate grouping factor within model frame ... ff0 <- replaceTerm(x[[3]], quote(`:`), quote(`%i%`)) ff <- try(eval(substitute(makeFac(fac), list(fac = ff0)), frloc), silent = TRUE) if (inherits(ff, "try-error")) { stop("couldn't evaluate grouping factor ", deparse1(x[[3]])," within model frame:", "error =", c(ff), " Try adding grouping factor to data ", "frame explicitly if possible",call.=FALSE) } if (all(is.na(ff))) stop("Invalid grouping factor specification, ", deparse1(x[[3]]),call.=FALSE) ## NB: *also* silently drops levels - and mkReTrms() and hence ## predict.merMod() have relied on that property : if (drop.unused.levels) ff <- factor(ff, exclude=NA) nl <- length(levels(ff)) ## this section implements eq. 6 of the JSS lmer paper ## model matrix based on LHS of random effect term (X_i) ## x[[2]] is the LHS (terms) of the a|b formula has.sparse.contrasts <- function(x) { cc <- attr(x, "contrasts") !is.null(cc) && is(cc, "sparseMatrix") } any.sparse.contrasts <- any(vapply(frloc, has.sparse.contrasts, FUN.VALUE = TRUE)) mMatrix <- if (!any.sparse.contrasts) model.matrix else sparse.model.matrix mm <- mMatrix(eval(substitute( ~ foo, list(foo = x[[2]]))), frloc) if (reorder.vars) { mm <- mm[colSort(colnames(mm)),] } ## this is J^T (see p. 9 of JSS lmer paper) ## construct indicator matrix for groups by observations ## use fac2sparse() rather than as() to allow *not* dropping ## unused levels where desired sm <- fac2sparse(ff, to = "d", drop.unused.levels = drop.unused.levels) sm <- KhatriRao(sm, t(mm)) dimnames(sm) <- list( rep(levels(ff),each=ncol(mm)), rownames(mm)) list(ff = ff, sm = sm, nl = nl, cnms = colnames(mm)) } ##' @noRd ##' @param bars result of findbars barnames <- function(bars) vapply(bars, function(x) deparse1(x[[3]]), "") makeFac <- function(x,char.only=FALSE) { if (!is.factor(x) && (!char.only || is.character(x))) factor(x) else x } factorize <- function(x,frloc,char.only=FALSE) { ## convert grouping variables to factors as necessary ## TODO: variables that are *not* in the data frame are ## not converted -- these could still break, e.g. if someone ## tries to use the : operator ## TODO: some sensible tests for drop.unused.levels ## (not actually used, but could come in handy) for (i in all.vars(RHSForm(x))) { if (!is.null(curf <- frloc[[i]])) frloc[[i]] <- makeFac(curf,char.only) } return(frloc) } colSort <- function(x) { termlev <- vapply(strsplit(x,":"),length,integer(1)) iterms <- split(x,termlev) iterms <- sapply(iterms,sort,simplify=FALSE) ## make sure intercept term is first ilab <- "(Intercept)" if (ilab %in% iterms[[1]]) { iterms[[1]] <- c(ilab,setdiff(iterms[[1]],ilab)) } unlist(iterms) } ## infix interaction operator (more careful) `%i%` <- function(f1, f2, fix.order = TRUE) { if (!is.factor(f1) || !is.factor(f2)) stop("both inputs must be factors") f12 <- paste(f1, f2, sep = ":") ## explicitly specifying levels is faster in any case ... u <- which(!duplicated(f12)) if (!fix.order) return(factor(f12, levels = f12[u])) ## deal with order of factor levels levs_rank <- length(levels(f2))*as.numeric(f1[u])+as.numeric(f2[u]) return(factor(f12, levels = (f12[u])[order(levs_rank)])) } ## was called "replaceForm" there but replaceTerm is better ## (decide on camelCase vs snake_case!) replaceTerm <- function(term,target,repl) { if (identical(term,target)) return(repl) if (!inForm(term,target)) return(term) if (length(term) == 2) { return(substitute(OP(x),list(OP=replaceTerm(term[[1]],target,repl), x=replaceTerm(term[[2]],target,repl)))) } return(substitute(OP(x,y),list(OP=replaceTerm(term[[1]],target,repl), x=replaceTerm(term[[2]],target,repl), y=replaceTerm(term[[3]],target,repl)))) } reformulas/R/utils.R0000644000176200001440000010143114711311002014103 0ustar liggesusers## backward compat (copied from lme4) if ((getRversion()) < "3.2.1") { lengths <- function (x, use.names = TRUE) vapply(x, length, 1L, USE.NAMES = use.names) } if (getRversion() < "4.0.0") { deparse1 <- function (expr, collapse = " ", width.cutoff = 500L, ...) { paste(deparse(expr, width.cutoff, ...), collapse = collapse) } } #' expand double-bar RE notation by splitting #' @param term a formula term #' @rdname formfuns #' @export expandDoubleVert <- function(term) { frml <- formula(substitute(~x,list(x=term[[2]]))) ## need term.labels not all.vars to capture interactions too: tt <- terms(frml) newtrms <- lapply(attr(tt, "term.labels"), function(t) { sumTerms(list(0, toLang(t))) }) if(attr(tt, "intercept") != 0) { newtrms <- c(1, newtrms) } res <- lapply(newtrms, function(t) { makeOp( makeOp(t, term[[3]], quote(`|`)), quote(`(`) ) }) return(res) } ##' From the right hand side of a formula for a mixed-effects model, ##' expand terms with the double vertical bar operator ##' into separate, independent random effect terms. ##' ##' @title Expand terms with \code{'||'} notation into separate \code{'|'} terms ##' @seealso \code{\link{formula}}, \code{\link{model.frame}}, \code{\link{model.matrix}}. ##' @param term a mixed-model formula ##' @return the modified term ##' @family utilities ##' @keywords models utilities ##' @export expandDoubleVerts <- function(term) { expandDoubleVert <- function(term) { frml <- formula(substitute(~x,list(x=term[[2]]))) ## FIXME: do this without paste and deparse if possible! ## need term.labels not all.vars to capture interactions too: newtrms <- paste0("0+", attr(terms(frml), "term.labels")) if(attr(terms(frml), "intercept")!=0) newtrms <- c("1", newtrms) as.formula(paste("~(", paste(vapply(newtrms, function(trm) paste0(trm, "|", deparse(term[[3]])), ""), collapse=")+("), ")"))[[2]] } if (!is.name(term) && is.language(term)) { if (term[[1]] == as.name("(")) { term[[2]] <- expandDoubleVerts(term[[2]]) } stopifnot(is.call(term)) if (term[[1]] == as.name('||')) return( expandDoubleVert(term) ) ## else : term[[2]] <- expandDoubleVerts(term[[2]]) if (length(term) != 2) { if(length(term) == 3) term[[3]] <- expandDoubleVerts(term[[3]]) } } term } #' extract right-hand side of a formula #' @param form a formula object #' @param as.form (logical) return a formula (TRUE) or as a call/symbolic object (FALSE) ? #' @examples #' RHSForm(y ~ x + (1|g)) #' @return a \code{language} object #' @export RHSForm <- function(form, as.form=FALSE) { if (!as.form) return(form[[length(form)]]) if (length(form)==2) return(form) ## already RHS-only ## by operating on RHS in situ rather than making a new formula ## object, we avoid messing up existing attributes/environments etc. form[[2]] <- NULL ## assumes response is *first* variable (I think this is safe ...) if (length(vars <- attr(form,"variables"))>0) { attr(form,"variables") <- vars[-2] } if (is.null(attr(form,"response"))) { attr(form,"response") <- 0 } if (length(facs <- attr(form,"factors"))>0) { attr(form,"factors") <- facs[-1,] } return(form) } #' set the right side of a formula #' @param formula a formula object #' @param value replacement value for RHS #' @rdname formfuns #' @examples #' f <- y ~ 1 + x #' RHSForm(f) <- quote(2+x^2) #' print(f) #' @export `RHSForm<-` <- function(formula,value) { formula[[length(formula)]] <- value formula } #' combine a list of formula terms as a sum #' @param termList a list of formula terms #' @rdname formfuns #' @export sumTerms <- function(termList) { Reduce(function(x,y) makeOp(x,y,op=quote(`+`)),termList) } #' extract random effects component of formula #' @param f a formula #' @param response include response variable? #' @param bracket bracket-protect terms? #' @param doublevert_split (logical) TRUE for lme4 back-compatibility; FALSE to make double vertical bars into \code{diag()} eterms #' @rdname formfuns #' @examples #' reOnly(~ 1 + x + y + (1|f) + (1|g)) #' @export reOnly <- function(f, response=FALSE, bracket=TRUE, doublevert_split = TRUE) { flen <- length(f) f2 <- f[[2]] if (bracket) { xdv <- if (doublevert_split) "split" else "diag_special" fb <- findbars_x(f, expand_doublevert_method = xdv) f <- lapply(fb, makeOp, quote(`(`)) ## bracket-protect terms } f <- sumTerms(f) if (response && flen==3) { form <- makeOp(f2, f, quote(`~`)) } else { form <- makeOp(f, quote(`~`)) } return(form) } #' combine unary or binary operator + arguments (sugar for 'substitute') #' @param x a formula term #' @param y a formula term (or an operator) #' @param op an operator #' @rdname formfuns ## FIXME: would be nice to have multiple dispatch, so ## (arg,op) gave unary, (arg,arg,op) gave binary operator #' @export makeOp <- function(x, y, op=NULL) { if (is.null(op) || missing(y)) { ## unary if (is.null(op)) { substitute(OP(X),list(X=x,OP=y)) } else { substitute(OP(X),list(X=x,OP=op)) } } else substitute(OP(X,Y), list(X=x,OP=op,Y=y)) } #' combines the right-hand sides of two formulas, or a formula and a symbol #' @param f1 formula #1 #' @param f2 formula #2 #' @rdname formfuns #' @export #' @examples #' addForm0(y~x,~1) #' addForm0(~x,~y) addForm0 <- function(f1,f2) { tilde <- as.symbol("~") if (!identical(head(f2),tilde)) { f2 <- makeOp(f2,tilde) } if (length(f2)==3) warning("discarding LHS of second argument") RHSForm(f1) <- makeOp(RHSForm(f1),RHSForm(f2),quote(`+`)) return(f1) } #' Combine right-hand sides of an arbitrary number of formulas #' @param ... arguments to pass through to \code{addForm0} #' @rdname formfuns #' @export addForm <- function(...) { Reduce(addForm0,list(...)) } ## FIXME: how do we handle sharing this information ## (names of covstructs) between glmmTMB and here? .valid_covstruct <- c( diag = 0, us = 1, cs = 2, ar1 = 3, ou = 4, exp = 5, gau = 6, mat = 7, toep = 8, rr = 9, homdiag = 10 ) #' list of specials -- taken from enum.R findReTrmClasses <- function() { c(names(.valid_covstruct), "s") } toLang <- function(x) parse(text=x)[[1]] #' apply #' @param f a language object (an atom of a formula) #' expandGrpVar(quote(x*y)) #' expandGrpVar(quote(x/y)) expandGrpVar <- function(f) { form <- as.formula(makeOp(f,quote(`~`))) mm <- terms(form) tl <- attr(mm,"term.labels") ## reverse order: f/g -> f + g:f (for lme4/back-compatibility) switch_order <- function(x) paste(rev(unlist(strsplit(x, ":"))), collapse = ":") if (inForm(f, quote(`/`))) { ## vapply adds names; remove them, and reverse order of sub-terms, for back-compatibility ... tl <- unname(vapply(tl, switch_order, character(1))) tl <- rev(tl) } res <- lapply(tl, toLang) return(res) } ##' expand interactions/combinations of grouping variables ##' ##' Modeled after lme4:::expandSlash, by Doug Bates. However, ##' all formula operators that apply to factors (\code{*}, \code{/}, \code{+}) ##' are applicable: the results are expanded into a list of independent (additive) ##' random effect terms ##' @param bb a list of naked grouping variables, i.e. 1 | f ##' @examples ##' ff <- findbars_x(y~1+(x|f/g)) ##' expandAllGrpVar(ff) ##' expandAllGrpVar(quote(1|(f/g)/h)) ##' expandAllGrpVar(quote(1|f/g/h)) ##' expandAllGrpVar(quote(1|f*g)) ##' expandAllGrpVar(quote(1|f+g)) ##' expandAllGrpVar(quote(a+b|f+g+h*i)) ##' expandAllGrpVar(quote(s(log(d), k = 4))) ##' expandAllGrpVar(quote(s(log(d+1)))) ##' @importFrom utils head ##' @rdname formfuns ##' @export ## wish list ... this should be (1|a) + (1|a:b) + (1|a:b:c) + (1|a:b:d) ... ## expandAllGrpVar(quote(a/b/(c+d))) expandAllGrpVar <- function(bb) { ## Return the list of expanded terms (/, *, ?) if (!is.list(bb)) expandAllGrpVar(list(bb)) else { for (i in seq_along(bb)) { return(unlist(lapply(bb,esfun))) } ## loop over bb } } esfun <- function(x) { if (length(x)==1 || !anySpecial(x, "|")) return(x) if (length(x)==2) { ## if (head(x)==as.name("(")) { ## return(makeOp(esfun(x[[2]]), quote(`(`))) ## } ## unary operator such as diag(1|f/g) ## return diag(...) + diag(...) + ... return(lapply(esfun(x[[2]]), makeOp, y=x[[1]])) } if (length(x)==3) { ## binary operator if (x[[1]]==quote(`|`)) { return(lapply(expandGrpVar(x[[3]]), makeOp, x=x[[2]], op=quote(`|`))) } else { return(x) ## return(x) would be nice, but in that case x gets evaluated ## return(setNames(makeOp(esfun(x[[2]]), esfun(x[[3]]), ## op=x[[1]]), names(x))) } } } ## esfun def. ## sugar: this returns the operator, whether ~ or something else #' @export head.formula <- function(x, ...) { x[[1]] } #' @export head.call <- head.formula #' @export head.language <- head.formula #' @export ## sugar: we can call head on a symbol and get back the symbol head.name <- function(x, ...) { x } ##' Find and process random effects terms ##' ##' @param term a formula or piece of a formula ##' @param debug (logical) debug? ##' @param specials list of special terms ##' @param default.special character: special to use for parenthesized terms - i.e. random effects terms with unspecified structure ##' @param expand_doublevert_method method for handling \code{||} operator: split into separate terms or replace by \code{diag}? Inherited from \emph{previous call where it was specified}. ##' 1. atom (not a call or an expression): NULL ##' 2. special, i.e. foo(...) where "foo" is in specials: return term ##' 3. parenthesized term: \emph{if} the head of the head is | (i.e. ##' it is of the form (xx|gg), then convert it to the default ##' special type; we won't allow pathological cases like ##' ((xx|gg)) ... can we detect them? ##' @examples ##' splitForm(quote(us(x,n=2))) ##' findbars_x(~ 1 + (x + y || g), expand_doublevert_method = "diag_special") ##' findbars_x(~ 1 + (x + y || g), expand_doublevert_method = "split") ##' findbars_x(~ 1 + (1 | f) + (1 | g)) ##' findbars_x(~ 1 + (1 | f) + (1 | g)) ##' findbars_x(~ 1 + (1|h) + (x + y || g), expand_doublevert_method = "split") ##' findbars_x(~ 1 + (1|Subject)) ##' findbars_x(~ (1||Subject)) ##' findbars_x(~ (1|Subject)) ##' findbars_x(~ (1|Subject), default.special = NULL) ##' findbars_x(~ 1 + x) ##' findbars_x(~ s(x, bs = "tp")) ##' findbars_x(y ~ a + log(b) + s(x, bs = "tp") + s(y, bs = "gp"), ##' target = "s", default.special = NULL) ##' @rdname formfuns ##' @export findbars_x <- function(term, debug=FALSE, specials=character(0), default.special="us", target = '|', expand_doublevert_method = c("diag_special", "split")) { expand_doublevert_method <- match.arg(expand_doublevert_method) ## drop RHS from two-sided formula if (length(term) == 3 && identical(term[[1]], quote(`~`))) { term <- RHSForm(term, as.form = TRUE) } ds <- if (is.null(default.special)) { NULL } else { ## convert default special char to symbol (less ugly way?) eval(substitute(as.name(foo),list(foo=default.special))) } ## base function ## defining internally in this way makes debugging slightly ## harder, but (1) allows easy propagation of the top-level ## arguments down the recursive chain; (2) allows the top-level ## expandAllGrpVar() operation (which also handles cases where ## a naked term rather than a list is returned) fbx <- function(term) { if (is.name(term) || !is.language(term)) return(NULL) if (list(term[[1]]) %in% lapply(specials,as.name)) { if (debug) cat("special: ",deparse(term),"\n") return(term) } if (head(term) == as.name(target)) { ## found x | g if (debug) { tt <- if (target == '|') "bar" else sprintf('"%s"', target) cat(sprintf("%s term: %s\n", tt, deparse(term))) } if (is.null(ds)) return(term) return(makeOp(term, ds)) } if (head(term) == as.name("||")) { if (expand_doublevert_method == "diag_special") { return(makeOp(makeOp(term[[2]], term[[3]], op = quote(`|`)), as.name("diag"))) } if (expand_doublevert_method == "split") { ## need to return *multiple* elements return(lapply(expandDoubleVert(term), fbx)) } stop("unknown doublevert method ", expand_doublevert_method) } if (head(term) == as.name("(")) { ## found (...) if (debug) cat("paren term:",deparse(term),"\n") return(fbx(term[[2]])) } stopifnot(is.call(term)) if (length(term) == 2) { ## unary operator, decompose argument if (debug) cat("unary operator:",deparse(term[[2]]),"\n") return(fbx(term[[2]])) } ## binary operator, decompose both arguments f2 <- fbx(term[[2]]) f3 <- fbx(term[[3]]) if (debug) { cat("binary operator:",deparse(term[[2]]),",", deparse(term[[3]]),"\n") cat("term 2: ", deparse(f2), "\n") cat("term 3: ", deparse(f3), "\n") } c(f2, f3) } fbx_term <- fbx(term) if (debug) cat("fbx(term): ", deparse(fbx_term)) expandAllGrpVar(fbx_term) } ##' @rdname formfuns ##' @export ## lme4::findbars-compatible findbars <- function(term) { findbars_x(term, default.special=NULL, expand_doublevert_method = "split") } ##' Parse a formula into fixed formula and random effect terms, ##' treating 'special' terms (of the form foo(x|g\[,m\])) appropriately ##' ##' Taken from Steve Walker's lme4ord, ##' ultimately from the flexLambda branch of lme4 ##' . Mostly for internal use. ##' @title Split formula containing special random effect terms ##' @param formula a formula containing special random effect terms ##' @param defaultTerm default type for non-special RE terms ##' @param allowFixedOnly (logical) are formulas with no RE terms OK? ##' @param allowNoSpecials (logical) are formulas with only standard RE terms OK? ##' @return a list containing elements \code{fixedFormula}; ##' \code{reTrmFormulas} list of \code{x | g} formulas for each term; ##' \code{reTrmAddArgs} list of function+additional arguments, i.e. \code{list()} (non-special), \code{foo()} (no additional arguments), \code{foo(addArgs)} (additional arguments); \code{reTrmClasses} (vector of special functions/classes, as character) ##' @examples ##' splitForm(~x+y) ## no specials or RE ##' splitForm(~x+y+(f|g)) ## no specials ##' splitForm(~x+y+diag(f|g)) ## one special ##' splitForm(~x+y+(diag(f|g))) ## 'hidden' special ##' splitForm(~x+y+(f|g)+cs(1|g)) ## combination ##' splitForm(~x+y+(1|f/g)) ## 'slash'; term ##' splitForm(~x+y+(1|f/g/h)) ## 'slash'; term ##' splitForm(~x+y+(1|(f/g)/h)) ## 'slash'; term ##' splitForm(~x+y+(f|g)+cs(1|g)+cs(a|b,stuff)) ## complex special ##' splitForm(~(((x+y)))) ## lots of parentheses ##' splitForm(~1+rr(f|g,n=2)) ##' splitForm(~1+s(x, bs = "tp")) ##' ##' @author Steve Walker ##' @export splitForm <- function(formula, defaultTerm="us", allowFixedOnly=TRUE, allowNoSpecials=TRUE, debug=FALSE, specials = findReTrmClasses()) { ## logic: ## string for error message *if* specials not allowed ## (probably package-specific) noSpecialsAlt <- "lmer or glmer" ## formula <- expandDoubleVerts(formula) ## split formula into separate ## random effects terms ## (including special terms) fbxx <- findbars_x(formula, debug, specials) formSplits <- expandAllGrpVar(fbxx) if (length(formSplits)>0) { formSplitID <- sapply(lapply(formSplits, "[[", 1), as.character) # warn about terms without a # setReTrm method ## FIXME:: do we need all of this?? if (FALSE) { badTrms <- formSplitID == "|" ## if(any(badTrms)) { ## stop("can't find setReTrm method(s)\n", ## "use findReTrmClasses() for available methods") ## FIXME: coerce bad terms to default as attempted below ## warning(paste("can't find setReTrm method(s) for term number(s)", ## paste(which(badTrms), collapse = ", "), ## "\ntreating those terms as unstructured")) formSplitID[badTrms] <- "(" fixBadTrm <- function(formSplit) { makeOp(formSplit[[1]],quote(`(`)) ## as.formula(paste(c("~(", as.character(formSplit)[c(2, 1, 3)], ")"), ## collapse = " "))[[2]] } formSplits[badTrms] <- lapply(formSplits[badTrms], fixBadTrm) } ## skipped parenTerm <- formSplitID == "(" # capture additional arguments reTrmAddArgs <- lapply(formSplits, "[", -2)[!parenTerm] # remove these additional # arguments formSplits <- lapply(formSplits, "[", 1:2) # standard RE terms formSplitStan <- formSplits[parenTerm] # structured RE terms formSplitSpec <- formSplits[!parenTerm] if (!allowNoSpecials) { if(length(formSplitSpec) == 0) stop( "no special covariance structures. ", "please use ",noSpecialsAlt, " or use findReTrmClasses() for available structures.") } reTrmFormulas <- c(lapply(formSplitStan, "[[", 2), lapply(formSplitSpec, "[[", 2)) reTrmFormulas <- unlist(reTrmFormulas) # Fix me:: added for rr structure when it has n = 2, gives a list of list... quick fix reTrmClasses <- c(rep(defaultTerm, length(formSplitStan)), sapply(lapply(formSplitSpec, "[[", 1), as.character)) } else { reTrmFormulas <- reTrmAddArgs <- reTrmClasses <- NULL } ## nobars() will get rid of any *naked* RE terms ## FIXME ... let noSpecials handle naked bar-terms if desired ? ## (would adding "|" to reTrmClasses work?) fixedFormula <- noSpecials(nobars(formula)) list(fixedFormula = fixedFormula, reTrmFormulas = reTrmFormulas, reTrmAddArgs = reTrmAddArgs, reTrmClasses = reTrmClasses) } ##' @param term language object ##' @rdname splitForm ##' @param debug debugging mode (print stuff)? ##' @examples ##' noSpecials(y~1+us(1|f)) ##' noSpecials(y~1+us(1|f),delete=FALSE) ##' noSpecials(y~us(1|f)) ##' noSpecials(y~us(1|f), delete=FALSE) ##' noSpecials(y~us(1|f), debug=TRUE) ##' noSpecials(y~us+1) ## should *not* delete unless head of a function ##' noSpecials(~us(1|f)+1) ## should work on a one-sided formula! ##' noSpecials(~s(stuff) + a + b, specials = "s") ##' noSpecials(cbind(b1, 20-b1) ~ s(x, bs = "tp")) ##' @export ##' @keywords internal noSpecials <- function(term, delete=TRUE, debug=FALSE, specials = findReTrmClasses()) { nospec <- noSpecials_(term, delete=delete, debug=debug, specials = specials) empty_RHS <- inherits(term, "formula") && length(term) == 3 && (is.symbol(nospec) || !identical(nospec[[1]], quote(`~`))) if (empty_RHS) { ## called with two-sided RE-only formula: ## construct response~1 formula as.formula(substitute(R~1,list(R=nospec)), env=environment(term)) ## FIXME::better 'nothing left' handling } else if (is.null(nospec)) { ~1 } else { nospec } } noSpecials_ <- function(term, delete=TRUE, debug=FALSE, specials = findReTrmClasses()) { if (debug) print(term) if (!anySpecial(term, specials)) return(term) if (length(term)==1) return(term) ## 'naked' specials if (isSpecial(term, specials)) { if(delete) { return(NULL) } else { ## careful to return (1|f) and not 1|f: return(substitute((TERM), list(TERM = term[[2]]))) } } else { if (debug) print("not special") nb2 <- noSpecials_(term[[2]], delete=delete, debug=debug, specials = specials) nb3 <- if (length(term)==3) { noSpecials_(term[[3]], delete=delete, debug=debug, specials = specials) } else NULL if (is.null(nb2)) { if (debug) cat("term[[2]] NULL, returning noSpecials_(term[[3]])\n") return(nb3) } else if (is.null(nb3)) { if (debug) cat("term[[3]] NULL\n") if (length(term)==2 && identical(term[[1]], quote(`~`))) { ## special case for one-sided formula if (debug) cat("one-sided formula special case\n") term[[2]] <- nb2 return(term) } else { return(nb2) } } else { ## neither term completely disappears term[[2]] <- nb2 term[[3]] <- nb3 return(term) } } } isSpecial <- function(term, specials = findReTrmClasses()) { if(is.call(term)) { ## %in% doesn't work (requires vector args) for(cls in specials) { if(term[[1]] == cls) return(TRUE) } } FALSE } isAnyArgSpecial <- function(term, specials = findReTrmClasses()) { for(tt in term) if(isSpecial(tt, specials)) return(TRUE) FALSE } #' Detect whether there are any 'specials' in a formula term #' @param term formula term #' @param specials values to detect #' @param fast (logical) use quick (syntactic) test for presence of specials? #' @return logical value #' @examples #' ## should only detect s as the head of a function, s(...) #' anySpecial(~diag(1)) #' anySpecial(~diag) #' anySpecial(~diag[[1]]) #' anySpecial(~diag[1]) #' anySpecial(~s) #' anySpecial(~s(hello+goodbye,whatever)) #' @export anySpecial <- function(term, specials=findReTrmClasses(), fast = FALSE) { if (fast) return(any(specials %in% all.names(term))) has_s <- FALSE as2 <- function(expr) { if (length(expr) == 1) return(NULL) ## we've hit bottom for (ss in specials) { if (identical(expr[[1]], as.name(ss))) { assign("has_s", TRUE, environment(as2)) break } } if (has_s) return(NULL) ## short-circuit lapply(expr[-1], as2) } as2(term) ## run function for side effect return(has_s) } ## also see: ## https://stackoverflow.com/questions/79093440/is-there-a-way-to-tell-if-the-formula-contains-specific-function-inside/79094196#79094196 ## rfun <- function(expr) { if (length(expr) == 1) return(FALSE) ## we've hit bottom if (identical(expr[[1]], quote(s))) return(TRUE) for (el in as.list(expr[-1])) { if (rfun(el)) return(TRUE) } return(FALSE) } ##' test whether a formula contains a particular element? ##' @rdname formfuns ##' @examples ##' inForm(z~.,quote(.)) ##' inForm(z~y,quote(.)) ##' inForm(z~a+b+c,quote(c)) ##' inForm(z~a+b+(d+e),quote(c)) ##' f <- ~ a + offset(x) ##' f2 <- z ~ a ##' inForm(f,quote(offset)) ##' inForm(f2,quote(offset)) ##' @export ##' @keywords internal inForm <- function(form, value) { if (any(sapply(form,identical,value))) return(TRUE) if (all(sapply(form,length)==1)) return(FALSE) return(any(vapply(form,inForm,value,FUN.VALUE=logical(1)))) } ##' extract terms with a given head from an expression/formula ##' @rdname formfuns ##' @param term expression/formula ##' @param value head of terms to extract ##' @return a list of expressions ##' @examples ##' extractForm(~a+offset(b),quote(offset)) ##' extractForm(~c,quote(offset)) ##' extractForm(~a+offset(b)+offset(c),quote(offset)) ##' extractForm(~offset(x),quote(offset)) ##' @export ##' @keywords internal extractForm <- function(term,value) { if (!inForm(term,value)) return(NULL) if (is.name(term) || !is.language(term)) return(NULL) if (identical(head(term),value)) { return(list(term)) } if (length(term) == 2) { return(extractForm(term[[2]],value)) } return(c(extractForm(term[[2]],value), extractForm(term[[3]],value))) } ##' return a formula/expression with a given value stripped, where ##' it occurs as the head of a term ##' @rdname formfuns ##' @examples ##' dropHead(~a+offset(b),quote(offset)) ##' dropHead(~a+poly(x+z,3)+offset(b),quote(offset)) ##' @export ##' @keywords internal dropHead <- function(term,value) { if (!inForm(term,value)) return(term) if (is.name(term) || !is.language(term)) return(term) if (identical(head(term),value)) { return(term[[2]]) } if (length(term) == 2) { return(dropHead(term[[2]],value)) } else if (length(term) == 3) { term[[2]] <- dropHead(term[[2]],value) term[[3]] <- dropHead(term[[3]],value) return(term) } else stop("length(term)>3") } ##' drop terms matching a particular value from an expression ##' @rdname formfuns ## from Gabor Grothendieck: recursive solution ## http://stackoverflow.com/questions/40308944/removing-offset-terms-from-a-formula ##' @param x formula ##' @param value term to remove from formula ##' @param preserve (integer) retain the specified occurrence of "value" ##' @examples ##' drop.special(x~a + b+ offset(z)) ##' @export ##' @importFrom stats update formula ##' @keywords internal drop.special <- function(x, value=quote(offset), preserve = NULL) { k <- 0 proc <- function(x) { if (length(x) == 1) return(x) if (x[[1]] == value && !((k <<- k+1) %in% preserve)) return(x[[1]]) replace(x, -1, lapply(x[-1], proc)) } ## handle 1- and 2-sided formulas if (length(x)==2) { newform <- substitute(~ . -x, list(x=value)) } else { newform <- substitute(. ~ . - x, list(x=value)) } return(update(proc(x), newform)) } #' replace a component of a call/parse tree #' n.b. won't work for terms with more than 2 args ... #' @rdname formfuns #' @export #' @examples #' replaceForm(quote(a(b+x*c(y,z))),quote(y),quote(R)) #' ss <- ~(1 | cask:batch) + (1 | batch) #' replaceForm(ss,quote(cask:batch),quote(batch:cask)) #' replaceForm(ss, quote(`:`), quote(`%:%`)) replaceForm <- function(term,target,repl) { if (identical(term,target)) return(repl) if (!inForm(term,target)) return(term) if (length(term) == 2) { return(substitute(OP(x),list(OP=replaceForm(term[[1]],target,repl), x=replaceForm(term[[2]],target,repl)))) } return(substitute(OP(x,y),list(OP=replaceForm(term[[1]],target,repl), x=replaceForm(term[[2]],target,repl), y=replaceForm(term[[3]],target,repl)))) } ##' Drop 'specials' from a formula ##' @param term a term or formula or list thereof ##' @param specials function types to drop ##' @return a \code{call} or \code{language} object (or list) with specials removed ##' @examples ##' no_specials(findbars_x(~ 1 + s(x) + (f|g) + diag(x|y))) ##' no_specials(~us(f|g)) ##' @export no_specials <- function(term, specials = c("|", "||", "s")) { if (is.list(term)) { return(lapply(term, no_specials)) } for (ss in specials) { if (identical(head(term), as.name(ss))) return(term) } if (length(term) == 3) stop("don't know what to do") return(no_specials(term[[2]], specials)) } ##' Substitute safe chars (+) for specials (for use in \code{model.frame}) ##' (Generalized from \code{lme4}'s \code{subbars} function.) ##' @param term formula or term in a formula ##' @param specials names of specials to process ##' @param keep_args number of arguments to retain (matching \code{specials}) ##' @return a term or formula with specials replaced by \code{+} (and extra arguments dropped) ##' @keywords internal ##' @examples ##' sub_specials( ~ s(a, k=4)) ##' sub_specials( ~ (1|x) + (a + b || y) + s(a, k=4)) ##' sub_specials(Reaction ~ s(Days) + (1 + Subject)) ##' sub_specials(~ s(cos((y^2*3)/2), bs = "tp")) ##' @export sub_specials <- function (term, specials = c("|", "||", "s"), keep_args = c(2L, 2L, NA_integer_)) { if (is.name(term) || !is.language(term)) return(term) ## previous version recursed immediately for unary operators, ## (we were only interested in `|`(x,y) and `||`(x,y)) ## but here s(x) needs to be processed ... for (i in seq_along(specials)) { if (is.call(term) && term[[1]] == as.name(specials[i])) { if (is.na(keep_args[i])) { ## keep only *unnamed* args if (!is.null(names(term))) { term <- term[names(term)==""] } } else { term <- term[1:(1+keep_args[i])] } term[[1]] <- as.name("+") ## converts s(x) to +x, which is ugly, but ## formula can handle repeated '+' ## discard additional arguments (e.g for s(x, ...)) ## (fragile re: order??) } } for (j in 2:length(term)) { term[[j]] <- sub_specials(term[[j]], specials = specials, keep_args = keep_args) } term } ##' Substitute the '+' function for the '|' and '||' function in a mixed-model ##' formula. This provides a formula suitable for the current ##' model.frame function. ##' ##' @title "Substitute bars" ##' @param term a mixed-model formula ##' @return the formula with all | and || operators replaced by + ##' @section Note: This function is called recursively on individual ##' terms in the model, which is why the argument is called \code{term} and not ##' a name like \code{form}, indicating a formula. ##' @examples ##' subbars(Reaction ~ Days + (Days|Subject)) ## => Reaction ~ Days + (Days + Subject) ##' @seealso \code{\link{formula}}, \code{\link{model.frame}}, \code{\link{model.matrix}}. ##' @family utilities ##' @keywords models utilities ##' @export subbars <- function(term) sub_specials(term, specials = c("|", "||"), keep_args = c(2L, 2L)) ## subbars <- function(term) ## { ## if (is.name(term) || !is.language(term)) return(term) ## if (length(term) == 2) { ## term[[2]] <- subbars(term[[2]]) ## return(term) ## } ## stopifnot(length(term) >= 3) ## if (is.call(term) && term[[1]] == as.name('|')) ## term[[1]] <- as.name('+') ## if (is.call(term) && term[[1]] == as.name('||')) ## term[[1]] <- as.name('+') ## for (j in 2:length(term)) term[[j]] <- subbars(term[[j]]) ## term ## } ##' Does every level of f1 occur in conjunction with exactly one level ##' of f2? The function is based on converting a triplet sparse matrix ##' to a compressed column-oriented form in which the nesting can be ##' quickly evaluated. ##' ##' @title Is f1 nested within f2? ##' ##' @param f1 factor 1 ##' @param f2 factor 2 ##' ##' @return TRUE if factor 1 is nested within factor 2 ##' @examples ##' if (requireNamespace("lme4")) { ##' data("Pastes", package = "lme4") ##' with(Pastes, isNested(cask, batch)) ## => FALSE ##' with(Pastes, isNested(sample, batch)) ## => TRUE ##' } ##' @importFrom methods as new ##' @export isNested <- function(f1, f2) { f1 <- as.factor(f1) f2 <- as.factor(f2) stopifnot(length(f1) == length(f2)) k <- length(levels(f1)) sm <- as(new("ngTMatrix", i = as.integer(f2) - 1L, j = as.integer(f1) - 1L, Dim = c(length(levels(f2)), k)), "CsparseMatrix") all(sm@p[2:(k+1L)] - sm@p[1:k] <= 1L) } subnms <- function(form, nms) { ## Recursive function applied to individual terms sbnm <- function(term) { if (is.name(term)) { if (any(term == nms)) 0 else term } else switch(length(term), term, ## 1 { ## 2 term[[2]] <- sbnm(term[[2]]) term }, { ## 3 term[[2]] <- sbnm(term[[2]]) term[[3]] <- sbnm(term[[3]]) term }) } sbnm(form) } reformulas/R/nobars.R0000644000176200001440000000433014675010660014246 0ustar liggesusers##' Remove the random-effects terms from a mixed-effects formula, ##' thereby producing the fixed-effects formula. ##' ##' @title Omit terms separated by vertical bars in a formula ##' @param term the right-hand side of a mixed-model formula ##' @return the fixed-effects part of the formula ##' @section Note: This function is called recursively on individual ##' terms in the model, which is why the argument is called \code{term} and not ##' a name like \code{form}, indicating a formula. ##' @examples ##' nobars(Reaction ~ Days + (Days|Subject)) ## => Reaction ~ Days ##' @seealso \code{\link{formula}}, \code{\link{model.frame}}, \code{\link{model.matrix}}. ##' @family utilities ##' @keywords models utilities ##' @importFrom methods is ##' @importFrom stats as.formula reformulate terms ##' @export nobars <- function(term) { e <- environment(term) nb <- nobars_(term) ## call recursive version if (is(term,"formula") && length(term)==3 && is.symbol(nb)) { ## called with two-sided RE-only formula: ## construct response~1 formula nb <- reformulate("1", response=deparse(nb)) } ## called with one-sided RE-only formula, or RHS alone if (is.null(nb)) { nb <- if (is(term,"formula")) ~1 else 1 } environment(nb) <- e nb } #' @rdname nobars #' @export nobars_ <- function(term) { if (!anyBars(term)) return(term) if (isBar(term)) return(NULL) if (isAnyArgBar(term)) return(NULL) if (length(term) == 2) { nb <- nobars_(term[[2]]) if(is.null(nb)) return(NULL) term[[2]] <- nb return(term) } nb2 <- nobars_(term[[2]]) nb3 <- nobars_(term[[3]]) if (is.null(nb2)) return(nb3) if (is.null(nb3)) return(nb2) term[[2]] <- nb2 term[[3]] <- nb3 term } isBar <- function(term) { if(is.call(term)) { if((term[[1]] == as.name("|")) || (term[[1]] == as.name("||"))) { return(TRUE) } } FALSE } isAnyArgBar <- function(term) { if ((term[[1]] != as.name("~")) && (term[[1]] != as.name("("))) { for(i in seq_along(term)) { if(isBar(term[[i]])) return(TRUE) } } FALSE } anyBars <- function(term) { any(c('|','||') %in% all.names(term)) } reformulas/NAMESPACE0000644000176200001440000000221414675010660013654 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(head,call) S3method(head,formula) S3method(head,language) S3method(head,name) export("RHSForm<-") export(RHSForm) export(addForm) export(addForm0) export(anySpecial) export(drop.special) export(dropHead) export(expandAllGrpVar) export(expandDoubleVert) export(expandDoubleVerts) export(extractForm) export(findbars) export(findbars_x) export(inForm) export(isNested) export(makeOp) export(mkReTrms) export(noSpecials) export(no_specials) export(nobars) export(nobars_) export(reOnly) export(replaceForm) export(splitForm) export(sub_specials) export(subbars) export(sumTerms) importFrom(Matrix,KhatriRao) importFrom(Matrix,drop0) importFrom(Matrix,fac2sparse) importFrom(Matrix,sparse.model.matrix) importFrom(Matrix,sparseMatrix) importFrom(Rdpack,reprompt) importFrom(methods,as) importFrom(methods,is) importFrom(methods,new) importFrom(stats,as.formula) importFrom(stats,formula) importFrom(stats,model.matrix) importFrom(stats,reformulate) importFrom(stats,terms) importFrom(stats,update) importFrom(utils,head) importMethodsFrom(Matrix,coerce) importMethodsFrom(Matrix,diag) importMethodsFrom(Matrix,t) reformulas/NEWS.md0000644000176200001440000000114614711313332013527 0ustar liggesusers# reformulas 0.4.0 * `expandAllGrpVars` etc. expand complex terms (e.g. * `anySpecials` now handles "naked" specials (e.g. `s` rather than `s(...)`) properly * `findbars` now only looks on the RHS of a formula (restore back-compatibility in cases where a term with `|` occurs on the LHS, as in the `tramME` package) * add tests (`tinytest`) * fix `noSpecials` bug (complex LHS and empty RHS after eliminating specials) # reformulas 0.3.0 * Preparing for `lme4` inclusion: include/move functions from `lme4` (`expandDoubleVerts` etc.), new imports/exports, etc. # reformulas 0.2.0 (2024-03-13) Initial release reformulas/inst/0000755000176200001440000000000014675010660013413 5ustar liggesusersreformulas/inst/REFERENCES.bib0000644000176200001440000000050614675010660015513 0ustar liggesusers@Article{lme4, title = {Fitting Linear Mixed-Effects Models Using {lme4}}, author = {Douglas Bates and Martin M{\"a}chler and Ben Bolker and Steve Walker}, journal = {Journal of Statistical Software}, year = {2015}, volume = {67}, number = {1}, pages = {1--48}, doi = {10.18637/jss.v067.i01}, }reformulas/inst/tinytest/0000755000176200001440000000000014711452740015276 5ustar liggesusersreformulas/inst/tinytest/test_doubleVertNotation.R0000644000176200001440000000532214675010660022311 0ustar liggesuserslibrary(reformulas) ## "basic intercept + slope '||' works" expect_equivalent( findbars(Reaction ~ Days + (Days||Subject)), findbars(Reaction ~ Days + (1|Subject) + (0 + Days|Subject)) ) ## '||' works with nested, multiple, or interaction terms" ## works with nested expect_equivalent(findbars(y ~ (x || id / id2)), findbars(y ~ (1 | id / id2) + (0 + x | id / id2))) ## works with multiple expect_equivalent(findbars(y ~ (x1 + x2 || id / id2) + (x3 | id3) + (x4 || id4)), findbars(y ~ (1 | id / id2) + (0 + x1 | id / id2) + (0 + x2 | id / id2) + (x3 | id3) + (1 | id4) + (0 + x4| id4))) ## interactions: expect_equivalent(findbars(y ~ (x1*x2 || id)), findbars(y ~ (1 | id) + (0+x1 | id) + (0 + x2 | id) + (0 + x1:x2 | id))) ## "quoted terms work" ## used to fail in test-oldRZXFailure.R f <- quote(crab.speciesS + crab.sizeS + crab.speciesS:crab.sizeS + (snail.size | plot)) expect_equivalent(findbars(f)[[1]], (~(snail.size|plot))[[2]][[2]] ) ## "leaves superfluous '||' alone" expect_equivalent(findbars(y ~ z + (0 + x || id)), findbars(y ~ z + (0 + x | id))) ## "plays nice with parens in fixed or random formulas" expect_equivalent(findbars(y ~ (z + x)^2 + (x || id)), findbars(y ~ (z + x)^2 + (1 | id) + (0 + x | id))) expect_equivalent(findbars(y ~ ((x || id)) + (x2|id)), findbars(y ~ (1 | id) + (0 + x | id) + (x2|id))) ## at("update works as expected", { ## m <- lmer(Reaction ~ Days + (Days || Subject), sleepstudy) ## expect_equivalent(fitted(update(m, .~.-(0 + Days | Subject))), ## fitted(lmer(Reaction ~ Days + (1|Subject), sleepstudy))) ## }) ## "long formulas work" form <- log.corti~z.n.fert.females*z.n.males+ is.alpha2*(z.infanticide.susceptibility+z.min.co.res+ z.co.res+z.log.tenure)+ z.xtime+z.age.at.sample+sin.season+cos.season+ (1 +z.n.fert.females +z.n.males +is.alpha2.subordinate +z.infanticide.susceptibility +z.min.co.res +z.log.tenure +z.co.res +z.xtime +z.age.at.sample +sin.season +cos.season +I(z.n.fert.females*z.n.males) +I(is.alpha2.subordinate*z.min.co.res) +I(z.co.res*is.alpha2.subordinate) +I(is.alpha2.subordinate*z.co.res) +int.is.a.log.ten ||monkeyid) expStr <- paste(deparse(expandDoubleVerts(form),width=500),collapse="") ## check: no spurious ~ induced expect_equal(1,sum(grepl("~",strsplit(expStr,"")[[1]]))) reformulas/inst/tinytest/test_nobar.R0000644000176200001440000000404614675010660017565 0ustar liggesuserslibrary(reformulas) rr <- reformulas::RHSForm expect_equal(nobars(y~1+(1|g)), y~1) expect_equal(nobars(y~1|g), y~1) expect_equal(nobars(y~1+(1||g)), y~1) expect_equal(nobars(y~1||g), y~1) expect_equal(nobars(y~1+(x:z|g)), y~1) expect_equal(nobars(y~1+(x*z|g/h)), y~1) expect_equal(nobars(y~(1|g)+x+(x|h)), y~x) expect_equal(nobars(y~(1|g)+x+(x+z|h)), y~x) expect_equal(nobars(~1+(1|g)), ~1) expect_equal(nobars(~(1|g)), ~1) expect_equal(nobars(rr(y~1+(1|g))), 1) expect_equal(nobars(rr(y~(1|g))), 1) nrt <- function(x) length(x$reTrmFormulas) ## basic splitform nrt <- function(x) length(x$reTrmFormulas) expect_equal(nrt(splitForm(y~(x+q))),0) ## reTrms part should be empty sf1 <- splitForm(y~(x+q)+(1|f)) sf2 <- splitForm(y~(x+q)+us(1|f)) sf3 <- splitForm(y~(x+q)+diag(1|f)) sf4 <- splitForm(~x+y+(f|g)+cs(1|g)) expect_equal(nrt(sf1),1) expect_equal(sf1$reTrmFormulas,list(quote(1|f))) expect_equal(sf1,sf2) expect_equal(sf3$reTrmClasses,"diag") expect_equal(sf4$reTrmClasses,c("us","cs")) ## test_that("slash terms", { sf5 <- splitForm(~x+y+(1|f/g)) sf6 <- splitForm(~x+y+(1|f/g/h)) sf7 <- splitForm(~x+y+(1|(f/g)/h)) expect_equal(sf5$reTrmClasses, rep("us",2)) expect_equal(sf6$reTrmClasses, rep("us",3)) expect_equal(sf6,sf7) ## test_that("grpvar terms", { sf8 <- splitForm(~x+y+(1|f*g)) sf9 <- splitForm(~x+y+(1|f+g+h)) expect_equal(sf8$reTrmClasses,rep("us",3)) expect_equal(sf8$reTrmFormula,list(quote(1|f),quote(1|g),quote(1|f:g))) expect_equal(sf9$reTrmClasses,rep("us",3)) expect_equal(sf9$reTrmFormula,list(quote(1|f),quote(1|g),quote(1|h))) ## }) ## test_that("noSpecial", { ## handle parentheses in formulas: GH #174 ff <- y~1+(((us(1|f)))) expect_equal(noSpecials(ff,delete=FALSE),y~1+(1|f)) expect_equal(noSpecials(ff),y~1) ## 'naked' special - left alone: GH #261 ff2 <- y ~ us expect_equal(noSpecials(ff2),ff2) reformulas/inst/tinytest/test_utils.R0000644000176200001440000000635514711452713017631 0ustar liggesusersexpect_equal(reOnly(~ 1 + x + y + (1|f) + (1|g)), ~(us(1 | f)) + (us(1 | g))) expect_equal(addForm0(y~x,~1), y ~ x+1) expect_equal(addForm0(~x,~y), ~x+y) ff <- findbars_x(y~1+(x|f/g)) ## deparse in tests to avoid having to deal with raw expressions/language objects efun <- function(x, y, FUN=expandAllGrpVar) expect_equal(deparse1(FUN(x)), y) efun(ff, "list(us(x | g:f), us(x | f))") efun(quote(1|(f/g)/h), "list(1 | h:g:f, 1 | g:f, 1 | f)") efun(quote(1|f/g/h), "list(1 | h:g:f, 1 | g:f, 1 | f)") efun(quote(1|f*g), "list(1 | f, 1 | g, 1 | f:g)") efun(quote(1|f+g), "list(1 | f, 1 | g)") efun(quote(a+b|f+g+h*i), "list(a + b | f, a + b | g, a + b | h, a + b | i, a + b | h:i)") efun(quote(s(log(d), k = 4)), "list(s(log(d), k = 4))") efun(quote(s(log(d+1))), "list(s(log(d + 1)))") efun(quote(us(x,n=2)), "list(fixedFormula = ~1, reTrmFormulas = list(x), reTrmAddArgs = list(us(n = 2)), reTrmClasses = \"us\")", FUN = splitForm) efun(quote((1 | a / (b*c))), "list((1 | c:b:a), (1 | c:a), (1 | b:a), (1 | a))") efun(quote((1 | a / (b+c))), "list((1 | c:a), (1 | b:a), (1 | a))") efun <- function(x, y, ..., FUN=findbars_x) expect_equal(deparse1(FUN(x, ...)), y) efun(~ 1 + (x + y || g), expand_doublevert_method = "diag_special", y = "list(diag(x + y | g))") efun(~ 1 + (x + y || g), expand_doublevert_method = "split", y = "list(us(1 | g), us(0 + x | g), us(0 + y | g))") efun(~ 1 + (1 | f) + (1 | g), y = "list(us(1 | f), us(1 | g))") efun(~ 1 + (1|h) + (x + y || g), expand_doublevert_method = "split", y = "list(us(1 | h), us(1 | g), us(0 + x | g), us(0 + y | g))") efun(~ 1 + (1|h) + (x + y || g), expand_doublevert_method = "split", default.special = NULL, y = "list(1 | h, 1 | g, 0 + x | g, 0 + y | g)") efun(~ 1 + (1|Subject), "list(us(1 | Subject))") efun(~ (1||Subject), "list(diag(1 | Subject))") efun(~ (1|Subject), "list(us(1 | Subject))") efun(~ (1|Subject), default.special = NULL, y = "list(1 | Subject)") expect_equal(findbars_x(~ 1 + x), NULL) expect_equal(findbars_x(~ s(x, bs = "tp")), NULL) efun(y ~ a + log(b) + s(x, bs = "tp") + s(y, bs = "gp"), target = "s", default.special = NULL, y = "list(s(x, bs = \"tp\"), s(y, bs = \"gp\"))") expect_true(inForm(z~.,quote(.))) expect_false(inForm(z~y,quote(.))) expect_true(inForm(z~a+b+c,quote(c))) expect_false(inForm(z~a+b+(d+e),quote(c))) f <- ~ a + offset(x) f2 <- z ~ a expect_true(inForm(f,quote(offset))) expect_false(inForm(f2,quote(offset))) efun3 <- function(x, y, ..., FUN=extractForm) expect_equal(deparse1(FUN(x, ...)), y) efun3(~a+offset(b),quote(offset), y="list(offset(b))") expect_equal(extractForm(~c,quote(offset)), NULL) efun3(~a+offset(b)+offset(c),quote(offset), y="list(offset(b), offset(c))") efun3(~offset(x), quote(offset), y="list(offset(x))") expect_equal(dropHead(~a+offset(b),quote(offset)), quote(a+b)) expect_equal(dropHead(~a+poly(x+z,3)+offset(b),quote(offset)), quote(a+poly(x+z,3)+b)) expect_equal(drop.special(x~a + b+ offset(z)), quote(x~a+b)) expect_equal(replaceForm(quote(a(b+x*c(y,z))),quote(y),quote(R)), quote(a(b+x*c(R,z)))) ss <- ~(1 | cask:batch) + (1 | batch) expect_equal(replaceForm(ss,quote(cask:batch),quote(batch:cask)), ~(1 | batch:cask) + (1 | batch)) expect_equal(replaceForm(ss, quote(`:`), quote(`%:%`)), ~(1 | cask %:% batch) + (1 | batch)) reformulas/inst/tinytest/test_anySpecial.R0000644000176200001440000000056514703735474020567 0ustar liggesuserslibrary(reformulas) library(tinytest) ## shouldn't find 'naked' specials expect_false(anySpecial(y ~ s)) expect_true(anySpecial(y ~ s(1))) expect_false(anySpecial(y ~ s[[1]])) expect_false(anySpecial(y ~ diag)) expect_true(anySpecial(y ~ diag(1))) expect_false(anySpecial(y ~ diag[[1]])) anySpecial(y ~ poly, specials = "poly") anySpecial(y ~ poly(1), specials = "poly") reformulas/inst/tinytest/test_noSpecial.R0000644000176200001440000000073314675010660020400 0ustar liggesuserslibrary(reformulas) expect_equal(noSpecials(y~1+us(1|f)), y ~ 1) expect_equal(noSpecials(y~1+us(1|f),delete=FALSE), y ~ 1 + (1|f)) expect_equal(noSpecials(y~us(1|f)), y ~ 1) expect_equal(noSpecials(y~us(1|f), delete=FALSE), y ~ (1|f)) expect_equal(noSpecials(y~us+1), y ~ us + 1) expect_equal(noSpecials(~us(1|f)+1), ~1) expect_equal(noSpecials(~s(stuff) + a + b, specials = "s"), ~a + b) expect_equal(noSpecials(cbind(b1, 20-b1) ~ s(x, bs = "tp")), cbind(b1, 20 - b1) ~ 1) reformulas/README.md0000644000176200001440000000163114675010660013716 0ustar liggesusers## reformulas [![R-CMD-check](https://github.com/bbolker/reformulas/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/bbolker/reformulas/actions/workflows/R-CMD-check.yaml) `reformulas` (**r**andom **e**ffects formulas) is a utility package for processing "`lme4`-style" random effects formulas in R (i.e., formulas where the random effects are included in the form `(f|g)` as components of an overall model formula, where `f` represents a sub-formula for the varying effects and `g` represents a sub-formula for the grouping variable(s). The package contains functions like `findbars` (extract terms containing `|`, i.e. random-effects terms), `nobars` (drop terms containing bars from a formula), etc.. The goal of `reformulas` is to be used upstream of `lme4` and `glmmTMB` (and possibly other packages) as a unified toolkit for processing formulas. reformulas/build/0000755000176200001440000000000014711452740013535 5ustar liggesusersreformulas/build/partial.rdb0000644000176200001440000001363714711452740015674 0ustar liggesusers][sFieY|/Ӗ옊)Ҳ[-f'Me@)!eiULվnSMHe\f}tf(JS= eHN^dsݓdISMR'ED1n؄* lKJw$_Zb_2e#/Wm`ӷٷʪFؓr+rrM}*\l(@`^]PwہR}aVlRe=s,k95/mV?jOyR_϶PJ5US={{ssyf~ìX+;iV\{w\{HëaEtnCNֳ 2/k3Nr=? q&RE(Q V-٪U'! 7GKi6ʷcti O0CM x JVб#FV (ʣI,!^GQ2N`}EIS%+c(Y#S3═SWMiM2l&5ZDTa7|IPfML6bBe*ۡ iL/p}i`?(?/9KЗGUZ>}i!/3G<[BJie#3* 41#lFWfL5\%D1j,4 @6 o֢,u嫱uHI SfΦW JQzfLBN%BdIsT))Ƌ*x KOGV4V%!5K C4=b=L6C3|/Au1AiJ5Dq(USkM3Un,QrLS <8lզjO En n1P<1:]6#u9 8P2ONr|9*,3VmbJZ & 6a9:OllP~}FAm5Ρ< [ɈzGr^DY( FF3TM;/q5%eILUxQ@+OQ~yzG'.}^AKm5iDTq'k:zl}G%t%(&G'BGrʗ:O e/vHSsjsIMWgQZ JeՊ䜷".S٬W$(J4r,‚^XɦwP,o d"G}ΣvH{ w~&`}(|~%rDP8+Y9gւՌacG%s-{Q ܥrNg/gToΣHʝ;T'Dۦ[U%~F2@b9[}QRlSst,ֹ(h0kp"TCW߷6BDݮ#O,Bݚz{ȍ'_T£P+.vPȲH~x&L"%P^|T\}Pf/*EJ8*Y Sn Cpz޻a=I5Vwa&+wC\FyԚB:}jA0ڭ'ivNO'<@a-j]ls΀u >Ja 8WUgL9bg}OǨF+0QH&4eRXP$.WP`,$@ug?B3x9ޤ[n#Π,pStxW12H,p2-01n6O,7sk(war#贎q?3Ӕ}hjI׏8pbm6&ڪ8HCA_3>8r~,|rQdFA l(xO&ȷE:¨iG%R2j'Ƨ[!(?aC獲/H)ƴO2}$Y6LřEQ- ?9ZC#f"f4W-w޹̇/pWO?F6r0ȘOL F$2d}QjJPu1r>G3Tdy+RcKj˽Bcj{{#w8zLST T*Nꥰ "7 v!S'(Uj9j,g#^P^ߊ3(5s"U]HF\)BQۑCL9oEQ! ߪ>z yd"(`."Il'@0x: [3wrb*4=-o$zJ@txK(#PcXӱNiTۏʘ;Cy84Pd"BO$F# Twʗ%AˈWQN.Pr99xAQzYt\C̢,2ao{iT˥iƒZ,xp}S0=^h_hl"Q6Tw Ob;2vX@|zsfst>fw]:k!()Gz:4D[' Tw1rE!:2ӈac=.P}J}Eg4k&`;T/X4xŴuӨԪi"';>Cr/яeUW^Z[('ٓiRe B=Y;8tl"UJ8U2ix+*AO_"dYUu%LY"/gu#6/órr<@~rσ6YslP dSF]3u cu6tOptTjL5EUjEy4`:Ul⹖4񆣞4bCr?}Qܠ{UZ0eK[tyۃRyUic7ɩ,|E'NNw<ހ7kW˫-~b(+lCEq+C 5>B,K^mU_eɊ0i%K^r g:#4*ث" Uۙ6Tu*1=̬aW}KKq)XkQfAorVugaS&k lLrV#ԝqU:>[g}~排)]sǩtܟ;>~Jfe{{`fw;P30wrs=oY;;cXFAS-f,201M-ӄ.Wu}| k9crS÷)׃z/*q_o}Jk '~a t_>jIȆâ2밿ZQɰKU^לqC9S2򛞗/6џUk~u$ }!QZu kjP2 z<6I*$d.ORdx, =J%"m6_٪*ITQ6S:d;FIWFfӴ둋HEdHJ@H~ #^CY(<y>F$(0Kp=t?*KI)gin,/!0FD#(5^9( F%#/5 XRߪ|\F$7H}Ln.#'$EITSseEX@ѢT,#$sya|Ux9?&iWD}'C('7b 0Vtj|1ަs,@8K3:?ϰ)JMU}LU0 [nwoخhKFM'N,*nhD_$]/+47 ƈU,[5/zWdQ6[oXqW; ~}|ެIE6Z: WlxWt^6*_hV/~*Pmx^ Z֕NXc~3s޷+F kBVPT]hr~lhoxAwm*2Vq~B+5p3 ]{RQ> {[vK Y0{՝72EuE1r]<.^2 mxMD>I573n(f$A_QS wHP mw!wՑO(` ZC<:#^XDlz/Oꀆ5Hʪ5%Pv5m?płڤPzJpfMoHKldW1Ay?p>tx(BWE-CQ^܀;ta*G6],!obs0ɆTu ʤ8AyVvO= WmL(-JR@/Rx|2 P' iERZ[ya%b㾬I ?oŢ^`$fEk_7˙}mz[,6;fq`Ԯ+hަik*5m/䯆wȞ_ګR9un&3~9d쐳n܆9*kQ.7 /.rJ?ߤSx|2!KZ^SKBږL/(ywF-ց伹/p{9 z,h@^upÇWhl;X%[I3=5oʗD I0LB@mfI湦y;s'A喇/:#T0`TPja gumۮZ<;Wa\sx3bóc_*bZdzA1#*HݜxtgOIxi<Ǚg8ޏ~qpQ>/w'cwۈw(0ȓ6V /|dl!s:ۃh@V,찌yI`1 _Q.&$ltk+geK(/W9Njt?W*[PAYIwYo}ti]+Z?``eu˱K˒2u|4?C]'?_{Н$c0єk6ժtԕfHd8.uZ6TssrdjZ_ aU樾~{,f umMZNY)}:huOE3/kXZI&Z4)УqM[+jƶ\E$`n66 o=ЏVPo⼑ؙ%RO)d[Q}[lkQ$ҡw)Cu@3Em"}'lol xd@F4tؖj,qVgwɒO۵9 P]Btyܐ_>kn Ev Dk&u*M,oP)sӅf`S+= I1w[$r)ɑ5ʖj&}|m&OzSoSV%9L>- i]΂reformulas/man/0000755000176200001440000000000014703510451013204 5ustar liggesusersreformulas/man/RHSForm.Rd0000644000176200001440000000071514675010660014763 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{RHSForm} \alias{RHSForm} \title{extract right-hand side of a formula} \usage{ RHSForm(form, as.form = FALSE) } \arguments{ \item{form}{a formula object} \item{as.form}{(logical) return a formula (TRUE) or as a call/symbolic object (FALSE) ?} } \value{ a \code{language} object } \description{ extract right-hand side of a formula } \examples{ RHSForm(y ~ x + (1|g)) } reformulas/man/anySpecial.Rd0000644000176200001440000000131714703510451015565 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{anySpecial} \alias{anySpecial} \title{Detect whether there are any 'specials' in a formula term} \usage{ anySpecial(term, specials = findReTrmClasses(), fast = FALSE) } \arguments{ \item{term}{formula term} \item{specials}{values to detect} \item{fast}{(logical) use quick (syntactic) test for presence of specials?} } \value{ logical value } \description{ Detect whether there are any 'specials' in a formula term } \examples{ ## should only detect s as the head of a function, s(...) anySpecial(~diag(1)) anySpecial(~diag) anySpecial(~diag[[1]]) anySpecial(~diag[1]) anySpecial(~s) anySpecial(~s(hello+goodbye,whatever)) } reformulas/man/splitForm.Rd0000644000176200001440000000500314703510451015450 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{splitForm} \alias{splitForm} \alias{noSpecials} \title{Split formula containing special random effect terms} \usage{ splitForm( formula, defaultTerm = "us", allowFixedOnly = TRUE, allowNoSpecials = TRUE, debug = FALSE, specials = findReTrmClasses() ) noSpecials(term, delete = TRUE, debug = FALSE, specials = findReTrmClasses()) } \arguments{ \item{formula}{a formula containing special random effect terms} \item{defaultTerm}{default type for non-special RE terms} \item{allowFixedOnly}{(logical) are formulas with no RE terms OK?} \item{allowNoSpecials}{(logical) are formulas with only standard RE terms OK?} \item{debug}{debugging mode (print stuff)?} \item{term}{language object} } \value{ a list containing elements \code{fixedFormula}; \code{reTrmFormulas} list of \code{x | g} formulas for each term; \code{reTrmAddArgs} list of function+additional arguments, i.e. \code{list()} (non-special), \code{foo()} (no additional arguments), \code{foo(addArgs)} (additional arguments); \code{reTrmClasses} (vector of special functions/classes, as character) } \description{ Parse a formula into fixed formula and random effect terms, treating 'special' terms (of the form foo(x|g[,m])) appropriately } \details{ Taken from Steve Walker's lme4ord, ultimately from the flexLambda branch of lme4 \url{https://github.com/stevencarlislewalker/lme4ord/blob/master/R/formulaParsing.R}. Mostly for internal use. } \examples{ splitForm(~x+y) ## no specials or RE splitForm(~x+y+(f|g)) ## no specials splitForm(~x+y+diag(f|g)) ## one special splitForm(~x+y+(diag(f|g))) ## 'hidden' special splitForm(~x+y+(f|g)+cs(1|g)) ## combination splitForm(~x+y+(1|f/g)) ## 'slash'; term splitForm(~x+y+(1|f/g/h)) ## 'slash'; term splitForm(~x+y+(1|(f/g)/h)) ## 'slash'; term splitForm(~x+y+(f|g)+cs(1|g)+cs(a|b,stuff)) ## complex special splitForm(~(((x+y)))) ## lots of parentheses splitForm(~1+rr(f|g,n=2)) splitForm(~1+s(x, bs = "tp")) noSpecials(y~1+us(1|f)) noSpecials(y~1+us(1|f),delete=FALSE) noSpecials(y~us(1|f)) noSpecials(y~us(1|f), delete=FALSE) noSpecials(y~us(1|f), debug=TRUE) noSpecials(y~us+1) ## should *not* delete unless head of a function noSpecials(~us(1|f)+1) ## should work on a one-sided formula! noSpecials(~s(stuff) + a + b, specials = "s") noSpecials(cbind(b1, 20-b1) ~ s(x, bs = "tp")) } \author{ Steve Walker } \keyword{internal} reformulas/man/expandDoubleVerts.Rd0000644000176200001440000000135214675010660017137 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{expandDoubleVerts} \alias{expandDoubleVerts} \title{Expand terms with \code{'||'} notation into separate \code{'|'} terms} \usage{ expandDoubleVerts(term) } \arguments{ \item{term}{a mixed-model formula} } \value{ the modified term } \description{ From the right hand side of a formula for a mixed-effects model, expand terms with the double vertical bar operator into separate, independent random effect terms. } \seealso{ \code{\link{formula}}, \code{\link{model.frame}}, \code{\link{model.matrix}}. Other utilities: \code{\link{mkReTrms}()}, \code{\link{nobars}()}, \code{\link{subbars}()} } \concept{utilities} \keyword{models} \keyword{utilities} reformulas/man/no_specials.Rd0000644000176200001440000000104014675010660015772 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{no_specials} \alias{no_specials} \title{Drop 'specials' from a formula} \usage{ no_specials(term, specials = c("|", "||", "s")) } \arguments{ \item{term}{a term or formula or list thereof} \item{specials}{function types to drop} } \value{ a \code{call} or \code{language} object (or list) with specials removed } \description{ Drop 'specials' from a formula } \examples{ no_specials(findbars_x(~ 1 + s(x) + (f|g) + diag(x|y))) no_specials(~us(f|g)) } reformulas/man/nobars.Rd0000644000176200001440000000174014675010660014766 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nobars.R \name{nobars} \alias{nobars} \alias{nobars_} \title{Omit terms separated by vertical bars in a formula} \usage{ nobars(term) nobars_(term) } \arguments{ \item{term}{the right-hand side of a mixed-model formula} } \value{ the fixed-effects part of the formula } \description{ Remove the random-effects terms from a mixed-effects formula, thereby producing the fixed-effects formula. } \section{Note}{ This function is called recursively on individual terms in the model, which is why the argument is called \code{term} and not a name like \code{form}, indicating a formula. } \examples{ nobars(Reaction ~ Days + (Days|Subject)) ## => Reaction ~ Days } \seealso{ \code{\link{formula}}, \code{\link{model.frame}}, \code{\link{model.matrix}}. Other utilities: \code{\link{expandDoubleVerts}()}, \code{\link{mkReTrms}()}, \code{\link{subbars}()} } \concept{utilities} \keyword{models} \keyword{utilities} reformulas/man/expandGrpVar.Rd0000644000176200001440000000046014675010660016101 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{expandGrpVar} \alias{expandGrpVar} \title{apply} \usage{ expandGrpVar(f) } \arguments{ \item{f}{a language object (an atom of a formula) expandGrpVar(quote(x*y)) expandGrpVar(quote(x/y))} } \description{ apply } reformulas/man/sub_specials.Rd0000644000176200001440000000173314675010660016160 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{sub_specials} \alias{sub_specials} \title{Substitute safe chars (+) for specials (for use in \code{model.frame}) (Generalized from \code{lme4}'s \code{subbars} function.)} \usage{ sub_specials( term, specials = c("|", "||", "s"), keep_args = c(2L, 2L, NA_integer_) ) } \arguments{ \item{term}{formula or term in a formula} \item{specials}{names of specials to process} \item{keep_args}{number of arguments to retain (matching \code{specials})} } \value{ a term or formula with specials replaced by \code{+} (and extra arguments dropped) } \description{ Substitute safe chars (+) for specials (for use in \code{model.frame}) (Generalized from \code{lme4}'s \code{subbars} function.) } \examples{ sub_specials( ~ s(a, k=4)) sub_specials( ~ (1|x) + (a + b || y) + s(a, k=4)) sub_specials(Reaction ~ s(Days) + (1 + Subject)) sub_specials(~ s(cos((y^2*3)/2), bs = "tp")) } \keyword{internal} reformulas/man/mkReTrms.Rd0000644000176200001440000000474714675010660015260 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mkReTrms.R \name{mkReTrms} \alias{mkReTrms} \title{Create list of structures needed for models with random effects} \usage{ mkReTrms( bars, fr, drop.unused.levels = TRUE, reorder.terms = TRUE, reorder.vars = FALSE, calc.lambdat = TRUE ) } \arguments{ \item{bars}{a list of parsed random-effects terms} \item{fr}{a model frame in which to evaluate these terms} \item{drop.unused.levels}{(logical) drop unused factor levels?} \item{reorder.terms}{arrange random effects terms in decreasing order of number of groups (factor levels)?} \item{reorder.vars}{arrange columns of individual random effects terms in alphabetical order?} \item{calc.lambdat}{(logical) compute \code{Lambdat} and \code{Lind} components? (At present these components are needed for \code{lme4} machinery but not for \code{glmmTMB}, and may be large in some cases; see Bates \emph{et al.} 2015} } \value{ a list with components \item{Zt}{transpose of the sparse model matrix for the random effects} \item{Ztlist}{list of components of the transpose of the random-effects model matrix, separated by random-effects term} \item{Lambdat}{transpose of the sparse relative covariance factor} \item{Lind}{an integer vector of indices determining the mapping of the elements of the \code{theta} to the \code{"x"} slot of \code{Lambdat}} \item{theta}{initial values of the covariance parameters} \item{lower}{lower bounds on the covariance parameters} \item{flist}{list of grouping factors used in the random-effects terms} \item{cnms}{a list of column names of the random effects according to the grouping factors} \item{Gp}{a vector indexing the association of elements of the conditional mode vector with random-effect terms; if \code{nb} is the vector of numbers of conditional modes per term (i.e. number of groups times number of effects per group), \code{Gp} is \code{c(0,cumsum(nb))} (and conversely \code{nb} is \code{diff(Gp)})} \item{nl}{names of the terms (in the same order as \code{Zt}, i.e. reflecting the \code{reorder.terms} argument)} } \description{ From the result of \code{\link{findbars}} applied to a model formula and and the evaluation frame, create the model matrix, etc. associated with random-effects terms. See the description of the returned value for a detailed list. } \references{ \insertRef{lme4}{reformulas}) } \seealso{ Other utilities: \code{\link{expandDoubleVerts}()}, \code{\link{nobars}()}, \code{\link{subbars}()} } \concept{utilities} reformulas/man/isNested.Rd0000644000176200001440000000130514675010660015255 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{isNested} \alias{isNested} \title{Is f1 nested within f2?} \usage{ isNested(f1, f2) } \arguments{ \item{f1}{factor 1} \item{f2}{factor 2} } \value{ TRUE if factor 1 is nested within factor 2 } \description{ Does every level of f1 occur in conjunction with exactly one level of f2? The function is based on converting a triplet sparse matrix to a compressed column-oriented form in which the nesting can be quickly evaluated. } \examples{ if (requireNamespace("lme4")) { data("Pastes", package = "lme4") with(Pastes, isNested(cask, batch)) ## => FALSE with(Pastes, isNested(sample, batch)) ## => TRUE } } reformulas/man/formfuns.Rd0000644000176200001440000001051114703510451015330 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{expandDoubleVert} \alias{expandDoubleVert} \alias{RHSForm<-} \alias{sumTerms} \alias{reOnly} \alias{makeOp} \alias{addForm0} \alias{addForm} \alias{expandAllGrpVar} \alias{findbars_x} \alias{findbars} \alias{inForm} \alias{extractForm} \alias{dropHead} \alias{drop.special} \alias{replaceForm} \title{expand double-bar RE notation by splitting} \usage{ expandDoubleVert(term) RHSForm(formula) <- value sumTerms(termList) reOnly(f, response = FALSE, bracket = TRUE, doublevert_split = TRUE) makeOp(x, y, op = NULL) addForm0(f1, f2) addForm(...) expandAllGrpVar(bb) findbars_x( term, debug = FALSE, specials = character(0), default.special = "us", target = "|", expand_doublevert_method = c("diag_special", "split") ) findbars(term) inForm(form, value) extractForm(term, value) dropHead(term, value) drop.special(x, value = quote(offset), preserve = NULL) replaceForm(term, target, repl) } \arguments{ \item{term}{expression/formula} \item{formula}{a formula object} \item{value}{term to remove from formula} \item{termList}{a list of formula terms} \item{f}{a formula} \item{response}{include response variable?} \item{bracket}{bracket-protect terms?} \item{doublevert_split}{(logical) TRUE for lme4 back-compatibility; FALSE to make double vertical bars into \code{diag()} eterms} \item{x}{formula} \item{y}{a formula term (or an operator)} \item{op}{an operator} \item{f1}{formula #1} \item{f2}{formula #2} \item{...}{arguments to pass through to \code{addForm0}} \item{bb}{a list of naked grouping variables, i.e. 1 | f} \item{debug}{(logical) debug?} \item{specials}{list of special terms} \item{default.special}{character: special to use for parenthesized terms - i.e. random effects terms with unspecified structure} \item{expand_doublevert_method}{method for handling \code{||} operator: split into separate terms or replace by \code{diag}? Inherited from \emph{previous call where it was specified}. \enumerate{ \item atom (not a call or an expression): NULL \item special, i.e. foo(...) where "foo" is in specials: return term \item parenthesized term: \emph{if} the head of the head is | (i.e. it is of the form (xx|gg), then convert it to the default special type; we won't allow pathological cases like ((xx|gg)) ... can we detect them? }} \item{preserve}{(integer) retain the specified occurrence of "value"} } \value{ a list of expressions } \description{ Modeled after lme4:::expandSlash, by Doug Bates. However, all formula operators that apply to factors (\code{*}, \code{/}, \code{+}) are applicable: the results are expanded into a list of independent (additive) random effect terms } \examples{ f <- y ~ 1 + x RHSForm(f) <- quote(2+x^2) print(f) reOnly(~ 1 + x + y + (1|f) + (1|g)) addForm0(y~x,~1) addForm0(~x,~y) ff <- findbars_x(y~1+(x|f/g)) expandAllGrpVar(ff) expandAllGrpVar(quote(1|(f/g)/h)) expandAllGrpVar(quote(1|f/g/h)) expandAllGrpVar(quote(1|f*g)) expandAllGrpVar(quote(1|f+g)) expandAllGrpVar(quote(a+b|f+g+h*i)) expandAllGrpVar(quote(s(log(d), k = 4))) expandAllGrpVar(quote(s(log(d+1)))) splitForm(quote(us(x,n=2))) findbars_x(~ 1 + (x + y || g), expand_doublevert_method = "diag_special") findbars_x(~ 1 + (x + y || g), expand_doublevert_method = "split") findbars_x(~ 1 + (1 | f) + (1 | g)) findbars_x(~ 1 + (1 | f) + (1 | g)) findbars_x(~ 1 + (1|h) + (x + y || g), expand_doublevert_method = "split") findbars_x(~ 1 + (1|Subject)) findbars_x(~ (1||Subject)) findbars_x(~ (1|Subject)) findbars_x(~ (1|Subject), default.special = NULL) findbars_x(~ 1 + x) findbars_x(~ s(x, bs = "tp")) findbars_x(y ~ a + log(b) + s(x, bs = "tp") + s(y, bs = "gp"), target = "s", default.special = NULL) inForm(z~.,quote(.)) inForm(z~y,quote(.)) inForm(z~a+b+c,quote(c)) inForm(z~a+b+(d+e),quote(c)) f <- ~ a + offset(x) f2 <- z ~ a inForm(f,quote(offset)) inForm(f2,quote(offset)) extractForm(~a+offset(b),quote(offset)) extractForm(~c,quote(offset)) extractForm(~a+offset(b)+offset(c),quote(offset)) extractForm(~offset(x),quote(offset)) dropHead(~a+offset(b),quote(offset)) dropHead(~a+poly(x+z,3)+offset(b),quote(offset)) drop.special(x~a + b+ offset(z)) replaceForm(quote(a(b+x*c(y,z))),quote(y),quote(R)) ss <- ~(1 | cask:batch) + (1 | batch) replaceForm(ss,quote(cask:batch),quote(batch:cask)) replaceForm(ss, quote(`:`), quote(`\%:\%`)) } \keyword{internal} reformulas/man/findReTrmClasses.Rd0000644000176200001440000000041014675010660016703 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{findReTrmClasses} \alias{findReTrmClasses} \title{list of specials -- taken from enum.R} \usage{ findReTrmClasses() } \description{ list of specials -- taken from enum.R } reformulas/man/subbars.Rd0000644000176200001440000000174014675010660015143 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{subbars} \alias{subbars} \title{"Substitute bars"} \usage{ subbars(term) } \arguments{ \item{term}{a mixed-model formula} } \value{ the formula with all | and || operators replaced by + } \description{ Substitute the '+' function for the '|' and '||' function in a mixed-model formula. This provides a formula suitable for the current model.frame function. } \section{Note}{ This function is called recursively on individual terms in the model, which is why the argument is called \code{term} and not a name like \code{form}, indicating a formula. } \examples{ subbars(Reaction ~ Days + (Days|Subject)) ## => Reaction ~ Days + (Days + Subject) } \seealso{ \code{\link{formula}}, \code{\link{model.frame}}, \code{\link{model.matrix}}. Other utilities: \code{\link{expandDoubleVerts}()}, \code{\link{mkReTrms}()}, \code{\link{nobars}()} } \concept{utilities} \keyword{models} \keyword{utilities} reformulas/DESCRIPTION0000644000176200001440000000154014711605143014141 0ustar liggesusersPackage: reformulas Title: Machinery for Processing Random Effect Formulas Version: 0.4.0 Authors@R: person(given = "Ben", family = "Bolker", role = c("aut", "cre"), email = "bolker@mcmaster.ca", comment=c(ORCID="0000-0002-2127-0443")) Description: Takes formulas including random-effects components (formatted as in 'lme4', 'glmmTMB', etc.) and processes them. Includes various helper functions. URL: https://github.com/bbolker/reformulas License: GPL-3 Encoding: UTF-8 Imports: stats, methods, Matrix, Rdpack RdMacros: Rdpack Suggests: lme4, tinytest RoxygenNote: 7.3.2 NeedsCompilation: no Packaged: 2024-11-02 16:40:00 UTC; bolker Author: Ben Bolker [aut, cre] () Maintainer: Ben Bolker Repository: CRAN Date/Publication: 2024-11-03 05:30:11 UTC