Nothing
R/webpower.R
In WebPower: Basic and Advanced Statistical Power Analysis
Defines functions
sem.effect.size
wp.mc.chisq.diff
wp.mc.t
wp.mc.sem.power.curve
wp.mc.sem.boot
wp.mc.sem.basic
wp.popPar
summary.power
wp.blcsm
plot.lcs.power
wp.lcsm
wp.anova.count
wp.anova.binary
wp.poisson
wp.correlation
estMRT3arm
estMRT2arm
estCRT3arm
estCRT2arm
wp.mediation
wp.logistic
wp.mrt3arm
wp.mrt2arm
wp.crt3arm
wp.crt2arm
nuniroot
wp.effect.MRT3arm
wp.effect.MRT2arm
wp.effect.CRT3arm
wp.effect.CRT2arm
wp.rmanova
wp.t2
wp.t1
wp.t
wp.two.prop.two.n
wp.two.prop
wp.one.prop
wp.prop
wp.anova
plot.webpower
print.webpower
Documented in
estCRT2arm
estCRT3arm
estMRT2arm
estMRT3arm
nuniroot
plot.lcs.power
plot.webpower
print.webpower
sem.effect.size
summary.power
wp.anova
wp.anova.binary
wp.anova.count
wp.blcsm
wp.correlation
wp.crt2arm
wp.crt3arm
wp.effect.CRT2arm
wp.effect.CRT3arm
wp.effect.MRT2arm
wp.effect.MRT3arm
wp.lcsm
wp.logistic
wp.mc.chisq.diff
wp.mc.sem.basic
wp.mc.sem.boot
wp.mc.sem.power.curve
wp.mc.t
wp.mediation
wp.mrt2arm
wp.mrt3arm
wp.poisson
wp.popPar
wp.prop
wp.rmanova
wp.t
print.webpower <- function(x, ...) {
cat(x$method, "\n\n", sep = "")
note <- x$note
url <- x$url
x[c("method", "note", "url", "alternative", "family", "parameter")] <- NULL
x <- do.call(cbind, x)
rownames(x) <- rep(" ", nrow(x))
print(x)
if (!is.null(note))
cat("\nNOTE: ", note, sep = "")
cat("\nURL: ", url, sep = "")
cat("\n")
invisible(x)
}
plot.webpower <- function(x, xvar = NULL, yvar = NULL, xlab = NULL, ylab = NULL,
...) {
wp <- x
wp[c("method", "note", "url", "alternative", "family", "parameter")] <- NULL
wp.matrix <- do.call(cbind, wp)
check <- is.null(xvar) + is.null(yvar)
if (check == 2) {
if (!is.null(xlab))
xlab <- xlab else xlab <- "Sample size"
if (!is.null(ylab))
ylab <- ylab else ylab <- "Power"
plot(wp$n, wp$power, xlab = xlab, ylab = ylab, ...)
lines(wp$n, wp$power, ...)
} else if (check == 1) {
stop("Both x and y need to be specified!")
} else {
if (!is.null(xlab))
xlab <- xlab else xlab <- xvar
if (!is.null(ylab))
ylab <- ylab else ylab <- yvar
plot(wp.matrix[, xvar], wp.matrix[, yvar], xlab = xlab, ylab = ylab,
...)
lines(wp.matrix[, xvar], wp.matrix[, yvar], ...)
}
}
wp.anova <- function(k = NULL, n = NULL, f = NULL, alpha = 0.05, power = NULL,
type = c("overall", "two.sided", "greater", "less")) {
type <- type[1]
if (sum(sapply(list(k, n, f, power, alpha), is.null)) != 1)
stop("exactly one of k, n, f, power, and alpha must be NULL")
if (!is.null(f) && min(f) < 0)
stop("f must be positive")
if (!is.null(k) && min(k) < 2)
stop("number of groups must be at least 2")
if (!is.null(n) && min(n) < 2)
stop("number of observations in each group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (type == "overall")
p.body <- quote({
lambda <- n * f^2
pf(qf(alpha, k - 1, n - k, lower = FALSE), k - 1, n - k, lambda,
lower = FALSE)
})
if (type == "two.sided")
p.body <- quote({
lambda <- n * f^2
pf(qf(alpha, 1, n - k, lower = FALSE), 1, n - k, lambda, lower = FALSE)
})
if (type == "greater")
p.body <- quote({
lambda <- sqrt(n) * f
pt(qt(alpha, n - k, lower = FALSE), n - k, lambda, lower = FALSE)
})
if (type == "less")
p.body <- quote({
lambda <- sqrt(n) * f
pt(qt(alpha, n - k), n - k, lambda)
})
if (is.null(power))
power <- eval(p.body) else if (is.null(k))
k <- uniroot(function(k) eval(p.body) - power, c(2 + 1e-10, 100))$root else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + k + 1e-10,
1e+05))$root else if (is.null(f))
f <- uniroot(function(f) eval(p.body) - power, c(1e-07, 1e+07))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
NOTE <- "n is the total sample size"
if (type == "overall") {
NOTE <- paste(NOTE, " (overall)", sep = "")
} else {
NOTE <- paste(NOTE, " (contrast, ", type, ")", sep = "")
}
METHOD <- "Power for One-way ANOVA"
URL <- "http://psychstat.org/anova"
structure(list(k = k, n = n, f = f, alpha = alpha, power = power, note = NOTE,
method = METHOD, url = URL), class = "webpower")
}
wp.prop <- function(h = NULL, n1 = NULL, n2 = NULL, alpha = 0.05, power = NULL,
type = c("1p", "2p", "2p2n"), alternative = c("two.sided", "less",
"greater")) {
type <- type[1]
if (type == "1p")
return(wp.one.prop(h = h, n = n1, alpha = alpha, power = power,
alternative = alternative))
if (type == "2p")
return(wp.two.prop(h = h, n = n1, alpha = alpha, power = power,
alternative = alternative))
if (type == "2p2n")
return(wp.two.prop.two.n(h = h, n1 = n1, n2 = n2, alpha = alpha,
power = power, alternative = alternative))
}
wp.one.prop <- function(h = NULL, n = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(h, n, power, alpha), is.null)) != 1)
stop("exactly one of h, n, power, and alpha must be NULL")
if (!is.null(n) && min(n) < 1)
stop("number of observations in each group must be at least 1")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(h))
h <- abs(h)
if (tside == 2) {
p.body <- quote({
pnorm(qnorm(alpha/2, lower = FALSE) - h * sqrt(n), lower = FALSE) +
pnorm(qnorm(alpha/2, lower = TRUE) - h * sqrt(n), lower = TRUE)
})
}
if (tside == 3) {
p.body <- quote({
pnorm(qnorm(alpha, lower = FALSE) - h * sqrt(n), lower = FALSE)
})
}
if (tside == 1) {
p.body <- quote({
pnorm(qnorm(alpha, lower = TRUE) - h * sqrt(n), lower = TRUE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(h)) {
if (tside == 2) {
h <- uniroot(function(h) eval(p.body) - power, c(1e-10, 10))$root
}
if (tside == 1) {
h <- uniroot(function(h) eval(p.body) - power, c(-10, 5))$root
}
if (tside == 3) {
h <- uniroot(function(h) eval(p.body) - power, c(-5, 10))$root
}
} else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
METHOD <- "Power for one-sample proportion test"
NOTE <- NULL
URL <- "http://psychstat.org/prop"
structure(list(h = h, n = n, alpha = alpha, power = power, url = URL,
method = METHOD, note = NOTE), class = "webpower")
}
wp.two.prop <- function(h = NULL, n = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(h, n, power, alpha), is.null)) != 1)
stop("exactly one of h, n, power, and alpha must be NULL")
if (!is.null(n) && min(n) < 1)
stop("number of observations in each group must be at least 1")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(h))
h <- abs(h)
if (tside == 3) {
p.body <- quote({
pnorm(qnorm(alpha, lower = FALSE) - h * sqrt(n/2), lower = FALSE)
})
}
if (tside == 2) {
p.body <- quote({
pnorm(qnorm(alpha/2, lower = FALSE) - h * sqrt(n/2), lower = FALSE) +
pnorm(qnorm(alpha/2, lower = TRUE) - h * sqrt(n/2), lower = TRUE)
})
}
if (tside == 1) {
p.body <- quote({
pnorm(qnorm(alpha, lower = TRUE) - h * sqrt(n/2), lower = TRUE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(h)) {
if (tside == 2) {
h <- uniroot(function(h) eval(p.body) - power, c(1e-10, 10))$root
}
if (tside == 1) {
h <- uniroot(function(h) eval(p.body) - power, c(-10, 5))$root
}
if (tside == 3) {
h <- uniroot(function(h) eval(p.body) - power, c(-5, 10))$root
}
} else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
NOTE <- "Sample sizes for EACH group"
URL <- "http://psychstat.org/prop2p"
METHOD <- "Power for two-sample proportion (equal n)"
structure(list(h = h, n = n, alpha = alpha, power = power, url = URL,
method = METHOD, note = NOTE), class = "webpower")
}
wp.two.prop.two.n <- function(h = NULL, n1 = NULL, n2 = NULL, alpha = 0.05,
power = NULL, alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(h, n1, n2, power, alpha), is.null)) != 1)
stop("exactly one of h, n1, n2, power, and alpha must be NULL")
if (!is.null(n1) && min(n1) < 2)
stop("number of observations in the first group must be at least 2")
if (!is.null(n2) && min(n2) < 2)
stop("number of observations in the second group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(h))
h <- abs(h)
if (tside == 3) {
p.body <- quote({
pnorm(qnorm(alpha, lower = FALSE) - h * sqrt((n1 * n2)/(n1 +
n2)), lower = FALSE)
})
}
if (tside == 1) {
p.body <- quote({
pnorm(qnorm(alpha, lower = TRUE) - h * sqrt((n1 * n2)/(n1 +
n2)), lower = TRUE)
})
}
if (tside == 2) {
p.body <- quote({
pnorm(qnorm(alpha/2, lower = FALSE) - h * sqrt((n1 * n2)/(n1 +
n2)), lower = FALSE) + pnorm(qnorm(alpha/2, lower = TRUE) -
h * sqrt((n1 * n2)/(n1 + n2)), lower = TRUE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(h)) {
if (tside == 2) {
h <- uniroot(function(h) eval(p.body) - power, c(1e-10, 10))$root
}
if (tside == 1) {
h <- uniroot(function(h) eval(p.body) - power, c(-10, 5))$root
}
if (tside == 3) {
h <- uniroot(function(h) eval(p.body) - power, c(-5, 10))$root
}
} else if (is.null(n1))
n1 <- uniroot(function(n1) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(n2))
n2 <- uniroot(function(n2) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
NOTE <- "Sample size for each group"
URL <- "http://psychstat.org/prop2p2n"
METHOD <- "Power for two-sample proportion (unequal n)"
structure(list(h = h, n1 = n1, n2 = n2, alpha = alpha, power = power,
url = URL, method = METHOD, note = NOTE), class = "webpower")
}
wp.t <- function(n1 = NULL, n2 = NULL, d = NULL, alpha = 0.05, power = NULL,
type = c("two.sample", "one.sample", "paired", "two.sample.2n"), alternative = c("two.sided",
"less", "greater"), tol = .Machine$double.eps^0.25) {
type <- type[1]
if (type == "two.sample.2n") {
return(wp.t2(n1 = n1, n2 = n2, d = d, alpha = alpha, power = power,
alternative = alternative, tol = tol))
} else {
return(wp.t1(n = n1, d = d, alpha = alpha, power = power, type = type,
alternative = alternative, tol = tol))
}
}
wp.t1 <- function(n = NULL, d = NULL, alpha = 0.05, power = NULL, type = c("two.sample",
"one.sample", "paired"), alternative = c("two.sided", "less", "greater"),
tol = .Machine$double.eps^0.25) {
if (sum(sapply(list(n, d, power, alpha), is.null)) != 1)
stop("exactly one of n, d, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
type <- match.arg(type)
alternative <- match.arg(alternative)
tsample <- switch(type, one.sample = 1, two.sample = 2, paired = 1)
ttside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 1)
if (tside == 2 && !is.null(d))
d <- abs(d)
if (ttside == 1) {
p.body <- quote({
nu <- (n - 1) * tsample
pt(qt(alpha/tside, nu, lower = TRUE), nu, ncp = sqrt(n/tsample) *
d, lower = TRUE)
})
}
if (ttside == 2) {
p.body <- quote({
nu <- (n - 1) * tsample
qu <- qt(alpha/tside, nu, lower = FALSE)
pt(qu, nu, ncp = sqrt(n/tsample) * d, lower = FALSE) + pt(-qu,
nu, ncp = sqrt(n/tsample) * d, lower = TRUE)
})
}
if (ttside == 3) {
p.body <- quote({
nu <- (n - 1) * tsample
pt(qt(alpha/tside, nu, lower = FALSE), nu, ncp = sqrt(n/tsample) *
d, lower = FALSE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10, 1e+07),
tol = tol, extendInt = "upX")$root else if (is.null(d)) {
if (ttside == 2) {
d <- uniroot(function(d) eval(p.body) - power, c(1e-07, 10),
tol = tol, extendInt = "upX")$root
}
if (ttside == 1) {
d <- uniroot(function(d) eval(p.body) - power, c(-10, 5), tol = tol,
extendInt = "upX")$root
}
if (ttside == 3) {
d <- uniroot(function(d) eval(p.body) - power, c(-5, 10), tol = tol,
extendInt = "upX")$root
}
} else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10), tol = tol, extendInt = "upX")$root else stop("internal error", domain = NA)
NOTE <- switch(type, paired = "n is number of *pairs*", two.sample = "n is number in *each* group",
NULL)
METHOD <- paste(switch(type, one.sample = "One-sample", two.sample = "Two-sample",
paired = "Paired"), "t-test")
URL <- "http://psychstat.org/ttest"
structure(list(n = n, d = d, alpha = alpha, power = power, alternative = alternative,
note = NOTE, method = METHOD, url = URL), class = "webpower")
}
wp.t2 <- function(n1 = NULL, n2 = NULL, d = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater"), tol = .Machine$double.eps^0.25) {
if (sum(sapply(list(n1, n2, d, power, alpha), is.null)) != 1)
stop("exactly one of n1, n2, d, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (!is.null(n1) && min(n1) < 2)
stop("number of observations in the first group must be at least 2")
if (!is.null(n2) && min(n2) < 2)
stop("number of observations in the second group must be at least 2")
alternative <- match.arg(alternative)
tsample <- 2
ttside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 1)
if (tside == 2 && !is.null(d))
d <- abs(d)
if (ttside == 1) {
p.body <- quote({
nu <- n1 + n2 - 2
pt(qt(alpha/tside, nu, lower = TRUE), nu, ncp = d * (1/sqrt(1/n1 +
1/n2)), lower = TRUE)
})
}
if (ttside == 2) {
p.body <- quote({
nu <- n1 + n2 - 2
qu <- qt(alpha/tside, nu, lower = FALSE)
pt(qu, nu, ncp = d * (1/sqrt(1/n1 + 1/n2)), lower = FALSE) +
pt(-qu, nu, ncp = d * (1/sqrt(1/n1 + 1/n2)), lower = TRUE)
})
}
if (ttside == 3) {
p.body <- quote({
nu <- n1 + n2 - 2
pt(qt(alpha/tside, nu, lower = FALSE), nu, ncp = d * (1/sqrt(1/n1 +
1/n2)), lower = FALSE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n1))
n1 <- uniroot(function(n1) eval(p.body) - power, c(2 + 1e-10, 1e+07),
tol = tol, extendInt = "upX")$root else if (is.null(n2))
n2 <- uniroot(function(n2) eval(p.body) - power, c(2 + 1e-10, 1e+07),
tol = tol, extendInt = "upX")$root else if (is.null(d)) {
if (ttside == 2) {
d <- uniroot(function(d) eval(p.body) - power, c(1e-07, 10),
tol = tol, extendInt = "upX")$root
}
if (ttside == 1) {
d <- uniroot(function(d) eval(p.body) - power, c(-10, 5), tol = tol,
extendInt = "upX")$root
}
if (ttside == 3) {
d <- uniroot(function(d) eval(p.body) - power, c(-5, 10), tol = tol,
extendInt = "upX")$root
}
} else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10), tol = tol, extendInt = "upX")$root else stop("internal error", domain = NA)
NOTE <- "n1 and n2 are number in *each* group"
METHOD <- "Unbalanced two-sample t-test"
URL <- "http://psychstat.org/ttest2n"
structure(list(n1 = n1, n2 = n2, d = d, alpha = alpha, power = power,
alternative = alternative, note = NOTE, method = METHOD, url = URL),
class = "webpower")
}
## function for repeated measures anova analysis
wp.rmanova <- function(n = NULL, ng = NULL, nm = NULL, f = NULL, nscor = 1,
alpha = 0.05, power = NULL, type = 0) {
if (sum(sapply(list(n, ng, nm, f, nscor, power, alpha), is.null)) !=
1)
stop("exactly one of n, ng, nm, power, and alpha must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 1)
stop("Sample size has to be larger than 1")
if (!is.null(ng) && min(ng) < 1)
stop("Number of groups have to be at least 1")
if (!is.null(nm) && min(nm) < 2)
stop("number of measurements must be at least 1")
if (!is.null(nscor) && !is.numeric(nscor) || any(0 > nscor | nscor >
1))
stop("Nonsphericity correction must be numeric in [0, 1]")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
## function to evaluate
if (type == 0) {
p.body <- quote({
df1 <- ng - 1
df2 <- n - ng
lambda <- f^2 * n * nscor
pf(qf(alpha, df1, df2, lower = FALSE), df1, df2, lambda, lower = FALSE)
})
}
if (type == 1) {
p.body <- quote({
df1 <- (nm - 1) * nscor
df2 <- (n - ng) * df1
lambda <- f^2 * n * nscor
pf(qf(alpha, df1, df2, lower = FALSE), df1, df2, lambda, lower = FALSE)
})
}
if (type == 2) {
p.body <- quote({
df1 <- (ng - 1) * (nm - 1) * nscor
df2 <- (n - ng) * (nm - 1) * nscor
lambda <- f^2 * n * nscor
pf(qf(alpha, df1, df2, lower = FALSE), df1, df2, lambda, lower = FALSE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(5 + ng, 1e+07))$root
} else if (is.null(ng)) {
ng <- uniroot(function(ng) eval(p.body) - power, c(1 + 1e-10,
1e+05))$root
} else if (is.null(nm)) {
nm <- uniroot(function(nm) eval(p.body) - power, c(1e-07, 1e+07))$root
} else if (is.null(f)) {
f <- uniroot(function(f) eval(p.body) - power, c(1e-07, 1e+07))$root
} else if (is.null(alpha)) {
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root
} else stop("internal error")
if (type == 0)
NOTE <- "Power analysis for between-effect test"
if (type == 1)
NOTE <- "Power analysis for within-effect test"
if (type == 2)
NOTE <- "Power analysis for interaction-effect test"
URL <- "http://psychstat.org/rmanova"
METHOD <- "Repeated-measures ANOVA analysis"
structure(list(n = n, f = f, ng = ng, nm = nm, nscor = nscor, alpha = alpha,
power = power, note = NOTE, method = METHOD, url = URL), class = "webpower")
}
## Effect size and ICC calculation for CRT with 2 arms based on
## empirical data The data has to be in text format where the first
## column of the data is the ID variable, the second column represents
## cluster, the third column is the outcome variable, and the fourth
## column is the condition variable (0 for control, 1 for condition).
## The first line of the data should be the variable names.
wp.effect.CRT2arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
dat.trt <- dat[dat[, 4] == 1, ]
dat.ctl <- dat[dat[, 4] == 0, ]
mutj <- aggregate(dat.trt[, 3], by = list(dat.trt[, 2]), FUN = mean)
mucj <- aggregate(dat.ctl[, 3], by = list(dat.ctl[, 2]), FUN = mean)
mu_j <- rbind(mutj, mucj)
names(mu_j) <- c(names(dat)[2], "mu")
dat.mu <- merge(dat, mu_j, by = names(dat)[2])
SSW <- sum((dat.mu[, 3] - dat.mu[5])^2)/(n * J - J)
mut <- mean(mutj[, 2])
muc <- mean(mucj[, 2])
SSB <- (sum((mutj[, 2] - mut)^2) + sum((mucj[, 2] - muc)^2))/(J - 2)
f <- (mut - muc)/sqrt(SSB + (1 - 1/n) * SSW)
rho <- (SSB - SSW/n)/(SSB + (1 - 1/n) * SSW)
return(list(f = f, ICC = rho))
}
## Effect size and ICC calculation for CRT with 3 arms based on
## empirical data The data has to be in text format, where the first
## column of the data is the ID variable, the second column represents
## cluster, the third column is the outcome variable, and the fourth
## column is the condition variable (0 for control, 1 for treatment1, 2
## for treatment2). The first line of the data should be the variable
## names.
wp.effect.CRT3arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
dat.ctl <- dat[dat[, 4] == 0, ]
dat.trt1 <- dat[dat[, 4] == 1, ]
dat.trt2 <- dat[dat[, 4] == 2, ]
mut1j <- aggregate(dat.trt1[, 3], by = list(dat.trt1[, 2]), FUN = mean)
mut2j <- aggregate(dat.trt2[, 3], by = list(dat.trt2[, 2]), FUN = mean)
mucj <- aggregate(dat.ctl[, 3], by = list(dat.ctl[, 2]), FUN = mean)
mu_j <- rbind(mut1j, mut2j, mucj)
names(mu_j) <- c(names(dat)[2], "mu")
dat.mu <- merge(dat, mu_j, by = names(dat)[2])
SSW <- sum((dat.mu[, 3] - dat.mu[5])^2)/(n * J - J)
mut1 <- mean(mut1j[, 2])
mut2 <- mean(mut2j[, 2])
muc <- mean(mucj[, 2])
SSB <- (sum((mut1j[, 2] - mut1)^2) + sum((mut2j[, 2] - mut2)^2) + sum((mucj[,
2] - muc)^2))/(J - 3)
tau_hat <- SSB - SSW/n
f1 <- (0.5 * mut1 + 0.5 * mut2 - muc)/sqrt(tau_hat + SSW)
f2 <- (mut1 - mut2)/sqrt(tau_hat + SSW)
f3 <- sqrt((((0.5 * (mut1 + mut2) - muc)^2)/4.5 + ((mut1 - mut2)^2)/6)/(tau_hat +
SSW))
rho <- tau_hat/(tau_hat + SSW)
return(list(f1 = f1, f2 = f2, f3 = f3, ICC = rho))
# f1: effect size of treatment main effect f2: effect size of comparing
# two treatments f3: effect size of omnibus test
}
## Effect size for MRT with 2 arms based on empirical data The data has
## to be in text format where the first column of the data is the ID
## variable, the second column represents cluster, the third column is
## the outcome variable, and the fourth column is the condition variable
## (0 for control, 1 for condition). The first line of the data should
## be the variable names.
wp.effect.MRT2arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
mutcj <- aggregate(dat[, 3], by = list(dat[, 2], dat[, 4]), FUN = mean)
mutj <- mutcj[mutcj[, 2] == 1, ]
mucj <- mutcj[mutcj[, 2] == 0, ]
beta0 <- aggregate(mutcj[, 3], by = list(mutcj[, 1]), FUN = mean)
names(beta0) <- c(names(dat)[2], "beta0")
dat1 <- merge(dat, beta0, by = names(dat)[2]) #merge beta0
mut_c <- merge(mutj, mucj, names(mutj)[1])
mut_c$beta1 <- mut_c[, 3] - mut_c[, 5]
mut_c1 <- mut_c[, c(1, 6)]
names(mut_c1) <- c(names(dat)[2], "beta1")
dat2 <- merge(dat1, mut_c1, by = names(dat)[2]) #merge beta1
mud <- sum(mut_c[, 3] - mut_c[, 5])/J
Xij <- dat[, 4] - 0.5
sg2 <- sum((dat2[, 3] - dat2[, 5] - dat2[, 6] * Xij)^2)/(J * (n - 2))
f <- mud/sqrt(sg2)
return(list(f = f))
}
## Effect size for MRT with 3 arms based on empirical data The data has
## to be in text format, where the first column of the data is the ID
## variable, the second column represents cluster, the third column is
## the outcome variable, and the fourth column is the condition variable
## (0 for control, 1 for treatment1, 2 for treatment2). The first line
## of the data should be the variable names.
wp.effect.MRT3arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
mutcj <- aggregate(dat[, 3], by = list(dat[, 2], dat[, 4]), FUN = mean)
mut1j <- mutcj[mutcj[, 2] == 1, ]
names(mut1j)[3] <- "y1"
mut2j <- mutcj[mutcj[, 2] == 2, ]
names(mut2j)[3] <- "y2"
mucj <- mutcj[mutcj[, 2] == 0, ]
names(mucj)[3] <- "y0"
beta0 <- aggregate(mutcj[, 3], by = list(mutcj[, 1]), FUN = mean)
names(beta0) <- c(names(dat)[2], "beta0")
dat1 <- merge(dat, beta0, by = names(dat)[2]) #merge beta0
mut_c1 <- merge(mut1j, mucj, names(mut1j)[1])
mut_c <- merge(mut2j, mut_c1, names(mut2j)[1])
mut_c <- mut_c[, c(1, 3, 5, 7)]
mut_c$beta1 <- (mut_c$y1 + mut_c$y2)/2 - mut_c$y0
mut_c$beta2 <- (mut_c$y1 - mut_c$y2)
names(mut_c)[1] <- names(dat)[2]
dat2 <- merge(dat1, mut_c, by = names(dat)[2]) #merge beta1 and beta2
mud1 <- sum(mut_c$y1 - mut_c$y0)/J
mud2 <- sum(mut_c$y2 - mut_c$y0)/J
X1ij <- rep(0, nrow(dat)) # 0.5 for trt1 and trt2, -1 for ctl
X2ij <- rep(0, nrow(dat)) # 1 for trt1, -1 for trt2, 0 for ctl
X1ij[dat[, 4] == 1] <- 0.5
X1ij[dat[, 4] == 2] <- 0.5
X1ij[dat[, 4] == 0] <- -1
X2ij[dat[, 4] == 1] <- 1
X2ij[dat[, 4] == 2] <- -1
X2ij[dat[, 4] == 0] <- 0
sg2 <- sum((dat2[, 3] - dat2$beta0 - dat2$beta1 * X1ij - dat2$beta2 *
X2ij)^2)/(J * (n - 3))
f1 <- (mud1 + mud2)/2/sqrt(sg2) #effect size of treatment main effect
f2 <- (mud1 - mud2)/sqrt(sg2) #effect size of comparing the two treatments
return(list(f1 = f1, f2 = f2))
}
nuniroot <- function(f, interval, maxlength = 100) {
if (length(interval)!=2) stop("Please provide an interval with two values such as c(0,1).")
x <- seq(min(interval), max(interval), length = maxlength)
f.out <- f(x)
if (min(f.out) * max(f.out) > 0)
stop("The specified parameters do not yield valid results. Please try to supply a different interval, e.g., using interval=c(0,1), for your parameter.") else {
low <- max(f.out[f.out < 0])
high <- min(f.out[f.out > 0])
interval <- c(x[f.out == low][1], x[f.out == high][1])
uniroot(f, interval)
}
}
####################################################### function for cluster randomized trials with 2 arms##
wp.crt2arm <- function(n = NULL, f = NULL, J = NULL, icc = NULL, power = NULL,
alpha = 0.05, alternative = c("two.sided", "one.sided"), interval = NULL) {
alternative <- alternative[1]
if (sum(sapply(list(J, n, f, icc, alpha, power), is.null)) != 1)
stop("exactly one of J, n, f, icc, and alpha,power must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 1)
stop("Sample size has to be larger than 1")
if (!is.null(J) && min(J) < 2)
stop("Number of clusters has to be at least 2")
if (!is.null(icc) && !is.numeric(icc) || any(0 > icc | icc > 1))
stop("Intraclass correlation must be numeric in [0, 1]")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
## function to evaluate two-sided
if (alternative == "two.sided") {
p.body <- quote({
df <- J - 2
lambda <- sqrt(J * f^2/(4 * icc + 4 * (1 - icc)/n))
1 - pt(qt(1 - alpha/2, df), df, lambda) + pt(-qt(1 - alpha/2,
df), df, lambda)
})
} else {
## one-sided
p.body <- quote({
df <- J - 2
lambda <- sqrt(J * f^2/(4 * icc + 4 * (1 - icc)/n))
1 - pt(qt(1 - alpha, J - 2), df, lambda)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(2 + 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1, 1e+06), interval))$root else if (is.null(f))
f <- nuniroot(function(f) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(icc))
icc <- nuniroot(function(icc) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(0, 1), interval))$root else if (is.null(alpha))
alpha <- nuniroot(function(alpha) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1 - 1e-10), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster."
METHOD <- "Cluster randomized trials with 2 arms"
URL <- "http://psychstat.org/crt2arm"
structure(list(J = J, n = n, f = f, icc = icc, power = power, alpha = alpha, note = NOTE, method = METHOD, url = URL), class = "webpower")
}
####################################################### function for cluster randomized trials with 3 arms##
wp.crt3arm <- function(n = NULL, f = NULL, J = NULL, icc = NULL, power = NULL,
alpha = 0.05, alternative = c("two.sided", "one.sided"), type = c("main",
"treatment", "omnibus"), interval = NULL) {
side <- alternative[1]
type <- type[1]
if (sum(sapply(list(J, n, f, icc, alpha, power), is.null)) != 1)
stop("exactly one of J, n, f, icc, and alpha,power must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 1)
stop("Sample size has to be larger than 1")
if (!is.null(J) && min(J) < 3)
stop("Number of clusters has to be at least 3")
if (!is.null(icc) && !is.numeric(icc) || any(0 > icc | icc > 1))
stop("Intraclass correlation must be numeric in [0, 1]")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
## compare the average treatment with control
if (type == "main") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 3
lambda1 <- sqrt(J) * f/sqrt(4.5 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda1) + pt(-t0, df, lambda1)
})
} else {
## one-sided
p.body <- quote({
df <- J - 3
lambda1 <- sqrt(J) * f/sqrt(4.5 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda1)
})
}
}
## compare the two treatments
if (type == "treatment") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 3
lambda2 <- sqrt(J) * f/sqrt(6 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda2) + pt(-t0, df, lambda2)
})
} else {
## one-sided
p.body <- quote({
df <- J - 3
lambda2 <- sqrt(J) * f/sqrt(6 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda2)
})
}
}
## omnibus test
if (type == "omnibus") {
p.body <- quote({
df1 <- 2
df2 <- J - 3
lambda3 <- J * f^2/(icc + (1 - icc)/n)
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0, df1, df2, lambda3)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(3 + 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(2 + 1e-10, 1e+06), interval))$root else if (is.null(f))
f <- nuniroot(function(f) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(icc))
icc <- nuniroot(function(icc) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(0, 1), interval))$root else if (is.null(alpha))
alpha <- nuniroot(function(alpha) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1 - 1e-10), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster."
METHOD <- "Cluster randomized trials with 3 arms"
URL <- "http://psychstat.org/crt3arm"
structure(list(J = J, n = n, f = f, icc = icc, power = power, alpha = alpha,
note = NOTE, method = METHOD, url = URL), class = "webpower")
}
######################################################### function for multisite randomized trials with 2 arms##
wp.mrt2arm <- function(n = NULL, f = NULL, J = NULL, tau00 = NULL, tau11 = NULL,
sg2 = NULL, power = NULL, alpha = 0.05, alternative = c("two.sided",
"one.sided"), type = c("main", "site", "variance"), interval = NULL) {
type <- type[1]
side <- alternative[1]
if (sum(sapply(list(f, n, J, power), is.null)) != 1 & type == "main")
stop("exactly one of f, J, n and power must be NULL")
if (sum(sapply(list(n, J, power), is.null)) != 1 & type != "main")
stop("exactly one of J, n and power must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 2)
stop("Sample size has to be larger than 2")
if (!is.null(J) && min(J) < 2)
stop("Number of sites has to be at least 2")
if (!is.null(tau00) && min(tau00) < 0)
stop("Variance of site means must be positive")
if (!is.null(tau11) && min(tau11) < 0)
stop("Variance of treatment main effects across sites must be positive")
if ((!is.null(sg2) && min(sg2) < 0) || is.null(sg2))
stop("Between-person variation must be a positive number")
if (is.null(alpha) || (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1)))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
if (is.null(tau11) && (type == "main" || type == "variance"))
stop("For this type of test, variance of treatment main effects across sites must be specified")
if (is.null(tau00) && type == "site")
stop("For this type of test, variance of site means must be specified")
## test treatment main effect #no tau00 needed
if (type == "main") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f/sqrt(4/n + tau11/sg2)
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda1) + pt(-t0, df, lambda1)
})
} else {
## one-sided #no tau00 needed
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f/sqrt(4/n + tau11/sg2)
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda1)
})
}
}
## test site variability #no tau11 and f needed
if (type == "site") {
p.body <- quote({
df1 <- J - 1
df2 <- J * (n - 2)
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0/(n * tau00/sg2 + 1), df1, df2)
})
}
## test variance of treatment effects #no tau00 and f needed
if (type == "variance") {
p.body <- quote({
df1 <- J - 1
df2 <- J * (n - 2)
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0/(n * tau11/sg2/4 + 1), df1, df2)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1 + 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(3 - 1e-10, 1e+06), interval))$root else if (is.null(f) & type == 1)
f <- nuniroot(function(f) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster"
METHOD <- "Multisite randomized trials with 2 arms"
URL <- "http://psychstat.org/mrt2arm"
structure(list(J = J, n = n, f = f, tau00 = tau00, tau11 = tau11, sg2 = sg2,
power = power, alpha = alpha, note = NOTE, method = METHOD, url = URL),
class = "webpower")
}
######################################################### function for multisite randomized trials with 3 arms##
wp.mrt3arm <- function(n = NULL, f1 = NULL, f2 = NULL, J = NULL, tau = NULL,
sg2 = NULL, power = NULL, alpha = 0.05, alternative = c("two.sided",
"one.sided"), type = c("main", "treatment", "omnibus"), interval = NULL) {
type <- type[1]
side <- alternative[1]
if (type == "main")
if (sum(sapply(list(f1, n, J, power, alpha), is.null)) != 1)
stop("exactly one of f1, J, n, power and alpha must be NULL")
if (type == "treatment")
if (sum(sapply(list(f2, n, J, power, alpha), is.null)) != 1)
stop("exactly one of f2, J, n, power and alpha must be NULL")
if (type == "omnibus") {
if (sum(sapply(list(n, J, power, alpha), is.null)) != 1)
stop("exactly one of J, n, power and alpha must be NULL")
if (is.null(f1) || is.null(f2))
stop("f1 & f2 must be given")
}
if (!is.null(f1) && min(f1) < 0)
stop("Effect size must be positive")
if (!is.null(f2) && min(f2) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 3)
stop("Sample size has to be larger than 3")
if (!is.null(J) && min(J) < 2)
stop("Number of sites has to be at least 2")
if (!is.null(tau) && min(tau) < 0)
stop("Variance of treatment main effects across sites must be positive")
if ((!is.null(sg2) && min(sg2) < 0) || is.null(sg2))
stop("Between-person variation must be a positive number")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
## Test treatment main effect
if (type == "main") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f1/sqrt(4.5/n + 1.5 * tau/sg2)
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda1) + pt(-t0, df, lambda1)
})
} else {
## one-sided
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f1/sqrt(4.5/n + 1.5 * tau/sg2)
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda1)
})
}
}
## Compare two treatments
if (type == "treatment") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 1
lambda2 <- sqrt(J) * f2/sqrt(6/n + 2 * tau/sg2)
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda2) + pt(-t0, df, lambda2)
})
} else {
## one-sided
p.body <- quote({
df <- J - 1
lambda2 <- sqrt(J) * f2/sqrt(6/n + 2 * tau/sg2)
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda2)
})
}
}
## Omnibus test
if (type == "omnibus") {
p.body <- quote({
df1 <- 2
df2 <- 2 * (J - 1)
lambda1 <- sqrt(J) * f1/sqrt(4.5/n + 1.5 * tau/sg2)
lambda2 <- sqrt(J) * f2/sqrt(6/n + 2 * tau/sg2)
lambda3 <- lambda1^2 + lambda2^2
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0, df1, df2, lambda3)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(2 - 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(3 - 1e-10, 1e+07), interval))$root else if (is.null(f1) && type != 2)
f1 <- nuniroot(function(f1) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(f2) && type != 1)
f2 <- nuniroot(function(f2) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster"
METHOD <- "Multisite randomized trials with 3 arms"
URL <- "http://psychstat.org/mrt3arm"
structure(list(J = J, n = n, f1 = f1, f2 = f2, tau = tau, sg2 = sg2,
power = power, alpha = alpha, note = NOTE, method = METHOD, url = URL),
class = "webpower")
}
wp.regression <- function (n = NULL, p1 = NULL, p2 = 0,
f2 = NULL, alpha = 0.05, power = NULL,
type=c("regular", "Cohen")){
if (sum(sapply(list(n, f2, power, alpha), is.null)) != 1)
stop("exactly one of n, f2, power, and alpha must be NULL")
if (!is.null(f2) && min(f2) < 0)
stop("f2 must be positive")
if (!is.null(n) && min(n) < 5)
stop("sample size has to be at least 5")
if (!is.null(p1) && min(p1) < 1)
stop("number of predictor in the full model has to be larger than 1")
if (!is.null(p2) && p1 < p2)
stop("number of predictor in the full model has to be larger than that in the reduced model")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha |
alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
u <- p1 - p2
v <- n - p1 - 1
if (type[1]=="Cohen"){
lambda <- f2 * (u + v + 1)
}else{
lambda <- f2 * n
}
pf(qf(alpha, u, v, lower = FALSE), u, v, lambda, lower = FALSE)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(5 +
p1 + 1e-10, 1e+05))$root
else if (is.null(f2))
f2 <- uniroot(function(f2) eval(p.body) - power, c(1e-07,
1e+07))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power,
c(1e-10, 1 - 1e-10))$root
else stop("internal error")
METHOD <- "Power for multiple regression"
URL <- "http://psychstat.org/regression"
structure(list(n = n, p1 = p1, p2 = p2, f2 = f2, alpha = alpha,
power = power, method = METHOD, url = URL), class = "webpower")
}
wp.logistic <- function(n = NULL, p0 = NULL, p1 = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater"), family = c("Bernoulli",
"exponential", "lognormal", "normal", "Poisson", "uniform"), parameter = NULL) {
sig.level <- alpha
if (sum(sapply(list(n, power), is.null)) != 1)
stop("exactly one of n, power, and alpha must be NULL")
if (is.null(p0) || !is.null(p0) && !is.numeric(p0) || any(0 > p0 |
p0 > 1))
stop(sQuote("p0"), " must be numeric in (0,1)")
if (is.null(p1) || !is.null(p1) && !is.numeric(p1) || any(0 > p1 |
p1 > 1))
stop(sQuote("p1"), " must be numeric in (0,1)")
if (!is.null(n) && min(n) < 5)
stop("number of observations must be at least 5")
if (is.null(alpha) || !is.null(alpha) & !is.numeric(alpha) || any(alpha <
0 | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) & !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (!(family %in% c("Bernoulli",
"exponential", "lognormal", "normal", "Poisson", "uniform")))
stop ("family must be one of Bernoulli, exponential, lognormal, normal, Poisson, or uniform")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
p.body <- quote({
s * pnorm(-qnorm(1 - alpha) - sqrt(n)/sqrt(g * v0 + (1 - g) * v1) *
beta1) + t * pnorm(-qnorm(1 - alpha) + sqrt(n)/sqrt(g * v0 +
(1 - g) * v1) * beta1)
})
if (family == "Bernoulli") {
## binomial predictor
if (is.null(parameter)) {
B <- 0.5
} else {
B <- parameter
}
g <- 0
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
beta0 <- log(p0/(1 - p0))
d <- B * p1 * (1 - p1) + (1 - B) * p0 * (1 - p0)
e <- B * p1 * (1 - p1)
f <- B * p1 * (1 - p1)
v1 <- d/(d * f - e^2)
### v0
mu1 <- B * p1 + (1 - B) * p0
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- B * pn * (1 - pn) #11
c <- B * pn * (1 - pn) #01
v0 <- b/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "exponential") {
## Exponential predictor
if (is.null(parameter)) {
lambda <- 1
} else {
lambda <- parameter
}
g <- 0
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dexp(x, lambda), 0, Inf,
subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dexp(x, lambda), 0, Inf,
subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dexp(x, lambda),
0, Inf, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x)) *
dexp(x, lambda), 0, Inf, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- 2 * lambda^(-2) * pn * (1 - pn) #11
c <- lambda^(-1) * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "lognormal") {
g <- 0
if (is.null(parameter)) {
mu <- 0
sigma <- 1
} else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the log-normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dlnorm(x, mu, sigma),
0, Inf, subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dlnorm(x, mu, sigma),
0, Inf, subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dlnorm(x,
mu, sigma), 0, Inf, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x)) *
dlnorm(x, mu, sigma), 0, Inf, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- (exp(sigma * sigma) - 1) * exp(2 * mu + sigma^2) * pn * (1 -
pn) #11
c <- exp(mu + 0.5 * sigma^2) * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "normal") {
g <- 0
if (is.null(parameter)) {
mu <- 0
sigma <- 1
} else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dnorm(x, mu, sigma), -Inf,
Inf, subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dnorm(x, mu, sigma), -Inf,
Inf, subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dnorm(x, mu,
sigma), -Inf, Inf, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x)) *
dnorm(x, mu, sigma), -Inf, Inf, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- sigma^2 * pn * (1 - pn) #11
c <- mu * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "Poisson") {
g <- 0
if (is.null(parameter)) {
lambda <- 1
} else {
lambda <- parameter
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- sum(sapply(0:1e+05, function(x) (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dpois(x, lambda)))
e <- sum(sapply(0:1e+05, function(x) x * (1 - (1 + exp(-beta0 -
beta1 * x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dpois(x,
lambda)))
f <- sum(sapply(0:1e+05, function(x) x^2 * (1 - (1 + exp(-beta0 -
beta1 * x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dpois(x,
lambda)))
v1 <- d/(d * f - e^2)
mu1 <- sum(sapply(0:1e+05, function(x) 1/(1 + exp(-beta0 - beta1 *
x)) * dpois(x, lambda)))
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- lambda * pn * (1 - pn) #11
c <- lambda * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "uniform") {
g <- 0
if (is.null(parameter)) {
L <- 0
R <- 1
} else {
if (length(parameter) != 2)
stop("The lower and upper bounds have to be provided as a vector")
L <- parameter[1]
R <- parameter[2]
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1)/(R - L), L, R, subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1)/(R - L), L, R, subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1)/(R - L), L,
R, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x))/(R -
L), L, R, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- (R - L)^2/12 * pn * (1 - pn) #11
c <- (R + L)/2 * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
METHOD <- "Power for logistic regression"
URL <- "http://psychstat.org/logistic"
structure(list(p0 = p0, p1 = p1, beta0 = beta0, beta1 = beta1, n = n,
alpha = sig.level, power = power, alternative = alternative, family = family,
parameter = parameter, method = METHOD, url = URL), class = "webpower")
}
wp.mediation <- function(n = NULL, power = NULL, a = 0.5, b = 0.5, varx = 1,
vary = 1, varm = 1, alpha = 0.05, interval = NULL) {
if (sum(sapply(list(n, a, b, varx, varm, vary, power, alpha), is.null)) !=
1)
stop("exactly one of n, a, b, varx, varm, vary, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
## power formulae
p.body <- quote({
numer <- sqrt(n) * a * b
denom <- sqrt(a^2 * vary/(varm - a^2 * varx) + b^2 * (varm - a^2 *
varx)/varx)
delta <- numer/denom
alpha2 <- alpha/2
za2 <- qnorm(1 - alpha2)
1 - pnorm(za2 - delta) + pnorm(-za2 - delta)
})
if (is.null(power))
power <- eval(p.body) else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(a)) {
astart <- varm/varx
alow <- -sqrt(astart) + 1e-06
aup <- sqrt(astart) - 1e-06
a <- nuniroot(function(a) eval(p.body) - power, c(alow, aup))$root
} else if (is.null(b))
b <- nuniroot(function(b) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(-10, 10), interval))$root else if (is.null(varx))
varx <- nuniroot(function(varx) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1e+07), interval))$root else if (is.null(vary))
vary <- nuniroot(function(vary) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1e+07), interval))$root else if (is.null(varm))
varm <- nuniroot(function(varm) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1e+07), interval))$root else if (is.null(alpha))
alpha <- nuniroot(function(alpha) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1 - 1e-10), interval))$root else stop("internal error")
METHOD <- "Power for simple mediation"
URL <- "http://psychstat.org/mediation"
structure(list(n = n, power = power, a = a, b = b, varx = varx, varm = varm,
vary = vary, alpha = alpha, method = METHOD, url = URL), class = "webpower")
}
estCRT2arm <- function(file) {
dat <- read.table(file, header = TRUE)
X <- dat[, 4] - 0.5
newdata <- data.frame(dat, X)
model <- summary(lmer(score ~ X + (1 | cluster), data = newdata))
parest <- model$coefficients
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 2)) * 2
test <- cbind(parest, p.value)
cat("Fixed effects (X: Treatment main effect):\n")
print(test)
}
estCRT3arm <- function(file) {
dat <- read.table(file, header = T)
X1 <- X2 <- rep(0, dim(dat)[1])
X1[dat[, 4] == 1] <- X1[dat[, 4] == 2] <- 1/3
X1[dat[, 4] == 0] <- -2/3
X2[dat[, 4] == 1] <- 1/2
X2[dat[, 4] == 2] <- -1/2
newdata <- data.frame(dat, X1, X2)
model <- summary(lmer(score ~ X1 + X2 + (1 | cluster), data = newdata))
parest <- model$coefficients
rownames(parest)[2] <- "X"
rownames(parest)[3] <- "X1-X2"
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 3)) * 2
test <- cbind(parest, p.value)
# Omnibus test
model1 <- lmer(score ~ X1 + X2 + (1 | cluster), data = newdata, REML = FALSE)
model2 <- lmer(score ~ (1 | cluster), data = newdata, REML = FALSE)
omnibus <- anova(model1, model2)$"Pr(>Chisq)"[2]
cat("Fixed effects (X: Treatment main effect; X1-X2: Comparing two treatments):\n")
print(test)
cat("Omnibust test: p-value = ")
cat(omnibus)
}
estMRT2arm <- function(file) {
dat <- read.table(file, header = TRUE)
X <- dat[, 4] - 0.5
newdata <- data.frame(dat, X)
model <- summary(lmer(score ~ X + (X | cluster), data = newdata))
parest <- model$coefficients
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 1)) * 2
test <- cbind(parest, p.value)
cat("Fixed effects (X: Treatment main effect):\n")
print(test)
}
estMRT3arm <- function(file) {
dat <- read.table(file, header = T)
X1 <- X2 <- rep(0, dim(dat)[1])
X1[dat[, 4] == 1] <- X1[dat[, 4] == 2] <- 1/3
X1[dat[, 4] == 0] <- -2/3
X2[dat[, 4] == 1] <- 1/2
X2[dat[, 4] == 2] <- -1/2
newdata <- data.frame(dat, X1, X2)
model <- summary(lmer(score ~ X1 + X2 + (X1 + X2 | cluster), data = newdata))
parest <- model$coefficients
rownames(parest)[2] <- "X"
rownames(parest)[3] <- "X1-X2"
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 1)) * 2
test <- cbind(parest, p.value)
# Omnibus test
model1 <- lmer(score ~ X1 + X2 + (X1 + X2 | cluster), data = newdata,
REML = FALSE)
model2 <- lmer(score ~ (X1 + X2 | cluster), data = newdata, REML = FALSE)
omnibus <- anova(model1, model2)$"Pr(>Chisq)"[2]
cat("Fixed effects (X: Treatment main effect; X1-X2: Comparing two treatments):\n")
print(test)
cat("Omnibust test: p-value = ")
cat(omnibus)
}
wp.correlation <- function(n = NULL, r = NULL, power = NULL, p = 0, rho0 = 0,
alpha = 0.05, alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(n, r, power, alpha), is.null)) != 1)
stop("exactly one of n, r, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (!is.null(n) && min(n) < 4)
stop("number of observations must be at least 4")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(r))
r <- abs(r)
if (tside == 3) {
p.body <- quote({
delta <- sqrt(n - 3 - p) * (log((1 + r)/(1 - r))/2 + r/(n -
1 - p)/2 * (1 + (5 + r^2)/(n - 1 - p)/4 + (11 + 2 * r^2 +
3 * r^4)/(n - 1 - p)^2/8) - log((1 + rho0)/(1 - rho0))/2 -
rho0/(n - 1 - p)/2)
v <- (n - 3 - p)/(n - 1 - p) * (1 + (4 - r^2)/(n - 1 - p)/2 +
(22 - 6 * r^2 - 3 * r^4)/(n - 1 - p)^2/6)
zalpha <- qnorm(1 - alpha)
pnorm((delta - zalpha)/sqrt(v))
})
}
if (tside == 1) {
p.body <- quote({
delta <- sqrt(n - 3 - p) * (log((1 + r)/(1 - r))/2 + r/(n -
1 - p)/2 * (1 + (5 + r^2)/(n - 1 - p)/4 + (11 + 2 * r^2 +
3 * r^4)/(n - 1 - p)^2/8) - log((1 + rho0)/(1 - rho0))/2 -
rho0/(n - 1 - p)/2)
v <- (n - 3 - p)/(n - 1 - p) * (1 + (4 - r^2)/(n - 1 - p)/2 +
(22 - 6 * r^2 - 3 * r^4)/(n - 1 - p)^2/6)
zalpha <- qnorm(1 - alpha)
pnorm((-delta - zalpha)/sqrt(v))
})
}
if (tside == 2) {
p.body <- quote({
delta <- sqrt(n - 3 - p) * (log((1 + r)/(1 - r))/2 + r/(n -
1 - p)/2 * (1 + (5 + r^2)/(n - 1 - p)/4 + (11 + 2 * r^2 +
3 * r^4)/(n - 1 - p)^2/8) - log((1 + rho0)/(1 - rho0))/2 -
rho0/(n - 1 - p)/2)
v <- (n - 3 - p)/(n - 1 - p) * (1 + (4 - r^2)/(n - 1 - p)/2 +
(22 - 6 * r^2 - 3 * r^4)/(n - 1 - p)^2/6)
zalpha <- qnorm(1 - alpha/2)
pnorm((delta - zalpha)/sqrt(v)) + pnorm((-delta - zalpha)/sqrt(v))
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(4 + p + 1e-10,
1e+07))$root else if (is.null(r)) {
if (tside == 2) {
r <- uniroot(function(r) eval(p.body) - power, c(1e-10, 1 -
1e-10))$root
} else {
r <- uniroot(function(r) eval(p.body) - power, c(-1 + 1e-10,
1 - 1e-10))$root
}
} else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
METHOD <- "Power for correlation"
URL <- "http://psychstat.org/correlation"
structure(list(n = n, r = r, alpha = alpha, power = power, alternative = alternative,
method = METHOD, url = URL), class = "webpower")
}
wp.poisson <- function(n = NULL, exp0 = NULL, exp1 = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater"),
family = c("Bernoulli", "exponential", "lognormal",
"normal", "Poisson", "uniform"),
parameter = NULL, subdivisions=200L,
i.method=c("numerical", "MC"), mc.iter=20000)
{
sig.level <- alpha
if(sum(sapply(list(n, power), is.null)) != 1)
stop("exactly one of n, power, andalpha must be NULL")
if(is.null(exp0) || !is.null(exp0) && !is.numeric(exp0) ||
exp0 <= 0)
stop(sQuote("exp0"), " must be numeric in (0,Infinity)")
if(is.null(exp1) || !is.null(exp1) && !is.numeric(exp1) ||
exp1 <= 0)
stop(sQuote("exp1"), " must be numeric in (0,Infinity)")
if(!is.null(n) && min(n) < 5)
stop("number of observations must be at least 5")
if(is.null(alpha) || !is.null(alpha) & !is.numeric(alpha) ||
any(alpha < 0 | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if(!is.null(power) & !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
p.body <- quote({
s * pnorm(-qnorm(1 - alpha) - sqrt(n)/sqrt(v1) * beta1) +
t * pnorm(-qnorm(1 - alpha) + sqrt(n)/sqrt(v1) *
beta1)
})
if (family == "Bernoulli") {
if (is.null(parameter)) {
B <- 0.5
}
else {
B <- parameter
}
beta1 <- log(exp1)
beta0 <- log(exp0)
a <- (1 - B) * exp(beta0) + B * exp(beta0 + beta1)
b <- B * exp(beta0 + beta1)
c <- B * exp(beta0 + beta1)
v1 <- a/(a * c - b^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "exponential") {
if (is.null(parameter)) {
lambda <- 1
}
else {
lambda <- parameter
}
beta1 <- log(exp1); beta0 <- log(exp0)
if (i.method[1] == "MC"){
x.s=rexp(mc.iter,lambda)
d=mean(exp0*exp(log(exp1)*x.s))
e=mean(x.s*exp0*exp(log(exp1)*x.s))
f=mean(x.s^2*exp0*exp(log(exp1)*x.s))
}else{
d.integ<-function(x,beta0,beta1,lamba){#beta1!=lambda
lambda*exp(beta0)/(beta1-lambda)*exp((beta1-lambda)*x)
}
e.integ<-function(x,beta0,beta1,lambda){
lambda*exp(beta0)/(beta1-lambda)*x*exp((beta1-lambda)*x) -1/(beta1-lambda)*d.integ(x,beta0,beta1,lambda)
}
f.integ<-function(x,beta0,beta1,lambda){
x^2*d.integ(x,beta0,beta1,lambda)-2/(beta1-lambda)*e.integ(x,beta0,beta1,lambda)
}
if(beta1<lambda){
d=d.integ(100/(lambda-beta1),beta0,beta1,lambda)-d.integ(0,beta0,beta1,lambda)
e=e.integ(100/(lambda-beta1),beta0,beta1,lambda)-e.integ(0,beta0,beta1,lambda)
f=f.integ(100/(lambda-beta1), beta0,beta1,lambda)-f.integ(0,beta0,beta1,lambda)
v1=d/(d*f-e^2)}
if(beta1>lambda){
d=d.integ(100/abs(lambda-beta1),beta0,beta1,lambda)-d.integ(0,beta0,beta1,lambda)
e=e.integ(100/abs(lambda-beta1),beta0,beta1,lambda)-e.integ(0,beta0,beta1,lambda)
f=f.integ(100/abs(lambda-beta1), beta0,beta1, lambda)-f.integ(0,beta0,beta1,lambda)
v1=d/(d*f-e^2)
}else{
v1=0.00001#the actual value is 0
}
}
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "lognormal") {
if (is.null(parameter)) {
mu <- 0
sigma <- 1
}
else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the log-normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta1 <- log(exp1)
beta0 <- log(exp0)
if (i.method[1] == "MC"){
x.s=rlnorm(mc.iter,mu,sigma)
d=mean(exp0*exp(log(exp1)*x.s))
e=mean(x.s*exp0*exp(log(exp1)*x.s))
f=mean(x.s^2*exp0*exp(log(exp1)*x.s))
}else{
d <- integrate(function(x) exp(beta0 + beta1 * x) * dlnorm(x, mu, sigma), 0, Inf, subdivisions = subdivisions)$value
e <- integrate(function(x) x * exp(beta0 + beta1 * x) * dlnorm(x, mu, sigma), 0, Inf, subdivisions = subdivisions)$value
f <- integrate(function(x) x^2 * exp(beta0 + beta1 * x) * dlnorm(x, mu, sigma), 0, Inf, subdivisions = subdivisions)$value
}
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "normal") {
if (is.null(parameter)) {
mu <- 0
sigma <- 1
}
else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta1 <- log(exp1)
beta0 <- log(exp0)
d=exp0*exp(beta1^2*sigma^2/2+beta1*mu)
e=exp0*exp(beta1^2*sigma^2/2+beta1*mu)*(mu+beta1*sigma^2)
f=exp0*exp(beta1^2*sigma^2/2+beta1*mu)*((mu+beta1*sigma^2)^2+sigma^2)
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "Poisson") {
if (is.null(parameter)) {
lambda <- 1
}
else {
lambda <- parameter
}
beta1 <- log(exp1)
beta0 <- log(exp0)
d <- sum(sapply(0:1e+05, function(x) exp(beta0 + beta1 *
x) * dpois(x, lambda)))
e <- sum(sapply(0:1e+05, function(x) x * exp(beta0 +
beta1 * x) * dpois(x, lambda)))
f <- sum(sapply(0:1e+05, function(x) x^2 * exp(beta0 +
beta1 * x) * dpois(x, lambda)))
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "uniform") {
if (is.null(parameter)) {
L <- 0
R <- 1
}
else {
if (length(parameter) != 2)
stop("The lower and upper bounds have to be provided as a vector")
L <- parameter[1]
R <- parameter[2]
}
beta1 <- log(exp1)
beta0 <- log(exp0)
d <- integrate(function(x) exp(beta0 + beta1 * x)/(R -
L), L, R, subdivisions = subdivisions)$value
e <- integrate(function(x) x * exp(beta0 + beta1 * x)/(R -
L), L, R, subdivisions = subdivisions)$value
f <- integrate(function(x) x^2 * exp(beta0 + beta1 *
x)/(R - L), L, R, subdivisions = subdivisions)$value
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
METHOD <- "Power for Poisson regression"
URL <- "http://psychstat.org/poisson"
structure(list(n = n, power = power, alpha = sig.level, exp0 = exp0,
exp1 = exp1, beta0 = beta0, beta1 = beta1, alternative = alternative,
family = family, method = METHOD,
url = URL), class = "webpower")
}
wp.sem.chisq <-
function (n = NULL, df = NULL, effect = NULL, power = NULL, alpha = 0.05)
{
if (sum(sapply(list(n, df, power, alpha, effect), is.null)) != 1)
stop("exactly one of sample size, degrees of freedom, effect size, alpha and power must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
ncp<-(n-1)*effect
#ncp<-n*effect
calpha<-qchisq(1-alpha, df)
1-pchisq(calpha, df, ncp)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(10 +
1e-10, 1e+08))$root
else if (is.null(df))
df <- uniroot(function(df) eval(p.body) - power, c(1,
10000))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(effect))
effect <- uniroot(function(effect) eval(p.body) - power, c(0, 1))$root
else stop("internal error")
METHOD <- "Power for SEM (Satorra & Saris, 1985)"
URL <- "http://psychstat.org/semchisq"
structure(list(n = n, df = df, effect = effect, power = power, alpha = alpha, url=URL, method=METHOD),
class = "webpower")
}
wp.sem.rmsea <-
function (n = NULL, df = NULL, rmsea0 = NULL, rmsea1 = NULL, power = NULL, alpha = 0.05, type=c('close','notclose')) {
if (sum(sapply(list(n, df, power, alpha, rmsea0, rmsea1), is.null)) != 1)
stop("exactly one of sample size, degrees of freedom, rmsea0, rmsea1, alpha and power must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
type <- match.arg(type)
htype <- switch(type, close = 1, notclose = 2)
if (htype==1){
p.body <- quote({
ncp0<-(n-1)*df*rmsea0^2
ncp1<-(n-1)*df*rmsea1^2
calpha<-qchisq(1-alpha, df, ncp0)
1-pchisq(calpha, df, ncp1)
})
}else{
p.body <- quote({
ncp0<-(n-1)*df*rmsea0^2
ncp1<-(n-1)*df*rmsea1^2
calpha<-qchisq(alpha, df, ncp0)
pchisq(calpha, df, ncp1)
})
}
if (is.null(power))
power <- eval(p.body)
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+05))$root
else if (is.null(df))
df <- uniroot(function(df) eval(p.body) - power, c(1,
10000))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(rmsea0))
rmsea0 <- uniroot(function(rmsea0) eval(p.body) -
power, c(0, 1))$root
else if (is.null(rmsea1))
rmsea1 <- uniroot(function(rmsea1) eval(p.body) -
power, c(0, 1))$root
else stop("internal error")
METHOD <- "Power for SEM based on RMSEA"
URL <- "http://psychstat.org/rmsea"
structure(list(n = n, df = df, rmsea0 = rmsea0, rmsea1 = rmsea1, power = power, alpha = alpha, method=METHOD, url=URL),
class = "webpower")
}
wp.kanova<-function (n = NULL, ndf = NULL, f = NULL, ng=NULL, alpha = 0.05, power = NULL)
{
if (sum(sapply(list(n, ndf, f, ng, power, alpha), is.null)) !=
1)
stop("exactly one of n, ndf, f, ng, power, alpha must be NULL")
if (!is.null(f) && min(f) < 0)
stop("f must be positive")
if (!is.null(n) && min(n) < 1)
stop("degree of freedom u for numerator must be at least 1")
if (!is.null(ndf) && min(ndf) < 1)
stop("degree of freedom v for denominator must be at least 1")
if (!is.null(ng) && min(ng) < 1)
stop("number of groups must be at least 1")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
lambda <- f^2 * n
ddf <- n - ng
pf(qf(alpha, ndf, ddf, lower = FALSE), ndf, ddf, lambda,
lower = FALSE)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(n)){
n <- uniroot(function(n) eval(p.body) - power, c(1 +
ng, 1e+07))$root
ddf <- n - ng
}
else if (is.null(ndf)){
ndf <- uniroot(function(ndf) eval(p.body) - power, c(1 +
1e-10, 1e+05))$root
ddf <- n -ng
}
else if (is.null(ng)) {
ng <- uniroot(function(ng) eval(p.body) - power, c(1e-07,
1e+07))$root
ddf <- n -ng
}
else if (is.null(f)){
f <- uniroot(function(f) eval(p.body) - power, c(1e-07,
1e+07))$root
ddf <- n -ng
}
else if (is.null(alpha)){
alpha <- uniroot(function(alpha) eval(p.body) -
power, c(1e-10, 1 - 1e-10))$root
ddf <- n -ng
}
else stop("internal error")
METHOD <- "Multiple way ANOVA analysis"
URL <- "http://psychstat.org/kanova"
NOTE <- "Sample size is the total sample size"
structure(list(n = n, ndf = ndf, ddf=ddf, f = f, ng=ng, alpha = alpha,
power = power, method = METHOD, url=URL, note=NOTE), class = "webpower")
}
## ANOVA with binary data
wp.anova.binary<-function(k = NULL, n = NULL, V = NULL, alpha = 0.05, power = NULL){
if (sum(sapply(list(k, n, V, power, alpha), is.null)) != 1)
stop("exactly one of k, n, V, power, and alpha must be NULL")
if (!is.null(V) && min(V) < 0)
stop("V must be positive")
if (!is.null(k) && min(k) < 2)
stop("number of groups must be at least 2")
if (!is.null(n) && min(n) < 2)
stop("number of observations in each group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
chi <- (V)^2*n*(k-1)
df <- k - 1
crit.val <- qchisq(p=1-alpha,df=df,ncp=0)
1-pchisq(crit.val,df=df,ncp=chi)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(k))
k <- uniroot(function(k) eval(p.body) - power, c(2 + 1e-10, 100))$root
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + k + 1e-10, 1e+05))$root
else if (is.null(V))
V <- uniroot(function(V) eval(p.body) - power, c(1e-07, 1e+07))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10, 1 - 1e-10))$root
else stop("internal error")
NOTE <- "n is the total sample size"
METHOD <- "One-way Analogous ANOVA with Binary Data"
URL <- "http://psychstat.org/anovabinary"
structure(list(k = k, n = n, V = V, alpha = alpha, power = power,
note = NOTE, method = METHOD, url=URL), class = "webpower")
}
wp.anova.count<-function(k = NULL, n = NULL, V = NULL, alpha = 0.05, power = NULL){
if (sum(sapply(list(k, n, V, power, alpha), is.null)) != 1)
stop("exactly one of k, n, V, power, and alpha must be NULL")
if (!is.null(V) && min(V) < 0)
stop("V must be positive")
if (!is.null(k) && min(k) < 2)
stop("number of groups must be at least 2")
if (!is.null(n) && min(n) < 2)
stop("number of observations in each group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
chi <- (V)^2*n*(k-1)
df <- k - 1
crit.val <- qchisq(p=1-alpha,df=df,ncp=0)
1-pchisq(crit.val,df=df,ncp=chi)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(k))
k <- uniroot(function(k) eval(p.body) - power, c(2 + 1e-10, 100))$root
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + k + 1e-10, 1e+05))$root
else if (is.null(V))
V <- uniroot(function(V) eval(p.body) - power, c(1e-07, 1e+07))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10, 1 - 1e-10))$root
else stop("internal error")
NOTE <- "n is the total sample size"
METHOD <- "One-way Analogous ANOVA with Count Data"
URL <- "http://psychstat.org/anovacount"
structure(list(k = k, n = n, V = V, alpha = alpha, power = power, note = NOTE, method = METHOD, url=URL), class = "webpower")
}
### Univariate Latent Change Score Models
wp.lcsm<-function(N=100, T=5, R=1000,
betay=0, my0=0, mys=0, varey=1, vary0=1, varys=1, vary0ys=0, alpha=0.05, ...){
#if (sum(N < 2*T)>0) stop("The sample size has to be at least 2 times of the number of occasions")
pop.model <- function(T){
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~", betay, "*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~", vary0ys, "*y0\n", sep="")
model<-paste(model, "y0~~", vary0, "*y0\n", sep="")
model<-paste(model, "ys~~", varys, "*ys\n", sep="")
model<-paste(model, "ys~", mys, "*1\n", sep="")
model<-paste(model, "y0~", my0, "*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~", varey, "*", "Y",i, "\n", sep="")
}
model
}
fit.model <- function(T){
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~start(", betay, ")*y", (i-1)," + betay*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~start(", vary0ys, ")*y0 + vary0ys*y0\n", sep="")
model<-paste(model, "y0~~start(", vary0, ")*y0 + vary0*y0\n", sep="")
model<-paste(model, "ys~~start(", varys, ")*ys + varys*ys\n", sep="")
model<-paste(model, "ys~start(", mys, ")*1 + label('mys')*1\n", sep="")
model<-paste(model, "y0~start(", my0, ")*1 + label('my0')*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~start(", varey, ")*", "Y", i, " + varey*Y",i, "\n", sep="")
}
model
}
sem.est <- function(model, data){
temp.res <- sem(model=model, data=data)
label <- temp.res@ParTable$label
c(temp.res@ParTable$est[label!=""], temp.res@ParTable$se[label!=""])
}
## do it once for a given N and T
fit.once <- function(N, T){
## generate data
pop.model.T <- pop.model(T)
pop.model.T.res <- sem(pop.model.T, do.fit=FALSE)
pop.model.T.cov <- inspect(pop.model.T.res, "cov.ov")
pop.model.T.mean <- inspect(pop.model.T.res, "mean.ov")
ynames <- row.names(pop.model.T.cov)
gen.data <- lapply(1:R, mvrnorm, n=N, mu=pop.model.T.mean, Sigma=pop.model.T.cov)
## conduct the analysis
fit.model.T <- fit.model(T)
fit.res <- lapply(gen.data, sem.est, model=fit.model.T)
## run once to get the model information
model.info.res <- sem(fit.model.T, gen.data[[1]])
label <- model.info.res@ParTable$label
label <- label[label!=""]
label.unique <- !duplicated(label)
label <- label[label.unique]
npar <- length(label)
## get the parameter estimates, sd, se, power, CI of power
all.res <- do.call(rbind, fit.res)
all.res <- all.res[, c(label.unique, label.unique)]
all.res <- na.omit(all.res)
mc.est <- colMeans(all.res[, 1:npar], na.rm=TRUE)
mc.se <- apply(all.res[, (npar+1):(2*npar)], 2, mean, na.rm=TRUE)
mc.sd <- apply(all.res[, 1:npar], 2, sd, na.rm=TRUE)
mc.z.score <- all.res[, 1:npar]/all.res[, (npar+1):(2*npar)]
mc.z.score.check <- abs(mc.z.score) >= qnorm(1-alpha/2)
mc.power <- colMeans(mc.z.score.check, na.rm=TRUE)
pop.par <- unlist(lapply(label, function(x){eval(parse(text=x))}))
mc.output <- cbind(pop.par, mc.est, mc.sd, mc.se, mc.power, N, T)
row.names(mc.output) <- label
label.sort <- sort(label)
mc.output[label.sort, ]
}
if (length(N)>1 | length(T)>1){
all.output <- list()
for (i in N){
for (j in T){
all.output [[paste('N',i,'-T',j, sep="")]]<- fit.once(i,j)
}
}
}else{
all.output <- fit.once(N,T)
}
class(all.output) <- "lcs.power"
all.output
}
plot.lcs.power <- function(x, parameter, ...){
## x is the output from power analysis
power.mat <- do.call('rbind', x)
power.par <- power.mat[rownames(power.mat)==parameter, ]
unique.N <- unique(power.par[ ,6])
unique.T <- unique(power.par[ ,7])
if (length(unique.N)==1 & length(unique.T)==1) stop("Multiple N or T is needed for power plot.")
if (length(unique.N)==1){
## plot the power along T
plot(power.par[, 7], power.par[, 5], type='l', xlab='Number of Occasions', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(power.par[, 7], power.par[, 5])
}
if (length(unique.T)==1){
plot(power.par[, 6], power.par[, 5], type='l', xlab='Sample size', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(power.par[, 6], power.par[, 5])
}
if (length(unique.N)>1 & length(unique.T)>1){
for (N in unique.N){
## plot power with time for a given sample size
temp.power <- power.par[power.par[, 6]==N, ]
plot(temp.power[, 7], temp.power[, 5], type='l', xlab='Number of Occasions', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(temp.power[, 7], temp.power[, 5])
cat ("Press [enter] to continue")
line <- readline()
}
for (T in unique.T){
## plot power with time for a given sample size
temp.power <- power.par[power.par[, 7]==T, ]
plot(temp.power[, 6], temp.power[, 5], type='l', xlab='Sample size', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(temp.power[, 6], temp.power[, 5])
cat ("Press [enter] to continue")
line <- readline()
}
}
}
wp.blcsm<-function(N=100, T=5, R=1000,
betay=0, my0=0, mys=0, varey=1, vary0=1, varys=1, vary0ys=0, alpha=0.05,
betax=0, mx0=0, mxs=0, varex=1, varx0=1, varxs=1, varx0xs=0, varx0y0=0,
varx0ys=0, vary0xs=0, varxsys=0, gammax=0, gammay=0, ...){
pop.model <- function(T){
## for y
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~", betay, "*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~", vary0ys, "*y0\n", sep="")
model<-paste(model, "y0~~", vary0, "*y0\n", sep="")
model<-paste(model, "ys~~", varys, "*ys\n", sep="")
model<-paste(model, "ys~", mys, "*1\n", sep="")
model<-paste(model, "y0~", my0, "*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~", varey, "*", "Y",i, "\n", sep="")
}
## for x
## latent x
## Intercept
model<-paste(model, "x0 =~ 1*x1\n")
## path from x(t-1) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "x",i,"~1*x",(i-1),"\n", sep="")
}
## loading from dx(t) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "dx",i,"=~1*x",i,"\n", sep="")
}
## path from x(t) to dx(t+1) with path betax
for (i in 2:T){
model<-paste(model, "dx",i,"~", betax, "*x", (i-1), "\n", sep="")
}
## latent slope xs factor model
for (i in 2:T){
model<-paste(model, "xs=~1*dx", i, "\n", sep="")
}
## variance for dx constraints to 0
for (i in 2:T){
model<-paste(model, "dx",i,"~~0*dx",i,"\n", sep="")
}
## variance for x constraints to 0
for (i in 1:T){
model<-paste(model, "x",i,"~~0*x",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "xs~~", varx0xs, "*x0\n", sep="")
model<-paste(model, "x0~~", varx0, "*x0\n", sep="")
model<-paste(model, "xs~~", varxs, "*xs\n", sep="")
model<-paste(model, "xs~", mxs, "*1\n", sep="")
model<-paste(model, "x0~", mx0, "*1\n", sep="")
## constrain means of x and dx to be zero
for (i in 1:T){
model<-paste(model, "x",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~0*1\n", sep="")
}
## for observed data part
## x(t) to X(t)
for (i in 1:T){
model<-paste(model, "x",i,"=~1*", "X",i, "\n", sep="")
}
## set means of X to be zero
for (i in 1:T){
model<-paste(model, "X",i, "~0*1\n", sep="")
}
## set the variance for X
for (i in 1:T){
model<-paste(model, "X",i, "~~", varex, "*", "X",i, "\n", sep="")
}
## coupling effects
for (i in 2:T){
model<-paste(model, "dy",i,"~", gammax, "*x",i-1, "\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~", gammay, "*y",i-1, "\n", sep="")
}
model<-paste(model, "x0~~", varx0y0, "*y0\n", sep="")
model<-paste(model, "x0~~", varx0ys, "*ys\n", sep="")
model<-paste(model, "y0~~", vary0xs, "*xs\n", sep="")
model<-paste(model, "xs~~", varxsys, "*ys\n", sep="")
model
}
fit.model <- function(T){
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~start(", betay, ")*y", (i-1)," + betay*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~start(", vary0ys, ")*y0 + vary0ys*y0\n", sep="")
model<-paste(model, "y0~~start(", vary0, ")*y0 + vary0*y0\n", sep="")
model<-paste(model, "ys~~start(", varys, ")*ys + varys*ys\n", sep="")
model<-paste(model, "ys~start(", mys, ")*1 + label('mys')*1\n", sep="")
model<-paste(model, "y0~start(", my0, ")*1 + label('my0')*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~start(", varey, ")*", "Y", i, " + varey*Y",i, "\n", sep="")
}
## latent x
## Intercept
model<-paste(model, "x0 =~ 1*x1\n")
## path from x(t-1) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "x",i,"~1*x",(i-1),"\n", sep="")
}
## loading from dx(t) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "dx",i,"=~1*x",i,"\n", sep="")
}
## path from x(t) to dx(t+1) with path betax
for (i in 2:T){
model<-paste(model, "dx",i,"~start(", betax, ")*x", (i-1)," + betax*x", (i-1), "\n", sep="")
}
## latent slope xs factor model
for (i in 2:T){
model<-paste(model, "xs=~1*dx", i, "\n", sep="")
}
## variance for dx constraints to 0
for (i in 2:T){
model<-paste(model, "dx",i,"~~0*dx",i,"\n", sep="")
}
## variance for x constraints to 0
for (i in 1:T){
model<-paste(model, "x",i,"~~0*x",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "xs~~start(", varx0xs, ")*x0 + varx0xs*x0\n", sep="")
model<-paste(model, "x0~~start(", varx0, ")*x0 + varx0*x0\n", sep="")
model<-paste(model, "xs~~start(", varxs, ")*xs + varxs*xs\n", sep="")
model<-paste(model, "xs~start(", mxs, ")*1 + label('mxs')*1\n", sep="")
model<-paste(model, "x0~start(", mx0, ")*1 + label('mx0')*1\n", sep="")
## constrain means of x and dx to be zero
for (i in 1:T){
model<-paste(model, "x",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~0*1\n", sep="")
}
## for observed data part
## x(t) to X(t)
for (i in 1:T){
model<-paste(model, "x",i,"=~1*", "X",i, "\n", sep="")
}
## set means of X to be zero
for (i in 1:T){
model<-paste(model, "X",i, "~0*1\n", sep="")
}
## set the variance for X
for (i in 1:T){
model<-paste(model, "X",i, "~~start(", varex, ")*", "X", i, " + varex*X",i, "\n", sep="")
}
## coupling effects
for (i in 2:T){
model<-paste(model, "dy",i,"~start(", gammax, ")*x", i-1, " + gammax*x", i-1, "\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~start(", gammay, ")*y", i-1, " + gammay*y", i-1, "\n", sep="")
}
model<-paste(model, "x0~~start(", varx0y0, ")*y0 + varx0y0*y0\n", sep="")
model<-paste(model, "x0~~start(", varx0ys, ")*ys + varx0ys*ys\n", sep="")
model<-paste(model, "y0~~start(", vary0xs, ")*xs + vary0xs*xs\n", sep="")
model<-paste(model, "xs~~start(", varxsys, ")*ys + varxsys*ys\n", sep="")
model
}
sem.est <- function(model, data){
temp.res <- sem(model=model, data=data)
label <- temp.res@ParTable$label
c(temp.res@ParTable$est[label!=""], temp.res@ParTable$se[label!=""])
}
## do it once for a given N and T
fit.once <- function(N, T){
## generate data
pop.model.T <- pop.model(T)
pop.model.T.res <- sem(pop.model.T, do.fit=FALSE)
pop.model.T.cov <- inspect(pop.model.T.res, "cov.ov")
pop.model.T.mean <- inspect(pop.model.T.res, "mean.ov")
ynames <- row.names(pop.model.T.cov)
gen.data <- lapply(1:R, mvrnorm, n=N, mu=pop.model.T.mean, Sigma=pop.model.T.cov)
## conduct the analysis
fit.model.T <- fit.model(T)
fit.res <- lapply(gen.data, sem.est, model=fit.model.T)
## run once to get the model information
model.info.res <- sem(fit.model.T, gen.data[[1]])
label <- model.info.res@ParTable$label
label <- label[label!=""]
label.unique <- !duplicated(label)
label <- label[label.unique]
npar <- length(label)
## get the parameter estimates, sd, se, power, CI of power
all.res <- do.call(rbind, fit.res)
all.res <- all.res[, c(label.unique, label.unique)]
all.res <- na.omit(all.res)
mc.est <- colMeans(all.res[, 1:npar], na.rm=TRUE)
mc.se <- apply(all.res[, (npar+1):(2*npar)], 2, mean, na.rm=TRUE)
mc.sd <- apply(all.res[, 1:npar], 2, sd, na.rm=TRUE)
mc.z.score <- all.res[, 1:npar]/all.res[, (npar+1):(2*npar)]
mc.z.score.check <- abs(mc.z.score) >= qnorm(1-alpha/2)
mc.power <- colMeans(mc.z.score.check, na.rm=TRUE)
pop.par <- unlist(lapply(label, function(x){eval(parse(text=x))}))
mc.output <- cbind(pop.par, mc.est, mc.sd, mc.se, mc.power, N, T)
row.names(mc.output) <- label
label.sort <- sort(label)
mc.output[label.sort, ]
}
if (length(N)>1 | length(T)>1){
all.output <- list()
for (i in N){
for (j in T){
all.output [[paste('N',i,'-T',j, sep="")]]<- fit.once(i,j)
}
}
}else{
all.output <- fit.once(N,T)
}
class(all.output) <- "lcs.power"
all.output
}
summary.power<-function(object, ...) {
# Show some basic about the simulation methods
# main part: parameter estimates
cat("Basic information:\n\n")
if(object$out@Options$test %in% c("satorra.bentler", "yuan.bentler",
"mean.var.adjusted",
"scaled.shifted") &&
length(object$out@Fit@test) > 1L) {
scaled <- TRUE
if(object$out@Options$test == "scaled.shifted")
shifted <- TRUE
else
shifted <- FALSE
} else {
scaled <- FALSE
shifted <- FALSE
}
t0.txt <- sprintf(" %-40s", "Esimation method")
t1.txt <- sprintf(" %10s", object$out@Options$estimator)
t2.txt <- ifelse(scaled,
sprintf(" %10s", "Robust"), "")
cat(t0.txt, t1.txt, t2.txt, "\n", sep="")
t0.txt <- sprintf(" %-40s", "Standard error")
t1.txt <- sprintf(" %10s", object$out@Options$se)
cat(t0.txt, t1.txt, "\n", sep="")
if (!is.null(object$info$bootstrap)){
t0.txt <- sprintf(" %-40s", "Number of requested bootstrap")
t1.txt <- sprintf(" %10i", object$info$bootstrap)
cat(t0.txt, t1.txt, "\n", sep="")
}
t0.txt <- sprintf(" %-40s", "Number of requested replications")
t1.txt <- sprintf(" %10i", object$info$nrep)
cat(t0.txt, t1.txt, "\n", sep="")
t0.txt <- sprintf(" %-40s", "Number of successful replications")
t1.txt <- sprintf(" %10i", nrow(object$results$estimates))
cat(t0.txt, t1.txt, "\n", sep="")
cat("\n")
# local print function
print.estimate <- function(name="ERROR", i=1, z.stat=TRUE) {
# cut name if (still) too long
name <- strtrim(name, width=15L)
txt <- sprintf(" %-15s %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f\n",
name, pop.value[i], est[i], mse[i], sd.est[i], power[i], cvg[i])
cat(txt)
}
est <- apply(object$results$estimates, 2, mean, na.rm=TRUE)
sd.est <- apply(object$results$estimates, 2, sd, na.rm=TRUE)
mse <- apply(object$results$se, 2, mean, na.rm=TRUE)
power <- object$power
pop.value<-object$pop.value
cvg<-object$coverage
object<-object$out
for(g in 1:object@Data@ngroups) {
ov.names <- lavNames(object, "ov")
lv.names <- lavNames(object, "lv")
# group header
if(object@Data@ngroups > 1) {
if(g > 1) cat("\n\n")
cat("Group ", g,
" [", object@Data@group.label[[g]], "]:\n\n", sep="")
}
# estimates header
#txt <- sprintf("%-13s %12s %12s %8s %8s %8s\n", "", "True", "Estimate", "MSE", "SD", "Power")
#cat(txt)
cat(" True Estimate MSE SD Power Coverage\n")
makeNames <- function(NAMES, LABELS) {
multiB <- FALSE
if(any(nchar(NAMES) != nchar(NAMES, "bytes")))
multiB <- TRUE
if(any(nchar(LABELS) != nchar(LABELS, "bytes")))
multiB <- TRUE
# labels?
l.idx <- which(nchar(LABELS) > 0L)
if(length(l.idx) > 0L) {
if(!multiB) {
LABELS <- abbreviate(LABELS, 4)
LABELS[l.idx] <- paste(" (", LABELS[l.idx], ")", sep="")
MAX.L <- max(nchar(LABELS))
NAMES <- abbreviate(NAMES, minlength = (13 - MAX.L),
strict = TRUE)
} else {
# do not abbreviate anything (eg in multi-byte locales)
MAX.L <- 4L
}
NAMES <- sprintf(paste("%-", (13 - MAX.L), "s%", MAX.L, "s",
sep=""), NAMES, LABELS)
} else {
if(!multiB) {
NAMES <- abbreviate(NAMES, minlength = 13, strict = TRUE)
} else {
NAMES <- sprintf(paste("%-", 13, "s", sep=""), NAMES)
}
}
NAMES
}
NAMES <- object@ParTable$rhs
# 1a. indicators ("=~") (we do show dummy indicators)
mm.idx <- which( object@ParTable$op == "=~" &
!object@ParTable$lhs %in% ov.names &
object@ParTable$group == g)
if(length(mm.idx)) {
cat("Latent variables:\n")
lhs.old <- ""
NAMES[mm.idx] <- makeNames( object@ParTable$rhs[mm.idx],
object@ParTable$label[mm.idx])
for(i in mm.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " =~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 1b. formative/composites ("<~")
fm.idx <- which( object@ParTable$op == "<~" &
object@ParTable$group == g)
if(length(fm.idx)) {
cat("Composites:\n")
lhs.old <- ""
NAMES[fm.idx] <- makeNames( object@ParTable$rhs[fm.idx],
object@ParTable$label[fm.idx])
for(i in fm.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " <~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 2. regressions
eqs.idx <- which(object@ParTable$op == "~" & object@ParTable$group == g)
if(length(eqs.idx) > 0) {
cat("Regressions:\n")
lhs.old <- ""
NAMES[eqs.idx] <- makeNames( object@ParTable$rhs[eqs.idx],
object@ParTable$label[eqs.idx])
for(i in eqs.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " ~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 3. covariances
cov.idx <- which(object@ParTable$op == "~~" &
!object@ParTable$exo &
object@ParTable$lhs != object@ParTable$rhs &
object@ParTable$group == g)
if(length(cov.idx) > 0) {
cat("Covariances:\n")
lhs.old <- ""
NAMES[cov.idx] <- makeNames( object@ParTable$rhs[cov.idx],
object@ParTable$label[cov.idx])
for(i in cov.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " ~~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 4. intercepts/means
ord.names <- lavNames(object, "ov.ord")
int.idx <- which(object@ParTable$op == "~1" &
!object@ParTable$lhs %in% ord.names &
!object@ParTable$exo &
object@ParTable$group == g)
if(length(int.idx) > 0) {
cat("Intercepts:\n")
NAMES[int.idx] <- makeNames( object@ParTable$lhs[int.idx],
object@ParTable$label[int.idx])
for(i in int.idx) {
print.estimate(name=NAMES[i], i)
}
cat("\n")
}
# 4b thresholds
th.idx <- which(object@ParTable$op == "|" &
object@ParTable$group == g)
if(length(th.idx) > 0) {
cat("Thresholds:\n")
NAMES[th.idx] <- makeNames( paste(object@ParTable$lhs[th.idx],
"|",
object@ParTable$rhs[th.idx],
sep=""),
object@ParTable$label[th.idx])
for(i in th.idx) {
print.estimate(name=NAMES[i], i)
}
cat("\n")
}
# 5. (residual) variances
var.idx <- which(object@ParTable$op == "~~" &
!object@ParTable$exo &
object@ParTable$lhs == object@ParTable$rhs &
object@ParTable$group == g)
if(length(var.idx) > 0) {
cat("Variances:\n")
NAMES[var.idx] <- makeNames( object@ParTable$rhs[var.idx],
object@ParTable$label[var.idx])
for(i in var.idx) {
if(object@Options$mimic == "lavaan") {
print.estimate(name=NAMES[i], i, z.stat=FALSE)
} else {
print.estimate(name=NAMES[i], i, z.stat=TRUE)
}
}
cat("\n")
}
# 6. latent response scales
delta.idx <- which(object@ParTable$op == "~*~" &
object@ParTable$group == g)
if(length(delta.idx) > 0) {
cat("Scales y*:\n")
NAMES[delta.idx] <- makeNames( object@ParTable$rhs[delta.idx],
object@ParTable$label[delta.idx])
for(i in delta.idx) {
print.estimate(name=NAMES[i], i, z.stat=TRUE)
}
cat("\n")
}
} # ngroups
# 6. variable definitions
def.idx <- which(object@ParTable$op == ":=")
if(length(def.idx) > 0) {
if(object@Data@ngroups > 1) cat("\n")
cat("Indirect/Mediation effects:\n")
NAMES[def.idx] <- makeNames( object@ParTable$lhs[def.idx], "")
for(i in def.idx) {
print.estimate(name=NAMES[i], i)
}
cat("\n")
}
}
wp.popPar<-function(object){
par.value<-object@ParTable$ustart
for (i in 1:length(par.value)){
if (is.na(par.value[i])){
if (object@ParTable$op[i]=="~~"){
par.value[i]<-1
}else{
par.value[i]<-0
}
}
}
names(par.value)<-object@ParTable$label
## for indirect effec defined here
for (i in 1:length(par.value)){
if (object@ParTable$op[i]==":="){
temp<-object@ParTable$rhs[i]
temp<-gsub(' +','',temp)
temp<-gsub('-','+', temp, fixed=TRUE)
temp<-unlist(strsplit(temp, '+', fixed=TRUE))
m<-length(temp)
temp.est<-0
par<-NULL
for (j in 1:m){
temp1<-unlist(strsplit(temp[j], '*', fixed=TRUE))
par<-c(par, temp1)
}
ind.exp<-parse(text=object@ParTable$rhs[i])
par.list<-as.list(par.value[par])
par.value[i]<-eval(ind.exp, par.list)
}
}
par.value
}
wp.mc.sem.basic<-function(model, indirect=NULL, nobs=100, nrep=1000, alpha=.95, skewness=NULL, kurtosis=NULL, ovnames=NULL, se="default", estimator="default", parallel="no", ncore=Sys.getenv('NUMBER_OF_PROCESSORS'), cl=NULL, ...){
if (missing(model)) stop("A model is needed.")
model.indirect<-paste(model, "\n", indirect, "\n")
ngroups <- length(nobs)
## Initial analysis for some model information
newdata<-simulateData(model,sample.nobs=nobs,skewness=0,kurtosis=0, ...)
if (ngroups > 1){
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', ...)
}else{
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, ...)
}
par.value<-wp.popPar(temp.res)
idx <- 1:length( temp.res@ParTable$lhs )
#cnames<-paste(temp.res@ParTable$lhs[idx], temp.res@ParTable$op[idx], temp.res@ParTable$rhs[idx])
ov<-lavNames(temp.res,'ov')
## dealing with skewness and kurtosis
if (length(skewness) > 1){
if (length(skewness)!=length(ovnames)) stop("The number of skewness is not equal to the number observed variables")
index<-match(ov, ovnames)
skewness<-skewness[index]
}
if (length(kurtosis) > 1){
if (length(kurtosis)!=length(ovnames)) stop("The number of kurtosis is not equal to the number observed variables")
index<-match(ov, ovnames)
kurtosis<-kurtosis[index]
}
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
cnames<-paste(temp.res@ParTable$lhs[idx], temp.res@ParTable$op[idx], temp.res@ParTable$rhs[idx])
out<-temp.res
runonce<-function(i){
## Step 1: generate data
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
## Step 2: fit the model
if (ngroups > 1){
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', warn=FALSE, ...))
}else{
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, warn=FALSE, ...))
}
## Step 3: Check significance
if (!inherits(temp.res, "try-error")){
idx <- 1:length( temp.res@ParTable$lhs )
temp.est<-temp.res@Fit@est[idx]
temp.se<-temp.res@Fit@se[idx]
temp.sig<-temp.est/temp.se
crit<-qnorm(1-(1-alpha)/2)
temp.sig.ind<-abs(temp.sig)>crit
temp.sig.ind[!is.finite(temp.sig)]<-NA
## Step 4: Check the coverage
ci.u<-temp.est+crit*temp.se
ci.l<-temp.est-crit*temp.se
temp.cvg<- (ci.u>par.value[idx]) & (ci.l<par.value[idx])
}else{
nna<-length(idx)
temp.est<-rep(NA, nna)
temp.sig.ind<-rep(NA, nna)
temp.se<-rep(NA, nna)
temp.cvg<-rep(NA, nna)
}
return(list(temp.sig.ind=temp.sig.ind, temp.est=temp.est, temp.se=temp.se, temp.cvg=temp.cvg))
}
## run parallel or not
# this is from the boot function in package boot
old_options <- options(); options(warn = -1)
have_mc <- have_snow <- FALSE
ncore <- ncore
if (parallel != "no" && ncore > 1L) {
if (parallel == "multicore") have_mc <- .Platform$OS.type != "windows"
else if (parallel == "snow") have_snow <- TRUE
if (!have_mc && !have_snow) ncore <- 1L
}
RR <- nrep
res <- if (ncore > 1L && (have_mc || have_snow)) {
if (have_mc) {
parallel::mclapply(seq_len(RR), runonce, mc.cores = ncore)
} else if (have_snow) {
list(...) # evaluate any promises
if (is.null(cl)) {
cl <- parallel::makePSOCKcluster(rep("localhost", ncore))
if(RNGkind()[1L] == "L'Ecuyer-CMRG")
parallel::clusterSetRNGStream(cl)
res <- parallel::parLapply(cl, seq_len(RR), runonce)
parallel::stopCluster(cl)
res
} else parallel::parLapply(cl, seq_len(RR), runonce)
}
} else lapply(seq_len(RR), runonce)
all.sig<-do.call(rbind, lapply(res, "[[", 'temp.sig.ind'))
all.par<-do.call(rbind, lapply(res, "[[", 'temp.est'))
all.se<-do.call(rbind, lapply(res, "[[", 'temp.se'))
all.cvg<-do.call(rbind, lapply(res, "[[", 'temp.cvg'))
options(old_options)
colnames(all.sig)<-cnames
power<-apply(all.sig, 2, mean, na.rm=TRUE)
cvg<-apply(all.cvg, 2, mean, na.rm=TRUE)
info<-list(nobs=nobs, nrep=nrep, alpha=alpha, method="Normal", bootstrap=NULL)
print(power)
object<-list(power=power, coverage=cvg, pop.value=par.value, results=list(estimates=all.par, se=all.se, all=res), info=info, out=out, data=newdata)
class(object)<-'power'
return(object)
}
wp.mc.sem.boot<-function(model, indirect=NULL, nobs=100, nrep=1000, nboot=1000, alpha=.95, skewness=NULL, kurtosis=NULL, ovnames=NULL, se="default", estimator="default", parallel="no", ncore=Sys.getenv('NUMBER_OF_PROCESSORS'), cl=NULL, ...){
if (missing(model)) stop("A model is needed.")
## internal function
coef.new<-function(x,...){
lavaan::coef(x, type='user', ...)
}
model.indirect<-paste(model, "\n", indirect, "\n")
ngroups <- length(nobs)
## Initial analysis for some model information
newdata<-simulateData(model,sample.nobs=nobs,skewness=0,kurtosis=0, ...)
if (ngroups > 1){
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', warn=FALSE, ...)
}else{
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, warn=FALSE, ...)
}
par.value<-wp.popPar(temp.res)
idx <- 1:length( temp.res@ParTable$lhs )
#cnames<-paste(temp.res@ParTable$lhs[idx], temp.res@ParTable$op[idx], temp.res@ParTable$rhs[idx])
ov<-lavNames(temp.res,'ov')
ptype<-temp.res@ParTable$op
## dealing with skewness and kurtosis
if (length(skewness) > 1){
if (length(skewness)!=length(ovnames)) stop("The number of skewness is not equal to the number observed variables")
index<-match(ov, ovnames)
skewness<-skewness[index]
}
if (length(kurtosis) > 1){
if (length(kurtosis)!=length(ovnames)) stop("The number of kurtosis is not equal to the number observed variables")
index<-match(ov, ovnames)
kurtosis<-kurtosis[index]
}
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
ci.bc1<-function(x, b, cl=.95){
n<-length(x)
z0<-qnorm(sum(x<b, na.rm=TRUE)/n)
alpha<-(1-cl)/2
alpha<-c(alpha, 1-alpha)
alpha<-sort(alpha)
alpha1<-alpha
alpha<-pnorm(2*z0+qnorm(alpha))
dig <- max(2L, getOption("digits"))
np<-length(alpha)
qs<-quantile(x, alpha, na.rm=TRUE)
names(qs) <- paste(if (np < 100)
formatC(100 * alpha1, format = "fg", width = 1, digits = dig)
else format(100 * alpha1, trim = TRUE, digits = dig),
"%", sep = "")
qs
}
ci.bc<-function(par.boot, par0, cl=.95){
se.boot<-apply(par.boot, 2, sd, na.rm=TRUE)
estimate<-par0
p<-ncol(par.boot)
ci<-NULL
for (i in 1:p){
ci<-rbind(ci, ci.bc1(par.boot[,i], par0[i], cl))
}
cbind(estimate, se.boot, ci)
}
## repeated the following for nrep times
runonce<-function(i){
## Step 1: generate data
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
## Step 2: fit the model
#temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, ...)
if (ngroups > 1){
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', warn=FALSE, ...))
}else{
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, warn=FALSE, ...))
}
## Step 3: Conduct bootstrap analysis
if (!inherits(temp.res, "try-error")){
orig.res<-coef.new(temp.res)
boot.res<-bootstrapLavaan(temp.res, FUN=coef.new, R=nboot, ...)
ci.res<-ci.bc(boot.res, orig.res, cl=alpha)
## Step 4: Check the coverage
temp.cvg<- (ci.res[,4]>=par.value[idx]) & (ci.res[,3]<par.value[idx])
## Step 5: check significance
temp.sig<-NULL
temp.est<-coef.new(temp.res)
temp.se<-ci.res[,2]
for (jj in 1:length(ptype)){
if (ptype[jj]=="~~"){
crit<-qnorm(1-(1-alpha)/2)
ci.temp<-ci.res[jj, 1] + c(-1,1)*ci.res[jj, 2]*crit
temp.sig<-c(temp.sig, (ci.temp[1]>0 | ci.temp[2]<0))
}else{
temp.sig<-c(temp.sig, (ci.res[jj, 3]>0 | ci.res[jj, 4]<0))
}
}
}else{
nna<-length(idx)
temp.est<-rep(NA, nna)
temp.sig<-rep(NA, nna)
temp.se<-rep(NA, nna)
temp.cvg<-rep(NA, nna)
boot.res<-NA
ci.res<-NA
}
return(list(temp.sig=temp.sig, temp.est=temp.est, temp.se=temp.se, temp.cvg=temp.cvg, boot.res=boot.res, ci.res=ci.res))
}
## run parallel or not
# this is from the boot function in package boot
old_options <- options(); options(warn = -1)
have_mc <- have_snow <- FALSE
ncore <- ncore
if (parallel != "no" && ncore > 1L) {
if (parallel == "multicore") have_mc <- .Platform$OS.type != "windows"
else if (parallel == "snow") have_snow <- TRUE
if (!have_mc && !have_snow) ncore <- 1L
}
RR <- nrep
res <- if (ncore > 1L && (have_mc || have_snow)) {
if (have_mc) {
parallel::mclapply(seq_len(RR), runonce, mc.cores = ncore)
} else if (have_snow) {
list(...) # evaluate any promises
if (is.null(cl)) {
cl <- parallel::makePSOCKcluster(rep("localhost", ncore))
if(RNGkind()[1L] == "L'Ecuyer-CMRG")
parallel::clusterSetRNGStream(cl)
res <- parallel::parLapply(cl, seq_len(RR), runonce)
parallel::stopCluster(cl)
res
} else parallel::parLapply(cl, seq_len(RR), runonce)
}
} else lapply(seq_len(RR), runonce)
all.sig<-do.call(rbind, lapply(res, "[[", 'temp.sig'))
all.par<-do.call(rbind, lapply(res, "[[", 'temp.est'))
all.se<-do.call(rbind, lapply(res, "[[", 'temp.se'))
all.cvg<-do.call(rbind, lapply(res, "[[", 'temp.cvg'))
options(old_options)
#colnames(all.sig)<-cnames
power<-apply(all.sig, 2, mean, na.rm=TRUE)
cvg<-apply(all.cvg, 2, mean, na.rm=TRUE)
info<-list(nobs=nobs, nrep=nrep, alpha=alpha, method="Normal", bootstrap=nboot)
## print(power)
object<-list(power=power, coverage=cvg, pop.value=par.value, results=list(estimates=all.par, se=all.se, all=res), info=info, out=temp.res, data=newdata)
class(object)<-'power'
return(object)
}
wp.mc.sem.power.curve<-function(model, indirect=NULL, nobs=100, type='basic', nrep=1000, nboot=1000, alpha=.95, skewness=NULL, kurtosis=NULL, ovnames=NULL, se="default", estimator="default", parallel="no", ncore=Sys.getenv('NUMBER_OF_PROCESSORS'), cl=NULL, ...){
if (missing(model)) stop("A model is needed.")
allpower<-NULL
## check whether nobs is a vector or not
if (is.vector(nobs)){
for (N in nobs){
if (type == 'basic'){
## sobel test based analysis
indpower <- wp.mc.sem.basic(model=model, indirect=indirect, nobs=N, nrep=nrep, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}else{
indpower <- wp.mc.sem.boot(model=model, indirect=indirect, nobs=N, nrep=nrep, nboot=nboot, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}
allpower<-rbind(allpower, indpower$power)
}
}else{
for (k in 1:nrow(nobs)){
N <- nobs[k]
if (type == 'basic'){
## sobel test based analysis
indpower <- wp.mc.sem.basic(model=model, indirect=indirect, nobs=N, nrep=nrep, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}else{
indpower <- wp.mc.sem.boot(model=model, indirect=indirect, nobs=N, nrep=nrep, nboot=nboot, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}
allpower<-rbind(allpower, indpower$power)
}
}
#windows(record=TRUE)
#op <- par(ask=TRUE)
#on.exit(par(op))
pnames <- colnames(allpower)
for (j in 1:ncol(allpower)){
if (sum(is.nan(allpower[,j])) == 0){
if (is.vector(nobs)){
plot(nobs, allpower[, j], ylab=paste('Power of', pnames[j]), xlab='Sample size')
lines(nobs, allpower[, j])
}else{
N<-apply(nobs, 1, sum)
plot(N, allpower[, j], ylab=paste('Power of', pnames[j]), xlab='Sample size')
lines(N, allpower[, j])
}
}
}
invisible(allpower)
}
## This function performs the sample size calculation for a mixed model of repeated measures with AR(1) correlation structure. See Lu, Luo, & Chen (2008) for parameter definitions and other details.
## power.mmrm.ar1 {longpower}
wp.mmrm.ar1 <-
function (N = NULL, rho = NULL, ra = NULL, sigmaa = NULL, rb = NULL,
sigmab = NULL, lambda = 1, times = 1:length(ra), delta = NULL,
alpha = 0.05, power = NULL, alternative = c("two.sided",
"one.sided"))
{
if (sum(sapply(list(N, rho, delta, power, alpha), is.null)) !=
1)
stop("exactly one of 'N', 'rho', 'delta', 'power', and 'alpha' must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop("'alpha' must be numeric in [0, 1]")
alternative <- match.arg(alternative)
if (length(times) != length(ra))
stop("ra and times should be the same length")
phia <- phib <- NULL
n.body <- quote({
J <- length(ra)
phia <- 1/ra[J] - sum(rho^(2 * (times[J] - times[-J])) *
(1/ra[-1] - 1/ra[-J]))
if (!is.null(rb)) {
phib <- 1/rb[J] - sum(rho^(2 * (times[J] - times[-J])) *
(1/rb[-1] - 1/rb[-J]))
} else {
rb <- ra
phib <- phia
}
if (is.null(sigmab)) {
sigma <- sigmaa
} else {
sigma <- mean(c(sigmaa, sigmab))
}
Na <-lambda*N/(1+lambda)
pnorm( delta/sigma*sqrt(Na/((phia + lambda * phib))) + qnorm(ifelse(alternative == "two.sided", alpha/2, alpha)) )
})
if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(n.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(delta))
delta <- uniroot(function(delta) eval(n.body) -
power,
c(1e-10, 1e+05))$root
else if (is.null(N)) uniroot(function(N) eval(n.body) -
power, c(10, 1e+05))$root
else if (is.null(rho))
rho <- uniroot(function(rho) eval(n.body) - power, c(1e-10,
1 - 1e-10))$root
else power <- eval(n.body)
NOTE <- "Based power.mmrm.ar1 in longpower (Lu, Luo, & Chen ,2008)"
METHOD <- "Power for Mixed Model of Repeated Measures"
URL <- "http://psychstat.org/longar"
structure(list(n=N, n1 = lambda*N/(1+lambda), n2 = N/(1+lambda), rho = rho, phi1 = phia, phi2 = phib,
delta = delta, alpha = alpha,
power = power, alternative = alternative, note = NOTE,
method = METHOD, url = URL),
class = "webpower")
}
## This function performs the sample size calculation for a mixed model of repeated measures with general correlation structure. See Lu, Luo, & Chen (2008) for parameter definitions and other details. This function executes Formula (3) on page 4.
## power.mmrm {longpower}
wp.mmrm<-function (N = NULL, Ra = NULL, ra = NULL,
sigmaa = NULL, Rb = NULL, rb = NULL, sigmab = NULL,
lambda = 1, delta = NULL, alpha = 0.05,
power = NULL, alternative = c("two.sided", "one.sided"))
{
if (sum(sapply(list(N, delta, power, alpha), is.null)) !=
1)
stop("exactly one of 'N', 'delta', 'power', and 'alpha' must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop("'alpha' must be numeric in [0, 1]")
alternative <- match.arg(alternative)
n.body <- quote({
Ia <- 0
ra <- c(ra, 0)
for (j in 1:nrow(Ra)) {
Raj <- matrix(0, nrow(Ra), nrow(Ra))
Raj[1:j, 1:j] <- solve(Ra[1:j, 1:j])
Ia <- Ia + (ra[j] - ra[j + 1]) * Raj
}
phia <- solve(Ia)[j, j]
if (is.null(rb)) rb <- ra
if (is.null(Rb)) Rb <- Ra
Ib <- 0
rb <- c(rb, 0)
for (j in 1:nrow(Rb)) {
Rbj <- matrix(0, nrow(Rb), nrow(Rb))
Rbj[1:j, 1:j] <- solve(Rb[1:j, 1:j])
Ib <- Ib + (rb[j] - rb[j + 1]) * Rbj
}
phib <- solve(Ib)[j, j]
if (is.null(sigmab)) {
sigma <- sigmaa
} else {
sigma <- mean(c(sigmaa, sigmab))
}
Na <-lambda*N/(1+lambda)
pnorm( delta/sigma*sqrt(Na/((phia + lambda * phib))) + qnorm(ifelse(alternative == "two.sided", alpha/2, alpha)) )
})
if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(n.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(delta))
delta <- uniroot(function(delta) eval(n.body) -
power,
c(1e-10, 1e+05))$root
else if (is.null(N)) uniroot(function(N) eval(n.body) -
power, c(10, 1e+05))$root
else power <- eval(n.body)
NOTE <- "Based power.mmrm in longpower (Lu, Luo, & Chen ,2008)"
METHOD <- "Power for Mixed Model of Repeated Measures"
URL <- "http://psychstat.org/longmmrm"
structure(list(n=N, n1 = lambda*N/(1+lambda), n2 = N/(1+lambda), delta = delta, alpha = alpha, power = power, alternative = alternative, note = NOTE, method = METHOD, url = URL), class = "webpower")
}
wp.mc.t <- function(n = NULL, R0 = 1e+5, R1=1e+3, mu0 = 0, mu1 = 0, sd = 1,
skewness = 0, kurtosis = 3, alpha = 0.05,
type = c("two.sample", "one.sample", "paired"), alternative = c("two.sided",
"less", "greater")) {
if (sum(sapply(list(n, mu0, R0, R1, mean, sd, skewness, kurtosis, alpha),
is.null)) >= 1)
stop("n, mu0, mean, sd, skewness, kurtosis, and alpha cannot be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha |
alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
type <- match.arg(type)
alternative <- match.arg(alternative)
tsample <- switch(type, one.sample = 1, two.sample = 2, paired = 1)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tsample == 1) {
##### under null hypothesis
moments0 <- c(mean = mu0, variance = sd^2, skewness = skewness,
kurtosis = kurtosis)
data0 <- matrix(rpearson(n * R0, moments = moments0), ncol = n,
nrow = R0)
y_bar0 <- apply(data0, 1, mean)
var0 <- apply(data0, 1, var)
t0 <- (y_bar0 - mu0)/sqrt(var0/n)
##### under alternative hypothesis
momentsa <- c(mean = mu1, variance = sd^2, skewness = skewness,
kurtosis = kurtosis)
dataa <- matrix(rpearson(n * R1, moments = momentsa), ncol = n,
nrow = R1)
y_bara <- apply(dataa, 1, mean)
vara <- apply(dataa, 1, var)
ta <- (y_bara - mu0)/sqrt(vara/n)
} else if (tsample == 2) {
if (length(mu0) == 1)
mu0 <- rep(mu0, 2)
if (length(mu1) == 1)
mu1 <- rep(mu1, 2)
if (length(sd) == 1)
sd <- rep(sd, 2)
if (length(skewness) == 1)
skewness <- rep(skewness, 2)
if (length(kurtosis) == 1)
kurtosis <- rep(kurtosis, 2)
if (length(n) == 1)
n <- rep(n, 2)
##### under null hypothesis
moments01 <- c(mean = mu0[1], variance = sd[1]^2, skewness = skewness[1],
kurtosis = kurtosis[1])
moments02 <- c(mean = mu0[2], variance = sd[2]^2, skewness = skewness[2],
kurtosis = kurtosis[2])
data01 <- matrix(rpearson(n[1] * R0, moments = moments01), ncol = n[1],
nrow = R0)
data02 <- matrix(rpearson(n[2] * R0, moments = moments02), ncol = n[2],
nrow = R0)
y_bar01 <- apply(data01, 1, mean)
var01 <- apply(data01, 1, var)
y_bar02 <- apply(data02, 1, mean)
var02 <- apply(data02, 1, var)
t0 <- (y_bar01 - y_bar02)/sqrt(var01/n[1] + var02/n[2])
##### under alternative hypothesis
momentsa1 <- c(mean = mu1[1], variance = sd[1]^2, skewness = skewness[1],
kurtosis = kurtosis[1])
momentsa2 <- c(mean = mu1[2], variance = sd[2]^2, skewness = skewness[2],
kurtosis = kurtosis[2])
dataa1 <- matrix(rpearson(n[1] * R1, moments = momentsa1), ncol = n[1],
nrow = R1)
dataa2 <- matrix(rpearson(n[2] * R1, moments = momentsa2), ncol = n[2],
nrow = R1)
y_bara1 <- apply(dataa1, 1, mean)
vara1 <- apply(dataa1, 1, var)
y_bara2 <- apply(dataa2, 1, mean)
vara2 <- apply(dataa2, 1, var)
ta <- (y_bara1 - y_bara2)/sqrt(vara1/n[1] + vara2/n[2])
}
if (tside == 2) {
t.cri <- quantile(sort(t0), c(alpha/2, 1 - alpha/2))
power <- mean(ta >= t.cri[2] | ta <= t.cri[1])
}
if (tside == 1) {
t.cri <- quantile(sort(t0), alpha)
power <- mean(ta <= t.cri)
}
if (tside == 3) {
t.cri <- quantile(sort(t0), 1 - alpha)
power <- mean(ta >= t.cri)
}
NOTE <- switch(type, paired = "n is number of *pairs*", two.sample = "n is number in *each* group",
NULL)
METHOD <- paste(switch(type, one.sample = "One-sample", two.sample = "Two-sample",
paired = "Paired"), "t test power calculation")
URL <- "http://psychstat.org/tnonnormal"
if (tsample == 2) {
structure(list(n1 = n[1], n2 = n[2], power = power, mean1 = mu1[1], mean2 = mu1[2], sd1 = sd[1], sd2 = sd[2], skewness1 = skewness[1], skewness2 = skewness[2],
kurtosis1 = kurtosis[1], kurtosis2 = kurtosis[1], alpha = alpha,
alternative = alternative, note = NOTE, method = METHOD, url=URL),
class = "webpower")
} else if (tsample == 1) {
structure(list(n = n, power = power, mu0=mu0, mu1 = mu1, sd = sd, skewness = skewness,
kurtosis = kurtosis, alpha = alpha,
alternative = alternative, note = NOTE, method = METHOD, url=URL), class = "webpower")
}
}
wp.mc.chisq.diff <- function(full.model.pop, full.model, reduced.model, N=100, R=1000, alpha=0.05){
chi.diff <- rep(0, R)
for (i in 1:R){
sim.data <- simulateData(full.model.pop, sample.nobs=N)
full.res <- sem(full.model, data=sim.data)
reduced.res <- sem(reduced.model, data=sim.data)
chi.diff[i] <- reduced.res@Fit@test[[1]]$stat - full.res@Fit@test[[1]]$stat
}
df <- reduced.res@Fit@test[[1]]$df - full.res@Fit@test[[1]]$df
power <- mean(chi.diff > qchisq(1-alpha, df))
list(power=power, df=df, chi.dff=chi.diff)
structure(list(n = N, power = power, df=df, alpha = alpha), class = "webpower")
}
sem.effect.size <- function(full.model.pop, reduced.model){
N <- 1000
full.res<-sem(full.model.pop, do.fit=FALSE)
sigma.F<-fitted.values(full.res)$cov
reduced.res<-sem(reduced.model, sample.cov=sigma.F, sample.nobs=N)
delta <- reduced.res@Fit@test[[1]]$stat/N
df <- reduced.res@Fit@test[[1]]$df
RMSEA <- fitMeasures(reduced.res, "rmsea")
list(delta=delta, df=df, RMSEA=RMSEA)
}
Try the WebPower package in your browser
Any scripts or data that you put into this service are public.
WebPower documentation built on Oct. 14, 2023, 1:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions sem.effect.size wp.mc.chisq.diff wp.mc.t wp.mc.sem.power.curve wp.mc.sem.boot wp.mc.sem.basic wp.popPar summary.power wp.blcsm plot.lcs.power wp.lcsm wp.anova.count wp.anova.binary wp.poisson wp.correlation estMRT3arm estMRT2arm estCRT3arm estCRT2arm wp.mediation wp.logistic wp.mrt3arm wp.mrt2arm wp.crt3arm wp.crt2arm nuniroot wp.effect.MRT3arm wp.effect.MRT2arm wp.effect.CRT3arm wp.effect.CRT2arm wp.rmanova wp.t2 wp.t1 wp.t wp.two.prop.two.n wp.two.prop wp.one.prop wp.prop wp.anova plot.webpower print.webpower
Documented in estCRT2arm estCRT3arm estMRT2arm estMRT3arm nuniroot plot.lcs.power plot.webpower print.webpower sem.effect.size summary.power wp.anova wp.anova.binary wp.anova.count wp.blcsm wp.correlation wp.crt2arm wp.crt3arm wp.effect.CRT2arm wp.effect.CRT3arm wp.effect.MRT2arm wp.effect.MRT3arm wp.lcsm wp.logistic wp.mc.chisq.diff wp.mc.sem.basic wp.mc.sem.boot wp.mc.sem.power.curve wp.mc.t wp.mediation wp.mrt2arm wp.mrt3arm wp.poisson wp.popPar wp.prop wp.rmanova wp.t
print.webpower <- function(x, ...) {
cat(x$method, "\n\n", sep = "")
note <- x$note
url <- x$url
x[c("method", "note", "url", "alternative", "family", "parameter")] <- NULL
x <- do.call(cbind, x)
rownames(x) <- rep(" ", nrow(x))
print(x)
if (!is.null(note))
cat("\nNOTE: ", note, sep = "")
cat("\nURL: ", url, sep = "")
cat("\n")
invisible(x)
}
plot.webpower <- function(x, xvar = NULL, yvar = NULL, xlab = NULL, ylab = NULL,
...) {
wp <- x
wp[c("method", "note", "url", "alternative", "family", "parameter")] <- NULL
wp.matrix <- do.call(cbind, wp)
check <- is.null(xvar) + is.null(yvar)
if (check == 2) {
if (!is.null(xlab))
xlab <- xlab else xlab <- "Sample size"
if (!is.null(ylab))
ylab <- ylab else ylab <- "Power"
plot(wp$n, wp$power, xlab = xlab, ylab = ylab, ...)
lines(wp$n, wp$power, ...)
} else if (check == 1) {
stop("Both x and y need to be specified!")
} else {
if (!is.null(xlab))
xlab <- xlab else xlab <- xvar
if (!is.null(ylab))
ylab <- ylab else ylab <- yvar
plot(wp.matrix[, xvar], wp.matrix[, yvar], xlab = xlab, ylab = ylab,
...)
lines(wp.matrix[, xvar], wp.matrix[, yvar], ...)
}
}
wp.anova <- function(k = NULL, n = NULL, f = NULL, alpha = 0.05, power = NULL,
type = c("overall", "two.sided", "greater", "less")) {
type <- type[1]
if (sum(sapply(list(k, n, f, power, alpha), is.null)) != 1)
stop("exactly one of k, n, f, power, and alpha must be NULL")
if (!is.null(f) && min(f) < 0)
stop("f must be positive")
if (!is.null(k) && min(k) < 2)
stop("number of groups must be at least 2")
if (!is.null(n) && min(n) < 2)
stop("number of observations in each group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (type == "overall")
p.body <- quote({
lambda <- n * f^2
pf(qf(alpha, k - 1, n - k, lower = FALSE), k - 1, n - k, lambda,
lower = FALSE)
})
if (type == "two.sided")
p.body <- quote({
lambda <- n * f^2
pf(qf(alpha, 1, n - k, lower = FALSE), 1, n - k, lambda, lower = FALSE)
})
if (type == "greater")
p.body <- quote({
lambda <- sqrt(n) * f
pt(qt(alpha, n - k, lower = FALSE), n - k, lambda, lower = FALSE)
})
if (type == "less")
p.body <- quote({
lambda <- sqrt(n) * f
pt(qt(alpha, n - k), n - k, lambda)
})
if (is.null(power))
power <- eval(p.body) else if (is.null(k))
k <- uniroot(function(k) eval(p.body) - power, c(2 + 1e-10, 100))$root else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + k + 1e-10,
1e+05))$root else if (is.null(f))
f <- uniroot(function(f) eval(p.body) - power, c(1e-07, 1e+07))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
NOTE <- "n is the total sample size"
if (type == "overall") {
NOTE <- paste(NOTE, " (overall)", sep = "")
} else {
NOTE <- paste(NOTE, " (contrast, ", type, ")", sep = "")
}
METHOD <- "Power for One-way ANOVA"
URL <- "http://psychstat.org/anova"
structure(list(k = k, n = n, f = f, alpha = alpha, power = power, note = NOTE,
method = METHOD, url = URL), class = "webpower")
}
wp.prop <- function(h = NULL, n1 = NULL, n2 = NULL, alpha = 0.05, power = NULL,
type = c("1p", "2p", "2p2n"), alternative = c("two.sided", "less",
"greater")) {
type <- type[1]
if (type == "1p")
return(wp.one.prop(h = h, n = n1, alpha = alpha, power = power,
alternative = alternative))
if (type == "2p")
return(wp.two.prop(h = h, n = n1, alpha = alpha, power = power,
alternative = alternative))
if (type == "2p2n")
return(wp.two.prop.two.n(h = h, n1 = n1, n2 = n2, alpha = alpha,
power = power, alternative = alternative))
}
wp.one.prop <- function(h = NULL, n = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(h, n, power, alpha), is.null)) != 1)
stop("exactly one of h, n, power, and alpha must be NULL")
if (!is.null(n) && min(n) < 1)
stop("number of observations in each group must be at least 1")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(h))
h <- abs(h)
if (tside == 2) {
p.body <- quote({
pnorm(qnorm(alpha/2, lower = FALSE) - h * sqrt(n), lower = FALSE) +
pnorm(qnorm(alpha/2, lower = TRUE) - h * sqrt(n), lower = TRUE)
})
}
if (tside == 3) {
p.body <- quote({
pnorm(qnorm(alpha, lower = FALSE) - h * sqrt(n), lower = FALSE)
})
}
if (tside == 1) {
p.body <- quote({
pnorm(qnorm(alpha, lower = TRUE) - h * sqrt(n), lower = TRUE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(h)) {
if (tside == 2) {
h <- uniroot(function(h) eval(p.body) - power, c(1e-10, 10))$root
}
if (tside == 1) {
h <- uniroot(function(h) eval(p.body) - power, c(-10, 5))$root
}
if (tside == 3) {
h <- uniroot(function(h) eval(p.body) - power, c(-5, 10))$root
}
} else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
METHOD <- "Power for one-sample proportion test"
NOTE <- NULL
URL <- "http://psychstat.org/prop"
structure(list(h = h, n = n, alpha = alpha, power = power, url = URL,
method = METHOD, note = NOTE), class = "webpower")
}
wp.two.prop <- function(h = NULL, n = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(h, n, power, alpha), is.null)) != 1)
stop("exactly one of h, n, power, and alpha must be NULL")
if (!is.null(n) && min(n) < 1)
stop("number of observations in each group must be at least 1")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(h))
h <- abs(h)
if (tside == 3) {
p.body <- quote({
pnorm(qnorm(alpha, lower = FALSE) - h * sqrt(n/2), lower = FALSE)
})
}
if (tside == 2) {
p.body <- quote({
pnorm(qnorm(alpha/2, lower = FALSE) - h * sqrt(n/2), lower = FALSE) +
pnorm(qnorm(alpha/2, lower = TRUE) - h * sqrt(n/2), lower = TRUE)
})
}
if (tside == 1) {
p.body <- quote({
pnorm(qnorm(alpha, lower = TRUE) - h * sqrt(n/2), lower = TRUE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(h)) {
if (tside == 2) {
h <- uniroot(function(h) eval(p.body) - power, c(1e-10, 10))$root
}
if (tside == 1) {
h <- uniroot(function(h) eval(p.body) - power, c(-10, 5))$root
}
if (tside == 3) {
h <- uniroot(function(h) eval(p.body) - power, c(-5, 10))$root
}
} else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
NOTE <- "Sample sizes for EACH group"
URL <- "http://psychstat.org/prop2p"
METHOD <- "Power for two-sample proportion (equal n)"
structure(list(h = h, n = n, alpha = alpha, power = power, url = URL,
method = METHOD, note = NOTE), class = "webpower")
}
wp.two.prop.two.n <- function(h = NULL, n1 = NULL, n2 = NULL, alpha = 0.05,
power = NULL, alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(h, n1, n2, power, alpha), is.null)) != 1)
stop("exactly one of h, n1, n2, power, and alpha must be NULL")
if (!is.null(n1) && min(n1) < 2)
stop("number of observations in the first group must be at least 2")
if (!is.null(n2) && min(n2) < 2)
stop("number of observations in the second group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(h))
h <- abs(h)
if (tside == 3) {
p.body <- quote({
pnorm(qnorm(alpha, lower = FALSE) - h * sqrt((n1 * n2)/(n1 +
n2)), lower = FALSE)
})
}
if (tside == 1) {
p.body <- quote({
pnorm(qnorm(alpha, lower = TRUE) - h * sqrt((n1 * n2)/(n1 +
n2)), lower = TRUE)
})
}
if (tside == 2) {
p.body <- quote({
pnorm(qnorm(alpha/2, lower = FALSE) - h * sqrt((n1 * n2)/(n1 +
n2)), lower = FALSE) + pnorm(qnorm(alpha/2, lower = TRUE) -
h * sqrt((n1 * n2)/(n1 + n2)), lower = TRUE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(h)) {
if (tside == 2) {
h <- uniroot(function(h) eval(p.body) - power, c(1e-10, 10))$root
}
if (tside == 1) {
h <- uniroot(function(h) eval(p.body) - power, c(-10, 5))$root
}
if (tside == 3) {
h <- uniroot(function(h) eval(p.body) - power, c(-5, 10))$root
}
} else if (is.null(n1))
n1 <- uniroot(function(n1) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(n2))
n2 <- uniroot(function(n2) eval(p.body) - power, c(2 + 1e-10, 1e+05))$root else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
NOTE <- "Sample size for each group"
URL <- "http://psychstat.org/prop2p2n"
METHOD <- "Power for two-sample proportion (unequal n)"
structure(list(h = h, n1 = n1, n2 = n2, alpha = alpha, power = power,
url = URL, method = METHOD, note = NOTE), class = "webpower")
}
wp.t <- function(n1 = NULL, n2 = NULL, d = NULL, alpha = 0.05, power = NULL,
type = c("two.sample", "one.sample", "paired", "two.sample.2n"), alternative = c("two.sided",
"less", "greater"), tol = .Machine$double.eps^0.25) {
type <- type[1]
if (type == "two.sample.2n") {
return(wp.t2(n1 = n1, n2 = n2, d = d, alpha = alpha, power = power,
alternative = alternative, tol = tol))
} else {
return(wp.t1(n = n1, d = d, alpha = alpha, power = power, type = type,
alternative = alternative, tol = tol))
}
}
wp.t1 <- function(n = NULL, d = NULL, alpha = 0.05, power = NULL, type = c("two.sample",
"one.sample", "paired"), alternative = c("two.sided", "less", "greater"),
tol = .Machine$double.eps^0.25) {
if (sum(sapply(list(n, d, power, alpha), is.null)) != 1)
stop("exactly one of n, d, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
type <- match.arg(type)
alternative <- match.arg(alternative)
tsample <- switch(type, one.sample = 1, two.sample = 2, paired = 1)
ttside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 1)
if (tside == 2 && !is.null(d))
d <- abs(d)
if (ttside == 1) {
p.body <- quote({
nu <- (n - 1) * tsample
pt(qt(alpha/tside, nu, lower = TRUE), nu, ncp = sqrt(n/tsample) *
d, lower = TRUE)
})
}
if (ttside == 2) {
p.body <- quote({
nu <- (n - 1) * tsample
qu <- qt(alpha/tside, nu, lower = FALSE)
pt(qu, nu, ncp = sqrt(n/tsample) * d, lower = FALSE) + pt(-qu,
nu, ncp = sqrt(n/tsample) * d, lower = TRUE)
})
}
if (ttside == 3) {
p.body <- quote({
nu <- (n - 1) * tsample
pt(qt(alpha/tside, nu, lower = FALSE), nu, ncp = sqrt(n/tsample) *
d, lower = FALSE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10, 1e+07),
tol = tol, extendInt = "upX")$root else if (is.null(d)) {
if (ttside == 2) {
d <- uniroot(function(d) eval(p.body) - power, c(1e-07, 10),
tol = tol, extendInt = "upX")$root
}
if (ttside == 1) {
d <- uniroot(function(d) eval(p.body) - power, c(-10, 5), tol = tol,
extendInt = "upX")$root
}
if (ttside == 3) {
d <- uniroot(function(d) eval(p.body) - power, c(-5, 10), tol = tol,
extendInt = "upX")$root
}
} else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10), tol = tol, extendInt = "upX")$root else stop("internal error", domain = NA)
NOTE <- switch(type, paired = "n is number of *pairs*", two.sample = "n is number in *each* group",
NULL)
METHOD <- paste(switch(type, one.sample = "One-sample", two.sample = "Two-sample",
paired = "Paired"), "t-test")
URL <- "http://psychstat.org/ttest"
structure(list(n = n, d = d, alpha = alpha, power = power, alternative = alternative,
note = NOTE, method = METHOD, url = URL), class = "webpower")
}
wp.t2 <- function(n1 = NULL, n2 = NULL, d = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater"), tol = .Machine$double.eps^0.25) {
if (sum(sapply(list(n1, n2, d, power, alpha), is.null)) != 1)
stop("exactly one of n1, n2, d, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (!is.null(n1) && min(n1) < 2)
stop("number of observations in the first group must be at least 2")
if (!is.null(n2) && min(n2) < 2)
stop("number of observations in the second group must be at least 2")
alternative <- match.arg(alternative)
tsample <- 2
ttside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 1)
if (tside == 2 && !is.null(d))
d <- abs(d)
if (ttside == 1) {
p.body <- quote({
nu <- n1 + n2 - 2
pt(qt(alpha/tside, nu, lower = TRUE), nu, ncp = d * (1/sqrt(1/n1 +
1/n2)), lower = TRUE)
})
}
if (ttside == 2) {
p.body <- quote({
nu <- n1 + n2 - 2
qu <- qt(alpha/tside, nu, lower = FALSE)
pt(qu, nu, ncp = d * (1/sqrt(1/n1 + 1/n2)), lower = FALSE) +
pt(-qu, nu, ncp = d * (1/sqrt(1/n1 + 1/n2)), lower = TRUE)
})
}
if (ttside == 3) {
p.body <- quote({
nu <- n1 + n2 - 2
pt(qt(alpha/tside, nu, lower = FALSE), nu, ncp = d * (1/sqrt(1/n1 +
1/n2)), lower = FALSE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n1))
n1 <- uniroot(function(n1) eval(p.body) - power, c(2 + 1e-10, 1e+07),
tol = tol, extendInt = "upX")$root else if (is.null(n2))
n2 <- uniroot(function(n2) eval(p.body) - power, c(2 + 1e-10, 1e+07),
tol = tol, extendInt = "upX")$root else if (is.null(d)) {
if (ttside == 2) {
d <- uniroot(function(d) eval(p.body) - power, c(1e-07, 10),
tol = tol, extendInt = "upX")$root
}
if (ttside == 1) {
d <- uniroot(function(d) eval(p.body) - power, c(-10, 5), tol = tol,
extendInt = "upX")$root
}
if (ttside == 3) {
d <- uniroot(function(d) eval(p.body) - power, c(-5, 10), tol = tol,
extendInt = "upX")$root
}
} else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10), tol = tol, extendInt = "upX")$root else stop("internal error", domain = NA)
NOTE <- "n1 and n2 are number in *each* group"
METHOD <- "Unbalanced two-sample t-test"
URL <- "http://psychstat.org/ttest2n"
structure(list(n1 = n1, n2 = n2, d = d, alpha = alpha, power = power,
alternative = alternative, note = NOTE, method = METHOD, url = URL),
class = "webpower")
}
## function for repeated measures anova analysis
wp.rmanova <- function(n = NULL, ng = NULL, nm = NULL, f = NULL, nscor = 1,
alpha = 0.05, power = NULL, type = 0) {
if (sum(sapply(list(n, ng, nm, f, nscor, power, alpha), is.null)) !=
1)
stop("exactly one of n, ng, nm, power, and alpha must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 1)
stop("Sample size has to be larger than 1")
if (!is.null(ng) && min(ng) < 1)
stop("Number of groups have to be at least 1")
if (!is.null(nm) && min(nm) < 2)
stop("number of measurements must be at least 1")
if (!is.null(nscor) && !is.numeric(nscor) || any(0 > nscor | nscor >
1))
stop("Nonsphericity correction must be numeric in [0, 1]")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
## function to evaluate
if (type == 0) {
p.body <- quote({
df1 <- ng - 1
df2 <- n - ng
lambda <- f^2 * n * nscor
pf(qf(alpha, df1, df2, lower = FALSE), df1, df2, lambda, lower = FALSE)
})
}
if (type == 1) {
p.body <- quote({
df1 <- (nm - 1) * nscor
df2 <- (n - ng) * df1
lambda <- f^2 * n * nscor
pf(qf(alpha, df1, df2, lower = FALSE), df1, df2, lambda, lower = FALSE)
})
}
if (type == 2) {
p.body <- quote({
df1 <- (ng - 1) * (nm - 1) * nscor
df2 <- (n - ng) * (nm - 1) * nscor
lambda <- f^2 * n * nscor
pf(qf(alpha, df1, df2, lower = FALSE), df1, df2, lambda, lower = FALSE)
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(5 + ng, 1e+07))$root
} else if (is.null(ng)) {
ng <- uniroot(function(ng) eval(p.body) - power, c(1 + 1e-10,
1e+05))$root
} else if (is.null(nm)) {
nm <- uniroot(function(nm) eval(p.body) - power, c(1e-07, 1e+07))$root
} else if (is.null(f)) {
f <- uniroot(function(f) eval(p.body) - power, c(1e-07, 1e+07))$root
} else if (is.null(alpha)) {
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root
} else stop("internal error")
if (type == 0)
NOTE <- "Power analysis for between-effect test"
if (type == 1)
NOTE <- "Power analysis for within-effect test"
if (type == 2)
NOTE <- "Power analysis for interaction-effect test"
URL <- "http://psychstat.org/rmanova"
METHOD <- "Repeated-measures ANOVA analysis"
structure(list(n = n, f = f, ng = ng, nm = nm, nscor = nscor, alpha = alpha,
power = power, note = NOTE, method = METHOD, url = URL), class = "webpower")
}
## Effect size and ICC calculation for CRT with 2 arms based on
## empirical data The data has to be in text format where the first
## column of the data is the ID variable, the second column represents
## cluster, the third column is the outcome variable, and the fourth
## column is the condition variable (0 for control, 1 for condition).
## The first line of the data should be the variable names.
wp.effect.CRT2arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
dat.trt <- dat[dat[, 4] == 1, ]
dat.ctl <- dat[dat[, 4] == 0, ]
mutj <- aggregate(dat.trt[, 3], by = list(dat.trt[, 2]), FUN = mean)
mucj <- aggregate(dat.ctl[, 3], by = list(dat.ctl[, 2]), FUN = mean)
mu_j <- rbind(mutj, mucj)
names(mu_j) <- c(names(dat)[2], "mu")
dat.mu <- merge(dat, mu_j, by = names(dat)[2])
SSW <- sum((dat.mu[, 3] - dat.mu[5])^2)/(n * J - J)
mut <- mean(mutj[, 2])
muc <- mean(mucj[, 2])
SSB <- (sum((mutj[, 2] - mut)^2) + sum((mucj[, 2] - muc)^2))/(J - 2)
f <- (mut - muc)/sqrt(SSB + (1 - 1/n) * SSW)
rho <- (SSB - SSW/n)/(SSB + (1 - 1/n) * SSW)
return(list(f = f, ICC = rho))
}
## Effect size and ICC calculation for CRT with 3 arms based on
## empirical data The data has to be in text format, where the first
## column of the data is the ID variable, the second column represents
## cluster, the third column is the outcome variable, and the fourth
## column is the condition variable (0 for control, 1 for treatment1, 2
## for treatment2). The first line of the data should be the variable
## names.
wp.effect.CRT3arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
dat.ctl <- dat[dat[, 4] == 0, ]
dat.trt1 <- dat[dat[, 4] == 1, ]
dat.trt2 <- dat[dat[, 4] == 2, ]
mut1j <- aggregate(dat.trt1[, 3], by = list(dat.trt1[, 2]), FUN = mean)
mut2j <- aggregate(dat.trt2[, 3], by = list(dat.trt2[, 2]), FUN = mean)
mucj <- aggregate(dat.ctl[, 3], by = list(dat.ctl[, 2]), FUN = mean)
mu_j <- rbind(mut1j, mut2j, mucj)
names(mu_j) <- c(names(dat)[2], "mu")
dat.mu <- merge(dat, mu_j, by = names(dat)[2])
SSW <- sum((dat.mu[, 3] - dat.mu[5])^2)/(n * J - J)
mut1 <- mean(mut1j[, 2])
mut2 <- mean(mut2j[, 2])
muc <- mean(mucj[, 2])
SSB <- (sum((mut1j[, 2] - mut1)^2) + sum((mut2j[, 2] - mut2)^2) + sum((mucj[,
2] - muc)^2))/(J - 3)
tau_hat <- SSB - SSW/n
f1 <- (0.5 * mut1 + 0.5 * mut2 - muc)/sqrt(tau_hat + SSW)
f2 <- (mut1 - mut2)/sqrt(tau_hat + SSW)
f3 <- sqrt((((0.5 * (mut1 + mut2) - muc)^2)/4.5 + ((mut1 - mut2)^2)/6)/(tau_hat +
SSW))
rho <- tau_hat/(tau_hat + SSW)
return(list(f1 = f1, f2 = f2, f3 = f3, ICC = rho))
# f1: effect size of treatment main effect f2: effect size of comparing
# two treatments f3: effect size of omnibus test
}
## Effect size for MRT with 2 arms based on empirical data The data has
## to be in text format where the first column of the data is the ID
## variable, the second column represents cluster, the third column is
## the outcome variable, and the fourth column is the condition variable
## (0 for control, 1 for condition). The first line of the data should
## be the variable names.
wp.effect.MRT2arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
mutcj <- aggregate(dat[, 3], by = list(dat[, 2], dat[, 4]), FUN = mean)
mutj <- mutcj[mutcj[, 2] == 1, ]
mucj <- mutcj[mutcj[, 2] == 0, ]
beta0 <- aggregate(mutcj[, 3], by = list(mutcj[, 1]), FUN = mean)
names(beta0) <- c(names(dat)[2], "beta0")
dat1 <- merge(dat, beta0, by = names(dat)[2]) #merge beta0
mut_c <- merge(mutj, mucj, names(mutj)[1])
mut_c$beta1 <- mut_c[, 3] - mut_c[, 5]
mut_c1 <- mut_c[, c(1, 6)]
names(mut_c1) <- c(names(dat)[2], "beta1")
dat2 <- merge(dat1, mut_c1, by = names(dat)[2]) #merge beta1
mud <- sum(mut_c[, 3] - mut_c[, 5])/J
Xij <- dat[, 4] - 0.5
sg2 <- sum((dat2[, 3] - dat2[, 5] - dat2[, 6] * Xij)^2)/(J * (n - 2))
f <- mud/sqrt(sg2)
return(list(f = f))
}
## Effect size for MRT with 3 arms based on empirical data The data has
## to be in text format, where the first column of the data is the ID
## variable, the second column represents cluster, the third column is
## the outcome variable, and the fourth column is the condition variable
## (0 for control, 1 for treatment1, 2 for treatment2). The first line
## of the data should be the variable names.
wp.effect.MRT3arm <- function(file) {
if (is.character(file)){
dat <- read.table(file, header = TRUE)
}else{
dat <- file
}
J <- length(unique(dat[, 2]))
n <- nrow(dat)/J
mutcj <- aggregate(dat[, 3], by = list(dat[, 2], dat[, 4]), FUN = mean)
mut1j <- mutcj[mutcj[, 2] == 1, ]
names(mut1j)[3] <- "y1"
mut2j <- mutcj[mutcj[, 2] == 2, ]
names(mut2j)[3] <- "y2"
mucj <- mutcj[mutcj[, 2] == 0, ]
names(mucj)[3] <- "y0"
beta0 <- aggregate(mutcj[, 3], by = list(mutcj[, 1]), FUN = mean)
names(beta0) <- c(names(dat)[2], "beta0")
dat1 <- merge(dat, beta0, by = names(dat)[2]) #merge beta0
mut_c1 <- merge(mut1j, mucj, names(mut1j)[1])
mut_c <- merge(mut2j, mut_c1, names(mut2j)[1])
mut_c <- mut_c[, c(1, 3, 5, 7)]
mut_c$beta1 <- (mut_c$y1 + mut_c$y2)/2 - mut_c$y0
mut_c$beta2 <- (mut_c$y1 - mut_c$y2)
names(mut_c)[1] <- names(dat)[2]
dat2 <- merge(dat1, mut_c, by = names(dat)[2]) #merge beta1 and beta2
mud1 <- sum(mut_c$y1 - mut_c$y0)/J
mud2 <- sum(mut_c$y2 - mut_c$y0)/J
X1ij <- rep(0, nrow(dat)) # 0.5 for trt1 and trt2, -1 for ctl
X2ij <- rep(0, nrow(dat)) # 1 for trt1, -1 for trt2, 0 for ctl
X1ij[dat[, 4] == 1] <- 0.5
X1ij[dat[, 4] == 2] <- 0.5
X1ij[dat[, 4] == 0] <- -1
X2ij[dat[, 4] == 1] <- 1
X2ij[dat[, 4] == 2] <- -1
X2ij[dat[, 4] == 0] <- 0
sg2 <- sum((dat2[, 3] - dat2$beta0 - dat2$beta1 * X1ij - dat2$beta2 *
X2ij)^2)/(J * (n - 3))
f1 <- (mud1 + mud2)/2/sqrt(sg2) #effect size of treatment main effect
f2 <- (mud1 - mud2)/sqrt(sg2) #effect size of comparing the two treatments
return(list(f1 = f1, f2 = f2))
}
nuniroot <- function(f, interval, maxlength = 100) {
if (length(interval)!=2) stop("Please provide an interval with two values such as c(0,1).")
x <- seq(min(interval), max(interval), length = maxlength)
f.out <- f(x)
if (min(f.out) * max(f.out) > 0)
stop("The specified parameters do not yield valid results. Please try to supply a different interval, e.g., using interval=c(0,1), for your parameter.") else {
low <- max(f.out[f.out < 0])
high <- min(f.out[f.out > 0])
interval <- c(x[f.out == low][1], x[f.out == high][1])
uniroot(f, interval)
}
}
####################################################### function for cluster randomized trials with 2 arms##
wp.crt2arm <- function(n = NULL, f = NULL, J = NULL, icc = NULL, power = NULL,
alpha = 0.05, alternative = c("two.sided", "one.sided"), interval = NULL) {
alternative <- alternative[1]
if (sum(sapply(list(J, n, f, icc, alpha, power), is.null)) != 1)
stop("exactly one of J, n, f, icc, and alpha,power must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 1)
stop("Sample size has to be larger than 1")
if (!is.null(J) && min(J) < 2)
stop("Number of clusters has to be at least 2")
if (!is.null(icc) && !is.numeric(icc) || any(0 > icc | icc > 1))
stop("Intraclass correlation must be numeric in [0, 1]")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
## function to evaluate two-sided
if (alternative == "two.sided") {
p.body <- quote({
df <- J - 2
lambda <- sqrt(J * f^2/(4 * icc + 4 * (1 - icc)/n))
1 - pt(qt(1 - alpha/2, df), df, lambda) + pt(-qt(1 - alpha/2,
df), df, lambda)
})
} else {
## one-sided
p.body <- quote({
df <- J - 2
lambda <- sqrt(J * f^2/(4 * icc + 4 * (1 - icc)/n))
1 - pt(qt(1 - alpha, J - 2), df, lambda)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(2 + 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1, 1e+06), interval))$root else if (is.null(f))
f <- nuniroot(function(f) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(icc))
icc <- nuniroot(function(icc) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(0, 1), interval))$root else if (is.null(alpha))
alpha <- nuniroot(function(alpha) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1 - 1e-10), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster."
METHOD <- "Cluster randomized trials with 2 arms"
URL <- "http://psychstat.org/crt2arm"
structure(list(J = J, n = n, f = f, icc = icc, power = power, alpha = alpha, note = NOTE, method = METHOD, url = URL), class = "webpower")
}
####################################################### function for cluster randomized trials with 3 arms##
wp.crt3arm <- function(n = NULL, f = NULL, J = NULL, icc = NULL, power = NULL,
alpha = 0.05, alternative = c("two.sided", "one.sided"), type = c("main",
"treatment", "omnibus"), interval = NULL) {
side <- alternative[1]
type <- type[1]
if (sum(sapply(list(J, n, f, icc, alpha, power), is.null)) != 1)
stop("exactly one of J, n, f, icc, and alpha,power must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 1)
stop("Sample size has to be larger than 1")
if (!is.null(J) && min(J) < 3)
stop("Number of clusters has to be at least 3")
if (!is.null(icc) && !is.numeric(icc) || any(0 > icc | icc > 1))
stop("Intraclass correlation must be numeric in [0, 1]")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
## compare the average treatment with control
if (type == "main") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 3
lambda1 <- sqrt(J) * f/sqrt(4.5 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda1) + pt(-t0, df, lambda1)
})
} else {
## one-sided
p.body <- quote({
df <- J - 3
lambda1 <- sqrt(J) * f/sqrt(4.5 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda1)
})
}
}
## compare the two treatments
if (type == "treatment") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 3
lambda2 <- sqrt(J) * f/sqrt(6 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda2) + pt(-t0, df, lambda2)
})
} else {
## one-sided
p.body <- quote({
df <- J - 3
lambda2 <- sqrt(J) * f/sqrt(6 * (icc + (1 - icc)/n))
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda2)
})
}
}
## omnibus test
if (type == "omnibus") {
p.body <- quote({
df1 <- 2
df2 <- J - 3
lambda3 <- J * f^2/(icc + (1 - icc)/n)
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0, df1, df2, lambda3)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(3 + 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(2 + 1e-10, 1e+06), interval))$root else if (is.null(f))
f <- nuniroot(function(f) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(icc))
icc <- nuniroot(function(icc) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(0, 1), interval))$root else if (is.null(alpha))
alpha <- nuniroot(function(alpha) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1 - 1e-10), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster."
METHOD <- "Cluster randomized trials with 3 arms"
URL <- "http://psychstat.org/crt3arm"
structure(list(J = J, n = n, f = f, icc = icc, power = power, alpha = alpha,
note = NOTE, method = METHOD, url = URL), class = "webpower")
}
######################################################### function for multisite randomized trials with 2 arms##
wp.mrt2arm <- function(n = NULL, f = NULL, J = NULL, tau00 = NULL, tau11 = NULL,
sg2 = NULL, power = NULL, alpha = 0.05, alternative = c("two.sided",
"one.sided"), type = c("main", "site", "variance"), interval = NULL) {
type <- type[1]
side <- alternative[1]
if (sum(sapply(list(f, n, J, power), is.null)) != 1 & type == "main")
stop("exactly one of f, J, n and power must be NULL")
if (sum(sapply(list(n, J, power), is.null)) != 1 & type != "main")
stop("exactly one of J, n and power must be NULL")
if (!is.null(f) && min(f) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 2)
stop("Sample size has to be larger than 2")
if (!is.null(J) && min(J) < 2)
stop("Number of sites has to be at least 2")
if (!is.null(tau00) && min(tau00) < 0)
stop("Variance of site means must be positive")
if (!is.null(tau11) && min(tau11) < 0)
stop("Variance of treatment main effects across sites must be positive")
if ((!is.null(sg2) && min(sg2) < 0) || is.null(sg2))
stop("Between-person variation must be a positive number")
if (is.null(alpha) || (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1)))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
if (is.null(tau11) && (type == "main" || type == "variance"))
stop("For this type of test, variance of treatment main effects across sites must be specified")
if (is.null(tau00) && type == "site")
stop("For this type of test, variance of site means must be specified")
## test treatment main effect #no tau00 needed
if (type == "main") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f/sqrt(4/n + tau11/sg2)
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda1) + pt(-t0, df, lambda1)
})
} else {
## one-sided #no tau00 needed
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f/sqrt(4/n + tau11/sg2)
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda1)
})
}
}
## test site variability #no tau11 and f needed
if (type == "site") {
p.body <- quote({
df1 <- J - 1
df2 <- J * (n - 2)
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0/(n * tau00/sg2 + 1), df1, df2)
})
}
## test variance of treatment effects #no tau00 and f needed
if (type == "variance") {
p.body <- quote({
df1 <- J - 1
df2 <- J * (n - 2)
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0/(n * tau11/sg2/4 + 1), df1, df2)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1 + 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(3 - 1e-10, 1e+06), interval))$root else if (is.null(f) & type == 1)
f <- nuniroot(function(f) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster"
METHOD <- "Multisite randomized trials with 2 arms"
URL <- "http://psychstat.org/mrt2arm"
structure(list(J = J, n = n, f = f, tau00 = tau00, tau11 = tau11, sg2 = sg2,
power = power, alpha = alpha, note = NOTE, method = METHOD, url = URL),
class = "webpower")
}
######################################################### function for multisite randomized trials with 3 arms##
wp.mrt3arm <- function(n = NULL, f1 = NULL, f2 = NULL, J = NULL, tau = NULL,
sg2 = NULL, power = NULL, alpha = 0.05, alternative = c("two.sided",
"one.sided"), type = c("main", "treatment", "omnibus"), interval = NULL) {
type <- type[1]
side <- alternative[1]
if (type == "main")
if (sum(sapply(list(f1, n, J, power, alpha), is.null)) != 1)
stop("exactly one of f1, J, n, power and alpha must be NULL")
if (type == "treatment")
if (sum(sapply(list(f2, n, J, power, alpha), is.null)) != 1)
stop("exactly one of f2, J, n, power and alpha must be NULL")
if (type == "omnibus") {
if (sum(sapply(list(n, J, power, alpha), is.null)) != 1)
stop("exactly one of J, n, power and alpha must be NULL")
if (is.null(f1) || is.null(f2))
stop("f1 & f2 must be given")
}
if (!is.null(f1) && min(f1) < 0)
stop("Effect size must be positive")
if (!is.null(f2) && min(f2) < 0)
stop("Effect size must be positive")
if (!is.null(n) && min(n) < 3)
stop("Sample size has to be larger than 3")
if (!is.null(J) && min(J) < 2)
stop("Number of sites has to be at least 2")
if (!is.null(tau) && min(tau) < 0)
stop("Variance of treatment main effects across sites must be positive")
if ((!is.null(sg2) && min(sg2) < 0) || is.null(sg2))
stop("Between-person variation must be a positive number")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop("alpha must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop("Power must be numeric in [0, 1]")
## Test treatment main effect
if (type == "main") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f1/sqrt(4.5/n + 1.5 * tau/sg2)
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda1) + pt(-t0, df, lambda1)
})
} else {
## one-sided
p.body <- quote({
df <- J - 1
lambda1 <- sqrt(J) * f1/sqrt(4.5/n + 1.5 * tau/sg2)
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda1)
})
}
}
## Compare two treatments
if (type == "treatment") {
if (side == "two.sided") {
## two-sided
p.body <- quote({
df <- J - 1
lambda2 <- sqrt(J) * f2/sqrt(6/n + 2 * tau/sg2)
t0 <- qt(1 - alpha/2, df)
1 - pt(t0, df, lambda2) + pt(-t0, df, lambda2)
})
} else {
## one-sided
p.body <- quote({
df <- J - 1
lambda2 <- sqrt(J) * f2/sqrt(6/n + 2 * tau/sg2)
t0 <- qt(1 - alpha, df)
1 - pt(t0, df, lambda2)
})
}
}
## Omnibus test
if (type == "omnibus") {
p.body <- quote({
df1 <- 2
df2 <- 2 * (J - 1)
lambda1 <- sqrt(J) * f1/sqrt(4.5/n + 1.5 * tau/sg2)
lambda2 <- sqrt(J) * f2/sqrt(6/n + 2 * tau/sg2)
lambda3 <- lambda1^2 + lambda2^2
f0 <- qf(1 - alpha, df1, df2)
1 - pf(f0, df1, df2, lambda3)
})
}
####
if (is.null(power))
power <- eval(p.body) else if (is.null(J))
J <- nuniroot(function(J) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(2 - 1e-10, 1000), interval))$root else if (is.null(n))
n <- nuniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(3 - 1e-10, 1e+07), interval))$root else if (is.null(f1) && type != 2)
f1 <- nuniroot(function(f1) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(f2) && type != 1)
f2 <- nuniroot(function(f2) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else stop("internal error")
NOTE <- "n is the number of subjects per cluster"
METHOD <- "Multisite randomized trials with 3 arms"
URL <- "http://psychstat.org/mrt3arm"
structure(list(J = J, n = n, f1 = f1, f2 = f2, tau = tau, sg2 = sg2,
power = power, alpha = alpha, note = NOTE, method = METHOD, url = URL),
class = "webpower")
}
wp.regression <- function (n = NULL, p1 = NULL, p2 = 0,
f2 = NULL, alpha = 0.05, power = NULL,
type=c("regular", "Cohen")){
if (sum(sapply(list(n, f2, power, alpha), is.null)) != 1)
stop("exactly one of n, f2, power, and alpha must be NULL")
if (!is.null(f2) && min(f2) < 0)
stop("f2 must be positive")
if (!is.null(n) && min(n) < 5)
stop("sample size has to be at least 5")
if (!is.null(p1) && min(p1) < 1)
stop("number of predictor in the full model has to be larger than 1")
if (!is.null(p2) && p1 < p2)
stop("number of predictor in the full model has to be larger than that in the reduced model")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha |
alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
u <- p1 - p2
v <- n - p1 - 1
if (type[1]=="Cohen"){
lambda <- f2 * (u + v + 1)
}else{
lambda <- f2 * n
}
pf(qf(alpha, u, v, lower = FALSE), u, v, lambda, lower = FALSE)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(5 +
p1 + 1e-10, 1e+05))$root
else if (is.null(f2))
f2 <- uniroot(function(f2) eval(p.body) - power, c(1e-07,
1e+07))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power,
c(1e-10, 1 - 1e-10))$root
else stop("internal error")
METHOD <- "Power for multiple regression"
URL <- "http://psychstat.org/regression"
structure(list(n = n, p1 = p1, p2 = p2, f2 = f2, alpha = alpha,
power = power, method = METHOD, url = URL), class = "webpower")
}
wp.logistic <- function(n = NULL, p0 = NULL, p1 = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater"), family = c("Bernoulli",
"exponential", "lognormal", "normal", "Poisson", "uniform"), parameter = NULL) {
sig.level <- alpha
if (sum(sapply(list(n, power), is.null)) != 1)
stop("exactly one of n, power, and alpha must be NULL")
if (is.null(p0) || !is.null(p0) && !is.numeric(p0) || any(0 > p0 |
p0 > 1))
stop(sQuote("p0"), " must be numeric in (0,1)")
if (is.null(p1) || !is.null(p1) && !is.numeric(p1) || any(0 > p1 |
p1 > 1))
stop(sQuote("p1"), " must be numeric in (0,1)")
if (!is.null(n) && min(n) < 5)
stop("number of observations must be at least 5")
if (is.null(alpha) || !is.null(alpha) & !is.numeric(alpha) || any(alpha <
0 | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) & !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (!(family %in% c("Bernoulli",
"exponential", "lognormal", "normal", "Poisson", "uniform")))
stop ("family must be one of Bernoulli, exponential, lognormal, normal, Poisson, or uniform")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
p.body <- quote({
s * pnorm(-qnorm(1 - alpha) - sqrt(n)/sqrt(g * v0 + (1 - g) * v1) *
beta1) + t * pnorm(-qnorm(1 - alpha) + sqrt(n)/sqrt(g * v0 +
(1 - g) * v1) * beta1)
})
if (family == "Bernoulli") {
## binomial predictor
if (is.null(parameter)) {
B <- 0.5
} else {
B <- parameter
}
g <- 0
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
beta0 <- log(p0/(1 - p0))
d <- B * p1 * (1 - p1) + (1 - B) * p0 * (1 - p0)
e <- B * p1 * (1 - p1)
f <- B * p1 * (1 - p1)
v1 <- d/(d * f - e^2)
### v0
mu1 <- B * p1 + (1 - B) * p0
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- B * pn * (1 - pn) #11
c <- B * pn * (1 - pn) #01
v0 <- b/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "exponential") {
## Exponential predictor
if (is.null(parameter)) {
lambda <- 1
} else {
lambda <- parameter
}
g <- 0
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dexp(x, lambda), 0, Inf,
subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dexp(x, lambda), 0, Inf,
subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dexp(x, lambda),
0, Inf, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x)) *
dexp(x, lambda), 0, Inf, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- 2 * lambda^(-2) * pn * (1 - pn) #11
c <- lambda^(-1) * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "lognormal") {
g <- 0
if (is.null(parameter)) {
mu <- 0
sigma <- 1
} else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the log-normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dlnorm(x, mu, sigma),
0, Inf, subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dlnorm(x, mu, sigma),
0, Inf, subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dlnorm(x,
mu, sigma), 0, Inf, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x)) *
dlnorm(x, mu, sigma), 0, Inf, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- (exp(sigma * sigma) - 1) * exp(2 * mu + sigma^2) * pn * (1 -
pn) #11
c <- exp(mu + 0.5 * sigma^2) * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "normal") {
g <- 0
if (is.null(parameter)) {
mu <- 0
sigma <- 1
} else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dnorm(x, mu, sigma), -Inf,
Inf, subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1) * dnorm(x, mu, sigma), -Inf,
Inf, subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dnorm(x, mu,
sigma), -Inf, Inf, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x)) *
dnorm(x, mu, sigma), -Inf, Inf, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- sigma^2 * pn * (1 - pn) #11
c <- mu * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "Poisson") {
g <- 0
if (is.null(parameter)) {
lambda <- 1
} else {
lambda <- parameter
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- sum(sapply(0:1e+05, function(x) (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dpois(x, lambda)))
e <- sum(sapply(0:1e+05, function(x) x * (1 - (1 + exp(-beta0 -
beta1 * x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dpois(x,
lambda)))
f <- sum(sapply(0:1e+05, function(x) x^2 * (1 - (1 + exp(-beta0 -
beta1 * x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1) * dpois(x,
lambda)))
v1 <- d/(d * f - e^2)
mu1 <- sum(sapply(0:1e+05, function(x) 1/(1 + exp(-beta0 - beta1 *
x)) * dpois(x, lambda)))
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- lambda * pn * (1 - pn) #11
c <- lambda * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
if (family == "uniform") {
g <- 0
if (is.null(parameter)) {
L <- 0
R <- 1
} else {
if (length(parameter) != 2)
stop("The lower and upper bounds have to be provided as a vector")
L <- parameter[1]
R <- parameter[2]
}
beta0 <- log(p0/(1 - p0))
odds <- p1/(1 - p1)/(p0/(1 - p0))
beta1 <- log(odds) ##beta1 under H_A in the population
d <- integrate(function(x) (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1)/(R - L), L, R, subdivisions = 100L)$value
e <- integrate(function(x) x * (1 - (1 + exp(-beta0 - beta1 * x))^(-1)) *
(1 + exp(-beta0 - beta1 * x))^(-1)/(R - L), L, R, subdivisions = 100L)$value
f <- integrate(function(x) x^2 * (1 - (1 + exp(-beta0 - beta1 *
x))^(-1)) * (1 + exp(-beta0 - beta1 * x))^(-1)/(R - L), L,
R, subdivisions = 100L)$value
v1 <- d/(d * f - e^2)
mu1 <- integrate(function(x) 1/(1 + exp(-beta0 - beta1 * x))/(R -
L), L, R, subdivisions = 100L)$value
i00 <- log(mu1/(1 - mu1))
pn <- 1/(1 + exp(-i00))
a <- pn * (1 - pn) #00
b <- (R - L)^2/12 * pn * (1 - pn) #11
c <- (R + L)/2 * pn * (1 - pn) #01
v0 <- a/(a * b - c^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power))
power <- eval(p.body)
if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + 1e-10,
1e+07))$root
}
METHOD <- "Power for logistic regression"
URL <- "http://psychstat.org/logistic"
structure(list(p0 = p0, p1 = p1, beta0 = beta0, beta1 = beta1, n = n,
alpha = sig.level, power = power, alternative = alternative, family = family,
parameter = parameter, method = METHOD, url = URL), class = "webpower")
}
wp.mediation <- function(n = NULL, power = NULL, a = 0.5, b = 0.5, varx = 1,
vary = 1, varm = 1, alpha = 0.05, interval = NULL) {
if (sum(sapply(list(n, a, b, varx, varm, vary, power, alpha), is.null)) !=
1)
stop("exactly one of n, a, b, varx, varm, vary, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
## power formulae
p.body <- quote({
numer <- sqrt(n) * a * b
denom <- sqrt(a^2 * vary/(varm - a^2 * varx) + b^2 * (varm - a^2 *
varx)/varx)
delta <- numer/denom
alpha2 <- alpha/2
za2 <- qnorm(1 - alpha2)
1 - pnorm(za2 - delta) + pnorm(-za2 - delta)
})
if (is.null(power))
power <- eval(p.body) else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-07, 1e+07), interval))$root else if (is.null(a)) {
astart <- varm/varx
alow <- -sqrt(astart) + 1e-06
aup <- sqrt(astart) - 1e-06
a <- nuniroot(function(a) eval(p.body) - power, c(alow, aup))$root
} else if (is.null(b))
b <- nuniroot(function(b) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(-10, 10), interval))$root else if (is.null(varx))
varx <- nuniroot(function(varx) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1e+07), interval))$root else if (is.null(vary))
vary <- nuniroot(function(vary) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1e+07), interval))$root else if (is.null(varm))
varm <- nuniroot(function(varm) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1e+07), interval))$root else if (is.null(alpha))
alpha <- nuniroot(function(alpha) eval(p.body) - power, ifelse(rep(is.null(interval), 2), c(1e-10, 1 - 1e-10), interval))$root else stop("internal error")
METHOD <- "Power for simple mediation"
URL <- "http://psychstat.org/mediation"
structure(list(n = n, power = power, a = a, b = b, varx = varx, varm = varm,
vary = vary, alpha = alpha, method = METHOD, url = URL), class = "webpower")
}
estCRT2arm <- function(file) {
dat <- read.table(file, header = TRUE)
X <- dat[, 4] - 0.5
newdata <- data.frame(dat, X)
model <- summary(lmer(score ~ X + (1 | cluster), data = newdata))
parest <- model$coefficients
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 2)) * 2
test <- cbind(parest, p.value)
cat("Fixed effects (X: Treatment main effect):\n")
print(test)
}
estCRT3arm <- function(file) {
dat <- read.table(file, header = T)
X1 <- X2 <- rep(0, dim(dat)[1])
X1[dat[, 4] == 1] <- X1[dat[, 4] == 2] <- 1/3
X1[dat[, 4] == 0] <- -2/3
X2[dat[, 4] == 1] <- 1/2
X2[dat[, 4] == 2] <- -1/2
newdata <- data.frame(dat, X1, X2)
model <- summary(lmer(score ~ X1 + X2 + (1 | cluster), data = newdata))
parest <- model$coefficients
rownames(parest)[2] <- "X"
rownames(parest)[3] <- "X1-X2"
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 3)) * 2
test <- cbind(parest, p.value)
# Omnibus test
model1 <- lmer(score ~ X1 + X2 + (1 | cluster), data = newdata, REML = FALSE)
model2 <- lmer(score ~ (1 | cluster), data = newdata, REML = FALSE)
omnibus <- anova(model1, model2)$"Pr(>Chisq)"[2]
cat("Fixed effects (X: Treatment main effect; X1-X2: Comparing two treatments):\n")
print(test)
cat("Omnibust test: p-value = ")
cat(omnibus)
}
estMRT2arm <- function(file) {
dat <- read.table(file, header = TRUE)
X <- dat[, 4] - 0.5
newdata <- data.frame(dat, X)
model <- summary(lmer(score ~ X + (X | cluster), data = newdata))
parest <- model$coefficients
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 1)) * 2
test <- cbind(parest, p.value)
cat("Fixed effects (X: Treatment main effect):\n")
print(test)
}
estMRT3arm <- function(file) {
dat <- read.table(file, header = T)
X1 <- X2 <- rep(0, dim(dat)[1])
X1[dat[, 4] == 1] <- X1[dat[, 4] == 2] <- 1/3
X1[dat[, 4] == 0] <- -2/3
X2[dat[, 4] == 1] <- 1/2
X2[dat[, 4] == 2] <- -1/2
newdata <- data.frame(dat, X1, X2)
model <- summary(lmer(score ~ X1 + X2 + (X1 + X2 | cluster), data = newdata))
parest <- model$coefficients
rownames(parest)[2] <- "X"
rownames(parest)[3] <- "X1-X2"
J <- model$ngrps
p.value <- (1 - pt(abs(parest[, 3]), J - 1)) * 2
test <- cbind(parest, p.value)
# Omnibus test
model1 <- lmer(score ~ X1 + X2 + (X1 + X2 | cluster), data = newdata,
REML = FALSE)
model2 <- lmer(score ~ (X1 + X2 | cluster), data = newdata, REML = FALSE)
omnibus <- anova(model1, model2)$"Pr(>Chisq)"[2]
cat("Fixed effects (X: Treatment main effect; X1-X2: Comparing two treatments):\n")
print(test)
cat("Omnibust test: p-value = ")
cat(omnibus)
}
wp.correlation <- function(n = NULL, r = NULL, power = NULL, p = 0, rho0 = 0,
alpha = 0.05, alternative = c("two.sided", "less", "greater")) {
if (sum(sapply(list(n, r, power, alpha), is.null)) != 1)
stop("exactly one of n, r, power, and alpha must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha >
1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power >
1))
stop(sQuote("power"), " must be numeric in [0, 1]")
if (!is.null(n) && min(n) < 4)
stop("number of observations must be at least 4")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tside == 2 && !is.null(r))
r <- abs(r)
if (tside == 3) {
p.body <- quote({
delta <- sqrt(n - 3 - p) * (log((1 + r)/(1 - r))/2 + r/(n -
1 - p)/2 * (1 + (5 + r^2)/(n - 1 - p)/4 + (11 + 2 * r^2 +
3 * r^4)/(n - 1 - p)^2/8) - log((1 + rho0)/(1 - rho0))/2 -
rho0/(n - 1 - p)/2)
v <- (n - 3 - p)/(n - 1 - p) * (1 + (4 - r^2)/(n - 1 - p)/2 +
(22 - 6 * r^2 - 3 * r^4)/(n - 1 - p)^2/6)
zalpha <- qnorm(1 - alpha)
pnorm((delta - zalpha)/sqrt(v))
})
}
if (tside == 1) {
p.body <- quote({
delta <- sqrt(n - 3 - p) * (log((1 + r)/(1 - r))/2 + r/(n -
1 - p)/2 * (1 + (5 + r^2)/(n - 1 - p)/4 + (11 + 2 * r^2 +
3 * r^4)/(n - 1 - p)^2/8) - log((1 + rho0)/(1 - rho0))/2 -
rho0/(n - 1 - p)/2)
v <- (n - 3 - p)/(n - 1 - p) * (1 + (4 - r^2)/(n - 1 - p)/2 +
(22 - 6 * r^2 - 3 * r^4)/(n - 1 - p)^2/6)
zalpha <- qnorm(1 - alpha)
pnorm((-delta - zalpha)/sqrt(v))
})
}
if (tside == 2) {
p.body <- quote({
delta <- sqrt(n - 3 - p) * (log((1 + r)/(1 - r))/2 + r/(n -
1 - p)/2 * (1 + (5 + r^2)/(n - 1 - p)/4 + (11 + 2 * r^2 +
3 * r^4)/(n - 1 - p)^2/8) - log((1 + rho0)/(1 - rho0))/2 -
rho0/(n - 1 - p)/2)
v <- (n - 3 - p)/(n - 1 - p) * (1 + (4 - r^2)/(n - 1 - p)/2 +
(22 - 6 * r^2 - 3 * r^4)/(n - 1 - p)^2/6)
zalpha <- qnorm(1 - alpha/2)
pnorm((delta - zalpha)/sqrt(v)) + pnorm((-delta - zalpha)/sqrt(v))
})
}
if (is.null(power))
power <- eval(p.body) else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(4 + p + 1e-10,
1e+07))$root else if (is.null(r)) {
if (tside == 2) {
r <- uniroot(function(r) eval(p.body) - power, c(1e-10, 1 -
1e-10))$root
} else {
r <- uniroot(function(r) eval(p.body) - power, c(-1 + 1e-10,
1 - 1e-10))$root
}
} else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10,
1 - 1e-10))$root else stop("internal error")
METHOD <- "Power for correlation"
URL <- "http://psychstat.org/correlation"
structure(list(n = n, r = r, alpha = alpha, power = power, alternative = alternative,
method = METHOD, url = URL), class = "webpower")
}
wp.poisson <- function(n = NULL, exp0 = NULL, exp1 = NULL, alpha = 0.05, power = NULL,
alternative = c("two.sided", "less", "greater"),
family = c("Bernoulli", "exponential", "lognormal",
"normal", "Poisson", "uniform"),
parameter = NULL, subdivisions=200L,
i.method=c("numerical", "MC"), mc.iter=20000)
{
sig.level <- alpha
if(sum(sapply(list(n, power), is.null)) != 1)
stop("exactly one of n, power, andalpha must be NULL")
if(is.null(exp0) || !is.null(exp0) && !is.numeric(exp0) ||
exp0 <= 0)
stop(sQuote("exp0"), " must be numeric in (0,Infinity)")
if(is.null(exp1) || !is.null(exp1) && !is.numeric(exp1) ||
exp1 <= 0)
stop(sQuote("exp1"), " must be numeric in (0,Infinity)")
if(!is.null(n) && min(n) < 5)
stop("number of observations must be at least 5")
if(is.null(alpha) || !is.null(alpha) & !is.numeric(alpha) ||
any(alpha < 0 | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if(!is.null(power) & !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
alternative <- match.arg(alternative)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
p.body <- quote({
s * pnorm(-qnorm(1 - alpha) - sqrt(n)/sqrt(v1) * beta1) +
t * pnorm(-qnorm(1 - alpha) + sqrt(n)/sqrt(v1) *
beta1)
})
if (family == "Bernoulli") {
if (is.null(parameter)) {
B <- 0.5
}
else {
B <- parameter
}
beta1 <- log(exp1)
beta0 <- log(exp0)
a <- (1 - B) * exp(beta0) + B * exp(beta0 + beta1)
b <- B * exp(beta0 + beta1)
c <- B * exp(beta0 + beta1)
v1 <- a/(a * c - b^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "exponential") {
if (is.null(parameter)) {
lambda <- 1
}
else {
lambda <- parameter
}
beta1 <- log(exp1); beta0 <- log(exp0)
if (i.method[1] == "MC"){
x.s=rexp(mc.iter,lambda)
d=mean(exp0*exp(log(exp1)*x.s))
e=mean(x.s*exp0*exp(log(exp1)*x.s))
f=mean(x.s^2*exp0*exp(log(exp1)*x.s))
}else{
d.integ<-function(x,beta0,beta1,lamba){#beta1!=lambda
lambda*exp(beta0)/(beta1-lambda)*exp((beta1-lambda)*x)
}
e.integ<-function(x,beta0,beta1,lambda){
lambda*exp(beta0)/(beta1-lambda)*x*exp((beta1-lambda)*x) -1/(beta1-lambda)*d.integ(x,beta0,beta1,lambda)
}
f.integ<-function(x,beta0,beta1,lambda){
x^2*d.integ(x,beta0,beta1,lambda)-2/(beta1-lambda)*e.integ(x,beta0,beta1,lambda)
}
if(beta1<lambda){
d=d.integ(100/(lambda-beta1),beta0,beta1,lambda)-d.integ(0,beta0,beta1,lambda)
e=e.integ(100/(lambda-beta1),beta0,beta1,lambda)-e.integ(0,beta0,beta1,lambda)
f=f.integ(100/(lambda-beta1), beta0,beta1,lambda)-f.integ(0,beta0,beta1,lambda)
v1=d/(d*f-e^2)}
if(beta1>lambda){
d=d.integ(100/abs(lambda-beta1),beta0,beta1,lambda)-d.integ(0,beta0,beta1,lambda)
e=e.integ(100/abs(lambda-beta1),beta0,beta1,lambda)-e.integ(0,beta0,beta1,lambda)
f=f.integ(100/abs(lambda-beta1), beta0,beta1, lambda)-f.integ(0,beta0,beta1,lambda)
v1=d/(d*f-e^2)
}else{
v1=0.00001#the actual value is 0
}
}
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "lognormal") {
if (is.null(parameter)) {
mu <- 0
sigma <- 1
}
else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the log-normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta1 <- log(exp1)
beta0 <- log(exp0)
if (i.method[1] == "MC"){
x.s=rlnorm(mc.iter,mu,sigma)
d=mean(exp0*exp(log(exp1)*x.s))
e=mean(x.s*exp0*exp(log(exp1)*x.s))
f=mean(x.s^2*exp0*exp(log(exp1)*x.s))
}else{
d <- integrate(function(x) exp(beta0 + beta1 * x) * dlnorm(x, mu, sigma), 0, Inf, subdivisions = subdivisions)$value
e <- integrate(function(x) x * exp(beta0 + beta1 * x) * dlnorm(x, mu, sigma), 0, Inf, subdivisions = subdivisions)$value
f <- integrate(function(x) x^2 * exp(beta0 + beta1 * x) * dlnorm(x, mu, sigma), 0, Inf, subdivisions = subdivisions)$value
}
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "normal") {
if (is.null(parameter)) {
mu <- 0
sigma <- 1
}
else {
if (length(parameter) != 2)
stop("Both mean and standard deviation of the normal distribution have to be provided as a vector.")
mu <- parameter[1]
sigma <- parameter[2]
}
beta1 <- log(exp1)
beta0 <- log(exp0)
d=exp0*exp(beta1^2*sigma^2/2+beta1*mu)
e=exp0*exp(beta1^2*sigma^2/2+beta1*mu)*(mu+beta1*sigma^2)
f=exp0*exp(beta1^2*sigma^2/2+beta1*mu)*((mu+beta1*sigma^2)^2+sigma^2)
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "Poisson") {
if (is.null(parameter)) {
lambda <- 1
}
else {
lambda <- parameter
}
beta1 <- log(exp1)
beta0 <- log(exp0)
d <- sum(sapply(0:1e+05, function(x) exp(beta0 + beta1 *
x) * dpois(x, lambda)))
e <- sum(sapply(0:1e+05, function(x) x * exp(beta0 +
beta1 * x) * dpois(x, lambda)))
f <- sum(sapply(0:1e+05, function(x) x^2 * exp(beta0 +
beta1 * x) * dpois(x, lambda)))
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
if (family == "uniform") {
if (is.null(parameter)) {
L <- 0
R <- 1
}
else {
if (length(parameter) != 2)
stop("The lower and upper bounds have to be provided as a vector")
L <- parameter[1]
R <- parameter[2]
}
beta1 <- log(exp1)
beta0 <- log(exp0)
d <- integrate(function(x) exp(beta0 + beta1 * x)/(R -
L), L, R, subdivisions = subdivisions)$value
e <- integrate(function(x) x * exp(beta0 + beta1 * x)/(R -
L), L, R, subdivisions = subdivisions)$value
f <- integrate(function(x) x^2 * exp(beta0 + beta1 *
x)/(R - L), L, R, subdivisions = subdivisions)$value
v1 <- d/(d * f - e^2)
if (tside == 1) {
s <- 1
t <- 0
alpha <- alpha
}
if (tside == 2) {
s <- 1
t <- 1
alpha <- alpha/2
}
if (tside == 3) {
s <- 0
t <- 1
alpha <- alpha
}
if (is.null(power)) {
power <- eval(p.body)
}
if (is.null(n)) {
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+07))$root
}
}
METHOD <- "Power for Poisson regression"
URL <- "http://psychstat.org/poisson"
structure(list(n = n, power = power, alpha = sig.level, exp0 = exp0,
exp1 = exp1, beta0 = beta0, beta1 = beta1, alternative = alternative,
family = family, method = METHOD,
url = URL), class = "webpower")
}
wp.sem.chisq <-
function (n = NULL, df = NULL, effect = NULL, power = NULL, alpha = 0.05)
{
if (sum(sapply(list(n, df, power, alpha, effect), is.null)) != 1)
stop("exactly one of sample size, degrees of freedom, effect size, alpha and power must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
ncp<-(n-1)*effect
#ncp<-n*effect
calpha<-qchisq(1-alpha, df)
1-pchisq(calpha, df, ncp)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(10 +
1e-10, 1e+08))$root
else if (is.null(df))
df <- uniroot(function(df) eval(p.body) - power, c(1,
10000))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(effect))
effect <- uniroot(function(effect) eval(p.body) - power, c(0, 1))$root
else stop("internal error")
METHOD <- "Power for SEM (Satorra & Saris, 1985)"
URL <- "http://psychstat.org/semchisq"
structure(list(n = n, df = df, effect = effect, power = power, alpha = alpha, url=URL, method=METHOD),
class = "webpower")
}
wp.sem.rmsea <-
function (n = NULL, df = NULL, rmsea0 = NULL, rmsea1 = NULL, power = NULL, alpha = 0.05, type=c('close','notclose')) {
if (sum(sapply(list(n, df, power, alpha, rmsea0, rmsea1), is.null)) != 1)
stop("exactly one of sample size, degrees of freedom, rmsea0, rmsea1, alpha and power must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
type <- match.arg(type)
htype <- switch(type, close = 1, notclose = 2)
if (htype==1){
p.body <- quote({
ncp0<-(n-1)*df*rmsea0^2
ncp1<-(n-1)*df*rmsea1^2
calpha<-qchisq(1-alpha, df, ncp0)
1-pchisq(calpha, df, ncp1)
})
}else{
p.body <- quote({
ncp0<-(n-1)*df*rmsea0^2
ncp1<-(n-1)*df*rmsea1^2
calpha<-qchisq(alpha, df, ncp0)
pchisq(calpha, df, ncp1)
})
}
if (is.null(power))
power <- eval(p.body)
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 +
1e-10, 1e+05))$root
else if (is.null(df))
df <- uniroot(function(df) eval(p.body) - power, c(1,
10000))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(rmsea0))
rmsea0 <- uniroot(function(rmsea0) eval(p.body) -
power, c(0, 1))$root
else if (is.null(rmsea1))
rmsea1 <- uniroot(function(rmsea1) eval(p.body) -
power, c(0, 1))$root
else stop("internal error")
METHOD <- "Power for SEM based on RMSEA"
URL <- "http://psychstat.org/rmsea"
structure(list(n = n, df = df, rmsea0 = rmsea0, rmsea1 = rmsea1, power = power, alpha = alpha, method=METHOD, url=URL),
class = "webpower")
}
wp.kanova<-function (n = NULL, ndf = NULL, f = NULL, ng=NULL, alpha = 0.05, power = NULL)
{
if (sum(sapply(list(n, ndf, f, ng, power, alpha), is.null)) !=
1)
stop("exactly one of n, ndf, f, ng, power, alpha must be NULL")
if (!is.null(f) && min(f) < 0)
stop("f must be positive")
if (!is.null(n) && min(n) < 1)
stop("degree of freedom u for numerator must be at least 1")
if (!is.null(ndf) && min(ndf) < 1)
stop("degree of freedom v for denominator must be at least 1")
if (!is.null(ng) && min(ng) < 1)
stop("number of groups must be at least 1")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power |
power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
lambda <- f^2 * n
ddf <- n - ng
pf(qf(alpha, ndf, ddf, lower = FALSE), ndf, ddf, lambda,
lower = FALSE)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(n)){
n <- uniroot(function(n) eval(p.body) - power, c(1 +
ng, 1e+07))$root
ddf <- n - ng
}
else if (is.null(ndf)){
ndf <- uniroot(function(ndf) eval(p.body) - power, c(1 +
1e-10, 1e+05))$root
ddf <- n -ng
}
else if (is.null(ng)) {
ng <- uniroot(function(ng) eval(p.body) - power, c(1e-07,
1e+07))$root
ddf <- n -ng
}
else if (is.null(f)){
f <- uniroot(function(f) eval(p.body) - power, c(1e-07,
1e+07))$root
ddf <- n -ng
}
else if (is.null(alpha)){
alpha <- uniroot(function(alpha) eval(p.body) -
power, c(1e-10, 1 - 1e-10))$root
ddf <- n -ng
}
else stop("internal error")
METHOD <- "Multiple way ANOVA analysis"
URL <- "http://psychstat.org/kanova"
NOTE <- "Sample size is the total sample size"
structure(list(n = n, ndf = ndf, ddf=ddf, f = f, ng=ng, alpha = alpha,
power = power, method = METHOD, url=URL, note=NOTE), class = "webpower")
}
## ANOVA with binary data
wp.anova.binary<-function(k = NULL, n = NULL, V = NULL, alpha = 0.05, power = NULL){
if (sum(sapply(list(k, n, V, power, alpha), is.null)) != 1)
stop("exactly one of k, n, V, power, and alpha must be NULL")
if (!is.null(V) && min(V) < 0)
stop("V must be positive")
if (!is.null(k) && min(k) < 2)
stop("number of groups must be at least 2")
if (!is.null(n) && min(n) < 2)
stop("number of observations in each group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
chi <- (V)^2*n*(k-1)
df <- k - 1
crit.val <- qchisq(p=1-alpha,df=df,ncp=0)
1-pchisq(crit.val,df=df,ncp=chi)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(k))
k <- uniroot(function(k) eval(p.body) - power, c(2 + 1e-10, 100))$root
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + k + 1e-10, 1e+05))$root
else if (is.null(V))
V <- uniroot(function(V) eval(p.body) - power, c(1e-07, 1e+07))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10, 1 - 1e-10))$root
else stop("internal error")
NOTE <- "n is the total sample size"
METHOD <- "One-way Analogous ANOVA with Binary Data"
URL <- "http://psychstat.org/anovabinary"
structure(list(k = k, n = n, V = V, alpha = alpha, power = power,
note = NOTE, method = METHOD, url=URL), class = "webpower")
}
wp.anova.count<-function(k = NULL, n = NULL, V = NULL, alpha = 0.05, power = NULL){
if (sum(sapply(list(k, n, V, power, alpha), is.null)) != 1)
stop("exactly one of k, n, V, power, and alpha must be NULL")
if (!is.null(V) && min(V) < 0)
stop("V must be positive")
if (!is.null(k) && min(k) < 2)
stop("number of groups must be at least 2")
if (!is.null(n) && min(n) < 2)
stop("number of observations in each group must be at least 2")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha | alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
if (!is.null(power) && !is.numeric(power) || any(0 > power | power > 1))
stop(sQuote("power"), " must be numeric in [0, 1]")
p.body <- quote({
chi <- (V)^2*n*(k-1)
df <- k - 1
crit.val <- qchisq(p=1-alpha,df=df,ncp=0)
1-pchisq(crit.val,df=df,ncp=chi)
})
if (is.null(power))
power <- eval(p.body)
else if (is.null(k))
k <- uniroot(function(k) eval(p.body) - power, c(2 + 1e-10, 100))$root
else if (is.null(n))
n <- uniroot(function(n) eval(p.body) - power, c(2 + k + 1e-10, 1e+05))$root
else if (is.null(V))
V <- uniroot(function(V) eval(p.body) - power, c(1e-07, 1e+07))$root
else if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(p.body) - power, c(1e-10, 1 - 1e-10))$root
else stop("internal error")
NOTE <- "n is the total sample size"
METHOD <- "One-way Analogous ANOVA with Count Data"
URL <- "http://psychstat.org/anovacount"
structure(list(k = k, n = n, V = V, alpha = alpha, power = power, note = NOTE, method = METHOD, url=URL), class = "webpower")
}
### Univariate Latent Change Score Models
wp.lcsm<-function(N=100, T=5, R=1000,
betay=0, my0=0, mys=0, varey=1, vary0=1, varys=1, vary0ys=0, alpha=0.05, ...){
#if (sum(N < 2*T)>0) stop("The sample size has to be at least 2 times of the number of occasions")
pop.model <- function(T){
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~", betay, "*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~", vary0ys, "*y0\n", sep="")
model<-paste(model, "y0~~", vary0, "*y0\n", sep="")
model<-paste(model, "ys~~", varys, "*ys\n", sep="")
model<-paste(model, "ys~", mys, "*1\n", sep="")
model<-paste(model, "y0~", my0, "*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~", varey, "*", "Y",i, "\n", sep="")
}
model
}
fit.model <- function(T){
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~start(", betay, ")*y", (i-1)," + betay*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~start(", vary0ys, ")*y0 + vary0ys*y0\n", sep="")
model<-paste(model, "y0~~start(", vary0, ")*y0 + vary0*y0\n", sep="")
model<-paste(model, "ys~~start(", varys, ")*ys + varys*ys\n", sep="")
model<-paste(model, "ys~start(", mys, ")*1 + label('mys')*1\n", sep="")
model<-paste(model, "y0~start(", my0, ")*1 + label('my0')*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~start(", varey, ")*", "Y", i, " + varey*Y",i, "\n", sep="")
}
model
}
sem.est <- function(model, data){
temp.res <- sem(model=model, data=data)
label <- temp.res@ParTable$label
c(temp.res@ParTable$est[label!=""], temp.res@ParTable$se[label!=""])
}
## do it once for a given N and T
fit.once <- function(N, T){
## generate data
pop.model.T <- pop.model(T)
pop.model.T.res <- sem(pop.model.T, do.fit=FALSE)
pop.model.T.cov <- inspect(pop.model.T.res, "cov.ov")
pop.model.T.mean <- inspect(pop.model.T.res, "mean.ov")
ynames <- row.names(pop.model.T.cov)
gen.data <- lapply(1:R, mvrnorm, n=N, mu=pop.model.T.mean, Sigma=pop.model.T.cov)
## conduct the analysis
fit.model.T <- fit.model(T)
fit.res <- lapply(gen.data, sem.est, model=fit.model.T)
## run once to get the model information
model.info.res <- sem(fit.model.T, gen.data[[1]])
label <- model.info.res@ParTable$label
label <- label[label!=""]
label.unique <- !duplicated(label)
label <- label[label.unique]
npar <- length(label)
## get the parameter estimates, sd, se, power, CI of power
all.res <- do.call(rbind, fit.res)
all.res <- all.res[, c(label.unique, label.unique)]
all.res <- na.omit(all.res)
mc.est <- colMeans(all.res[, 1:npar], na.rm=TRUE)
mc.se <- apply(all.res[, (npar+1):(2*npar)], 2, mean, na.rm=TRUE)
mc.sd <- apply(all.res[, 1:npar], 2, sd, na.rm=TRUE)
mc.z.score <- all.res[, 1:npar]/all.res[, (npar+1):(2*npar)]
mc.z.score.check <- abs(mc.z.score) >= qnorm(1-alpha/2)
mc.power <- colMeans(mc.z.score.check, na.rm=TRUE)
pop.par <- unlist(lapply(label, function(x){eval(parse(text=x))}))
mc.output <- cbind(pop.par, mc.est, mc.sd, mc.se, mc.power, N, T)
row.names(mc.output) <- label
label.sort <- sort(label)
mc.output[label.sort, ]
}
if (length(N)>1 | length(T)>1){
all.output <- list()
for (i in N){
for (j in T){
all.output [[paste('N',i,'-T',j, sep="")]]<- fit.once(i,j)
}
}
}else{
all.output <- fit.once(N,T)
}
class(all.output) <- "lcs.power"
all.output
}
plot.lcs.power <- function(x, parameter, ...){
## x is the output from power analysis
power.mat <- do.call('rbind', x)
power.par <- power.mat[rownames(power.mat)==parameter, ]
unique.N <- unique(power.par[ ,6])
unique.T <- unique(power.par[ ,7])
if (length(unique.N)==1 & length(unique.T)==1) stop("Multiple N or T is needed for power plot.")
if (length(unique.N)==1){
## plot the power along T
plot(power.par[, 7], power.par[, 5], type='l', xlab='Number of Occasions', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(power.par[, 7], power.par[, 5])
}
if (length(unique.T)==1){
plot(power.par[, 6], power.par[, 5], type='l', xlab='Sample size', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(power.par[, 6], power.par[, 5])
}
if (length(unique.N)>1 & length(unique.T)>1){
for (N in unique.N){
## plot power with time for a given sample size
temp.power <- power.par[power.par[, 6]==N, ]
plot(temp.power[, 7], temp.power[, 5], type='l', xlab='Number of Occasions', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(temp.power[, 7], temp.power[, 5])
cat ("Press [enter] to continue")
line <- readline()
}
for (T in unique.T){
## plot power with time for a given sample size
temp.power <- power.par[power.par[, 7]==T, ]
plot(temp.power[, 6], temp.power[, 5], type='l', xlab='Sample size', ylab=paste('Power of ',parameter, sep=""), ylim=c(0,1))
points(temp.power[, 6], temp.power[, 5])
cat ("Press [enter] to continue")
line <- readline()
}
}
}
wp.blcsm<-function(N=100, T=5, R=1000,
betay=0, my0=0, mys=0, varey=1, vary0=1, varys=1, vary0ys=0, alpha=0.05,
betax=0, mx0=0, mxs=0, varex=1, varx0=1, varxs=1, varx0xs=0, varx0y0=0,
varx0ys=0, vary0xs=0, varxsys=0, gammax=0, gammay=0, ...){
pop.model <- function(T){
## for y
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~", betay, "*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~", vary0ys, "*y0\n", sep="")
model<-paste(model, "y0~~", vary0, "*y0\n", sep="")
model<-paste(model, "ys~~", varys, "*ys\n", sep="")
model<-paste(model, "ys~", mys, "*1\n", sep="")
model<-paste(model, "y0~", my0, "*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~", varey, "*", "Y",i, "\n", sep="")
}
## for x
## latent x
## Intercept
model<-paste(model, "x0 =~ 1*x1\n")
## path from x(t-1) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "x",i,"~1*x",(i-1),"\n", sep="")
}
## loading from dx(t) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "dx",i,"=~1*x",i,"\n", sep="")
}
## path from x(t) to dx(t+1) with path betax
for (i in 2:T){
model<-paste(model, "dx",i,"~", betax, "*x", (i-1), "\n", sep="")
}
## latent slope xs factor model
for (i in 2:T){
model<-paste(model, "xs=~1*dx", i, "\n", sep="")
}
## variance for dx constraints to 0
for (i in 2:T){
model<-paste(model, "dx",i,"~~0*dx",i,"\n", sep="")
}
## variance for x constraints to 0
for (i in 1:T){
model<-paste(model, "x",i,"~~0*x",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "xs~~", varx0xs, "*x0\n", sep="")
model<-paste(model, "x0~~", varx0, "*x0\n", sep="")
model<-paste(model, "xs~~", varxs, "*xs\n", sep="")
model<-paste(model, "xs~", mxs, "*1\n", sep="")
model<-paste(model, "x0~", mx0, "*1\n", sep="")
## constrain means of x and dx to be zero
for (i in 1:T){
model<-paste(model, "x",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~0*1\n", sep="")
}
## for observed data part
## x(t) to X(t)
for (i in 1:T){
model<-paste(model, "x",i,"=~1*", "X",i, "\n", sep="")
}
## set means of X to be zero
for (i in 1:T){
model<-paste(model, "X",i, "~0*1\n", sep="")
}
## set the variance for X
for (i in 1:T){
model<-paste(model, "X",i, "~~", varex, "*", "X",i, "\n", sep="")
}
## coupling effects
for (i in 2:T){
model<-paste(model, "dy",i,"~", gammax, "*x",i-1, "\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~", gammay, "*y",i-1, "\n", sep="")
}
model<-paste(model, "x0~~", varx0y0, "*y0\n", sep="")
model<-paste(model, "x0~~", varx0ys, "*ys\n", sep="")
model<-paste(model, "y0~~", vary0xs, "*xs\n", sep="")
model<-paste(model, "xs~~", varxsys, "*ys\n", sep="")
model
}
fit.model <- function(T){
## latent y
## Intercept
model<-"y0 =~ 1*y1\n"
## path from y(t-1) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "y",i,"~1*y",(i-1),"\n", sep="")
}
## loading from dy(t) to y(t) with path 1
for (i in 2:T){
model<-paste(model, "dy",i,"=~1*y",i,"\n", sep="")
}
## path from y(t) to dy(t+1) with path betay
for (i in 2:T){
model<-paste(model, "dy",i,"~start(", betay, ")*y", (i-1)," + betay*y", (i-1), "\n", sep="")
}
## latent slope ys factor model
for (i in 2:T){
model<-paste(model, "ys=~1*dy", i, "\n", sep="")
}
## variance for dy constraints to 0
for (i in 2:T){
model<-paste(model, "dy",i,"~~0*dy",i,"\n", sep="")
}
## variance for y constraints to 0
for (i in 1:T){
model<-paste(model, "y",i,"~~0*y",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "ys~~start(", vary0ys, ")*y0 + vary0ys*y0\n", sep="")
model<-paste(model, "y0~~start(", vary0, ")*y0 + vary0*y0\n", sep="")
model<-paste(model, "ys~~start(", varys, ")*ys + varys*ys\n", sep="")
model<-paste(model, "ys~start(", mys, ")*1 + label('mys')*1\n", sep="")
model<-paste(model, "y0~start(", my0, ")*1 + label('my0')*1\n", sep="")
## constrain means of y and dy to be zero
for (i in 1:T){
model<-paste(model, "y",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dy",i,"~0*1\n", sep="")
}
## for observed data part
## y(t) to Y(t)
for (i in 1:T){
model<-paste(model, "y",i,"=~1*", "Y",i, "\n", sep="")
}
## set means of Y to be zero
for (i in 1:T){
model<-paste(model, "Y",i, "~0*1\n", sep="")
}
## set the variance for Y
for (i in 1:T){
model<-paste(model, "Y",i, "~~start(", varey, ")*", "Y", i, " + varey*Y",i, "\n", sep="")
}
## latent x
## Intercept
model<-paste(model, "x0 =~ 1*x1\n")
## path from x(t-1) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "x",i,"~1*x",(i-1),"\n", sep="")
}
## loading from dx(t) to x(t) with path 1
for (i in 2:T){
model<-paste(model, "dx",i,"=~1*x",i,"\n", sep="")
}
## path from x(t) to dx(t+1) with path betax
for (i in 2:T){
model<-paste(model, "dx",i,"~start(", betax, ")*x", (i-1)," + betax*x", (i-1), "\n", sep="")
}
## latent slope xs factor model
for (i in 2:T){
model<-paste(model, "xs=~1*dx", i, "\n", sep="")
}
## variance for dx constraints to 0
for (i in 2:T){
model<-paste(model, "dx",i,"~~0*dx",i,"\n", sep="")
}
## variance for x constraints to 0
for (i in 1:T){
model<-paste(model, "x",i,"~~0*x",i,"\n", sep="")
}
## variance and covariance for intercept and slope
model<-paste(model, "xs~~start(", varx0xs, ")*x0 + varx0xs*x0\n", sep="")
model<-paste(model, "x0~~start(", varx0, ")*x0 + varx0*x0\n", sep="")
model<-paste(model, "xs~~start(", varxs, ")*xs + varxs*xs\n", sep="")
model<-paste(model, "xs~start(", mxs, ")*1 + label('mxs')*1\n", sep="")
model<-paste(model, "x0~start(", mx0, ")*1 + label('mx0')*1\n", sep="")
## constrain means of x and dx to be zero
for (i in 1:T){
model<-paste(model, "x",i,"~0*1\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~0*1\n", sep="")
}
## for observed data part
## x(t) to X(t)
for (i in 1:T){
model<-paste(model, "x",i,"=~1*", "X",i, "\n", sep="")
}
## set means of X to be zero
for (i in 1:T){
model<-paste(model, "X",i, "~0*1\n", sep="")
}
## set the variance for X
for (i in 1:T){
model<-paste(model, "X",i, "~~start(", varex, ")*", "X", i, " + varex*X",i, "\n", sep="")
}
## coupling effects
for (i in 2:T){
model<-paste(model, "dy",i,"~start(", gammax, ")*x", i-1, " + gammax*x", i-1, "\n", sep="")
}
for (i in 2:T){
model<-paste(model, "dx",i,"~start(", gammay, ")*y", i-1, " + gammay*y", i-1, "\n", sep="")
}
model<-paste(model, "x0~~start(", varx0y0, ")*y0 + varx0y0*y0\n", sep="")
model<-paste(model, "x0~~start(", varx0ys, ")*ys + varx0ys*ys\n", sep="")
model<-paste(model, "y0~~start(", vary0xs, ")*xs + vary0xs*xs\n", sep="")
model<-paste(model, "xs~~start(", varxsys, ")*ys + varxsys*ys\n", sep="")
model
}
sem.est <- function(model, data){
temp.res <- sem(model=model, data=data)
label <- temp.res@ParTable$label
c(temp.res@ParTable$est[label!=""], temp.res@ParTable$se[label!=""])
}
## do it once for a given N and T
fit.once <- function(N, T){
## generate data
pop.model.T <- pop.model(T)
pop.model.T.res <- sem(pop.model.T, do.fit=FALSE)
pop.model.T.cov <- inspect(pop.model.T.res, "cov.ov")
pop.model.T.mean <- inspect(pop.model.T.res, "mean.ov")
ynames <- row.names(pop.model.T.cov)
gen.data <- lapply(1:R, mvrnorm, n=N, mu=pop.model.T.mean, Sigma=pop.model.T.cov)
## conduct the analysis
fit.model.T <- fit.model(T)
fit.res <- lapply(gen.data, sem.est, model=fit.model.T)
## run once to get the model information
model.info.res <- sem(fit.model.T, gen.data[[1]])
label <- model.info.res@ParTable$label
label <- label[label!=""]
label.unique <- !duplicated(label)
label <- label[label.unique]
npar <- length(label)
## get the parameter estimates, sd, se, power, CI of power
all.res <- do.call(rbind, fit.res)
all.res <- all.res[, c(label.unique, label.unique)]
all.res <- na.omit(all.res)
mc.est <- colMeans(all.res[, 1:npar], na.rm=TRUE)
mc.se <- apply(all.res[, (npar+1):(2*npar)], 2, mean, na.rm=TRUE)
mc.sd <- apply(all.res[, 1:npar], 2, sd, na.rm=TRUE)
mc.z.score <- all.res[, 1:npar]/all.res[, (npar+1):(2*npar)]
mc.z.score.check <- abs(mc.z.score) >= qnorm(1-alpha/2)
mc.power <- colMeans(mc.z.score.check, na.rm=TRUE)
pop.par <- unlist(lapply(label, function(x){eval(parse(text=x))}))
mc.output <- cbind(pop.par, mc.est, mc.sd, mc.se, mc.power, N, T)
row.names(mc.output) <- label
label.sort <- sort(label)
mc.output[label.sort, ]
}
if (length(N)>1 | length(T)>1){
all.output <- list()
for (i in N){
for (j in T){
all.output [[paste('N',i,'-T',j, sep="")]]<- fit.once(i,j)
}
}
}else{
all.output <- fit.once(N,T)
}
class(all.output) <- "lcs.power"
all.output
}
summary.power<-function(object, ...) {
# Show some basic about the simulation methods
# main part: parameter estimates
cat("Basic information:\n\n")
if(object$out@Options$test %in% c("satorra.bentler", "yuan.bentler",
"mean.var.adjusted",
"scaled.shifted") &&
length(object$out@Fit@test) > 1L) {
scaled <- TRUE
if(object$out@Options$test == "scaled.shifted")
shifted <- TRUE
else
shifted <- FALSE
} else {
scaled <- FALSE
shifted <- FALSE
}
t0.txt <- sprintf(" %-40s", "Esimation method")
t1.txt <- sprintf(" %10s", object$out@Options$estimator)
t2.txt <- ifelse(scaled,
sprintf(" %10s", "Robust"), "")
cat(t0.txt, t1.txt, t2.txt, "\n", sep="")
t0.txt <- sprintf(" %-40s", "Standard error")
t1.txt <- sprintf(" %10s", object$out@Options$se)
cat(t0.txt, t1.txt, "\n", sep="")
if (!is.null(object$info$bootstrap)){
t0.txt <- sprintf(" %-40s", "Number of requested bootstrap")
t1.txt <- sprintf(" %10i", object$info$bootstrap)
cat(t0.txt, t1.txt, "\n", sep="")
}
t0.txt <- sprintf(" %-40s", "Number of requested replications")
t1.txt <- sprintf(" %10i", object$info$nrep)
cat(t0.txt, t1.txt, "\n", sep="")
t0.txt <- sprintf(" %-40s", "Number of successful replications")
t1.txt <- sprintf(" %10i", nrow(object$results$estimates))
cat(t0.txt, t1.txt, "\n", sep="")
cat("\n")
# local print function
print.estimate <- function(name="ERROR", i=1, z.stat=TRUE) {
# cut name if (still) too long
name <- strtrim(name, width=15L)
txt <- sprintf(" %-15s %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f\n",
name, pop.value[i], est[i], mse[i], sd.est[i], power[i], cvg[i])
cat(txt)
}
est <- apply(object$results$estimates, 2, mean, na.rm=TRUE)
sd.est <- apply(object$results$estimates, 2, sd, na.rm=TRUE)
mse <- apply(object$results$se, 2, mean, na.rm=TRUE)
power <- object$power
pop.value<-object$pop.value
cvg<-object$coverage
object<-object$out
for(g in 1:object@Data@ngroups) {
ov.names <- lavNames(object, "ov")
lv.names <- lavNames(object, "lv")
# group header
if(object@Data@ngroups > 1) {
if(g > 1) cat("\n\n")
cat("Group ", g,
" [", object@Data@group.label[[g]], "]:\n\n", sep="")
}
# estimates header
#txt <- sprintf("%-13s %12s %12s %8s %8s %8s\n", "", "True", "Estimate", "MSE", "SD", "Power")
#cat(txt)
cat(" True Estimate MSE SD Power Coverage\n")
makeNames <- function(NAMES, LABELS) {
multiB <- FALSE
if(any(nchar(NAMES) != nchar(NAMES, "bytes")))
multiB <- TRUE
if(any(nchar(LABELS) != nchar(LABELS, "bytes")))
multiB <- TRUE
# labels?
l.idx <- which(nchar(LABELS) > 0L)
if(length(l.idx) > 0L) {
if(!multiB) {
LABELS <- abbreviate(LABELS, 4)
LABELS[l.idx] <- paste(" (", LABELS[l.idx], ")", sep="")
MAX.L <- max(nchar(LABELS))
NAMES <- abbreviate(NAMES, minlength = (13 - MAX.L),
strict = TRUE)
} else {
# do not abbreviate anything (eg in multi-byte locales)
MAX.L <- 4L
}
NAMES <- sprintf(paste("%-", (13 - MAX.L), "s%", MAX.L, "s",
sep=""), NAMES, LABELS)
} else {
if(!multiB) {
NAMES <- abbreviate(NAMES, minlength = 13, strict = TRUE)
} else {
NAMES <- sprintf(paste("%-", 13, "s", sep=""), NAMES)
}
}
NAMES
}
NAMES <- object@ParTable$rhs
# 1a. indicators ("=~") (we do show dummy indicators)
mm.idx <- which( object@ParTable$op == "=~" &
!object@ParTable$lhs %in% ov.names &
object@ParTable$group == g)
if(length(mm.idx)) {
cat("Latent variables:\n")
lhs.old <- ""
NAMES[mm.idx] <- makeNames( object@ParTable$rhs[mm.idx],
object@ParTable$label[mm.idx])
for(i in mm.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " =~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 1b. formative/composites ("<~")
fm.idx <- which( object@ParTable$op == "<~" &
object@ParTable$group == g)
if(length(fm.idx)) {
cat("Composites:\n")
lhs.old <- ""
NAMES[fm.idx] <- makeNames( object@ParTable$rhs[fm.idx],
object@ParTable$label[fm.idx])
for(i in fm.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " <~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 2. regressions
eqs.idx <- which(object@ParTable$op == "~" & object@ParTable$group == g)
if(length(eqs.idx) > 0) {
cat("Regressions:\n")
lhs.old <- ""
NAMES[eqs.idx] <- makeNames( object@ParTable$rhs[eqs.idx],
object@ParTable$label[eqs.idx])
for(i in eqs.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " ~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 3. covariances
cov.idx <- which(object@ParTable$op == "~~" &
!object@ParTable$exo &
object@ParTable$lhs != object@ParTable$rhs &
object@ParTable$group == g)
if(length(cov.idx) > 0) {
cat("Covariances:\n")
lhs.old <- ""
NAMES[cov.idx] <- makeNames( object@ParTable$rhs[cov.idx],
object@ParTable$label[cov.idx])
for(i in cov.idx) {
lhs <- object@ParTable$lhs[i]
if(lhs != lhs.old) cat(" ", lhs, " ~~\n", sep="")
print.estimate(name=NAMES[i], i)
lhs.old <- lhs
}
cat("\n")
}
# 4. intercepts/means
ord.names <- lavNames(object, "ov.ord")
int.idx <- which(object@ParTable$op == "~1" &
!object@ParTable$lhs %in% ord.names &
!object@ParTable$exo &
object@ParTable$group == g)
if(length(int.idx) > 0) {
cat("Intercepts:\n")
NAMES[int.idx] <- makeNames( object@ParTable$lhs[int.idx],
object@ParTable$label[int.idx])
for(i in int.idx) {
print.estimate(name=NAMES[i], i)
}
cat("\n")
}
# 4b thresholds
th.idx <- which(object@ParTable$op == "|" &
object@ParTable$group == g)
if(length(th.idx) > 0) {
cat("Thresholds:\n")
NAMES[th.idx] <- makeNames( paste(object@ParTable$lhs[th.idx],
"|",
object@ParTable$rhs[th.idx],
sep=""),
object@ParTable$label[th.idx])
for(i in th.idx) {
print.estimate(name=NAMES[i], i)
}
cat("\n")
}
# 5. (residual) variances
var.idx <- which(object@ParTable$op == "~~" &
!object@ParTable$exo &
object@ParTable$lhs == object@ParTable$rhs &
object@ParTable$group == g)
if(length(var.idx) > 0) {
cat("Variances:\n")
NAMES[var.idx] <- makeNames( object@ParTable$rhs[var.idx],
object@ParTable$label[var.idx])
for(i in var.idx) {
if(object@Options$mimic == "lavaan") {
print.estimate(name=NAMES[i], i, z.stat=FALSE)
} else {
print.estimate(name=NAMES[i], i, z.stat=TRUE)
}
}
cat("\n")
}
# 6. latent response scales
delta.idx <- which(object@ParTable$op == "~*~" &
object@ParTable$group == g)
if(length(delta.idx) > 0) {
cat("Scales y*:\n")
NAMES[delta.idx] <- makeNames( object@ParTable$rhs[delta.idx],
object@ParTable$label[delta.idx])
for(i in delta.idx) {
print.estimate(name=NAMES[i], i, z.stat=TRUE)
}
cat("\n")
}
} # ngroups
# 6. variable definitions
def.idx <- which(object@ParTable$op == ":=")
if(length(def.idx) > 0) {
if(object@Data@ngroups > 1) cat("\n")
cat("Indirect/Mediation effects:\n")
NAMES[def.idx] <- makeNames( object@ParTable$lhs[def.idx], "")
for(i in def.idx) {
print.estimate(name=NAMES[i], i)
}
cat("\n")
}
}
wp.popPar<-function(object){
par.value<-object@ParTable$ustart
for (i in 1:length(par.value)){
if (is.na(par.value[i])){
if (object@ParTable$op[i]=="~~"){
par.value[i]<-1
}else{
par.value[i]<-0
}
}
}
names(par.value)<-object@ParTable$label
## for indirect effec defined here
for (i in 1:length(par.value)){
if (object@ParTable$op[i]==":="){
temp<-object@ParTable$rhs[i]
temp<-gsub(' +','',temp)
temp<-gsub('-','+', temp, fixed=TRUE)
temp<-unlist(strsplit(temp, '+', fixed=TRUE))
m<-length(temp)
temp.est<-0
par<-NULL
for (j in 1:m){
temp1<-unlist(strsplit(temp[j], '*', fixed=TRUE))
par<-c(par, temp1)
}
ind.exp<-parse(text=object@ParTable$rhs[i])
par.list<-as.list(par.value[par])
par.value[i]<-eval(ind.exp, par.list)
}
}
par.value
}
wp.mc.sem.basic<-function(model, indirect=NULL, nobs=100, nrep=1000, alpha=.95, skewness=NULL, kurtosis=NULL, ovnames=NULL, se="default", estimator="default", parallel="no", ncore=Sys.getenv('NUMBER_OF_PROCESSORS'), cl=NULL, ...){
if (missing(model)) stop("A model is needed.")
model.indirect<-paste(model, "\n", indirect, "\n")
ngroups <- length(nobs)
## Initial analysis for some model information
newdata<-simulateData(model,sample.nobs=nobs,skewness=0,kurtosis=0, ...)
if (ngroups > 1){
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', ...)
}else{
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, ...)
}
par.value<-wp.popPar(temp.res)
idx <- 1:length( temp.res@ParTable$lhs )
#cnames<-paste(temp.res@ParTable$lhs[idx], temp.res@ParTable$op[idx], temp.res@ParTable$rhs[idx])
ov<-lavNames(temp.res,'ov')
## dealing with skewness and kurtosis
if (length(skewness) > 1){
if (length(skewness)!=length(ovnames)) stop("The number of skewness is not equal to the number observed variables")
index<-match(ov, ovnames)
skewness<-skewness[index]
}
if (length(kurtosis) > 1){
if (length(kurtosis)!=length(ovnames)) stop("The number of kurtosis is not equal to the number observed variables")
index<-match(ov, ovnames)
kurtosis<-kurtosis[index]
}
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
cnames<-paste(temp.res@ParTable$lhs[idx], temp.res@ParTable$op[idx], temp.res@ParTable$rhs[idx])
out<-temp.res
runonce<-function(i){
## Step 1: generate data
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
## Step 2: fit the model
if (ngroups > 1){
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', warn=FALSE, ...))
}else{
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, warn=FALSE, ...))
}
## Step 3: Check significance
if (!inherits(temp.res, "try-error")){
idx <- 1:length( temp.res@ParTable$lhs )
temp.est<-temp.res@Fit@est[idx]
temp.se<-temp.res@Fit@se[idx]
temp.sig<-temp.est/temp.se
crit<-qnorm(1-(1-alpha)/2)
temp.sig.ind<-abs(temp.sig)>crit
temp.sig.ind[!is.finite(temp.sig)]<-NA
## Step 4: Check the coverage
ci.u<-temp.est+crit*temp.se
ci.l<-temp.est-crit*temp.se
temp.cvg<- (ci.u>par.value[idx]) & (ci.l<par.value[idx])
}else{
nna<-length(idx)
temp.est<-rep(NA, nna)
temp.sig.ind<-rep(NA, nna)
temp.se<-rep(NA, nna)
temp.cvg<-rep(NA, nna)
}
return(list(temp.sig.ind=temp.sig.ind, temp.est=temp.est, temp.se=temp.se, temp.cvg=temp.cvg))
}
## run parallel or not
# this is from the boot function in package boot
old_options <- options(); options(warn = -1)
have_mc <- have_snow <- FALSE
ncore <- ncore
if (parallel != "no" && ncore > 1L) {
if (parallel == "multicore") have_mc <- .Platform$OS.type != "windows"
else if (parallel == "snow") have_snow <- TRUE
if (!have_mc && !have_snow) ncore <- 1L
}
RR <- nrep
res <- if (ncore > 1L && (have_mc || have_snow)) {
if (have_mc) {
parallel::mclapply(seq_len(RR), runonce, mc.cores = ncore)
} else if (have_snow) {
list(...) # evaluate any promises
if (is.null(cl)) {
cl <- parallel::makePSOCKcluster(rep("localhost", ncore))
if(RNGkind()[1L] == "L'Ecuyer-CMRG")
parallel::clusterSetRNGStream(cl)
res <- parallel::parLapply(cl, seq_len(RR), runonce)
parallel::stopCluster(cl)
res
} else parallel::parLapply(cl, seq_len(RR), runonce)
}
} else lapply(seq_len(RR), runonce)
all.sig<-do.call(rbind, lapply(res, "[[", 'temp.sig.ind'))
all.par<-do.call(rbind, lapply(res, "[[", 'temp.est'))
all.se<-do.call(rbind, lapply(res, "[[", 'temp.se'))
all.cvg<-do.call(rbind, lapply(res, "[[", 'temp.cvg'))
options(old_options)
colnames(all.sig)<-cnames
power<-apply(all.sig, 2, mean, na.rm=TRUE)
cvg<-apply(all.cvg, 2, mean, na.rm=TRUE)
info<-list(nobs=nobs, nrep=nrep, alpha=alpha, method="Normal", bootstrap=NULL)
print(power)
object<-list(power=power, coverage=cvg, pop.value=par.value, results=list(estimates=all.par, se=all.se, all=res), info=info, out=out, data=newdata)
class(object)<-'power'
return(object)
}
wp.mc.sem.boot<-function(model, indirect=NULL, nobs=100, nrep=1000, nboot=1000, alpha=.95, skewness=NULL, kurtosis=NULL, ovnames=NULL, se="default", estimator="default", parallel="no", ncore=Sys.getenv('NUMBER_OF_PROCESSORS'), cl=NULL, ...){
if (missing(model)) stop("A model is needed.")
## internal function
coef.new<-function(x,...){
lavaan::coef(x, type='user', ...)
}
model.indirect<-paste(model, "\n", indirect, "\n")
ngroups <- length(nobs)
## Initial analysis for some model information
newdata<-simulateData(model,sample.nobs=nobs,skewness=0,kurtosis=0, ...)
if (ngroups > 1){
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', warn=FALSE, ...)
}else{
temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, warn=FALSE, ...)
}
par.value<-wp.popPar(temp.res)
idx <- 1:length( temp.res@ParTable$lhs )
#cnames<-paste(temp.res@ParTable$lhs[idx], temp.res@ParTable$op[idx], temp.res@ParTable$rhs[idx])
ov<-lavNames(temp.res,'ov')
ptype<-temp.res@ParTable$op
## dealing with skewness and kurtosis
if (length(skewness) > 1){
if (length(skewness)!=length(ovnames)) stop("The number of skewness is not equal to the number observed variables")
index<-match(ov, ovnames)
skewness<-skewness[index]
}
if (length(kurtosis) > 1){
if (length(kurtosis)!=length(ovnames)) stop("The number of kurtosis is not equal to the number observed variables")
index<-match(ov, ovnames)
kurtosis<-kurtosis[index]
}
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
ci.bc1<-function(x, b, cl=.95){
n<-length(x)
z0<-qnorm(sum(x<b, na.rm=TRUE)/n)
alpha<-(1-cl)/2
alpha<-c(alpha, 1-alpha)
alpha<-sort(alpha)
alpha1<-alpha
alpha<-pnorm(2*z0+qnorm(alpha))
dig <- max(2L, getOption("digits"))
np<-length(alpha)
qs<-quantile(x, alpha, na.rm=TRUE)
names(qs) <- paste(if (np < 100)
formatC(100 * alpha1, format = "fg", width = 1, digits = dig)
else format(100 * alpha1, trim = TRUE, digits = dig),
"%", sep = "")
qs
}
ci.bc<-function(par.boot, par0, cl=.95){
se.boot<-apply(par.boot, 2, sd, na.rm=TRUE)
estimate<-par0
p<-ncol(par.boot)
ci<-NULL
for (i in 1:p){
ci<-rbind(ci, ci.bc1(par.boot[,i], par0[i], cl))
}
cbind(estimate, se.boot, ci)
}
## repeated the following for nrep times
runonce<-function(i){
## Step 1: generate data
newdata<-simulateData(model,sample.nobs=nobs,skewness=skewness,kurtosis=kurtosis, ...)
## Step 2: fit the model
#temp.res<-sem(model.indirect, data=newdata, se=se, estimator=estimator, ...)
if (ngroups > 1){
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, group='group', warn=FALSE, ...))
}else{
temp.res<-try(sem(model.indirect, data=newdata, se=se, estimator=estimator, warn=FALSE, ...))
}
## Step 3: Conduct bootstrap analysis
if (!inherits(temp.res, "try-error")){
orig.res<-coef.new(temp.res)
boot.res<-bootstrapLavaan(temp.res, FUN=coef.new, R=nboot, ...)
ci.res<-ci.bc(boot.res, orig.res, cl=alpha)
## Step 4: Check the coverage
temp.cvg<- (ci.res[,4]>=par.value[idx]) & (ci.res[,3]<par.value[idx])
## Step 5: check significance
temp.sig<-NULL
temp.est<-coef.new(temp.res)
temp.se<-ci.res[,2]
for (jj in 1:length(ptype)){
if (ptype[jj]=="~~"){
crit<-qnorm(1-(1-alpha)/2)
ci.temp<-ci.res[jj, 1] + c(-1,1)*ci.res[jj, 2]*crit
temp.sig<-c(temp.sig, (ci.temp[1]>0 | ci.temp[2]<0))
}else{
temp.sig<-c(temp.sig, (ci.res[jj, 3]>0 | ci.res[jj, 4]<0))
}
}
}else{
nna<-length(idx)
temp.est<-rep(NA, nna)
temp.sig<-rep(NA, nna)
temp.se<-rep(NA, nna)
temp.cvg<-rep(NA, nna)
boot.res<-NA
ci.res<-NA
}
return(list(temp.sig=temp.sig, temp.est=temp.est, temp.se=temp.se, temp.cvg=temp.cvg, boot.res=boot.res, ci.res=ci.res))
}
## run parallel or not
# this is from the boot function in package boot
old_options <- options(); options(warn = -1)
have_mc <- have_snow <- FALSE
ncore <- ncore
if (parallel != "no" && ncore > 1L) {
if (parallel == "multicore") have_mc <- .Platform$OS.type != "windows"
else if (parallel == "snow") have_snow <- TRUE
if (!have_mc && !have_snow) ncore <- 1L
}
RR <- nrep
res <- if (ncore > 1L && (have_mc || have_snow)) {
if (have_mc) {
parallel::mclapply(seq_len(RR), runonce, mc.cores = ncore)
} else if (have_snow) {
list(...) # evaluate any promises
if (is.null(cl)) {
cl <- parallel::makePSOCKcluster(rep("localhost", ncore))
if(RNGkind()[1L] == "L'Ecuyer-CMRG")
parallel::clusterSetRNGStream(cl)
res <- parallel::parLapply(cl, seq_len(RR), runonce)
parallel::stopCluster(cl)
res
} else parallel::parLapply(cl, seq_len(RR), runonce)
}
} else lapply(seq_len(RR), runonce)
all.sig<-do.call(rbind, lapply(res, "[[", 'temp.sig'))
all.par<-do.call(rbind, lapply(res, "[[", 'temp.est'))
all.se<-do.call(rbind, lapply(res, "[[", 'temp.se'))
all.cvg<-do.call(rbind, lapply(res, "[[", 'temp.cvg'))
options(old_options)
#colnames(all.sig)<-cnames
power<-apply(all.sig, 2, mean, na.rm=TRUE)
cvg<-apply(all.cvg, 2, mean, na.rm=TRUE)
info<-list(nobs=nobs, nrep=nrep, alpha=alpha, method="Normal", bootstrap=nboot)
## print(power)
object<-list(power=power, coverage=cvg, pop.value=par.value, results=list(estimates=all.par, se=all.se, all=res), info=info, out=temp.res, data=newdata)
class(object)<-'power'
return(object)
}
wp.mc.sem.power.curve<-function(model, indirect=NULL, nobs=100, type='basic', nrep=1000, nboot=1000, alpha=.95, skewness=NULL, kurtosis=NULL, ovnames=NULL, se="default", estimator="default", parallel="no", ncore=Sys.getenv('NUMBER_OF_PROCESSORS'), cl=NULL, ...){
if (missing(model)) stop("A model is needed.")
allpower<-NULL
## check whether nobs is a vector or not
if (is.vector(nobs)){
for (N in nobs){
if (type == 'basic'){
## sobel test based analysis
indpower <- wp.mc.sem.basic(model=model, indirect=indirect, nobs=N, nrep=nrep, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}else{
indpower <- wp.mc.sem.boot(model=model, indirect=indirect, nobs=N, nrep=nrep, nboot=nboot, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}
allpower<-rbind(allpower, indpower$power)
}
}else{
for (k in 1:nrow(nobs)){
N <- nobs[k]
if (type == 'basic'){
## sobel test based analysis
indpower <- wp.mc.sem.basic(model=model, indirect=indirect, nobs=N, nrep=nrep, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}else{
indpower <- wp.mc.sem.boot(model=model, indirect=indirect, nobs=N, nrep=nrep, nboot=nboot, alpha=alpha, skewness=skewness, kurtosis=kurtosis, ovnames=ovnames, se=se, estimator=estimator, parallel=parallel, ncore=ncore, cl=cl, ...)
}
allpower<-rbind(allpower, indpower$power)
}
}
#windows(record=TRUE)
#op <- par(ask=TRUE)
#on.exit(par(op))
pnames <- colnames(allpower)
for (j in 1:ncol(allpower)){
if (sum(is.nan(allpower[,j])) == 0){
if (is.vector(nobs)){
plot(nobs, allpower[, j], ylab=paste('Power of', pnames[j]), xlab='Sample size')
lines(nobs, allpower[, j])
}else{
N<-apply(nobs, 1, sum)
plot(N, allpower[, j], ylab=paste('Power of', pnames[j]), xlab='Sample size')
lines(N, allpower[, j])
}
}
}
invisible(allpower)
}
## This function performs the sample size calculation for a mixed model of repeated measures with AR(1) correlation structure. See Lu, Luo, & Chen (2008) for parameter definitions and other details.
## power.mmrm.ar1 {longpower}
wp.mmrm.ar1 <-
function (N = NULL, rho = NULL, ra = NULL, sigmaa = NULL, rb = NULL,
sigmab = NULL, lambda = 1, times = 1:length(ra), delta = NULL,
alpha = 0.05, power = NULL, alternative = c("two.sided",
"one.sided"))
{
if (sum(sapply(list(N, rho, delta, power, alpha), is.null)) !=
1)
stop("exactly one of 'N', 'rho', 'delta', 'power', and 'alpha' must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop("'alpha' must be numeric in [0, 1]")
alternative <- match.arg(alternative)
if (length(times) != length(ra))
stop("ra and times should be the same length")
phia <- phib <- NULL
n.body <- quote({
J <- length(ra)
phia <- 1/ra[J] - sum(rho^(2 * (times[J] - times[-J])) *
(1/ra[-1] - 1/ra[-J]))
if (!is.null(rb)) {
phib <- 1/rb[J] - sum(rho^(2 * (times[J] - times[-J])) *
(1/rb[-1] - 1/rb[-J]))
} else {
rb <- ra
phib <- phia
}
if (is.null(sigmab)) {
sigma <- sigmaa
} else {
sigma <- mean(c(sigmaa, sigmab))
}
Na <-lambda*N/(1+lambda)
pnorm( delta/sigma*sqrt(Na/((phia + lambda * phib))) + qnorm(ifelse(alternative == "two.sided", alpha/2, alpha)) )
})
if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(n.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(delta))
delta <- uniroot(function(delta) eval(n.body) -
power,
c(1e-10, 1e+05))$root
else if (is.null(N)) uniroot(function(N) eval(n.body) -
power, c(10, 1e+05))$root
else if (is.null(rho))
rho <- uniroot(function(rho) eval(n.body) - power, c(1e-10,
1 - 1e-10))$root
else power <- eval(n.body)
NOTE <- "Based power.mmrm.ar1 in longpower (Lu, Luo, & Chen ,2008)"
METHOD <- "Power for Mixed Model of Repeated Measures"
URL <- "http://psychstat.org/longar"
structure(list(n=N, n1 = lambda*N/(1+lambda), n2 = N/(1+lambda), rho = rho, phi1 = phia, phi2 = phib,
delta = delta, alpha = alpha,
power = power, alternative = alternative, note = NOTE,
method = METHOD, url = URL),
class = "webpower")
}
## This function performs the sample size calculation for a mixed model of repeated measures with general correlation structure. See Lu, Luo, & Chen (2008) for parameter definitions and other details. This function executes Formula (3) on page 4.
## power.mmrm {longpower}
wp.mmrm<-function (N = NULL, Ra = NULL, ra = NULL,
sigmaa = NULL, Rb = NULL, rb = NULL, sigmab = NULL,
lambda = 1, delta = NULL, alpha = 0.05,
power = NULL, alternative = c("two.sided", "one.sided"))
{
if (sum(sapply(list(N, delta, power, alpha), is.null)) !=
1)
stop("exactly one of 'N', 'delta', 'power', and 'alpha' must be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 >
alpha | alpha > 1))
stop("'alpha' must be numeric in [0, 1]")
alternative <- match.arg(alternative)
n.body <- quote({
Ia <- 0
ra <- c(ra, 0)
for (j in 1:nrow(Ra)) {
Raj <- matrix(0, nrow(Ra), nrow(Ra))
Raj[1:j, 1:j] <- solve(Ra[1:j, 1:j])
Ia <- Ia + (ra[j] - ra[j + 1]) * Raj
}
phia <- solve(Ia)[j, j]
if (is.null(rb)) rb <- ra
if (is.null(Rb)) Rb <- Ra
Ib <- 0
rb <- c(rb, 0)
for (j in 1:nrow(Rb)) {
Rbj <- matrix(0, nrow(Rb), nrow(Rb))
Rbj[1:j, 1:j] <- solve(Rb[1:j, 1:j])
Ib <- Ib + (rb[j] - rb[j + 1]) * Rbj
}
phib <- solve(Ib)[j, j]
if (is.null(sigmab)) {
sigma <- sigmaa
} else {
sigma <- mean(c(sigmaa, sigmab))
}
Na <-lambda*N/(1+lambda)
pnorm( delta/sigma*sqrt(Na/((phia + lambda * phib))) + qnorm(ifelse(alternative == "two.sided", alpha/2, alpha)) )
})
if (is.null(alpha))
alpha <- uniroot(function(alpha) eval(n.body) -
power, c(1e-10, 1 - 1e-10))$root
else if (is.null(delta))
delta <- uniroot(function(delta) eval(n.body) -
power,
c(1e-10, 1e+05))$root
else if (is.null(N)) uniroot(function(N) eval(n.body) -
power, c(10, 1e+05))$root
else power <- eval(n.body)
NOTE <- "Based power.mmrm in longpower (Lu, Luo, & Chen ,2008)"
METHOD <- "Power for Mixed Model of Repeated Measures"
URL <- "http://psychstat.org/longmmrm"
structure(list(n=N, n1 = lambda*N/(1+lambda), n2 = N/(1+lambda), delta = delta, alpha = alpha, power = power, alternative = alternative, note = NOTE, method = METHOD, url = URL), class = "webpower")
}
wp.mc.t <- function(n = NULL, R0 = 1e+5, R1=1e+3, mu0 = 0, mu1 = 0, sd = 1,
skewness = 0, kurtosis = 3, alpha = 0.05,
type = c("two.sample", "one.sample", "paired"), alternative = c("two.sided",
"less", "greater")) {
if (sum(sapply(list(n, mu0, R0, R1, mean, sd, skewness, kurtosis, alpha),
is.null)) >= 1)
stop("n, mu0, mean, sd, skewness, kurtosis, and alpha cannot be NULL")
if (!is.null(alpha) && !is.numeric(alpha) || any(0 > alpha |
alpha > 1))
stop(sQuote("alpha"), " must be numeric in [0, 1]")
type <- match.arg(type)
alternative <- match.arg(alternative)
tsample <- switch(type, one.sample = 1, two.sample = 2, paired = 1)
tside <- switch(alternative, less = 1, two.sided = 2, greater = 3)
if (tsample == 1) {
##### under null hypothesis
moments0 <- c(mean = mu0, variance = sd^2, skewness = skewness,
kurtosis = kurtosis)
data0 <- matrix(rpearson(n * R0, moments = moments0), ncol = n,
nrow = R0)
y_bar0 <- apply(data0, 1, mean)
var0 <- apply(data0, 1, var)
t0 <- (y_bar0 - mu0)/sqrt(var0/n)
##### under alternative hypothesis
momentsa <- c(mean = mu1, variance = sd^2, skewness = skewness,
kurtosis = kurtosis)
dataa <- matrix(rpearson(n * R1, moments = momentsa), ncol = n,
nrow = R1)
y_bara <- apply(dataa, 1, mean)
vara <- apply(dataa, 1, var)
ta <- (y_bara - mu0)/sqrt(vara/n)
} else if (tsample == 2) {
if (length(mu0) == 1)
mu0 <- rep(mu0, 2)
if (length(mu1) == 1)
mu1 <- rep(mu1, 2)
if (length(sd) == 1)
sd <- rep(sd, 2)
if (length(skewness) == 1)
skewness <- rep(skewness, 2)
if (length(kurtosis) == 1)
kurtosis <- rep(kurtosis, 2)
if (length(n) == 1)
n <- rep(n, 2)
##### under null hypothesis
moments01 <- c(mean = mu0[1], variance = sd[1]^2, skewness = skewness[1],
kurtosis = kurtosis[1])
moments02 <- c(mean = mu0[2], variance = sd[2]^2, skewness = skewness[2],
kurtosis = kurtosis[2])
data01 <- matrix(rpearson(n[1] * R0, moments = moments01), ncol = n[1],
nrow = R0)
data02 <- matrix(rpearson(n[2] * R0, moments = moments02), ncol = n[2],
nrow = R0)
y_bar01 <- apply(data01, 1, mean)
var01 <- apply(data01, 1, var)
y_bar02 <- apply(data02, 1, mean)
var02 <- apply(data02, 1, var)
t0 <- (y_bar01 - y_bar02)/sqrt(var01/n[1] + var02/n[2])
##### under alternative hypothesis
momentsa1 <- c(mean = mu1[1], variance = sd[1]^2, skewness = skewness[1],
kurtosis = kurtosis[1])
momentsa2 <- c(mean = mu1[2], variance = sd[2]^2, skewness = skewness[2],
kurtosis = kurtosis[2])
dataa1 <- matrix(rpearson(n[1] * R1, moments = momentsa1), ncol = n[1],
nrow = R1)
dataa2 <- matrix(rpearson(n[2] * R1, moments = momentsa2), ncol = n[2],
nrow = R1)
y_bara1 <- apply(dataa1, 1, mean)
vara1 <- apply(dataa1, 1, var)
y_bara2 <- apply(dataa2, 1, mean)
vara2 <- apply(dataa2, 1, var)
ta <- (y_bara1 - y_bara2)/sqrt(vara1/n[1] + vara2/n[2])
}
if (tside == 2) {
t.cri <- quantile(sort(t0), c(alpha/2, 1 - alpha/2))
power <- mean(ta >= t.cri[2] | ta <= t.cri[1])
}
if (tside == 1) {
t.cri <- quantile(sort(t0), alpha)
power <- mean(ta <= t.cri)
}
if (tside == 3) {
t.cri <- quantile(sort(t0), 1 - alpha)
power <- mean(ta >= t.cri)
}
NOTE <- switch(type, paired = "n is number of *pairs*", two.sample = "n is number in *each* group",
NULL)
METHOD <- paste(switch(type, one.sample = "One-sample", two.sample = "Two-sample",
paired = "Paired"), "t test power calculation")
URL <- "http://psychstat.org/tnonnormal"
if (tsample == 2) {
structure(list(n1 = n[1], n2 = n[2], power = power, mean1 = mu1[1], mean2 = mu1[2], sd1 = sd[1], sd2 = sd[2], skewness1 = skewness[1], skewness2 = skewness[2],
kurtosis1 = kurtosis[1], kurtosis2 = kurtosis[1], alpha = alpha,
alternative = alternative, note = NOTE, method = METHOD, url=URL),
class = "webpower")
} else if (tsample == 1) {
structure(list(n = n, power = power, mu0=mu0, mu1 = mu1, sd = sd, skewness = skewness,
kurtosis = kurtosis, alpha = alpha,
alternative = alternative, note = NOTE, method = METHOD, url=URL), class = "webpower")
}
}
wp.mc.chisq.diff <- function(full.model.pop, full.model, reduced.model, N=100, R=1000, alpha=0.05){
chi.diff <- rep(0, R)
for (i in 1:R){
sim.data <- simulateData(full.model.pop, sample.nobs=N)
full.res <- sem(full.model, data=sim.data)
reduced.res <- sem(reduced.model, data=sim.data)
chi.diff[i] <- reduced.res@Fit@test[[1]]$stat - full.res@Fit@test[[1]]$stat
}
df <- reduced.res@Fit@test[[1]]$df - full.res@Fit@test[[1]]$df
power <- mean(chi.diff > qchisq(1-alpha, df))
list(power=power, df=df, chi.dff=chi.diff)
structure(list(n = N, power = power, df=df, alpha = alpha), class = "webpower")
}
sem.effect.size <- function(full.model.pop, reduced.model){
N <- 1000
full.res<-sem(full.model.pop, do.fit=FALSE)
sigma.F<-fitted.values(full.res)$cov
reduced.res<-sem(reduced.model, sample.cov=sigma.F, sample.nobs=N)
delta <- reduced.res@Fit@test[[1]]$stat/N
df <- reduced.res@Fit@test[[1]]$df
RMSEA <- fitMeasures(reduced.res, "rmsea")
list(delta=delta, df=df, RMSEA=RMSEA)
}
Try the WebPower package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.