Nothing
######################################################################
########################## Class Enrichment ##########################
############################## Creation ##############################
######################################################################
setClass(
Class = "Enrichment",
representation = representation(
Loss = "data.frame",
Call = "list",
eSNP = "EnrichSNP",
xSNP = "EnrichSNP",
Chromosomes = "list"
),
prototype = prototype(
Loss = data.frame(),
Call = list(readEnrichment = list(pattern = NULL, signalFile = NULL, transcriptFile = NULL, snpListDir = NULL, snpInfoDir = NULL,
distThresh = NULL, sigThresh = NULL, LD = NULL, ldDir = NULL, mc.cores = NULL),
reSample = list(object = NULL, nSample = NULL, empiricPvalue = NULL, MAFpool = NULL, mc.cores = NULL, onlyGenome = NULL)),
eSNP = enrichSNP(),
xSNP = enrichSNP(),
Chromosomes = eval(parse(text = paste0("list(", paste(paste0("Chrom", seq(22), " = chromosome()"), collapse = ", "), ")")))
)
)
setMethod(f = "enrichment", signature = "ANY", definition = function (Loss, Call, eSNP, xSNP, Chromosomes) {
if (missing(Loss)) {
Loss <- data.frame()
} else {}
if (missing(Call)) {
Call <- list(readEnrichment = list(pattern = NULL, signalFile = NULL, transcriptFile = NULL, snpListDir = NULL, snpInfoDir = NULL,
distThresh = NULL, sigThresh = NULL, LD = NULL, ldDir = NULL, mc.cores = NULL),
reSample = list(object = NULL, nSample = NULL, empiricPvalue = NULL, MAFpool = NULL, mc.cores = NULL, onlyGenome = NULL))
} else {}
if (missing(Chromosomes)) {
Chromosomes <- eval(parse(text = paste0("list(", paste(paste0("Chrom", seq(22), " = chromosome()"), collapse = ", "), ")")))
} else {}
if (missing(eSNP)) {
List <- eval(parse(text = paste0("c(", paste(paste0("Chromosomes$Chrom", seq(22), "@eSNP@List"), collapse=", "), ")")))
eSNP <- enrichSNP(List = List)
} else {}
if (missing(xSNP)) {
List <- eval(parse(text = paste0("c(", paste(paste0("Chromosomes$Chrom", seq(22), "@xSNP@List"), collapse=", "), ")")))
xSNP <- enrichSNP(List = List)
} else {}
return(new("Enrichment", Loss = Loss, Call = Call, eSNP = eSNP, xSNP = xSNP, Chromosomes = Chromosomes))
})
setMethod(f = "is.enrichment", signature = "ANY", definition = function (object) {
if (length(object)>1) {
return(sapply(object, is.enrichment))
} else {
if (class(object) == "Enrichment") {
return(TRUE)
} else {
return(FALSE)
}
}
})
setMethod(f = "print", signature = "Enrichment", definition = function (x, what = "Genome", type = c("eSNP", "xSNP")) {
if (missing(x)) {
stop('[Enrichment:print] "x" is missing.', call. = FALSE)
} else {}
if (is.null(what) | any(!what%in%c("All", "Genome", seq(22)))) {
stop('[Enrichment:print] "what" must be: "All", "Genome" or numeric value (atomic or vector).', call. = FALSE)
} else {}
if (is.null(type) | any(!type%in%c("eSNP", "xSNP"))) {
stop('[Enrichment:print] "type" must be: "eSNP" and/or "xSNP".', call. = FALSE)
} else {}
empiricPvalue <- x["Call"][["reSample"]][["empiricPvalue"]]
if (is.null(empiricPvalue)) {
empiricPvalue <- FALSE
} else {}
if (length(what)==1) {
switch(EXPR = as.character(what),
"Genome" = {
res <- list()
for (iType in type) {
resTmp <- print(x[iType])
colnames(resTmp) <- c("EnrichmentRatio", "Z", "PValue", "nSample", "TotalSNP", iType)
rownames(resTmp) <- paste("Chrom", iType, sep = ":")
if (empiricPvalue) {
resTmp <- resTmp[, -grep("Z", colnames(resTmp))]
} else {}
res[[iType]] <- resTmp
}
if (length(type)==1) {
return(res[[1]])
} else {
res <- do.call("rbind", res)
rownames(res) <- paste(what, type, sep = ":")
return(res)
}
},
"All" = {
res <- list()
for (iType in type) {
resTmp <- print(x[iType])
tmp <- do.call("rbind", lapply(seq(22), function (n) {
print(x["Chromosomes", n], type = iType)
}))
resTmp <- rbind(resTmp, tmp)
rownames(resTmp) <- c("Genome", paste0("Chrom", seq(22)))
colnames(resTmp) <- c("EnrichmentRatio", "Z", "PValue", "nSample", "TotalSNP", iType)
if (empiricPvalue) {
resTmp <- resTmp[, -grep("Z", colnames(resTmp))]
} else {}
res[[iType]] <- resTmp
}
if (length(type)==1) {
return(res[[1]])
} else {
return(res)
}
},
{
res <- print(x["Chromosomes", what], type = type)
rownames(res) <- paste0("Chrom", what, ":", type)
return(res)
}
)
} else {
if (!is.numeric(what)) {
stop('[Enrichment:print] "what" must be: "Genome", "All" or a numeric vector.', call. = FALSE)
} else {}
resTmp <- lapply(what, function (iWhat) { print(x["Chromosomes", iWhat], type = type)})
res <- do.call("rbind", resTmp)
whatNames <- sapply(what, function (iWhat) {
return(paste0("Chrom", iWhat))
})
rownames(res) <- paste0(rep(whatNames, each = length(type)), ":", type)
if (empiricPvalue) {
res <- res[, -grep("Z", colnames(res))]
} else {}
return(res)
}
})
.Enrichment.show <- function (object) {
.showArgs <- function (args) {
for (iFuncArg in seq(args)) {
if (is.null(unlist(args[iFuncArg]))) {
cat(paste0(" ", names(args[iFuncArg]), '() : Not yet called.\n'))
} else {
tmpArgs <- args[[names(args[iFuncArg])]]
type <- lapply(tmpArgs, class)
res <- NULL
tmpArgs <- lapply(tmpArgs, function (li) {
if (length(li)>1) {
return(deparse(li))
} else {
return(li)
}
})
for (iArg in names(tmpArgs)) {
res <- c(res, paste0(iArg,
ifelse(type[[iArg]]=="character", '="', "="),
ifelse(type[[iArg]]=="NULL" | type[[iArg]]=="name", deparse(tmpArgs[[iArg]]), tmpArgs[[iArg]]),
ifelse(type[[iArg]]=="character", '"', "")))
}
cat(paste0(" ", names(args[iFuncArg]), '(', paste(res, collapse = paste0(", \n", paste(rep(" ", nchar(names(args[iFuncArg]))+5), collapse = ""))), ')\n'))
}
}
}
cat(" ~ Loss :", paste0("(", paste(dim(object@Loss), collapse = "x"), ")"))
if (nrow(object@Loss) == 0) {
cat(" NA")
} else {
cat("\n")
resFormat <- cbind(c("", rownames(object@Loss[seq(2), ])), rbind(colnames(object@Loss[seq(2), ]), apply(round(object@Loss[seq(2), ], digits = 4), 2, as.character)))
resFormat <- rbind(resFormat, ".....")
cat(paste(" ", apply(apply(matrix(paste0(" ", resFormat, " "), nrow = nrow(resFormat)), 2, format, justify = "centre"), 1, paste, collapse = ""), "\n", sep = "", collapse = ""))
}
cat("\n ~ Call :\n")
.showArgs(object@Call)
cat("\n ~ eSNP :\n")
.EnrichSNP.show(object@eSNP)
cat("\n ~ xSNP :\n")
.EnrichSNP.show(object@xSNP)
nbVoid <- 0
for (slot in names(object@Chromosomes)) {
eval(parse(text = paste0("nbVoid <- nbVoid + as.numeric(identical(chromosome(), ", paste0("object@Chromosomes$", slot), "))")))
}
cat("\n ~ Chromosomes :", paste(nbVoid, length(names(object@Chromosomes)), sep = "/"), "empty Chromosomes")
cat("\n")
return(invisible(object))
}
setMethod(f = "show", signature = "Enrichment", definition = function (object) {cat(" ~~~ Class:", class(object), "~~~ \n"); .Enrichment.show(object); return(invisible(object))})
setMethod(f = "[", signature = "Enrichment", definition = function (x, i, j, drop) {
nbChr <- length(x@Chromosomes)
if (missing(j)) {
switch(EXPR = i,
"Loss" = {return(x@Loss)},
"Data" = {
resData <- mclapply2(seq(22), mc.cores = min(22, detectCores()), function (iChr) {
return(x@Chromosomes[[iChr]]@Data)
})
return(do.call("rbind", resData))
},
"LD" = {
resLD <- mclapply2(seq(22), mc.cores = min(22, detectCores()), function (iChr) {
return(x@Chromosomes[[iChr]]@LD)
})
return(unlist(resLD))
},
"Call" = {return(x@Call)},
"eSNP" = {return(x@eSNP)},
"xSNP" = {return(x@xSNP)},
"Table" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('x@', iType, '@Table')))
}
return(res)
},
"Chromosomes" = {return(x@Chromosomes)},
"Stats" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
EnrichmentRatio <- eval(parse(text = paste0('x@', iType, '@EnrichmentRatio')))
Z <- eval(parse(text = paste0('x@', iType, '@Z')))
PValue <- eval(parse(text = paste0('x@', iType, '@PValue')))
Resampling <- eval(parse(text = paste0('nrow(x@', iType, '@Resampling)')))
Data <- x@Loss["Signal", ncol(x@Loss)]
List <- eval(parse(text = paste0('length(x@', iType, '@List)')))
resTmp <- c(if (length(EnrichmentRatio)==0) {NA} else {EnrichmentRatio},
if (length(Z)==0) {NA} else {Z},
if (length(PValue)==0) {NA} else {PValue},
if (length(Resampling)==0) {NA} else {Resampling},
if (length(Data)==0) {NA} else {Data},
if (length(List)==0) {NA} else {List}
)
names(resTmp) <- c("EnrichmentRatio", "Z", "PVALUE", "nbSample", "SNP", iType)
res[[iType]] <- resTmp
}
return(res)
},
stop('[Enrichment:get] ', i, ' is not a "Enrichment" slot.', call. = FALSE)
)
} else {
if (max(j)>nbChr) {
if (j == "ALL") {
switch(EXPR = i,
"Loss" = {return(x@Loss)},
"Data" = {
resData <- mclapply2(seq(22), mc.cores = min(22, detectCores()), function (iChr) {
return(x@Chromosomes[[iChr]]@Data)
})
return(do.call("rbind", resData))
},
"LD" = {
resLD <- mclapply2(seq(22), mc.cores = min(22, detectCores()), function (iChr) {
return(x@Chromosomes[[iChr]]@LD)
})
return(unlist(resLD))
},
"Call" = {return(x@Call)},
"List" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('x@', iType, '@List')))
}
return(res)
},
"Table" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('x@', iType, '@Table')))
}
return(res)
},
"EnrichmentRatio" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('x@', iType, '@EnrichmentRatio')))
}
return(res)
},
"Z" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('x@', iType, '@Z')))
}
return(res)
},
"PValue" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('x@', iType, '@PValue')))
}
return(res)
},
"Resampling" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('x@', iType, '@Resampling')))
}
return(res)
},
"Chromosomes" = {return(x@Chromosomes)},
"Stats" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
EnrichmentRatio <- eval(parse(text = paste0('x@', iType, '@EnrichmentRatio')))
Z <- eval(parse(text = paste0('x@', iType, '@Z')))
PValue <- eval(parse(text = paste0('x@', iType, '@PValue')))
Resampling <- eval(parse(text = paste0('nrow(x@', iType, '@Resampling)')))
Data <- x@Loss["Signal", ncol(x@Loss)]
List <- eval(parse(text = paste0('length(x@', iType, '@List)')))
resTmp <- c(if (length(EnrichmentRatio)==0) {NA} else {EnrichmentRatio},
if (length(Z)==0) {NA} else {Z},
if (length(PValue)==0) {NA} else {PValue},
if (length(Resampling)==0) {NA} else {Resampling},
if (length(Data)==0) {NA} else {Data},
if (length(List)==0) {NA} else {List}
)
for (iChr in seq(22)) {
EnrichmentRatio <- eval(parse(text = paste0('x@Chromosomes$Chrom', iChr, '@', iType, '@EnrichmentRatio')))
Z <- eval(parse(text = paste0('x@Chromosomes$Chrom', iChr, '@', iType, '@Z')))
PValue <- eval(parse(text = paste0('x@Chromosomes$Chrom', iChr, '@', iType, '@PValue',)))
Resampling <- eval(parse(text = paste0('nrow(x@Chromosomes$Chrom', iChr, '@', iType, '@Resampling)')))
Data <- eval(parse(text = paste0('nrow(x@Chromosomes$Chrom', iChr, '@Data)')))
List <- eval(parse(text = paste0('length(x@Chromosomes$Chrom', iChr, '@', iType, '@List)')))
tmp <- c(if (length(EnrichmentRatio)==0) {NA} else {EnrichmentRatio},
if (length(Z)==0) {NA} else {Z},
if (length(PValue)==0) {NA} else {PValue},
if (length(Resampling)==0) {NA} else {Resampling},
if (length(Data)==0) {NA} else {Data},
if (length(List)==0) {NA} else {List}
)
resTmp <- rbind(resTmp, tmp)
}
rownames(resTmp) <- c("Genome", paste0("Chrom", seq(22)))
colnames(resTmp) <- c("EnrichmentRatio", "Z", "PVALUE", "nbSample", "SNP", iType)
res[[iType]] <- resTmp
}
return(res)
},
stop('[Enrichment:get] ', i, ' is not a "Enrichment" slot.', call. = FALSE)
)
} else {
stop('[Enrichment:get] "j" is out of limits.', call. = FALSE)
}
} else {
if (length(j)>1) {
switch(EXPR = i,
"Signal" = {return(eval(parse(text = paste0('list(', paste(paste0("x@Chromosomes$Chrom", j, "@Data[, c('SNP', 'PVALUE')]"), collapse = ", "), ')'))))},
"Data" = {
resData <- mclapply2(j, mc.cores = min(length(j), detectCores()), function (iChr) {
return(x@Chromosomes[[iChr]]@Data)
})
return(do.call("rbind", resData))
},
"LD" = {
resLD <- mclapply2(j, mc.cores = min(length(j), detectCores()), function (iChr) {
return(x@Chromosomes[[iChr]]@LD)
})
return(unlist(resLD))
},
"Call" = {return(x@Call)},
"List" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('c(', paste(paste0("x@Chromosomes$Chrom", j, "@", iType,"@List"), collapse = ", "), ')')))
}
return(res)
},
"Table" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('list(', paste(paste0("x@Chromosomes$Chrom", j, "@", iType,"@Table"), collapse = ", "), ')')))
}
return(res)
},
"EnrichmentRatio" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('c(', paste(paste0("x@Chromosomes$Chrom", j, "@", iType,"@EnrichmentRatio"), collapse = ", "), ')')))
}
return(res)
},
"Z" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('c(', paste(paste0("x@Chromosomes$Chrom", j, "@", iType,"@Z"), collapse = ", "), ')')))
}
return(res)
},
"PValue" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('c(', paste(paste0("x@Chromosomes$Chrom", j, "@", iType,"@PValue"), collapse = ", "), ')')))
}
return(res)
},
"Resampling" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0('list(', paste(paste0("x@Chromosomes$Chrom", j, "@", iType,"@Resampling"), collapse = ", "), ')')))
}
return(res)
},
"Chromosomes" = {return(x@Chromosomes[j])},
"Stats" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
resTmp <- NULL
for (iChr in j) {
EnrichmentRatio <- eval(parse(text = paste0('x@Chromosomes$Chrom', iChr, '@', iType, '@EnrichmentRatio')))
Z <- eval(parse(text = paste0('x@Chromosomes$Chrom', iChr, '@', iType, '@Z')))
PValue <- eval(parse(text = paste0('x@Chromosomes$Chrom', iChr, '@', iType, '@PValue')))
Resampling <- eval(parse(text = paste0('nrow(x@Chromosomes$Chrom', iChr, '@', iType, '@Resampling)')))
Data <- eval(parse(text = paste0('nrow(x@Chromosomes$Chrom', iChr, '@Data)')))
List <- eval(parse(text = paste0('length(x@Chromosomes$Chrom', iChr, '@', iType, '@List)')))
tmp <- c(if (length(EnrichmentRatio)==0) {NA} else {EnrichmentRatio},
if (length(Z)==0) {NA} else {Z},
if (length(PValue)==0) {NA} else {PValue},
if (length(Resampling)==0) {NA} else {Resampling},
if (length(Data)==0) {NA} else {Data},
if (length(List)==0) {NA} else {List}
)
resTmp <- rbind(resTmp, tmp)
}
rownames(resTmp) <- c(paste0("Chrom", j))
colnames(resTmp) <- c("EnrichmentRatio", "Z", "PVALUE", "nbSample", "SNP", iType)
res[[iType]] <- resTmp
}
return(res)
},
stop('[Enrichment:get] ', i, ' is not a "Enrichment" slot.', call. = FALSE)
)
} else {
switch(EXPR = i,
"Signal" = {return(eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@Data[, c('SNP', 'PVALUE')]"))))},
"Data" = {return(eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@Data"))))},
"LD" = {return(eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@LD"))))},
"Call" = {return(x@Call)},
"List" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@", iType,"@List")))
}
return(res)
},
"Table" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@", iType,"@Table")))
}
return(res)
},
"EnrichmentRatio" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@", iType,"@EnrichmentRatio")))
}
return(res)
},
"Z" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@", iType,"@Z")))
}
return(res)
},
"PValue" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@", iType,"@PValue")))
}
return(res)
},
"Resampling" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
res[[iType]] <- eval(parse(text = paste0("x@Chromosomes$Chrom", j, "@", iType,"@Resampling")))
}
return(res)
},
"Chromosomes" = {return(x@Chromosomes[[j]])},
"Stats" = {
res <- list(eSNP = NULL, xSNP = NULL)
for (iType in c("eSNP", "xSNP")) {
EnrichmentRatio <- eval(parse(text = paste0('x@Chromosomes$Chrom', j, '@', iType, '@EnrichmentRatio')))
Z <- eval(parse(text = paste0('x@Chromosomes$Chrom', j, '@', iType, '@Z')))
PValue <- eval(parse(text = paste0('x@Chromosomes$Chrom', j, '@', iType, '@PValue')))
Resampling <- eval(parse(text = paste0('nrow(x@Chromosomes$Chrom', j, '@', iType, '@Resampling)')))
Data <- eval(parse(text = paste0('nrow(x@Chromosomes$Chrom', j, '@Data)')))
List <- eval(parse(text = paste0('length(x@Chromosomes$Chrom', j, '@', iType, '@List)')))
tmp <- c(if (length(EnrichmentRatio)==0) {NA} else {EnrichmentRatio},
if (length(Z)==0) {NA} else {Z},
if (length(PValue)==0) {NA} else {PValue},
if (length(Resampling)==0) {NA} else {Resampling},
if (length(Data)==0) {NA} else {Data},
if (length(List)==0) {NA} else {List}
)
names(tmp) <- c("EnrichmentRatio", "Z", "PVALUE", "nbSample", "SNP", iType)
res[[iType]] <- tmp
}
return(res)
},
stop('[Enrichment:get] ', i, ' is not a "Enrichment" slot.', call. = FALSE)
)
}
}
}
})
setMethod(f = "[<-", signature = "Enrichment", definition = function (x, i, j, value) {
nbChr <- length(x@Chromosomes)
if (missing(j)) {
switch(EXPR = i,
"Loss" = {x@Loss <- value},
"Data" = {stop('[Enrichment:set] "Data" is not available for Set function.', call. = FALSE)},
"LD" = {stop('[Enrichment:set] "LD" is not available for Set function.', call. = FALSE)},
"Call" = {x@Call <- value},
"eSNP" = {x@eSNP <- value},
"xSNP" = {x@xSNP <- value},
"List" = {stop('[Enrichment:set] "List" is not available for Set function.', call. = FALSE)},
"Table" = {stop('[Enrichment:set] "Table" is not available for Set function.', call. = FALSE)},
"EnrichmentRatio" = {stop('[Enrichment:set] "EnrichmentRatio" is not available for Set function.', call. = FALSE)},
"Z" = {stop('[Enrichment:set] "Z" is not available for Set function.', call. = FALSE)},
"PValue" = {stop('[Enrichment:set] "PValue" is not available for Set function.', call. = FALSE)},
"Resampling" = {stop('[Enrichment:set] "Resampling" is not available for Set function.', call. = FALSE)},
"Chromosomes" = {x@Chromosomes <- value},
"Stats" = {stop('[Enrichment:set] "Stats" is not available for Set function.', call. = FALSE)},
stop('[Enrichment:set] ', i, ' is not a "Enrichment" slot.', call. = FALSE)
)
} else {
if (max(j)>nbChr) {
stop('[Enrichment:set] "j" is out of limits.', call. = FALSE)
} else {
if (length(j)>1) {
stop('[Enrichment:set] "j" must be atomic.', call. = FALSE)
} else {
switch(EXPR = i,
"Loss" = {x@Loss <- value},
"Data" = {stop('[Enrichment:set] "Data" is not available for Set function.', call. = FALSE)},
"LD" = {stop('[Enrichment:set] "LD" is not available for Set function.', call. = FALSE)},
"Call" = {x@Call <- value},
"eSNP" = {x@Chromosomes[[j]]@eSNP <- value},
"xSNP" = {x@Chromosomes[[j]]@xSNP <- value},
"List" = {stop('[Enrichment:set] "List" is not available for Set function.', call. = FALSE)},
"Table" = {stop('[Enrichment:set] "Table" is not available for Set function.', call. = FALSE)},
"EnrichmentRatio" = {stop('[Enrichment:set] "EnrichmentRatio" is not available for Set function.', call. = FALSE)},
"Z" = {stop('[Enrichment:set] "Z" is not available for Set function.', call. = FALSE)},
"PValue" = {stop('[Enrichment:set] "PValue" is not available for Set function.', call. = FALSE)},
"Resampling" = {stop('[Enrichment:set] "Resampling" is not available for Set function.', call. = FALSE)},
"Chromosomes" = {x@Chromosomes[[j]] <- value},
"Stats" = {stop('[Enrichment:set] "Stats" is not available for Set functions.', call. = FALSE)},
stop('[Enrichment:set] ', i, ' is not a "Enrichment" slot.', call. = FALSE)
)
}
}
}
validObject(x)
return(x)
})
setMethod(f = "computeER", signature = "Enrichment", definition = function (object, sigThresh = 0.05, mc.cores = 1) {
if (!missing(object)) {
rowNames <- c(paste0("P>=", sigThresh), paste0("P<", sigThresh))
object@Chromosomes <- mclapply2(object@Chromosomes, mc.cores = mc.cores, function (chr) {
data <- chr@Data
chrLD <- length(chr@LD)
pvalFactor <- factor(data[, "PVALUE"]<sigThresh, levels = c(FALSE, TRUE))
for (iType in c("eSNP", "xSNP")) {
if (!(chrLD == 0 & iType == "xSNP")) {
snpEnrich <- table(pvalFactor, factor(data[, iType], levels = c(0, 1)))
colnames(snpEnrich) <- c("otherSNP", iType)
rownames(snpEnrich) <- rowNames
chr[iType] <- enrichSNP(List = chr[iType]@List, Table = unclass(snpEnrich), EnrichmentRatio = .enrichmentRatio(snpEnrich))
} else {}
}
return(chr)
})
for (iType in c("eSNP", "xSNP")) {
bigEnrichment <- matrix(rowSums(sapply(seq(22), function (jChr) {
object@Chromosomes[[jChr]][iType]@Table
})), nrow = 2, ncol = 2)
object[iType]@Table <- bigEnrichment
object[iType]@EnrichmentRatio <- .enrichmentRatio(bigEnrichment)
}
return(object)
} else {
stop('[Enrichment:computeER] "Enrichment" object is required.', call. = FALSE)
}
})
setMethod(f = "reSample", signature = "Enrichment", definition = function (object, nSample = 100, empiricPvalue = TRUE, MAFpool = c(0.05, 0.10, 0.2, 0.3, 0.4, 0.5), mc.cores = 1, onlyGenome = TRUE) {
if (!missing(object)) {
if (nSample<10) {
nSample = 10
warning('[Enrichment:reSample] nSample was increased to 10.', call. = FALSE)
} else {}
sigThresh <- object@Call$readEnrichment$sigThresh
cat("########### Resample Enrichment ############\n")
warnings.env <- new.env()
assign("minCores", mc.cores, envir = warnings.env)
assign("maxCores", 0, envir = warnings.env)
nSampleOld <- object@Call$reSample$nSample
if (onlyGenome == FALSE) {
listRes <- eval(parse(text = paste0("list(", paste(paste0("Chrom", seq(22), " = NULL"), collapse = ", "), ")")))
for (iChr in seq(22)) {
cat(" Chromosome ", if (nchar(iChr) == 1) {paste0("0", iChr)} else {iChr}, ": ", sep = "")
nbCores <- suppressWarnings(maxCores(mc.cores))
assign("minCores", min(get("minCores", envir = warnings.env), nbCores), envir = warnings.env)
assign("maxCores", max(get("maxCores", envir = warnings.env), nbCores), envir = warnings.env)
suppressWarnings(listRes[[iChr]] <- reSample(object = object@Chromosomes[[iChr]], nSample = nSample, empiricPvalue = empiricPvalue, sigThresh = sigThresh, MAFpool = MAFpool, mc.cores = mc.cores))
cat("END\n")
}
object@Chromosomes <- listRes
rm(listRes)
} else {}
cat(" Genome : ")
nbCores <- suppressWarnings(maxCores(mc.cores))
assign("minCores", min(get("minCores", envir = warnings.env), nbCores), envir = warnings.env)
assign("maxCores", max(get("maxCores", envir = warnings.env), nbCores), envir = warnings.env)
suppressWarnings(result <- .reSample(object = object, nSample = nSample, empiricPvalue = empiricPvalue, sigThresh = sigThresh, MAFpool = MAFpool, mc.cores = mc.cores))
cat("END\n")
rm(object)
sysCall <- sys.call(sys.parent())
argsSNP <- as.list(sysCall[-1])
formal <- as.list(names(formals(as.character(sysCall))))
names(formal) <- formal
if (is.null(names(argsSNP))) {
names(argsSNP) <- names(formal)[seq_along(argsSNP)]
} else {
emptyNames <- which(names(argsSNP)=="")
names(argsSNP)[emptyNames] <- names(formal)[emptyNames]
}
names(argsSNP)[grep("^$", names(argsSNP))] <- names(formal)[grep("^$", names(argsSNP))]
argsSNP <- c(argsSNP, lapply(formal[!names(formal) %in% names(argsSNP)], as.name))[names(formal)]
paramClass <- sapply(argsSNP, class)
for (iArg in names(formal)) {
if (iArg != "...") {
paramPos <- grep(iArg, names(formal), fixed = TRUE)
argTmp <- argsSNP[[paramPos]]
classTmp <- paramClass[[paramPos]]
switch(EXPR = classTmp,
"character" = {formal[[iArg]] <- argTmp},
"logical" = {formal[[iArg]] <- argTmp},
"numeric" = {formal[[iArg]] <- argTmp},
"integer" = {formal[[iArg]] <- argTmp},
"NULL" = {formal[[iArg]] <- "NULL"},
"call" = {formal[[iArg]] <- eval(argTmp)},
"name" = {
if (class(try(resEval <- eval(argTmp), silent = TRUE))=="try-error") {
formal[[iArg]] <- argTmp
} else {
switch(EXPR = class(resEval),
"character" = {formal[[iArg]] <- resEval},
"logical" = {formal[[iArg]] <- resEval},
"numeric" = {formal[[iArg]] <- resEval},
"integer" = {formal[[iArg]] <- resEval},
"matrix" = {formal[[iArg]] <- argTmp},
"data.frame" = {formal[[iArg]] <- argTmp},
"Enrichment" = {formal[[iArg]] <- argTmp}
)
}
}
)
} else {}
}
if (is.numeric(nSampleOld)) {
formal$nSample <- nSampleOld + formal$nSample
} else {}
result@Call$reSample <- formal[c("object", "nSample", "empiricPvalue", "MAFpool", "mc.cores", "onlyGenome")]
nameObject <- deparse(result@Call$reSample[["object"]])
assign(nameObject, result, inherits = TRUE, envir = parent.frame(2))
assign("maxCores", min(get("maxCores", envir = warnings.env), mc.cores), envir = warnings.env)
if (get("minCores", envir = warnings.env)==get("maxCores", envir = warnings.env)) {
if (get("minCores", envir = warnings.env)!=mc.cores) {
warning(paste0('[Enrichment:reSample] To avoid memory overload "mc.cores" was decreased to ',
get("minCores", envir = warnings.env), "."), call. = FALSE)
} else {}
} else {
warning(paste0('[Enrichment:reSample] To avoid memory overload "mc.cores" was decreased to min=',
get("minCores", envir = warnings.env), " and max=",
get("maxCores", envir = warnings.env), "."), call. = FALSE)
}
cat("######## Resample Enrichment Done ##########\n")
cat(paste0('*** Object "', nameObject, '" has been updated. ***\n\n'))
return(invisible(result))
} else {
stop('[Enrichment:reSample] "Enrichment" object is required.', call. = FALSE)
}
})
setMethod(f = "excludeSNP", signature = "Enrichment", definition = function (object, excludeFile, mc.cores = 1) {
if (missing(excludeFile)) {
stop('[Enrichment:excludeSNP] argument "excludeFile" is missing.' , call. = FALSE)
} else {
cat("########## Exclude SNP list Start ##########\n")
if (all(class(try(close(file(excludeFile)), silent = TRUE))!="try-error")) {
eSNPexclude <- read.delim(file = excludeFile, header = FALSE, na.string = c("NA", ""), check.names = FALSE, strip.white = TRUE, stringsAsFactors = FALSE, sep = "\t")
} else {
eSNPexclude <- excludeFile
}
if (class(eSNPexclude) %in% c("matrix", "data.frame")) {
if (ncol(eSNPexclude)>1) {
eSNPexclude <- eSNPexclude[, 1]
} else {}
} else {}
eSNPexclude <- unlist(eSNPexclude, use.names = FALSE)
callLD <- object@Call$readEnrichment$LD
resParallel <- mclapply2(X = seq(22), mc.cores = min(22, mc.cores), FUN = function (iChr) {
chrObject <- eval(parse(text = paste0('object@Chromosomes$Chrom', iChr)))
temp <- chrObject@Data
if (callLD) {
xSNPexclude <- intersect(temp[, "SNP"], unique(c(eSNPexclude, chrObject@LD[names(chrObject@LD) %in% eSNPexclude])))
} else {
xSNPexclude <- eSNPexclude
}
temp[temp[, "SNP"]%in%xSNPexclude, "eSNP"] <- 0
temp[temp[, "SNP"]%in%xSNPexclude, "xSNP"] <- 0
res <- chromosome(Data = temp, LD = chrObject@LD)
return(res)
})
names(resParallel) <- paste0("Chrom", seq(22))
result <- enrichment(Loss = object@Loss,
Chromosomes = resParallel,
Call = list(readEnrichment = object@Call$readEnrichment,
reSample = list(object = NULL, nSample = NULL, empiricPvalue = NULL, MAFpool = NULL, mc.cores = NULL, onlyGenome = NULL)))
rm(resParallel)
GC()
result <- computeER(object = result, sigThresh = object@Call$readEnrichment$sigThresh, mc.cores = mc.cores)
cat("########### Update SNP list END ############\n")
for (iType in c("eSNP", "xSNP")) {
cat(" ", length(setdiff(object[iType]@List, result[iType]@List)), " SNPs are removed from", iType, "list.\n")
}
result@Loss <- cbind(result@Loss,
exclude = c(result@Loss["Signal", "CIS"],
length(result["List", seq(22)][["eSNP"]]),
sapply(seq(22), function (iChr) {length(result["List", iChr][["eSNP"]])})))
cat("########### Exclude SNP list END ###########\n")
return(result)
}
})
setMethod(f = "reset", signature = "Enrichment", definition = function (object, i) {
switch(EXPR = i,
"Loss" = {
object@Loss <- data.frame()
},
"Data" = {
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "Data")
},
"LD" = {
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "LD")
},
"Call" = {
object@Call <- list(readEnrichment = list(pattern = NULL, signalFile = NULL, transcriptFile = NULL, snpListDir = NULL, snpInfoDir = NULL,
distThresh = NULL, sigThresh = NULL, LD = NULL, ldDir = NULL, mc.cores = NULL),
reSample = list(object = NULL, nSample = NULL, empiricPvalue = NULL, MAFpool = NULL, mc.cores = NULL, onlyGenome = NULL))
},
"eSNP" = {
object@eSNP <- enrichSNP()
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "eSNP")
},
"xSNP" = {
object@xSNP <- enrichSNP()
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "xSNP")
},
"List" = {
for (iType in c("eSNP", "xSNP")) {
object[iType]@List <- character()
}
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "List")
},
"Table" = {
for (iType in c("eSNP", "xSNP")) {
object[iType]@Table <- matrix(0, ncol = 2, nrow = 2)
}
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "Table")
},
"EnrichmentRatio" = {
for (iType in c("eSNP", "xSNP")) {
object[iType]@EnrichmentRatio <- numeric()
}
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "EnrichmentRatio")
},
"Z" = {
for (iType in c("eSNP", "xSNP")) {
object[iType]@Z <- numeric()
}
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "Z")
},
"PValue" = {
for (iType in c("eSNP", "xSNP")) {
object[iType]@PValue <- numeric()
}
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "PValue")
},
"Resampling" = {
for (iType in c("eSNP", "xSNP")) {
object[iType]@Resampling <- matrix(0, ncol = 5, nrow = 0)
}
object@Chromosomes <- lapply(object@Chromosomes, reset, i = "Resampling")
},
"Chromosomes" = {
object@Chromosomes <- eval(parse(text = paste0("list(", paste(paste0("Chrom", seq(22), " = chromosome()"), collapse = ", "), ")")))
},
stop('[Enrichment:reset] ', i, ' is not a "Enrichment" slot.', call. = FALSE)
)
return(object)
})
setMethod(f = "compareEnrichment", signature = "ANY", definition = function (object.x, object.y, pattern = "Chrom", nSample = 100, empiricPvalue = TRUE, mc.cores = 1, onlyGenome = TRUE) {
if (!missing(object.x) & !missing(object.y)) {
if (nSample<10) {
nSample = 10
warning('[Enrichment:compareEnrichment] "nSample" was increased to 10.', call. = FALSE)
} else {}
if (is.enrichment(object.x) & is.enrichment(object.y)) {
if (nrow(object.x["Data"]) == 0) {
stop('[Enrichment:compareEnrichment] "Enrichment" data is empty for "object.x".', call. = FALSE)
} else {}
if (nrow(object.y["Data"]) == 0) {
stop('[Enrichment:compareEnrichment] "Enrichment" data is empty for "object.y".', call. = FALSE)
} else {}
} else {
stop('[Enrichment:compareEnrichment] "Enrichment" object is required.', call. = FALSE)
}
sigThresh.x <- object.x@Call$readEnrichment$sigThresh
sigThresh.y <- object.y@Call$readEnrichment$sigThresh
if (!identical(sigThresh.x, sigThresh.y)) {
warning(paste0('[Enrichment:compareEnrichment] "sigThresh" differs from "object.x" to "object.y".\n "object.x" parameter is: ', deparse(sigThresh.x)), call. = FALSE)
} else {}
sigThresh <- sigThresh.x
MAFpool.x <- object.x@Call$reSample$MAFpool
MAFpool.y <- object.y@Call$reSample$MAFpool
if (!identical(MAFpool.x, MAFpool.y)) {
warning(paste0('[Enrichment:compareEnrichment] "MAFpool" differs from "object.x" to "object.y".\n "object.x" parameter is: ', deparse(MAFpool.x)), call. = FALSE)
} else {}
MAFpool <- eval(MAFpool.x)
if (missing(MAFpool) | is.null(MAFpool)) {
MAFpool <- c(0.05, 0.10, 0.2, 0.3, 0.4, 0.5)
} else{}
object.x@Call$reSample$empiricPvalue <- empiricPvalue
object.y@Call$reSample$empiricPvalue <- empiricPvalue
l1 <- object.x@eSNP@List
l2 <- object.y@eSNP@List
if (identical(l1, l2)) {
stop('[Enrichment:compareEnrichment] Both lists are identical.', call. = FALSE)
} else {}
if (is.null(object.x@Call$reSample$nSample) | is.null(object.y@Call$reSample$nSample)) {
cat("########## Resample objects Start ##########\n")
if (is.null(object.x@Call$reSample$nSample)) {
cat(" Resampling object.x ...\n")
.verbose(reSample(object = object.x, nSample = nSample, empiricPvalue = empiricPvalue, MAFpool = MAFpool, mc.cores = mc.cores, onlyGenome = onlyGenome))
} else {}
if (is.null(object.y@Call$reSample$nSample)) {
cat(" Resampling object.y ...\n")
.verbose(reSample(object = object.y, nSample = nSample, empiricPvalue = empiricPvalue, MAFpool = MAFpool, mc.cores = mc.cores, onlyGenome = onlyGenome))
} else {}
cat("########### Resample objects End ###########\n")
} else {}
enrichObject1 <- object.x
enrichObject2 <- object.y
object.x <- reset(object.x, "Resampling")
object.y <- reset(object.y, "Resampling")
if (length(l1)<length(l2)) {
object1 <- object.x
object2 <- object.y
namesRes <- c("Enrichment_1", "Enrichment_2", "PVALUE_1", "PVALUE_2", "PVALUE", "nSAMPLE", "SNP_1", "SNP_2")
} else {
object1 <- object.y
object2 <- object.x
namesRes <- c("Enrichment_2", "Enrichment_1", "PVALUE_2", "PVALUE_1", "PVALUE", "nSAMPLE", "SNP_2", "SNP_1")
}
rm(object.x, object.y)
object2 <- reset(object2, "Data")
object2 <- reset(object2, "LD")
cat("############ Comparison Start ##############\n")
if (onlyGenome == FALSE) {
listRes <- eval(parse(text = paste0("list(", paste(paste0("Chrom", seq(22), " = NULL"), collapse = ", "), ")")))
for (iChr in seq(22)) {
cat(" Chromosome ", if (nchar(iChr) == 1) {paste0("0", iChr)} else {iChr}, ": ", sep = "")
listRes[[iChr]] <- .compareEnrich(object1 = object1@Chromosomes[[iChr]], object2 = object2@Chromosomes[[iChr]], nSample = nSample, empiricPvalue = empiricPvalue, sigThresh = sigThresh, MAFpool = MAFpool, mc.cores = mc.cores)
if (identical(sort(object1@Chromosomes[[iChr]]@eSNP@List), sort(object2@Chromosomes[[iChr]]@eSNP@List))) {
listRes[[iChr]] <- reset(listRes[[iChr]], "Z")
listRes[[iChr]] <- reset(listRes[[iChr]], "Resampling")
listRes[[iChr]]@eSNP@PValue <- as.numeric(NA)
listRes[[iChr]]@xSNP@PValue <- as.numeric(NA)
} else {}
cat("END\n")
}
} else {}
cat(" Genome : ")
result <- .compareEnrich(object1 = object1, object2 = object2, nSample = nSample, empiricPvalue = empiricPvalue, sigThresh = sigThresh, MAFpool = MAFpool, mc.cores = mc.cores)
if (onlyGenome == FALSE) {
result@Chromosomes <- listRes
} else {}
cat("END\n")
res <- list(eSNP = NULL, xSNP = NULL)
summaryObj1 <- print(object1, what = "All")
summaryObj2 <- print(object2, what = "All")
summaryRes <- print(result, what = "All")
if (empiricPvalue) {
res[["eSNP"]] <- cbind(summaryObj1[["eSNP"]][, "EnrichmentRatio"], summaryObj2[["eSNP"]][, "EnrichmentRatio"], summaryObj1[["eSNP"]][, "PValue"], summaryObj2[["eSNP"]][, "PValue"], summaryRes[["eSNP"]][, c("PValue", "nSample")], summaryObj1[["eSNP"]][, "eSNP"], summaryObj2[["eSNP"]][, "eSNP"])
res[["xSNP"]] <- cbind(summaryObj1[["xSNP"]][, "EnrichmentRatio"], summaryObj2[["xSNP"]][, "EnrichmentRatio"], summaryObj1[["xSNP"]][, "PValue"], summaryObj2[["xSNP"]][, "PValue"], summaryRes[["xSNP"]][, c("PValue", "nSample")], summaryObj1[["xSNP"]][, "xSNP"], summaryObj2[["xSNP"]][, "xSNP"])
colnames(res[["eSNP"]]) <- namesRes
colnames(res[["xSNP"]]) <- namesRes
} else {
res[["eSNP"]] <- cbind(summaryObj1[["eSNP"]][, "EnrichmentRatio"], summaryObj2[["eSNP"]][, "EnrichmentRatio"], summaryObj1[["eSNP"]][, "PValue"], summaryObj2[["eSNP"]][, "PValue"], summaryRes[["eSNP"]][, c("PValue", "Z", "nSample")], summaryObj1[["eSNP"]][, "eSNP"], summaryObj2[["eSNP"]][, "eSNP"])
res[["xSNP"]] <- cbind(summaryObj1[["xSNP"]][, "EnrichmentRatio"], summaryObj2[["xSNP"]][, "EnrichmentRatio"], summaryObj1[["xSNP"]][, "PValue"], summaryObj2[["xSNP"]][, "PValue"], summaryRes[["xSNP"]][, c("PValue", "Z", "nSample")], summaryObj1[["xSNP"]][, "xSNP"], summaryObj2[["xSNP"]][, "xSNP"])
colnames(res[["eSNP"]]) <- c(namesRes[1:5], "Z", namesRes[6:8])
colnames(res[["xSNP"]]) <- c(namesRes[1:5], "Z", namesRes[6:8])
}
cat("############# Comparison End ###############\n")
warning("[Enrichment:compareEnrichment] This function is in development!", call. = FALSE)
if (onlyGenome) {
return(invisible(list(object.xy = print(result, what = "Genome"), object.x = print(enrichObject1, what = "Genome"), object.y = print(enrichObject2, what = "Genome"))))
} else {
return(invisible(list(object.xy = print(result), object.x = print(enrichObject1), object.y = print(enrichObject2))))
}
} else {
stop('[Enrichment:compareEnrichment] "Enrichment" object is required.', call. = FALSE)
}
})
setMethod(f = "plot", signature = "Enrichment", definition = function (x, what = "Genome", type = c("eSNP", "xSNP"), ggplot = FALSE, pvalue = TRUE, ...) {
if (is.null(unlist(x@Call$reSample))) {
stop('[Enrichment:plot] "reSample" have to be run before "plot".', call. = FALSE)
} else {}
if (is.null(what) | any(!what%in%c("All", "Genome", seq(22)))) {
stop('[Enrichment:plot] "what" must be: "All", "Genome" or numeric value (atomic or vector).', call. = FALSE)
} else {}
if (is.null(type) | any(!type%in%c("eSNP", "xSNP"))) {
stop('[Enrichment:plot] "type" must be: "eSNP" and/or "xSNP".', call. = FALSE)
} else {}
if (any(type%in%"xSNP") & length(x["xSNP"]["List"])==0) {
type <- "eSNP"
} else {}
.computeER4plot <- function (EnrichSNPObject) {
ER <- EnrichSNPObject@EnrichmentRatio
if (nrow(EnrichSNPObject@Resampling)==0) {
stop('[Enrichment:plot] "reSample" have to be run before "plot".', call. = FALSE)
} else {}
resampling <- EnrichSNPObject@Resampling[, 5]
ERsample <- NULL
size <- length(resampling)
if (size >= 1000) {
interv <- unique(c(seq(from = min(1000, floor(0.1*size)), to = size, by = floor(size/1000)), size))
} else {
interv <- unique(c(seq(from = max(floor(0.1*size), 3), to = size, by = 1), size))
}
ERsample <- sapply(interv, function (k) {
resamplingInterv <- resampling[1:k]
resamplingClean <- resamplingInterv[!(is.na(resamplingInterv) | is.infinite(resamplingInterv))]
mu <- mean(resamplingClean)
sigma <- sqrt(var(resamplingClean))
if (sigma==0 | is.na(sigma)) {
if (mu==0 ) {
return(0)
} else {
return((ER-mu))
}
} else {
return((ER-mu)/sigma)
}
})
names(ERsample) <- interv
return(as.matrix(ERsample))
}
.computeEmpP4plot <- function (EnrichSNPObject) {
ER <- EnrichSNPObject@EnrichmentRatio
if (nrow(EnrichSNPObject@Resampling)==0) {
stop('[Enrichment:plot] "reSample" have to be run before "plot".', call. = FALSE)
} else {}
resampling <- EnrichSNPObject@Resampling[, 5]
ERsample <- NULL
size <- length(resampling)
if (size >= 1000) {
interv <- unique(c(seq(from = min(1000, floor(0.1*size)), to = size, by = floor(size/1000)), size))
} else {
interv <- unique(c(seq(from = max(floor(0.1*size), 3), to = size, by = 1), size))
}
ERsample <- sapply(interv, function (k) {
resamplingInterv <- resampling[1:k]
resamplingClean <- resamplingInterv[!(is.na(resamplingInterv) | is.infinite(resamplingInterv))]
sum(EnrichSNPObject@EnrichmentRatio<resamplingClean)/length(resamplingClean)
})
names(ERsample) <- interv
return(as.matrix(ERsample))
}
if (x@Call$reSample$empiricPvalue) {
matrixER <- list(eSNP = NULL, xSNP = NULL)
for (iType in type) {
if (length(what)==1) {
switch(EXPR = as.character(what),
"Genome" = {
matrixER[[iType]] <- .computeEmpP4plot(x[iType])
colnames(matrixER[[iType]]) <- "Genome"
},
"All" = {
matrixER[[iType]] <- .computeEmpP4plot(x[iType])
for (j in seq(22)) {
matrixER[[iType]] <- cbind(matrixER[[iType]], .computeEmpP4plot(x["Chromosomes", j][iType]))
}
colnames(matrixER[[iType]]) <- c("Genome", paste0("Chrom", seq(22)))
},
{
for (j in what) {
matrixER[[iType]] <- cbind(matrixER[[iType]], .computeEmpP4plot(x["Chromosomes", j][iType]))
}
colnames(matrixER[[iType]]) <- paste0("Chrom", what)
}
)
} else {
for (j in what) {
matrixER[[iType]] <- cbind(matrixER[[iType]], .computeEmpP4plot(x["Chromosomes", j][iType]))
}
colnames(matrixER[[iType]]) <- paste0("Chrom", what)
}
}
} else {
matrixER <- list(eSNP = NULL, xSNP = NULL)
for (iType in type) {
if (length(what)==1) {
switch(EXPR = as.character(what),
"Genome" = {
matrixER[[iType]] <- .computeER4plot(x[iType])
colnames(matrixER[[iType]]) <- "Genome"
},
"All" = {
matrixER[[iType]] <- .computeER4plot(x[iType])
for (j in seq(22)) {
matrixER[[iType]] <- cbind(matrixER[[iType]], .computeER4plot(x["Chromosomes", j][iType]))
}
colnames(matrixER[[iType]]) <- c("Genome", paste0("Chrom", seq(22)))
},
{
for (j in what) {
matrixER[[iType]] <- cbind(matrixER[[iType]], .computeER4plot(x["Chromosomes", j][iType]))
}
colnames(matrixER[[iType]]) <- paste0("Chrom", what)
}
)
} else {
for (j in what) {
matrixER[[iType]] <- cbind(matrixER[[iType]], .computeER4plot(x["Chromosomes", j][iType]))
}
colnames(matrixER[[iType]]) <- paste0("Chrom", what)
}
}
}
if (ggplot) {
is.installed <- function (mypkg) {
is.element(mypkg, installed.packages()[,1])
}
# if (all(is.installed(c("ggplot2", "grid")))) {
if (require("ggplot2") & require("grid")) {
require(ggplot2)
require(grid)
multiplot <- function (..., plotlist = NULL, cols = 1, rows = 1, layout = NULL) {
plots <- c(list(...), plotlist)
numPlots = length(plots)
if (is.null(layout)) {
layout <- matrix(seq(1, cols * ceiling(numPlots/cols)), ncol = cols, nrow = rows, byrow = TRUE)
} else {}
if (numPlots==1) {
print(plots[[1]])
} else {
grid.newpage()
pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout))))
for (i in 1:numPlots) {
matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE))
print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row, layout.pos.col = matchidx$col))
}
}
}
.ggplotColours <- function (n = 6, h = c(0, 360) + 15) {
if ((diff(h)%%360) < 1) {
h[2] <- h[2] - 360/n
} else {}
hcl(h = (seq(h[1], h[2], length = n)), c = 100, l = 65)
}
listPlots <- list()
for (iType in type) {
if (pvalue) {
if (x@Call$reSample$empiricPvalue) {
ylab <- "P-Value (Empirical)"
} else {
matrixER[[iType]] <- apply(matrixER[[iType]], 2, pnorm, lower.tail = FALSE)
ylab <- "P-Value (From Z-statistic)"
}
} else {
ylab <- "Z statistic"
}
if (ncol(matrixER[[iType]])>1) {
matrixER[[iType]] <- apply(matrixER[[iType]], 2, scale)
} else {}
tmpDF <- as.data.frame(t(matrixER[[iType]]))
cnames <- colnames(tmpDF)
colnames(tmpDF) <- paste0("R", colnames(tmpDF))
tmpDF$IID <- factor(colnames(matrixER[[iType]]), levels = c("Genome", paste0("Chrom", seq(22))), labels = c("Genome", paste0("Chrom", seq(22))))
tmp <- reshape(tmpDF, idvar = "IID", direction = "long", varying = list(grep("R", colnames(tmpDF))), times = cnames)
colnames(tmp) <- c("IID", "Resampling", "Z")
tmp[, "Resampling"] <- as.numeric(tmp[, "Resampling"])
p <- ggplot(data = tmp, aes_string(x = "Resampling", y = "Z", colour = "IID")) + geom_line()
noGridColour <- "transparent" # c("gray90", "grey95")
base_size <- 12
base_family <- ""
p <- p + theme(
line = element_line(colour = "black", size = 0.5, linetype = 1, lineend = "butt"),
rect = element_rect(fill = "white", colour = "black", size = 0.5, linetype = 1),
text = element_text(family = base_family, face = "plain", colour = "black", size = base_size, hjust = 0.5, vjust = 0.5, angle = 0, lineheight = 0.9),
axis.text = element_text(size = rel(0.8), colour = "black"),
strip.text = element_text(size = rel(0.8)),
axis.line = element_blank(),
axis.text.x = element_text(vjust = 1),
axis.text.y = element_text(hjust = 1),
axis.ticks = element_line(colour = "black"),
axis.title.x = element_text(),
axis.title.y = element_text(angle = 90),
axis.ticks.length = unit(0.15, "cm"),
axis.ticks.margin = unit(0.1, "cm"),
legend.background = element_rect(fill = "white", colour = "black"),
legend.margin = unit(0.2, "cm"),
legend.key = element_rect(fill = "white", colour = "black"),
legend.key.size = unit(1.2, "lines"),
legend.key.height = NULL,
legend.key.width = NULL,
legend.text = element_text(size = rel(0.8)),
legend.text.align = NULL,
legend.title = element_text(size = rel(0.8), face = "bold", hjust = 0),
legend.title.align = NULL,
legend.position = "right",
legend.direction = NULL,
legend.justification = "center",
legend.box = NULL,
panel.background = element_rect(fill = "white", colour = "black"),
panel.border = element_blank(),
panel.grid.major = element_line(colour = noGridColour[1]),
panel.grid.minor = element_line(colour = noGridColour[length(noGridColour)], size = 0.25),
panel.margin = unit(0.25, "lines"),
strip.background = element_rect(fill = "black", colour = "black"),
strip.text.x = element_text(colour = "white"),
strip.text.y = element_text(angle = -90, colour = "white"),
plot.background = element_rect(colour = "white"),
plot.title = element_text(size = rel(1.2)),
plot.margin = unit(c(1, 1, 0.5, 0.5), "lines"),
complete = TRUE
)
p <- p + xlab(paste(iType, "Resampling"))
if (ncol(matrixER[[iType]])>1) {
p <- p + ylab(paste(ylab, "(scale and center)"))
} else {
p <- p + ylab(ylab)
}
p <- p + theme(legend.title = element_blank())
if (length(what)>=5 | what == "All") {
p <- p + theme(legend.background = element_rect(fill = "gray90", linetype = "dotted"))
} else {
quarter <- floor(3/4*nrow(tmp)):nrow(tmp)
rangeZtmp <- range(tmp[, "Z"])
if (rangeZtmp[1] == rangeZtmp[2]) {
if (all(rangeZtmp==0)) {
rangeZtmp[1] <- -1
rangeZtmp[2] <- 1
} else {
rangeZtmp[1] <- rangeZtmp[1]*0.90
rangeZtmp[2] <- rangeZtmp[2]*1.10
}
} else {}
rangeZ <- seq(rangeZtmp[1], rangeZtmp[2], by = diff(rangeZtmp)*1/3)
names(rangeZ) <- c("0%", "33%", "66%", "100%")
rangeQuarter <- range(tmp[quarter, "Z"])
inf <- apply(sapply(rangeQuarter, function (lim) {
lim<rangeZ
}), 1, all)
sup <- apply(sapply(rangeQuarter, function (lim) {
lim>rangeZ
}), 1, all)
if (sum(inf)<=sum(sup)) {
p <- p + theme(legend.justification = c(1, 0), legend.position = c(1, 0))
} else {
p <- p + theme(legend.justification = c(1, 1), legend.position = c(1, 1))
}
}
if ("Genome" %in% unique(tmp$IID)) {
p <- p + scale_colour_manual(values = c("black", .ggplotColours(ifelse(length(unique(tmp$IID))-1>0, length(unique(tmp$IID))-1, 1))))
} else {}
listPlots[[iType]] <- p
}
multiplot(plotlist = listPlots, cols = length(listPlots))
return(invisible(listPlots))
} else {
stop('[Enrichment:plot] "ggPlot2" and "grid" packages must be installed with "ggplot=TRUE".', call. = FALSE)
}
} else {
par(mfrow = c(1, length(type)))
for (iType in type) {
if (pvalue) {
if (x@Call$reSample$empiricPvalue) {
matrixER[[iType]] <- .computeEmpP4plot(x[iType])
ylab <- "P-Value (Empirical)"
} else {
matrixER[[iType]] <- apply(matrixER[[iType]], 2, pnorm, lower.tail = FALSE)
ylab <- "P-Value (From Z-statistic)"
}
} else {
ylab <- "Z statistic"
}
nbCol <- ncol(matrixER[[iType]])
ylim <- range(na.exclude(matrixER[[iType]]))
xNames <- rownames(matrixER[[iType]])
colors <- rainbow(nbCol)
if (nbCol>1) {
matrixER[[iType]] <- apply(matrixER[[iType]], 2, scale)
ylab <- paste(ylab, "(scale and center)")
plot(x = xNames, y = matrixER[[iType]][, 1], ylab = ylab, xlab = iType, type = "l", ylim = ylim)
res <- sapply(seq(ncol(matrixER[[iType]][, -1])), function (iER) {
lines(x = xNames, y = matrixER[[iType]][, iER+1], iType = "l", ylim = ylim, col = colors[iER+1])
})
} else {
plot(x = xNames, y = matrixER[[iType]][, 1], ylab = ylab, xlab = iType, type = "l", ylim = ylim)
}
}
return(invisible())
}
})
setMethod(f = "getEnrichSNP", signature = "Enrichment", definition = function (object, type = "eSNP") {
alpha <- object["Call"][["readEnrichment"]][["sigThresh"]]
resData <- switch(type,
"eSNP" = {
object["Data"][object["Data"][, "PVALUE"]<alpha & object["Data"][, type]==1, ]
},
"xSNP" = {
if (object["Call"][["readEnrichment"]][["LD"]]) {
message('Loading ...')
dataSNP <- object["Data"]
dataLD <- object["LD"]
xSNP <- dataSNP[dataSNP[, "PVALUE"]<alpha & dataSNP[, type]==1, ]
dataLDtmp <- dataLD[dataLD %in% xSNP[, "SNP"]]
dataLDtmp <- cbind(SNP_A = names(dataLDtmp), SNP_B = dataLDtmp)
dataLDtmp <- dataLDtmp[dataLDtmp[, "SNP_A"]%in%dataSNP[dataSNP[, "eSNP"]%in%1, "SNP"], ]
xSNPld <- do.call("rbind",by(dataLDtmp, dataLDtmp[, "SNP_B"], function (iDta) {
cbind(xSNP = unique(as.character(iDta[, "SNP_B"])), LD_with_eSNP = paste(iDta[, "SNP_A"], collapse = ";"))
}))
merge(xSNP, xSNPld, by.x = "SNP", by.y = "xSNP")
} else {
warning('[Enrichment:getEnrichSNP] significant "eSNP" are returned instead of "xSNP",\n "readEnrichment" should be run with "LD=TRUE".', call. = FALSE)
object["Data"][object["Data"][, "PVALUE"]<alpha & object["Data"][, type]==1, ]
}
},
stop('[Enrichment:getEnrichSNP] "type" should be equal to "eSNP" or "xSNP".', call. = FALSE)
)
return(resData)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.