[Lme4-commits] r1436 - pkg/lme4Eigen/inst/unitTests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Nov 4 20:20:23 CET 2011
Author: dmbates
Date: 2011-11-04 20:20:23 +0100 (Fri, 04 Nov 2011)
New Revision: 1436
Modified:
pkg/lme4Eigen/inst/unitTests/runit.compDev.R
pkg/lme4Eigen/inst/unitTests/runit.link.R
pkg/lme4Eigen/inst/unitTests/runit.lmerResp.R
Log:
update tests (compDev is inert at present but could be activated for glmer tests)
Modified: pkg/lme4Eigen/inst/unitTests/runit.compDev.R
===================================================================
--- pkg/lme4Eigen/inst/unitTests/runit.compDev.R 2011-11-02 20:44:05 UTC (rev 1435)
+++ pkg/lme4Eigen/inst/unitTests/runit.compDev.R 2011-11-04 19:20:23 UTC (rev 1436)
@@ -1,3 +1,4 @@
+if (FALSE) { # compDev no longer exists for lmer models - maybe check glmer?
test.compDev <- function() { # cross-check compDev versus R evaluation
fm1 <- lmer(Yield ~ 1|Batch, Dyestuff, doFit = FALSE)
dd1c <- mkdevfun(fm1)
@@ -5,3 +6,4 @@
checkEquals(dd1c(1), dd1u(1))
checkEquals(bobyqa(1,dd1c,0), bobyqa(1,dd1u,0))
}
+}
Modified: pkg/lme4Eigen/inst/unitTests/runit.link.R
===================================================================
--- pkg/lme4Eigen/inst/unitTests/runit.link.R 2011-11-02 20:44:05 UTC (rev 1435)
+++ pkg/lme4Eigen/inst/unitTests/runit.link.R 2011-11-04 19:20:23 UTC (rev 1436)
@@ -1,10 +1,12 @@
eps <- .Machine$double.eps
oneMeps <- 1 - eps
set.seed(1)
+
etas <- data.frame(A = seq.int(-8, 8, by=1), # equal spacing to asymptotic area
B = runif(17, -8, 8), # random sample from wide uniform dist
C = rnorm(17, 0, 8), # random sample from wide normal dist
D = c(-10^30, rnorm(15, 0, 4), 10^30))
+
etapos <- data.frame(A = seq.int(1, 20, by=1),
B = rexp(20),
C = rgamma(20, 3),
@@ -17,64 +19,71 @@
pmin(pmax(eps, rbeta(100, 3, 0.1)), oneMeps)), as.numeric)
tst.lnki <- function(fam, frm) {
- rr <- glmerResp$new(fam, numeric(nrow(frm)))
- sapply(frm, function(x) checkEquals(fam$linkinv(x), {rr$updateMu(x); rr$mu()}))
+ ff <- glmFamily$new(family=fam)
+ sapply(frm, function(x) checkEquals(fam$linkinv(x), ff$linkInv(x)))
}
+tst.link <- function(fam, frm) {
+ ff <- glmFamily$new(family=fam)
+ sapply(frm, function(x) checkEquals(fam$linkfun(x), ff$link(x)))
+}
+
tst.muEta <- function(fam, frm) {
- rr <- glmerResp$new(fam, numeric(nrow(frm)))
- sapply(frm, function(x) checkEquals(fam$mu.eta(x), {rr$updateMu(x); rr$muEta()}))
+ ff <- glmFamily$new(family=fam)
+ sapply(frm, function(x) checkEquals(fam$mu.eta(x), ff$muEta(x)))
}
tst.variance <- function(fam, frm) {
- rr <- glmerResp$new(fam, numeric(nrow(frm)))
- sapply(frm, function(x) checkEquals(fam$variance(fam$linkinv(x)), {rr$updateMu(x); rr$variance()}))
+ ff <- glmFamily$new(family=fam)
+ sapply(frm, function(x) checkEquals(fam$variance(x), ff$variance(x)))
}
test.uncons.lnki <- function() { # linkinv on unconstrained eta
tst.lnki(binomial(), etas) # binomial with logit link
tst.muEta(binomial(), etas)
- tst.variance(binomial(), etas)
tst.lnki(binomial("probit"), etas) # binomial with probit link
tst.muEta(binomial("probit"), etas)
- tst.variance(binomial("probit"), etas)
tst.lnki(binomial("cloglog"), etas) # binomial with cloglog link
tst.muEta(binomial("cloglog"), etas)
- tst.variance(binomial("cloglog"), etas)
tst.lnki(binomial("cauchit"), etas) # binomial with cauchit link
tst.muEta(binomial("cauchit"), etas)
- tst.variance(binomial("cauchit"), etas)
tst.lnki(poisson(), etas) # Poisson with log link
tst.muEta(poisson(), etas)
- tst.variance(poisson(), etas)
tst.lnki(gaussian(), etas) # Gaussian with identity link
tst.muEta(gaussian(), etas)
- tst.variance(gaussian(), etas)
}
test.pos.lnki <- function() { # linkinv for positive eta
- set.seed(1)
tst.lnki(Gamma(), etapos) # gamma family
tst.muEta(Gamma(), etapos)
- tst.variance(Gamma(), etapos)
tst.lnki(inverse.gaussian(), etapos) # inverse Gaussian
tst.muEta(inverse.gaussian(), etapos)
- tst.variance(inverse.gaussian(), etapos)
}
-test.binom.link <- function() { # link for binomial mu
+test.binom.link <- function() { # link and variance for binomial mu
tst.link(binomial(), mubinom)
+ tst.variance(binomial(), mubinom)
tst.link(binomial("probit"), mubinom)
+ tst.variance(binomial("probit"), mubinom)
+ tst.link(binomial("cauchit"), mubinom)
+ tst.variance(binomial("cauchit"), mubinom)
}
-test.pos.link <- function() { # link for positive mu
+test.pos.link <- function() { # link for positive mu (using positive etas)
tst.link(poisson(), etapos)
+ tst.variance(poisson(), etapos)
tst.link(Gamma(), etapos)
- tst.link(inverse.gaussian(), etapos)
+ tst.variance(Gamma(), etapos)
+ tst.link(inverse.gaussian(), etapos)
+ tst.variance(inverse.gaussian(), etapos)
}
-test.uncons.link <- function() { # link for unconstrained mu
+test.uncons.link <- function() { # link for unconstrained mu (using unconstrained etas)
tst.link(gaussian(), etas)
+ tst.variance(gaussian(), etas)
}
-## ToDo: Add checks on variance functions
+
+
+
+
Modified: pkg/lme4Eigen/inst/unitTests/runit.lmerResp.R
===================================================================
--- pkg/lme4Eigen/inst/unitTests/runit.lmerResp.R 2011-11-02 20:44:05 UTC (rev 1435)
+++ pkg/lme4Eigen/inst/unitTests/runit.lmerResp.R 2011-11-04 19:20:23 UTC (rev 1436)
@@ -1,35 +1,45 @@
set.seed(1)
-
-test.lmerResp.twoarg <- function() {
+test.lmerResp <- function() {
n <- nrow(Dyestuff)
YY <- Dyestuff$Yield
mYY <- mean(YY)
mres <- YY - mYY
- rr <- lmerResp$new(1L, YY)
+ rr <- lmerResp$new(y=YY)
checkEquals(rr$weights, rep.int(1, n))
- checkEquals(rr$sqrtrwt, rep.int(1, n))
- checkEquals(rr$sqrtXwt, rep.int(1, n))
- checkEquals(rr$offset, rep.int(0, n))
- checkEquals(rr$mu, rep.int(0, n))
- checkEquals(rr$wtres, YY)
+ checkEquals(rr$sqrtrwt(), rep.int(1, n))
+ checkEquals(rr$sqrtXwt(), array(rep.int(1, n), c(n, 1L)))
+ checkEquals(rr$offset, rep.int(0, n))
+ checkEquals(rr$fitted(), rep.int(0, n))
+ checkEquals(rr$wtres(), YY)
+ checkEquals(rr$wrss(), sum(YY * YY))
checkEquals(rr$updateMu(rep.int(mYY, n)), sum(mres^2))
+ checkEquals(rr$reml, 0L)
+ rr$reml <- 1L
+ checkEquals(rr$reml, 1L)
}
-test.lmerResp.threearg <- function() {
+test.glmResp <- function() {
n <- nrow(Dyestuff)
YY <- Dyestuff$Yield
- WW <- rep(1, n)
- ZZ <- rep(0, n)
- sqrtWW <- sqrt(WW)
- mYY <- mean(YY)
- mres <- YY - mYY
- rr <- lmerResp$new(1L, YY, WW)
- checkEquals(rr$weights, WW)
- checkEquals(rr$sqrtrwt, WW)
- checkEquals(rr$sqrtXwt, WW)
- checkEquals(rr$offset, ZZ)
- checkEquals(rr$mu, ZZ)
- checkEquals(rr$wtres, YY)
- checkEquals(rr$updateMu(rep.int(mYY, n)), sum(mres^2))
+ mlYY <- mean(log(YY))
+ gmeanYY <- exp(mlYY) # geometric mean
+ mres <- YY - gmeanYY
+ rr <- glmResp$new(family=poisson(), y=YY)
+
+ checkEquals(rr$weights, rep.int(1, n))
+ checkEquals(rr$sqrtrwt(), rep.int(1, n))
+ checkEquals(rr$sqrtXwt(), array(rep.int(1, n), c(n, 1L)))
+ checkEquals(rr$offset, rep.int(0, n))
+ checkEquals(rr$fitted(), rep.int(0, n))
+ checkEquals(rr$wtres(), YY)
+ checkEquals(rr$wrss(), sum(YY^2))
+ checkEquals(rr$n, rep.int(1, n))
+ checkEquals(rr$updateMu(rep.int(mlYY, n)), sum(mres^2))
+ checkEquals(rr$fitted(), rep.int(gmeanYY, n))
+ checkEquals(rr$muEta(), rep.int(gmeanYY, n))
+ checkEquals(rr$variance(), rep.int(gmeanYY, n))
+ rr$updateWts()
+ checkEquals(1/sqrt(rr$variance()), rr$sqrtrwt())
+ checkEquals(as.vector(rr$sqrtXwt()), rr$sqrtrwt() * rr$muEta())
}
More information about the Lme4-commits
mailing list