R/zzz.R

In lme4: Linear Mixed-Effects Models using 'Eigen' and S4

.onLoad <- function(libname, pkgname) {
  ## don't do this in production; also flags problems in downstream packages
  ## options(Matrix.warnDeprecatedCoerce = 3)
  options(lme4.summary.cor.max = 12)

  Ons <- parent.env(environment()) # our own namespace
  if((Rv <- getRversion()) < "4.4.0") {
    assign('%||%', envir = Ons, inherits = FALSE,
           function(x, y) if(is.null(x)) y else x)
    if(Rv < "4.1.0") {
      ## https://stackoverflow.com/questions/49056642/how-to-make-variable-available-to-namespace-at-loading-time/67664852#67664852
      ## not quite equivalent; this *forces* ... entries whereas true ...names()  doesn't
      assign('...names', envir = Ons,
             function() eval(quote(names(list(...))), sys.frame(-1L)))
      if(Rv < "4.0.0") {
        ## NB: R >= 4.0.0's deparse1() is a generalization of our previous safeDeparse()
        assign('deparse1', envir = Ons,
               function (expr, collapse = " ", width.cutoff = 500L, ...)
                   paste(deparse(expr, width.cutoff, ...), collapse = collapse)
               )
        ## not equivalent ...
        assign('...length', envir = Ons,
               function() eval(quote(length(list(...))), sys.frame(-1L))
               )
        assign("sequence.default", envir = Ons,
               function(nvec, from = 1L, by = 1L, ...) {
                   if(length(nvec) == 0L)
                       return(integer(0L))
                   else if(length(from) == 0L || length(by) == 0L)
                       stop(gettextf("'%s' has length 0 but '%s' does not",
                                     if(length(from) == 0L) "from" else "by", "nvec"),
                            domain = NA)
                   unlist(.mapply(seq.int,
                                  list(from = as.integer(from),
                                       by = as.integer(by),
                                       length.out = as.integer(nvec)),
                                  NULL),
                          recursive = FALSE, use.names = FALSE)
               })
        if (Rv < "3.6.0") {
          assign('reformulate', envir = Ons,
                 function(..., env = parent.env) {
                     f <- stats::reformulate(...)
                     environment(f) <- env
                     f
                 })
        if (Rv < "3.2.1") {
        assign('lengths', envir = Ons,
               function (x, use.names = TRUE) vapply(x, length, 1L, USE.NAMES = use.names)
               )
        if(Rv < "3.1.0") {
          assign('anyNA', envir = Ons, function(x) any(is.na(x)) )
          if(Rv < "3.0.0") {
            assign('rep_len', envir = Ons, function(x, length.out) rep(x, length.out=length.out) )
            if(Rv < "2.15") {
              assign('paste0', envir = Ons, function(...) paste(..., sep = '') )
            } ## R < 2.15
          } ## R < 3.0.0
        } ## R < 3.1.0
        } ## R < 3.2.1
      } ## R < 3.6.0
      } ## R < 4.0.0
    } ## R < 4.1.0
  } ## R < 4.4.0
  rm(Rv, Ons)
  ## check Matrix ABI version
  check_dep_version()
}

## https://github.com/lme4/lme4/issues/768
## https://github.com/kaskr/adcomp/issues/387
get_abi_version <- function() {
    if (utils::packageVersion("Matrix") < "1.6-2") return(numeric_version("0"))
    Matrix::Matrix.Version()[["abi"]]
}

.Matrix.abi.build.version <- get_abi_version()

## simplified version of glmmTMB package checking
##' @param this_pkg downstream package being tested
##' @param dep_pkg upstream package on which \code{this_pkg} depends
##' @param dep_type "ABI" or "package"
##' @param built_version a \code{numeric_version} object indicating what version of \code{dep_pkg} was used to  build \code{this_pkg}
##' @param warn (logical) warn if condition not met?
##' @noRd
check_dep_version <- function(this_pkg = "lme4",  dep_pkg = "Matrix", dep_type = "ABI",
                              built_version = .Matrix.abi.build.version,
                              warn = TRUE) {
    cur_version <- get_abi_version()
    result_ok <- cur_version == built_version
    if (!result_ok) {
        warning(
            sprintf("%s version mismatch: \n", dep_type),
            sprintf("%s was built with %s %s version %s\n",
                    this_pkg, dep_pkg, dep_type, built_version),
            sprintf("Current %s %s version is %s\n",
                    dep_pkg, dep_type, cur_version),
            sprintf("Please re-install %s from source ", this_pkg),
            "or restore original ",
            sQuote(dep_pkg), " package"
        )
    }
    return(result_ok)
}

.onUnload <- function(libpath) {
  gc()
  if (is.loaded("lmer_Deviance", PACKAGE="lme4")) {
    library.dynam.unload("lme4", libpath)
  }
}