[IPSUR-commits] r214 - in pkg/RcmdrPlugin.IPSUR: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jan 21 18:36:24 CET 2013
Author: gkerns
Date: 2013-01-21 18:36:24 +0100 (Mon, 21 Jan 2013)
New Revision: 214
Modified:
pkg/RcmdrPlugin.IPSUR/DESCRIPTION
pkg/RcmdrPlugin.IPSUR/NAMESPACE
pkg/RcmdrPlugin.IPSUR/R/globals.R
pkg/RcmdrPlugin.IPSUR/R/misc.r
pkg/RcmdrPlugin.IPSUR/R/numSumIPSUR.r
Log:
fixed it to conform to R-3.0.0
Modified: pkg/RcmdrPlugin.IPSUR/DESCRIPTION
===================================================================
--- pkg/RcmdrPlugin.IPSUR/DESCRIPTION 2013-01-21 14:34:27 UTC (rev 213)
+++ pkg/RcmdrPlugin.IPSUR/DESCRIPTION 2013-01-21 17:36:24 UTC (rev 214)
@@ -4,7 +4,7 @@
Title: An IPSUR Plugin for the R Commander
Author: G. Jay Kerns <gkerns at ysu.edu> with contributions by Theophilius Boye and Tyler Drombosky, adapted from the work of John Fox et al.
Maintainer: G. Jay Kerns <gkerns at ysu.edu>
-Imports: Rcmdr (>= 1.4-0)
+Imports: Rcmdr (>= 1.4-0), abind, e1071
Suggests: abind, car, distr, distrEx, e1071, effects (>= 1.0-7), foreign, grid, lattice, lmtest, MASS, mgcv, multcomp (>= 0.991-2), nlme, nnet, qcc, relimp, RODBC
LazyLoad: yes
LazyData: yes
Modified: pkg/RcmdrPlugin.IPSUR/NAMESPACE
===================================================================
--- pkg/RcmdrPlugin.IPSUR/NAMESPACE 2013-01-21 14:34:27 UTC (rev 213)
+++ pkg/RcmdrPlugin.IPSUR/NAMESPACE 2013-01-21 17:36:24 UTC (rev 214)
@@ -1,3 +1,5 @@
import(stats, Rcmdr)
+importFrom(e1071, skewness, kurtosis)
+importFrom(abind, abind)
exportPattern("^[^\\.]")
Modified: pkg/RcmdrPlugin.IPSUR/R/globals.R
===================================================================
--- pkg/RcmdrPlugin.IPSUR/R/globals.R 2013-01-21 14:34:27 UTC (rev 213)
+++ pkg/RcmdrPlugin.IPSUR/R/globals.R 2013-01-21 17:36:24 UTC (rev 214)
@@ -1 +1,49 @@
-if (getRversion() >= '2.15.1') globalVariables(c('top','meanVariable', 'sumVariable','sdVariable', 'discardVariable','checkBoxFrame', 'discardcheckBoxFrame','buttonsFrame', '.x','xmin', 'xmax', 'PoissonDistributionPlot','.Table','binomsimNumber', 'expsimNumber','typeVariable','groupsFrame','typeFrame', 'samplesn','horzOptionVariable','notchOptionVariable','varwidthOptionVariable', 'OKbutton','cancelButton','marginsVariable', 'percentsVariable','chisqVariable','chisqComponentsVariable', 'expFreqVariable','fisherVariable','.Test','marginsFrame', 'percentsFrame','testsFrame','alternativeVariable','testVariable','alternativeFrame','testFrame','subwin','.Probs','subButtonsFrame','skewnessVariable', 'kurtosisVariable', '.groups','coloOptionVariable', 'chisqTestVariable','fisherTestVariable','subsetVariable', 'subsetFrame'))
+if (getRversion() >= '2.15.1') globalVariables(c('top', 'meanVariable',
+ 'sumVariable',
+ 'sdVariable',
+ 'discardVariable',
+ 'checkBoxFrame',
+ 'discardcheckBoxFrame',
+ 'buttonsFrame',
+ '.x',
+ 'xmin',
+ 'xmax',
+ 'PoissonDistributionPlot',
+ '.Table',
+ 'binomsimNumber',
+ 'expsimNumber',
+ 'typeVariable',
+ 'groupsFrame',
+ 'typeFrame',
+ 'samplesn',
+ 'horzOptionVariable',
+ 'notchOptionVariable',
+ 'varwidthOptionVariable',
+ 'OKbutton','cancelButton',
+ 'marginsVariable',
+ 'percentsVariable',
+ 'chisqVariable',
+ 'chisqComponentsVariable',
+ 'expFreqVariable',
+ 'fisherVariable',
+ '.Test',
+ 'marginsFrame',
+ 'percentsFrame',
+ 'testsFrame',
+ 'alternativeVariable',
+ 'testVariable',
+ 'alternativeFrame',
+ 'testFrame',
+ 'subwin',
+ '.Probs',
+ 'subButtonsFrame',
+ 'skewnessVariable',
+ 'kurtosisVariable',
+ '.groups',
+ 'coloOptionVariable',
+ 'chisqTestVariable',
+ 'fisherTestVariable',
+ 'subsetVariable',
+ 'subsetFrame',
+ 'support'
+ ))
Modified: pkg/RcmdrPlugin.IPSUR/R/misc.r
===================================================================
--- pkg/RcmdrPlugin.IPSUR/R/misc.r 2013-01-21 14:34:27 UTC (rev 213)
+++ pkg/RcmdrPlugin.IPSUR/R/misc.r 2013-01-21 17:36:24 UTC (rev 214)
@@ -1,101 +1,101 @@
-# Last modified Mar 23, 2012
-
-
-`pbirthday.ipsur` <-
-function (n, classes = 365, coincident = 2)
-{
- k <- coincident
- c <- classes
- if (k < 2)
- return(1)
- if (k > n)
- return(0)
- if (k == 2) {
- return(1 - prod((c:(c - n + 1))/rep(c, n)))
- }
- if (n > c * (k - 1))
- return(1)
- eps <- 1e-14
- if (qbirthday(1 - eps, c, k) <= n)
- return(1 - eps)
- f <- function(p) qbirthday(p, c, k) - n
- upper <- min(1, exp(k * log(n) - (k - 1) * log(c)), na.rm = TRUE)
- nmin <- uniroot(f, lower = 0, upper = upper, tol = eps)
- if (nmin$root == 0 && f(.Machine$double.xmin) < 0) {
- f <- function(ln.p) qbirthday(exp(ln.p), c, k) - n
- nmin <- uniroot(f, lower = floor(log(.Machine$double.xmin)),
- upper = -2, tol = eps)
- exp(nmin$root)
- }
- else nmin$root
-}
-
-
-`qbirthday.ipsur` <-
-function (prob = 0.5, classes = 365, coincident = 2)
-{
- k <- coincident
- c <- classes
- p <- prob
- if (p <= 0)
- return(1)
- if (p >= 1)
- return(c * (k - 1) + 1)
- if (k == 2) {
- x <- sapply(0:c, function(t) pbirthday(n = t, classes = c,
- coincident = 2))
- return(min(which(x >= p)) - 1)
- }
- if ((k - 1) * log(c) > 8 || 1 - p < 1e-07) {
- lnN <- ((k - 1) * log(c) + lgamma(k + 1) + log(-log1p(-p)))/k
- N <- exp(lnN)
- }
- else {
- N <- (c^(k - 1) * gamma(k + 1) * log(1/(1 - p)))^(1/k)
- }
- round(N)
-}
-
-
-
-
-#######
-# Need this to assign numbers below
-RcmdrEnv <- function() {
- pos <- match("RcmdrEnv", search())
- if (is.na(pos)) { # Must create it
- RcmdrEnv <- list()
- attach(RcmdrEnv, pos = length(search()) - 1)
- rm(RcmdrEnv)
- pos <- match("RcmdrEnv", search())
- }
- return(pos.to.env(pos))
- }
-
-###############################################################
-###############################################################
-# Extra counters
- #assign("simsetNumber", 0, envir = RcmdrEnv())
- #assign("datasetNumber", 0, envir = RcmdrEnv())
- assign("betasimNumber", 0, envir = RcmdrEnv())
- assign("chisqsimNumber", 0, envir = RcmdrEnv())
- assign("binomsimNumber", 0, envir = RcmdrEnv())
- assign("hypersimNumber", 0, envir = RcmdrEnv())
- assign("gammasimNumber", 0, envir = RcmdrEnv())
- assign("expsimNumber", 0, envir = RcmdrEnv())
- assign("normsimNumber", 0, envir = RcmdrEnv())
- assign("fsimNumber", 0, envir = RcmdrEnv())
- assign("tsimNumber", 0, envir = RcmdrEnv())
- assign("cauchysimNumber", 0, envir = RcmdrEnv())
- assign("geomsimNumber", 0, envir = RcmdrEnv())
- assign("lnormsimNumber", 0, envir = RcmdrEnv())
- assign("logissimNumber", 0, envir = RcmdrEnv())
- assign("nbinomsimNumber", 0, envir = RcmdrEnv())
- assign("poissimNumber", 0, envir = RcmdrEnv())
- assign("weibullsimNumber", 0, envir = RcmdrEnv())
- assign("unifsimNumber", 0, envir = RcmdrEnv())
- assign("disunifsimNumber", 0, envir = RcmdrEnv())
-
-###############################################################
-###############################################################
-# End Extra counters
+# Last modified Mar 23, 2012
+
+
+`pbirthday.ipsur` <-
+function (n, classes = 365, coincident = 2)
+{
+ k <- coincident
+ c <- classes
+ if (k < 2)
+ return(1)
+ if (k > n)
+ return(0)
+ if (k == 2) {
+ return(1 - prod((c:(c - n + 1))/rep(c, n)))
+ }
+ if (n > c * (k - 1))
+ return(1)
+ eps <- 1e-14
+ if (qbirthday(1 - eps, c, k) <= n)
+ return(1 - eps)
+ f <- function(p) qbirthday(p, c, k) - n
+ upper <- min(1, exp(k * log(n) - (k - 1) * log(c)), na.rm = TRUE)
+ nmin <- uniroot(f, lower = 0, upper = upper, tol = eps)
+ if (nmin$root == 0 && f(.Machine$double.xmin) < 0) {
+ g <- function(ln.p) qbirthday(exp(ln.p), c, k) - n
+ nmin <- uniroot(g, lower = floor(log(.Machine$double.xmin)),
+ upper = -2, tol = eps)
+ exp(nmin$root)
+ }
+ else nmin$root
+}
+
+
+`qbirthday.ipsur` <-
+function (prob = 0.5, classes = 365, coincident = 2)
+{
+ k <- coincident
+ c <- classes
+ p <- prob
+ if (p <= 0)
+ return(1)
+ if (p >= 1)
+ return(c * (k - 1) + 1)
+ if (k == 2) {
+ x <- sapply(0:c, function(t) pbirthday(n = t, classes = c,
+ coincident = 2))
+ return(min(which(x >= p)) - 1)
+ }
+ if ((k - 1) * log(c) > 8 || 1 - p < 1e-07) {
+ lnN <- ((k - 1) * log(c) + lgamma(k + 1) + log(-log1p(-p)))/k
+ N <- exp(lnN)
+ }
+ else {
+ N <- (c^(k - 1) * gamma(k + 1) * log(1/(1 - p)))^(1/k)
+ }
+ round(N)
+}
+
+
+
+
+#######
+# Need this to assign numbers below
+RcmdrEnv <- function() {
+ pos <- match("RcmdrEnv", search())
+ if (is.na(pos)) { # Must create it
+ RcmdrEnv <- list()
+ attach(RcmdrEnv, pos = length(search()) - 1)
+ rm(RcmdrEnv)
+ pos <- match("RcmdrEnv", search())
+ }
+ return(pos.to.env(pos))
+ }
+
+###############################################################
+###############################################################
+# Extra counters
+ #assign("simsetNumber", 0, envir = RcmdrEnv())
+ #assign("datasetNumber", 0, envir = RcmdrEnv())
+ assign("betasimNumber", 0, envir = RcmdrEnv())
+ assign("chisqsimNumber", 0, envir = RcmdrEnv())
+ assign("binomsimNumber", 0, envir = RcmdrEnv())
+ assign("hypersimNumber", 0, envir = RcmdrEnv())
+ assign("gammasimNumber", 0, envir = RcmdrEnv())
+ assign("expsimNumber", 0, envir = RcmdrEnv())
+ assign("normsimNumber", 0, envir = RcmdrEnv())
+ assign("fsimNumber", 0, envir = RcmdrEnv())
+ assign("tsimNumber", 0, envir = RcmdrEnv())
+ assign("cauchysimNumber", 0, envir = RcmdrEnv())
+ assign("geomsimNumber", 0, envir = RcmdrEnv())
+ assign("lnormsimNumber", 0, envir = RcmdrEnv())
+ assign("logissimNumber", 0, envir = RcmdrEnv())
+ assign("nbinomsimNumber", 0, envir = RcmdrEnv())
+ assign("poissimNumber", 0, envir = RcmdrEnv())
+ assign("weibullsimNumber", 0, envir = RcmdrEnv())
+ assign("unifsimNumber", 0, envir = RcmdrEnv())
+ assign("disunifsimNumber", 0, envir = RcmdrEnv())
+
+###############################################################
+###############################################################
+# End Extra counters
Modified: pkg/RcmdrPlugin.IPSUR/R/numSumIPSUR.r
===================================================================
--- pkg/RcmdrPlugin.IPSUR/R/numSumIPSUR.r 2013-01-21 14:34:27 UTC (rev 213)
+++ pkg/RcmdrPlugin.IPSUR/R/numSumIPSUR.r 2013-01-21 17:36:24 UTC (rev 214)
@@ -1,198 +1,198 @@
-# Last modified Feb 16, 2008
-
-`numSummaryIPSUR` <-
-function (data, statistics = c("mean", "sd", "skewness", "kurtosis",
- "quantiles"), quantiles = c(0, 0.25, 0.5, 0.75, 1), groups)
-{
- if (!require(abind))
- stop("abind package missing")
- if (!require(e1071))
- stop("e1071 package missing")
- data <- as.data.frame(data)
- if (!missing(groups))
- groups <- as.factor(groups)
- variables <- names(data)
- statistics <- match.arg(statistics, c("mean", "sd", "skewness",
- "kurtosis", "quantiles"), several.ok = TRUE)
- ngroups <- if (missing(groups))
- 1
- else length(grps <- levels(groups))
- quantiles <- if ("quantiles" %in% statistics)
- quantiles
- else NULL
- quants <- if (length(quantiles) > 1)
- paste(100 * quantiles, "%", sep = "")
- else NULL
- nquants <- length(quants)
- stats <- c(c("mean", "sd", "skewness", "kurtosis")[c("mean",
- "sd", "skewness", "kurtosis") %in% statistics], quants)
- nstats <- length(stats)
- nvars <- length(variables)
- result <- list()
- if ((ngroups == 1) && (nvars == 1) && (length(statistics) ==
- 1)) {
- if (statistics == "quantiles")
- table <- quantile(data[, variables], probs = quantiles,
- na.rm = TRUE)
- else {
- table <- do.call(statistics, list(x = data[, variables],
- na.rm = TRUE))
- names(table) <- statistics
- }
- NAs <- sum(is.na(data[, variables]))
- n <- nrow(data) - NAs
- result$type <- 1
- }
- else if ((ngroups > 1) && (nvars == 1) && (length(statistics) ==
- 1)) {
- if (statistics == "quantiles") {
- table <- matrix(unlist(tapply(data[, variables],
- groups, quantile, probs = quantiles, na.rm = TRUE)),
- ngroups, nquants, byrow = TRUE)
- rownames(table) <- grps
- colnames(table) <- quants
- }
- else table <- tapply(data[, variables], groups, statistics,
- na.rm = TRUE)
- NAs <- tapply(data[, variables], groups, function(x) sum(is.na(x)))
- n <- table(groups) - NAs
- result$type <- 2
- }
- else if ((ngroups == 1)) {
- table <- matrix(0, nvars, nstats)
- rownames(table) <- if (length(variables) > 1)
- variables
- else ""
- colnames(table) <- stats
- if ("mean" %in% stats)
- table[, "mean"] <- mean(data[, variables], na.rm = TRUE)
- if ("sd" %in% stats)
- table[, "sd"] <- sd(data[, variables], na.rm = TRUE)
- if ("skewness" %in% stats)
- table[, "skewness"] <- apply(as.matrix(data[, variables]),
- MARGIN = 2, skewness, na.rm = TRUE)
- if ("kurtosis" %in% stats)
- table[, "kurtosis"] <- apply(as.matrix(data[, variables]),
- MARGIN = 2, kurtosis, na.rm = TRUE)
- if ("quantiles" %in% statistics) {
- table[, quants] <- t(apply(data[, variables, drop = FALSE],
- 2, quantile, probs = quantiles, na.rm = TRUE))
- }
- NAs <- colSums(is.na(data[, variables, drop = FALSE]))
- n <- nrow(data) - NAs
- result$type <- 3
- }
- else {
- table <- array(0, c(ngroups, nstats, nvars), dimnames = list(Group = grps,
- Statistic = stats, Variable = variables))
- NAs <- matrix(0, nvars, ngroups)
- rownames(NAs) <- variables
- colnames(NAs) <- grps
- for (variable in variables) {
- if ("mean" %in% stats)
- table[, "mean", variable] <- tapply(data[, variable],
- groups, mean, na.rm = TRUE)
- if ("sd" %in% stats)
- table[, "sd", variable] <- tapply(data[, variable],
- groups, sd, na.rm = TRUE)
- if ("skewness" %in% stats)
- table[, "skewness", variable] <- tapply(data[,
- variable], groups, skewness, na.rm = TRUE)
- if ("kurtosis" %in% stats)
- table[, "kurtosis", variable] <- tapply(data[,
- variable], groups, kurtosis, na.rm = TRUE)
- if ("quantiles" %in% statistics) {
- res <- matrix(unlist(tapply(data[, variable],
- groups, quantile, probs = quantiles, na.rm = TRUE)),
- ngroups, nquants, byrow = TRUE)
- table[, quants, variable] <- res
- }
- NAs[variable, ] <- tapply(data[, variable], groups,
- function(x) sum(is.na(x)))
- }
- if (nstats == 1)
- table <- table[, 1, ]
- if (nvars == 1)
- table <- table[, , 1]
- n <- table(groups)
- n <- matrix(n, nrow = nrow(NAs), ncol = ncol(NAs), byrow = TRUE)
- n <- n - NAs
- result$type <- 4
- }
- result$table <- table
- result$statistics <- statistics
- result$n <- n
- if (any(NAs > 0))
- result$NAs <- NAs
- class(result) <- "numSummaryIPSUR"
- result
-}
-
-
-`print.numSummaryIPSUR` <-
-function (x, ...)
-{
- NAs <- x$NAs
- table <- x$table
- n <- x$n
- statistics <- x$statistics
- switch(x$type, "1" = {
- if (!is.null(NAs)) {
- table <- c(table, n, NAs)
- names(table)[length(table) - 1:0] <- c("n", "NA")
- }
- print(table)
- }, "2" = {
- if (statistics == "quantiles") {
- table <- cbind(table, n)
- colnames(table)[ncol(table)] <- "n"
- if (!is.null(NAs)) {
- table <- cbind(table, NAs)
- colnames(table)[ncol(table)] <- "NA"
- }
- }
- else {
- table <- rbind(table, n)
- rownames(table)[c(1, nrow(table))] <- c(statistics,
- "n")
- if (!is.null(NAs)) {
- table <- rbind(table, NAs)
- rownames(table)[nrow(table)] <- "NA"
- }
- table <- t(table)
- }
- print(table)
- }, "3" = {
- table <- cbind(table, n)
- colnames(table)[ncol(table)] <- "n"
- if (!is.null(NAs)) {
- table <- cbind(table, NAs)
- colnames(table)[ncol(table)] <- "NA"
- }
- print(table)
- }, "4" = {
- if (length(dim(table)) == 2) {
- table <- cbind(table, t(n))
- colnames(table)[ncol(table)] <- "n"
- if (!is.null(NAs)) {
- table <- cbind(table, t(NAs))
- colnames(table)[ncol(table)] <- "NA"
- }
- print(table)
- }
- else {
- table <- abind(table, t(n), along = 2)
- dimnames(table)[[2]][dim(table)[2]] <- "n"
- if (!is.null(NAs)) {
- table <- abind(table, t(NAs), along = 2)
- dimnames(table)[[2]][dim(table)[2]] <- "NA"
- }
- nms <- dimnames(table)[[3]]
- for (name in nms) {
- cat("\nVariable:", name, "\n")
- print(table[, , name])
- }
- }
- })
- invisible(x)
-}
+# Last modified Feb 16, 2008
+
+`numSummaryIPSUR` <-
+function (data, statistics = c("mean", "sd", "skewness", "kurtosis",
+ "quantiles"), quantiles = c(0, 0.25, 0.5, 0.75, 1), groups)
+{
+ if (!require(abind))
+ stop("abind package missing")
+ if (!require(e1071))
+ stop("e1071 package missing")
+ data <- as.data.frame(data)
+ if (!missing(groups))
+ groups <- as.factor(groups)
+ variables <- names(data)
+ statistics <- match.arg(statistics, c("mean", "sd", "skewness",
+ "kurtosis", "quantiles"), several.ok = TRUE)
+ ngroups <- if (missing(groups))
+ 1
+ else length(grps <- levels(groups))
+ quantiles <- if ("quantiles" %in% statistics)
+ quantiles
+ else NULL
+ quants <- if (length(quantiles) > 1)
+ paste(100 * quantiles, "%", sep = "")
+ else NULL
+ nquants <- length(quants)
+ stats <- c(c("mean", "sd", "skewness", "kurtosis")[c("mean",
+ "sd", "skewness", "kurtosis") %in% statistics], quants)
+ nstats <- length(stats)
+ nvars <- length(variables)
+ result <- list()
+ if ((ngroups == 1) && (nvars == 1) && (length(statistics) ==
+ 1)) {
+ if (statistics == "quantiles")
+ table <- quantile(data[, variables], probs = quantiles,
+ na.rm = TRUE)
+ else {
+ table <- do.call(statistics, list(x = data[, variables],
+ na.rm = TRUE))
+ names(table) <- statistics
+ }
+ NAs <- sum(is.na(data[, variables]))
+ n <- nrow(data) - NAs
+ result$type <- 1
+ }
+ else if ((ngroups > 1) && (nvars == 1) && (length(statistics) ==
+ 1)) {
+ if (statistics == "quantiles") {
+ table <- matrix(unlist(tapply(data[, variables],
+ groups, quantile, probs = quantiles, na.rm = TRUE)),
+ ngroups, nquants, byrow = TRUE)
+ rownames(table) <- grps
+ colnames(table) <- quants
+ }
+ else table <- tapply(data[, variables], groups, statistics,
+ na.rm = TRUE)
+ NAs <- tapply(data[, variables], groups, function(x) sum(is.na(x)))
+ n <- table(groups) - NAs
+ result$type <- 2
+ }
+ else if ((ngroups == 1)) {
+ table <- matrix(0, nvars, nstats)
+ rownames(table) <- if (length(variables) > 1)
+ variables
+ else ""
+ colnames(table) <- stats
+ if ("mean" %in% stats)
+ table[, "mean"] <- mean(data[, variables], na.rm = TRUE)
+ if ("sd" %in% stats)
+ table[, "sd"] <- sd(data[, variables], na.rm = TRUE)
+ if ("skewness" %in% stats)
+ table[, "skewness"] <- apply(as.matrix(data[, variables]),
+ MARGIN = 2, skewness, na.rm = TRUE)
+ if ("kurtosis" %in% stats)
+ table[, "kurtosis"] <- apply(as.matrix(data[, variables]),
+ MARGIN = 2, kurtosis, na.rm = TRUE)
+ if ("quantiles" %in% statistics) {
+ table[, quants] <- t(apply(data[, variables, drop = FALSE],
+ 2, quantile, probs = quantiles, na.rm = TRUE))
+ }
+ NAs <- colSums(is.na(data[, variables, drop = FALSE]))
+ n <- nrow(data) - NAs
+ result$type <- 3
+ }
+ else {
+ table <- array(0, c(ngroups, nstats, nvars), dimnames = list(Group = grps,
+ Statistic = stats, Variable = variables))
+ NAs <- matrix(0, nvars, ngroups)
+ rownames(NAs) <- variables
+ colnames(NAs) <- grps
+ for (variable in variables) {
+ if ("mean" %in% stats)
+ table[, "mean", variable] <- tapply(data[, variable],
+ groups, mean, na.rm = TRUE)
+ if ("sd" %in% stats)
+ table[, "sd", variable] <- tapply(data[, variable],
+ groups, sd, na.rm = TRUE)
+ if ("skewness" %in% stats)
+ table[, "skewness", variable] <- tapply(data[,
+ variable], groups, skewness, na.rm = TRUE)
+ if ("kurtosis" %in% stats)
+ table[, "kurtosis", variable] <- tapply(data[,
+ variable], groups, kurtosis, na.rm = TRUE)
+ if ("quantiles" %in% statistics) {
+ res <- matrix(unlist(tapply(data[, variable],
+ groups, quantile, probs = quantiles, na.rm = TRUE)),
+ ngroups, nquants, byrow = TRUE)
+ table[, quants, variable] <- res
+ }
+ NAs[variable, ] <- tapply(data[, variable], groups,
+ function(x) sum(is.na(x)))
+ }
+ if (nstats == 1)
+ table <- table[, 1, ]
+ if (nvars == 1)
+ table <- table[, , 1]
+ n <- table(groups)
+ n <- matrix(n, nrow = nrow(NAs), ncol = ncol(NAs), byrow = TRUE)
+ n <- n - NAs
+ result$type <- 4
+ }
+ result$table <- table
+ result$statistics <- statistics
+ result$n <- n
+ if (any(NAs > 0))
+ result$NAs <- NAs
+ class(result) <- "numSummaryIPSUR"
+ result
+}
+
+
+`print.numSummaryIPSUR` <-
+function (x, ...)
+{
+ NAs <- x$NAs
+ table <- x$table
+ n <- x$n
+ statistics <- x$statistics
+ switch(x$type, "1" = {
+ if (!is.null(NAs)) {
+ table <- c(table, n, NAs)
+ names(table)[length(table) - 1:0] <- c("n", "NA")
+ }
+ print(table)
+ }, "2" = {
+ if (statistics == "quantiles") {
+ table <- cbind(table, n)
+ colnames(table)[ncol(table)] <- "n"
+ if (!is.null(NAs)) {
+ table <- cbind(table, NAs)
+ colnames(table)[ncol(table)] <- "NA"
+ }
+ }
+ else {
+ table <- rbind(table, n)
+ rownames(table)[c(1, nrow(table))] <- c(statistics,
+ "n")
+ if (!is.null(NAs)) {
+ table <- rbind(table, NAs)
+ rownames(table)[nrow(table)] <- "NA"
+ }
+ table <- t(table)
+ }
+ print(table)
+ }, "3" = {
+ table <- cbind(table, n)
+ colnames(table)[ncol(table)] <- "n"
+ if (!is.null(NAs)) {
+ table <- cbind(table, NAs)
+ colnames(table)[ncol(table)] <- "NA"
+ }
+ print(table)
+ }, "4" = {
+ if (length(dim(table)) == 2) {
+ table <- cbind(table, t(n))
+ colnames(table)[ncol(table)] <- "n"
+ if (!is.null(NAs)) {
+ table <- cbind(table, t(NAs))
+ colnames(table)[ncol(table)] <- "NA"
+ }
+ print(table)
+ }
+ else {
+ table <- abind(table, t(n), along = 2)
+ dimnames(table)[[2]][dim(table)[2]] <- "n"
+ if (!is.null(NAs)) {
+ table <- abind(table, t(NAs), along = 2)
+ dimnames(table)[[2]][dim(table)[2]] <- "NA"
+ }
+ nms <- dimnames(table)[[3]]
+ for (name in nms) {
+ cat("\nVariable:", name, "\n")
+ print(table[, , name])
+ }
+ }
+ })
+ invisible(x)
+}
More information about the IPSUR-commits
mailing list