R 由于使用了新版本的lme4，复制先前答案的结果不起作用

我试图重现“估计随机效应并使用R lme4或nlme软件包应用用户定义的相关/协方差结构”这一问题答案的结果

亚伦·伦达尔密码

 library(pedigreemm)
 relmatmm <- function (formula, data, family = NULL, REML = TRUE, relmat = list(), 
control = list(), start = NULL, verbose = FALSE, subset, 
weights, na.action, offset, contrasts = NULL, model = TRUE, 
x = TRUE, ...) 
{
mc <- match.call()
lmerc <- mc
lmerc[[1]] <- as.name("lmer")
lmerc$relmat <- NULL
if (!length(relmat)) 
    return(eval.parent(lmerc))
stopifnot(is.list(relmat), length(names(relmat)) == length(relmat))
lmerc$doFit <- FALSE
lmf <- eval(lmerc, parent.frame())
relfac <- relmat
relnms <- names(relmat)
stopifnot(all(relnms %in% names(lmf$FL$fl)))
asgn <- attr(lmf$FL$fl, "assign")
for (i in seq_along(relmat)) {
    tn <- which(match(relnms[i], names(lmf$FL$fl)) == asgn)
    if (length(tn) > 1) 
        stop("a relationship matrix must be associated with only one random effects term")
    Zt <- lmf$FL$trms[[tn]]$Zt
    relmat[[i]] <- Matrix(relmat[[i]][rownames(Zt), rownames(Zt)], 
        sparse = TRUE)
    relfac[[i]] <- chol(relmat[[i]])
    lmf$FL$trms[[tn]]$Zt <- lmf$FL$trms[[tn]]$A <- relfac[[i]] %*% Zt
}
ans <- do.call(if (!is.null(lmf$glmFit)) 
    lme4:::glmer_finalize
else lme4:::lmer_finalize, lmf)
ans <- new("pedigreemm", relfac = relfac, ans)
ans@call <- match.call()
ans
}

我会感激你的帮助的？

---

谢谢

这是对前面代码的重新实现--我做了一些轻微的修改，而且我没有以任何方式对其进行测试--请自行测试和/或使用

首先创建一个稍微模块化的函数，该函数构造偏差函数并适合模型：

doFit <- function(lmod,lmm=TRUE) {
    ## see ?modular
    if (lmm) {
        devfun <- do.call(mkLmerDevfun, lmod)
        opt <- optimizeLmer(devfun)
        mkMerMod(environment(devfun), opt, lmod$reTrms, fr = lmod$fr)
    } else {
        devfun <- do.call(mkGlmerDevfun, lmod)
        opt <- optimizeGlmer(devfun)
        devfun <- updateGlmerDevfun(devfun, lmod$reTrms)
        opt <- optimizeGlmer(devfun, stage=2)
        mkMerMod(environment(devfun), opt, lmod$reTrms, fr = lmod$fr)
    }
}

范例

set.seed(1234)
mydata <- data.frame (gen = factor(rep(1:10, each = 10)),
                  repl = factor(rep(1:10, 10)),
                  yld = rnorm(10, 5, 0.5))

library(lme4)
covmat <- round(nearPD(matrix(runif(100, 0, 0.2), nrow = 10))$mat, 2)
diag(covmat) <- diag(covmat)/10+1
rownames(covmat) <- colnames(covmat) <- levels(mydata$gen)

m <- relmatmm(yld ~ (1|gen) + (1|repl), relmat=list(gen=covmat), 
     data=mydata)

set.seed（1234）
mydata这是使用在新版
lme4
中更改的
lme4
中的内部结构。我现在没有时间查看这一点：您可能需要要求原始作者（Aaron Rendahl？）更新代码，以便与新版
lme4
一起使用（请参阅
帮助（“modular”，package=“lme4”）
作为一个开始。联系
pedigreemm
软件包的维护人员，看看他们是否能提供帮助也可能会有所帮助。PS由于模块化程度的提高，新版本的
lme4
实际上应该比以前更容易做到这一点（参见之前的评论），但这仍然意味着代码需要重做……相关：亲爱的本：非常感谢您重新实现Aaron代码——我很久以前就尝试过发表这篇评论，但不允许我这么做——当应用您的新代码时，我遇到了以下错误：relmat[[i]][zn，zn]中的错误：无效或尚未实现的“矩阵”子设置对我有效。你能发布
sessionInfo（）
（特别是
Matrix
和
lme4
）的结果吗？这是我的sessionInfo（）R版本3.0.1（2013-05-16）平台：x86_64-w64-mingw32/x64（64位）[1]谱系mm_0.3-1-----[22]lme4\u 1.0-4---Matrix\u 1.0-12您是否愿意尝试将
Matrix
、
Rcpeigen
、和
lme4
（按顺序）分别更新到版本1.1-0、0.3.2.0和1.0-5…？（更新Matrix是重要的部分，但如果您不更新（或至少重新安装）
RcppEigen
和
lme4
，您将遇到麻烦。我将尝试按照您的建议更新所有这些文件
doFit <- function(lmod,lmm=TRUE) {
    ## see ?modular
    if (lmm) {
        devfun <- do.call(mkLmerDevfun, lmod)
        opt <- optimizeLmer(devfun)
        mkMerMod(environment(devfun), opt, lmod$reTrms, fr = lmod$fr)
    } else {
        devfun <- do.call(mkGlmerDevfun, lmod)
        opt <- optimizeGlmer(devfun)
        devfun <- updateGlmerDevfun(devfun, lmod$reTrms)
        opt <- optimizeGlmer(devfun, stage=2)
        mkMerMod(environment(devfun), opt, lmod$reTrms, fr = lmod$fr)
    }
}

relmatmm <- function (formula, ..., lmm=TRUE, relmat = list()) {
    ff <- if (lmm) lFormula(formula, ...) else glFormula(formula, ...)
    stopifnot(is.list(relmat), length(names(relmat)) == length(relmat))
    relnms <- names(relmat)
    relfac <- relmat
    flist <- ff$reTrms[["flist"]]   ## list of factors
     ## random-effects design matrix components
    Ztlist <- ff$reTrms[["Ztlist"]]
    stopifnot(all(relnms %in% names(flist)))
    asgn <- attr(flist, "assign")
    for (i in seq_along(relmat)) {
        tn <- which(match(relnms[i], names(flist)) == asgn)
        if (length(tn) > 1) 
            stop("a relationship matrix must be",
                 " associated with only one random effects term")
        zn <- rownames(Ztlist[[i]])
        relmat[[i]] <- Matrix(relmat[[i]][zn,zn],sparse = TRUE)
        relfac[[i]] <- chol(relmat[[i]])
        Ztlist[[i]] <-  relfac[[i]] %*% Ztlist[[i]]
    }
    ff$reTrms[["Ztlist"]] <- Ztlist
    ff$reTrms[["Zt"]] <- do.call(rBind,Ztlist)
    fit <- doFit(ff,lmm)
}

set.seed(1234)
mydata <- data.frame (gen = factor(rep(1:10, each = 10)),
                  repl = factor(rep(1:10, 10)),
                  yld = rnorm(10, 5, 0.5))

library(lme4)
covmat <- round(nearPD(matrix(runif(100, 0, 0.2), nrow = 10))$mat, 2)
diag(covmat) <- diag(covmat)/10+1
rownames(covmat) <- colnames(covmat) <- levels(mydata$gen)

m <- relmatmm(yld ~ (1|gen) + (1|repl), relmat=list(gen=covmat), 
     data=mydata)