[Genabel-commits] r1670 - pkg/DatABEL/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Apr 2 17:57:32 CEST 2014
Author: lckarssen
Date: 2014-04-02 17:57:31 +0200 (Wed, 02 Apr 2014)
New Revision: 1670
Modified:
pkg/DatABEL/R/apply2dfo_util.R
pkg/DatABEL/R/databel_class_internal.R
Log:
Updated these two DatABEL files to the coding standards. No functional changes.
Modified: pkg/DatABEL/R/apply2dfo_util.R
===================================================================
--- pkg/DatABEL/R/apply2dfo_util.R 2014-04-01 12:47:02 UTC (rev 1669)
+++ pkg/DatABEL/R/apply2dfo_util.R 2014-04-02 15:57:31 UTC (rev 1670)
@@ -1,25 +1,24 @@
#' 'apply2dfo'-associated functions
-#'
-#' A number of functions used in
-#' conjunction with 'apply2dfo'.
-#' Standardly supported apply2dfo's anFUN analysis functions
-#' include 'lm', 'glm', 'coxph', 'sum', 'prod', "sum_not_NA"
-#' (no. non-missing obs), and "sum_NA" (no. missing obs.).
-#' Pre-defined processing functions include "process_lm_output"
-#' (can process functions "lm", "glm", "coxph") and "process_simple_output"
-#' (process output from "sum", "prod", "sum_not_NA",
-#' "sum_NA")
-#'
+#'
+#' A number of functions used in conjunction with 'apply2dfo'.
+#' Standardly supported apply2dfo's anFUN analysis functions include
+#' 'lm', 'glm', 'coxph', 'sum', 'prod', "sum_not_NA" (no. non-missing
+#' obs), and "sum_NA" (no. missing obs.). Pre-defined processing
+#' functions include "process_lm_output" (can process functions "lm",
+#' "glm", "coxph") and "process_simple_output" (process output from
+#' "sum", "prod", "sum_not_NA", "sum_NA")
+#'
#' @aliases process_lm_output process_simple_output sum_not_NA sum_NA
-#'
-#' @usage process_lm_output(lmo,verbosity=2)
-#'
+#'
+#' @usage process_lm_output(lmo,verbosity=2)
+#'
#' @param lmo object returned by analysis with "lm", "glm", etc.
#' @param verbosity verbosity
-#'
+#'
#' @seealso \link{apply2dfo}
-#'
-#' @examples
+#' @export
+#'
+#' @examples
#' a <- matrix(rnorm(50),10,5)
#' rownames(a) <- paste("id",1:10,sep="")
#' colnames(a) <- paste("snp",1:5,sep="")
@@ -27,51 +26,64 @@
#' apply(a,FUN="sum",MAR=2)
#' apply2dfo(SNP,dfodata=b,anFUN="sum",procFUN="process_simple_output")
#' apply2dfo(SNP,dfodata=b,anFUN="sum",transpose=FALSE)
-#'
+#'
#' sex <- 1*(runif(10)>.5)
#' trait <- rnorm(10)+sex+as(b[,2],"vector")+as(b[,2],"vector")*sex*5
#' apply2dfo(trait~SNP*sex,dfodata=b,anFUN="lm",procFUN="process_lm_output")
-#'
+#'
-process_lm_output <- function(lmo,verbosity=2)
+process_lm_output <- function(lmo, verbosity=2)
{
- if (class(lmo) != "lm" && class(lmo) != "glm") stop(paste("cannot process object of type",class(lmo)))
- if (length(grep("coef",names(lmo))) != 1) stop("weird lmo object")
- nams <- names(lmo$coef)
- #print(lmo)
- lmo <- summary(lmo)
- if (length(grep("coef",names(lmo))) != 1) stop("weird lmo object")
- lmo <- lmo$coef
- #print(lmo)
- #print(nams)
- if (dim(lmo)[1]<length(nams)) {
- lmo <- rbind(lmo,matrix(NA,ncol=dim(lmo)[2],nrow=length(nams)-dim(lmo)[1]))
- rownames(lmo) <- nams
- }
- snprows <- grep("SNP",rownames(lmo))
- if (length(snprows) < 1) {
- snprows <- rep(NA,10)
- }
-
- if (verbosity <= 0)
- selcols <- c(1)
- else if (verbosity == 1)
- selcols <- c(1,2)
- else if (verbosity == 2)
- selcols <- c(1,2,4)
- else
- selcols <- c(1:dim(lmo)[2])
-
- out <- matrix(lmo[snprows,selcols],ncol=length(selcols))
- #print(dimnames(lmo))
- #print(c(snprows))
- #print(c(selcols))
- #print(dim(out))
- #print(out)
- dimnames(out) <- list(dimnames(lmo)[[1]][snprows],dimnames(lmo)[[2]][selcols])
- #print(dimnames(out))
-
- return(out)
+ if (class(lmo) != "lm" && class(lmo) != "glm") {
+ stop(paste("cannot process object of type", class(lmo)))
+ }
+ if (length(grep("coef", names(lmo))) != 1) {
+ stop("weird lmo object")
+ }
+ nams <- names(lmo$coef)
+ #print(lmo)
+ lmo <- summary(lmo)
+ if (length(grep("coef", names(lmo))) != 1) {
+ stop("weird lmo object")
+ }
+ lmo <- lmo$coef
+ #print(lmo)
+ #print(nams)
+ if (dim(lmo)[1]<length(nams)) {
+ lmo <- rbind(lmo, matrix(NA,
+ ncol=dim(lmo)[2],
+ nrow=length(nams)-dim(lmo)[1]))
+ rownames(lmo) <- nams
+ }
+ snprows <- grep("SNP", rownames(lmo))
+ if (length(snprows) < 1) {
+ snprows <- rep(NA, 10)
+ }
+
+ if (verbosity <= 0) {
+ selcols <- c(1)
+ }
+ else if (verbosity == 1) {
+ selcols <- c(1, 2)
+ }
+ else if (verbosity == 2) {
+ selcols <- c(1, 2, 4)
+ }
+ else {
+ selcols <- c(1:dim(lmo)[2])
+ }
+
+ out <- matrix(lmo[snprows, selcols], ncol=length(selcols))
+ #print(dimnames(lmo))
+ #print(c(snprows))
+ #print(c(selcols))
+ #print(dim(out))
+ #print(out)
+ dimnames(out) <- list(dimnames(lmo)[[1]][snprows],
+ dimnames(lmo)[[2]][selcols])
+ #print(dimnames(out))
+
+ return(out)
}
process_simple_output <- function(o) return(o)
Modified: pkg/DatABEL/R/databel_class_internal.R
===================================================================
--- pkg/DatABEL/R/databel_class_internal.R 2014-04-01 12:47:02 UTC (rev 1669)
+++ pkg/DatABEL/R/databel_class_internal.R 2014-04-02 15:57:31 UTC (rev 1670)
@@ -2,73 +2,78 @@
# databel internal util
#
-databel_check <- function(x, reconnect = TRUE, stop_on_error = TRUE, quiet = FALSE)
+databel_check <- function(x, reconnect = TRUE, stop_on_error = TRUE,
+ quiet = FALSE)
{
-# print("databel_check started");
-
- if (class(x) != "databel") {
- msg <- "databel_check: object is not of class 'databel'"
- stop(msg)
- #if (stop_on_error) {stop(msg);} else {warning(msg);return(FALSE)}
- }
-
- if (class(x at data) != "externalptr") {
- msg <- "databel_check: data is not of class 'externalptr'";
- stop(msg);
- #if (stop_on_error) {stop(msg);} else {warning(msg);return(FALSE)}
- }
-
- if (externalptr_is_null(x at data)) {
- if (!reconnect) {
- msg <- "databel_check: object is not connected (will not work for writing, access is slower); use 'connect(object)'"
- if (stop_on_error) {
- stop(msg);
- } else {
- if (!quiet) warning(msg);
- return(FALSE)
- }
- } else {
- result <- try(
- eval.parent(substitute(connect(x)))
- )
- if (class(result) != "try-error") {
- return(TRUE)
- } else {
- msg <- "databel_check: can not connect object"
- if (stop_on_error) {stop(msg);} else {warning(msg);return(FALSE)}
- }
- }
- }
-# print("databel_check finished");
- return(TRUE);
+ # print("dataprovcbel_check started");
+
+ if (class(x) != "databel") {
+ msg <- "databel_check: object is not of class 'databel'"
+ stop(msg)
+ #if (stop_on_error) {stop(msg);} else {warning(msg);return(FALSE)}
+ }
+
+ if (class(x at data) != "externalptr") {
+ msg <- "databel_check: data is not of class 'externalptr'";
+ stop(msg);
+ #if (stop_on_error) {stop(msg);} else {warning(msg);return(FALSE)}
+ }
+
+ if (externalptr_is_null(x at data)) {
+ if (!reconnect) {
+ msg <- "databel_check: object is not connected (will not work for writing, access is slower); use 'connect(object)'"
+ if (stop_on_error) {
+ stop(msg);
+ } else {
+ if (!quiet) warning(msg);
+ return(FALSE)
+ }
+ } else {
+ result <- try(
+ eval.parent(substitute(connect(x)))
+ )
+ if (class(result) != "try-error") {
+ return(TRUE)
+ } else {
+ msg <- "databel_check: can not connect object"
+ if (stop_on_error) {stop(msg);} else {warning(msg);return(FALSE)}
+ }
+ }
+ }
+ # print("databel_check finished");
+ return(TRUE);
};
+
externalptr_is_null <- function(x) {
- if (!is(x,"externalptr")) stop("x is not 'externalptr'")
- return(.Call("externalptr_is_null",x))
+ if (!is(x, "externalptr")) stop("x is not 'externalptr'")
+ return(.Call("externalptr_is_null", x))
}
+
uninames <- function(filtredmatrixptr)
{
- out <- list()
- out$unique.names <- out$unique.colnames <- out$unique.rownames <- FALSE
- colnames <- .Call("get_all_varnames_R",filtredmatrixptr)
- rownames <- .Call("get_all_obsnames_R",filtredmatrixptr)
- if (!anyDuplicated(colnames)) {
- out$unique.colnames <- TRUE
- } else {
- warning("uninames: some column names are not unique; use set_dimnames/get_dimnames for non-unique row/col names")
- }
- if (!anyDuplicated(rownames)) {
- out$unique.rownames <- TRUE
- } else {
- warning("uninames: some row names are not unique; use set_dimnames/get_dimnames for non-unique row/col names")
- }
-
- if (all(colnames == c(1:length(colnames)))) out$unique.colnames <- FALSE
- if (all(rownames == c(1:length(rownames)))) out$unique.rownames <- FALSE
-
- out$unique.names <- (out$unique.colnames && out$unique.rownames)
-
- return(out)
+ out <- list()
+ out$unique.names <- out$unique.colnames <- out$unique.rownames <- FALSE
+ colnames <- .Call("get_all_varnames_R", filtredmatrixptr)
+ rownames <- .Call("get_all_obsnames_R", filtredmatrixptr)
+
+ if (!anyDuplicated(colnames)) {
+ out$unique.colnames <- TRUE
+ } else {
+ warning("uninames: some column names are not unique; use set_dimnames/get_dimnames for non-unique row/col names")
+ }
+
+ if (!anyDuplicated(rownames)) {
+ out$unique.rownames <- TRUE
+ } else {
+ warning("uninames: some row names are not unique; use set_dimnames/get_dimnames for non-unique row/col names")
+ }
+
+ if (all(colnames == c(1:length(colnames)))) out$unique.colnames <- FALSE
+ if (all(rownames == c(1:length(rownames)))) out$unique.rownames <- FALSE
+
+ out$unique.names <- (out$unique.colnames && out$unique.rownames)
+
+ return(out)
}
More information about the Genabel-commits
mailing list