├── MCMCglmm-utils.R ├── R-utils.R ├── README.org ├── mer-utils.R └── regression-utils.R /MCMCglmm-utils.R: -------------------------------------------------------------------------------- 1 | vif.MCMCglmm <- function (fit, intercept.columns = c(1)) { 2 | nF <- fit$Fixed$nfl 3 | v <- cov(as.matrix(fit$X[,1:nF])) 4 | nam <- colnames(fit$Sol[,1:nF]) 5 | 6 | v <- v[-intercept.columns, -intercept.columns, drop = FALSE] 7 | nam <- nam[-intercept.columns] 8 | 9 | d <- diag(v)^0.5 10 | v <- diag(solve(v/(d %o% d))) 11 | names(v) <- nam 12 | v 13 | } 14 | 15 | kappa.MCMCglmm <- function (fit, add.intercept = TRUE, scale = TRUE, intercept.columns = c(1)) { 16 | nF <- fit$Fixed$nfl 17 | X <- fit$X[,1:nF] 18 | if (with.intercept & scale) { 19 | kappa(cBind(rep(1), scale(X[, -intercept.columns]))) 20 | } else if (with.intercept & !scale) { 21 | kappa(X) 22 | } else if (!add.intercept & scale) { 23 | kappa(scale(X[,-intercept.columns])) 24 | } else { 25 | kappa(X[,-intercept.columns]) 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /R-utils.R: -------------------------------------------------------------------------------- 1 | as.numeric.factor <- function (x) as.numeric(as.character.factor(x)) 2 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: README.org 2 | #+AUTHOR: Austin F. Frank 3 | #+EMAIL: austin.frank@gmail.com 4 | #+DATE: 2011-02-24 Thu 5 | #+OPTIONS: H:3 num:t toc:t \n:nil @:t ::t |:t ^:t -:t f:t *:t <:t 6 | #+OPTIONS: TeX:t LaTeX:t skip:nil d:nil todo:t pri:nil tags:not-in-toc 7 | 8 | When I find I'm using the same functions on more than one project, I 9 | factor them out and keep them here. 10 | -------------------------------------------------------------------------------- /mer-utils.R: -------------------------------------------------------------------------------- 1 | vif.mer <- function (fit) { 2 | ## adapted from rms::vif 3 | 4 | v <- vcov(fit) 5 | nam <- names(fixef(fit)) 6 | 7 | ## exclude intercepts 8 | ns <- sum(1 * (nam == "Intercept" | nam == "(Intercept)")) 9 | if (ns > 0) { 10 | v <- v[-(1:ns), -(1:ns), drop = FALSE] 11 | nam <- nam[-(1:ns)] 12 | } 13 | 14 | d <- diag(v)^0.5 15 | v <- diag(solve(v/(d %o% d))) 16 | names(v) <- nam 17 | v 18 | } 19 | 20 | kappa.mer <- function (fit, 21 | scale = TRUE, center = FALSE, 22 | add.intercept = TRUE, 23 | exact = FALSE) { 24 | X <- fit@pp$X 25 | nam <- names(fixef(fit)) 26 | 27 | ## exclude intercepts 28 | nrp <- sum(1 * (nam == "(Intercept)")) 29 | if (nrp > 0) { 30 | X <- X[, -(1:nrp), drop = FALSE] 31 | nam <- nam[-(1:nrp)] 32 | } 33 | 34 | if (add.intercept) { 35 | X <- cbind(rep(1), scale(X, scale = scale, center = center)) 36 | kappa(X, exact = exact) 37 | } else { 38 | kappa(scale(X, scale = scale, center = scale), exact = exact) 39 | } 40 | } 41 | 42 | colldiag.mer <- function (fit, 43 | scale = TRUE, center = FALSE, 44 | add.intercept = TRUE) { 45 | ## adapted from perturb::colldiag, method in Belsley, Kuh, and 46 | ## Welsch (1980). look for a high condition index (> 30) with 47 | ## more than one high variance propotion. see ?colldiag for more 48 | ## tips. 49 | result <- NULL 50 | if (center) 51 | add.intercept <- FALSE 52 | if (is.matrix(fit) || is.data.frame(fit)) { 53 | X <- as.matrix(fit) 54 | nms <- colnames(fit) 55 | } 56 | else if (class(fit) == "mer") { 57 | nms <- names(fixef(fit)) 58 | X <- fit@X 59 | if (any(grepl("(Intercept)", nms))) { 60 | add.intercept <- FALSE 61 | } 62 | } 63 | X <- X[!is.na(apply(X, 1, all)), ] 64 | 65 | if (add.intercept) { 66 | X <- cbind(1, X) 67 | colnames(X)[1] <- "(Intercept)" 68 | } 69 | X <- scale(X, scale = scale, center = center) 70 | 71 | svdX <- svd(X) 72 | svdX$d 73 | condindx <- max(svdX$d)/svdX$d 74 | dim(condindx) <- c(length(condindx), 1) 75 | 76 | Phi = svdX$v %*% diag(1/svdX$d) 77 | Phi <- t(Phi^2) 78 | pi <- prop.table(Phi, 2) 79 | colnames(condindx) <- "cond.index" 80 | if (!is.null(nms)) { 81 | rownames(condindx) <- nms 82 | colnames(pi) <- nms 83 | rownames(pi) <- nms 84 | } else { 85 | rownames(condindx) <- 1:length(condindx) 86 | colnames(pi) <- 1:ncol(pi) 87 | rownames(pi) <- 1:nrow(pi) 88 | } 89 | 90 | result <- data.frame(cbind(condindx, pi)) 91 | zapsmall(result) 92 | } 93 | 94 | maxcorr.mer <- function (fit, 95 | exclude.intercept = TRUE) { 96 | so <- summary(fit) 97 | corF <- so@vcov@factors$correlation 98 | nam <- names(fixef(fit)) 99 | 100 | ## exclude intercepts 101 | ns <- sum(1 * (nam == "Intercept" | nam == "(Intercept)")) 102 | if (ns > 0 & exclude.intercept) { 103 | corF <- corF[-(1:ns), -(1:ns), drop = FALSE] 104 | nam <- nam[-(1:ns)] 105 | } 106 | corF[!lower.tri(corF)] <- 0 107 | maxCor <- max(corF) 108 | minCor <- min(corF) 109 | if (abs(maxCor) > abs(minCor)) { 110 | zapsmall(maxCor) 111 | } else { 112 | zapsmall(minCor) 113 | } 114 | } 115 | -------------------------------------------------------------------------------- /regression-utils.R: -------------------------------------------------------------------------------- 1 | c. <- function (x) scale(x, scale = FALSE) 2 | z. <- function (x) scale(x) 3 | r. <- function (formula, ...) rstandard(lm(formula, ...)) 4 | l. <- function (x) log(x) 5 | s. <- function (x) { 6 | ## Seber 1977 page 216, from http://dx.doi.org/10.1021/ie970236k 7 | ## Transforms continuous variable to the range [-1, 1] 8 | ## In linked paper, recommended before computing orthogonal 9 | ## polynomials 10 | (2 * x - max(x) - min(x)) / (max(x) - min(x)) 11 | } 12 | p. <- function (x, ...) poly(x, ...) 13 | --------------------------------------------------------------------------------