[Gmpm-commits] r15 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Feb 23 02:26:51 CET 2010
Author: dalebarr
Date: 2010-02-23 02:26:51 +0100 (Tue, 23 Feb 2010)
New Revision: 15
Added:
pkg/R/gmpm.R
pkg/man/GMPM-class.Rd
pkg/man/GMPMSummary-class.Rd
pkg/man/gmpm.Rd
pkg/man/gmpmCoef.Rd
pkg/man/gmpmCtrl.Rd
Removed:
pkg/R/gmp.R
pkg/man/Gmp-class.Rd
pkg/man/GmpSummary-class.Rd
pkg/man/gmp.Rd
pkg/man/gmpCoef.Rd
pkg/man/gmpCtrl.Rd
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/basemethods.R
pkg/R/generics.R
pkg/R/helpers.R
pkg/R/mdtest.R
pkg/man/fitOnce.Rd
pkg/man/getFactorCodes.Rd
pkg/man/getMainSummary.Rd
pkg/man/getModelFrame.Rd
pkg/man/getNExceeding.Rd
pkg/man/getPValue.Rd
pkg/man/getPermMx.Rd
pkg/man/getRegSummary.Rd
pkg/man/gmpm-package.Rd
pkg/man/kb07.Rd
pkg/man/mdTest.Rd
pkg/man/origFit.Rd
pkg/man/permSpace.Rd
pkg/man/permute.Rd
Log:
MAJOR UPDATE:
gmpm now does synchronized permutations!
changed gmp to gmpm
changed gmpCreate to gmpmCreate
changed gmpFit to gmpmEstimate
changed gmpCoef to gmpmCoef
changed class name to GMPM
updated all documentation
TO DO: fix mdTest(GMPM,vector-method)
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2009-09-16 14:48:56 UTC (rev 14)
+++ pkg/DESCRIPTION 2010-02-23 01:26:51 UTC (rev 15)
@@ -1,11 +1,11 @@
Package: gmpm
Type: Package
Title: Generalized Multilevel Permutation Models
-Version: 0.1-5
-Date: 2009-09-16
-Author: Dale Barr <dale.barr at ucr.edu>
-Maintainer: Dale Barr <dale.barr at ucr.edu>
-Description: Permutation methods for testing hypotheses on various types of multilevel data
+Version: 0.4-0
+Date: 2010-02-22
+Author: Dale Barr <dalejbarr3 at gmail.com>
+Maintainer: Dale Barr <dalejbarr3 at gmail.com>
+Description: Permutation methods for testing hypotheses on multilevel experimental data
License: GPL (>=2)
LazyLoad: yes
Depends: methods
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2009-09-16 14:48:56 UTC (rev 14)
+++ pkg/NAMESPACE 2010-02-23 01:26:51 UTC (rev 15)
@@ -1,7 +1,7 @@
export(
- "gmp",
- "gmpCreate",
- "gmpCtrl"
+ "gmpm",
+ "gmpmCreate",
+ "gmpmCtrl"
)
exportMethods(
@@ -11,10 +11,10 @@
"getPermMx",
"getPValue",
"getRegSummary",
- "gmpCoef",
+ "gmpmCoef",
"getModelFrame",
"getFactorCodes",
- "gmpFit",
+ "gmpmEstimate",
"mdTest",
"origFit",
"permSpace",
@@ -24,11 +24,11 @@
)
exportClasses(
- "Gmp",
- "Gmp.glm",
- "Gmp.mul",
- "GmpSummary",
- "Gmp.user",
+ "GMPM",
+ "GMPM.glm",
+ "GMPM.mul",
+ "GMPMSummary",
+ "GMPM.user",
"Mdtest",
"Mdtest.sum"
)
Modified: pkg/R/basemethods.R
===================================================================
--- pkg/R/basemethods.R 2009-09-16 14:48:56 UTC (rev 14)
+++ pkg/R/basemethods.R 2010-02-23 01:26:51 UTC (rev 15)
@@ -1,11 +1,11 @@
-setClass("Gmp",
+setClass("GMPM",
representation(
df1="data.frame", # the model.frame
dform="formula", # design formula (including covars)
mform="formula", # full model formula
munit="character", # multilevel sampling unit
nunits="numeric", # number of units sampled
- gmpControl="list", # control of fitting functions
+ gmpmControl="list", # control of fitting functions
fitcall="list", # call to fitting function
famtype="character", # type of data
DVname="character", # name of DV
@@ -15,47 +15,53 @@
nBetween="numeric", # nBetween unit variables
ivWithin="character", # list of within IVs
ivBetween="character", # list of between IVs
+ minN="numeric", # nObs in smallest cell in design
ivars="vector", # list of names of IVs
IVcoef="list", # names of factor vars in glm output
covars="character", # list of names of covars
coefTerms="list", # names of variables from fit output
# w/interactions separated.
- psBetween="data.frame", # permn scheme (Betw unit IVs)
+ psBetween="list", # permn scheme (Betw unit IVs)
psWithin="list", # permutation scheme (Within unit IVs)
+ nwrep="numeric", # n. within reps per withinIV
pspace="numeric", # size of permutation space
+ nSections="numeric", # number of permutation sections for estimation
+ psec="list", # permutation sections
+
pmx="matrix", # matrix of permutation coefficients
nCellsPerUnit="numeric", # nCells per sampling unit
ncomp="numeric", # n of runs completed
+ ndigits="numeric", # n of digits to round p value to
"VIRTUAL"), # factor matrix for the model
prototype=prototype(
nunits=1, nWithin=0, nBetween=0, ncomp=0),
)
-setClass(Class="GmpSummary",
+setClass(Class="GMPMSummary",
representation(
- gmpInfo="list", # misc. info about Gmp object
- gmpMainSum="list", # list of data frames
+ gmpmInfo="list", # misc. info about gmpm object
+ gmpmMainSum="list", # list of data frames
# with summary info
- gmpRegSum="list", # main regression
+ gmpmRegSum="list", # main regression
showReg="logical" # whether to show reg coef?
),
prototype(showReg=FALSE)
)
setClass(
- Class="Gmp.glm",
+ Class="GMPM.glm",
representation(
coef0="numeric", # vector of original coefficients
family="list"
),
- contains="Gmp"
+ contains="GMPM"
)
setClass(
- Class="Gmp.mul",
+ Class="GMPM.mul",
representation(
coef0="matrix", # vector of original coefficients
family="character",
@@ -63,34 +69,34 @@
convergence="vector" # did it converge?
),
prototype(family="multinomial",famtype="multinomial"),
- contains="Gmp"
+ contains="GMPM"
)
setClass(
- Class="Gmp.user",
+ Class="GMPM.user",
representation(
family="character"
),
prototype(family="user",famtype="user"),
- contains="Gmp"
+ contains="GMPM"
)
setMethod("initialize",
- signature(.Object = "Gmp"),
+ signature(.Object = "GMPM"),
function (.Object,
formula, family, data,
- ivars, gmpControl)
+ ivars, gmpmControl)
{
-# print(">>>> initializing (Gmp)")
+# print(">>>> initializing (GMPM)")
return(.Object)
}
)
setMethod("initialize",
- signature(.Object="Gmp.glm"),
+ signature(.Object="GMPM.glm"),
function(.Object, family=gaussian, ...)
{
-# print(">>>> initializing (Gmp.glm)")
+# print(">>>> initializing (GMPM.glm)")
if (is.character(family)) {
family <- get(family, mode = "function",
envir = globalenv())
@@ -127,10 +133,10 @@
)
setMethod("initialize",
- signature(.Object="Gmp.mul"),
+ signature(.Object="GMPM.mul"),
function(.Object, ...)
{
-# print(">>>> initializing (Gmp.mul)")
+# print(">>>> initializing (GMPM.mul)")
# callNextMethod()
require(nnet)
return(.Object)
@@ -138,33 +144,33 @@
)
setMethod("initialize",
- signature(.Object="Gmp.user"),
+ signature(.Object="GMPM.user"),
function(.Object, ...)
{
-# print(">>>> initializing (Gmp.user)")
+# print(">>>> initializing (GMPM.user)")
cat("Warning: User must supply fitting function (see ?createCall for details).\n")
return(.Object)
}
)
setMethod("initialize",
- signature(.Object="GmpSummary"),
- function(.Object, gmpInfo, gmpMainSum=NULL, gmpRegSum=NULL)
+ signature(.Object="GMPMSummary"),
+ function(.Object, gmpmInfo, gmpmMainSum=NULL, gmpmRegSum=NULL)
{
-# print(">>>> initializing (GmpSummary)")
- .Object at gmpInfo <- gmpInfo
- if (!is.null(gmpMainSum)) {
- .Object at gmpMainSum <- gmpMainSum
+# print(">>>> initializing (GMPMSummary)")
+ .Object at gmpmInfo <- gmpmInfo
+ if (!is.null(gmpmMainSum)) {
+ .Object at gmpmMainSum <- gmpmMainSum
} else {}
- if (!is.null(gmpRegSum)) {
- .Object at gmpRegSum <- gmpRegSum
+ if (!is.null(gmpmRegSum)) {
+ .Object at gmpmRegSum <- gmpmRegSum
} else {}
return(.Object)
}
)
setMethod("show",
- signature(object = "Gmp"),
+ signature(object = "GMPM"),
function (object)
{
xsum <- summary(object)
@@ -174,7 +180,7 @@
)
#setMethod("coef",
-# signature(object = "Gmp"),
+# signature(object = "GMPM"),
# function (object)
# {
# return(gmpCoef(object))
@@ -182,7 +188,7 @@
#)
#setMethod("coefficients",
-# signature(object = "Gmp"),
+# signature(object = "GMPM"),
# function (object)
# {
# return(gmpCoef(object))
@@ -190,11 +196,11 @@
#)
setMethod("show",
- signature(object = "GmpSummary"),
+ signature(object = "GMPMSummary"),
function(object)
{
cat("\n")
- x <- object at gmpInfo
+ x <- object at gmpmInfo
if (x$nunits == 1) {
cat("Single-level data with", x$nobs, "observations.\n\n")
@@ -241,7 +247,7 @@
}
print(dft)
} else {
- x <- object at gmpRegSum
+ x <- object at gmpmRegSum
if (length(x) > 0) {
cat("Summary of Individual Regression Parameters:\n")
if (length(x) == 1) {
@@ -265,7 +271,7 @@
cat("\n")
# now come the main results
- mainSum <- object at gmpMainSum
+ mainSum <- object at gmpmMainSum
nSections <- length(mainSum)
if (nSections > 0) {
cat(">>>>>>>>> SUMMARY OF MAIN RESULTS <<<<<<<<<\n\n")
@@ -288,13 +294,13 @@
}
cat("\n")
- if (object at gmpInfo$ncomp > 1) {
- cat("All p-values based on", object at gmpInfo$ncomp,
- "Monte Carlo samples\n",
- "from ", object at gmpInfo$pspace,
- "possible permutations.\n\n")
+ if (object at gmpmInfo$ncomp > 1) {
+ cat("All p-values based on", object at gmpmInfo$ncomp,
+ "Monte Carlo samples\n\n")
+ #"from ", object at gmpmInfo$pspace,
+ # "possible permutations.\n\n")
- if (object at gmpInfo$ncomp < 999) {
+ if (object at gmpmInfo$ncomp < 999) {
cat("Warning: Too few Monte Carlo samples for reliable p-values.\n", "Consider increasing 'maxruns'.\n")
} else {}
}
@@ -302,31 +308,31 @@
)
setMethod("summary",
- signature(object = "Gmp"),
+ signature(object = "GMPM"),
function (object, showReg=FALSE, ...)
{
-# print("~~~ in summary (Gmp) ~~~")
+# print("~~~ in summary (GMPM) ~~~")
x <- object
- gmpInfo <- list()
- gmpInfo$nunits <- x at nunits
- gmpInfo$nobs <- dim(x at df1)[1]
- gmpInfo$munit <- x at munit
- gmpInfo$DVname <- x at DVname
- gmpInfo$famtype <- x at famtype
- gmpInfo$IVinfo <- x at IVinfo
- gmpInfo$mform <- x at mform
- gmpInfo$ncomp <- x at ncomp
- gmpInfo$pspace <- x at pspace
- gmpInfo$coef0 <- x at coef0
- gmpInfo$covars <- x at covars
+ gmpmInfo <- list()
+ gmpmInfo$nunits <- x at nunits
+ gmpmInfo$nobs <- dim(x at df1)[1]
+ gmpmInfo$munit <- x at munit
+ gmpmInfo$DVname <- x at DVname
+ gmpmInfo$famtype <- x at famtype
+ gmpmInfo$IVinfo <- x at IVinfo
+ gmpmInfo$mform <- x at mform
+ gmpmInfo$ncomp <- x at ncomp
+ gmpmInfo$pspace <- x at pspace
+ gmpmInfo$coef0 <- x at coef0
+ gmpmInfo$covars <- x at covars
if (x at famtype == "multinomial") {
- gmpInfo$DVlevels <- .getDVlevels(x)
+ gmpmInfo$DVlevels <- .getDVlevels(x)
}
if (x at ncomp <= 1) {
- xsum <- new("GmpSummary",
- gmpInfo)
+ xsum <- new("GMPMSummary",
+ gmpmInfo)
xsum at showReg <- FALSE
} else {
# build main summary.
@@ -339,12 +345,12 @@
# build regression summary.
if (showReg) {
- gmpRegSum <- getRegSummary(object)
+ gmpmRegSum <- getRegSummary(object)
} else {
- gmpRegSum <- data.frame()
+ gmpmRegSum <- data.frame()
}
- gmpMainSum <- list()
+ gmpmMainSum <- list()
faclist <-
attr(attr(x at df1,"terms"),"factors")[-1,]
if (is.vector(faclist)) {
@@ -365,16 +371,16 @@
nTests <- dim(faclist)[2]
}
# build main summary
- gmpMainSum <-
+ gmpmMainSum <-
getMainSummary(x)
- xsum <- new("GmpSummary",
- gmpInfo, gmpMainSum, gmpRegSum)
+ xsum <- new("GMPMSummary",
+ gmpmInfo, gmpmMainSum, gmpmRegSum)
xsum at showReg = showReg
}
-# print("... exiting summary (Gmp) ...")
+# print("... exiting summary (GMPM) ...")
return(xsum)
}
)
Modified: pkg/R/generics.R
===================================================================
--- pkg/R/generics.R 2009-09-16 14:48:56 UTC (rev 14)
+++ pkg/R/generics.R 2010-02-23 01:26:51 UTC (rev 15)
@@ -34,12 +34,12 @@
def=function(x, byCovar=FALSE) {standardGeneric(".prepareMainSum")})
setGeneric(name=".mainSumProc",
- def=function(x, faclist, allvars, nTests, pmx) {
+ def=function(x, faclist, allvars, nTests, psec) {
standardGeneric(".mainSumProc")
})
setGeneric(name=".regSumProc",
- def=function(x, pmx, index) {
+ def=function(x, psec, index) {
standardGeneric(".regSumProc")
})
@@ -64,12 +64,12 @@
)
setGeneric(name=".storeFitResult",
- def=function(x, fit, index) {
+ def=function(x, fit, section, index) {
standardGeneric(".storeFitResult")}
)
setGeneric(name=".reportProgress",
- def=function(x, myFit, ix, maxruns, elapsed) {
+ def=function(x, ix, maxruns, elapsed) {
standardGeneric(".reportProgress")}
)
@@ -79,15 +79,15 @@
standardGeneric(".createPermMx")}
)
-setGeneric(name="gmpCoef",
- def=function(x){standardGeneric("gmpCoef")})
+setGeneric(name="gmpmCoef",
+ def=function(x){standardGeneric("gmpmCoef")})
#setGeneric(name="coef",
# def=function(x){standardGeneric("coef")})
setGeneric(
name="permute",
- def=function(x){standardGeneric("permute")}
+ def=function(x, thisiv){standardGeneric("permute")}
)
setGeneric(
@@ -164,11 +164,24 @@
)
setGeneric(
- name="gmpFit",
- def=function(object,gmpControl){standardGeneric("gmpFit")})
+ name="gmpmFit",
+ def=function(object,gmpmControl){
+ standardGeneric("gmpmFit")})
setGeneric(name="getPermMx",
def=function(x){standardGeneric("getPermMx")})
setGeneric(name="coefNames",
def=function(x){standardGeneric("coefNames")})
+
+setGeneric(name="gmpmEstimate",
+ def=function(x,gmpmControl){
+ standardGeneric("gmpmEstimate")})
+
+setGeneric(name=".createMatrixSections",
+ def=function(x,pmx){
+ standardGeneric(".createMatrixSections")})
+
+setGeneric(name=".collapseMultinomPmx",
+ def=function(x,index){
+ standardGeneric(".collapseMultinomPmx")})
Deleted: pkg/R/gmp.R
===================================================================
--- pkg/R/gmp.R 2009-09-16 14:48:56 UTC (rev 14)
+++ pkg/R/gmp.R 2010-02-23 01:26:51 UTC (rev 15)
@@ -1,1264 +0,0 @@
-setMethod(".initFinal",
- signature(object="Gmp"),
- function(object) {
- return(object)
- })
-
-setMethod(".initFinal",
- signature(object="Gmp.mul"),
- function(object) {
-
- # make sure that if it is a single variable, it is coded as a factor
- if (length(grep("cbind", object at DVname))==0) {
- if (!is.matrix(object at df1[,object at DVname])) {
- if (!is.factor(object at df1[,object at DVname])) {
- object at df1[,object at DVname] <- factor(object at df1[,object at DVname])
- warning("Converting '", object at DVname, "' to a factor")
- } else {}
- } else {}
- } else {}
-
- return(object)
- })
-
-setMethod("getModelFrame",
- signature(object="Gmp"),
- function(object) {
- return(object at df1)
- })
-
-setMethod("getFactorCodes",
- signature(object="Gmp"),
- function(object) {
- ivs <- object at ivars
- nIVs <- length(object at ivars)
- fcodes <- list()
- for (i in 1:nIVs) {
- mx <- attr(object at df1[,ivs[i]],"contrasts")
- colnames(mx) <- object at IVcoef[[ivs[i]]]
- fcodes[[ivs[i]]] <- mx
- }
- return(fcodes)
- })
-
-setMethod(".getFactorLabelsFromFit",
- signature(object="Gmp"),
- function(object, ivar) {
- fcall <- as.list(object at fitcall)
- dform <- object at dform
- lhs <- strsplit(deparse(dform), "~")[[1]][1]
- for (i in 1:length(object at ivars)) {
- nform <- paste(lhs, "~", object at ivars[i], sep="")
- fcall$formula <- nform
- if (object at famtype == "multinomial") {
- capture.output(nn1 <- colnames(coef(eval(as.call(fcall)))))
- } else {
- nn1 <- names(coef(eval(as.call(fcall))))
- }
- object at IVcoef[[object at ivars[i]]] <- nn1[2:length(nn1)]
- }
- return(object at IVcoef)
- })
-
-setMethod(".getPredictorsFromFaclist",
- signature(x="Gmp"),
- function(x, faclist, allvars, nTests, j) {
- if (nTests > 1) {
- ivinc <- allvars[faclist[,j]==1]
- } else {
- ivinc <- allvars
- }
-
- if (length(intersect(ivinc, x at covars)) > 1) {
- # there is more than one co-variate in the term.
- # we need to perform a union rather than an intersection
- cvartmp <- intersect(ivinc, x at covars)
- cvars <- c()
- ivartmp <- intersect(ivinc, x at ivars)
- for (i in 1:length(cvartmp)) {
- cvars <- c(cvars, .getIXfromIV(x, c(ivartmp, cvartmp[i]), TRUE))
- }
- } else {
- cvars <- .getIXfromIV(x, ivinc, TRUE)
- }
-
- return(cvars)
- })
-
-setMethod("testDV",
- signature(x="Gmp.mul"),
- function(x, excludeLevels, byCovar=FALSE) {
- DVlevels <- .getDVlevels(x)
- if (!missing(excludeLevels)) {
- if (is.character(excludeLevels)) {
- excludeLevels <- c(excludeLevels)
- } else {}
- if (DVlevels[1] %in% excludeLevels) {
- stop("Can't exclude baseline level '", DVlevels[1], "' from analysis.")
- } else {}
- ltest <- setdiff(DVlevels[2:length(DVlevels)], excludeLevels)
- if (length(ltest) < 2) {
- stop("Only ", length(ltest), " regions to test.\nMinimum of 2 required.")
- }
- } else {
- ltest <- DVlevels[2:length(DVlevels)]
- }
- ff <- .prepareMainSum(x, byCovar)
- nTests <- ff$nTests
- nDiffs <- length(ltest)-1
- pwid <- dim(x at pmx)[3]
- mx <- matrix(nrow=dim(x at pmx)[1], ncol=nDiffs*pwid)
- colnames(mx) <- rep(dimnames(x at pmx)$coef, nDiffs)
- newDVname <- paste("(",
- paste(c(DVlevels[1], ltest), collapse=",", sep=""),
- ")", sep="")
- for (k in 1:nDiffs) {
- ix0 <- (k-1)*(pwid)+1
- ix1 <- ix0+pwid-1
- mx[,ix0:ix1] <- x at pmx[,ltest[1],]-x at pmx[,ltest[k+1],]
- }
- mlist <- list()
- for (j in 1:nTests) {
- cvars <- .getPredictorsFromFaclist(x, ff$faclist, ff$allvars, ff$nTests, j)
- ctest <- cvars + rep(rep(0:(nDiffs-1))*pwid, each=length(cvars))
- tname <- paste(colnames(ff$faclist)[j], ":", newDVname, sep="")
- mlist[[tname]] <- ctest
- }
- return(mdTest(mx, mlist))
- })
-
-setMethod(".getDVlevels",
- signature(x="Gmp.mul"),
- function(x) {
- if(length(grep("cbind", x at DVname))>0) {
- f1 <- strsplit(x at DVname, "\\(")[[1]][2]
- f2 <- gsub(")", "", f1)
- f3 <- gsub(" ", "", f2)
- return(strsplit(f3, ",")[[1]])
- }
-
- if (is.matrix(x at df1[,x at DVname]))
- return(colnames(x at df1[,x at DVname]))
- else if (is.factor(x at df1[,x at DVname]))
- return(levels(x at df1[,x at DVname]))
- else {}
-
- stop("unsure of how DV '",x at DVname,"' is represented\n",
- "(was not factor, matrix, or cbind.)")
- })
-
-setMethod(".writeFit",
- signature(x="Gmp"),
- function(x, y, outfile, append) {
- cat(y, "\n", file=outfile, append=append)
- })
-
-setMethod(".writeFit",
- signature(x="Gmp.mul"),
- function(x, y, outfile, append) {
- nRows <- dim(y)[1]
- for (i in 1:nRows) {
- cat(y[i,], " ", file=outfile, append=append)
- }
- cat("\n", file=outfile, append=TRUE)
- })
-
-setMethod("appendToPmx",
- signature(x="Gmp", y="Gmp"),
- function(x, y) {
- nameObject <- deparse(substitute(x))
- if (length(dim(x)) != length(dim(y))) {
- cat("Gmp source object permutation matrix has dimensions ", dim(y),
- "\n")
- cat("Gmp destination object permutation matrix has dimensions ", dim(x),
- "\n")
- stop("These Gmp objects do not look the same.")
- }
- pmxSrc <- getPermMx(y)[-1,]
- pmxThis <- getPermMx(x)
- if (dim(pmxThis)[1]==0) {
- x at pmx <- getPermMx(y)
- } else {
- x at pmx <- rbind(pmxThis, pmxSrc)
- }
- cat("appended ", length(pmxSrc[,1]), " rows\n")
- x at ncomp <- dim(x at pmx)[1]-1
- warning("Error checking not implemented yet; \nPlease ensure these two Gmp objects have the same underlying model / data.")
- assign(nameObject, x, envir=parent.frame())
- return(invisible(x))
- })
-
-setMethod("appendToPmx",
- signature(x="Gmp", y="character"),
- function(x, y) {
- nameObject <- deparse(substitute(x))
- ff <- read.table(y)
- pmxSrc <- as.matrix(ff[-1,])
- rownames(pmxSrc) <- NULL
- pmxThis <- getPermMx(x)
- if (dim(pmxThis)[1]==0) {
- pmxSrc <- as.matrix(ff)
- colnames(pmxSrc) <- colnames(x at coef0)
- x at pmx <- pmxSrc
- } else {
- colnames(pmxSrc) <- colnames(pmxThis)
- x at pmx <- rbind(pmxThis, pmxSrc)
- }
- x at ncomp <- dim(x at pmx)[1]-1
- cat("appended ", length(pmxSrc[,1]), " rows\n")
-
- assign(nameObject, x, envir=parent.frame())
- return(invisible(x))
- })
-
-setMethod("appendToPmx",
- signature(x="Gmp.mul", y="Gmp"),
- function(x, y) {
- nameObject <- deparse(substitute(x))
- if (length(dim(x)) != length(dim(y))) {
- cat("Gmp source object permutation matrix has dimensions ", dim(y),
- "\n")
- cat("Gmp destination object permutation matrix has dimensions ", dim(x),
- "\n")
- stop("These Gmp objects do not look the same.")
- }
- pmxSrc <- getPermMx(y)[-1,,]
- srclen <- dim(pmxSrc)[1]
- pmxThis <- getPermMx(x)
- destlen <- dim(pmxThis)[1]
- nDVlevels <- dim(x at coef0)[1]
- nCoef <- dim(x at coef0)[2]
- dmn <- c("run","dv","coef")
- if (destlen > 0) {
- x at pmx <- array(dim=c(srclen+destlen,nDVlevels,nCoef),
- dimnames=dmn)
- x at pmx[1:destlen,,] <- pmxThis
- x at pmx[(destlen+1):(srclen+destlen),,] <- pmxSrc
- } else {
- pmxSrc <- getPermMx(y)
- srclen <- dim(pmxSrc)[1]
- x at pmx <- getPermMx(y)
- }
- cat("appended ", srclen, " rows\n")
- x at ncomp <- dim(x at pmx)[1]-1
- warning("Error checking not implemented yet; \nPlease ensure these two Gmp objects have the same underlying model / data.")
- assign(nameObject, x, envir=parent.frame())
- return(invisible(x))
- })
-
-setMethod("appendToPmx",
- signature(x="Gmp.mul", y="character"),
- function(x, y) {
- nameObject <- deparse(substitute(x))
- ff <- read.table(y)
- pmxSrc <- as.matrix(ff[-1,])
- rownames(pmxSrc) <- NULL
- pmxThis <- getPermMx(x)
- colnames(pmxSrc) <- colnames(pmxThis)
- x at pmx <- rbind(pmxThis, pmxSrc)
- x at ncomp <- dim(x at pmx)[1]-1
- cat("appended ", length(pmxSrc[,1]), " rows\n")
-
- assign(nameObject, x, envir=parent.frame())
- return(invisible(x))
- })
-
-setMethod(".prepareMainSum",
- signature(x="Gmp"),
- function(x, byCovar=FALSE) {
-
- # figure out tests we need to run from model frame
- faclist <-
- attr(attr(x at df1,"terms"),"factors")[-1,]
- if (is.vector(faclist)) {
- allvars <- x at ivars
- nTests <- 1
- } else {
- allvars <- rownames(faclist)
- nTests <- dim(faclist)[2]
- }
-
- # do not test main effects of covars
- if (length(x at covars) > 0) {
- m <- match(x at covars, colnames(faclist))
- m <- m[!is.na(m)]
- faclist <- faclist[,-m]
- }
-
- if ((!byCovar) && (length(x at covars) > 1)) {
- fl1 <- faclist[x at covars[-1],]
- if (is.vector(fl1)) {
- test1 <- fl1==0
- } else {
- test1 <- colSums(fl1)==0
- }
- newfl <- faclist[,faclist[x at covars[1],]==1 | test1]
- r1 <- newfl[x at covars[1],]
- c1 <- names(r1)[r1==1]
- newfl[x at covars[-1],c1] <- 1
- flnames <- strsplit(colnames(newfl), ":")
- srep <- paste("(",paste(x at covars, collapse=","),")",sep="")
- ncn <- rep("", length(flnames))
- for (i in 1:length(flnames)) {
- flnames[[i]][flnames[[i]]==x at covars[1]] <- srep
- ncn[i] <- paste(flnames[[i]],collapse=":",sep="")
- }
- colnames(newfl) <- ncn
- faclist <- newfl
- }
-
- if (is.vector(faclist)) {
- nTests <- 1
- } else {
- nTests <- dim(faclist)[2]
- }
-
- return(list(faclist=faclist,
- allvars=allvars,
- nTests=nTests))
- })
-
-setMethod(".regSumProc",
- signature(x="Gmp"),
- function(x, pmx, index) {
- #print("~~~ in .regSumProc ~~~")
- coef0 <- pmx[1,]
- ctest <- 1:length(coef0) %in% index
-
- c2 <- coef0
- se <- rep(NA, length(c2))
- nexceed <- rep(NA, length(c2))
- pval <- rep(NA, length(c2))
- for (i in 1:length(c2)) {
- if (ctest[i]) {
- se[i] <- sd(pmx[,i])
- nexceed[i] <- getNExceeding(pmx, i)
- pval[i] <- getPValue(pmx, i)
- }
- }
-
- c2 <- round(c2,4)
- se <- round(se,4)
- pval <- round(pval,4)
- gmpRegSum <- data.frame(Coef=names(c2),
- Estimate=c2, se, nexceed,
- pval, .getSig(pval))
- rownames(gmpRegSum) <- 1:length(c2)
- colnames(gmpRegSum) <- c("Coefficient", "Estimate",
- "Std. Error", "N>=orig", "p-value", " ")
- return(gmpRegSum)
- })
-
-setMethod("getRegSummary",
- signature(x="Gmp"),
- function(x) {
- ff <- list(.regSumProc(x, x at pmx, x at ivix))
- names(ff) <- "Main Regression"
- return(ff)
- })
-
-setMethod("getRegSummary",
- signature(x="Gmp.mul"),
- function(x) {
- #print("~~~ in getRegSummary (Gmp.mul) ~~~")
- mlist <- list()
- DVlevels <- .getDVlevels(x)
- nDVlevels <- dim(x at coef0)[1]
- mnames <- paste(DVlevels[2:length(DVlevels)], DVlevels[1],
- sep=" versus ")
- for (i in 1:nDVlevels) {
- mlist[[i]] <- .regSumProc(x, x at pmx[,i,], x at ivix)
- }
- names(mlist) <- mnames
- #print("... exiting getMainSummary (Gmp.mul) ...")
- return(mlist)
-
- })
-
-setMethod(".mainSumProc",
- signature(x="Gmp"),
- function(x, faclist, allvars, nTests, pmx) {
- #print("~~~ in .mainSumProc ~~~")
-
- coef0 <- pmx[1,]
- nge <- rep(NA, nTests)
- pval <- rep(NA, nTests)
- mcoef <- rep(NA, nTests)
-
- for (j in 1:nTests) {
- cvars <- .getPredictorsFromFaclist(x, faclist, allvars, nTests, j)
-
- if (length(cvars) > 1) {
- mdt <- mdTest(pmx, cvars)
- nge[j] <- .getResults(mdt, 1, "nge")
- pval[j] <- .getResults(mdt, 1, "pval")
- mcoef[j] <- paste(.getResults(mdt, 1, "ix"), collapse=",", sep="")
- } else {
- nge[j] <- getNExceeding(pmx, cvars[1])
- pval[j] <- getPValue(pmx, cvars[1])
- mcoef[j] <- cvars[1]
- }
- ##############################################
- }
-
- gmpMainSum <- data.frame(mcoef, nge, pval, .getSig(pval))
- colnames(gmpMainSum) <- c("Coef","N>=Orig","p-value", " ")
- if (nTests > 1) {
- rownames(gmpMainSum) <- colnames(faclist)
- } else {
- rownames(gmpMainSum) <- x at ivars
- }
-
- if (length(x at covars) > 0) {
- vv <- faclist[!(rownames(faclist) %in% x at ivars),]
- if (!is.vector(vv)) {
- vv <- as.vector(colSums(vv))
- vv[vv>1] <- 1
- }
- gmpMainSum <- gmpMainSum[order(vv),]
- }
-
- #print("... exiting .mainSumProc ...")
- return(gmpMainSum)
- })
-
-setMethod("getMainSummary",
- signature(x="Gmp"),
- function(x, byCovar=FALSE) {
- gg <- .prepareMainSum(x, byCovar)
- faclist <- gg[["faclist"]]
- allvars <- gg[["allvars"]]
- nTests <- gg[["nTests"]]
- #print("~~~ in getMainSummary (Gmp) ~~~")
- ff <- list(.mainSumProc(x, faclist, allvars, nTests, x at pmx))
- names(ff) <- c("Main Results")
- #print("... exiting getMainSummary Gmp) ...")
- return(ff)
- })
-
-setMethod("getMainSummary",
- signature(x="Gmp.mul"),
- function(x, byCovar=FALSE) {
- #print("~~~ in getMainSummary (Gmp.mul) ~~~")
- gg <- .prepareMainSum(x, byCovar)
- faclist <- gg[["faclist"]]
- allvars <- gg[["allvars"]]
- nTests <- gg[["nTests"]]
- mlist <- list()
- DVlevels <- .getDVlevels(x)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gmpm -r 15
More information about the Gmpm-commits
mailing list