Документ взят из кэша поисковой машины. Адрес оригинального документа : http://herba.msu.ru/shipunov/school/biol_240/en/r/concordance.r Дата изменения: Sun Sep 20 05:13:42 2015 Дата индексирования: Mon Apr 11 04:00:48 2016 Кодировка:

# saved from the older version of "concordance"
cohen.kappa <- function (classif, type = c("score", "count"))
{
if (missing(classif))
stop("Usage: cohen.kappa(classif, type=\"score\")\n")
if (!is.numeric(classif))
classif <- apply(apply(classif, 2, as.factor), 2, as.numeric)
if (type[1] == "score")
classif.mat <- scores.to.counts(classif)
else classif.mat <- as.matrix(classif)
minclassif <- min(classif.mat)
classdim <- dim(classif)
k <- apply(classif.mat, 1, sum)
if (any(k != k[1])) {
classif.mat <- cbind(classif.mat, max(k) - k)
k <- apply(classif.mat, 1, sum)
cat("Different row sums, a no-classification category was added.\n\n")
}
matdim <- dim(classif.mat)
N <- matdim[1]
ncat <- matdim[2]
if (type[1] == "score") {
if (any(is.na(classif))) {
cat("Can't use Cohen's method with NAs\n")
PEc <- NA
}
else {
pj <- apply(apply(classif, 2, tabulate, nbins = ncat)/N,
1, prod)
PEc <- sum(pj)
}
}
else PEc <- NA
Cj <- apply(classif.mat, 2, sum)
pj <- Cj/(N * k[1])
PEsc <- sum(pj^2)
Si <- 1/(k[1] * (k[1] - 1)) * sum(classif.mat * (classif.mat -
1))
PA <- (1/N) * sum(Si)
Ksc <- (PA - PEsc)/(1 - PEsc)
if (type[1] == "score") {
Kc <- (PA - PEc)/(1 - PEc)
varKc <- (2/(N * k[1] * (k[1] - 1))) * (PEc - (2 * k[1] -
3) * PEc^2 + 2 * (k[1] - 2) * sum(pj^3))/(1 - PEc)^2
Zc <- Kc/sqrt(varKc)
pc <- 1 - pnorm(Zc)
}
else {
Kc <- NA
Zc <- NA
pc <- NA
}
varKsc <- (2/(N * k[1] * (k[1] - 1))) * (PEsc - (2 * k[1] -
3) * PEsc^2 + 2 * (k[1] - 2) * sum(pj^3))/(1 - PEsc)^2
Zsc <- Ksc/sqrt(varKsc)
psc <- 1 - pnorm(Zsc)
Kbbc <- 2 * PA - 1
c.k <- list(kappa.c = Kc, kappa.sc = Ksc, kappa.bbc = Kbbc,
Zc = Zc, Zsc = Zsc, pc = pc, psc = psc, categories = matdim[2],
methods = k[1])
class(c.k) <- "cohen.kappa"
return(c.k)
}

scores.to.counts <- function (scores)
{
if (is.data.frame(scores))
score.names <- levels(as.factor(as.vector(unlist(scores))))
if (is.matrix(scores))
score.names <- levels(as.factor(as.vector(scores)))
if (missing(score.names))
stop("scores must be a data frame or matrix")
score.levels <- as.numeric(score.names)
nlevels <- length(score.levels)
nobj <- length(scores[, 1])
counts <- matrix(0, nrow = nobj, ncol = nlevels)
colnames(counts) <- score.names
for (i in 1:nobj) {
for (j in 1:nlevels) counts[i, j] <- sum(scores[i, ] ==
score.levels[j], na.rm = TRUE)
}
return(counts)
}

print.cohen.kappa <- function (x, ...)
{
cat("Kappa test for nominally classified data\n")
cat(paste(x$categories, "categories -", x$methods, "methods\n"))
if (!is.na(x$kappa.c)) {
cat(paste("kappa (Cohen) =", signif(x$kappa.c), ", Z =",
signif(x$Zc), ", p =", signif(x$pc), "\n"))
}
cat(paste("kappa (Siegel) =", signif(x$kappa.sc), ", Z =",
signif(x$Zsc), ", p =", signif(x$psc), "\n"))
cat(paste("kappa (2*PA-1) =", signif(x$kappa.bbc), "\n\n"))
}