##############################################################################
##############################################################################
###
### Running command:
###
### C:\Users\biocbuild\bbs-3.11-bioc\R\bin\R.exe CMD check --force-multiarch --install=check:Logolas.install-out.txt --library=C:\Users\biocbuild\bbs-3.11-bioc\R\library --no-vignettes --timings Logolas_1.12.0.tar.gz
###
##############################################################################
##############################################################################
* using log directory 'C:/Users/biocbuild/bbs-3.11-bioc/meat/Logolas.Rcheck'
* using R version 4.0.3 (2020-10-10)
* using platform: x86_64-w64-mingw32 (64-bit)
* using session charset: ISO8859-1
* using option '--no-vignettes'
* checking for file 'Logolas/DESCRIPTION' ... OK
* checking extension type ... Package
* this is package 'Logolas' version '1.12.0'
* package encoding: UTF-8
* checking package namespace information ... OK
* checking package dependencies ... OK
* checking if this is a source package ... OK
* checking if there is a namespace ... OK
* checking for hidden files and directories ... OK
* checking for portable file names ... OK
* checking whether package 'Logolas' can be installed ... OK
* checking installed package size ... OK
* checking package directory ... OK
* checking 'build' directory ... OK
* checking DESCRIPTION meta-information ... OK
* checking top-level files ... OK
* checking for left-over files ... OK
* checking index information ... OK
* checking package subdirectories ... OK
* checking R files for non-ASCII characters ... OK
* checking R files for syntax errors ... OK
* loading checks for arch 'i386'
** checking whether the package can be loaded ... OK
** checking whether the package can be loaded with stated dependencies ... OK
** checking whether the package can be unloaded cleanly ... OK
** checking whether the namespace can be loaded with stated dependencies ... OK
** checking whether the namespace can be unloaded cleanly ... OK
* loading checks for arch 'x64'
** checking whether the package can be loaded ... OK
** checking whether the package can be loaded with stated dependencies ... OK
** checking whether the package can be unloaded cleanly ... OK
** checking whether the namespace can be loaded with stated dependencies ... OK
** checking whether the namespace can be unloaded cleanly ... OK
* checking dependencies in R code ... OK
* checking S3 generic/method consistency ... OK
* checking replacement functions ... OK
* checking foreign function calls ... OK
* checking R code for possible problems ... OK
* checking Rd files ... OK
* checking Rd metadata ... OK
* checking Rd cross-references ... OK
* checking for missing documentation entries ... OK
* checking for code/documentation mismatches ... OK
* checking Rd \usage sections ... OK
* checking Rd contents ... OK
* checking for unstated dependencies in examples ... OK
* checking contents of 'data' directory ... OK
* checking data for non-ASCII characters ... OK
* checking data for ASCII and uncompressed saves ... OK
* checking files in 'vignettes' ... OK
* checking examples ...
** running examples for arch 'i386' ... ERROR
Running examples in 'Logolas-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: GetConsensusSeq
> ### Title: Function for obtaining consensus sequence of DNA sequence
> ### symbols from a PWM matrix
> ### Aliases: GetConsensusSeq
>
> ### ** Examples
>
>
> pwm=matrix(c(0.8,0.1,0.1,0,
+ 0.9,0.1,0,0,0.9,0.05,0.05,0,0.5,
+ 0.4,0,0.1,0.6,0.4,0,0,0.4,0.4,0.1,
+ 0.1,0.5,0,0.2,0.3,0.35,0.35,0.06,
+ 0.24,0.4,0.3,0.2,0.1,0.4,0.2,0.2,
+ 0.2,0.28,0.24,0.24,0.24,0.5,0.16,0.17,
+ 0.17,0.6,0.13,0.13,0.14,0.7,0.15,0.15,0),
+ nrow = 4,byrow = FALSE)
> rownames(pwm)=c('A','C','G','T')
> colnames(pwm)=1:ncol(pwm)
> GetConsensusSeq(pwm)
using a background with equal probability for all symbols
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
Logolas
--- call from context ---
get_logo_heights(pwm, ic = FALSE, score = "log-odds")
--- call from argument ---
if (class(table) == "data.frame") {
table <- as.matrix(table)
} else if (class(table) != "matrix") {
stop("the table must be of class matrix or data.frame")
}
--- R stacktrace ---
where 1: get_logo_heights(pwm, ic = FALSE, score = "log-odds")
where 2: GetConsensusSeq(pwm)
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (table, ic = FALSE, score = c("diff", "log", "log-odds",
"probKL", "ratio", "unscaled_log", "wKL"), bg = NULL, epsilon = 0.01,
opt = 1, symm = TRUE, alpha = 1, hist = FALSE, quant = 0.5)
{
if (ic & score == "unscaled_log") {
warning("ic = TRUE not compatible with score = `unscaled-log`: switching to\n ic = FALSE")
ic = FALSE
}
if (ic & score == "wKL") {
warning("ic = TRUE not compatible with score = `wKL`: switching to \n ic = FALSE")
ic = FALSE
}
if (length(score) != 1) {
stop("score can be wither diff, log, log-odds, probKL, ratio, \n unscaled_log or wKL")
}
if (is.vector(bg) == TRUE) {
if (length(bg) != dim(table)[1]) {
stop("If background prob (bg) is a vector, the length of bg must\n equal the number of symbols for the logo plot")
}
else if (length(which(is.na(table))) > 0) {
stop("For NA in table, a vector bg is not allowed")
}
else {
bgmat <- bg %*% t(rep(1, dim(table)[2]))
bgmat[which(is.na(table))] <- NA
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
}
}
else if (is.matrix(bg) == TRUE) {
if (dim(bg)[1] != dim(table)[1] | dim(bg)[2] != dim(table)[2]) {
stop("If background prob (bg) is a matrix, its dimensions must\n match that of the table")
}
else {
bgmat <- bg
bgmat[which(is.na(table))] <- NA
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
}
}
else {
message("using a background with equal probability for all symbols")
bgmat <- matrix(1/dim(table)[1], dim(table)[1], dim(table)[2])
bgmat[which(is.na(table))] <- NA
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
}
table <- apply(table + 1e-04, 2, normalize4)
bgmat <- apply(bgmat + 1e-04, 2, normalize4)
if (class(table) == "data.frame") {
table <- as.matrix(table)
}
else if (class(table) != "matrix") {
stop("the table must be of class matrix or data.frame")
}
table_mat_norm <- apply(table, 2, function(x) return(x/sum(x[!is.na(x)])))
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
npos <- ncol(table_mat_norm)
chars <- as.character(rownames(table_mat_norm))
if (!ic) {
if (score == "diff") {
table_mat_adj <- apply((table_mat_norm + epsilon) -
(bgmat + epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "log") {
table_mat_adj <- apply(log((table_mat_norm + epsilon)/(bgmat +
epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "log-odds") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply((table_mat_norm + epsilon),
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
z <- y - quantile(y, quant)
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "probKL") {
table_mat_adj <- apply((table_mat_norm + epsilon) *
log((table_mat_norm + epsilon)/(bgmat + epsilon),
base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "ratio") {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "unscaled_log") {
table_mat_adj <- apply(log((table_mat_norm + epsilon)/(bgmat +
epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "wKL") {
table_mat_adj <- apply(log((table_mat_norm + epsilon)/(bgmat +
epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
stop("The value of score chosen is not compatible")
}
}
else {
if (score == "diff") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon) -
(bgmat + epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply(table_mat_norm + epsilon,
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "log") {
if (opt == 1) {
table_mat_adj <- apply(log((table_mat_norm +
epsilon)/(bgmat + epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply(log(table_mat_norm + epsilon,
base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "log-odds") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply((table_mat_norm + epsilon),
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
z <- y - quantile(y, quant)
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "probKL") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon) *
log((table_mat_norm + epsilon)/(bgmat + epsilon),
base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply((table_mat_norm + epsilon) *
log(table_mat_norm + epsilon, base = 2), 2,
function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "ratio") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply(table_mat_norm + scale,
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else {
stop("The value of score chosen is not compatible")
}
}
if (!ic) {
table_mat_pos <- table_mat_adj
table_mat_pos[table_mat_pos <= 0] = 0
table_mat_pos_norm <- apply(table_mat_pos, 2, function(x) return(x/sum(x)))
table_mat_pos_norm[table_mat_pos_norm == "NaN"] = 0
table_mat_neg <- table_mat_adj
table_mat_neg[table_mat_neg >= 0] = 0
table_mat_neg_norm <- apply(abs(table_mat_neg), 2, function(x) return(x/sum(x)))
table_mat_neg_norm[table_mat_neg_norm == "NaN"] = 0
pos_ic <- colSums(table_mat_pos)
neg_ic <- colSums(abs(table_mat_neg))
ll <- list()
ll$pos_ic <- pos_ic
ll$neg_ic <- neg_ic
ll$table_mat_pos_norm <- table_mat_pos_norm
ll$table_mat_neg_norm <- table_mat_neg_norm
}
else {
table_mat_pos <- table_mat_adj
table_mat_pos[table_mat_pos <= 0] = 0
table_mat_pos_norm <- apply(table_mat_pos, 2, function(x) return(x/sum(x)))
table_mat_pos_norm[table_mat_pos_norm == "NaN"] = 0
table_mat_neg <- table_mat_adj
table_mat_neg[table_mat_neg >= 0] = 0
table_mat_neg_norm <- apply(table_mat_neg, 2, function(x) return(x/sum(x)))
table_mat_neg_norm[table_mat_neg_norm == "NaN"] = 0
table_mat_norm <- replace(table_mat_norm, is.na(table_mat_norm),
0)
for (j in 1:dim(table_mat_neg_norm)[2]) {
if (sum(table_mat_neg_norm[, j]) == 0) {
table_mat_neg_norm[, j] <- normalize4(table_mat_neg_norm[,
j] + 0.001)
}
}
for (j in 1:dim(table_mat_pos_norm)[2]) {
if (sum(table_mat_pos_norm[, j]) == 0) {
table_mat_pos_norm[, j] <- normalize4(table_mat_pos_norm[,
j] + 0.001)
}
}
if (symm == TRUE) {
table_mat_norm[which(is.na(table))] <- NA
ic <- 0.5 * (ic_computer(table_mat_norm, alpha, hist = hist,
bg = bgmat) + ic_computer(bgmat, alpha, hist = hist,
bg = table_mat_norm))
}
else {
table_mat_norm[which(is.na(table))] <- NA
ic <- ic_computer(table_mat_norm, alpha, hist = hist,
bg = bgmat)
}
tab_neg <- apply(table_mat_adj, 2, function(x) {
y = x[x < 0]
if (length(y) == 0) {
return(0)
}
else {
return(abs(sum(y)))
}
})
tab_pos <- apply(table_mat_adj, 2, function(x) {
y = x[x > 0]
if (length(y) == 0) {
return(0)
}
else {
return(abs(sum(y)))
}
})
tab_pos[tab_pos == 0] <- 0.001
tab_neg[tab_neg == 0] <- 0.001
pos_neg_scaling <- apply(rbind(tab_pos, tab_neg), 2,
function(x) return(x/sum(x)))
pos_ic <- pos_neg_scaling[1, ] * ic
neg_ic <- pos_neg_scaling[2, ] * ic
ll <- list()
ll$pos_ic <- pos_ic
ll$neg_ic <- neg_ic
ll$table_mat_pos_norm <- table_mat_pos_norm
ll$table_mat_neg_norm <- table_mat_neg_norm
}
return(ll)
}
<bytecode: 0x021489f0>
<environment: namespace:Logolas>
--- function search by body ---
Function get_logo_heights in namespace Logolas has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
** running examples for arch 'x64' ... ERROR
Running examples in 'Logolas-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: GetConsensusSeq
> ### Title: Function for obtaining consensus sequence of DNA sequence
> ### symbols from a PWM matrix
> ### Aliases: GetConsensusSeq
>
> ### ** Examples
>
>
> pwm=matrix(c(0.8,0.1,0.1,0,
+ 0.9,0.1,0,0,0.9,0.05,0.05,0,0.5,
+ 0.4,0,0.1,0.6,0.4,0,0,0.4,0.4,0.1,
+ 0.1,0.5,0,0.2,0.3,0.35,0.35,0.06,
+ 0.24,0.4,0.3,0.2,0.1,0.4,0.2,0.2,
+ 0.2,0.28,0.24,0.24,0.24,0.5,0.16,0.17,
+ 0.17,0.6,0.13,0.13,0.14,0.7,0.15,0.15,0),
+ nrow = 4,byrow = FALSE)
> rownames(pwm)=c('A','C','G','T')
> colnames(pwm)=1:ncol(pwm)
> GetConsensusSeq(pwm)
using a background with equal probability for all symbols
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
Logolas
--- call from context ---
get_logo_heights(pwm, ic = FALSE, score = "log-odds")
--- call from argument ---
if (class(table) == "data.frame") {
table <- as.matrix(table)
} else if (class(table) != "matrix") {
stop("the table must be of class matrix or data.frame")
}
--- R stacktrace ---
where 1: get_logo_heights(pwm, ic = FALSE, score = "log-odds")
where 2: GetConsensusSeq(pwm)
--- value of length: 2 type: logical ---
[1] FALSE FALSE
--- function from context ---
function (table, ic = FALSE, score = c("diff", "log", "log-odds",
"probKL", "ratio", "unscaled_log", "wKL"), bg = NULL, epsilon = 0.01,
opt = 1, symm = TRUE, alpha = 1, hist = FALSE, quant = 0.5)
{
if (ic & score == "unscaled_log") {
warning("ic = TRUE not compatible with score = `unscaled-log`: switching to\n ic = FALSE")
ic = FALSE
}
if (ic & score == "wKL") {
warning("ic = TRUE not compatible with score = `wKL`: switching to \n ic = FALSE")
ic = FALSE
}
if (length(score) != 1) {
stop("score can be wither diff, log, log-odds, probKL, ratio, \n unscaled_log or wKL")
}
if (is.vector(bg) == TRUE) {
if (length(bg) != dim(table)[1]) {
stop("If background prob (bg) is a vector, the length of bg must\n equal the number of symbols for the logo plot")
}
else if (length(which(is.na(table))) > 0) {
stop("For NA in table, a vector bg is not allowed")
}
else {
bgmat <- bg %*% t(rep(1, dim(table)[2]))
bgmat[which(is.na(table))] <- NA
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
}
}
else if (is.matrix(bg) == TRUE) {
if (dim(bg)[1] != dim(table)[1] | dim(bg)[2] != dim(table)[2]) {
stop("If background prob (bg) is a matrix, its dimensions must\n match that of the table")
}
else {
bgmat <- bg
bgmat[which(is.na(table))] <- NA
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
}
}
else {
message("using a background with equal probability for all symbols")
bgmat <- matrix(1/dim(table)[1], dim(table)[1], dim(table)[2])
bgmat[which(is.na(table))] <- NA
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
}
table <- apply(table + 1e-04, 2, normalize4)
bgmat <- apply(bgmat + 1e-04, 2, normalize4)
if (class(table) == "data.frame") {
table <- as.matrix(table)
}
else if (class(table) != "matrix") {
stop("the table must be of class matrix or data.frame")
}
table_mat_norm <- apply(table, 2, function(x) return(x/sum(x[!is.na(x)])))
bgmat <- apply(bgmat, 2, function(x) return(x/sum(x[!is.na(x)])))
npos <- ncol(table_mat_norm)
chars <- as.character(rownames(table_mat_norm))
if (!ic) {
if (score == "diff") {
table_mat_adj <- apply((table_mat_norm + epsilon) -
(bgmat + epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "log") {
table_mat_adj <- apply(log((table_mat_norm + epsilon)/(bgmat +
epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "log-odds") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply((table_mat_norm + epsilon),
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
z <- y - quantile(y, quant)
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "probKL") {
table_mat_adj <- apply((table_mat_norm + epsilon) *
log((table_mat_norm + epsilon)/(bgmat + epsilon),
base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "ratio") {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "unscaled_log") {
table_mat_adj <- apply(log((table_mat_norm + epsilon)/(bgmat +
epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else if (score == "wKL") {
table_mat_adj <- apply(log((table_mat_norm + epsilon)/(bgmat +
epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
stop("The value of score chosen is not compatible")
}
}
else {
if (score == "diff") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon) -
(bgmat + epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply(table_mat_norm + epsilon,
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "log") {
if (opt == 1) {
table_mat_adj <- apply(log((table_mat_norm +
epsilon)/(bgmat + epsilon), base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply(log(table_mat_norm + epsilon,
base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "log-odds") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply((table_mat_norm + epsilon),
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = log(x/(sum(x) - x), base = 2)
z <- y - quantile(y, quant)
return(z)
}
else {
w <- x[!is.na(x)]
y <- log(w/(sum(w) - w), base = 2)
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "probKL") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon) *
log((table_mat_norm + epsilon)/(bgmat + epsilon),
base = 2), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply((table_mat_norm + epsilon) *
log(table_mat_norm + epsilon, base = 2), 2,
function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else if (score == "ratio") {
if (opt == 1) {
table_mat_adj <- apply((table_mat_norm + epsilon)/(bgmat +
epsilon), 2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
return(z)
}
else {
y <- x[!is.na(x)]
if (quant != 0) {
qq <- quantile(y, quant)
}
else {
qq <- 0
}
z <- y - qq
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
else {
table_mat_adj <- apply(table_mat_norm + scale,
2, function(x) {
indices <- which(is.na(x))
if (length(indices) == 0) {
y = x
z <- y - quantile(y, quant)
return(z)
}
else {
y <- x[!is.na(x)]
z <- y - quantile(y, quant)
zext <- array(0, length(x))
zext[indices] <- 0
zext[-indices] <- z
return(zext)
}
})
}
}
else {
stop("The value of score chosen is not compatible")
}
}
if (!ic) {
table_mat_pos <- table_mat_adj
table_mat_pos[table_mat_pos <= 0] = 0
table_mat_pos_norm <- apply(table_mat_pos, 2, function(x) return(x/sum(x)))
table_mat_pos_norm[table_mat_pos_norm == "NaN"] = 0
table_mat_neg <- table_mat_adj
table_mat_neg[table_mat_neg >= 0] = 0
table_mat_neg_norm <- apply(abs(table_mat_neg), 2, function(x) return(x/sum(x)))
table_mat_neg_norm[table_mat_neg_norm == "NaN"] = 0
pos_ic <- colSums(table_mat_pos)
neg_ic <- colSums(abs(table_mat_neg))
ll <- list()
ll$pos_ic <- pos_ic
ll$neg_ic <- neg_ic
ll$table_mat_pos_norm <- table_mat_pos_norm
ll$table_mat_neg_norm <- table_mat_neg_norm
}
else {
table_mat_pos <- table_mat_adj
table_mat_pos[table_mat_pos <= 0] = 0
table_mat_pos_norm <- apply(table_mat_pos, 2, function(x) return(x/sum(x)))
table_mat_pos_norm[table_mat_pos_norm == "NaN"] = 0
table_mat_neg <- table_mat_adj
table_mat_neg[table_mat_neg >= 0] = 0
table_mat_neg_norm <- apply(table_mat_neg, 2, function(x) return(x/sum(x)))
table_mat_neg_norm[table_mat_neg_norm == "NaN"] = 0
table_mat_norm <- replace(table_mat_norm, is.na(table_mat_norm),
0)
for (j in 1:dim(table_mat_neg_norm)[2]) {
if (sum(table_mat_neg_norm[, j]) == 0) {
table_mat_neg_norm[, j] <- normalize4(table_mat_neg_norm[,
j] + 0.001)
}
}
for (j in 1:dim(table_mat_pos_norm)[2]) {
if (sum(table_mat_pos_norm[, j]) == 0) {
table_mat_pos_norm[, j] <- normalize4(table_mat_pos_norm[,
j] + 0.001)
}
}
if (symm == TRUE) {
table_mat_norm[which(is.na(table))] <- NA
ic <- 0.5 * (ic_computer(table_mat_norm, alpha, hist = hist,
bg = bgmat) + ic_computer(bgmat, alpha, hist = hist,
bg = table_mat_norm))
}
else {
table_mat_norm[which(is.na(table))] <- NA
ic <- ic_computer(table_mat_norm, alpha, hist = hist,
bg = bgmat)
}
tab_neg <- apply(table_mat_adj, 2, function(x) {
y = x[x < 0]
if (length(y) == 0) {
return(0)
}
else {
return(abs(sum(y)))
}
})
tab_pos <- apply(table_mat_adj, 2, function(x) {
y = x[x > 0]
if (length(y) == 0) {
return(0)
}
else {
return(abs(sum(y)))
}
})
tab_pos[tab_pos == 0] <- 0.001
tab_neg[tab_neg == 0] <- 0.001
pos_neg_scaling <- apply(rbind(tab_pos, tab_neg), 2,
function(x) return(x/sum(x)))
pos_ic <- pos_neg_scaling[1, ] * ic
neg_ic <- pos_neg_scaling[2, ] * ic
ll <- list()
ll$pos_ic <- pos_ic
ll$neg_ic <- neg_ic
ll$table_mat_pos_norm <- table_mat_pos_norm
ll$table_mat_neg_norm <- table_mat_neg_norm
}
return(ll)
}
<bytecode: 0x00000000051dbe90>
<environment: namespace:Logolas>
--- function search by body ---
Function get_logo_heights in namespace Logolas has this body.
----------- END OF FAILURE REPORT --------------
Fatal error: the condition has length > 1
* checking for unstated dependencies in vignettes ... OK
* checking package vignettes in 'inst/doc' ... OK
* checking running R code from vignettes ... SKIPPED
* checking re-building of vignette outputs ... SKIPPED
* checking PDF version of manual ... OK
* DONE
Status: 2 ERRORs
See
'C:/Users/biocbuild/bbs-3.11-bioc/meat/Logolas.Rcheck/00check.log'
for details.