##########################################################################################
# Helper Intermediate Methods
##########################################################################################
.mergeParams <- function(paramInput = NULL, paramDefault = NULL){
for(i in seq_along(paramDefault)){
if(!(names(paramDefault)[i] %in% names(paramInput))){
paramInput[[names(paramDefault)[i]]] <- paramDefault[[i]]
}
}
return(paramInput)
}
.requirePackage <- function(x = NULL, load = TRUE, installInfo = NULL, source = NULL){
if(x %in% rownames(installed.packages())){
if(load){
suppressPackageStartupMessages(require(x, character.only = TRUE))
}else{
return(0)
}
}else{
if(!is.null(source) & is.null(installInfo)){
if(tolower(source) == "cran"){
installInfo <- paste0('install.packages("',x,'")')
}else if(tolower(source) == "bioc"){
installInfo <- paste0('BiocManager::install("',x,'")')
}else{
stop("Unrecognized package source, available are cran/bioc!")
}
}
if(!is.null(installInfo)){
stop(paste0("Required package : ", x, " is not installed/found!\n Package Can Be Installed : ", installInfo))
}else{
stop(paste0("Required package : ", x, " is not installed/found!"))
}
}
}
##########################################################################################
# Safe saveRDS check
##########################################################################################
.safeSaveRDS <- function(
object = NULL,
file = "",
ascii = FALSE,
version = NULL,
compress = TRUE,
refhook = NULL
){
#Try to save a test data.frame in location
testDF <- data.frame(a=1,b=2)
canSave <- suppressWarnings(tryCatch({
saveRDS(object = testDF, file = file, ascii = ascii, version = version, compress = compress, refhook = refhook)
TRUE
}, error = function(x){
FALSE
}))
if(!canSave){
dirExists <- dir.exists(dirname(file))
if(dirExists){
stop("Cannot saveRDS. File Path : ", file)
}else{
stop("Cannot saveRDS because directory does not exist (",dirname(file),"). File Path : ", file)
}
}else{
saveRDS(object = object, file = file, ascii = ascii, version = version, compress = compress, refhook = refhook)
}
}
##########################################################################################
# Stat/Summary Methods
##########################################################################################
.computeKNN <- function(
data = NULL,
query = NULL,
k = 50,
includeSelf = FALSE,
...
){
.validInput(input = data, name = "data", valid = c("dataframe", "matrix"))
.validInput(input = query, name = "query", valid = c("dataframe", "matrix"))
.validInput(input = k, name = "k", valid = c("integer"))
.validInput(input = includeSelf, name = "includeSelf", valid = c("boolean"))
if(is.null(query)){
query <- data
searchSelf <- TRUE
}else{
searchSelf <- FALSE
}
.requirePackage("nabor", source = "cran")
if(searchSelf & !includeSelf){
knnIdx <- nabor::knn(data = data, query = query, k = k + 1, ...)$nn.idx
knnIdx <- knnIdx[,-1,drop=FALSE]
}else{
knnIdx <- nabor::knn(data = data, query = query, k = k, ...)$nn.idx
}
knnIdx
}
.rowZscores <- function(m = NULL, min = -2, max = 2, limit = FALSE){
z <- sweep(m - rowMeans(m), 1, matrixStats::rowSds(m),`/`)
if(limit){
z[z > max] <- max
z[z < min] <- min
}
return(z)
}
.computeROC <- function(labels = NULL, scores = NULL, name="ROC"){
.calcAUC <- function(TPR = NULL, FPR = NULL){
# http://blog.revolutionanalytics.com/2016/11/calculating-auc.html
dFPR <- c(diff(FPR), 0)
dTPR <- c(diff(TPR), 0)
out <- sum(TPR * dFPR) + sum(dTPR * dFPR)/2
return(out)
}
labels <- labels[order(scores, decreasing=TRUE)]
df <- data.frame(
False_Positive_Rate = cumsum(!labels)/sum(!labels),
True_Positive_Rate = cumsum(labels)/sum(labels)
)
df$AUC <- round(.calcAUC(df$True_Positive_Rate,df$False_Positive_Rate),3)
df$name <- name
return(df)
}
.getQuantiles <- function(v = NULL, len = length(v)){
if(length(v) < len){
v2 <- rep(0, len)
v2[seq_along(v)] <- v
}else{
v2 <- v
}
p <- trunc(rank(v2))/length(v2)
if(length(v) < len){
p <- p[seq_along(v)]
}
return(p)
}
.rowScale <- function(mat = NULL, min = NULL, max = NULL){
if(!is.null(min)){
rMin <- min
}else{
rMin <- matrixStats::rowMins(mat)
}
if(!is.null(max)){
rMax <- max
}else{
rMax <- matrixStats::rowMaxs(mat)
}
rScale <- rMax - rMin
matDiff <- mat - rMin
matScale <- matDiff/rScale
out <- list(mat=matScale, min=rMin, max=rMax)
return(out)
}
.quantileCut <- function(x = NULL, lo = 0.025, hi = 0.975, maxIf0 = TRUE){
q <- quantile(x, probs = c(lo,hi))
if(q[2] == 0){
if(maxIf0){
q[2] <- max(x)
}
}
x[x < q[1]] <- q[1]
x[x > q[2]] <- q[2]
return(x)
}
.normalizeCols <- function(mat = NULL, colSm = NULL, scaleTo = NULL){
if(is.null(colSm)){
colSm <- Matrix::colSums(mat)
}
if(!is.null(scaleTo)){
mat@x <- scaleTo * mat@x / rep.int(colSm, Matrix::diff(mat@p))
}else{
mat@x <- mat@x / rep.int(colSm, Matrix::diff(mat@p))
}
return(mat)
}
.safeSubset <- function(mat = NULL, subsetRows = NULL, subsetCols = NULL){
if(!is.null(subsetRows)){
idxNotIn <- which(subsetRows %ni% rownames(mat))
if(length(idxNotIn) > 0){
subsetNamesNotIn <- subsetRows[idxNotIn]
matNotIn <- Matrix::sparseMatrix(i=1,j=1,x=0,dims=c(length(idxNotIn), ncol = ncol(mat)))
rownames(matNotIn) <- subsetNamesNotIn
mat <- rbind(mat, matNotIn)
}
mat <- mat[subsetRows,]
}
if(!is.null(subsetCols)){
idxNotIn <- which(subsetCols %ni% colnames(mat))
if(length(idxNotIn) > 0){
subsetNamesNotIn <- subsetCols[idxNotIn]
matNotIn <- Matrix::sparseMatrix(i=1,j=1,x=0,dims=c(nrow(mat), ncol = length(idxNotIn)))
colnames(matNotIn) <- subsetNamesNotIn
mat <- cbind(mat, matNotIn)
}
mat <- mat[,subsetCols]
}
mat
}
.groupMeans <- function(mat = NULL, groups=NULL, na.rm = TRUE, sparse = FALSE){
stopifnot(!is.null(groups))
stopifnot(length(groups)==ncol(mat))
gm <- lapply(unique(groups), function(x){
if(sparse){
Matrix::rowMeans(mat[,which(groups==x),drop=F], na.rm=na.rm)
}else{
rowMeans(mat[,which(groups==x),drop=F], na.rm=na.rm)
}
}) %>% Reduce("cbind",.)
colnames(gm) <- unique(groups)
return(gm)
}
.groupSums <- function(mat = NULL, groups=NULL, na.rm = TRUE, sparse = FALSE){
stopifnot(!is.null(groups))
stopifnot(length(groups)==ncol(mat))
gm <- lapply(unique(groups), function(x){
if(sparse){
Matrix::rowSums(mat[,which(groups==x),drop=F], na.rm=na.rm)
}else{
rowSums(mat[,which(groups==x),drop=F], na.rm=na.rm)
}
}) %>% Reduce("cbind",.)
colnames(gm) <- unique(groups)
return(gm)
}
.groupSds <- function(mat = NULL, groups = NULL, na.rm = TRUE, sparse = FALSE){
stopifnot(!is.null(groups))
stopifnot(length(groups)==ncol(mat))
gs <- lapply(unique(groups), function(x){
if (sparse){
matrixStats::rowSds(as.matrix(mat[, which(groups == x), drop = F]), na.rm = na.rm)
}else{
matrixStats::rowSds(mat[, which(groups == x), drop = F], na.rm = na.rm)
}
}) %>% Reduce("cbind",.)
colnames(gs) <- unique(groups)
return(gs)
}
.centerRollMean <- function(v = NULL, k = NULL){
o1 <- data.table::frollmean(v, k, align = "right", na.rm = FALSE)
if(k%%2==0){
o2 <- c(rep(o1[k], floor(k/2)-1), o1[-seq_len(k-1)], rep(o1[length(o1)], floor(k/2)))
}else if(k%%2==1){
o2 <- c(rep(o1[k], floor(k/2)), o1[-seq_len(k-1)], rep(o1[length(o1)], floor(k/2)))
}else{
stop("Error!")
}
o2
}
##########################################################################################
# Miscellaneous Methods
##########################################################################################
.splitEvery <- function(x = NULL, n = NULL){
#https://stackoverflow.com/questions/3318333/split-a-vector-into-chunks-in-r
if(is.atomic(x)){
split(x, ceiling(seq_along(x) / n))
}else{
split(x, ceiling(seq_len(nrow(x)) / n))
}
}
.suppressAll <- function(expr = NULL){
suppressPackageStartupMessages(suppressMessages(suppressWarnings(expr)))
}
.getAssay <- function(se = NULL, assayName = NULL){
.assayNames <- function(se){
names(SummarizedExperiment::assays(se))
}
if(is.null(assayName)){
o <- SummarizedExperiment::assay(se)
}else if(assayName %in% .assayNames(se)){
o <- SummarizedExperiment::assays(se)[[assayName]]
}else{
stop(sprintf("assayName '%s' is not in assayNames of se : %s", assayName, paste(.assayNames(se),collapse=", ")))
}
return(o)
}
.fileExtension <- function (x = NULL){
pos <- regexpr("\\.([[:alnum:]]+)$", x)
ifelse(pos > -1L, substring(x, pos + 1L), "")
}
.checkPath <- function(u = NULL, path = NULL, throwError = TRUE){
if(is.null(u)){
out <- TRUE
}
out <- lapply(u, function(x, error = TRUE){
if (Sys.which(x) == "") {
if(!is.null(path) && file.exists(file.path(path, x))){
o <- TRUE
}else{
if(throwError){
stop(x, " not found in path, please add ", x, " to path!")
}else{
o <- FALSE
}
}
}else{
o <- TRUE
}
return(o)
}) %>% unlist %>% all
return(out)
}
.tempfile <- function(pattern = "tmp", tmpdir = "tmp", fileext = "", addDOC = TRUE){
#if the directory doesnt already exist and file.exists evaluates to true, then a file exists with that name
if(!dir.exists(tmpdir)){
if(file.exists(tmpdir)){
stop(paste0("Attempted to create temporary directory ", tmpdir," but a file already exists with this name. Please remove this file and try again!"))
}
}
dir.create(tmpdir, showWarnings = FALSE)
if(!dir.exists(tmpdir)){
stop(paste0("Unable to create temporary directory ", tmpdir,". Check file permissions!"))
}
if(addDOC){
doc <- paste0("-Date-", Sys.Date(), "_Time-", gsub(":","-", stringr::str_split(Sys.time(), pattern=" ",simplify=TRUE)[1,2]))
}else{
doc <- ""
}
tempfile(pattern = paste0(pattern, "-"), tmpdir = tmpdir, fileext = paste0(doc, fileext))
}
.ArchRLogo <- function(ascii = "Logo", messageLogo = TRUE){
Ascii <- list(
Package = c("
___ .______ ______ __ __ .______
/ \\\ | _ \\\ / || | | | | _ \\\
/ ^ \\\ | |_) | | ,----'| |__| | | |_) |
/ /_\\\ \\\ | / | | | __ | | /
/ _____ \\\ | |\\\ \\\\___ | `----.| | | | | |\\\ \\\\___.
/__/ \\__\\ | _| `._____| \\______||__| |__| | _| `._____|
"),
#modified from cyu@athena.mit.edu
Logo = c("
/ |
/ \\\
. / |.
\\\\\\ / |.
\\\\\\ / `|.
\\\\\\ / |.
\\\ / |\\\
\\\\#####\\\ / ||
==###########> / ||
\\\\##==......\\\ / ||
______ = =|__ /__ || \\\\\\\
,--' ,----`-,__ ___/' --,-`-===================##========>
\\\ ' ##_______ _____ ,--,__,=##,__ ///
, __== ___,-,__,--'#' ===' `-' | ##,-/
-,____,---' \\\\####\\\\________________,--\\\\_##,/
___ .______ ______ __ __ .______
/ \\\ | _ \\\ / || | | | | _ \\\
/ ^ \\\ | |_) | | ,----'| |__| | | |_) |
/ /_\\\ \\\ | / | | | __ | | /
/ _____ \\\ | |\\\ \\\\___ | `----.| | | | | |\\\ \\\\___.
/__/ \\__\\ | _| `._____| \\______||__| |__| | _| `._____|
")
)
if(messageLogo){
message(Ascii[[ascii]])
}else{
Ascii[[ascii]]
}
}
##########################################################################################
# Batch Methods
##########################################################################################
.safelapply <- function(..., threads = 1, preschedule = FALSE){
if(tolower(.Platform$OS.type) == "windows"){
threads <- 1
}
if(threads > 1){
.requirePackage("parallel", source = "cran")
o <- mclapply(..., mc.cores = threads, mc.preschedule = preschedule)
errorMsg <- list()
for(i in seq_along(o)){ #Make Sure this doesnt explode!
if(inherits(o[[i]], "try-error")){
capOut <- utils::capture.output(o[[i]])
capOut <- capOut[!grepl("attr\\(\\,|try-error", capOut)]
capOut <- head(capOut, 10)
capOut <- unlist(lapply(capOut, function(x) substr(x, 1, 250)))
capOut <- paste0("\t", capOut)
errorMsg[[length(errorMsg) + 1]] <- paste0(c(paste0("Error Found Iteration ", i, " : "), capOut), "\n")
}
}
if(length(errorMsg) != 0){
errorMsg <- unlist(errorMsg)
errorMsg <- head(errorMsg, 50)
errorMsg[1] <- paste0("\n", errorMsg[1])
stop(errorMsg)
}
}else{
o <- lapply(...)
}
o
}
.batchlapply <- function(args = NULL, sequential = FALSE){
if(is.null(args$tstart)){
args$tstart <- Sys.time()
}
#Determine Parallel Backend
if(inherits(args$parallelParam, "BatchtoolsParam")){
.logStop("Batchtools not yet fully supported please use local parallel threading!", logFile = args$logFile)
.logDiffTime("Batch Execution w/ BatchTools through BiocParallel!", t1 = args$tstart, verbose = TRUE, logFile = args$logFile)
require(BiocParallel)
args$parallelParam <- btParam
#Unlink registry Directory
if(dir.exists(args$registryDir)){
#Clean Up Registry
unlink(args$registryDir, recursive = TRUE)# Delete registry directory
}
#Set Up Registry For Runnning
args$parallelParam$registryargs <- batchtoolsRegistryargs(
file.dir = args$registryDir,
work.dir = getwd(),
packages = character(0L),
namespaces = character(0L),
source = character(0L),
load = character(0L)
)
#Register
BPPARAM <- args$parallelParam
register(BPPARAM)
#Add To Args
args$BPPARAM <- BPPARAM
if("..." %in% names(args)){
args["..."] <- NULL
}
#Run
args <- args[names(args) %ni% c("threads", "parallelParam", "subThreading")]
outlist <- do.call(bplapply, args)
}else{
.logDiffTime("Batch Execution w/ safelapply!", t1 = args$tstart, verbose = TRUE, logFile = args$logFile)
if(sequential){
args$subThreads <- args$threads
args$threads <- 1
}else{
if(args$threads > length(args$X)){
args$subThreads <- floor( args$threads / length(args$X) )
args$threads <- length(args$X)
}else{
args$subThreads <- 1
}
}
args <- args[names(args) %ni% c("registryDir", "parallelParam", "subThreading")]
outlist <- do.call(.safelapply, args)
}
return(outlist)
}
.retryCatch <- function(expr, ..., maxAttempts = 3, warnAttempts = FALSE, nameFN = "FN", printInfo = NULL, logFile = NULL){
currentAttempt <- 0
completed <- FALSE
while(!completed & currentAttempt <= maxAttempts){
currentAttempt <- currentAttempt + 1
if(currentAttempt > 1){
.logMessage(nameFN, " : Error occured, attempting again (", currentAttempt - 1, " of ", maxAttempts, ")", logFile = logFile)
}
###########################################################
tryResult <- tryCatch({
#########################################################
#Try Catch Statement Here
if(warnAttempts){
out <- return(expr)
}else{
out <- suppressWarnings(return(expr))
}
#########################################################
list(out = out, completed = TRUE)
}, error = function(e){
list(out = e, completed = FALSE)
}, ...)
###########################################################
completed <- tryResult$completed
}
if(!completed){
.logMessage(nameFN, " : Error occured and could not be resolved after ", maxAttempts, " additional attempts!", logFile = logFile)
if(!is.null(printInfo)){
.logMessage("Error occured at ", printInfo, logFile = logFile)
}
print(tryResult[[1]])
stop()
}
tryResult[[1]]
}
##########################################################################################
# Developer Utils
##########################################################################################
.devMode <- function(package = "ArchR"){
# fn <- unclass(lsf.str(envir = asNamespace(package), all = TRUE))
# for(i in seq_along(fn)){
# tryCatch({
# assign(fn[i], paste0(package,':::', fn[i]), envir=globalenv())
# #eval(parse(text=paste0(fn[i], paste0('<<-',package,':::'), fn[i])))
# }, error = function(x){
# })
# }
fn <- unclass(lsf.str(envir = asNamespace("ArchR"), all = TRUE))
for(i in seq_along(fn)){
tryCatch({
eval(parse(text=paste0(fn[i], '<-ArchR:::', fn[i])))
}, error = function(x){
})
}
}
.convertToPNG <- function(
ArchRProj = NULL,
paths = c("QualityControl"),
recursive = TRUE,
outDir = "Figures",
command = "mv"
){
#If error try
#brew install fontconfig
.requirePackage("pdftools", source = "cran")
if(!is.null(ArchRProj)){
paths <- c(paths, file.path(getOutputDirectory(ArchRProj), "Plots"))
}
pdfFiles <- lapply(seq_along(paths), function(i){
if(recursive){
dirs <- list.dirs(paths[i], recursive = FALSE, full.names = FALSE)
if(length(dirs) > 0){
pdfs <- lapply(seq_along(dirs), function(j){
list.files(file.path(paths[i], dirs[j]), full.names = TRUE, pattern = "\\.pdf")
}) %>% unlist
}else{
pdfs <- c()
}
pdfs <- c(list.files(paths[i], full.names = TRUE, pattern = "\\.pdf"), pdfs)
}else{
pdfs <- list.files(paths[i], full.names = TRUE, pattern = "\\.pdf")
}
pdfs
}) %>% unlist
dir.create(outDir, showWarnings = FALSE)
for(i in seq_along(pdfFiles)){
print(i)
tryCatch({
pdf_convert(
pdfFiles[i],
format = "png",
pages = NULL,
filenames = file.path(outDir, gsub("\\.pdf", "_%d.png",basename(pdfFiles[i]))),
dpi = 300,
opw = "",
upw = "",
verbose = TRUE
)
system(paste0(command, " ", pdfFiles[i], " ", file.path(outDir, basename(pdfFiles[i]))))
},error=function(x){
0
})
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.