P281424/AMR
1
0
Fork 0
mirror of https://github.com/msberends/AMR.git synced 2025-07-10 05:41:59 +02:00
Code Releases Activity

(v0.7.1.9102) lintr

Browse Source
This commit is contained in:
dr. M.S. (Matthijs) Berends
2019-10-11 17:21:02 +02:00
parent 59af355a89
commit 00cdb498a0
65 changed files with 620 additions and 812 deletions
Download Patch File Download Diff File Expand all files Collapse all files

75
R/g.test.R
View File

@ -107,10 +107,10 @@
#' # Meaning: there are significantly more left-billed birds.
#'
g.test <- function(x,
y = NULL,
# correct = TRUE,
p = rep(1/length(x), length(x)),
rescale.p = FALSE) {
y = NULL,
# correct = TRUE,
p = rep(1 / length(x), length(x)),
rescale.p = FALSE) {
DNAME <- deparse(substitute(x))
if (is.data.frame(x))
x <- as.matrix(x)
@ -144,11 +144,8 @@ g.test <- function(x,
stop("all entries of 'x' must be nonnegative and finite")
if ((n <- sum(x)) == 0)
stop("at least one entry of 'x' must be positive")
# if (simulate.p.value) {
# setMETH <- function() METHOD <<- paste(METHOD, "with simulated p-value\n\t (based on",
# B, "replicates)")
# almost.1 <- 1 - 64 * .Machine$double.eps
# }
if (is.matrix(x)) {
METHOD <- "G-test of independence"
nr <- as.integer(nrow(x))
@ -157,34 +154,18 @@ g.test <- function(x,
stop("invalid nrow(x) or ncol(x)", domain = NA)
# add fisher.test suggestion
if (nr == 2 && nc == 2)
warning("`fisher.test()` is always more reliable for 2x2 tables and although must slower, often only takes seconds.")
warning("`fisher.test()` is always more reliable for 2x2 tables and although much slower, often only takes seconds.")
sr <- rowSums(x)
sc <- colSums(x)
E <- outer(sr, sc, "*")/n
v <- function(r, c, n) c * r * (n - r) * (n - c)/n^3
E <- outer(sr, sc, "*") / n
v <- function(r, c, n) c * r * (n - r) * (n - c) / n ^ 3
V <- outer(sr, sc, v, n)
dimnames(E) <- dimnames(x)
# if (simulate.p.value && all(sr > 0) && all(sc > 0)) {
# setMETH()
# tmp <- .Call(chisq_sim, sr, sc, B, E, PACKAGE = "stats")
# STATISTIC <- 2 * sum(x * log(x / E)) # sum(sort((x - E)^2/E, decreasing = TRUE)) for chisq.test
# PARAMETER <- NA
# PVAL <- (1 + sum(tmp >= almost.1 * STATISTIC))/(B +
# 1)
# }
# else {
# if (simulate.p.value)
# warning("cannot compute simulated p-value with zero marginals")
# if (correct && nrow(x) == 2L && ncol(x) == 2L) {
# YATES <- min(0.5, abs(x - E))
# if (YATES > 0)
# METHOD <- paste(METHOD, "with Yates' continuity correction")
# }
# else YATES <- 0
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
STATISTIC <- 2 * sum(x * log(x / E)) # sum((abs(x - E) - YATES)^2/E) for chisq.test
PARAMETER <- (nr - 1L) * (nc - 1L)
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
else {
if (length(dim(x)) > 2L)
@ -197,7 +178,7 @@ g.test <- function(x,
stop("probabilities must be non-negative.")
if (abs(sum(p) - 1) > sqrt(.Machine$double.eps)) {
if (rescale.p)
p <- p/sum(p)
p <- p / sum(p)
else stop("probabilities must sum to 1.")
}
METHOD <- "G-test of goodness-of-fit (likelihood ratio test)"
@ -205,30 +186,18 @@ g.test <- function(x,
V <- n * p * (1 - p)
STATISTIC <- 2 * sum(x * log(x / E)) # sum((x - E)^2/E) for chisq.test
names(E) <- names(x)
# if (simulate.p.value) {
# setMETH()
# nx <- length(x)
# sm <- matrix(sample.int(nx, B * n, TRUE, prob = p),
# nrow = n)
# ss <- apply(sm, 2L, function(x, E, k) {
# sum((table(factor(x, levels = 1L:k)) - E)^2/E)
# }, E = E, k = nx)
# PARAMETER <- NA
# PVAL <- (1 + sum(ss >= almost.1 * STATISTIC))/(B +
# 1)
# }
# else {
PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
# }
PARAMETER <- length(x) - 1
PVAL <- pchisq(STATISTIC, PARAMETER, lower.tail = FALSE)
}
names(STATISTIC) <- "X-squared"
names(PARAMETER) <- "df"
if (any(E < 5) && is.finite(PARAMETER))
warning("G-statistic approximation may be incorrect due to E < 5")
structure(list(statistic = STATISTIC, parameter = PARAMETER,
p.value = PVAL, method = METHOD, data.name = DNAME,
observed = x, expected = E, residuals = (x - E)/sqrt(E),
stdres = (x - E)/sqrt(V)), class = "htest")
observed = x, expected = E, residuals = (x - E) / sqrt(E),
stdres = (x - E) / sqrt(V)), class = "htest")
}