diff --git a/.DS_Store b/.DS_Store new file mode 100644 index 0000000..2da82d0 Binary files /dev/null and b/.DS_Store differ diff --git a/DESCRIPTION b/DESCRIPTION index 6d1731a..f2b7fd6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,10 +1,11 @@ Package: GeoDiff Type: Package Title: Count model based differential expression and normalization on GeoMx RNA data -Version: 1.1.2 +Version: 1.1.3 Authors@R: c(person("Nicole", "Ortogero", email = "nortogero@nanostring.com", role = c("cre")), person("Lei", "Yang", email = "lyang@nanostring.com", role = c("aut")), - person("Zhi", "Yang", email = "zyang@nanostring.com", role = c("aut"))) + person("Zhi", "Yang", email = "zyang@nanostring.com", role = c("aut")), + person("Ned", "Booker", email = "ned@procogia.com", role = c("aut"))) Description: A series of statistical models using count generating distributions for background modelling, feature and sample QC, normalization and differential expression analysis on GeoMx RNA data. The application of these methods are @@ -15,6 +16,7 @@ Imports: plyr, lme4, Rcpp (>= 1.0.4.6), + Rfast, withr, methods, graphics, diff --git a/NEWS.md b/NEWS.md index b08dd53..614bf40 100644 --- a/NEWS.md +++ b/NEWS.md @@ -55,3 +55,6 @@ Revisions * transfer maintainership +# GeoDiff 1.1.3 + +* implement code optimizations (mostly RFast and matrix methods) to speed up execution (NBth.R, NBthDE.R, PoisBG.R, PoisthNorm.R, ScoreTest.R). Added error handling, improved matrix methods, accelerated code for NBthDEOptPara.cpp Rcpp code. diff --git a/R/.DS_Store b/R/.DS_Store new file mode 100644 index 0000000..5008ddf Binary files /dev/null and b/R/.DS_Store differ diff --git a/R/NBth.R b/R/NBth.R index f99419e..5f7628e 100644 --- a/R/NBth.R +++ b/R/NBth.R @@ -73,173 +73,172 @@ #' setGeneric("fitNBth", - signature = c("object"), - function(object, ...) standardGeneric("fitNBth") + signature = c("object"), + function(object, ...) standardGeneric("fitNBth") ) #' @rdname fitNBth-methods #' @aliases fitNBth,NanoStringGeoMxSet-method setMethod( - "fitNBth", "NanoStringGeoMxSet", - function(object, split = TRUE, - features_high = NULL, - sizefact_BG = NULL, sizefact_start = sizefact_BG, - size_scale = c("sum", "first"), - threshold_start = NULL, threshold_fix = FALSE, - tol = 1e-7, iterations = 8, - start_para = c(threshold_start, 0.5), - lower_sizefact = 0, lower_threshold = threshold_start / 5) { - # check on tol - tol <- as.double(tol) - stopifnot(length(tol) == 1) - stopifnot(tol >= 0) - - - fDat <- Biobase::fData(object) - pDat <- Biobase::pData(object) - - posdat <- object[-which(fDat$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(posdat) - - fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] - - # calculate probenum for the dataset - if ("probenum" %in% fvarLabels(posdat)) { - probenum <- fData(posdat)[["probenum"]] + "fitNBth", "NanoStringGeoMxSet", + function(object, split = TRUE, + features_high = NULL, + sizefact_BG = NULL, sizefact_start = sizefact_BG, + size_scale = c("sum", "first"), + threshold_start = NULL, threshold_fix = FALSE, + tol = 1e-7, iterations = 8, + start_para = c(threshold_start, 0.5), + lower_sizefact = 0, lower_threshold = threshold_start / 5) { + # check on tol + tol <- as.double(tol) + stopifnot(length(tol) == 1) + stopifnot(tol >= 0) + + fDat <- Biobase::fData(object) + pDat <- Biobase::pData(object) + + posdat <- object[-which(fDat$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(posdat) + + fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] + + # calculate probenum for the dataset + if ("probenum" %in% fvarLabels(posdat)) { + probenum <- fData(posdat)[["probenum"]] + } else { + stop("No `probenum` is found. Run `aggreprobe` first.") + } + names(probenum) <- rownames(fData(posdat)) + + # only calculate thmean if any of the two params are missing + if (any(c(is.null(sizefact_BG), is.null(threshold_start)))) { + if (isFALSE(split)) { + # single slide + if (!("sizefact" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first.") } else { - stop("No `probenum` is found. Run `aggreprobe` first.") + # calculate the thmean for WTA or CTA data + thmean <- mean(fDatNeg[["featfact"]]) } - names(probenum) <- rownames(fData(posdat)) - - # only calculate thmean if any of the two params are missing - if (any(c(is.null(sizefact_BG), is.null(threshold_start)))) { - if (isFALSE(split)) { - # single slide - if (!("sizefact" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first.") - } else { - # calculate the thmean for WTA or CTA data - thmean <- mean(fDatNeg[["featfact"]]) - } - } else { - # multiple slides - if (!("sizefact_sp" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } else { - # calculate the thmean for WTA or CTA data - thmean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] - } - } - } - - # setting default value for sizefact_BG - if (is.null(sizefact_BG)) { - if (isFALSE(split)) { - # single slide - sizefact_BG <- pDat[["sizefact"]] - } else { - # multiple slides - sizefact_BG <- pDat[["sizefact_sp"]] - } - sizefact_start <- sizefact_BG - } - - # setting default value for sizefact_start - if (is.null(threshold_start)) { - message(sprintf("`threshold_start` is missing. The default value is estimated based on fitPoisBG results with %s.", - ifelse(isTRUE(split), "multiple slides", "a single slide"))) - thmean <- unname(thmean) - threshold_start <- thmean + } else { + # multiple slides + if (!("sizefact_sp" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } else { + # calculate the thmean for WTA or CTA data + thmean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] } - - # setting default value for features_high - if (is.null(features_high)) { - gene_sum <- rowSums(countmat) - - if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { - features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) - features_high <- sample(features_high, 1500) - } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { - if ( !any(grepl("scores", colnames(fDat))) ) { - stop("Please run `BGScoreTest` first. If you run `BGScoreTest` before, please specify `split = TRUE` for multiple slides.") - } else { - if ( any(grepl("scores_", colnames(fDat))) ){ - # fit the model with multiple slides - sc1_scores <- fData(posdat)[, grep("scores_", fvarLabels(posdat))] - rownames(sc1_scores) <- fData(posdat)[, "TargetName"] - features_high <- apply(sc1_scores, 2, function(x){ - ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) - }) - features_high <- names(which(apply(features_high, 1, all))) - - } else { - sc1_scores <- fData(posdat)[, "scores"] - names(sc1_scores) <- fData(posdat)[, "TargetName"] - features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) - features_high <- names(which(features_high)) - - } - } - - } else { - stop("No information is found to determine the data type (CTA or WTA).") - } + } + } + + # setting default value for sizefact_BG + if (is.null(sizefact_BG)) { + if (isFALSE(split)) { + # single slide + sizefact_BG <- pDat[["sizefact"]] + } else { + # multiple slides + sizefact_BG <- pDat[["sizefact_sp"]] + } + sizefact_start <- sizefact_BG + } + + # setting default value for sizefact_start + if (is.null(threshold_start)) { + message(sprintf("`threshold_start` is missing. The default value is estimated based on fitPoisBG results with %s.", + ifelse(isTRUE(split), "multiple slides", "a single slide"))) + thmean <- unname(thmean) + threshold_start <- thmean + } + + # setting default value for features_high + if (is.null(features_high)) { + gene_sum <- rowSums(countmat) + + if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { + features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) + features_high <- sample(features_high, 1500) + } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { + if ( !any(grepl("scores", colnames(fDat))) ) { + stop("Please run `BGScoreTest` first. If you run `BGScoreTest` before, please specify `split = TRUE` for multiple slides.") + } else { + if ( any(grepl("scores_", colnames(fDat))) ){ + # fit the model with multiple slides + sc1_scores <- fData(posdat)[, grep("scores_", fvarLabels(posdat))] + rownames(sc1_scores) <- fData(posdat)[, "TargetName"] + features_high <- apply(sc1_scores, 2, function(x){ + ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) + }) + features_high <- names(which(apply(features_high, 1, all))) + + } else { + sc1_scores <- fData(posdat)[, "scores"] + names(sc1_scores) <- fData(posdat)[, "TargetName"] + features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) + features_high <- names(which(features_high)) + + } } - - result <- fitNBth( - object = countmat[features_high, ], - probenum = probenum, - features_high = features_high, - sizefact_BG = sizefact_BG, - sizefact_start = sizefact_start, - size_scale = size_scale, - threshold_start = threshold_start, - threshold_fix = threshold_fix, - tol = tol, - iterations = iterations, - start_para = start_para, - lower_sizefact = lower_sizefact, - lower_threshold = lower_threshold - ) - - # update para0 - Biobase::notes(object)$para0 <- ifelse(is.na(result$para0), "NA", result$para0) - - # update para - Biobase::fData(object)[["para"]] <- matrix(NA, - nrow = nrow(object), ncol = 2, - dimnames = list(featureNames(object), c("signal", "r")) - ) - Biobase::fData(object)[["para"]][colnames(result$para), ] <- t(result$para) - - # update sizefact - object[["sizefact_fitNBth"]] <- result$sizefact - - # update preci1 - Biobase::notes(object)$preci1 <- ifelse(is.na(result$preci1), "NA", result$preci1) - - # update conv0 - Biobase::notes(object)$conv0 <- ifelse(is.na(result$conv0), "NA", result$conv0) - - # update conv - Biobase::notes(object)$conv <- ifelse(is.na(result$conv), "NA", result$conv) - - # update Im - Biobase::notes(object)$Im <- ifelse(is.na(result$Im), "NA", result$Im) - - # update features_high - Biobase::fData(object)[["feature_high_fitNBth"]] <- 0 - Biobase::fData(object)[["feature_high_fitNBth"]][match(result$features_high, Biobase::featureNames(object), nomatch = 0)] <- 1 - - # update features_all - Biobase::notes(object)$features_all <- ifelse(is.na(result$features_all), "NA", result$features_all) - - # update threshold - Biobase::notes(object)$threshold <- ifelse(is.na(result$threshold), "NA", result$threshold) - - return(object) + } else { + stop("No information is found to determine the data type (CTA or WTA).") + } } + + + result <- fitNBth( + object = countmat[features_high, ], + probenum = probenum, + features_high = features_high, + sizefact_BG = sizefact_BG, + sizefact_start = sizefact_start, + size_scale = size_scale, + threshold_start = threshold_start, + threshold_fix = threshold_fix, + tol = tol, + iterations = iterations, + start_para = start_para, + lower_sizefact = lower_sizefact, + lower_threshold = lower_threshold + ) + + # update para0 + Biobase::notes(object)$para0 <- ifelse(is.na(result$para0), "NA", result$para0) + + # update para + Biobase::fData(object)[["para"]] <- matrix(NA, + nrow = nrow(object), ncol = 2, + dimnames = list(featureNames(object), c("signal", "r")) + ) + Biobase::fData(object)[["para"]][colnames(result$para), ] <- t(result$para) + + # update sizefact + object[["sizefact_fitNBth"]] <- result$sizefact + + # update preci1 + Biobase::notes(object)$preci1 <- ifelse(is.na(result$preci1), "NA", result$preci1) + + # update conv0 + Biobase::notes(object)$conv0 <- ifelse(is.na(result$conv0), "NA", result$conv0) + + # update conv + Biobase::notes(object)$conv <- ifelse(is.na(result$conv), "NA", result$conv) + + # update Im + Biobase::notes(object)$Im <- ifelse(is.na(result$Im), "NA", result$Im) + + # update features_high + Biobase::fData(object)[["feature_high_fitNBth"]] <- 0 + Biobase::fData(object)[["feature_high_fitNBth"]][match(result$features_high, Biobase::featureNames(object), nomatch = 0)] <- 1 + + # update features_all + Biobase::notes(object)$features_all <- ifelse(is.na(result$features_all), "NA", result$features_all) + + # update threshold + Biobase::notes(object)$threshold <- ifelse(is.na(result$threshold), "NA", result$threshold) + + return(object) + } ) #' Negative Binomial threshold model @@ -277,69 +276,59 @@ setMethod( #' @rdname fitNBth-methods #' @aliases fitNBth,matrix-method setMethod( - "fitNBth", "matrix", - function(object, features_high, probenum, sizefact_BG, sizefact_start = sizefact_BG, size_scale = c("sum", "first"), threshold_start, threshold_fix = FALSE, tol = 1e-7, iterations = 8, - start_para = c(threshold_start, 1), lower_sizefact = 0, lower_threshold = threshold_start / 5) { - size_scale <- match.arg(size_scale) - sizefact0 <- sizefact <- sizefact_start - threshold <- threshold_start - # mat <- matrix(1, nrow(object), 1) - if (is.null(names(probenum))) names(probenum) <- rownames(object) - for (iter in seq_len(iterations)) { - para <- NBth_paraopt(object[features_high, ], probenum[features_high], sizefact, sizefact_BG, threshold, start = start_para) - # result <- mleprobeNBall(object[,features_high], mat, sizefact0, sizefact, - # matrix(0,1,1), threshold, 0, - # c(rep(0,ncol(mat)), 1, threshold), 0) - features_NA <- features_high[unique(which(is.na(para), arr.ind = TRUE)[, 2])] - features_remain <- setdiff(features_high, features_NA) - - - for (i in seq_len(length(sizefact))) { - fun <- NBth_scalenll(object[features_remain, i], probenum[features_remain], t(para[1, features_remain]), t(para[2, features_remain]), sizefact_BG[i], threshold) - sizefact[i] <- optim(c(sizefact_start[i]), fun, lower = c(lower_sizefact), method = "L-BFGS-B")$par - } - - if (size_scale == "first") { - scale_fac <- sizefact[1] - } else if (size_scale == "sum") { - scale_fac <- sum(sizefact) - } - - sizefact <- sizefact / scale_fac - - - if (!threshold_fix) { - fun1 <- NBth_thnll(object[features_remain, ], probenum[features_remain], sizefact, sizefact_BG, scale_fac * t(para[1, features_remain]), t(para[2, features_remain])) - - threshold <- optim(c(threshold_start), fun1, lower = c(lower_threshold), method = "L-BFGS-B")$par - } - - - - - message(sprintf("Iteration = %s, squared error = %s", iter, sum((sizefact - sizefact0)^2))) - - - if (sum((sizefact - sizefact0)^2) < tol) break - - sizefact0 <- sizefact - - } - message("Model converged.") - - rownames(para) <- c("signal", "r") + "fitNBth", "matrix", + function(object, features_high, probenum, sizefact_BG, sizefact_start = sizefact_BG, size_scale = c("sum", "first"), threshold_start, threshold_fix = FALSE, tol = 1e-7, iterations = 8, + start_para = c(threshold_start, 1), lower_sizefact = 0, lower_threshold = threshold_start / 5) { + size_scale <- match.arg(size_scale) + sizefact0 <- sizefact <- sizefact_start + threshold <- threshold_start + # mat <- matrix(1, nrow(object), 1) + if (is.null(names(probenum))) names(probenum) <- rownames(object) + for (iter in seq_len(iterations)) { + para <- NBth_paraopt(object[features_high, ], probenum[features_high], sizefact, sizefact_BG, threshold, start = start_para) + features_NA <- features_high[unique(which(is.na(para), arr.ind = TRUE)[, 2])] + features_remain <- setdiff(features_high, features_NA) + + for (i in seq_len(length(sizefact))) { + fun <- NBth_scalenll(object[features_remain, i], probenum[features_remain], t(para[1, features_remain]), t(para[2, features_remain]), sizefact_BG[i], threshold) + sizefact[i] <- optim(c(sizefact_start[i]), fun, lower = c(lower_sizefact), method = "L-BFGS-B")$par + } + + if (size_scale == "first") { + scale_fac <- sizefact[1] + } else if (size_scale == "sum") { + scale_fac <- sum(sizefact) + } + + sizefact <- sizefact / scale_fac + + if (!threshold_fix) { + fun1 <- NBth_thnll(object[features_remain, ], probenum[features_remain], sizefact, sizefact_BG, scale_fac * t(para[1, features_remain]), t(para[2, features_remain])) - return(list( - para0 = NA, - para = para, - sizefact = sizefact, - preci1 = NA, - conv0 = NA, - conv = NA, - Im = NA, - features_high = features_high, - features_all = NA, - threshold = threshold - )) + threshold <- optim(c(threshold_start), fun1, lower = c(lower_threshold), method = "L-BFGS-B")$par + } + + message(sprintf("Iteration = %s, squared error = %s", iter, sum((sizefact - sizefact0)^2))) + + if (sum((sizefact - sizefact0)^2) < tol) break + + sizefact0 <- sizefact } + message("Model converged.") + + rownames(para) <- c("signal", "r") + + return(list( + para0 = NA, + para = para, + sizefact = sizefact, + preci1 = NA, + conv0 = NA, + conv = NA, + Im = NA, + features_high = features_high, + features_all = NA, + threshold = threshold + )) + } ) diff --git a/R/NBthDE.R b/R/NBthDE.R index 6402e4d..cb11ccc 100644 --- a/R/NBthDE.R +++ b/R/NBthDE.R @@ -104,173 +104,173 @@ #' @rdname fitNBthDE-methods #' setGeneric("fitNBthDE", - signature = c("object"), - function(object, ...) standardGeneric("fitNBthDE") + signature = c("object"), + function(object, ...) standardGeneric("fitNBthDE") ) #' @rdname fitNBthDE-methods #' @aliases fitNBthDE,NanoStringGeoMxSet-method setMethod( - "fitNBthDE", "NanoStringGeoMxSet", - function(object, form, split, ROIs_high = NULL, - features_high = NULL, features_all = NULL, - sizefact_start = NULL, sizefact_BG = NULL, - threshold_mean = NULL, preci2 = 10000, lower_threshold = 0.01, - prior_type = c("contrast", "equal"), sizefactrec = TRUE, - size_scale = c("sum", "first"), sizescalebythreshold = FALSE, - iterations = 2, covrob = FALSE, preci1con=1/25, cutoff = 10, confac = 1) { - fDat <- Biobase::fData(object) - pDat <- Biobase::pData(object) - - posdat <- object[-which(fDat$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(posdat) - - fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] - - # only calculate thmean if any of the three params are missing - if (any(c(is.null(sizefact_BG), is.null(sizefact_start), is.null(ROIs_high), is.null(threshold_mean)))) { - if (isFALSE(split)) { - # single slide - if (!("sizefact" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first.") - } else { - # calculate the thmean for WTA or CTA data - thmean <- mean(fDatNeg[["featfact"]]) - } - } else { - # multiple slides - if (!("sizefact_sp" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } else { - # calculate the thmean for WTA or CTA data - thmean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] - } - } - } - - # calculate probenum for the dataset - if ("probenum" %in% fvarLabels(posdat)) { - probenum <- fData(posdat)[["probenum"]] + "fitNBthDE", "NanoStringGeoMxSet", + function(object, form, split, ROIs_high = NULL, + features_high = NULL, features_all = NULL, + sizefact_start = NULL, sizefact_BG = NULL, + threshold_mean = NULL, preci2 = 10000, lower_threshold = 0.01, + prior_type = c("contrast", "equal"), sizefactrec = TRUE, + size_scale = c("sum", "first"), sizescalebythreshold = FALSE, + iterations = 2, covrob = FALSE, preci1con=1/25, cutoff = 10, confac = 1) { + fDat <- Biobase::fData(object) + pDat <- Biobase::pData(object) + + posdat <- object[-which(fDat$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(posdat) + + fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] + + # only calculate thmean if any of the three params are missing + if (any(c(is.null(sizefact_BG), is.null(sizefact_start), is.null(ROIs_high), is.null(threshold_mean)))) { + if (isFALSE(split)) { + # single slide + if (!("sizefact" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first.") } else { - stop("No `probenum` is found. Run `aggreprobe` first.") - } - names(probenum) <- rownames(fData(posdat)) - - # extract annot from object - annot <- Biobase::pData(object) - - # setting default value for ROIs_high - if (is.null(ROIs_high)) { - if (!("sizefact_fitNBth" %in% varLabels(object))) { - stop("Please run `fitNBth` first.") - } else { - # estimate values for ROIs_high - ROIs_high <- Biobase::sampleNames(object)[which((quantile(Biobase::fData(object)[["para"]][, 1], probs = 0.90, na.rm = TRUE) - - Biobase::notes(object)[["threshold"]]) * object$sizefact_fitNBth > 2)] - } - } - - # setting default value for sizefact_BG - if (is.null(sizefact_BG)) { - if (isFALSE(split)) { - # single slide - sizefact_BG <- pDat[ROIs_high, "sizefact"] - } else { - # multiple slides - sizefact_BG <- pDat[ROIs_high, ][["sizefact_sp"]] - } - names(sizefact_BG) <- rownames(pDat[ROIs_high, ]) - } - - # setting default value for sizefact_start - if (is.null(sizefact_start)) { - if (!("sizefact_fitNBth" %in% colnames(pDat))) { - stop("Please run `fitNBth` first.") - } else { - sizefact_start <- pDat[ROIs_high, ][["sizefact_fitNBth"]] - } - names(sizefact_start) <- rownames(pDat[ROIs_high, ]) - } - - # setting default value for features_all - if (is.null(features_all)) { - gene_sum <- rowSums(countmat) - - if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { - features_all <- rownames(countmat) - } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { - features_all <- rownames(countmat) - } else { - stop("No information is found to determine the data type (CTA or WTA).") - } + # calculate the thmean for WTA or CTA data + thmean <- mean(fDatNeg[["featfact"]]) } - - # setting default value for features_high - if (is.null(features_high)) { - gene_sum <- rowSums(countmat) - - if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { - features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) - features_high <- sample(features_high, 1500) - } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { - if ( !any(grepl("scores", colnames(fDat))) ) { - stop("Please run `BGScoreTest` first. If you run `BGScoreTest` before, please specify `split = TRUE` for multiple slides.") - } else { - if ( any(grepl("scores_", colnames(fDat))) ){ - # fit the model with multiple slides - sc1_scores <- fData(posdat)[, grep("scores_", fvarLabels(posdat))] - rownames(sc1_scores) <- fData(posdat)[, "TargetName"] - features_high <- apply(sc1_scores, 2, function(x){ - ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) - }) - features_high <- names(which(apply(features_high, 1, all))) - - } else { - sc1_scores <- fData(posdat)[, "scores"] - names(sc1_scores) <- fData(posdat)[, "TargetName"] - features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) - features_high <- names(which(features_high)) - - } - } - - } else { - stop("No information is found to determine the data type (CTA or WTA).") - } + } else { + # multiple slides + if (!("sizefact_sp" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } else { + # calculate the thmean for WTA or CTA data + thmean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] } - - # replace threshold_mean for WTA - if (is.null(threshold_mean)) { - if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { - threshold_mean <- Biobase::notes(object)[["threshold"]] - } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { - threshold_mean <- thmean - } else { - stop("No information is found to determine the data type (CTA or WTA).") - } + } + } + + # calculate probenum for the dataset + if ("probenum" %in% fvarLabels(posdat)) { + probenum <- fData(posdat)[["probenum"]] + } else { + stop("No `probenum` is found. Run `aggreprobe` first.") + } + names(probenum) <- rownames(fData(posdat)) + + # extract annot from object + annot <- Biobase::pData(object) + + # setting default value for ROIs_high + if (is.null(ROIs_high)) { + if (!("sizefact_fitNBth" %in% varLabels(object))) { + stop("Please run `fitNBth` first.") + } else { + # estimate values for ROIs_high + ROIs_high <- Biobase::sampleNames(object)[which((quantile(Biobase::fData(object)[["para"]][, 1], probs = 0.90, na.rm = TRUE) - + Biobase::notes(object)[["threshold"]]) * object$sizefact_fitNBth > 2)] + } + } + + # setting default value for sizefact_BG + if (is.null(sizefact_BG)) { + if (isFALSE(split)) { + # single slide + sizefact_BG <- pDat[ROIs_high, "sizefact"] + } else { + # multiple slides + sizefact_BG <- pDat[ROIs_high, ][["sizefact_sp"]] + } + names(sizefact_BG) <- rownames(pDat[ROIs_high, ]) + } + + # setting default value for sizefact_start + if (is.null(sizefact_start)) { + if (!("sizefact_fitNBth" %in% colnames(pDat))) { + stop("Please run `fitNBth` first.") + } else { + sizefact_start <- pDat[ROIs_high, ][["sizefact_fitNBth"]] + } + names(sizefact_start) <- rownames(pDat[ROIs_high, ]) + } + + # setting default value for features_all + if (is.null(features_all)) { + gene_sum <- rowSums(countmat) + + if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { + features_all <- rownames(countmat) + } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { + features_all <- rownames(countmat) + } else { + stop("No information is found to determine the data type (CTA or WTA).") + } + } + + # setting default value for features_high + if (is.null(features_high)) { + gene_sum <- rowSums(countmat) + + if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { + features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) + features_high <- sample(features_high, 1500) + } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { + if ( !any(grepl("scores", colnames(fDat))) ) { + stop("Please run `BGScoreTest` first. If you run `BGScoreTest` before, please specify `split = TRUE` for multiple slides.") + } else { + if ( any(grepl("scores_", colnames(fDat))) ){ + # fit the model with multiple slides + sc1_scores <- fData(posdat)[, grep("scores_", fvarLabels(posdat))] + rownames(sc1_scores) <- fData(posdat)[, "TargetName"] + features_high <- apply(sc1_scores, 2, function(x){ + ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) + }) + features_high <- names(which(apply(features_high, 1, all))) + + } else { + sc1_scores <- fData(posdat)[, "scores"] + names(sc1_scores) <- fData(posdat)[, "TargetName"] + features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) + features_high <- names(which(features_high)) + + } } - - result <- fitNBthDE( - form = form, - annot = annot[ROIs_high, ], - object = countmat[, ROIs_high], - probenum = probenum, - features_high = features_high, - features_all = features_all, - sizefact_start = sizefact_start, - sizefact_BG = sizefact_BG, - threshold_mean = threshold_mean, - preci2 = preci2, - prior_type = prior_type, - sizefactrec = sizefactrec, - sizescalebythreshold = sizescalebythreshold, - iterations = iterations, - covrob = covrob, - preci1con = preci1con - ) - - return(result) + + } else { + stop("No information is found to determine the data type (CTA or WTA).") + } } + + # replace threshold_mean for WTA + if (is.null(threshold_mean)) { + if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { + threshold_mean <- Biobase::notes(object)[["threshold"]] + } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { + threshold_mean <- thmean + } else { + stop("No information is found to determine the data type (CTA or WTA).") + } + } + + result <- fitNBthDE( + form = form, + annot = annot[ROIs_high, ], + object = countmat[, ROIs_high], + probenum = probenum, + features_high = features_high, + features_all = features_all, + sizefact_start = sizefact_start, + sizefact_BG = sizefact_BG, + threshold_mean = threshold_mean, + preci2 = preci2, + prior_type = prior_type, + sizefactrec = sizefactrec, + sizescalebythreshold = sizescalebythreshold, + iterations = iterations, + covrob = covrob, + preci1con = preci1con + ) + + return(result) + } ) @@ -323,168 +323,168 @@ setMethod( #' @rdname fitNBthDE-methods #' @aliases fitNBthDE,matrix-method setMethod( - "fitNBthDE", "matrix", - function(form, annot, object, probenum, - features_high, features_all, sizefact_start, sizefact_BG, - threshold_mean, preci2=10000, lower_threshold = 0.01, - prior_type = c("contrast", "equal"), sizefactrec = TRUE, - size_scale = c("sum", "first"), sizescalebythreshold = FALSE, - iterations = 2, covrob = FALSE, preci1con=1/25, cutoff = 10, confac = 1) { - if (iterations == 1) { - if (!setequal(features_high, features_all)) { - warning("features_high and features_all need to be identical when iterations=1, + "fitNBthDE", "matrix", + function(form, annot, object, probenum, + features_high, features_all, sizefact_start, sizefact_BG, + threshold_mean, preci2=10000, lower_threshold = 0.01, + prior_type = c("contrast", "equal"), sizefactrec = TRUE, + size_scale = c("sum", "first"), sizescalebythreshold = FALSE, + iterations = 2, covrob = FALSE, preci1con=1/25, cutoff = 10, confac = 1) { + if (iterations == 1) { + if (!setequal(features_high, features_all)) { + warning("features_high and features_all need to be identical when iterations=1, assign features_high <- features_all") - } - features_high <- features_all - } - - X <- model.matrix(form, data = annot) - - - sizefact0 <- sizefact <- sizefact_start - n_sample <- nrow(X) - n_para <- ncol(X) - n_var <- max(attributes(X)$assign) - n_levels <- as.list(table(attributes(X)$assign)) - var_ind <- as.numeric(names(n_levels)) - - prior_type <- match.arg(prior_type) + } + features_high <- features_all + } + + X <- model.matrix(form, data = annot) + + + sizefact0 <- sizefact <- sizefact_start + n_sample <- nrow(X) + n_para <- ncol(X) + n_var <- max(attributes(X)$assign) + n_levels <- as.list(table(attributes(X)$assign)) + var_ind <- as.numeric(names(n_levels)) + + prior_type <- match.arg(prior_type) + if (prior_type == "equal") { + preci1 <- preci1con * t(X) %*% diag(1, n_sample) %*% X + } else if (prior_type == "contrast") { + contrvec <- t(rep(1 / n_sample, n_sample)) %*% X + + preci1 <- (preci1con) * t(contrvec) %*% contrvec + } + + + + + if (is.null(names(probenum))) names(probenum) <- rownames(object) + + if (sizescalebythreshold) { + startpara <- c(rep(0, ncol(X)), 1, 1.0) + } else { + startpara <- c(rep(0, ncol(X)), 1, threshold_mean) + } + + + for (iter in seq_len(iterations)) { + if (iter == 1) { + result <- NBthDE_paraOptall( + t(object[features_high, ]), as.matrix(X), sizefact_BG, sizefact, + preci1, threshold_mean * probenum[features_high], preci2, + startpara, sizescalebythreshold, (iter == iterations) + ) + para <- result$par + colnames(para) <- features_high + conv <- result$conv + names(conv) <- features_high + Im <- result$hes + names(Im) <- features_high + Im0 <- Im + para0 <- para + conv0 <- conv + } else { + result <- NBthDE_paraOptall( + t(object[features_all, ]), X, sizefact_BG, sizefact, + preci1, threshold_mean * probenum[features_all], preci2, + startpara, sizescalebythreshold, (iter == iterations) + ) + para <- result$par + colnames(para) <- features_all + conv <- result$conv + names(conv) <- features_all + Im <- result$hes + names(Im) <- features_all + } + + features_remain <- NA + if ((iterations > 1) & (iter == 1)) { + features_remain <- names(which(colMeans(abs(para[2:n_para, , drop = FALSE])) < cutoff)) if (prior_type == "equal") { - preci1 <- preci1con * t(X) %*% diag(1, n_sample) %*% X + if (covrob) { + cov_mat <- robust::covRob(t(para[seq_len(n_para), features_remain]), na.action = na.omit)$cov + } else { + cov_mat <- cov(t(para[seq_len(n_para), features_remain, drop = FALSE]), use = "pairwise.complete.obs") + } + preci1 <- solve(cov_mat) } else if (prior_type == "contrast") { - contrvec <- t(rep(1 / n_sample, n_sample)) %*% X - - preci1 <- (preci1con) * t(contrvec) %*% contrvec - } - - - - - if (is.null(names(probenum))) names(probenum) <- rownames(object) - - if (sizescalebythreshold) { - startpara <- c(rep(0, ncol(X)), 1, 1.0) - } else { - startpara <- c(rep(0, ncol(X)), 1, threshold_mean) - } - - - for (iter in seq_len(iterations)) { - if (iter == 1) { - result <- NBthDE_paraOptall( - t(object[features_high, ]), X, sizefact_BG, sizefact, - preci1, threshold_mean * probenum[features_high], preci2, - startpara, sizescalebythreshold, (iter == iterations) - ) - para <- result$par - colnames(para) <- features_high - conv <- result$conv - names(conv) <- features_high - Im <- result$hes - names(Im) <- features_high - Im0 <- Im - para0 <- para - conv0 <- conv + if (covrob) { + if (n_para == 2) { + cov_mat0 <- (robust::covRob(t(para[seq_len(n_para), features_remain]), na.action = na.omit)$cov)[2:n_para, 2:n_para, drop = FALSE] } else { - result <- NBthDE_paraOptall( - t(object[features_all, ]), X, sizefact_BG, sizefact, - preci1, threshold_mean * probenum[features_all], preci2, - startpara, sizescalebythreshold, (iter == iterations) - ) - para <- result$par - colnames(para) <- features_all - conv <- result$conv - names(conv) <- features_all - Im <- result$hes - names(Im) <- features_all - } - - features_remain <- NA - if ((iterations > 1) & (iter == 1)) { - features_remain <- names(which(colMeans(abs(para[2:n_para, , drop = FALSE])) < cutoff)) - if (prior_type == "equal") { - if (covrob) { - cov_mat <- robust::covRob(t(para[seq_len(n_para), features_remain]), na.action = na.omit)$cov - } else { - cov_mat <- cov(t(para[seq_len(n_para), features_remain, drop = FALSE]), use = "pairwise.complete.obs") - } - preci1 <- solve(cov_mat) - } else if (prior_type == "contrast") { - if (covrob) { - if (n_para == 2) { - cov_mat0 <- (robust::covRob(t(para[seq_len(n_para), features_remain]), na.action = na.omit)$cov)[2:n_para, 2:n_para, drop = FALSE] - } else { - cov_mat0 <- robust::covRob(t(para[2:n_para, features_remain]), na.action = na.omit)$cov - } - } else { - cov_mat0 <- cov(t(para[2:n_para, features_remain, drop = FALSE]), use = "pairwise.complete.obs") - } - - contrvec <- t(rep(1 / n_sample, n_sample)) %*% X - contrmat <- rbind(contrvec, cbind(rep(0, (n_para - 1)), diag(1, (n_para - 1)))) - preci_list <- list(`0` = diag(confac * preci1con, nrow = 1), preci_mat = solve(cov_mat0)) - preci10 <- Matrix::bdiag(preci_list) - preci1 <- as.matrix(t(contrmat) %*% preci10 %*% contrmat) - } - } - - - if (sizefactrec) { - # if((EB)&(iter==1)){ - # genes_NA <- features_high[unique(which(is.na(para), arr.ind = TRUE)[,2])] - # features_remain <- setdiff(features_high, genes_NA) - # } else { - # genes_NA <- features_all[unique(which(is.na(para), arr.ind = TRUE)[,2])] - # features_remain <- setdiff(features_all, genes_NA) - # } - size_scale <- match.arg(size_scale) - features_remain <- names(which(colMeans(abs(para[2:n_para, , drop = FALSE])) < cutoff)) - - - for (i in seq_len(length(sizefact))) { - fun <- NBthDE_scalenll(X[i, ], object[features_remain, i], probenum[features_remain], para[seq_len(n_para), features_remain], t(para[n_para + 1, features_remain]), sizefact_BG[i], para[n_para + 2, features_remain], sizescalebythreshold, threshold_mean) - sizefact[i] <- optim(c(sizefact[i]), fun, lower = c(0), method = "L-BFGS-B")$par - } - - if (size_scale == "first") { - scale_fac <- sizefact[1] - } else if (size_scale == "sum") { - scale_fac <- sum(sizefact) - } - - sizefact <- sizefact / scale_fac - - message(sprintf( - "Iteration = %s, squared error = %e", - iter, - sum((sizefact - sizefact0)^2) - )) - - if (iter == 1) { - sizefact0 <- sizefact - } + cov_mat0 <- robust::covRob(t(para[2:n_para, features_remain]), na.action = na.omit)$cov } + } else { + cov_mat0 <- cov(t(para[2:n_para, features_remain, drop = FALSE]), use = "pairwise.complete.obs") + } + + contrvec <- t(rep(1 / n_sample, n_sample)) %*% X + contrmat <- rbind(contrvec, cbind(rep(0, (n_para - 1)), diag(1, (n_para - 1)))) + preci_list <- list(`0` = diag(confac * preci1con, nrow = 1), preci_mat = solve(cov_mat0)) + preci10 <- Matrix::bdiag(preci_list) + preci1 <- as.matrix(t(contrmat) %*% preci10 %*% contrmat) } - - - paraname <- c(colnames(X), c("r", "threshold")) - rownames(para0) <- rownames(para) <- paraname - - return(list( - X = X, - para0 = para0, - para = para, - sizefact = sizefact, - sizefact0 = sizefact0, - preci1 = preci1, - Im0 = Im0, - Im = Im, - conv0 = conv0, - conv = conv, - features_high = features_high, - features_all = features_all + } + + + if (sizefactrec) { + # if((EB)&(iter==1)){ + # genes_NA <- features_high[unique(which(is.na(para), arr.ind = TRUE)[,2])] + # features_remain <- setdiff(features_high, genes_NA) + # } else { + # genes_NA <- features_all[unique(which(is.na(para), arr.ind = TRUE)[,2])] + # features_remain <- setdiff(features_all, genes_NA) + # } + size_scale <- match.arg(size_scale) + features_remain <- names(which(colMeans(abs(para[2:n_para, , drop = FALSE])) < cutoff)) + + + for (i in seq_len(length(sizefact))) { + fun <- NBthDE_scalenll(X[i, ], object[features_remain, i], probenum[features_remain], para[seq_len(n_para), features_remain], t(para[n_para + 1, features_remain]), sizefact_BG[i], para[n_para + 2, features_remain], sizescalebythreshold, threshold_mean) + sizefact[i] <- optim(c(sizefact[i]), fun, lower = c(0), method = "L-BFGS-B")$par + } + + if (size_scale == "first") { + scale_fac <- sizefact[1] + } else if (size_scale == "sum") { + scale_fac <- sum(sizefact) + } + + sizefact <- sizefact / scale_fac + + message(sprintf( + "Iteration = %s, squared error = %e", + iter, + sum((sizefact - sizefact0)^2) )) + + if (iter == 1) { + sizefact0 <- sizefact + } + } } + + + paraname <- c(colnames(X), c("r", "threshold")) + rownames(para0) <- rownames(para) <- paraname + + return(list( + X = X, + para0 = para0, + para = para, + sizefact = sizefact, + sizefact0 = sizefact0, + preci1 = preci1, + Im0 = Im0, + Im = Im, + conv0 = conv0, + conv = conv, + features_high = features_high, + features_all = features_all + )) + } ) #' Generate list of Wald test inference results on model coefficients @@ -511,49 +511,49 @@ setMethod( #' @rdname coefNBth-methods setGeneric("coefNBth", - signature = c("object"), - function(object, ...) standardGeneric("coefNBth") + signature = c("object"), + function(object, ...) standardGeneric("coefNBth") ) #' @rdname coefNBth-methods #' @aliases coefNBth,list-method setMethod( - "coefNBth", "list", - function(object, fullpara = FALSE) { - X <- object$X - if (fullpara) { - n_para <- ncol(X) + 2 - paraname <- c(colnames(X), c("r", "threshold")) - } else { - n_para <- ncol(X) - paraname <- colnames(X) - } - estimate <- object$para[seq_len(n_para), ] - se <- lapply(object$Im, function(x) tryCatch( - { - x_tmp <- diag(solve(x)) - x_tmp[which(x_tmp <0 )] <- NaN - res <- sqrt(x_tmp)[seq_len(n_para)] - return(res) - }, - error = function(err) NA)) - - wald_stat <- mapply(function(x, y) (x / y), as.list(as.data.frame(estimate)), se, SIMPLIFY = FALSE) - - - p_value <- sapply(wald_stat, function(x) 2 * pnorm(-abs(x))) - wald_stat <- sapply(wald_stat, function(x) x) - se <- sapply(se, function(x) x) - - rownames(estimate) <- rownames(wald_stat) <- rownames(p_value) <- rownames(se) <- paraname - - return(list( - estimate = estimate, - wald_stat = wald_stat, - p_value = p_value, - se = se - )) + "coefNBth", "list", + function(object, fullpara = FALSE) { + X <- object$X + if (fullpara) { + n_para <- ncol(X) + 2 + paraname <- c(colnames(X), c("r", "threshold")) + } else { + n_para <- ncol(X) + paraname <- colnames(X) } + estimate <- object$para[seq_len(n_para), ] + se <- lapply(object$Im, function(x) tryCatch( + { + x_tmp <- diag(solve(x)) + x_tmp[which(x_tmp <0 )] <- NaN + res <- sqrt(x_tmp)[seq_len(n_para)] + return(res) + }, + error = function(err) NA)) + + wald_stat <- mapply(function(x, y) (x / y), as.list(as.data.frame(estimate)), se, SIMPLIFY = FALSE) + + + p_value <- sapply(wald_stat, function(x) 2 * pnorm(-abs(x))) + wald_stat <- sapply(wald_stat, function(x) x) + se <- sapply(se, function(x) x) + + rownames(estimate) <- rownames(wald_stat) <- rownames(p_value) <- rownames(se) <- paraname + + return(list( + estimate = estimate, + wald_stat = wald_stat, + p_value = p_value, + se = se + )) + } ) @@ -584,48 +584,48 @@ setMethod( #' @rdname contrastNBth-methods #' setGeneric("contrastNBth", - signature = c("object"), - function(object, ...) standardGeneric("contrastNBth") + signature = c("object"), + function(object, ...) standardGeneric("contrastNBth") ) #' @rdname contrastNBth-methods #' @aliases contrastNBth,list-method setMethod( - "contrastNBth", "list", - function(object, test = c("two-sided", ">", "<"), - method = diag(1, ncol(object$X)), - baseline = rep(0, ncol(method))) { - test <- match.arg(test) - X <- object$X - n_para <- ncol(X) - if (is.matrix(method)) { - contrast <- method - } else { - stop("matrix is the only contrast method is allowed for now") - } - estimate <- t(contrast) %*% object$para[seq_len(n_para), ] - estimate <- estimate - matrix(rep(baseline, ncol(estimate)), ncol = ncol(estimate)) - se <- lapply(object$Im, function(x) tryCatch(sqrt(diag(t(contrast) %*% solve(x)[seq_len(n_para), seq_len(n_para)] %*% contrast)), error = function(err) NA)) - wald_stat <- mapply(function(x, y) (x / y), as.list(as.data.frame(estimate)), se, SIMPLIFY = FALSE) - if (test == "two-sided") { - p_value <- sapply(wald_stat, function(x) 2 * pnorm(-abs(x))) - } else if (test == ">") { - p_value <- sapply(wald_stat, function(x) pnorm(x, lower.tail = FALSE)) - } else { - p_value <- sapply(wald_stat, function(x) pnorm(x, lower.tail = TRUE)) - } - - wald_stat <- sapply(wald_stat, function(x) x) - se <- sapply(se, function(x) x) - rownames(estimate) <- rownames(wald_stat) <- rownames(p_value) <- rownames(se) <- colnames(contrast) - - return(list( - estimate = estimate, - wald_stat = wald_stat, - p_value = p_value, - se = se - )) + "contrastNBth", "list", + function(object, test = c("two-sided", ">", "<"), + method = diag(1, ncol(object$X)), + baseline = rep(0, ncol(method))) { + test <- match.arg(test) + X <- object$X + n_para <- ncol(X) + if (is.matrix(method)) { + contrast <- method + } else { + stop("matrix is the only contrast method is allowed for now") + } + estimate <- t(contrast) %*% object$para[seq_len(n_para), ] + estimate <- estimate - matrix(rep(baseline, ncol(estimate)), ncol = ncol(estimate)) + se <- lapply(object$Im, function(x) tryCatch(sqrt(diag(t(contrast) %*% solve(x)[seq_len(n_para), seq_len(n_para)] %*% contrast)), error = function(err) NA)) + wald_stat <- mapply(function(x, y) (x / y), as.list(as.data.frame(estimate)), se, SIMPLIFY = FALSE) + if (test == "two-sided") { + p_value <- sapply(wald_stat, function(x) 2 * pnorm(-abs(x))) + } else if (test == ">") { + p_value <- sapply(wald_stat, function(x) pnorm(x, lower.tail = FALSE)) + } else { + p_value <- sapply(wald_stat, function(x) pnorm(x, lower.tail = TRUE)) } + + wald_stat <- sapply(wald_stat, function(x) x) + se <- sapply(se, function(x) x) + rownames(estimate) <- rownames(wald_stat) <- rownames(p_value) <- rownames(se) <- colnames(contrast) + + return(list( + estimate = estimate, + wald_stat = wald_stat, + p_value = p_value, + se = se + )) + } ) @@ -653,27 +653,27 @@ setMethod( #' @rdname DENBth-methods #' setGeneric("DENBth", - signature = c("object"), - function(object, ...) standardGeneric("DENBth") + signature = c("object"), + function(object, ...) standardGeneric("DENBth") ) #' @rdname DENBth-methods #' @aliases DENBth,list-method setMethod( - "DENBth", "list", - function(object, variable, NAto1 = TRUE, padj = TRUE, padj_method = "BH") { - DEtab <- as.data.frame(cbind(log2FC = object$estimate[variable, ], pvalue = object$p_value[variable, ])) - if (NAto1) { - DEtab$pvalue[is.na(DEtab$pvalue)] <- 1 - } - - if (padj) { - DEtab$adjp <- p.adjust(DEtab$pvalue, method = padj_method) - } - - - return(DEtab) + "DENBth", "list", + function(object, variable, NAto1 = TRUE, padj = TRUE, padj_method = "BH") { + DEtab <- as.data.frame(cbind(log2FC = object$estimate[variable, ], pvalue = object$p_value[variable, ])) + if (NAto1) { + DEtab$pvalue[is.na(DEtab$pvalue)] <- 1 + } + + if (padj) { + DEtab$adjp <- p.adjust(DEtab$pvalue, method = padj_method) } + + + return(DEtab) + } ) diff --git a/R/NBthDE_nllopt.R b/R/NBthDE_nllopt.R index c4cd9de..7ddeb83 100644 --- a/R/NBthDE_nllopt.R +++ b/R/NBthDE_nllopt.R @@ -1,32 +1,21 @@ - - - - - - NBthDE_scalenll <- function(X, Y, probenum, regcoefmat, rvec, sizefact0, threshold, sizescale, threshold_mean) { - tmp0 <- 2^(X %*% regcoefmat) - if (sizescale) { - loglik_ind <- function(sizefact) { - tmp1 <- probenum * threshold_mean * sizefact0 * threshold + probenum * threshold_mean * sizefact * tmp0 - - - tmp3 <- dnbinom(x = Y, size = rvec, mu = tmp1, log = TRUE) - - # - ((log(phi) - m0)^2)/(2 * (sigma^2)) - log(sigma) - -(sum(tmp3)) - } - } else { - loglik_ind <- function(sizefact) { - tmp1 <- sizefact0 * probenum * threshold + sizefact * tmp0 - - - tmp3 <- dnbinom(x = Y, size = rvec, mu = tmp1, log = TRUE) - - # - ((log(phi) - m0)^2)/(2 * (sigma^2)) - log(sigma) - -(sum(tmp3)) - } + tmp0 <- 2^(X %*% regcoefmat) + if (sizescale) { + loglik_ind <- function(sizefact) { + tmp1 <- probenum * threshold_mean * sizefact0 * threshold + probenum * threshold_mean * sizefact * tmp0 + + tmp3 <- dnbinom(x = Y, size = rvec, mu = tmp1, log = TRUE) + -(sum(tmp3)) + } + } else { + loglik_ind <- function(sizefact) { + tmp1 <- sizefact0 * probenum * threshold + sizefact * tmp0 + + + tmp3 <- dnbinom(x = Y, size = rvec, mu = tmp1, log = TRUE) + -(sum(tmp3)) } - return(loglik_ind) + } + return(loglik_ind) } diff --git a/R/NBth_nllopt.R b/R/NBth_nllopt.R index 78d52b4..ebd01d8 100644 --- a/R/NBth_nllopt.R +++ b/R/NBth_nllopt.R @@ -1,69 +1,47 @@ NBth_paranll <- function(Y, probenum, sizefact, sizefact0, threshold) { - loglik_ind <- function(x) { - featfact <- x[1] - r <- x[2] - # tmp1 = 1/(1 + (sizefact0*min(featfact, threshold)+sizefact*max(featfact-threshold,0))/r) - tmp1 <- sizefact0 * min(featfact, probenum * threshold) + sizefact * max(featfact - probenum * threshold, 0) - - # tmp3 = dnbinom(x = Y, size = r, prob = tmp1, log = TRUE) - - tmp3 <- dnbinom(x = Y, size = r, mu = tmp1, log = TRUE) - - # - ((log(phi) - m0)^2)/(2 * (sigma^2)) - log(sigma) - -(sum(tmp3)) - } + loglik_ind <- function(x) { + featfact <- x[1] + r <- x[2] + tmp1 <- sizefact0 * min(featfact, probenum * threshold) + sizefact * max(featfact - probenum * threshold, 0) + + tmp3 <- dnbinom(x = Y, size = r, mu = tmp1, log = TRUE) + -(sum(tmp3)) + } } NBth_scalenll <- function(Y, probenum, featfactvec, rvec, sizefact0, threshold) { - loglik_ind <- function(sizefact) { - - - # tmp1 = 1/(1 + (sizefact0*pmin(featfactvec, threshold)+sizefact*pmax(featfactvec-threshold,0))/rvec) - tmp1 <- sizefact0 * pmin(featfactvec, probenum * threshold) + sizefact * pmax(featfactvec - probenum * threshold, 0) - - # tmp3 <- dnbinom(x = Y, size=rvec, prob = tmp1, log = TRUE) - - tmp3 <- dnbinom(x = Y, size = rvec, mu = tmp1, log = TRUE) - - # - ((log(phi) - m0)^2)/(2 * (sigma^2)) - log(sigma) - -(sum(tmp3)) - } + loglik_ind <- function(sizefact) { + + tmp1 <- sizefact0 * pmin(featfactvec, probenum * threshold) + sizefact * pmax(featfactvec - probenum * threshold, 0) + + tmp3 <- dnbinom(x = Y, size = rvec, mu = tmp1, log = TRUE) + + -(sum(tmp3)) + } } NBth_thnll <- function(Y, probenum, sizefact, sizefact0, featfactvec, rvec) { - loglik_ind <- function(threshold) { - - - # tmp1 = 1/(1 + sweep((sizefact0%*%(pmin(featfactvec, threshold))+sizefact%*%(pmax(featfactvec-threshold,0))), 2, rvec, FUN="/")) - - tmp1 <- sizefact0 %*% (pmin(featfactvec, probenum * threshold)) + sizefact %*% (pmax(featfactvec - probenum * threshold, 0)) - - - - # tmp3 <- dnbinom(x = as.matrix(Y), size = matrix(rep(rvec, each=length(sizefact)), ncol=length(rvec)), - # prob = tmp1, log = TRUE) - - tmp3 <- dnbinom( - x = t(as.matrix(Y)), size = matrix(rep(rvec, each = length(sizefact)), ncol = length(rvec)), - mu = tmp1, log = TRUE - ) - - - - # - ((log(phi) - m0)^2)/(2 * (sigma^2)) - log(sigma) - -(sum(tmp3)) - } + loglik_ind <- function(threshold) { + + tmp1 <- sizefact0 %*% (pmin(featfactvec, probenum * threshold)) + sizefact %*% (pmax(featfactvec - probenum * threshold, 0)) + + tmp3 <- dnbinom( + x = t(as.matrix(Y)), size = matrix(rep(rvec, each = length(sizefact)), ncol = length(rvec)), + mu = tmp1, log = TRUE + ) + + -(sum(tmp3)) + } } - NBth_paraopt <- function(countmat, probenum, sizefact, sizefact0, threshold, start = c(0.5, 0.5), lower = c(0.01, 0.01)) { - if (is.null(names(probenum))) probenum <- rownames(countmat) - para <- sapply(rownames(countmat), function(x) { - fun1 <- NBth_paranll(countmat[x, ], probenum[x], sizefact, sizefact0, threshold) - result <- tryCatch(optim(start, fun1, lower = lower, method = "L-BFGS-B")$par, error = function(err) c(NA, NA)) - }) - return(para) + if (is.null(names(probenum))) probenum <- rownames(countmat) + para <- sapply(rownames(countmat), function(x) { + fun1 <- NBth_paranll(countmat[x, ], probenum[x], sizefact, sizefact0, threshold) + result <- tryCatch(optim(start, fun1, lower = lower, method = "L-BFGS-B")$par, error = function(err) c(NA, NA)) + }) + return(para) } diff --git a/R/NBthmDE.R b/R/NBthmDE.R index 14d92f7..6f2b3da 100644 --- a/R/NBthmDE.R +++ b/R/NBthmDE.R @@ -108,144 +108,141 @@ #' @docType methods #' @rdname fitNBthmDE-methods setGeneric("fitNBthmDE", - signature = c("object"), - function(object, ...) standardGeneric("fitNBthmDE") + signature = c("object"), + function(object, ...) standardGeneric("fitNBthmDE") ) #' @rdname fitNBthmDE-methods #' @aliases fitNBthmDE,NanoStringGeoMxSet-method setMethod( - "fitNBthmDE", "NanoStringGeoMxSet", - function(object, form, split, ROIs_high = NULL, - features_all = NULL, sizefact = NULL, sizefact_BG = NULL, - preci1, threshold_mean = NULL, - preci2=10000, sizescalebythreshold = TRUE, controlRandom = list()) { - fDat <- Biobase::fData(object) - pDat <- Biobase::pData(object) - - posdat <- object[-which(fDat$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(posdat) - - fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] - - # only calculate backmean if any of the three params are missing - if (any(c(is.null(sizefact_BG), is.null(sizefact), is.null(ROIs_high), is.null(threshold_mean)))) { - if (isFALSE(split)) { - # single slide - if (!("sizefact" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first.") - } else { - # calculate the backmean for WTA or CTA data - featfact_mean <- mean(fDatNeg[["featfact"]]) - } - } else { - # multiple slides - if (!("sizefact_sp" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } else { - # calculate the backmean for WTA or CTA data - featfact_mean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] - } - } - } - - - - # calculate probenum for the dataset - if ("probenum" %in% fvarLabels(posdat)) { - probenum <- fData(posdat)[["probenum"]] + "fitNBthmDE", "NanoStringGeoMxSet", + function(object, form, split, ROIs_high = NULL, + features_all = NULL, sizefact = NULL, sizefact_BG = NULL, + preci1, threshold_mean = NULL, + preci2=10000, sizescalebythreshold = TRUE, controlRandom = list()) { + fDat <- Biobase::fData(object) + pDat <- Biobase::pData(object) + + posdat <- object[-which(fDat$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(posdat) + + fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] + + # only calculate backmean if any of the three params are missing + if (any(c(is.null(sizefact_BG), is.null(sizefact), is.null(ROIs_high), is.null(threshold_mean)))) { + if (isFALSE(split)) { + # single slide + if (!("sizefact" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first.") } else { - stop("No `probenum` is found. Run `aggreprobe` first.") - } - names(probenum) <- rownames(fData(posdat)) - - # extract annot from object - annot <- Biobase::pData(object) - - # setting default value for ROIs_high - if (is.null(ROIs_high)) { - if (!("sizefact_fitNBth" %in% varLabels(object))) { - stop("Please run `fitNBth` first.") - } else { - # estimate values for ROIs_high - ROIs_high <- Biobase::sampleNames(object)[which((quantile(Biobase::fData(object)[["para"]][, 1], probs = 0.90, na.rm = TRUE) - - Biobase::notes(object)[["threshold"]]) * object$sizefact_fitNBth > 2)] - } - } - - # setting default value for sizefact_BG - if (is.null(sizefact_BG)) { - if (isFALSE(split)) { - # single slide - sizefact_BG <- pDat[ROIs_high, "sizefact"] - } else { - # multiple slides - sizefact_BG <- pDat[ROIs_high, ][["sizefact_sp"]] - } - names(sizefact_BG) <- rownames(pDat[ROIs_high, ]) + # calculate the backmean for WTA or CTA data + featfact_mean <- mean(fDatNeg[["featfact"]]) } - - - # setting default value for sizefact - if (is.null(sizefact)) { - if (!("sizefact_fitNBth" %in% colnames(pDat))) { - stop("Please run `fitNBth` first.") - } else { - sizefact <- pDat[ROIs_high, ][["sizefact_fitNBth"]] - } - names(sizefact) <- rownames(pDat[ROIs_high, ]) + } else { + # multiple slides + if (!("sizefact_sp" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } else { + # calculate the backmean for WTA or CTA data + featfact_mean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] } - - # setting default value for features_high - if (is.null(features_all)) { - gene_sum <- rowSums(countmat) - - if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { - features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) - features_high <- sample(features_high, 1500) - } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { - if ( !any(grepl("scores", colnames(fDat))) ) { - stop("Please run `BGScoreTest` first. If you run `BGScoreTest` before, please specify `split = TRUE` for multiple slides.") - } else { - if ( any(grepl("scores_", colnames(fDat))) ){ - # fit the model with multiple slides - sc1_scores <- fData(posdat)[, grep("scores_", fvarLabels(posdat))] - rownames(sc1_scores) <- fData(posdat)[, "TargetName"] - features_high <- apply(sc1_scores, 2, function(x){ - ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) - }) - features_high <- names(which(apply(features_high, 1, all))) - - } else { - sc1_scores <- fData(posdat)[, "scores"] - names(sc1_scores) <- fData(posdat)[, "TargetName"] - features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) - features_high <- names(which(features_high)) - - } - } - - } else { - stop("No information is found to determine the data type (CTA or WTA).") - } - features_all <- features_high[seq_len(5)] + } + } + + # calculate probenum for the dataset + if ("probenum" %in% fvarLabels(posdat)) { + probenum <- fData(posdat)[["probenum"]] + } else { + stop("No `probenum` is found. Run `aggreprobe` first.") + } + names(probenum) <- rownames(fData(posdat)) + + # extract annot from object + annot <- Biobase::pData(object) + + # setting default value for ROIs_high + if (is.null(ROIs_high)) { + if (!("sizefact_fitNBth" %in% varLabels(object))) { + stop("Please run `fitNBth` first.") + } else { + # estimate values for ROIs_high + ROIs_high <- Biobase::sampleNames(object)[which((quantile(Biobase::fData(object)[["para"]][, 1], probs = 0.90, na.rm = TRUE) - + Biobase::notes(object)[["threshold"]]) * object$sizefact_fitNBth > 2)] + } + } + + # setting default value for sizefact_BG + if (is.null(sizefact_BG)) { + if (isFALSE(split)) { + # single slide + sizefact_BG <- pDat[ROIs_high, "sizefact"] + } else { + # multiple slides + sizefact_BG <- pDat[ROIs_high, ][["sizefact_sp"]] + } + names(sizefact_BG) <- rownames(pDat[ROIs_high, ]) + } + + # setting default value for sizefact + if (is.null(sizefact)) { + if (!("sizefact_fitNBth" %in% colnames(pDat))) { + stop("Please run `fitNBth` first.") + } else { + sizefact <- pDat[ROIs_high, ][["sizefact_fitNBth"]] + } + names(sizefact) <- rownames(pDat[ROIs_high, ]) + } + + # setting default value for features_high + if (is.null(features_all)) { + gene_sum <- rowSums(countmat) + + if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { + features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) + features_high <- sample(features_high, 1500) + } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { + if ( !any(grepl("scores", colnames(fDat))) ) { + stop("Please run `BGScoreTest` first. If you run `BGScoreTest` before, please specify `split = TRUE` for multiple slides.") + } else { + if ( any(grepl("scores_", colnames(fDat))) ){ + # fit the model with multiple slides + sc1_scores <- fData(posdat)[, grep("scores_", fvarLabels(posdat))] + rownames(sc1_scores) <- fData(posdat)[, "TargetName"] + features_high <- apply(sc1_scores, 2, function(x){ + ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) + }) + features_high <- names(which(apply(features_high, 1, all))) + + } else { + sc1_scores <- fData(posdat)[, "scores"] + names(sc1_scores) <- fData(posdat)[, "TargetName"] + features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) + features_high <- names(which(features_high)) + + } } - - result <- fitNBthmDE( - form = form, - annot = annot[ROIs_high, ], - object = countmat[, ROIs_high], - probenum = probenum, - features_all = features_all, - sizefact = sizefact, - sizefact_BG = sizefact_BG, - preci1 = preci1, - threshold_mean = threshold_mean, - preci2 = preci2, - sizescalebythreshold = sizescalebythreshold, - controlRandom = controlRandom - ) + + } else { + stop("No information is found to determine the data type (CTA or WTA).") + } + features_all <- features_high[seq_len(5)] } + + result <- fitNBthmDE( + form = form, + annot = annot[ROIs_high, ], + object = countmat[, ROIs_high], + probenum = probenum, + features_all = features_all, + sizefact = sizefact, + sizefact_BG = sizefact_BG, + preci1 = preci1, + threshold_mean = threshold_mean, + preci2 = preci2, + sizescalebythreshold = sizescalebythreshold, + controlRandom = controlRandom + ) + } ) #' Negative Binomial threshold mixed model for differential expression analysis @@ -291,132 +288,130 @@ setMethod( #' @rdname fitNBthmDE-methods #' @aliases fitNBthmDE,matrix-method setMethod( - "fitNBthmDE", "matrix", - function(form, annot, object, probenum = rep(1, NROW(object)), - features_all, sizefact, sizefact_BG, preci1, threshold_mean = NULL, - preci2=10000, sizescalebythreshold = TRUE, controlRandom = list()) { - if (is.null(names(probenum))) names(probenum) <- rownames(object) - - n_feature <- length(features_all) - - cRandom <- list( - nmh_s = 40, nmh_e = 200, - thin_s = 8, thin_e = 20, useprior = TRUE, thetapri = 1, - nu = NA, lower = NA, upper = NA, iterations = 300, - lower0 = 0.01, upper0 = 20, preciu0 = 1 - ) - - - # Options for random effect - cRandomNames <- names(cRandom) - cRandom[(controlN <- names(controlRandom))] <- controlRandom - if (length(unkwn <- controlN[!controlN %in% cRandomNames])) { - warning("Unknown names in control: ", paste(unkwn, collapse = ", ")) - } - - - annot$fake <- 1 - if (length(form) == 2) { - form[[3]] <- form[[2]] - } - form[[2]] <- as.name("fake") - resu <- lme4::lFormula(form, data = annot) - - X <- resu$X - - rt <- resu$reTrms - Z <- t(as.matrix(rt$Zt)) - Lambdati <- rt$Lambdat - mapping <- function(theta) theta[rt$Lind] - - if (missing(preci1)) { - preci <- diag(1, ncol(X)) - } - - rl <- nrow(Lambdati) - if (is.na(cRandom$preciu0)) { - cRandom$preciu0 <- 1 - } - - - - cRandom$preciu <- diag(cRandom$preciu0, rl) - - - lower <- rt$lower - lower[lower == 0] <- cRandom$lower0 - cRandom$lower <- lower - - upper <- -rt$lower - upper[upper == 0] <- cRandom$upper0 - cRandom$upper <- upper - - message(rl) - message("----------") - if (is.na(cRandom$nu)) { - nu <- 4 + rl - cRandom$nu <- nu - } - - cluster_size <- sum(rt$Lind == 1) - temp_size <- nrow(Lambdati) / cluster_size - - para <- matrix(0, nrow = (ncol(X) + 2), ncol = n_feature) - theta <- matrix(0, nrow = max(rt$Lind), ncol = n_feature) - varcov <- theta - colnames(theta) <- features_all - colnames(varcov) <- features_all - colnames(para) <- features_all - - Im <- list() - nmh_sq <- floor(seq(cRandom$nmh_s, cRandom$nmh_e, length.out = cRandom$iterations)) - thin_sq <- floor(seq(cRandom$thin_s, cRandom$thin_e, length.out = cRandom$iterations)) - cRandom$nmh_sq <- nmh_sq - cRandom$thin_sq <- thin_sq - - - Uvec <- matrix(0, ncol(Z), n_feature) - colnames(Uvec) <- features_all - conv <- numeric(n_feature) - names(conv) <- features_all - for (feature in features_all) { - NBthmmodfeat <- fitNBthmDEfeat( - t(object[feature, ]), probenum[feature], X, Z, sizefact, sizefact_BG, preci1, threshold_mean, preci2, Lambdati, - mapping, cluster_size, temp_size, rl, rt, sizescalebythreshold, cRandom - ) - para[, feature] <- NBthmmodfeat$para_fix - theta[, feature] <- NBthmmodfeat$theta - varcov[, feature] <- NBthmmodfeat$varcov - Im[[feature]] <- NBthmmodfeat$Im - Uvec[, feature] <- NBthmmodfeat$Uvec - conv[feature] <- NBthmmodfeat$conv - message(feature) - message("----------") - } - names(Im) <- features_all - names(theta) <- features_all - - paraname <- c(colnames(X), c("r", "threshold")) - rownames(para) <- paraname - - return(list( - X = X, - Z = Z, - rt = rt, - para0 = NA, - para = para, - sizefact = sizefact, - sizefact0 = NA, - preci1 = preci1, - conv0 = NA, - conv = conv, - Im0 = NA, - Im = Im, - features_high = NA, - features_all = features_all, - theta = theta, - varcov = varcov, - Uvec = Uvec - )) + "fitNBthmDE", "matrix", + function(form, annot, object, probenum = rep(1, NROW(object)), + features_all, sizefact, sizefact_BG, preci1, threshold_mean = NULL, + preci2=10000, sizescalebythreshold = TRUE, controlRandom = list()) { + if (is.null(names(probenum))) names(probenum) <- rownames(object) + + n_feature <- length(features_all) + + cRandom <- list( + nmh_s = 40, nmh_e = 200, + thin_s = 8, thin_e = 20, useprior = TRUE, thetapri = 1, + nu = NA, lower = NA, upper = NA, iterations = 300, + lower0 = 0.01, upper0 = 20, preciu0 = 1 + ) + + + # Options for random effect + cRandomNames <- names(cRandom) + cRandom[(controlN <- names(controlRandom))] <- controlRandom + if (length(unkwn <- controlN[!controlN %in% cRandomNames])) { + warning("Unknown names in control: ", paste(unkwn, collapse = ", ")) + } + + + annot$fake <- 1 + if (length(form) == 2) { + form[[3]] <- form[[2]] + } + form[[2]] <- as.name("fake") + resu <- lme4::lFormula(form, data = annot) + + X <- resu$X + + rt <- resu$reTrms + Z <- t(as.matrix(rt$Zt)) + Lambdati <- rt$Lambdat + mapping <- function(theta) theta[rt$Lind] + + if (missing(preci1)) { + preci <- diag(1, ncol(X)) + } + + rl <- nrow(Lambdati) + if (is.na(cRandom$preciu0)) { + cRandom$preciu0 <- 1 + } + + cRandom$preciu <- diag(cRandom$preciu0, rl) + + + lower <- rt$lower + lower[lower == 0] <- cRandom$lower0 + cRandom$lower <- lower + + upper <- -rt$lower + upper[upper == 0] <- cRandom$upper0 + cRandom$upper <- upper + + message(rl) + message("----------") + if (is.na(cRandom$nu)) { + nu <- 4 + rl + cRandom$nu <- nu + } + + cluster_size <- sum(rt$Lind == 1) + temp_size <- nrow(Lambdati) / cluster_size + + para <- matrix(0, nrow = (ncol(X) + 2), ncol = n_feature) + theta <- matrix(0, nrow = max(rt$Lind), ncol = n_feature) + varcov <- theta + colnames(theta) <- features_all + colnames(varcov) <- features_all + colnames(para) <- features_all + + Im <- list() + nmh_sq <- floor(seq(cRandom$nmh_s, cRandom$nmh_e, length.out = cRandom$iterations)) + thin_sq <- floor(seq(cRandom$thin_s, cRandom$thin_e, length.out = cRandom$iterations)) + cRandom$nmh_sq <- nmh_sq + cRandom$thin_sq <- thin_sq + + + Uvec <- matrix(0, ncol(Z), n_feature) + colnames(Uvec) <- features_all + conv <- numeric(n_feature) + names(conv) <- features_all + for (feature in features_all) { + NBthmmodfeat <- fitNBthmDEfeat( + t(object[feature, ]), probenum[feature], X, Z, sizefact, sizefact_BG, preci1, threshold_mean, preci2, Lambdati, + mapping, cluster_size, temp_size, rl, rt, sizescalebythreshold, cRandom + ) + para[, feature] <- NBthmmodfeat$para_fix + theta[, feature] <- NBthmmodfeat$theta + varcov[, feature] <- NBthmmodfeat$varcov + Im[[feature]] <- NBthmmodfeat$Im + Uvec[, feature] <- NBthmmodfeat$Uvec + conv[feature] <- NBthmmodfeat$conv + message(feature) + message("----------") } + names(Im) <- features_all + names(theta) <- features_all + + paraname <- c(colnames(X), c("r", "threshold")) + rownames(para) <- paraname + + return(list( + X = X, + Z = Z, + rt = rt, + para0 = NA, + para = para, + sizefact = sizefact, + sizefact0 = NA, + preci1 = preci1, + conv0 = NA, + conv = conv, + Im0 = NA, + Im = Im, + features_high = NA, + features_all = features_all, + theta = theta, + varcov = varcov, + Uvec = Uvec + )) + } ) diff --git a/R/NBthmDE_feat.R b/R/NBthmDE_feat.R index 587f5e1..7918ecd 100644 --- a/R/NBthmDE_feat.R +++ b/R/NBthmDE_feat.R @@ -1,165 +1,160 @@ fitNBthmDEfeat <- function(Y, probenum, X, Z, sizefact, sizefact0, preci1, threshold_mean, preci2, Lambdati, mapping, cluster_size, - temp_size, rl, rt, sizescalebythreshold, cRandom) { - nmh_sq <- cRandom$nmh_sq - thin_sq <- cRandom$thin_sq - - thetapri <- cRandom$thetapri - nu <- cRandom$nu - lower <- cRandom$lower - upper <- cRandom$upper - iterations <- cRandom$iterations - useprior <- cRandom$useprior - preciu <- cRandom$preciu - - - para_fixmat <- matrix(0, iterations, ncol(X) + 2) - theta_mat <- matrix(0, iterations, max(rt$Lind)) - if (missing(preci1)) { - preci1 <- diag(1, ncol(X)) + temp_size, rl, rt, sizescalebythreshold, cRandom) { + nmh_sq <- cRandom$nmh_sq + thin_sq <- cRandom$thin_sq + + thetapri <- cRandom$thetapri + nu <- cRandom$nu + lower <- cRandom$lower + upper <- cRandom$upper + iterations <- cRandom$iterations + useprior <- cRandom$useprior + preciu <- cRandom$preciu + + para_fixmat <- matrix(0, iterations, ncol(X) + 2) + theta_mat <- matrix(0, iterations, max(rt$Lind)) + if (missing(preci1)) { + preci1 <- diag(1, ncol(X)) + } + + Im <- NA + + conv <- FALSE + dive <- FALSE + + if (sizescalebythreshold) { + sizefact <- sizefact * threshold_mean * probenum + sizefact0 <- sizefact0 * threshold_mean * probenum + threshold_mean <- 1.0 + } else { + threshold_mean <- threshold_mean * probenum + } + + para_fix0 <- para_fix <- c(numeric(ncol(X)), 1, threshold_mean) + + + Sigma <- as.matrix(Lambdati) %*% t(as.matrix(Lambdati)) + + for (iter in seq_len(iterations)) { + Tem <- Sigma[seq_len(temp_size), seq_len(temp_size), drop = FALSE] + + + U <- NBthmDE_uOpt(numeric(rl), X, Z, Y, sizefact0, sizefact, para_fix, preciu, 0)$par + # print(U) + ## Metropolis Hasting + + for (iter_conv in seq_len(5)) { + if (!conv) { + Umat <- NBthmDE_mh( + Tem, U, X, as.matrix(Z), Y, sizefact0, + sizefact, para_fix, nmh_sq[iter] + ) + } else { + Umat <- NBthmDE_mh( + Tem, U, X, as.matrix(Z), Y, sizefact0, + sizefact, para_fix, nmh_sq[iterations] + ) + } + # + ## MLE for covariance + + if (useprior) { + covnll <- NBthm_rcovnlliWp(Umat, Lambdati, mapping, nu = nu, diag(thetapri, rl)) + } else { + covnll <- NBthm_rcovnll(Umat, Lambdati, mapping) + } + + result <- tryCatch( + expr = { + optim(rt$theta, covnll, lower = lower, upper = upper, method = "L-BFGS-B") + }, + error = function(e) { + message(sprintf("`optim` encountered singularity problems. Re-assigning the initial values (%s/5).", iter_conv)) + return(NULL) + } + ) + + if (!is.null(result)) { + break + } } - - Im <- NA - - conv <- FALSE - dive <- FALSE - - if (sizescalebythreshold) { - sizefact <- sizefact * threshold_mean * probenum - sizefact0 <- sizefact0 * threshold_mean * probenum - threshold_mean <- 1.0 - } else { - threshold_mean <- threshold_mean * probenum + + if (is.null(result)) { + return(list( + para_fix = NA, + theta = NA, + Im = NA, + conv = NA, + Uvec = NA + )) } - - para_fix0 <- para_fix <- c(numeric(ncol(X)), 1, threshold_mean) - - + + + theta <- result$par + # print(theta) + theta_mat[iter, ] <- theta + # print(theta) + Lambdati@x[] <- mapping(theta) + Sigma <- as.matrix(Lambdati) %*% t(as.matrix(Lambdati)) - - for (iter in seq_len(iterations)) { - Tem <- Sigma[seq_len(temp_size), seq_len(temp_size), drop = FALSE] - - - U <- NBthmDE_uOpt(numeric(rl), X, Z, Y, sizefact0, sizefact, para_fix, preciu, 0)$par - # print(U) - ## Metropolis Hasting - - for (iter_conv in seq_len(5)) { - if (!conv) { - Umat <- NBthmDE_mh( - Tem, U, X, as.matrix(Z), Y, sizefact0, - sizefact, para_fix, nmh_sq[iter] - ) - } else { - Umat <- NBthmDE_mh( - Tem, U, X, as.matrix(Z), Y, sizefact0, - sizefact, para_fix, nmh_sq[iterations] - ) - } - # print(colMeans(Umat)) - # - ## MLE for covariance - - if (useprior) { - covnll <- NBthm_rcovnlliWp(Umat, Lambdati, mapping, nu = nu, diag(thetapri, rl)) - } else { - covnll <- NBthm_rcovnll(Umat, Lambdati, mapping) - } - - result <- tryCatch( - expr = { - optim(rt$theta, covnll, lower = lower, upper = upper, method = "L-BFGS-B") - }, - error = function(e) { - message(sprintf("`optim` encountered singularity problems. Re-assigning the initial values (%s/5).", iter_conv)) - return(NULL) - } - ) - - if (!is.null(result)) { - break - } - } - - if (is.null(result)) { - return(list( - para_fix = NA, - theta = NA, - Im = NA, - conv = NA, - Uvec = NA - )) - } - - - theta <- result$par - # print(theta) - theta_mat[iter, ] <- theta - # print(theta) - Lambdati@x[] <- mapping(theta) - - Sigma <- as.matrix(Lambdati) %*% t(as.matrix(Lambdati)) - ## MLE for parameters for fixed effects - - if (!conv) { - result <- NBthmDE_fparaOptfeat(X, Z, Y, sizefact0, sizefact, preci1, threshold_mean, preci2, Umat[((seq_len(thin_sq[iter])) * floor(nmh_sq[iter] / thin_sq[iter])), ], para_fix, iter == iterations) - } else { - result <- NBthmDE_fparaOptfeat(X, Z, Y, sizefact0, sizefact, preci1, threshold_mean, preci2, Umat[((seq_len(thin_sq[iterations])) * floor(nmh_sq[iterations] / thin_sq[iterations])), ], para_fix, 1) - } - - - para_fix <- result$par - - para_fixmat[iter, ] <- para_fix - if (conv | (iter == iterations)) { - hes <- result$hes - gr0 <- NBthmDE_gradM( - Y, X, Z, para_fix, Umat[((seq_len(thin_sq[iterations])) * floor(nmh_sq[iterations] / thin_sq[iterations])), ], - sizefact0, sizefact, preci1, preci2, threshold_mean - ) - grt <- plyr::alply(gr0, 2, function(x) x %*% t(x)) - a <- array(unlist(grt), c(ncol(X) + 2, ncol(X) + 2, length(grt))) - grm <- apply(a, seq_len(2), mean) - - Im <- hes - grm - } - - if (conv) break - - - if (sum((para_fix - para_fix0)^2) < 5e-3) { - conv <- TRUE - } - if (mean(diag(as.matrix(Lambdati))) > 19.98) { - dive <- TRUE - } - - # print(iter) - if (dive) { - Im <- NA - break - } - - para_fix0 <- para_fix + ## MLE for parameters for fixed effects + + if (!conv) { + result <- NBthmDE_fparaOptfeat(X, Z, Y, sizefact0, sizefact, preci1, threshold_mean, preci2, Umat[((seq_len(thin_sq[iter])) * floor(nmh_sq[iter] / thin_sq[iter])), ], para_fix, iter == iterations) + } else { + result <- NBthmDE_fparaOptfeat(X, Z, Y, sizefact0, sizefact, preci1, threshold_mean, preci2, Umat[((seq_len(thin_sq[iterations])) * floor(nmh_sq[iterations] / thin_sq[iterations])), ], para_fix, 1) } - Tem <- Sigma[seq_len(temp_size), seq_len(temp_size), drop = FALSE] - Temupper <- Tem - Temupper[lower.tri(Tem)] <- 0 - varcov <- methods::as(Temupper, "sparseMatrix")@x[] - # print(mconv) - message(sprintf("conv = %s", conv)) - message(sprintf("theta = %s", paste0(round(theta, 4), collapse = " "))) - message(sprintf("varcov = %s", paste0(round(varcov, 4), collapse = " "))) - message(sprintf("Iteration = %s", iter)) - - # plot(theta_mat[200:300,1]) - - return(list( - para_fix = para_fix, - theta = theta, - Im = Im, - conv = conv, - varcov = varcov, - Uvec = colMeans(Umat) - )) + + para_fix <- result$par + para_fixmat[iter, ] <- para_fix + if (conv | (iter == iterations)) { + hes <- result$hes + gr0 <- NBthmDE_gradM( + Y, X, Z, para_fix, Umat[((seq_len(thin_sq[iterations])) * floor(nmh_sq[iterations] / thin_sq[iterations])), ], + sizefact0, sizefact, preci1, preci2, threshold_mean + ) + grt <- plyr::alply(gr0, 2, function(x) x %*% t(x)) + a <- array(unlist(grt), c(ncol(X) + 2, ncol(X) + 2, length(grt))) + grm <- apply(a, seq_len(2), mean) + + Im <- hes - grm + } + + if (conv) break + + if (sum((para_fix - para_fix0)^2) < 5e-3) { + conv <- TRUE + } + if (mean(diag(as.matrix(Lambdati))) > 19.98) { + dive <- TRUE + } + + # print(iter) + if (dive) { + Im <- NA + break + } + + para_fix0 <- para_fix + } + Tem <- Sigma[seq_len(temp_size), seq_len(temp_size), drop = FALSE] + Temupper <- Tem + Temupper[lower.tri(Tem)] <- 0 + varcov <- methods::as(Temupper, "sparseMatrix")@x[] + # print(mconv) + message(sprintf("conv = %s", conv)) + message(sprintf("theta = %s", paste0(round(theta, 4), collapse = " "))) + message(sprintf("varcov = %s", paste0(round(varcov, 4), collapse = " "))) + message(sprintf("Iteration = %s", iter)) + + # plot(theta_mat[200:300,1]) + + return(list( + para_fix = para_fix, + theta = theta, + Im = Im, + conv = conv, + varcov = varcov, + Uvec = colMeans(Umat) + )) } diff --git a/R/NBthmDE_rcovnll.R b/R/NBthmDE_rcovnll.R index cbfc516..7a430f8 100644 --- a/R/NBthmDE_rcovnll.R +++ b/R/NBthmDE_rcovnll.R @@ -1,24 +1,23 @@ NBthm_rcovnll <- function(Umat, Lambdati, mapping) { - N <- nrow(Umat) - loglik_fun <- function(theta) { - Lambdati@x[] <- mapping(theta) - Sigma <- as.matrix(Lambdati) %*% t(as.matrix(Lambdati)) - value <- -(N / 2) * determinant(Sigma, logarithm = TRUE)$modulus - 1 / 2 * (sum(apply(t(solve(Sigma, t(Umat))) * Umat, 1, sum))) - return(-value) - } + N <- nrow(Umat) + loglik_fun <- function(theta) { + Lambdati@x[] <- mapping(theta) + Sigma <- as.matrix(Lambdati) %*% t(as.matrix(Lambdati)) + value <- -(N / 2) * determinant(Sigma, logarithm = TRUE)$modulus - 1 / 2 * (sum(apply(t(solve(Sigma, t(Umat))) * Umat, 1, sum))) + return(-value) + } } - NBthm_rcovnlliWp <- function(Umat, Lambdati, mapping, nu, Lambda0) { - N <- nrow(Umat) - d <- ncol(Umat) - loglik_fun <- function(theta) { - Lambdati@x[] <- mapping(theta) - Sigma <- as.matrix(Lambdati) %*% t(as.matrix(Lambdati)) - value <- -((N + nu + d + 1) / 2) * determinant(Sigma, logarithm = TRUE)$modulus - - (1 / 2) * (sum(apply(t(solve(Sigma, t(Umat))) * Umat, 1, sum))) - - (1 / 2) * sum(diag(solve(Sigma, Lambda0))) - return(-value) - } + N <- nrow(Umat) + d <- ncol(Umat) + loglik_fun <- function(theta) { + Lambdati@x[] <- mapping(theta) + Sigma <- as.matrix(Lambdati) %*% t(as.matrix(Lambdati)) + value <- -((N + nu + d + 1) / 2) * determinant(Sigma, logarithm = TRUE)$modulus - + (1 / 2) * (sum(apply(t(solve(Sigma, t(Umat))) * Umat, 1, sum))) - + (1 / 2) * sum(diag(solve(Sigma, Lambda0))) + return(-value) + } } diff --git a/R/PoisBG.R b/R/PoisBG.R index 2646fa2..890f6f8 100644 --- a/R/PoisBG.R +++ b/R/PoisBG.R @@ -14,6 +14,9 @@ #' @importFrom Biobase sampleNames #' @importFrom Biobase featureNames #' +#' @importFrom Rfast rowsums +#' @importFrom Rfast colsums +#' #' @return a valid GeoMx S4 object if split is FALSE #' \itemize{ #' \item sizefact - estimated size factor in phenoData @@ -36,81 +39,147 @@ #' @export #' @docType methods #' @rdname fitPoisBG-methods - setGeneric("fitPoisBG", - signature = c("object"), - function(object, ...) standardGeneric("fitPoisBG") + signature = c("object"), + function(object, ...) standardGeneric("fitPoisBG") ) #' @rdname fitPoisBG-methods #' @aliases fitPoisBG,NanoStringGeoMxSet-method setMethod( - "fitPoisBG", "NanoStringGeoMxSet", - function(object, groupvar = NULL, iterations = 10, tol = 1e-3, size_scale = c("sum", "first"), ...) { - # check on tol - tol <- as.double(tol) - stopifnot(length(tol) == 1) - stopifnot(tol >= 0) - - # extract the negative probes matrix - negdat <- object[which(Biobase::fData(object)$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(negdat) - - if (is.null(groupvar)) { - # fit the model as a single slide - split <- FALSE - } else if (!(groupvar %in% varLabels(object))) { - stop(sprintf("%s is not found in the S4 object.", groupvar)) - } else { - # extract the groupvar - id <- object[[groupvar]] - - if (length(unique(id)) == 1) { - # this is equivalent as fitting the model as a single slide - split <- FALSE - warning(sprintf("`%s` has only one value, %s", groupvar, unique(id))) - } else { - # fit the model for multiple slides - split <- TRUE - } - } - - if (isFALSE(split)) { - # calling the fitPoisBG function when split is FALSE - result <- fitPoisBG( - object = countmat, - iterations = iterations, - tol = tol, - size_scale = size_scale - ) - - object[["sizefact"]] <- result$sizefact[Biobase::sampleNames(object)] - Biobase::fData(object)[["featfact"]] <- NA - Biobase::fData(object)[["featfact"]][match(names(result$featfact), Biobase::featureNames(object), nomatch = 0)] <- result$featfact - } else { - # calling the fitPoisBG_sp function when split is TRUE - result <- fitPoisBG_sp( - object = countmat, - id = id, - iterations = iterations, - tol = tol, - size_scale = size_scale - ) - - # append results to the object - object[["sizefact_sp"]] <- result$sizefact[Biobase::sampleNames(object)] - for (index in unique(result$id)) { - Biobase::fData(object)[[paste0("featfact_", index)]] <- NA - Biobase::fData(object)[[paste0("featfact_", index)]][match(rownames(result$featfact), Biobase::featureNames(object), nomatch = 0)] <- result$featfact[, index] - } - - Biobase::notes(object)$fitPoisBG_sp_var <- groupvar - } - - return(object) + "fitPoisBG", "NanoStringGeoMxSet", + function(object, groupvar = NULL, iterations = 10, tol = 1e-3, size_scale = c("sum", "first"), ...) { + # check on tol + tol <- as.double(tol) + stopifnot(length(tol) == 1) + stopifnot(tol >= 0) + + # extract the negative probes matrix + negdat <- object[which(Biobase::fData(object)$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(negdat) + + if (is.null(groupvar)) { + # fit the model as a single slide + split <- FALSE + } else if (!(groupvar %in% varLabels(object))) { + stop(sprintf("%s is not found in the S4 object.", groupvar)) + } else { + # extract the groupvar + id <- object[[groupvar]] + + if (length(unique(id)) == 1) { + # this is equivalent as fitting the model as a single slide + split <- FALSE + warning(sprintf("`%s` has only one value, %s", groupvar, unique(id))) + } else { + # fit the model for multiple slides + split <- TRUE + } + } + + if (isFALSE(split)) { + # calling the fitPoisBG function when split is FALSE + result <- fitPoisBG( + object = countmat, + iterations = iterations, + tol = tol, + size_scale = size_scale + ) + + object[["sizefact"]] <- result$sizefact[Biobase::sampleNames(object)] + Biobase::fData(object)[["featfact"]] <- NA + Biobase::fData(object)[["featfact"]][match(names(result$featfact), Biobase::featureNames(object), nomatch = 0)] <- result$featfact + } else { + # calling the fitPoisBG_sp function when split is TRUE + result <- fitPoisBG_sp( + object <- countmat, + id <- id, + iterations <- iterations, + tol <- tol, + size_scale <- size_scale + ) + + # append results to the object + object[["sizefact_sp"]] <- result$sizefact[Biobase::sampleNames(object)] + for (index in unique(result$id)) { + Biobase::fData(object)[[paste0("featfact_", index)]] <- NA + Biobase::fData(object)[[paste0("featfact_", index)]][match(rownames(result$featfact), Biobase::featureNames(object), nomatch = 0)] <- result$featfact[, index] + } + + Biobase::notes(object)$fitPoisBG_sp_var <- groupvar } + + return(object) + } ) +fitPoisBG_function = function(object, iterations = 10, tol = 1e-3, size_scale = c("sum", "first")) { + size_scale <- match.arg(size_scale) + n_feature <- NROW(object) + n_sample <- NCOL(object) + if (sum(is.na(object)) ==0){ind_na = NA} + else{ind_na <- which(is.na(object), arr.ind = TRUE)} + + featfact0 <- numeric(n_feature) + sizefact <- colMeans(object) + + if (size_scale == "first") { + scale_fac <- sizefact[1] + } else if (size_scale == "sum") { + scale_fac <- sum(sizefact) + } + + sizefact <- sizefact / scale_fac + sizefact0 <- sizefact + sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) + if (is.na(ind_na)) {} + else {sizefact_mat[ind_na] <- NA} + + object_rowsum <- rowSums(object, na.rm = TRUE) + object_colsum <- colSums(object, na.rm = TRUE) + for (iter in seq_len(iterations)) { + if (is.na(ind_na) ){} + else {sizefact_mat[ind_na] <- 0} + + featfact <- object_rowsum / Rfast::rowsums(sizefact_mat) + featfact_mat <- matrix(rep(featfact, n_sample), n_feature, n_sample) + if (is.na(ind_na) ){} + else {featfact_mat[ind_na] <- NA} + + sizefact <- object_colsum / Rfast::colsums(featfact_mat) + names(sizefact) = colnames(object) + if (size_scale == "first") { + scale_fac <- sizefact[1] + } else if (size_scale == "sum") { + scale_fac <- sum(sizefact) + } + + sizefact <- sizefact / scale_fac + + sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) + if (is.na(ind_na) ){} + else {sizefact_mat[ind_na] <- NA} + + message(sprintf( + "Iteration = %s, squared error = %e", + iter, + sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) + )) + if (sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) < tol) { + break + } + + sizefact0 <- sizefact + featfact0 <- featfact + } + message("Model converged.") + + return(list( + sizefact = sizefact, + featfact = featfact, + countmat = object + )) +} #' Estimate Poisson background model #' #' Estimate Poisson background model: @@ -128,66 +197,16 @@ setMethod( #' } #' #' @rdname fitPoisBG-methods -#' @aliases fitPoisBG,matrix-method +#' @export +#' +#' setMethod( - "fitPoisBG", "matrix", - function(object, iterations = 10, tol = 1e-3, size_scale = c("sum", "first")) { - size_scale <- match.arg(size_scale) - n_feature <- NROW(object) - n_sample <- NCOL(object) - ind_na <- which(is.na(object), arr.ind = TRUE) - featfact0 <- numeric(n_feature) - sizefact <- apply(object, 2, mean, na.rm = TRUE) - - if (size_scale == "first") { - scale_fac <- sizefact[1] - } else if (size_scale == "sum") { - scale_fac <- sum(sizefact) - } - - sizefact <- sizefact / scale_fac - sizefact0 <- sizefact - sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) - sizefact_mat[ind_na] <- NA - - for (iter in seq_len(iterations)) { - featfact <- apply(object, 1, sum, na.rm = TRUE) / apply(sizefact_mat, 1, sum, na.rm = TRUE) - featfact_mat <- matrix(rep(featfact, n_sample), n_feature, n_sample) - featfact_mat[ind_na] <- NA - - sizefact <- apply(object, 2, sum, na.rm = TRUE) / apply(featfact_mat, 2, sum, na.rm = TRUE) - - if (size_scale == "first") { - scale_fac <- sizefact[1] - } else if (size_scale == "sum") { - scale_fac <- sum(sizefact) - } - - sizefact <- sizefact / scale_fac - - sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) - sizefact_mat[ind_na] <- NA - - message(sprintf( - "Iteration = %s, squared error = %e", - iter, - sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) - )) - if (sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) < tol) { - break - } - - sizefact0 <- sizefact - featfact0 <- featfact - } - message("Model converged.") - - return(list( - sizefact = sizefact, - featfact = featfact, - countmat = object - )) - } + "fitPoisBG", "dgCMatrix",fitPoisBG_function +) +#' @rdname fitPoisBG-methods +#' @exportMethod +setMethod( + "fitPoisBG", "matrix",fitPoisBG_function ) @@ -216,82 +235,86 @@ setMethod( #' @rdname fitPoisBG_sp-methods #' setGeneric("fitPoisBG_sp", - signature = c("object"), - function(object, ...) standardGeneric("fitPoisBG_sp") + signature = c("object"), + function(object, ...) standardGeneric("fitPoisBG_sp") ) #' @rdname fitPoisBG_sp-methods #' @aliases fitPoisBG_sp,matrix-method setMethod( - "fitPoisBG_sp", "matrix", - function(object, id, iterations = 10, tol = 1e-3, size_scale = c("sum", "first")) { - size_scale <- match.arg(size_scale) - - uniid <- unique(as.character(id)) - n_feature <- NROW(object) - n_sample <- NCOL(object) - ind_na <- which(is.na(object), arr.ind = TRUE) - - sizefact <- apply(object, 2, mean, na.rm = TRUE) - - if (size_scale == "first") { - scale_fac <- sizefact[1] - } else if (size_scale == "sum") { - scale_fac <- sum(sizefact) - } - - - sizefact <- sizefact / scale_fac - - sizefact0 <- sizefact - sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) - sizefact_mat[ind_na] <- NA - featfact0 <- matrix(0, n_feature, length(uniid)) - for (iter in seq_len(iterations)) { - featfact <- sapply(uniid, function(x) { - apply(object[, x == id, drop = FALSE], 1, sum, na.rm = TRUE) / - apply(sizefact_mat[, x == id, drop = FALSE], 1, sum, na.rm = TRUE) - }) - - featfact_mat <- featfact[, id] - featfact_mat[ind_na] <- NA - - sizefact <- apply(object, 2, sum, na.rm = TRUE) / apply(featfact_mat, 2, sum, na.rm = TRUE) - - if (size_scale == "first") { - scale_fac <- sizefact[1] - } else if (size_scale == "sum") { - scale_fac <- sum(sizefact) - } - - sizefact <- sizefact / scale_fac - - - sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) - sizefact_mat[ind_na] <- NA - - message(sprintf( - "Iteration = %s, squared error = %e", - iter, - sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) - )) - - if (sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) < tol) { - break - } - - sizefact0 <- sizefact - featfact0 <- featfact - } - message("Model converged.") + "fitPoisBG_sp", "matrix", + function(object, id, iterations = 10, tol = 1e-3, size_scale = c("sum", "first")) { + size_scale <- match.arg(size_scale) + + uniid <- unique(as.character(id)) + n_feature <- NROW(object) + n_sample <- NCOL(object) + ind_na <- which(is.na(object), arr.ind = TRUE) + + sizefact <- Rfast::colmeans(object, 2) + + if (size_scale == "first") { + scale_fac <- sizefact[1] + } else if (size_scale == "sum") { + scale_fac <- sum(sizefact) + } - return(list( - sizefact = sizefact, - featfact = featfact, - countmat = object, - id = id - )) + sizefact <- sizefact / scale_fac + + sizefact0 <- sizefact + sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) + sizefact_mat[ind_na] <- NA + featfact0 <- matrix(0, n_feature, length(uniid)) + tmp_obj = object + tmp_obj[ind_na] = 0 + + tmp_sizefact_mat = sizefact_mat + tmp_sizefact_mat[ind_na] = 0 + for (iter in seq_len(iterations)) { + featfact <- sapply(uniid, function(x) { + rowSums(tmp_obj[, x == id, drop = FALSE], na.rm=TRUE) / + rowSums(sizefact_mat[, x == id, drop = FALSE], na.rm=TRUE) + }) + + featfact_mat <- featfact[, id] + featfact_mat[ind_na] <- NA + tmp_featfact_mat = featfact_mat + tmp_featfact_mat[ind_na] = 0 + + sizefact <- colSums(tmp_obj, na.rm=TRUE) / colSums(tmp_featfact_mat, na.rm=TRUE) + if (size_scale == "first") { + scale_fac <- sizefact[1] + } else if (size_scale == "sum") { + scale_fac <- sum(sizefact) + } + + sizefact <- sizefact / scale_fac + + sizefact_mat <- matrix(rep(sizefact, n_feature), n_feature, n_sample, byrow = TRUE) + sizefact_mat[ind_na] <- NA + + message(sprintf( + "Iteration = %s, squared error = %e", + iter, + sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) + )) + + if (sum((sizefact - sizefact0)^2) + sum((featfact - featfact0)^2) < tol) { + break + } + + sizefact0 <- sizefact + featfact0 <- featfact } + message("Model converged.") + + return(list( + sizefact = sizefact, + featfact = featfact, + countmat = object, + id = id + )) + } ) @@ -338,104 +361,103 @@ setMethod( setGeneric("diagPoisBG", - signature = c("object"), - function(object, ...) standardGeneric("diagPoisBG") + signature = c("object"), + function(object, ...) standardGeneric("diagPoisBG") ) #' @rdname diagPoisBG-methods #' @aliases diagPoisBG,NanoStringGeoMxSet-method setMethod( - "diagPoisBG", "NanoStringGeoMxSet", - function(object, split = FALSE, padj = FALSE, padj_method = "BH", cutoff = 1e-6, generate_ppplot = TRUE) { - negdat <- object[which(Biobase::fData(object)$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(negdat) - pDat <- Biobase::pData(negdat) - fDat <- Biobase::fData(negdat) - - if (isFALSE(split)) { - if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { - stop("Please run `fitPoisBG` first. If you run `fitPoisBG` before, please specify `split = TRUE`.") - } - sizefact <- setNames(pDat[["sizefact"]], rownames(pDat)) - featfact <- setNames(fDat[["featfact"]], rownames(fDat)) - - BGmod <- list( - sizefact = sizefact, - featfact = featfact, - countmat = countmat - ) - } else { - if (!any(c("sizefact_sp" %in% colnames(pDat), "featfact_" %in% colnames(fDat)))) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } - sizefact <- setNames(pDat[["sizefact_sp"]], rownames(pDat)) - featfact <- fDat[, grep("featfact_", colnames(fDat))] - colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) - idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] - id <- pDat[[idvar]] - message(sprintf("The results are based on stored `groupvar`, %s", idvar)) - - BGmod <- list( - sizefact = sizefact, - featfact = as.matrix(featfact), - countmat = countmat, - id = id - ) - } - - - result <- diagPoisBG(BGmod, - padj = padj, - padj_method = padj_method, - cutoff = cutoff, - generate_ppplot = generate_ppplot - ) - - # add lowtail matrix - lowtail_mat <- matrix(NA, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - lowtail_mat[rownames(result$uptail_prob), colnames(result$uptail_prob)] <- result$uptail_prob - Biobase::assayDataElement(object, "lowtail_prob") <- lowtail_mat - - # add uptail matrix - uptail_mat <- matrix(NA, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - uptail_mat[rownames(result$uptail_prob), colnames(result$uptail_prob)] <- result$uptail_prob - Biobase::assayDataElement(object, "uptail_prob") <- uptail_mat - - # add disper parameter - if (isTRUE(split)) { - Biobase::notes(object)$disper_sp <- result$disper - } else { - Biobase::notes(object)$disper <- result$disper - } - - # add upper tail outlier - low_outlier_mat <- matrix(0, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - for (i in seq_len(nrow(result$outlier$low_outlier))) { - low_outlier_mat[rownames(result$outlier$low_outlier)[i], result$outlier$low_outlier[i, "col"]] <- 1 - } - Biobase::assayDataElement(object, "low_outlier") <- low_outlier_mat - - # add lower tail outlier - up_outlier_mat <- matrix(0, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - for (i in seq_len(nrow(result$outlier$up_outlier))) { - up_outlier_mat[rownames(result$outlier$up_outlier)[i], result$outlier$up_outlier[i, "col"]] <- 1 - } - Biobase::assayDataElement(object, "up_outlier") <- up_outlier_mat - - return(object) + "diagPoisBG", "NanoStringGeoMxSet", + function(object, split = FALSE, padj = FALSE, padj_method = "BH", cutoff = 1e-6, generate_ppplot = TRUE) { + negdat <- object[which(Biobase::fData(object)$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(negdat) + pDat <- Biobase::pData(negdat) + fDat <- Biobase::fData(negdat) + + if (isFALSE(split)) { + if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { + stop("Please run `fitPoisBG` first. If you run `fitPoisBG` before, please specify `split = TRUE`.") + } + sizefact <- setNames(pDat[["sizefact"]], rownames(pDat)) + featfact <- setNames(fDat[["featfact"]], rownames(fDat)) + + BGmod <- list( + sizefact = sizefact, + featfact = featfact, + countmat = countmat + ) + } else { + if (!any(c("sizefact_sp" %in% colnames(pDat), "featfact_" %in% colnames(fDat)))) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } + sizefact <- setNames(pDat[["sizefact_sp"]], rownames(pDat)) + featfact <- fDat[, grep("featfact_", colnames(fDat))] + colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) + idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] + id <- pDat[[idvar]] + message(sprintf("The results are based on stored `groupvar`, %s", idvar)) + + BGmod <- list( + sizefact = sizefact, + featfact = as.matrix(featfact), + countmat = countmat, + id = id + ) + } + + result <- diagPoisBG(BGmod, + padj = padj, + padj_method = padj_method, + cutoff = cutoff, + generate_ppplot = generate_ppplot + ) + + # add lowtail matrix + lowtail_mat <- matrix(NA, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + lowtail_mat[rownames(result$uptail_prob), colnames(result$uptail_prob)] <- result$uptail_prob + Biobase::assayDataElement(object, "lowtail_prob") <- lowtail_mat + + # add uptail matrix + uptail_mat <- matrix(NA, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + uptail_mat[rownames(result$uptail_prob), colnames(result$uptail_prob)] <- result$uptail_prob + Biobase::assayDataElement(object, "uptail_prob") <- uptail_mat + + # add disper parameter + if (isTRUE(split)) { + Biobase::notes(object)$disper_sp <- result$disper + } else { + Biobase::notes(object)$disper <- result$disper + } + + # add upper tail outlier + low_outlier_mat <- matrix(0, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + for (i in seq_len(nrow(result$outlier$low_outlier))) { + low_outlier_mat[rownames(result$outlier$low_outlier)[i], result$outlier$low_outlier[i, "col"]] <- 1 } + Biobase::assayDataElement(object, "low_outlier") <- low_outlier_mat + + # add lower tail outlier + up_outlier_mat <- matrix(0, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + for (i in seq_len(nrow(result$outlier$up_outlier))) { + up_outlier_mat[rownames(result$outlier$up_outlier)[i], result$outlier$up_outlier[i, "col"]] <- 1 + } + Biobase::assayDataElement(object, "up_outlier") <- up_outlier_mat + + return(object) + } ) #' Perform diagnosis on Poisson background model @@ -462,60 +484,67 @@ setMethod( #' @aliases diagPoisBG,list-method setMethod( - "diagPoisBG", "list", - function(object, padj = FALSE, padj_method = "BH", cutoff = 1e-6, generate_ppplot = TRUE) { - countmat <- object$countmat - if (NCOL(object$featfact) == 1) { - countmat_expected <- (object$featfact %*% t(object$sizefact)) - } else { - countmat_expected <- sweep(object$featfact[, object$id], 2, object$sizefact, FUN = "*") - } - - countmat <- as.matrix(countmat) - - lowtail_prob1 <- ppois(q = countmat, lambda = countmat_expected) - lowtail_prob2 <- ppois(q = countmat - 1, lambda = countmat_expected) - - lowtail_prob <- (lowtail_prob1 + lowtail_prob2) / 2 - - uptail_prob <- 1 - lowtail_prob - - # simualte data (do it only once) - countmat_simu <- t(apply(countmat_expected, 1, function(x) rpois(rep(1, ncol(countmat)), lambda = x))) - lowtail_prob1_simu <- ppois(q = countmat_simu, lambda = countmat_expected) - lowtail_prob2_simu <- ppois(q = countmat_simu - 1, lambda = countmat_expected) - lowtail_prob_simu <- (lowtail_prob1_simu + lowtail_prob2_simu) / 2 - - if (generate_ppplot) { - y <- sort(lowtail_prob, na.last = TRUE) - y_simu <- sort(lowtail_prob_simu, na.last = TRUE) - plot(y_simu, y, ylim = c(0, 1), xlab = "Empircal CDF from simulated data", ylab = "Empircal CDF", main = "Poisson model") - graphics::abline(a = 0, b = 1) - } - - - disper <- mean((countmat - countmat_expected)^2 / countmat_expected, na.rm = TRUE) - - if (padj) { - lowtail_prob <- matrix(p.adjust(lowtail_prob, method = padj_method), nrow = nrow(lowtail_prob), ncol = ncol(lowtail_prob)) - uptail_prob <- matrix(p.adjust(uptail_prob, method = padj_method), nrow = nrow(uptail_prob), ncol = ncol(uptail_prob)) - } - - - - low_outlier <- which(lowtail_prob < cutoff, arr.ind = TRUE) - up_outlier <- which(uptail_prob < cutoff, arr.ind = TRUE) - - return(list( - lowtail_prob = lowtail_prob, - uptail_prob = uptail_prob, - disper = disper, - outlier = list( - low_outlier = low_outlier, - up_outlier = up_outlier - ) - )) + "diagPoisBG", "list", + function(object, padj = FALSE, padj_method = "BH", cutoff = 1e-6, generate_ppplot = TRUE) { + countmat <- object$countmat + if (NCOL(object$featfact) == 1) { + countmat_expected <- (object$featfact %*% t(object$sizefact)) + } else { + countmat_expected <- sweep(object$featfact[, object$id], 2, object$sizefact, FUN = "*") + } + + countmat <- as.matrix(countmat) + + lowtail_prob1 <- ppois(q = countmat, lambda = countmat_expected) + lowtail_prob2 <- ppois(q = countmat - 1, lambda = countmat_expected) + + lowtail_prob <- (lowtail_prob1 + lowtail_prob2) / 2 + + uptail_prob <- 1 - lowtail_prob + + # simualte data (do it only once) + countmat_simu <- t(apply(countmat_expected, 1, function(x) rpois(rep(1, ncol(countmat)), lambda = x))) + lowtail_prob1_simu <- ppois(q = countmat_simu, lambda = countmat_expected) + lowtail_prob2_simu <- ppois(q = countmat_simu - 1, lambda = countmat_expected) + lowtail_prob_simu <- (lowtail_prob1_simu + lowtail_prob2_simu) / 2 + + if (generate_ppplot) { + y <- sort(lowtail_prob, na.last = TRUE) + + y = y[!is.na(y)] + y = y[!is.infinite(y)] + + y_simu <- sort(lowtail_prob_simu, na.last = TRUE) + + y_simu = y_simu[!is.na(y_simu)] + y_simu = y_simu[!is.infinite(y_simu)] + + plot(y_simu, y, ylim = c(0, 1), xlab = "Empircal CDF from simulated data", ylab = "Empircal CDF", main = "Poisson model") + graphics::abline(a = 0, b = 1) } + + disper <- mean((countmat - countmat_expected)^2 / countmat_expected, na.rm = TRUE) + + + if (padj) { + lowtail_prob <- matrix(p.adjust(lowtail_prob, method = padj_method), nrow = nrow(lowtail_prob), ncol = ncol(lowtail_prob)) + uptail_prob <- matrix(p.adjust(uptail_prob, method = padj_method), nrow = nrow(uptail_prob), ncol = ncol(uptail_prob)) + } + + + low_outlier <- which(lowtail_prob < cutoff, arr.ind = TRUE) + up_outlier <- which(uptail_prob < cutoff, arr.ind = TRUE) + + return(list( + lowtail_prob = lowtail_prob, + uptail_prob = uptail_prob, + disper = disper, + outlier = list( + low_outlier = low_outlier, + up_outlier = up_outlier + ) + )) + } ) #' Compute Quantile Range @@ -556,79 +585,79 @@ setMethod( #' @rdname QuanRange-methods setGeneric("QuanRange", - signature = c("object"), - function(object, ...) standardGeneric("QuanRange") + signature = c("object"), + function(object, ...) standardGeneric("QuanRange") ) #' @rdname QuanRange-methods #' @aliases QuanRange,NanoStringGeoMxSet-method setMethod( - "QuanRange", "NanoStringGeoMxSet", - function(object, split = FALSE, probs, removeoutlier = FALSE, ...) { - fDat <- Biobase::fData(object) - pDat <- Biobase::pData(object) - # get the positive probes - - posdat <- object[-which(fDat$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(posdat) - - # get the negative probes - negdat <- object[which(fDat$CodeClass == "Negative"), ] - pDatNeg <- Biobase::pData(negdat) - fDatNeg <- Biobase::fData(negdat) - - if (isFALSE(split)) { - if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { - stop("Please run `fitPoisBG` first. If you run `fitPoisBG` before, please specify `split = TRUE`.") - } - sizefact <- setNames(pDatNeg[["sizefact"]], rownames(pDatNeg)) - featfact <- setNames(fDatNeg[["featfact"]], rownames(fDatNeg)) - - BGmod <- list( - sizefact = sizefact, - featfact = featfact, - countmat = countmat - ) - } else { - if (!any(c("sizefact_sp" %in% colnames(pDatNeg), "featfact_" %in% colnames(fDatNeg)))) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } - sizefact <- setNames(pDatNeg[["sizefact_sp"]], rownames(pDatNeg)) - featfact <- fDatNeg[, grep("featfact_", colnames(fDatNeg))] - colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) - idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] - id <- pDat[[idvar]] - message(sprintf("The results are based on stored `groupvar`, %s", idvar)) - - BGmod <- list( - sizefact = sizefact, - featfact = as.matrix(featfact), - countmat = countmat, - id = id - ) - } - - # calculate probenum for the dataset - if ("probenum" %in% fvarLabels(posdat)) { - probenum <- fData(posdat)[["probenum"]] - } else { - stop("No `probenum` is found. Run `aggreprobe` first.") - } - names(probenum) <- rownames(fData(posdat)) - - result <- QuanRange( - object = countmat, - probenum = probenum, - BGmod = BGmod, - probs = probs, - removeoutlier = removeoutlier - ) - - for (prob in as.character(probs)) { - object[[prob]] <- result[, prob] - } - return(object) + "QuanRange", "NanoStringGeoMxSet", + function(object, split = FALSE, probs, removeoutlier = FALSE, ...) { + fDat <- Biobase::fData(object) + pDat <- Biobase::pData(object) + # get the positive probes + + posdat <- object[-which(fDat$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(posdat) + + # get the negative probes + negdat <- object[which(fDat$CodeClass == "Negative"), ] + pDatNeg <- Biobase::pData(negdat) + fDatNeg <- Biobase::fData(negdat) + + if (isFALSE(split)) { + if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { + stop("Please run `fitPoisBG` first. If you run `fitPoisBG` before, please specify `split = TRUE`.") + } + sizefact <- setNames(pDatNeg[["sizefact"]], rownames(pDatNeg)) + featfact <- setNames(fDatNeg[["featfact"]], rownames(fDatNeg)) + + BGmod <- list( + sizefact = sizefact, + featfact = featfact, + countmat = countmat + ) + } else { + if (!any(c("sizefact_sp" %in% colnames(pDatNeg), "featfact_" %in% colnames(fDatNeg)))) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } + sizefact <- setNames(pDatNeg[["sizefact_sp"]], rownames(pDatNeg)) + featfact <- fDatNeg[, grep("featfact_", colnames(fDatNeg))] + colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) + idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] + id <- pDat[[idvar]] + message(sprintf("The results are based on stored `groupvar`, %s", idvar)) + + BGmod <- list( + sizefact = sizefact, + featfact = as.matrix(featfact), + countmat = countmat, + id = id + ) + } + + # calculate probenum for the dataset + if ("probenum" %in% fvarLabels(posdat)) { + probenum <- fData(posdat)[["probenum"]] + } else { + stop("No `probenum` is found. Run `aggreprobe` first.") } + names(probenum) <- rownames(fData(posdat)) + + result <- QuanRange( + object = countmat, + probenum = probenum, + BGmod = BGmod, + probs = probs, + removeoutlier = removeoutlier + ) + + for (prob in as.character(probs)) { + object[[prob]] <- result[, prob] + } + return(object) + } ) @@ -651,48 +680,49 @@ setMethod( #' @aliases QuanRange,matrix-method setMethod( - "QuanRange", "matrix", - function(object, probenum, BGmod, probs, removeoutlier = FALSE) { - if (NCOL(BGmod$featfact) == 1) { - if (removeoutlier == TRUE) { - boxobj <- graphics::boxplot(BGmod$featfact, plot = FALSE) - - if (length(boxobj$out) > 0) { - featfact <- BGmod$featfact[-which(BGmod$featfact %in% boxobj$out)] - } else { - featfact <- BGmod$featfact - } - message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) - } else { - featfact <- BGmod$featfact - } - - back <- mean(featfact) * BGmod$sizefact + "QuanRange", "matrix", + function(object, probenum, BGmod, probs, removeoutlier = FALSE) { + if (NCOL(BGmod$featfact) == 1) { + if (removeoutlier == TRUE) { + boxobj <- graphics::boxplot(BGmod$featfact, plot = FALSE) + + if (length(boxobj$out) > 0) { + featfact <- BGmod$featfact[-which(BGmod$featfact %in% boxobj$out)] } else { - if (removeoutlier == TRUE) { - featfact <- apply(BGmod$featfact, 2, function(x) { - boxobj <- graphics::boxplot(x, plot = FALSE) - message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) - x[which(x %in% boxobj$out)] <- NA - x - }) - } else { - featfact <- BGmod$featfact - } - - back <- colMeans(featfact[, BGmod$id], na.rm = TRUE) * BGmod$sizefact + featfact <- BGmod$featfact } - - - - - object <- sweep(object, 1, probenum, FUN = "/") - - quan <- sapply(probs, function(y) apply(object, 2, function(x) quantile(x, probs = y))) - - colnames(quan) <- probs - quanrange <- sweep(quan, 1, back, FUN = "-") - - return(quanrange) + message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) + } else { + featfact <- BGmod$featfact + } + + back <- mean(featfact) * BGmod$sizefact + } else { + if (removeoutlier == TRUE) { + featfact <- apply(BGmod$featfact, 2, function(x) { + boxobj <- graphics::boxplot(x, plot = FALSE) + message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) + x[which(x %in% boxobj$out)] <- NA + x + }) + } else { + featfact <- BGmod$featfact + } + + back <- colMeans(featfact[, BGmod$id], na.rm = TRUE) * BGmod$sizefact } + + + + + object <- sweep(object, 1, probenum, FUN = "/") + + quan <- sapply(probs, function(y) apply(object, 2, function(x) quantile(x, probs = y))) + + colnames(quan) <- probs + quanrange <- sweep(quan, 1, back, FUN = "-") + + return(quanrange) + } ) + diff --git a/R/PoisthNorm.R b/R/PoisthNorm.R index 1c752f6..3a60399 100644 --- a/R/PoisthNorm.R +++ b/R/PoisthNorm.R @@ -118,302 +118,297 @@ #' @rdname fitPoisthNorm-methods setGeneric("fitPoisthNorm", - signature = c("object"), - function(object, ...) standardGeneric("fitPoisthNorm") + signature = c("object"), + function(object, ...) standardGeneric("fitPoisthNorm") ) #' @rdname fitPoisthNorm-methods #' @aliases fitPoisthNorm,NanoStringGeoMxSet-method setMethod( - "fitPoisthNorm", "NanoStringGeoMxSet", - function(object, split = FALSE, ROIs_high = NULL, features_high = NULL, - features_all = NULL, sizefact_start = NULL, sizefact_BG = NULL, - threshold_mean = NULL, preci2=10000, iterations = 2, prior_type = c("contrast", "equal"), - sizefactrec = TRUE, size_scale = c("sum", "first"), sizescalebythreshold = FALSE, - covrob = FALSE, preci1con = 1 / 25, cutoff = 15, confac = 1, calhes = FALSE) { - # calculate backmean - # setting default values for sizefact_BG - fDat <- Biobase::fData(object) - fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] - - # only calculate backmean if any of the three params are missing - if (any(c(is.null(sizefact_BG), is.null(sizefact_start), is.null(ROIs_high), is.null(threshold_mean)))) { - if (isFALSE(split)) { - # single slide - if (!("sizefact" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first.") - } else { - # calculate the backmean for WTA or CTA data - thmean <- mean(fDatNeg[["featfact"]]) - } - } else { - # multiple slides - if (!("sizefact_sp" %in% varLabels(object))) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } else { - # calculate the backmean for WTA or CTA data - thmean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] - } - } - } - - - - # setting default value for ROIs_high - if (is.null(ROIs_high)) { - if (!("sizefact_fitNBth" %in% varLabels(object))) { - stop("Please run `fitNBth` first.") - } else { - ROIs_high <- Biobase::sampleNames(object)[which((quantile(fData(object)[["para"]][, 1], - probs = 0.90, na.rm = TRUE - ) - notes(object)[["threshold"]]) * object$sizefact_fitNBth > 2)] - } - } - - object_high <- object[, ROIs_high] - - fDat <- Biobase::fData(object_high) - pDat <- Biobase::pData(object_high) - - posdat <- object_high[-which(fDat$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(posdat) - - # calculate probenum for the dataset - if ("probenum" %in% fvarLabels(posdat)) { - probenum <- fData(posdat)[["probenum"]] + "fitPoisthNorm", "NanoStringGeoMxSet", + function(object, split = FALSE, ROIs_high = NULL, features_high = NULL, + features_all = NULL, sizefact_start = NULL, sizefact_BG = NULL, + threshold_mean = NULL, preci2=10000, iterations = 2, prior_type = c("contrast", "equal"), + sizefactrec = TRUE, size_scale = c("sum", "first"), sizescalebythreshold = FALSE, + covrob = FALSE, preci1con = 1 / 25, cutoff = 15, confac = 1, calhes = FALSE) { + # calculate backmean + # setting default values for sizefact_BG + fDat <- Biobase::fData(object) + fDatNeg <- fDat[which(fDat$CodeClass == "Negative"), ] + + # only calculate backmean if any of the three params are missing + if (any(c(is.null(sizefact_BG), is.null(sizefact_start), is.null(ROIs_high), is.null(threshold_mean)))) { + if (isFALSE(split)) { + # single slide + if (!("sizefact" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first.") } else { - stop("No `probenum` is found. Run `aggreprobe` first.") - } - names(probenum) <- rownames(fData(posdat)) - - # setting default value for sizefact_BG - if (is.null(sizefact_BG)) { - if (isFALSE(split)) { - # single slide - sizefact_BG <- pDat[["sizefact"]] - } else { - # multiple slides - sizefact_BG <- pDat[["sizefact_sp"]] - } - } - - - # setting default value for sizefact_start - if (is.null(sizefact_start)) { - if (!("sizefact_fitNBth" %in% colnames(pDat))) { - stop("Please run `fitNBth` first.") - } else { - sizefact_start <- pDat[["sizefact_fitNBth"]] - } + # calculate the backmean for WTA or CTA data + thmean <- mean(fDatNeg[["featfact"]]) } - - - # setting default value for features_all - if (is.null(features_all)) { - gene_sum <- rowSums(countmat) - - if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { - features_all <- rownames(countmat) - } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { - features_all <- rownames(countmat) - } else { - stop("No information is found to determine the data type (CTA or WTA).") - } - } - - # setting default value for sizefact_start - if (is.null(threshold_mean)) { - threshold_mean <- thmean - } - - # setting default value for features_high - if (is.null(features_high)) { - gene_sum <- rowSums(countmat) - - if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { - features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) - features_high <- sort(sample(features_high, 1500)) - } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { - if (any(grepl("scores", fvarLabels(object)))) { - if (split == TRUE) { - sc1_scores <- fData(object)[-which(fData(object)$Negative), grepl("scores_", fvarLabels(object))] - rownames(sc1_scores) <- fData(object)[-which(fData(object)$Negative), "TargetName"] - features_high <- apply(sc1_scores, 2, function(x) { - ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) - }) - features_high <- names(which(apply(features_high, 1, all))) - } else { - sc1_scores <- fData(object)[-which(fData(object)$Negative), "scores"] - names(sc1_scores) <- fData(object)[-which(fData(object)$Negative), "TargetName"] - features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) - features_high <- names(which(features_high)) - } - } else { - stop("Please run score test first using `BGScoreTest`.") - } - } else { - stop("No information is found to determine the data type (CTA or WTA).") - } + } else { + # multiple slides + if (!("sizefact_sp" %in% varLabels(object))) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } else { + # calculate the backmean for WTA or CTA data + thmean <- colMeans(fDatNeg[, grep("featfact_", fvarLabels(object))])[1] } - - - if (isFALSE(split)) { - result <- fitPoisthNorm( - object = countmat, - probenum = probenum, - features_high = features_high, - features_all = features_all, - sizefact_start = sizefact_start, - sizefact_BG = sizefact_BG, - threshold_mean = threshold_mean, - preci2 = preci2, - iterations = iterations, - prior_type = prior_type, - sizefactrec = sizefactrec, - size_scale = size_scale, - sizescalebythreshold = sizescalebythreshold, - covrob = covrob, - preci1con = preci1con, - cutoff = cutoff, - confac = confac, - calhes = calhes - ) - - # para0 - Biobase::fData(object)[["para0_norm"]] <- matrix(NA, - nrow = nrow(object), ncol = nrow(result$para0), - dimnames = list(Biobase::featureNames(object), paste0("var", seq_len((nrow(result$para0))))) - ) - Biobase::fData(object)[["para0_norm"]][colnames(result$para0), ] <- t(result$para0) - - # para - Biobase::fData(object)[["para_norm"]] <- matrix(NA, - nrow = nrow(object), ncol = nrow(result$para), - dimnames = list(Biobase::featureNames(object), paste0("var", seq_len((nrow(result$para))))) - ) - Biobase::fData(object)[["para_norm"]][colnames(result$para), ] <- t(result$para) - - # normmat0 - normmat0_mat <- matrix(NA, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - normmat0_mat[colnames(result$normmat0), ROIs_high] <- t(result$normmat0) - Biobase::assayDataElement(object, "normmat0") <- normmat0_mat - - # normmat - normmat_mat <- matrix(NA, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - normmat_mat[colnames(result$normmat), ROIs_high] <- t(result$normmat) - Biobase::assayDataElement(object, "normmat") <- normmat_mat - - # sizefact - Biobase::pData(object)[ROIs_high, "sizefact_norm"] <- result$sizefact - # sizefac0 - Biobase::pData(object)[ROIs_high, "sizefact0_norm"] <- result$sizefact0 - - # preci1 - Biobase::notes(object)$preci1_norm <- result$preci1 - - # skipping appending Im0 and Im from result for now. - - # conv0 - Biobase::fData(object)[features_high, "conv0"] <- result$conv0 - # conv - Biobase::fData(object)[features_all, "conv"] <- result$conv - - # features_high - Biobase::fData(object)[features_high, "features_high"] <- 1 - # features_all - Biobase::fData(object)[features_all, "features_all"] <- 1 + } + } + + # setting default value for ROIs_high + if (is.null(ROIs_high)) { + if (!("sizefact_fitNBth" %in% varLabels(object))) { + stop("Please run `fitNBth` first.") + } else { + ROIs_high <- Biobase::sampleNames(object)[which((quantile(fData(object)[["para"]][, 1], + probs = 0.90, na.rm = TRUE + ) - notes(object)[["threshold"]]) * object$sizefact_fitNBth > 2)] + } + } + + object_high <- object[, ROIs_high] + + fDat <- Biobase::fData(object_high) + pDat <- Biobase::pData(object_high) + + posdat <- object_high[-which(fDat$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(posdat) + + # calculate probenum for the dataset + if ("probenum" %in% fvarLabels(posdat)) { + probenum <- fData(posdat)[["probenum"]] + } else { + stop("No `probenum` is found. Run `aggreprobe` first.") + } + names(probenum) <- rownames(fData(posdat)) + + # setting default value for sizefact_BG + if (is.null(sizefact_BG)) { + if (isFALSE(split)) { + # single slide + sizefact_BG <- pDat[["sizefact"]] + } else { + # multiple slides + sizefact_BG <- pDat[["sizefact_sp"]] + } + } + + # setting default value for sizefact_start + if (is.null(sizefact_start)) { + if (!("sizefact_fitNBth" %in% colnames(pDat))) { + stop("Please run `fitNBth` first.") + } else { + sizefact_start <- pDat[["sizefact_fitNBth"]] + } + } + + # setting default value for features_all + if (is.null(features_all)) { + gene_sum <- rowSums(countmat) + + if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { + features_all <- rownames(countmat) + } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { + features_all <- rownames(countmat) + } else { + stop("No information is found to determine the data type (CTA or WTA).") + } + } + + # setting default value for sizefact_start + if (is.null(threshold_mean)) { + threshold_mean <- thmean + } + + # setting default value for features_high + if (is.null(features_high)) { + gene_sum <- rowSums(countmat) + + if (any(grepl("WTA", toupper(Biobase::annotation(object))))) { + features_high <- names(which(((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))))) + features_high <- sort(sample(features_high, 1500)) + } else if (any(grepl("CTA", toupper(Biobase::annotation(object))))) { + if (any(grepl("scores", fvarLabels(object)))) { + if (split == TRUE) { + sc1_scores <- fData(object)[-which(fData(object)$Negative), grepl("scores_", fvarLabels(object))] + rownames(sc1_scores) <- fData(object)[-which(fData(object)$Negative), "TargetName"] + features_high <- apply(sc1_scores, 2, function(x) { + ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) + }) + features_high <- names(which(apply(features_high, 1, all))) + } else { + sc1_scores <- fData(object)[-which(fData(object)$Negative), "scores"] + names(sc1_scores) <- fData(object)[-which(fData(object)$Negative), "TargetName"] + features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) + features_high <- names(which(features_high)) + } } else { - if (is.null(Biobase::notes(object)$fitPoisBG_sp_var)) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } else { - idvar <- Biobase::notes(object)$fitPoisBG_sp_var - id <- Biobase::pData(object)[[idvar]][match(ROIs_high, colnames(object))] - message(sprintf("The results are based on stored `groupvar`, %s", idvar)) - } - - result <- fitPoisthNorm_sp( - object = countmat, - probenum = probenum, - features_high = features_high, - features_all = features_all, - sizefact_start = sizefact_start, - sizefact_BG = sizefact_BG, - threshold_mean = threshold_mean, - preci2 = preci2, - id = id, - iterations = iterations, - prior_type = prior_type, - sizefactrec = sizefactrec, - size_scale = size_scale, - sizescalebythreshold = sizescalebythreshold, - covrob = covrob, - preci1con = preci1con, - cutoff = cutoff, - confac = confac - ) - - # threshold0 - Biobase::fData(object)[["threshold0"]] <- matrix(NA, - nrow = nrow(object), ncol = nrow(result$threshold0), - dimnames = list(Biobase::featureNames(object), rownames(result$threshold0)) - ) - Biobase::fData(object)[["threshold0"]][colnames(result$threshold0), ] <- t(result$threshold0) - - # threshold - Biobase::fData(object)[["threshold"]] <- matrix(NA, - nrow = nrow(object), ncol = nrow(result$threshold), - dimnames = list(Biobase::featureNames(object), rownames(result$threshold)) - ) - Biobase::fData(object)[["threshold"]][colnames(result$threshold), ] <- t(result$threshold) - - # normmat0 - normmat0_mat <- matrix(NA, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - normmat0_mat[colnames(result$normmat0), ROIs_high] <- t(result$normmat0) - Biobase::assayDataElement(object, "normmat0_sp") <- normmat0_mat - - # normmat - normmat_mat <- matrix(NA, - nrow = nrow(object), ncol = ncol(object), - dimnames = dimnames(object) - ) - normmat_mat[colnames(result$normmat), ROIs_high] <- t(result$normmat) - Biobase::assayDataElement(object, "normmat_sp") <- normmat_mat - - # sizefact - Biobase::pData(object)[ROIs_high, "sizefact_norm_sp"] <- result$sizefact - # sizefact0 - Biobase::pData(object)[ROIs_high, "sizefact0_norm_sp"] <- result$sizefact0 - - # preci1 - Biobase::notes(object)$preci1_norm_sp <- result$preci1 - - # skipping appending Im0 and Im from result for now. - - # conv0 - for (index in names(result$conv0)) { - Biobase::fData(object)[features_high, paste0("conv0_sp_", index)] <- result$conv0[[index]] - } - # conv - for (index in names(result$conv0)) { - Biobase::fData(object)[features_all, paste0("conv_sp_", index)] <- result$conv[[index]] - } - # features_high - Biobase::fData(object)[features_high, "features_high_sp"] <- 1 - # features_all - Biobase::fData(object)[features_all, "features_all_sp"] <- 1 + stop("Please run score test first using `BGScoreTest`.") } - - return(object) + } else { + stop("No information is found to determine the data type (CTA or WTA).") + } } + + if (isFALSE(split)) { + result <- fitPoisthNorm( + object = countmat, + probenum = probenum, + features_high = features_high, + features_all = features_all, + sizefact_start = sizefact_start, + sizefact_BG = sizefact_BG, + threshold_mean = threshold_mean, + preci2 = preci2, + iterations = iterations, + prior_type = prior_type, + sizefactrec = sizefactrec, + size_scale = size_scale, + sizescalebythreshold = sizescalebythreshold, + covrob = covrob, + preci1con = preci1con, + cutoff = cutoff, + confac = confac, + calhes = calhes + ) + + # para0 + Biobase::fData(object)[["para0_norm"]] <- matrix(NA, + nrow = nrow(object), ncol = nrow(result$para0), + dimnames = list(Biobase::featureNames(object), paste0("var", seq_len((nrow(result$para0))))) + ) + Biobase::fData(object)[["para0_norm"]][colnames(result$para0), ] <- t(result$para0) + + # para + Biobase::fData(object)[["para_norm"]] <- matrix(NA, + nrow = nrow(object), ncol = nrow(result$para), + dimnames = list(Biobase::featureNames(object), paste0("var", seq_len((nrow(result$para))))) + ) + Biobase::fData(object)[["para_norm"]][colnames(result$para), ] <- t(result$para) + + # normmat0 + normmat0_mat <- matrix(NA, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + normmat0_mat[colnames(result$normmat0), ROIs_high] <- t(result$normmat0) + Biobase::assayDataElement(object, "normmat0") <- normmat0_mat + + # normmat + normmat_mat <- matrix(NA, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + normmat_mat[colnames(result$normmat), ROIs_high] <- t(result$normmat) + Biobase::assayDataElement(object, "normmat") <- normmat_mat + + # sizefact + Biobase::pData(object)[ROIs_high, "sizefact_norm"] <- result$sizefact + # sizefac0 + Biobase::pData(object)[ROIs_high, "sizefact0_norm"] <- result$sizefact0 + + # preci1 + Biobase::notes(object)$preci1_norm <- result$preci1 + + # skipping appending Im0 and Im from result for now. + + # conv0 + Biobase::fData(object)[features_high, "conv0"] <- result$conv0 + # conv + Biobase::fData(object)[features_all, "conv"] <- result$conv + + # features_high + Biobase::fData(object)[features_high, "features_high"] <- 1 + # features_all + Biobase::fData(object)[features_all, "features_all"] <- 1 + } else { + if (is.null(Biobase::notes(object)$fitPoisBG_sp_var)) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } else { + idvar <- Biobase::notes(object)$fitPoisBG_sp_var + id <- Biobase::pData(object)[[idvar]][match(ROIs_high, colnames(object))] + message(sprintf("The results are based on stored `groupvar`, %s", idvar)) + } + + result <- fitPoisthNorm_sp( + object = countmat, + probenum = probenum, + features_high = features_high, + features_all = features_all, + sizefact_start = sizefact_start, + sizefact_BG = sizefact_BG, + threshold_mean = threshold_mean, + preci2 = preci2, + id = id, + iterations = iterations, + prior_type = prior_type, + sizefactrec = sizefactrec, + size_scale = size_scale, + sizescalebythreshold = sizescalebythreshold, + covrob = covrob, + preci1con = preci1con, + cutoff = cutoff, + confac = confac + ) + + # threshold0 + Biobase::fData(object)[["threshold0"]] <- matrix(NA, + nrow = nrow(object), ncol = nrow(result$threshold0), + dimnames = list(Biobase::featureNames(object), rownames(result$threshold0)) + ) + Biobase::fData(object)[["threshold0"]][colnames(result$threshold0), ] <- t(result$threshold0) + + # threshold + Biobase::fData(object)[["threshold"]] <- matrix(NA, + nrow = nrow(object), ncol = nrow(result$threshold), + dimnames = list(Biobase::featureNames(object), rownames(result$threshold)) + ) + Biobase::fData(object)[["threshold"]][colnames(result$threshold), ] <- t(result$threshold) + + # normmat0 + normmat0_mat <- matrix(NA, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + normmat0_mat[colnames(result$normmat0), ROIs_high] <- t(result$normmat0) + Biobase::assayDataElement(object, "normmat0_sp") <- normmat0_mat + + # normmat + normmat_mat <- matrix(NA, + nrow = nrow(object), ncol = ncol(object), + dimnames = dimnames(object) + ) + normmat_mat[colnames(result$normmat), ROIs_high] <- t(result$normmat) + Biobase::assayDataElement(object, "normmat_sp") <- normmat_mat + + # sizefact + Biobase::pData(object)[ROIs_high, "sizefact_norm_sp"] <- result$sizefact + # sizefact0 + Biobase::pData(object)[ROIs_high, "sizefact0_norm_sp"] <- result$sizefact0 + + # preci1 + Biobase::notes(object)$preci1_norm_sp <- result$preci1 + + # skipping appending Im0 and Im from result for now. + + # conv0 + for (index in names(result$conv0)) { + Biobase::fData(object)[features_high, paste0("conv0_sp_", index)] <- result$conv0[[index]] + } + # conv + for (index in names(result$conv0)) { + Biobase::fData(object)[features_all, paste0("conv_sp_", index)] <- result$conv[[index]] + } + # features_high + Biobase::fData(object)[features_high, "features_high_sp"] <- 1 + # features_all + Biobase::fData(object)[features_all, "features_all_sp"] <- 1 + } + + return(object) + } ) #' @@ -463,137 +458,125 @@ setMethod( #' @aliases fitPoisthNorm,matrix-method setMethod( - "fitPoisthNorm", "matrix", - function(object, probenum = rep(1, NROW(object)), features_high, features_all, - sizefact_start, sizefact_BG, threshold_mean, preci2=10000, iterations = 2, - prior_type = c("contrast", "equal"), sizefactrec = TRUE, size_scale = c("sum", "first"), - sizescalebythreshold = FALSE, covrob = FALSE, preci1con = 1 / 25, cutoff = 15, confac = 1, calhes = FALSE) { - if (iterations != 2) { - stop("Only iterations=2 is allowed") - } - - if (is.null(names(probenum))) names(probenum) <- rownames(object) - - sizefact0 <- sizefact <- sizefact_start - - - n_para <- ncol(object) - - X <- diag(1, n_para) - - prior_type <- match.arg(prior_type) - - + "fitPoisthNorm", "matrix", + function(object, probenum = rep(1, NROW(object)), features_high, features_all, + sizefact_start, sizefact_BG, threshold_mean, preci2=10000, iterations = 2, + prior_type = c("contrast", "equal"), sizefactrec = TRUE, size_scale = c("sum", "first"), + sizescalebythreshold = FALSE, covrob = FALSE, preci1con = 1 / 25, cutoff = 15, confac = 1, calhes = FALSE) { + if (iterations != 2) { + stop("Only iterations=2 is allowed") + } + + if (is.null(names(probenum))) names(probenum) <- rownames(object) + + sizefact0 <- sizefact <- sizefact_start + + + n_para <- ncol(object) + + X <- diag(1, n_para) + + prior_type <- match.arg(prior_type) + + if (prior_type == "equal") { + preci1 <- preci1con * t(X) %*% diag(1, n_para) %*% X + } else if (prior_type == "contrast") { + contrvec <- t(rep(1 / n_para, n_para)) %*% X + + preci1 <- (preci1con) * t(contrvec) %*% contrvec + } + + for (iter in seq_len(iterations)) { + if (iter == 1) { + modfit <- PoisthNorm_paraOptall(t(object[features_high, ]), X, sizefact_BG, sizefact, preci1, threshold_mean * probenum, preci2, sizescalebythreshold, calhes & (iter == iterations)) + Im <- modfit$hes + Im0 <- Im + para <- modfit$par + colnames(para) <- features_high + para0 <- para + conv0 <- modfit$conv + } else { + modfit <- PoisthNorm_paraOptall(t(object[features_all, ]), X, sizefact_BG, sizefact, preci1, threshold_mean * probenum, preci2, sizescalebythreshold, calhes & (iter == iterations)) + Im <- modfit$hes + + para <- modfit$par + colnames(para) <- features_all + conv <- modfit$conv + } + + message("probe finished") + + if (iter == 1) { + features_remain <- names(which(colMeans(abs(para[seq_len(n_para), , drop = FALSE])) < cutoff)) if (prior_type == "equal") { - preci1 <- preci1con * t(X) %*% diag(1, n_para) %*% X + if (covrob) { + cov_mat <- robust::covRob(t(para[seq_len(n_para), features_remain]), na.action = na.omit)$cov + } else { + cov_mat <- cov(t(para[seq_len(n_para), features_remain]), use = "pairwise.complete.obs") + } + + preci1 <- solve(cov_mat) } else if (prior_type == "contrast") { - contrvec <- t(rep(1 / n_para, n_para)) %*% X - - preci1 <- (preci1con) * t(contrvec) %*% contrvec + contrmat <- cbind(rep(1, n_para - 1), -diag(1, (n_para - 1))) + para_EB <- para[seq_len(n_para), features_remain] + + contrpara <- contrmat %*% para_EB + + + if (covrob) { + cov_mat <- robust::covRob(t(contrpara), na.action = na.omit)$cov + } else { + cov_mat <- cov(t(contrpara), use = "pairwise.complete.obs") + } + + preci1 <- t(contrmat) %*% solve(cov_mat) %*% contrmat + + preci1 <- confac * preci1 + (preci1con) * t(contrvec) %*% contrvec } - - - - for (iter in seq_len(iterations)) { - if (iter == 1) { - modfit <- PoisthNorm_paraOptall(t(object[features_high, ]), X, sizefact_BG, sizefact, preci1, threshold_mean * probenum, preci2, sizescalebythreshold, calhes & (iter == iterations)) - Im <- modfit$hes - Im0 <- Im - para <- modfit$par - colnames(para) <- features_high - para0 <- para - conv0 <- modfit$conv - } else { - modfit <- PoisthNorm_paraOptall(t(object[features_all, ]), X, sizefact_BG, sizefact, preci1, threshold_mean * probenum, preci2, sizescalebythreshold, calhes & (iter == iterations)) - Im <- modfit$hes - - para <- modfit$par - colnames(para) <- features_all - conv <- modfit$conv - } - - - message("probe finished") - - if (iter == 1) { - features_remain <- names(which(colMeans(abs(para[seq_len(n_para), , drop = FALSE])) < cutoff)) - if (prior_type == "equal") { - if (covrob) { - cov_mat <- robust::covRob(t(para[seq_len(n_para), features_remain]), na.action = na.omit)$cov - } else { - cov_mat <- cov(t(para[seq_len(n_para), features_remain]), use = "pairwise.complete.obs") - } - - preci1 <- solve(cov_mat) - } else if (prior_type == "contrast") { - contrmat <- cbind(rep(1, n_para - 1), -diag(1, (n_para - 1))) - para_EB <- para[seq_len(n_para), features_remain] - - contrpara <- contrmat %*% para_EB - - - if (covrob) { - cov_mat <- robust::covRob(t(contrpara), na.action = na.omit)$cov - } else { - cov_mat <- cov(t(contrpara), use = "pairwise.complete.obs") - } - - - - - preci1 <- t(contrmat) %*% solve(cov_mat) %*% contrmat - - # avevec <- rep(1, n_para)/n_para - - preci1 <- confac * preci1 + (preci1con) * t(contrvec) %*% contrvec - } - } - - if (sizefactrec) { - size_scale <- match.arg(size_scale) - features_remain <- names(which(colMeans(abs(para[seq_len(n_para), , drop = FALSE])) < cutoff)) - - - - - for (i in seq_len(length(sizefact))) { - fun <- PoisthNorm_scalenll(X[i, ], object[features_remain, i], probenum[features_remain], para[seq_len(n_para), features_remain], sizefact_BG[i], para[n_para + 1, features_remain], sizescalebythreshold, threshold_mean) - sizefact[i] <- optim(c(sizefact[i]), fun, lower = c(0), method = "L-BFGS-B")$par - } - if (size_scale == "first") { - scale_fac <- sizefact[1] - } else if (size_scale == "sum") { - scale_fac <- sum(sizefact) - } - - sizefact <- sizefact / scale_fac - - message(sprintf("Iteration = %s, squared error = %s", iter, sum((sizefact - sizefact0)^2))) - - if (iter == 1) { - sizefact0 <- sizefact - } - } + } + + if (sizefactrec) { + size_scale <- match.arg(size_scale) + features_remain <- names(which(colMeans(abs(para[seq_len(n_para), , drop = FALSE])) < cutoff)) + + for (i in seq_len(length(sizefact))) { + fun <- PoisthNorm_scalenll(X[i, ], object[features_remain, i], probenum[features_remain], para[seq_len(n_para), features_remain], sizefact_BG[i], para[n_para + 1, features_remain], sizescalebythreshold, threshold_mean) + sizefact[i] <- optim(c(sizefact[i]), fun, lower = c(0), method = "L-BFGS-B")$par + } + if (size_scale == "first") { + scale_fac <- sizefact[1] + } else if (size_scale == "sum") { + scale_fac <- sum(sizefact) } - normmat0 <- X %*% para0[seq_len(n_para), ] - normmat <- X %*% para[seq_len(n_para), ] - message("Model converged.") - return(list( - para0 = para0, - para = para, - normmat0 = normmat0, - normmat = normmat, - sizefact = sizefact, - sizefact0 = sizefact0, - preci1 = preci1, - Im0 = Im0, - Im = Im, - conv0 = conv0, - conv = conv, - features_high = features_high, - features_all = features_all - )) + + sizefact <- sizefact / scale_fac + + message(sprintf("Iteration = %s, squared error = %s", iter, sum((sizefact - sizefact0)^2))) + + if (iter == 1) { + sizefact0 <- sizefact + } + } } + normmat0 <- X %*% para0[seq_len(n_para), ] + normmat <- X %*% para[seq_len(n_para), ] + message("Model converged.") + return(list( + para0 = para0, + para = para, + normmat0 = normmat0, + normmat = normmat, + sizefact = sizefact, + sizefact0 = sizefact0, + preci1 = preci1, + Im0 = Im0, + Im = Im, + conv0 = conv0, + conv = conv, + features_high = features_high, + features_all = features_all + )) + } ) @@ -643,81 +626,81 @@ setMethod( #' @rdname fitPoisthNorm_sp-methods setGeneric("fitPoisthNorm_sp", - signature = c("object"), - function(object, ...) standardGeneric("fitPoisthNorm_sp") + signature = c("object"), + function(object, ...) standardGeneric("fitPoisthNorm_sp") ) #' @rdname fitPoisthNorm_sp-methods #' @aliases fitPoisthNorm_sp,matrix-method setMethod( - "fitPoisthNorm_sp", "matrix", - function(object, probenum, features_high, - features_all = colnames(object), sizefact_start, sizefact_BG, - threshold_mean, preci2=10000, id, iterations = 2, prior_type = c("contrast", "equal"), - sizefactrec = TRUE, size_scale = c("sum", "first"), sizescalebythreshold = FALSE, - covrob = FALSE, preci1con = 1 / 25, cutoff = 15, confac = 1) { - uniid <- unique(as.character(id)) - - loc <- lapply(uniid, function(x) which(id == x)) - names(loc) <- uniid - normmod_ls <- lapply(uniid, function(x) { - fitPoisthNorm(object[, id == x], - probenum = probenum, features_high, features_all, - sizefact_start[id == x], sizefact_BG[id == x], threshold_mean, preci2, iterations, prior_type = prior_type, sizefactrec = sizefactrec, size_scale = size_scale, sizescalebythreshold = sizescalebythreshold, - covrob = covrob, preci1con = preci1con, cutoff = cutoff, confac = confac - ) - }) - names(normmod_ls) <- uniid - - preci1 <- list() - threshold0 <- matrix(NA, length(uniid), length(features_high)) - threshold <- matrix(NA, length(uniid), length(features_all)) - rownames(threshold) <- rownames(threshold0) <- uniid - normmat0 <- matrix(NA, length(id), length(features_high)) - normmat <- matrix(NA, length(id), length(features_all)) - - colnames(normmat) <- colnames(threshold) <- features_all - colnames(normmat0) <- colnames(threshold0) <- features_high - - sizefact <- sizefact0 <- sizefact_BG - conv0 <- list() - conv <- list() - Im0 <- list() - Im <- list() - - for (idname in uniid) { - threshold0[idname, ] <- normmod_ls[[idname]]$para0[length(loc[[idname]]) + 1, ] - threshold[idname, ] <- normmod_ls[[idname]]$para[length(loc[[idname]]) + 1, ] - - normmat0[loc[[idname]], ] <- normmod_ls[[idname]]$normmat0 - normmat[loc[[idname]], ] <- normmod_ls[[idname]]$normmat - sizefact[loc[[idname]]] <- normmod_ls[[idname]]$sizefact - sizefact0[loc[[idname]]] <- normmod_ls[[idname]]$sizefact0 - - Im0[[idname]] <- normmod_ls[[idname]]$Im0 - Im[[idname]] <- normmod_ls[[idname]]$Im - - - conv0[[idname]] <- normmod_ls[[idname]]$conv0 - conv[[idname]] <- normmod_ls[[idname]]$conv - - preci1[[idname]] <- normmod_ls[[idname]]$preci1 - } - - return(list( - threshold0 = threshold0, - threshold = threshold, - normmat0 = normmat0, - normmat = normmat, - sizefact = sizefact, - sizefact0 = sizefact0, - preci1 = preci1, - Im0 = Im0, - Im = Im, - conv0 = conv0, - conv = conv, - features_high = features_high, - features_all = features_all - )) + "fitPoisthNorm_sp", "matrix", + function(object, probenum, features_high, + features_all = colnames(object), sizefact_start, sizefact_BG, + threshold_mean, preci2=10000, id, iterations = 2, prior_type = c("contrast", "equal"), + sizefactrec = TRUE, size_scale = c("sum", "first"), sizescalebythreshold = FALSE, + covrob = FALSE, preci1con = 1 / 25, cutoff = 15, confac = 1) { + uniid <- unique(as.character(id)) + + loc <- lapply(uniid, function(x) which(id == x)) + names(loc) <- uniid + normmod_ls <- lapply(uniid, function(x) { + fitPoisthNorm(object[, id == x], + probenum = probenum, features_high, features_all, + sizefact_start[id == x], sizefact_BG[id == x], threshold_mean, preci2, iterations, prior_type = prior_type, sizefactrec = sizefactrec, size_scale = size_scale, sizescalebythreshold = sizescalebythreshold, + covrob = covrob, preci1con = preci1con, cutoff = cutoff, confac = confac + ) + }) + names(normmod_ls) <- uniid + + preci1 <- list() + threshold0 <- matrix(NA, length(uniid), length(features_high)) + threshold <- matrix(NA, length(uniid), length(features_all)) + rownames(threshold) <- rownames(threshold0) <- uniid + normmat0 <- matrix(NA, length(id), length(features_high)) + normmat <- matrix(NA, length(id), length(features_all)) + + colnames(normmat) <- colnames(threshold) <- features_all + colnames(normmat0) <- colnames(threshold0) <- features_high + + sizefact <- sizefact0 <- sizefact_BG + conv0 <- list() + conv <- list() + Im0 <- list() + Im <- list() + + for (idname in uniid) { + threshold0[idname, ] <- normmod_ls[[idname]]$para0[length(loc[[idname]]) + 1, ] + threshold[idname, ] <- normmod_ls[[idname]]$para[length(loc[[idname]]) + 1, ] + + normmat0[loc[[idname]], ] <- normmod_ls[[idname]]$normmat0 + normmat[loc[[idname]], ] <- normmod_ls[[idname]]$normmat + sizefact[loc[[idname]]] <- normmod_ls[[idname]]$sizefact + sizefact0[loc[[idname]]] <- normmod_ls[[idname]]$sizefact0 + + Im0[[idname]] <- normmod_ls[[idname]]$Im0 + Im[[idname]] <- normmod_ls[[idname]]$Im + + + conv0[[idname]] <- normmod_ls[[idname]]$conv0 + conv[[idname]] <- normmod_ls[[idname]]$conv + + preci1[[idname]] <- normmod_ls[[idname]]$preci1 } + + return(list( + threshold0 = threshold0, + threshold = threshold, + normmat0 = normmat0, + normmat = normmat, + sizefact = sizefact, + sizefact0 = sizefact0, + preci1 = preci1, + Im0 = Im0, + Im = Im, + conv0 = conv0, + conv = conv, + features_high = features_high, + features_all = features_all + )) + } ) diff --git a/R/PoisthNorm_nllopt.R b/R/PoisthNorm_nllopt.R index ef4add0..1312332 100644 --- a/R/PoisthNorm_nllopt.R +++ b/R/PoisthNorm_nllopt.R @@ -1,27 +1,23 @@ PoisthNorm_scalenll <- function(X, Y, probenum, betamat, sizefact0, threshold, sizescale, threshold_mean) { - tmp0 <- 2^(X %*% betamat) - - if (sizescale) { - loglik_ind <- function(sizefact) { - tmp1 <- probenum * sizefact0 * threshold_mean * threshold + probenum * sizefact * threshold_mean * tmp0 - - - tmp3 <- dpois(x = Y, lambda = tmp1, log = TRUE) - - # - ((log(phi) - m0)^2)/(2 * (sigma^2)) - log(sigma) - -(sum(tmp3)) - } - } else { - loglik_ind <- function(sizefact) { - tmp1 <- probenum * sizefact0 * threshold + sizefact * tmp0 - - - tmp3 <- dpois(x = Y, lambda = tmp1, log = TRUE) - - # - ((log(phi) - m0)^2)/(2 * (sigma^2)) - log(sigma) - -(sum(tmp3)) - } + tmp0 <- 2^(X %*% betamat) + + if (sizescale) { + loglik_ind <- function(sizefact) { + tmp1 <- probenum * sizefact0 * threshold_mean * threshold + probenum * sizefact * threshold_mean * tmp0 + + tmp3 <- dpois(x = Y, lambda = tmp1, log = TRUE) + + -(sum(tmp3)) } - - return(loglik_ind) + } else { + loglik_ind <- function(sizefact) { + tmp1 <- probenum * sizefact0 * threshold + sizefact * tmp0 + + tmp3 <- dpois(x = Y, lambda = tmp1, log = TRUE) + + -(sum(tmp3)) + } + } + + return(loglik_ind) } diff --git a/R/RcppExports.R b/R/RcppExports.R index 5ee4ce6..afab237 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -2,46 +2,46 @@ # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 NBthDE_paraOptfeat <- function(X, y, alpha0, alpha, preci1, threshold0, preci2, x0, calhes) { - .Call(`_GeoDiff_NBthDE_paraOptfeat`, X, y, alpha0, alpha, preci1, threshold0, preci2, x0, calhes) + .Call(`_GeoDiff_NBthDE_paraOptfeat`, X, y, alpha0, alpha, preci1, threshold0, preci2, x0, calhes) } NBthDE_paraOptall <- function(Y, X, alpha0, alpha, preci1, threshold0, preci2, x0, sizescale, calhes) { - .Call(`_GeoDiff_NBthDE_paraOptall`, Y, X, alpha0, alpha, preci1, threshold0, preci2, x0, sizescale, calhes) + .Call(`_GeoDiff_NBthDE_paraOptall`, Y, X, alpha0, alpha, preci1, threshold0, preci2, x0, sizescale, calhes) } NBthmDE_grad <- function(y, X, Z, x, u, alpha0, alpha, preci1, preci2, threshold0) { - .Call(`_GeoDiff_NBthmDE_grad`, y, X, Z, x, u, alpha0, alpha, preci1, preci2, threshold0) + .Call(`_GeoDiff_NBthmDE_grad`, y, X, Z, x, u, alpha0, alpha, preci1, preci2, threshold0) } NBthmDE_gradM <- function(y, X, Z, x, u_mat, alpha0, alpha, preci1, preci2, threshold0) { - .Call(`_GeoDiff_NBthmDE_gradM`, y, X, Z, x, u_mat, alpha0, alpha, preci1, preci2, threshold0) + .Call(`_GeoDiff_NBthmDE_gradM`, y, X, Z, x, u_mat, alpha0, alpha, preci1, preci2, threshold0) } condi_u <- function(Tem, ind, u, temp_size) { - .Call(`_GeoDiff_condi_u`, Tem, ind, u, temp_size) + .Call(`_GeoDiff_condi_u`, Tem, ind, u, temp_size) } NBthmDE_mh <- function(Tem, u, X, Z, y, alpha0, alpha, x, nmh) { - .Call(`_GeoDiff_NBthmDE_mh`, Tem, u, X, Z, y, alpha0, alpha, x, nmh) + .Call(`_GeoDiff_NBthmDE_mh`, Tem, u, X, Z, y, alpha0, alpha, x, nmh) } NBthmDE_fparaOptfeat <- function(X, Z, y, alpha0, alpha, preci1, threshold0, preci2, u_mat, x0, calhes) { - .Call(`_GeoDiff_NBthmDE_fparaOptfeat`, X, Z, y, alpha0, alpha, preci1, threshold0, preci2, u_mat, x0, calhes) + .Call(`_GeoDiff_NBthmDE_fparaOptfeat`, X, Z, y, alpha0, alpha, preci1, threshold0, preci2, u_mat, x0, calhes) } NBthmDE_uOpt <- function(u0, X, Z, y, alpha0, alpha, x, preciu, calhes) { - .Call(`_GeoDiff_NBthmDE_uOpt`, u0, X, Z, y, alpha0, alpha, x, preciu, calhes) + .Call(`_GeoDiff_NBthmDE_uOpt`, u0, X, Z, y, alpha0, alpha, x, preciu, calhes) } PoisthNorm_paraOptfeat <- function(y, X, alpha0, alpha, preci1, preci2, threshold0, calhes) { - .Call(`_GeoDiff_PoisthNorm_paraOptfeat`, y, X, alpha0, alpha, preci1, preci2, threshold0, calhes) + .Call(`_GeoDiff_PoisthNorm_paraOptfeat`, y, X, alpha0, alpha, preci1, preci2, threshold0, calhes) } PoisthNorm_paraOptall <- function(Y, X, alpha0, alpha, preci1, threshold0, preci2, sizescale, calhes) { - .Call(`_GeoDiff_PoisthNorm_paraOptall`, Y, X, alpha0, alpha, preci1, threshold0, preci2, sizescale, calhes) + .Call(`_GeoDiff_PoisthNorm_paraOptall`, Y, X, alpha0, alpha, preci1, threshold0, preci2, sizescale, calhes) } dnbinom_mu_vec <- function(x, sz, mu, lg) { - .Call(`_GeoDiff_dnbinom_mu_vec`, x, sz, mu, lg) + .Call(`_GeoDiff_dnbinom_mu_vec`, x, sz, mu, lg) } diff --git a/R/ScoreTest.R b/R/ScoreTest.R index e950ce8..cd75e6e 100644 --- a/R/ScoreTest.R +++ b/R/ScoreTest.R @@ -1,3 +1,8 @@ +library(magrittr) +library(GeomxTools) +library(Rcpp) +library(Rfast) +library(Matrix) #' Testing for features above the background #' #' Testing for features above the background using Poisson background model as reference @@ -50,106 +55,106 @@ #' @rdname BGScoreTest-methods setGeneric("BGScoreTest", - signature = c("object"), - function(object, ...) standardGeneric("BGScoreTest") + signature = c("object"), + function(object, ...) standardGeneric("BGScoreTest") ) #' @rdname BGScoreTest-methods #' @aliases BGScoreTest,NanoStringGeoMxSet-method setMethod( - "BGScoreTest", "NanoStringGeoMxSet", - function(object, split = FALSE, adj = 1, removeoutlier = FALSE, useprior = FALSE) { - posdat <- object[-which(Biobase::fData(object)$CodeClass == "Negative"), ] - countmat <- Biobase::exprs(posdat) - - pDat <- Biobase::pData(object) - fDat <- Biobase::fData(object) - - # calculate probenum for the dataset - if ("probenum" %in% fvarLabels(posdat)) { - probenum <- fData(posdat)[["probenum"]] - } else { - warning("No `probenum` is found. For targets with >1 probe, this ", - "is allowed in order to run `aggreprobe` with `use=\"score\"`") - probenum <- rep(1, nrow(posdat)) - } - names(probenum) <- rownames(fData(posdat)) - - if (isFALSE(split)) { - if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { - stop("Please run `fitPoisBG` first. If you run `fitPoisBG` before, please specify `split = TRUE`.") - } - - sizefact <- setNames(object[["sizefact"]], Biobase::sampleNames(object)) - featfact <- setNames(fDat[["featfact"]], Biobase::featureNames(object)) - featfact <- featfact[-which(is.na(featfact))] - - BGmod <- list( - sizefact = sizefact, - featfact = featfact, - countmat = countmat - ) - - result <- BGScoreTest( - object = countmat, - BGmod = BGmod, - probenum = probenum, - adj = adj, - removeoutlier = removeoutlier, - useprior = useprior - ) - - if (any(c("pvalues", "scores") %in% Biobase::varLabels(object))) { - warning("`pvalues` and `scores` exist in the phenodata. Those values are replaced.") - } - - Biobase::fData(object)[["pvalues"]] <- NA - Biobase::fData(object)[["pvalues"]][match(names(result$pvalues), Biobase::featureNames(object), nomatch = 0)] <- result$pvalues - Biobase::fData(object)[["scores"]] <- NA - Biobase::fData(object)[["scores"]][match(names(result$scores), Biobase::featureNames(object), nomatch = 0)] <- result$scores - } else { - if (!any(c("sizefact_sp" %in% colnames(pDat), "featfact_" %in% colnames(fDat)))) { - stop("Please run `fitPoisBG` first with `groupvar`.") - } - - idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] - id <- pDat[[idvar]] - message(sprintf("The results are based on stored `groupvar`, %s", idvar)) - - sizefact <- setNames(pDat[["sizefact_sp"]], Biobase::sampleNames(object)) - featfact <- fDat[, paste0("featfact_", unique(id))] - featfact <- featfact[which(fDat$CodeClass == "Negative"), ] - colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) - - BGmod <- list( - sizefact = sizefact, - featfact = as.matrix(featfact), - countmat = countmat, - id = id - ) - - result <- BGScoreTest_sp( - object = countmat, - BGmod = BGmod, - probenum = probenum, - adj = adj, - removeoutlier = removeoutlier, - useprior = useprior - ) - - if (length(c(grep("pvalues_", Biobase::fvarLabels(object)), grep("scores_", Biobase::fvarLabels(object)))) > 0) { - warning("`pvalues_sp` and `scores_sp` exist in the phenodata. Those values are replaced.") - } - # append results to the object - for (index in unique(id)) { - Biobase::fData(object)[[paste0("pvalues_", index)]] <- NA - Biobase::fData(object)[[paste0("pvalues_", index)]][match(rownames(result$pvalues), Biobase::featureNames(object), nomatch = 0)] <- result$pvalues[, index] - Biobase::fData(object)[[paste0("scores_", index)]] <- NA - Biobase::fData(object)[[paste0("scores_", index)]][match(rownames(result$scores_sp), Biobase::featureNames(object), nomatch = 0)] <- result$scores_sp[, index] - } - } - return(object) + "BGScoreTest", "NanoStringGeoMxSet", + function(object, split = FALSE, adj = 1, removeoutlier = FALSE, useprior = FALSE) { + posdat <- object[-which(Biobase::fData(object)$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(posdat) + + pDat <- Biobase::pData(object) + fDat <- Biobase::fData(object) + + # calculate probenum for the dataset + if ("probenum" %in% fvarLabels(posdat)) { + probenum <- fData(posdat)[["probenum"]] + } else { + warning("No `probenum` is found. For targets with >1 probe, this ", + "is allowed in order to run `aggreprobe` with `use=\"score\"`") + probenum <- rep(1, nrow(posdat)) + } + names(probenum) <- rownames(fData(posdat)) + + if (isFALSE(split)) { + if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { + stop("Please run `fitPoisBG` first. If you run `fitPoisBG` before, please specify `split = TRUE`.") + } + + sizefact <- setNames(object[["sizefact"]], Biobase::sampleNames(object)) + featfact <- setNames(fDat[["featfact"]], Biobase::featureNames(object)) + featfact <- featfact[-which(is.na(featfact))] + + BGmod <- list( + sizefact = sizefact, + featfact = featfact, + countmat = countmat + ) + + result <- BGScoreTest( + object = countmat, + BGmod = BGmod, + probenum = probenum, + adj = adj, + removeoutlier = removeoutlier, + useprior = useprior + ) + + if (any(c("pvalues", "scores") %in% Biobase::varLabels(object))) { + warning("`pvalues` and `scores` exist in the phenodata. Those values are replaced.") + } + + Biobase::fData(object)[["pvalues"]] <- NA + Biobase::fData(object)[["pvalues"]][match(names(result$pvalues), Biobase::featureNames(object), nomatch = 0)] <- result$pvalues + Biobase::fData(object)[["scores"]] <- NA + Biobase::fData(object)[["scores"]][match(names(result$scores), Biobase::featureNames(object), nomatch = 0)] <- result$scores + } else { + if (!any(c("sizefact_sp" %in% colnames(pDat), "featfact_" %in% colnames(fDat)))) { + stop("Please run `fitPoisBG` first with `groupvar`.") + } + + idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] + id <- pDat[[idvar]] + message(sprintf("The results are based on stored `groupvar`, %s", idvar)) + + sizefact <- setNames(pDat[["sizefact_sp"]], Biobase::sampleNames(object)) + featfact <- fDat[, paste0("featfact_", unique(id))] + featfact <- featfact[which(fDat$CodeClass == "Negative"), ] + colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) + + BGmod <- list( + sizefact = sizefact, + featfact = as.matrix(featfact), + countmat = countmat, + id = id + ) + + result <- BGScoreTest_sp( + object = countmat, + BGmod = BGmod, + probenum = probenum, + adj = adj, + removeoutlier = removeoutlier, + useprior = useprior + ) + + if (length(c(grep("pvalues_", Biobase::fvarLabels(object)), grep("scores_", Biobase::fvarLabels(object)))) > 0) { + warning("`pvalues_sp` and `scores_sp` exist in the phenodata. Those values are replaced.") + } + # append results to the object + for (index in unique(id)) { + Biobase::fData(object)[[paste0("pvalues_", index)]] <- NA + Biobase::fData(object)[[paste0("pvalues_", index)]][match(rownames(result$pvalues), Biobase::featureNames(object), nomatch = 0)] <- result$pvalues[, index] + Biobase::fData(object)[[paste0("scores_", index)]] <- NA + Biobase::fData(object)[[paste0("scores_", index)]][match(rownames(result$scores_sp), Biobase::featureNames(object), nomatch = 0)] <- result$scores_sp[, index] + } } + return(object) + } ) #' Testing for features above the background @@ -174,70 +179,151 @@ setMethod( #' } #' @rdname BGScoreTest-methods #' @aliases BGScoreTest,matrix-method +#' @export - +#' @rdname BGScoreTest-methods +#' @exportMethod setMethod( - "BGScoreTest", "matrix", - function(object, BGmod, adj = 1, probenum, removeoutlier = FALSE, useprior = FALSE) { - if (removeoutlier == TRUE) { - boxobj <- graphics::boxplot(BGmod$featfact, plot = FALSE) - - if (length(boxobj$out) > 0) { - featfact <- BGmod$featfact[-which(BGmod$featfact %in% boxobj$out)] - } else { - featfact <- BGmod$featfact - } - message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) - } else { - featfact <- BGmod$featfact - } - - sizefact <- BGmod$sizefact - - if (useprior == FALSE) { - if (missing(probenum)) { - prodfact <- sizefact * mean(adj * featfact) - scores <- apply(object, 1, function(x) sum(x - prodfact) / sqrt(sum(prodfact))) - } else { - if (is.null(names(probenum))) names(probenum) <- rownames(object) - scores <- sapply( - names(probenum), - function(feat) { - prodfact <- sizefact * mean(probenum[feat] * featfact) - sum(object[feat, ] - prodfact) / sqrt(sum(prodfact)) - } - ) - } - } else { - if (missing(probenum)) { - featfact0 <- mean(adj * featfact) - sigma <- var(adj * featfact) / (mean(adj * featfact))^2 - deno <- (sizefact * sigma * featfact0 + 1) * featfact0 - - scores <- apply(object, 1, function(x) sum((x - sizefact * featfact0) / deno) / sqrt(sum(sizefact / deno))) - } else { - if (is.null(names(probenum))) names(probenum) <- rownames(object) - scores <- sapply( - names(probenum), - function(feat) { - featfact0 <- mean(probenum[feat] * featfact) - sigma <- var(probenum[feat] * featfact) / (mean(probenum[feat] * featfact))^2 - deno <- (sizefact * sigma * featfact0 + 1) * featfact0 - sum((object[feat, ] - sizefact * featfact0) / deno) / sqrt(sum(sizefact / deno)) - } - ) - } - } + "BGScoreTest", "dgCMatrix", + function(object, BGmod, adj = 1, probenum, removeoutlier = FALSE, useprior = FALSE) { + if (removeoutlier == TRUE) { + boxobj <- graphics::boxplot(BGmod$featfact, plot = FALSE) + + if (length(boxobj$out) > 0) { + featfact <- BGmod$featfact[-which(BGmod$featfact %in% boxobj$out)] + } else { + featfact <- BGmod$featfact + } + message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) + } else { + featfact <- BGmod$featfact + } + + sizefact <- BGmod$sizefact + + if (useprior == FALSE) { + if (missing(probenum)) { + prodfact <- sizefact * mean(adj * featfact) - pvalues <- pnorm(scores, lower.tail = FALSE) - - return(list( - pvalues = pvalues, - scores = scores - )) + scores <- apply(object, 1, function(x) sum(x - prodfact) / sqrt(sum(prodfact))) + } else { + if (is.null(names(probenum))) names(probenum) <- rownames(object) + scores <- sapply( + names(probenum), + function(feat) { + prodfact <- sizefact * mean(probenum[feat] * featfact) + sum(object[feat, ] - prodfact) / sqrt(sum(prodfact)) + } + ) + } + } else { + if (missing(probenum)) { + featfact0 <- mean(adj * featfact) + sigma <- var(adj * featfact) / (mean(adj * featfact))^2 + deno <- (sizefact * sigma * featfact0 + 1) * featfact0 + tmp = sizefact * featfact0 + new_object_denominator = 1/(sqrt(sum(sizefact / deno))*deno) + new_object_denominator = as(new_object_denominator, "sparseMatrix") + quotient_A = (object)%*%new_object_denominator + quotient_B = tmp%*%new_object_denominator + quotient = quotient_A-quotient_B[1][1] + scores_ned = quotient[,1] + names(scores_ned) = rownames(object) + scores = scores_ned + + } else { + if (is.null(names(probenum))) names(probenum) <- rownames(object) + + scores <- sapply( + names(probenum), + function(feat) { + featfact0 <- mean(probenum[feat] * featfact) + sigma <- var(probenum[feat] * featfact) / (mean(probenum[feat] * featfact))^2 + deno <- (sizefact * sigma * featfact0 + 1) * featfact0 + sum((object[feat, ] - sizefact * featfact0) / deno) / sqrt(sum(sizefact / deno)) + } + ) + } } + + pvalues <- pnorm(scores, lower.tail = FALSE) + + return(list( + pvalues = pvalues, + scores = scores + )) + } +) +setMethod( + "BGScoreTest", "matrix", + function(object, BGmod, adj = 1, probenum, removeoutlier = FALSE, useprior = FALSE) { + if (removeoutlier == TRUE) { + boxobj <- graphics::boxplot(BGmod$featfact, plot = FALSE) + + if (length(boxobj$out) > 0) { + featfact <- BGmod$featfact[-which(BGmod$featfact %in% boxobj$out)] + } else { + featfact <- BGmod$featfact + } + message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) + } else { + featfact <- BGmod$featfact + } + + sizefact <- BGmod$sizefact + + if (useprior == FALSE) { + if (missing(probenum)) { + prodfact <- sizefact * mean(adj * featfact) + + scores <- apply(object, 1, function(x) sum(x - prodfact) / sqrt(sum(prodfact))) + } else { + if (is.null(names(probenum))) names(probenum) <- rownames(object) + scores <- sapply( + names(probenum), + function(feat) { + prodfact <- sizefact * mean(probenum[feat] * featfact) + sum(object[feat, ] - prodfact) / sqrt(sum(prodfact)) + } + ) + } + } else { + if (missing(probenum)) { + featfact0 <- mean(adj * featfact) + sigma <- var(adj * featfact) / (mean(adj * featfact))^2 + deno <- (sizefact * sigma * featfact0 + 1) * featfact0 + tmp = sizefact * featfact0 + new_object_denominator = 1/(sqrt(sum(sizefact / deno))*deno) + new_object_denominator = as(new_object_denominator, "sparseMatrix") + quotient_A = (object)%*%new_object_denominator + quotient_B = tmp%*%new_object_denominator + quotient = quotient_A-quotient_B[1][1] + scores_ned = quotient[,1] + names(scores_ned) = rownames(object) + scores = scores_ned + } else { + if (is.null(names(probenum))) names(probenum) <- rownames(object) + + scores <- sapply( + names(probenum), + function(feat) { + featfact0 <- mean(probenum[feat] * featfact) + sigma <- var(probenum[feat] * featfact) / (mean(probenum[feat] * featfact))^2 + deno <- (sizefact * sigma * featfact0 + 1) * featfact0 + sum((object[feat, ] - sizefact * featfact0) / deno) / sqrt(sum(sizefact / deno)) + } + ) + } + } + + pvalues <- pnorm(scores, lower.tail = FALSE) + + return(list( + pvalues = pvalues, + scores = scores + )) + } ) - #' Testing for features above the background, multiple slides case #' @@ -265,80 +351,75 @@ setMethod( #' @rdname BGScoreTest_sp-methods #' setGeneric("BGScoreTest_sp", - signature = c("object"), - function(object, ...) standardGeneric("BGScoreTest_sp") + signature = c("object"), + function(object, ...) standardGeneric("BGScoreTest_sp") ) #' @rdname BGScoreTest_sp-methods #' @aliases BGScoreTest_sp,matrix-method setMethod( - "BGScoreTest_sp", "matrix", - function(object, BGmod, adj = 1, probenum, removeoutlier = FALSE, useprior = FALSE) { - id <- BGmod$id - uniid <- unique(as.character(id)) - - if (removeoutlier == TRUE) { - - # boxobj <- apply(BGmod$featfact, 2, function(x) boxplot(x, plot = FALSE)) - - featfact <- apply(BGmod$featfact, 2, function(x) { - boxobj <- graphics::boxplot(x, plot = FALSE) - message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) - x[which(x %in% boxobj$out)] <- NA - x - }) - } else { - featfact <- BGmod$featfact - } - - sizefact <- BGmod$sizefact - - - if (useprior == FALSE) { - if (missing(probenum)) { - prodfact <- lapply(uniid, function(x) sizefact[x == id] * mean(adj * featfact[, x], na.rm = TRUE)) - names(prodfact) <- uniid - # scores <- apply(countmat, 2, function(x) sum(x - ab)/sqrt(sum(ab))) - scores_sp <- sapply(uniid, function(x) apply(object[, x == id, drop = FALSE], 1, function(y) sum(y - prodfact[[x]]) / sqrt(sum(prodfact[[x]])))) - } else { - if (is.null(names(probenum))) names(probenum) <- rownames(object) - scores_sp <- sapply(names(probenum), function(feat) { - prodfact <- lapply(uniid, function(x) sizefact[x == id, drop = FALSE] * mean(probenum[feat] * featfact[, x], na.rm = TRUE)) - names(prodfact) <- uniid - # scores <- apply(countmat, 2, function(x) sum(x - ab)/sqrt(sum(ab))) - sapply(uniid, function(x) sum(object[feat, x == id, drop = FALSE] - prodfact[[x]]) / sqrt(sum(prodfact[[x]]))) - }) - scores_sp <- t(scores_sp) - } - } else { - if (missing(probenum)) { - featfact0 <- colMeans(adj * featfact, na.rm = TRUE) - sigma <- apply(adj * featfact, 2, var, na.rm = TRUE) / featfact0^2 - deno <- lapply(uniid, function(x) (sizefact[x == id] * sigma[x] * featfact0[x] + 1) * featfact0[x]) - names(deno) <- uniid - - scores_sp <- sapply(uniid, function(x) apply(object[, x == id, drop = FALSE], 1, function(y) sum((y - sizefact[x == id] * featfact0[x]) / deno[[x]]) / sqrt(sum(sizefact[x == id] / deno[[x]])))) - # scores <- apply(scores2, 1, mean) - } else { - if (is.null(names(probenum))) names(probenum) <- rownames(object) - scores_sp <- sapply(names(probenum), function(feat) { - featfact0 <- colMeans(probenum[feat] * featfact, na.rm = TRUE) - sigma <- apply(probenum[feat] * featfact, 2, var, na.rm = TRUE) / featfact0^2 - deno <- lapply(uniid, function(x) (sizefact[x == id] * sigma[x] * featfact0[x] + 1) * featfact0[x]) - names(deno) <- uniid - - sapply(uniid, function(x) sum((object[feat, x == id, drop = FALSE] - sizefact[x == id] * featfact0[x]) / deno[[x]]) / sqrt(sum(sizefact[x == id] / deno[[x]]))) - }) - - scores_sp <- t(scores_sp) - } - } - - pvalues <- pnorm(scores_sp, lower.tail = FALSE) - - return(list( - pvalues = pvalues, - scores_sp = scores_sp - )) + "BGScoreTest_sp", "matrix", + function(object, BGmod, adj = 1, probenum, removeoutlier = FALSE, useprior = FALSE) { + id <- BGmod$id + uniid <- unique(as.character(id)) + + if (removeoutlier == TRUE) { + + featfact <- apply(BGmod$featfact, 2, function(x) { + boxobj <- graphics::boxplot(x, plot = FALSE) + message(sprintf("%s negative probes are removed prior to the score test.", length(boxobj$out))) + x[which(x %in% boxobj$out)] <- NA + x + }) + } else { + featfact <- BGmod$featfact + } + + sizefact <- BGmod$sizefact + + if (useprior == FALSE) { + if (missing(probenum)) { + prodfact <- lapply(uniid, function(x) sizefact[x == id] * mean(adj * featfact[, x], na.rm = TRUE)) + names(prodfact) <- uniid + scores_sp <- sapply(uniid, function(x) apply(object[, x == id, drop = FALSE], 1, function(y) sum(y - prodfact[[x]]) / sqrt(sum(prodfact[[x]])))) + } else { + if (is.null(names(probenum))) names(probenum) <- rownames(object) + scores_sp <- sapply(names(probenum), function(feat) { + prodfact <- lapply(uniid, function(x) sizefact[x == id, drop = FALSE] * mean(probenum[feat] * featfact[, x], na.rm = TRUE)) + names(prodfact) <- uniid + sapply(uniid, function(x) sum(object[feat, x == id, drop = FALSE] - prodfact[[x]]) / sqrt(sum(prodfact[[x]]))) + }) + scores_sp <- t(scores_sp) + } + } else { + if (missing(probenum)) { + featfact0 <- colMeans(adj * featfact) + sigma <- apply(adj * featfact, 2, var, na.rm = TRUE) / featfact0^2 + deno <- lapply(uniid, function(x) (sizefact[x == id] * sigma[x] * featfact0[x] + 1) * featfact0[x]) + names(deno) <- uniid + + scores_sp <- sapply(uniid, function(x) apply(object[, x == id, drop = FALSE], 1, function(y) sum((y - sizefact[x == id] * featfact0[x]) / deno[[x]]) / sqrt(sum(sizefact[x == id] / deno[[x]])))) + + } else { + if (is.null(names(probenum))) names(probenum) <- rownames(object) + scores_sp <- sapply(names(probenum), function(feat) { + featfact0 <- colMeans(probenum[feat] * featfact, na.rm = TRUE) + sigma <- apply(probenum[feat] * featfact, 2, var, na.rm = TRUE) / featfact0^2 + deno <- lapply(uniid, function(x) (sizefact[x == id] * sigma[x] * featfact0[x] + 1) * featfact0[x]) + names(deno) <- uniid + + sapply(uniid, function(x) sum((object[feat, x == id, drop = FALSE] - sizefact[x == id] * featfact0[x]) / deno[[x]]) / sqrt(sum(sizefact[x == id] / deno[[x]]))) + }) + + scores_sp <- t(scores_sp) + } } + + pvalues <- pnorm(scores_sp, lower.tail = FALSE) + + return(list( + pvalues = pvalues, + scores_sp = scores_sp + )) + } ) diff --git a/R/aggreprobe.R b/R/aggreprobe.R index a3162ca..0a4404b 100644 --- a/R/aggreprobe.R +++ b/R/aggreprobe.R @@ -32,125 +32,125 @@ #' setGeneric("aggreprobe", - signature = c("object"), - function(object, ...) standardGeneric("aggreprobe") + signature = c("object"), + function(object, ...) standardGeneric("aggreprobe") ) #' @rdname aggreprobe-methods #' @aliases aggreprobe,NanoStringGeoMxSet-method setMethod( - "aggreprobe", "NanoStringGeoMxSet", - function(object, split, use = c("score", "cor", "both"), corcutoff = 0.85, ...) { - if(GeomxTools::featureType(object) == "Target") { - stop("GeoMxSet object feature type is already target-level. ", - "No further aggregation can be performed.") - } - object_neg <- object[which(Biobase::fData(object)$CodeClass == "Negative"), ] - countmat_neg <- Biobase::exprs(object_neg) - object_nonneg <- object[which(Biobase::fData(object)$CodeClass != "Negative"), ] - countmat_nonneg <- Biobase::exprs(object_nonneg) - pDat <- Biobase::pData(object_neg) - fDat <- Biobase::fData(object_neg) - - use <- match.arg(use) - if (use == "score" | use == "both") { - if (isFALSE(split)) { - if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { - stop("No sizefact and featfact is found. Please run `fitPoisBG` first. If you run `fitPoisBG` with `groupvar` before, please specify `split = TRUE` for `aggreprobe`.") - } - sizefact <- setNames(pDat[["sizefact"]], rownames(pDat)) - featfact <- setNames(fDat[["featfact"]], rownames(fDat)) - - BGmod <- list( - sizefact = sizefact, - featfact = featfact, - countmat = countmat_nonneg - ) - } else { - if (!any(c("sizefact_sp" %in% colnames(pDat), "featfact_" %in% colnames(fDat)))) { - stop("No sizefact and featfact for multiple slides is found. Please run `fitPoisBG` first with `groupvar`.") - } - sizefact <- setNames(pDat[["sizefact_sp"]], rownames(pDat)) - featfact <- fDat[, grep("featfact_", colnames(fDat))] - colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) - idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] - id <- pDat[[idvar]] - message(sprintf("The results are based on stored `groupvar`, %s", idvar)) - - BGmod <- list( - sizefact = sizefact, - featfact = as.matrix(featfact), - countmat = countmat_nonneg, - id = id - ) - } - } else { - BGmod <- NULL + "aggreprobe", "NanoStringGeoMxSet", + function(object, split, use = c("score", "cor", "both"), corcutoff = 0.85, ...) { + if(GeomxTools::featureType(object) == "Target") { + stop("GeoMxSet object feature type is already target-level. ", + "No further aggregation can be performed.") + } + object_neg <- object[which(Biobase::fData(object)$CodeClass == "Negative"), ] + countmat_neg <- Biobase::exprs(object_neg) + object_nonneg <- object[which(Biobase::fData(object)$CodeClass != "Negative"), ] + countmat_nonneg <- Biobase::exprs(object_nonneg) + pDat <- Biobase::pData(object_neg) + fDat <- Biobase::fData(object_neg) + + use <- match.arg(use) + if (use == "score" | use == "both") { + if (isFALSE(split)) { + if (!any(c("sizefact" %in% colnames(pDat), "featfact" %in% colnames(fDat)))) { + stop("No sizefact and featfact is found. Please run `fitPoisBG` first. If you run `fitPoisBG` with `groupvar` before, please specify `split = TRUE` for `aggreprobe`.") } - - result <- aggreprobe( - object = countmat_nonneg, - probenames = rownames(countmat_nonneg), - featurenames = Biobase::fData(object_nonneg)$TargetName, - negmod = BGmod, - use = use, - corcutoff = corcutoff, - ... + sizefact <- setNames(pDat[["sizefact"]], rownames(pDat)) + featfact <- setNames(fDat[["featfact"]], rownames(fDat)) + + BGmod <- list( + sizefact = sizefact, + featfact = featfact, + countmat = countmat_nonneg ) - - # assemble assay data for negative and non-negative - # assay data for negative data - targetCounts_neg <- do.call(rbind, NanoStringNCTools::esBy(object_neg, - GROUP = "TargetName", - FUN = function(x) { - Biobase::esApply(x, 2, identity) - }, simplify = FALSE - )) - # assay data for non-negative data - targetCounts_nonneg <- result$featuremat - - # separate feature data by negative and non-negative - # feature data for non-negative - targetFeats <- Biobase::fData(object_nonneg) - targetFeats <- - targetFeats[!duplicated(targetFeats[["TargetName"]]), ] - rownames(targetFeats) <- targetFeats[, "TargetName"] - probeColumns <- c("RTS_ID", "QCFlags", "ProbeID") - targetFeats_nonneg <- - targetFeats[, !colnames(targetFeats) %in% probeColumns] - targetFeats_nonneg$probenum <- result$probenum[match(rownames(targetFeats), names(result$probenum))] - targetFeats_nonneg$proberemained <- cbind(result$remain)[match(rownames(targetFeats), names(result$remain)), ] - - # feature data for negative probes - targetFeats <- Biobase::fData(object_neg) - rownames(targetFeats) <- targetFeats[, "RTS_ID"] - targetFeats[, "TargetName"] <- targetFeats[, "RTS_ID"] - probeColumns <- c("RTS_ID", "QCFlags", "ProbeID") - targetFeats_neg <- - targetFeats[, !colnames(targetFeats) %in% probeColumns] - targetFeats_neg$probenum <- 1 - targetFeats_neg$proberemained <- targetFeats_neg$TargetName - - # combine feature data - targetFeats <- - Biobase::AnnotatedDataFrame(rbind( - targetFeats_nonneg[rownames(targetCounts_nonneg), ], - targetFeats_neg[rownames(targetCounts_neg), ] - ), - dimLabels = c("featureNames", "featureColumns") - ) - - targetObject <- GeomxTools::NanoStringGeoMxSet( - assayData = rbind(targetCounts_nonneg, targetCounts_neg), - phenoData = Biobase::phenoData(object), - featureData = targetFeats, - experimentData = Biobase::experimentData(object), - annotation = Biobase::annotation(object), - protocolData = Biobase::protocolData(object), - featureType = "Target", - check = FALSE + } else { + if (!any(c("sizefact_sp" %in% colnames(pDat), "featfact_" %in% colnames(fDat)))) { + stop("No sizefact and featfact for multiple slides is found. Please run `fitPoisBG` first with `groupvar`.") + } + sizefact <- setNames(pDat[["sizefact_sp"]], rownames(pDat)) + featfact <- fDat[, grep("featfact_", colnames(fDat))] + colnames(featfact) <- gsub("featfact_", "", colnames(featfact)) + idvar <- Biobase::notes(object)[["fitPoisBG_sp_var"]] + id <- pDat[[idvar]] + message(sprintf("The results are based on stored `groupvar`, %s", idvar)) + + BGmod <- list( + sizefact = sizefact, + featfact = as.matrix(featfact), + countmat = countmat_nonneg, + id = id ) + } + } else { + BGmod <- NULL } + + result <- aggreprobe( + object = countmat_nonneg, + probenames = rownames(countmat_nonneg), + featurenames = Biobase::fData(object_nonneg)$TargetName, + negmod = BGmod, + use = use, + corcutoff = corcutoff, + ... + ) + + # assemble assay data for negative and non-negative + # assay data for negative data + targetCounts_neg <- do.call(rbind, NanoStringNCTools::esBy(object_neg, + GROUP = "TargetName", + FUN = function(x) { + Biobase::esApply(x, 2, identity) + }, simplify = FALSE + )) + # assay data for non-negative data + targetCounts_nonneg <- result$featuremat + + # separate feature data by negative and non-negative + # feature data for non-negative + targetFeats <- Biobase::fData(object_nonneg) + targetFeats <- + targetFeats[!duplicated(targetFeats[["TargetName"]]), ] + rownames(targetFeats) <- targetFeats[, "TargetName"] + probeColumns <- c("RTS_ID", "QCFlags", "ProbeID") + targetFeats_nonneg <- + targetFeats[, !colnames(targetFeats) %in% probeColumns] + targetFeats_nonneg$probenum <- result$probenum[match(rownames(targetFeats), names(result$probenum))] + targetFeats_nonneg$proberemained <- cbind(result$remain)[match(rownames(targetFeats), names(result$remain)), ] + + # feature data for negative probes + targetFeats <- Biobase::fData(object_neg) + rownames(targetFeats) <- targetFeats[, "RTS_ID"] + targetFeats[, "TargetName"] <- targetFeats[, "RTS_ID"] + probeColumns <- c("RTS_ID", "QCFlags", "ProbeID") + targetFeats_neg <- + targetFeats[, !colnames(targetFeats) %in% probeColumns] + targetFeats_neg$probenum <- 1 + targetFeats_neg$proberemained <- targetFeats_neg$TargetName + + # combine feature data + targetFeats <- + Biobase::AnnotatedDataFrame(rbind( + targetFeats_nonneg[rownames(targetCounts_nonneg), ], + targetFeats_neg[rownames(targetCounts_neg), ] + ), + dimLabels = c("featureNames", "featureColumns") + ) + + targetObject <- GeomxTools::NanoStringGeoMxSet( + assayData = rbind(targetCounts_nonneg, targetCounts_neg), + phenoData = Biobase::phenoData(object), + featureData = targetFeats, + experimentData = Biobase::experimentData(object), + annotation = Biobase::annotation(object), + protocolData = Biobase::protocolData(object), + featureType = "Target", + check = FALSE + ) + } ) #' Generate aggregated counts of probes for the same target @@ -176,75 +176,72 @@ setMethod( #' @aliases aggreprobe,matrix-method #' setMethod( - "aggreprobe", "matrix", - function(object, probenames, featurenames, negmod, use = c("score", "cor", "both"), corcutoff=0.85, ...) { - use <- match.arg(use) - - # Stop when there are probes with all 0 counts - if(any(rowSums(object[probenames,])==0)) - stop("There are all 0 probes in the count matrix, remove them and rerun aggreprobe.") - - - # select rows with probenames - object <- object[probenames,] - - probemat_ls <- lapply(split(probenames, featurenames), function(x) object[x, ]) - - remain <- split(probenames, featurenames) - feature_useall <- names(which(sapply(remain, length) <= 2)) - feature_toagre <- names(which(sapply(remain, length) > 2)) - ## outlier by score test - if (use == "score" | use == "both") { - scores <- BGScoreTest(object, negmod, ...)$scores - if (NCOL(scores) > 1) { - scores <- apply(scores, 1, median) - } - scores_ls <- split(scores, featurenames) - scores_ls <- scores_ls[feature_toagre] - remainscores <- lapply(scores_ls, function(x) names(which(abs(x - median(x)) <= 1.96 * 1.25 * mad(x)))) - remainscores <- c(remain[feature_useall], remainscores) - } - ## outlier by correlation - if (use == "cor" | use == "both") { - cor_ls <- lapply(probemat_ls, function(x) cor(t(x)))[feature_toagre] - remaincor <- remain[feature_useall] - remaincortemp <- remain[feature_toagre] - - - mean_cor_ls <- lapply(names(cor_ls), function(x) { - apply(cor_ls[[x]][remaincortemp[[x]], remaincortemp[[x]]], 2, function(z) (sum(z) - 1) / (length(z) - 1)) - }) - names(mean_cor_ls) <- names(cor_ls) - remaincortemp <- lapply(mean_cor_ls, function(x) { - if (all(x > corcutoff)) y <- names(x) else y <- setdiff(names(x), names(which.min(x))) - y - }) - remaincor <- c(remaincor, remaincortemp[names(which(sapply(remaincortemp, length) <= 2))]) - remaincortemp <- remaincortemp[names(which(sapply(remaincortemp, length) > 2))] - - - cor_ls <- cor_ls[names(remaincortemp)] - - - remaincor <- c(remaincor, remaincortemp) - } - if (use == "both") { - remainscores <- remainscores[unique(featurenames)] - remaincor <- remaincor[unique(featurenames)] - remain <- mapply(function(x, y) intersect(x, y), remaincor, remainscores) - } else if (use == "score") { - remain <- remainscores[unique(featurenames)] - } else { - remain <- remaincor[unique(featurenames)] - } - - probenum <- sapply(remain, length) - featuremat <- t(sapply(remain, function(x) colSums(object[x, , drop = FALSE]))) - rownames(featuremat) <- names(remain) - return(list( - remain = remain, - probenum = probenum, - featuremat = featuremat - )) + "aggreprobe", "matrix", + function(object, probenames, featurenames, negmod, use = c("score", "cor", "both"), corcutoff=0.85, ...) { + use <- match.arg(use) + + # Stop when there are probes with all 0 counts + if(any(rowSums(object[probenames,])==0)) + stop("There are all 0 probes in the count matrix, remove them and rerun aggreprobe.") + + + # select rows with probenames + object <- object[probenames,] + + probemat_ls <- lapply(split(probenames, featurenames), function(x) object[x, ]) + + remain <- split(probenames, featurenames) + feature_useall <- names(which(sapply(remain, length) <= 2)) + feature_toagre <- names(which(sapply(remain, length) > 2)) + ## outlier by score test + if (use == "score" | use == "both") { + scores <- BGScoreTest(object, negmod, ...)$scores + if (NCOL(scores) > 1) { + scores <- apply(scores, 1, median) + } + scores_ls <- split(scores, featurenames) + scores_ls <- scores_ls[feature_toagre] + remainscores <- lapply(scores_ls, function(x) names(which(abs(x - median(x)) <= 1.96 * 1.25 * mad(x)))) + remainscores <- c(remain[feature_useall], remainscores) + } + ## outlier by correlation + if (use == "cor" | use == "both") { + cor_ls <- lapply(probemat_ls, function(x) cor(t(x)))[feature_toagre] + remaincor <- remain[feature_useall] + remaincortemp <- remain[feature_toagre] + + mean_cor_ls <- lapply(names(cor_ls), function(x) { + apply(cor_ls[[x]][remaincortemp[[x]], remaincortemp[[x]]], 2, function(z) (sum(z) - 1) / (length(z) - 1)) + }) + names(mean_cor_ls) <- names(cor_ls) + remaincortemp <- lapply(mean_cor_ls, function(x) { + if (all(x > corcutoff)) y <- names(x) else y <- setdiff(names(x), names(which.min(x))) + y + }) + remaincor <- c(remaincor, remaincortemp[names(which(sapply(remaincortemp, length) <= 2))]) + remaincortemp <- remaincortemp[names(which(sapply(remaincortemp, length) > 2))] + + cor_ls <- cor_ls[names(remaincortemp)] + + remaincor <- c(remaincor, remaincortemp) + } + if (use == "both") { + remainscores <- remainscores[unique(featurenames)] + remaincor <- remaincor[unique(featurenames)] + remain <- mapply(function(x, y) intersect(x, y), remaincor, remainscores) + } else if (use == "score") { + remain <- remainscores[unique(featurenames)] + } else { + remain <- remaincor[unique(featurenames)] } + + probenum <- sapply(remain, length) + featuremat <- t(sapply(remain, function(x) colSums(object[x, , drop = FALSE]))) + rownames(featuremat) <- names(remain) + return(list( + remain = remain, + probenum = probenum, + featuremat = featuremat + )) + } ) diff --git a/R/data.R b/R/data.R index 501cc25..6bd5b95 100644 --- a/R/data.R +++ b/R/data.R @@ -1,5 +1,4 @@ #' A demo dataset for GeoMx Cancer Transcriptome Atlas (CTA) panel -#' #' A demo dataset contains 88 ROIs and 8707 features #' #' @docType data @@ -24,6 +23,19 @@ #' "kidney" +#' A demo dataset for GeoMx Human Whole Transcriptome Atlas (WTA) panel +#' +#' A demo dataset contains 276 ROIs and 18642 features +#' +#' @docType data +#' @usage data(test_data) +#' @format A set of lists used to test the function fitNBthDE +#' @keywords datasets +#' @examples +#' data(test_data) +#' +"test_data" + #' A demo example output list returned by function fitNBthDE #' #' A list used to demonstrate the function coefNBth diff --git a/data/.DS_Store b/data/.DS_Store new file mode 100644 index 0000000..5008ddf Binary files /dev/null and b/data/.DS_Store differ diff --git a/data/test_data.rda b/data/test_data.rda new file mode 100644 index 0000000..bd504d8 Binary files /dev/null and b/data/test_data.rda differ diff --git a/man/.DS_Store b/man/.DS_Store new file mode 100644 index 0000000..5008ddf Binary files /dev/null and b/man/.DS_Store differ diff --git a/man/BGScoreTest-methods.Rd b/man/BGScoreTest-methods.Rd index 0ad6e8a..dfc016d 100644 --- a/man/BGScoreTest-methods.Rd +++ b/man/BGScoreTest-methods.Rd @@ -4,6 +4,7 @@ \name{BGScoreTest} \alias{BGScoreTest} \alias{BGScoreTest,NanoStringGeoMxSet-method} +\alias{BGScoreTest,dgCMatrix-method} \alias{BGScoreTest,matrix-method} \title{Testing for features above the background} \usage{ @@ -17,7 +18,7 @@ BGScoreTest(object, ...) useprior = FALSE ) -\S4method{BGScoreTest}{matrix}( +\S4method{BGScoreTest}{dgCMatrix}( object, BGmod, adj = 1, diff --git a/man/fitNBthDE-methods.Rd b/man/fitNBthDE-methods.Rd index 106c4d2..2cdf5d4 100644 --- a/man/fitNBthDE-methods.Rd +++ b/man/fitNBthDE-methods.Rd @@ -4,6 +4,7 @@ \name{fitNBthDE} \alias{fitNBthDE} \alias{fitNBthDE,NanoStringGeoMxSet-method} +\alias{fitNBthDE,dgCMatrix-method} \alias{fitNBthDE,matrix-method} \title{Negative Binomial threshold model for differential expression analysis} \usage{ @@ -29,7 +30,34 @@ fitNBthDE(object, ...) covrob = FALSE, preci1con = 1/25, cutoff = 10, - confac = 1 + confac = 1, + run_parallel = FALSE, + n_parallel = 4 +) + +\S4method{fitNBthDE}{dgCMatrix}( + form, + annot, + object, + probenum, + features_high, + features_all, + sizefact_start, + sizefact_BG, + threshold_mean, + preci2 = 10000, + lower_threshold = 0.01, + prior_type = c("contrast", "equal"), + sizefactrec = TRUE, + size_scale = c("sum", "first"), + sizescalebythreshold = FALSE, + iterations = 2, + covrob = FALSE, + preci1con = 1/25, + cutoff = 10, + confac = 1, + run_parallel = FALSE, + n_parallel = 4L ) \S4method{fitNBthDE}{matrix}( @@ -52,7 +80,9 @@ fitNBthDE(object, ...) covrob = FALSE, preci1con = 1/25, cutoff = 10, - confac = 1 + confac = 1, + run_parallel = FALSE, + n_parallel = 4L ) } \arguments{ @@ -192,4 +222,6 @@ NBthDEmod1 <- fitNBthDE( ) + + } diff --git a/man/fitPoisBG-methods.Rd b/man/fitPoisBG-methods.Rd index f28cffd..204b22d 100644 --- a/man/fitPoisBG-methods.Rd +++ b/man/fitPoisBG-methods.Rd @@ -4,6 +4,7 @@ \name{fitPoisBG} \alias{fitPoisBG} \alias{fitPoisBG,NanoStringGeoMxSet-method} +\alias{fitPoisBG,dgCMatrix-method} \alias{fitPoisBG,matrix-method} \title{Estimate Poisson background model for either single slide or multiple slides} \usage{ @@ -18,7 +19,7 @@ fitPoisBG(object, ...) ... ) -\S4method{fitPoisBG}{matrix}(object, iterations = 10, tol = 0.001, size_scale = c("sum", "first")) +\S4method{fitPoisBG}{dgCMatrix}(object, iterations = 10, tol = 0.001, size_scale = c("sum", "first")) } \arguments{ \item{object}{count matrix with features in rows and samples in columns} diff --git a/man/test_data.Rd b/man/test_data.Rd new file mode 100644 index 0000000..110aa86 --- /dev/null +++ b/man/test_data.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{test_data} +\alias{test_data} +\title{A demo dataset for GeoMx Human Whole Transcriptome Atlas (WTA) panel} +\format{ +A set of lists used to test the function fitNBthDE +} +\usage{ +data(test_data) +} +\description{ +A demo dataset contains 276 ROIs and 18642 features +} +\examples{ +data(test_data) + +} +\keyword{datasets} diff --git a/src-i386/GeoDiff.h b/src-i386/GeoDiff.h deleted file mode 100644 index f9b4c72..0000000 --- a/src-i386/GeoDiff.h +++ /dev/null @@ -1,5 +0,0 @@ -#include "RcppArmadillo.h" -using namespace Rcpp; -// [[Rcpp::depends("RcppArmadillo")]] - -arma::vec dnbinom_mu_vec(arma::vec x, double sz, arma::vec mu, int lg); diff --git a/src-i386/Makevars b/src-i386/Makevars deleted file mode 100644 index d3e3f41..0000000 --- a/src-i386/Makevars +++ /dev/null @@ -1,14 +0,0 @@ - -## With R 3.1.0 or later, you can uncomment the following line to tell R to -## enable compilation with C++11 (where available) -## -## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider -## availability of the package we do not yet enforce this here. It is however -## recommended for client packages to set it. -## -## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP -## support within Armadillo prefers / requires it -CXX_STD = CXX11 - -PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) diff --git a/src-i386/Makevars.win b/src-i386/Makevars.win deleted file mode 100644 index d3e3f41..0000000 --- a/src-i386/Makevars.win +++ /dev/null @@ -1,14 +0,0 @@ - -## With R 3.1.0 or later, you can uncomment the following line to tell R to -## enable compilation with C++11 (where available) -## -## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider -## availability of the package we do not yet enforce this here. It is however -## recommended for client packages to set it. -## -## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP -## support within Armadillo prefers / requires it -CXX_STD = CXX11 - -PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) -PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) diff --git a/src-i386/NBthDEOptPara.cpp b/src-i386/NBthDEOptPara.cpp deleted file mode 100644 index 282e7e1..0000000 --- a/src-i386/NBthDEOptPara.cpp +++ /dev/null @@ -1,302 +0,0 @@ -#include -#include "GeoDiff.h" -#include -// [[Rcpp::depends(RcppArmadillo)]] - -#include -// [[Rcpp::depends(roptim)]] -using namespace Rcpp; -using namespace roptim; - -// You can include R code blocks in C++ files processed with sourceCpp -// (useful for testing and development). The R code will be automatically -// run after the compilation. -// - - - - - - -class NBthDE_paranll : public Functor { -public: - arma::vec y; - arma::mat X; - arma::vec alpha0; - arma::vec alpha; - arma::mat preci1; - double preci2; - double threshold0; - - - double operator()(const arma::vec &x) override { - int n = X.n_cols; - int m = y.n_elem; - arma::vec beta = x(arma::span(0,n-1)); - double r = x(n); - double threshold = x(n+1); - - - arma::vec tmp0 = arma::exp2(X*beta); - arma::vec tmp1 = alpha0*threshold+alpha%tmp0; - - - arma::vec llk = dnbinom_mu_vec(y, r, tmp1, 1); - - // Rcout << "mean(llk.row(0))" << arma::mean(llk.row(0)) << "\n"; - //arma::mat pen - arma::mat pen10 = beta.t()*preci1*beta; - double pen1 = pen10(0,0)/2.0; - //+nmh*(1.0/2.0)*pow((threshold-threshold0),2)*preci2 - return(-arma::sum(llk)+pen1+(1.0/2.0)*pow((threshold-threshold0),2)*preci2); - } - - - - void Gradient(const arma::vec &x, arma::vec &gr) override { - int n = X.n_cols; - int m = y.n_elem; - - - gr = arma::zeros(n+2); - - arma::vec beta = x(arma::span(0,n-1)); - - double r = x(n); - double threshold = x(n+1); - - - arma::vec tmp0 = arma::exp2(X*beta); - - // Rcout << "tmp0:" << tmp0(arma::span(0,4)) << "\n"; - - arma::vec tmp1 = alpha0*threshold+alpha%tmp0; - - // Rcout << "tmp1:" << tmp1(arma::span(0,4)) << "\n"; - - arma::vec tmp2 = (y/tmp1-1.0)/(1.0+tmp1/r); - - // Rcout << "tmp2:" << tmp2(arma::span(0,4)) << "\n"; - - gr(arma::span(0,n-1)) = (-log(2.0)*(tmp2%alpha%tmp0).t()*X+beta.t()*preci1).t(); - - arma::vec pLr = -arma::log(1.0+tmp1/r); - - for(int k = 0; k < y.n_elem; k++){ - for(int j = 0; j < y(k); j++){ - pLr(k) += 1.0/(j+r); - } - } - - pLr += -(y-tmp1)/(r+tmp1); - - gr(n) = -arma::sum(pLr); - - arma::mat tmp3 = tmp2.t()*alpha0; - gr(n+1) = -tmp3(0,0)+(threshold-threshold0)*preci2; - -// Rcout << "gr:" << gr << "\n"; - } - -}; - -// // [[Rcpp::export]] -// double test(arma::mat X, arma::vec y, arma::vec& alpha0, -// arma::vec alpha, arma::vec x, arma::mat preci1, -// double threshold0, double preci2){ -// NBthDE_paranll f; -// f.X=X; -// f.y=y; -// f.alpha0 = alpha0; -// f.alpha = alpha; -// f.preci1=preci1; -// f.threshold0=threshold0; -// f.preci2=preci2; -// -// return(f(x)); -// } -// -// // [[Rcpp::export]] -// arma::vec test2(arma::mat X, arma::vec y, arma::vec alpha0, -// arma::vec alpha, arma::vec x, arma::mat preci1, -// double threshold0, double preci2){ -// int n = X.n_cols; -// int m = y.n_elem; -// -// -// arma::vec gr = arma::zeros(n+2); -// -// arma::vec beta = x(arma::span(0,n-1)); -// -// double r = x(n); -// double threshold = x(n+1); -// -// -// arma::vec tmp0 = arma::exp2(X*beta); -// -// // Rcout << "tmp0:" << tmp0(arma::span(0,4)) << "\n"; -// -// arma::vec tmp1 = alpha0*threshold+alpha%tmp0; -// -// // Rcout << "tmp1:" << tmp1(arma::span(0,4)) << "\n"; -// -// arma::vec tmp2 = (y/tmp1-1.0)/(1.0+tmp1/r); -// -// // Rcout << "tmp2:" << tmp2(arma::span(0,4)) << "\n"; -// -// gr(arma::span(0,n-1)) = (-log(2.0)*(tmp2%alpha%tmp0).t()*X+beta.t()*preci1).t(); -// -// arma::vec pLr = -arma::log(1.0+tmp1/r); -// -// for(int k = 0; k < y.n_elem; k++){ -// for(int j = 0; j < y(k); j++){ -// pLr(k) += 1.0/(j+r); -// } -// } -// -// pLr += -(y-tmp1)/(r+tmp1); -// -// gr(n) = -arma::sum(pLr); -// -// arma::mat tmp3 = tmp2.t()*alpha0; -// gr(n+1) = -tmp3(0,0)+(threshold-threshold0)*preci2; -// -// Rcout << "gr:" << gr << "\n"; -// -// return(gr); -// } - - - -// [[Rcpp::export]] -List NBthDE_paraOptfeat(arma::mat& X, - arma::vec y, - arma::vec alpha0, - arma::vec alpha, - arma::mat& preci1, - double threshold0, - double preci2, - arma::vec& x0, - bool calhes) { - NBthDE_paranll f; - f.X=X; - f.y=y; - f.alpha0 = alpha0; - f.alpha = alpha; - f.preci1=preci1; - f.threshold0=threshold0; - f.preci2=preci2; - - int n = X.n_cols; - - - arma::vec lower = arma::ones(n+2) * (-100); - lower(n) = 0.01; - lower(n+1) = 0.01; - arma::vec upper = arma::ones(n+2) * 100; - upper(n) = 1000; - upper(n+1) = 1000000; - - Roptim opt("L-BFGS-B"); - opt.set_lower(lower); - opt.set_upper(upper); - //opt.control.maxit = maxit; - - opt.set_hessian(calhes); - - // opt.set_hessian(true); - opt.control.pgtol=1e-3; - arma::vec x = x0; - // arma::zeros(n+2); - // x(arma::span(0,n-1))=arma::solve(X, arma::log2(y/alpha + 0.001)); - // x(n) = 1; - // x(n+1)=threshold0; - - opt.minimize(f, x); - - // arma::mat hes = opt.hessian(); - // double hes_det = arma::log_det(hes); - // double hes_det1 = arma::log_det(hes(arma::span(1,n-1), arma::span(1,n-1))); - - return List::create(Named("par") = opt.par(), - Named("conv") = opt.convergence(), - Named("hes") = opt.hessian()); - - -} - - - - -// [[Rcpp::depends(RcppArmadillo)]] -// [[Rcpp::export]] -List NBthDE_paraOptall(arma::mat& Y, - arma::mat& X, - arma::vec& alpha0, - arma::vec& alpha, - arma::mat& preci1, - arma::vec& threshold0, - double preci2, - arma::vec& x0, - bool sizescale, - bool calhes){ - - int n = X.n_cols; - int m = Y.n_cols; - arma::mat par(n+2,m); - List hes(m); - - - arma::vec conv(m); - - if(sizescale){ - for(int i=0; i < m; i++){ - List result = NBthDE_paraOptfeat(X, Y.col(i), - threshold0(i)*alpha0, threshold0(i)*alpha, - preci1, 1.0, preci2, x0, calhes); - - par.col(i) = (as(result["par"])); - hes[i] = result["hes"]; - conv(i) = result["conv"]; - } - - } else { - for(int i=0; i < m; i++){ - List result = NBthDE_paraOptfeat(X, Y.col(i), - alpha0, alpha, - preci1, threshold0(i), preci2, x0, calhes); - - par.col(i) = (as(result["par"])); - hes[i] = result["hes"]; - conv(i) = result["conv"]; - } - } - return List::create(Named("par") = par, - Named("conv") = conv, - Named("hes") = hes); -} - - - -/*** R -#save(mat, Z, alpha0, alpha, para_fix ,Umat, threshold0, preci2, file="testData.Rdata") -#load("testData.Rdata") -#test(mat, Z, Y, alpha0=alpha0, -# alpha=alpha, x=para_fix0, NBmod$preci1, threshold0, preci2, Umat[((1:10)*20),]) - - -#lik_fun2 <- lik_probe2(mat, Z, Y, alpha0=alpha0, alpha=alpha, Umat[((1:10)*20),], threshold0, preci2) - -#lik_fun2(para_fix0) -# -# microbenchmark::microbenchmark(test(mat, Z, Y, alpha0=alpha0, alpha=alpha, x=para_fix, threshold0, preci2, Umat[((1:20)*20),]), lik_fun2(para_fix)) -# -# -# -# system.time(result1<- optim(para_fix0, lik_fun2, lower=c(rep(-Inf,ncol(mat)), 0.01,0.01), -# method="L-BFGS-B")) -# - -#system.time(result2 <- mleprobe2(mat, Z, Y, alpha0, alpha, preci1, threshold0, preci2, Umat[((1:20)*10),], para_fix0, FALSE)) - -*/ diff --git a/src-i386/NBthmDEGrad.cpp b/src-i386/NBthmDEGrad.cpp deleted file mode 100644 index e78969f..0000000 --- a/src-i386/NBthmDEGrad.cpp +++ /dev/null @@ -1,108 +0,0 @@ -#include - -#include -// [[Rcpp::depends(RcppArmadillo)]] - -#include -// [[Rcpp::depends(roptim)]] -using namespace Rcpp; -using namespace roptim; - -// You can include R code blocks in C++ files processed with sourceCpp -// (useful for testing and development). The R code will be automatically -// run after the compilation. -// - -// [[Rcpp::depends(RcppArmadillo)]] -// [[Rcpp::export]] -arma::vec NBthmDE_grad(arma::vec& y, arma::mat& X, arma::mat& Z, arma::vec& x, arma::vec& u, arma::vec& alpha0, - arma::vec& alpha, arma::mat& preci1, double preci2, double threshold0){ - int n = X.n_cols; - arma::vec gr = arma::zeros(n+2); - - arma::vec beta = x(arma::span(0,n-1)); - double r = x(n); - double threshold = x(n+1); - - arma::vec tmp0 = arma::exp2(X*beta+Z*u); - arma::vec tmp1 = alpha0*threshold+alpha%tmp0; - arma::vec tmp2 = (y/tmp1-1.0)/(1.0+tmp1/r); - - gr(arma::span(0,n-1)) = (-log(2.0)*(tmp2%alpha%tmp0).t()*X+beta.t()*preci1).t(); - - arma::vec pLr = -arma::log(1.0+tmp1/r); - for(int i = 0; i < y.n_elem; i++){ - for(int j = 0; j < y(i); j++){ - pLr(i) += 1.0/(j+r); - } - } - pLr += -(y-tmp1)/(r+tmp1); - gr(n) = -arma::sum(pLr); - - arma::mat tmp3 = tmp2.t()*alpha0; - gr(n+1) = -tmp3(0,0)+(threshold-threshold0)*preci2; - return gr; -} - - - -// [[Rcpp::depends(RcppArmadillo)]] -// [[Rcpp::export]] -arma::mat NBthmDE_gradM(arma::vec& y, arma::mat& X, arma::mat& Z, arma::vec& x, arma::mat& u_mat, arma::vec& alpha0, - arma::vec& alpha, arma::mat& preci1, double preci2, double threshold0){ - - int n = X.n_cols; - int nmh = u_mat.n_rows; - int m = y.n_elem; - - - - arma::vec beta = x(arma::span(0,n-1)); - double r = x(n); - double threshold = x(n+1); - - arma::mat tmp0 = Z*u_mat.t(); - - arma::vec tmp00 = X*beta; - - tmp0.each_col() += tmp00; - - tmp0 = arma::exp2(tmp0); - - arma::mat tmp1=tmp0; - - tmp1.each_col() %= alpha; - - arma::vec tmp11 = alpha0*threshold; - - tmp1.each_col() += tmp11; - - arma::mat tmp2(m, nmh, arma::fill::zeros); - - arma::mat grm(n+2, nmh, arma::fill::zeros); - - arma::vec pLr(m); - arma::mat tmp3(1,1); - for(int i=0; i < nmh; i++){ - tmp2.col(i) = (y/tmp1.col(i)-1.0)/(1.0+tmp1.col(i)/r); - grm(arma::span(0,n-1), i) = (-log(2.0)*(tmp2.col(i)%alpha%tmp0.col(i)).t()*X+beta.t()*preci1).t(); - pLr = -arma::log(1.0+tmp1.col(i)/r); - for(int k = 0; k < y.n_elem; k++){ - for(int j = 0; j < y(k); j++){ - pLr(k) += 1.0/(j+r); - } - } - pLr += -(y-tmp1.col(i))/(r+tmp1.col(i)); - grm(n, i) = -arma::sum(pLr); - tmp3 = tmp2.col(i).t()*alpha0; - grm(n+1, i) = -tmp3(0,0)+(threshold-threshold0)*preci2; - } - - return grm; - -} - - -/*** R - -*/ diff --git a/src-i386/NBthmDEMH.cpp b/src-i386/NBthmDEMH.cpp deleted file mode 100644 index 7a24122..0000000 --- a/src-i386/NBthmDEMH.cpp +++ /dev/null @@ -1,144 +0,0 @@ -#include // std::pow -#include "GeoDiff.h" -#include -// [[Rcpp::depends(RcppArmadillo)]] - -#include -// [[Rcpp::depends(roptim)]] -using namespace Rcpp; -using namespace roptim; - -// You can include R code blocks in C++ files processed with sourceCpp -// (useful for testing and development). The R code will be automatically -// run after the compilation. -// - - - - - -class NBthmDE_unll : public Functor { -public: - arma::mat X; - arma::mat Z; - arma::vec y; - arma::vec alpha0; - arma::vec alpha; - arma::vec x; - - double operator()(const arma::vec &u) override { - int n = X.n_cols; - arma::vec beta = x(arma::span(0,n-1)); - double r = x(n); - double threshold = x(n+1); - arma::vec tmp = arma::exp2(X*beta+Z*u); - arma::vec mu = alpha0*threshold+alpha%tmp; - - return(arma::sum(dnbinom_mu_vec(y, r, mu, 1))); - } -}; - -// // [[Rcpp::export]] -// double haha(arma::mat X, arma::mat Z, arma::vec y, arma::vec alpha0, -// arma::vec alpha, arma::vec x, arma::vec u){ -// lik_probe_mh f; -// f.X=X; -// f.Z=Z; -// f.y=y; -// f.alpha0 = alpha0; -// f.alpha=alpha; -// f.x=x; -// -// return(f(u)); -// } - -// [[Rcpp::export]] -List condi_u(arma::mat& Tem, int ind, arma::vec& u, - int temp_size){ - float mu; - float Sig; - - if(temp_size==1) { - mu = 0; - Sig = Tem(0,0); - } else { - int cluster_ind = (ind+temp_size-1)/temp_size; - //Rcout << "cluster_ind:" << cluster_ind << "\n"; - int temp_ind = ind - (cluster_ind-1)*temp_size; - //Rcout << "temp_ind:" << temp_ind << "\n"; - arma::vec u_temp = u(arma::span(((cluster_ind-1)*temp_size),(cluster_ind*temp_size-1))); - //Rcout << "u_temp:" << u_temp << "\n"; - arma::vec ind_vec = arma::linspace(0,(temp_size-1), temp_size); - arma::uvec lef = arma::find(ind_vec!=(temp_ind-1)); - arma::uvec temp_ind_v(1); - temp_ind_v.fill(temp_ind-1); - //Rcout << "lef:" << lef << "\n"; - //arma::mat mu = Tem.submat(temp_ind_v, lef)*arma::solve(Tem.submat(lef,lef), u_temp.elem(lef))); - //arma::mat Sig = Tem.submat(temp_ind_v,temp_ind_v)+Tem.submat(temp_ind_v, lef)*arma::solve(Tem.submat(lef,lef), Tem.submat(lef, temp_ind_v)); - arma::mat mu0 = Tem.submat(temp_ind_v, lef)*arma::solve(Tem.submat(lef,lef), u_temp.elem(lef)); - arma::mat Sig0 = Tem.submat(temp_ind_v,temp_ind_v)+Tem.submat(temp_ind_v, lef)*arma::solve(Tem.submat(lef,lef), Tem.submat(lef, temp_ind_v)); - mu = mu0(0,0); - Sig = Sig0(0,0); - } - - //Rcout << "mu:" << mu << "\n"; - //Rcout << "Sig:" << Sig << "\n"; - // arma::rowvec mu2 = mu(lef); - // arma::vec mu3 = mu2.elem(lef); - // Rcout << "mu2:" << mu2 << "\n"; - // // - return List::create(Named("mu") = mu, - Named("Sig") = Sig); - -} - - - -// [[Rcpp::export]] -arma::mat NBthmDE_mh(arma::mat& Tem, arma::vec& u, arma::mat& X, arma::mat& Z, arma::vec& y, arma::vec& alpha0, - arma::vec& alpha, arma::vec& x, int nmh){ - int len_u = u.n_elem; - int temp_size = Tem.n_rows; - float v=0; - arma::vec u_tmp = u; - NBthmDE_unll f; - f.X=X; - f.Z=Z; - f.y=y; - f.alpha0 = alpha0; - f.alpha=alpha; - f.x=x; - - arma::mat u_mat(nmh, len_u, arma::fill::zeros); - - for(int i=0; i < nmh; i++){ - for (int j=0; j < len_u; j++){ - u_tmp = u; - List condidis = condi_u(Tem, (j+1) ,u, temp_size); - float mu = condidis["mu"]; -// Rcout << "mu" << mu << "\n"; - float Sig = condidis["Sig"]; -// Rcout << "Sig" << Sig << "\n"; - u_tmp(j) = R::rnorm(mu, sqrt(Sig)); -// Rcout << "u_tmp(j):" << u_tmp(j) << "\n"; - - float ratio = exp(f(u_tmp)-f(u)); - if(ratio>1) { - u(j) = u_tmp(j); - } else{ - v=R::runif(0,1); - if(v -#include "GeoDiff.h" -#include -// [[Rcpp::depends(RcppArmadillo)]] - -#include -// [[Rcpp::depends(roptim)]] -using namespace Rcpp; -using namespace roptim; - -// You can include R code blocks in C++ files processed with sourceCpp -// (useful for testing and development). The R code will be automatically -// run after the compilation. -// - - - - - - -class NBthmDE_fparanll : public Functor { -public: - arma::mat X; - arma::mat Z; - arma::vec y; - arma::vec alpha0; - arma::vec alpha; - arma::mat u_mat; - arma::mat preci1; - double preci2; - double threshold0; - - double operator()(const arma::vec &x) override { - int n = X.n_cols; - int nmh = u_mat.n_rows; - int m = y.n_elem; - arma::vec beta = x(arma::span(0,n-1)); - double r = x(n); - double threshold = x(n+1); - arma::mat tmp0 = Z*u_mat.t(); - - arma::vec tmp1 = X*beta; - - tmp0.each_col() += tmp1; - - arma::mat tmp = arma::exp2(tmp0); - - tmp.each_col() %= alpha; - - arma::vec tmp2 = alpha0*threshold; - - tmp.each_col() += tmp2; - - - arma::mat llk(m,nmh, arma::fill::zeros); - - for(int i=0; i < nmh; i++){ - llk.col(i) = dnbinom_mu_vec(y, r, tmp.col(i), 1); - } - // Rcout << "mean(llk.row(0))" << arma::mean(llk.row(0)) << "\n"; - //arma::mat pen - arma::mat pen10 = beta.t()*preci1*beta; - double pen1 = pen10(0,0)/2.0; - //+nmh*(1.0/2.0)*pow((threshold-threshold0),2)*preci2 - return(-arma::accu(llk)/static_cast(nmh)+pen1+(1.0/2.0)*pow((threshold-threshold0),2)*preci2); - } - - - - void Gradient(const arma::vec &x, arma::vec &gr) override { - int n = X.n_cols; - int nmh = u_mat.n_rows; - int m = y.n_elem; - - gr = arma::zeros(n+2); - - arma::vec beta = x(arma::span(0,n-1)); - double r = x(n); - double threshold = x(n+1); - - arma::mat tmp0 = Z*u_mat.t(); - - arma::vec tmp00 = X*beta; - - tmp0.each_col() += tmp00; - - tmp0 = arma::exp2(tmp0); - - arma::mat tmp1=tmp0; - - tmp1.each_col() %= alpha; - - arma::vec tmp11 = alpha0*threshold; - - tmp1.each_col() += tmp11; - - arma::mat tmp2(m, nmh, arma::fill::zeros); - - arma::mat grm(n+2, nmh, arma::fill::zeros); - - arma::vec pLr(m); - arma::mat tmp3(1,1); - for(int i=0; i < nmh; i++){ - tmp2.col(i) = (y/tmp1.col(i)-1.0)/(1.0+tmp1.col(i)/r); - grm(arma::span(0,n-1), i) = (-log(2.0)*(tmp2.col(i)%alpha%tmp0.col(i)).t()*X+beta.t()*preci1).t(); - pLr = -arma::log(1.0+tmp1.col(i)/r); - for(int k = 0; k < y.n_elem; k++){ - for(int j = 0; j < y(k); j++){ - pLr(k) += 1.0/(j+r); - } - } - pLr += -(y-tmp1.col(i))/(r+tmp1.col(i)); - grm(n, i) = -arma::sum(pLr); - tmp3 = tmp2.col(i).t()*alpha0; - grm(n+1, i) = -tmp3(0,0)+(threshold-threshold0)*preci2; - gr += grm.col(i)/static_cast(nmh); - } - - - } -}; - -// // [[Rcpp::export]] -// double test(arma::mat X, arma::mat Z, arma::vec y, arma::vec alpha0, -// arma::vec alpha, arma::vec x, arma::mat preci1, -// double threshold0, double preci2, arma::mat u_mat){ -// lik_probe2_mh f; -// f.X=X; -// f.Z=Z; -// f.y=y; -// f.alpha0 = alpha0; -// f.alpha = alpha; -// f.u_mat=u_mat; -// f.preci1=preci1; -// f.threshold0=threshold0; -// f.preci2=preci2; -// -// return(f(x)); -// } - - - -// [[Rcpp::export]] -List NBthmDE_fparaOptfeat(arma::mat& X, - arma::mat& Z, - arma::vec& y, - arma::vec& alpha0, - arma::vec& alpha, - arma::mat& preci1, - double threshold0, - double preci2, - arma::mat& u_mat, - arma::vec& x0, - bool calhes) { - NBthmDE_fparanll f; - f.X=X; - f.Z=Z; - f.y=y; - f.alpha0 = alpha0; - f.alpha = alpha; - f.u_mat=u_mat; - f.preci1=preci1; - f.threshold0=threshold0; - f.preci2=preci2; - - int n = X.n_cols; - - - arma::vec lower = arma::ones(n+2) * (-100); - lower(n) = 0.01; - lower(n+1) = 0.01; - arma::vec upper = arma::ones(n+2) * 100; - upper(n) = 1000; - upper(n+1) = 1000000; - - Roptim opt("L-BFGS-B"); - opt.set_lower(lower); - opt.set_upper(upper); - //opt.control.maxit = maxit; - - opt.set_hessian(calhes); - - // opt.set_hessian(true); - opt.control.pgtol=1e-3; - arma::vec x = x0; - // arma::zeros(n+2); - // x(arma::span(0,n-1))=arma::solve(X, arma::log2(y/alpha + 0.001)); - // x(n) = 1; - // x(n+1)=threshold0; - - opt.minimize(f, x); - - // arma::mat hes = opt.hessian(); - // double hes_det = arma::log_det(hes); - // double hes_det1 = arma::log_det(hes(arma::span(1,n-1), arma::span(1,n-1))); - - return List::create(Named("par") = opt.par(), - Named("conv") = opt.convergence(), - Named("hes") = opt.hessian()); - - -} - - - -/*** R -#save(mat, Z, alpha0, alpha, para_fix ,Umat, threshold0, preci2, file="testData.Rdata") -#load("testData.Rdata") -#test(mat, Z, Y, alpha0=alpha0, -# alpha=alpha, x=para_fix0, NBmod$preci1, threshold0, preci2, Umat[((1:10)*20),]) - - -#lik_fun2 <- lik_probe2(mat, Z, Y, alpha0=alpha0, alpha=alpha, Umat[((1:10)*20),], threshold0, preci2) - -#lik_fun2(para_fix0) -# -# microbenchmark::microbenchmark(test(mat, Z, Y, alpha0=alpha0, alpha=alpha, x=para_fix, threshold0, preci2, Umat[((1:20)*20),]), lik_fun2(para_fix)) -# -# -# -# system.time(result1<- optim(para_fix0, lik_fun2, lower=c(rep(-Inf,ncol(mat)), 0.01,0.01), -# method="L-BFGS-B")) -# - -#system.time(result2 <- mleprobe2(mat, Z, Y, alpha0, alpha, preci1, threshold0, preci2, Umat[((1:20)*10),], para_fix0, FALSE)) - -*/ diff --git a/src-i386/NBthmDEOptU.cpp b/src-i386/NBthmDEOptU.cpp deleted file mode 100644 index 7b3a040..0000000 --- a/src-i386/NBthmDEOptU.cpp +++ /dev/null @@ -1,131 +0,0 @@ -#include -#include "GeoDiff.h" -#include -// [[Rcpp::depends(RcppArmadillo)]] - -#include -// [[Rcpp::depends(roptim)]] -using namespace Rcpp; -using namespace roptim; - -// You can include R code blocks in C++ files processed with sourceCpp -// (useful for testing and development). The R code will be automatically -// run after the compilation. -// - - - -class NBthDE_unll : public Functor { -public: - arma::mat X; - arma::mat Z; - arma::vec y; - arma::vec alpha0; - arma::vec alpha; - arma::vec x; - arma::mat preciu; - - double operator()(const arma::vec &u) override { - int n = X.n_cols; - arma::vec beta = x(arma::span(0,n-1)); - double r = x(n); - double threshold = x(n+1); - arma::vec tmp = arma::exp2(X*beta+Z*u); - arma::vec mu = alpha0*threshold+alpha%tmp; - arma::mat pen10 = u.t()*preciu*u; - double pen1 = pen10(0,0)/2.0; - return(-arma::sum(dnbinom_mu_vec(y, r, mu, 1))+pen1); - } -}; - -// // [[Rcpp::export]] -// double haha(arma::mat X, arma::mat Z, arma::vec y, arma::vec alpha0, -// arma::vec alpha, arma::vec x, arma::mat preciu, arma::vec u){ -// pos_u f; -// f.X=X; -// f.Z=Z; -// f.y=y; -// f.alpha0 = alpha0; -// f.alpha=alpha; -// f.x=x; -// f.preciu=preciu; -// return(f(u)); -// } - - - - - - -// [[Rcpp::export]] -List NBthmDE_uOpt(arma::vec& u0, arma::mat& X, arma::mat& Z, arma::vec& y, arma::vec& alpha0, - arma::vec& alpha, arma::vec& x, arma::mat& preciu, bool calhes) { - int len_u = u0.n_elem; - NBthDE_unll f; - f.X=X; - f.Z=Z; - f.y=y; - f.alpha0 = alpha0; - f.alpha = alpha; - f.x=x; - f.preciu = preciu; - - - arma::vec lower = arma::ones(len_u) * (-100); - arma::vec upper = arma::ones(len_u) * 100; - - - Roptim opt("L-BFGS-B"); - opt.set_lower(lower); - opt.set_upper(upper); - //opt.control.maxit = maxit; - - opt.set_hessian(calhes); - - // opt.set_hessian(true); - opt.control.pgtol=1e-3; - arma::vec u = u0; - // arma::zeros(n+2); - // x(arma::span(0,n-1))=arma::solve(X, arma::log2(y/alpha + 0.001)); - // x(n) = 1; - // x(n+1)=threshold0; - - opt.minimize(f, u); - - // arma::mat hes = opt.hessian(); - // double hes_det = arma::log_det(hes); - // double hes_det1 = arma::log_det(hes(arma::span(1,n-1), arma::span(1,n-1))); - - return List::create(Named("par") = opt.par(), - Named("conv") = opt.convergence(), - Named("hes") = opt.hessian()); - - -} - - - -/*** R -#save(mat, Z, alpha0, alpha, para_fix, Umat, threshold0, preci2, Y, Lambdati, file="testData.Rdata") -#load("testData.Rdata") -# -# preciu <- as.matrix(solve(Lambdati)) -# -# haha(mat, Z, Y, alpha0, -# alpha, para_fix, preciu, u) - -#lik_fun2 <- lik_probe2(mat, Z, Y, alpha0=alpha0, alpha=alpha, Umat[((1:10)*20),], threshold0, preci2) - -#lik_fun2(para_fix0) -# -# microbenchmark::microbenchmark(test(mat, Z, Y, alpha0=alpha0, alpha=alpha, x=para_fix, threshold0, preci2, Umat[((1:20)*20),]), lik_fun2(para_fix)) -# -# -# -# system.time(result1<- optim(para_fix0, lik_fun2, lower=c(rep(-Inf,ncol(mat)), 0.01,0.01), -# method="L-BFGS-B")) -# - -#system.time(result2 <- mleprobe2(mat, Z, Y, alpha0, alpha, preci1, threshold0, preci2, Umat[((1:20)*10),], para_fix0, FALSE)) - -*/ diff --git a/src-i386/PoisthNormOptPara.cpp b/src-i386/PoisthNormOptPara.cpp deleted file mode 100644 index 6e66d6d..0000000 --- a/src-i386/PoisthNormOptPara.cpp +++ /dev/null @@ -1,265 +0,0 @@ -#include // std::pow - -#include -// [[Rcpp::depends(RcppArmadillo)]] - -#include -// [[Rcpp::depends(roptim)]] -using namespace Rcpp; -using namespace roptim; - -// This is a simple example of exporting a C++ function to R. You can -// source this function into an R session using the Rcpp::sourceCpp -// function (or via the Source button on the editor toolbar). Learn -// more about Rcpp at: -// -// http://www.rcpp.org/ -// http://adv-r.had.co.nz/Rcpp.html -// http://gallery.rcpp.org/ -// - - - -// // [[Rcpp::depends(RcppArmadillo)]] -// // [[Rcpp::export]] -// double poisprobe0(NumericVector y, arma::mat X, arma::vec x,arma::vec alpha0, -// arma::vec alpha, arma::mat preci1, double preci2, double threshold0) -// { int N=y.length(); -// arma::vec tmp(N); -// NumericVector z(1); -// -// -// int n = X.n_cols; -// arma::vec beta = x(arma::span(0,n-1)); -// double threshold = x(n); -// arma::vec tmp0 = arma::exp2(X*beta); -// arma::vec tmp1 = alpha0*threshold+alpha%tmp0; -// -// for(int i=0; i < N; i++){ -// z[0] = y[i]; -// -// tmp(i) = dpois(z, tmp1(i), true)[0]; -// } -// -// arma::mat pen10 = beta.t()*preci1*beta; -// double pen1 = pen10(0,0); -// return -arma::sum(tmp)+pen1/2+pow((threshold-threshold0),2)*preci2/2;} -// -// -// -// -// // [[Rcpp::depends(RcppArmadillo)]] -// // [[Rcpp::export]] -// double poisprobe00(arma::vec y, arma::mat X, arma::vec x,arma::vec alpha0, -// arma::vec alpha, arma::mat preci1, double preci2, double threshold0) -// { int N=y.n_elem; -// arma::vec tmp(N); -// -// -// -// int n = X.n_cols; -// arma::vec beta = x(arma::span(0,n-1)); -// double threshold = x(n); -// arma::vec tmp0 = arma::exp2(X*beta); -// arma::vec tmp1 = alpha0*threshold+alpha%tmp0; -// -// tmp = y%log(tmp1)-tmp1; -// -// arma::mat pen10 = beta.t()*preci1*beta; -// double pen1 = pen10(0,0); -// return -arma::sum(tmp)+pen1/2+pow((threshold-threshold0),2)*preci2/2;} - - -// // [[Rcpp::depends(RcppArmadillo)]] -// // [[Rcpp::export]] -// arma::vec poisprobegr(arma::vec y, arma::mat X, arma::vec x,arma::vec alpha0, -// arma::vec alpha, arma::mat preci1, double preci2, double threshold0) -// { int n = X.n_cols; -// arma::vec gr = arma::zeros(n+1); -// -// arma::vec beta = x(arma::span(0,n-1)); -// double threshold = x(n); -// -// arma::vec tmp0 = arma::exp2(X*beta); -// arma::vec tmp1 = alpha0*threshold+alpha%tmp0; -// arma::vec tmp2 = (y/tmp1-1); -// -// gr(arma::span(0,n-1)) = (-log(2.0)*(tmp2%alpha%tmp0).t()*X+beta.t()*preci1).t(); -// -// arma::mat tmp3 = tmp2.t()*alpha0; -// gr(n) = -tmp3(0,0)+(threshold-threshold0)*preci2; -// return gr;} - - - - -class PoisthNorm_paranll : public Functor { -public: - arma::vec y; - arma::mat X; - arma::vec alpha0; - arma::vec alpha; - arma::mat preci1; - double preci2; - double threshold0; - - double operator()(const arma::vec &x) override { - int N=y.n_elem; - arma::vec tmp(N); - - - - int n = X.n_cols; - arma::vec beta = x(arma::span(0,n-1)); - double threshold = x(n); - arma::vec tmp0 = arma::exp2(X*beta); - arma::vec tmp1 = alpha0*threshold+alpha%tmp0; - - tmp = y%log(tmp1)-tmp1; - - arma::mat pen10 = beta.t()*preci1*beta; - double pen1 = pen10(0,0); - return -arma::sum(tmp)+pen1/2.0+pow((threshold-threshold0),2)*preci2/2.0; - } - - void Gradient(const arma::vec &x, arma::vec &gr) override { - int n = X.n_cols; - gr = arma::zeros(n+1); - - arma::vec beta = x(arma::span(0,n-1)); - double threshold = x(n); - - arma::vec tmp0 = arma::exp2(X*beta); - arma::vec tmp1 = alpha0*threshold+alpha%tmp0; - arma::vec tmp2 = (y/tmp1-1); - gr(arma::span(0,n-1)) = (-log(2.0)*(tmp2%alpha%tmp0).t()*X+beta.t()*preci1).t(); - - arma::mat tmp3 = tmp2.t()*alpha0; - gr(n) = -tmp3(0,0)+(threshold-threshold0)*preci2; - - } - -}; - - - - -// [[Rcpp::export]] -List PoisthNorm_paraOptfeat(arma::vec y, - arma::mat& X, - arma::vec alpha0, - arma::vec alpha, - arma::mat& preci1, - double preci2, - double threshold0, - bool calhes) { - PoisthNorm_paranll f; - f.X = X; - f.y = y; - f.alpha = alpha; - f.alpha0 = alpha0; - f.preci1 = preci1; - f.preci2 = preci2; - f.threshold0 = threshold0; - - int n = X.n_cols; - - - arma::vec lower = arma::ones(n+1) * (-50); - lower(n) = 0.01; - arma::vec upper = arma::ones(n+1) * 50; - upper(n) = 1000000; - - Roptim opt("L-BFGS-B"); - opt.set_lower(lower); - opt.set_upper(upper); - opt.control.maxit = 500; - opt.set_hessian(calhes); - opt.control.pgtol=1e-8; - arma::vec x = arma::zeros(n+1); - - - x(arma::span(0,n-1))=arma::solve(X, arma::log2(y/alpha + 0.001)); - - x(n)=threshold0; - - opt.minimize(f, x); - - // double hes_det = arma::log_det(hes); - // double hes_det1 = arma::log_det(hes(arma::span(1,n-1), arma::span(1,n-1))); - - return List::create(Named("par") = opt.par(), - Named("conv") = opt.convergence(), - Named("hes") = opt.hessian()); -// Named("hes_det1") = arma::log_det(hes(arma::span(1,n-1), arma::span(1,n-1)))); - - -} - - - -// [[Rcpp::depends(RcppArmadillo)]] -// [[Rcpp::export]] -List PoisthNorm_paraOptall(arma::mat& Y, - arma::mat& X, - arma::vec& alpha0, - arma::vec& alpha, - arma::mat& preci1, - arma::vec& threshold0, - double preci2, - bool sizescale, - bool calhes){ - - int n = X.n_cols; - int m = Y.n_cols; - arma::mat par(n+1,m); - // arma::vec hes_det(m); - // arma::vec hes_det1(m); - arma::vec conv(m); - List hes(m); - if(sizescale) { - for(int i=0; i < m; i++){ - List result = PoisthNorm_paraOptfeat(Y.col(i),X, - threshold0(i)*alpha0, - threshold0(i)*alpha, - preci1, - preci2, - 1.0, - calhes); - par.col(i) = (as(result["par"])); - // hes_det(i) = result["hes_det"]; - // hes_det1(i) = result["hes_det1"]; - hes[i] = result["hes"]; - conv(i) = result["conv"]; - } - } else { - for(int i=0; i < m; i++){ - List result = PoisthNorm_paraOptfeat(Y.col(i),X, - alpha0, - alpha, - preci1, - preci2, - threshold0(i), - calhes); - par.col(i) = (as(result["par"])); - // hes_det(i) = result["hes_det"]; - // hes_det1(i) = result["hes_det1"]; - hes[i] = result["hes"]; - conv(i) = result["conv"]; - } - - - } - return List::create(Named("par") = par, - Named("conv") = conv, - Named("hes") = hes); - // Named("hes_det") = hes_det, - // Named("hes_det1") = hes_det1); -} - - -// // NumericVector conv(arma::vec y){ -// // return as(wrap(y)); -// // } -// -// diff --git a/src-i386/RcppExports.cpp b/src-i386/RcppExports.cpp deleted file mode 100644 index 55ff3c8..0000000 --- a/src-i386/RcppExports.cpp +++ /dev/null @@ -1,236 +0,0 @@ -// Generated by using Rcpp::compileAttributes() -> do not edit by hand -// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 - -#include -#include - -using namespace Rcpp; - -#ifdef RCPP_USE_GLOBAL_ROSTREAM -Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); -Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); -#endif - -// NBthDE_paraOptfeat -List NBthDE_paraOptfeat(arma::mat& X, arma::vec y, arma::vec alpha0, arma::vec alpha, arma::mat& preci1, double threshold0, double preci2, arma::vec& x0, bool calhes); -RcppExport SEXP _GeoDiff_NBthDE_paraOptfeat(SEXP XSEXP, SEXP ySEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP threshold0SEXP, SEXP preci2SEXP, SEXP x0SEXP, SEXP calhesSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::vec >::type y(ySEXP); - Rcpp::traits::input_parameter< arma::vec >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preci1(preci1SEXP); - Rcpp::traits::input_parameter< double >::type threshold0(threshold0SEXP); - Rcpp::traits::input_parameter< double >::type preci2(preci2SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type x0(x0SEXP); - Rcpp::traits::input_parameter< bool >::type calhes(calhesSEXP); - rcpp_result_gen = Rcpp::wrap(NBthDE_paraOptfeat(X, y, alpha0, alpha, preci1, threshold0, preci2, x0, calhes)); - return rcpp_result_gen; -END_RCPP -} -// NBthDE_paraOptall -List NBthDE_paraOptall(arma::mat& Y, arma::mat& X, arma::vec& alpha0, arma::vec& alpha, arma::mat& preci1, arma::vec& threshold0, double preci2, arma::vec& x0, bool sizescale, bool calhes); -RcppExport SEXP _GeoDiff_NBthDE_paraOptall(SEXP YSEXP, SEXP XSEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP threshold0SEXP, SEXP preci2SEXP, SEXP x0SEXP, SEXP sizescaleSEXP, SEXP calhesSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat& >::type Y(YSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preci1(preci1SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type threshold0(threshold0SEXP); - Rcpp::traits::input_parameter< double >::type preci2(preci2SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type x0(x0SEXP); - Rcpp::traits::input_parameter< bool >::type sizescale(sizescaleSEXP); - Rcpp::traits::input_parameter< bool >::type calhes(calhesSEXP); - rcpp_result_gen = Rcpp::wrap(NBthDE_paraOptall(Y, X, alpha0, alpha, preci1, threshold0, preci2, x0, sizescale, calhes)); - return rcpp_result_gen; -END_RCPP -} -// NBthmDE_grad -arma::vec NBthmDE_grad(arma::vec& y, arma::mat& X, arma::mat& Z, arma::vec& x, arma::vec& u, arma::vec& alpha0, arma::vec& alpha, arma::mat& preci1, double preci2, double threshold0); -RcppExport SEXP _GeoDiff_NBthmDE_grad(SEXP ySEXP, SEXP XSEXP, SEXP ZSEXP, SEXP xSEXP, SEXP uSEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP preci2SEXP, SEXP threshold0SEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::vec& >::type y(ySEXP); - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type u(uSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preci1(preci1SEXP); - Rcpp::traits::input_parameter< double >::type preci2(preci2SEXP); - Rcpp::traits::input_parameter< double >::type threshold0(threshold0SEXP); - rcpp_result_gen = Rcpp::wrap(NBthmDE_grad(y, X, Z, x, u, alpha0, alpha, preci1, preci2, threshold0)); - return rcpp_result_gen; -END_RCPP -} -// NBthmDE_gradM -arma::mat NBthmDE_gradM(arma::vec& y, arma::mat& X, arma::mat& Z, arma::vec& x, arma::mat& u_mat, arma::vec& alpha0, arma::vec& alpha, arma::mat& preci1, double preci2, double threshold0); -RcppExport SEXP _GeoDiff_NBthmDE_gradM(SEXP ySEXP, SEXP XSEXP, SEXP ZSEXP, SEXP xSEXP, SEXP u_matSEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP preci2SEXP, SEXP threshold0SEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::vec& >::type y(ySEXP); - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type u_mat(u_matSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preci1(preci1SEXP); - Rcpp::traits::input_parameter< double >::type preci2(preci2SEXP); - Rcpp::traits::input_parameter< double >::type threshold0(threshold0SEXP); - rcpp_result_gen = Rcpp::wrap(NBthmDE_gradM(y, X, Z, x, u_mat, alpha0, alpha, preci1, preci2, threshold0)); - return rcpp_result_gen; -END_RCPP -} -// condi_u -List condi_u(arma::mat& Tem, int ind, arma::vec& u, int temp_size); -RcppExport SEXP _GeoDiff_condi_u(SEXP TemSEXP, SEXP indSEXP, SEXP uSEXP, SEXP temp_sizeSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat& >::type Tem(TemSEXP); - Rcpp::traits::input_parameter< int >::type ind(indSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type u(uSEXP); - Rcpp::traits::input_parameter< int >::type temp_size(temp_sizeSEXP); - rcpp_result_gen = Rcpp::wrap(condi_u(Tem, ind, u, temp_size)); - return rcpp_result_gen; -END_RCPP -} -// NBthmDE_mh -arma::mat NBthmDE_mh(arma::mat& Tem, arma::vec& u, arma::mat& X, arma::mat& Z, arma::vec& y, arma::vec& alpha0, arma::vec& alpha, arma::vec& x, int nmh); -RcppExport SEXP _GeoDiff_NBthmDE_mh(SEXP TemSEXP, SEXP uSEXP, SEXP XSEXP, SEXP ZSEXP, SEXP ySEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP xSEXP, SEXP nmhSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat& >::type Tem(TemSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type u(uSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type y(ySEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< int >::type nmh(nmhSEXP); - rcpp_result_gen = Rcpp::wrap(NBthmDE_mh(Tem, u, X, Z, y, alpha0, alpha, x, nmh)); - return rcpp_result_gen; -END_RCPP -} -// NBthmDE_fparaOptfeat -List NBthmDE_fparaOptfeat(arma::mat& X, arma::mat& Z, arma::vec& y, arma::vec& alpha0, arma::vec& alpha, arma::mat& preci1, double threshold0, double preci2, arma::mat& u_mat, arma::vec& x0, bool calhes); -RcppExport SEXP _GeoDiff_NBthmDE_fparaOptfeat(SEXP XSEXP, SEXP ZSEXP, SEXP ySEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP threshold0SEXP, SEXP preci2SEXP, SEXP u_matSEXP, SEXP x0SEXP, SEXP calhesSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type y(ySEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preci1(preci1SEXP); - Rcpp::traits::input_parameter< double >::type threshold0(threshold0SEXP); - Rcpp::traits::input_parameter< double >::type preci2(preci2SEXP); - Rcpp::traits::input_parameter< arma::mat& >::type u_mat(u_matSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type x0(x0SEXP); - Rcpp::traits::input_parameter< bool >::type calhes(calhesSEXP); - rcpp_result_gen = Rcpp::wrap(NBthmDE_fparaOptfeat(X, Z, y, alpha0, alpha, preci1, threshold0, preci2, u_mat, x0, calhes)); - return rcpp_result_gen; -END_RCPP -} -// NBthmDE_uOpt -List NBthmDE_uOpt(arma::vec& u0, arma::mat& X, arma::mat& Z, arma::vec& y, arma::vec& alpha0, arma::vec& alpha, arma::vec& x, arma::mat& preciu, bool calhes); -RcppExport SEXP _GeoDiff_NBthmDE_uOpt(SEXP u0SEXP, SEXP XSEXP, SEXP ZSEXP, SEXP ySEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP xSEXP, SEXP preciuSEXP, SEXP calhesSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::vec& >::type u0(u0SEXP); - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type Z(ZSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type y(ySEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preciu(preciuSEXP); - Rcpp::traits::input_parameter< bool >::type calhes(calhesSEXP); - rcpp_result_gen = Rcpp::wrap(NBthmDE_uOpt(u0, X, Z, y, alpha0, alpha, x, preciu, calhes)); - return rcpp_result_gen; -END_RCPP -} -// PoisthNorm_paraOptfeat -List PoisthNorm_paraOptfeat(arma::vec y, arma::mat& X, arma::vec alpha0, arma::vec alpha, arma::mat& preci1, double preci2, double threshold0, bool calhes); -RcppExport SEXP _GeoDiff_PoisthNorm_paraOptfeat(SEXP ySEXP, SEXP XSEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP preci2SEXP, SEXP threshold0SEXP, SEXP calhesSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::vec >::type y(ySEXP); - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::vec >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preci1(preci1SEXP); - Rcpp::traits::input_parameter< double >::type preci2(preci2SEXP); - Rcpp::traits::input_parameter< double >::type threshold0(threshold0SEXP); - Rcpp::traits::input_parameter< bool >::type calhes(calhesSEXP); - rcpp_result_gen = Rcpp::wrap(PoisthNorm_paraOptfeat(y, X, alpha0, alpha, preci1, preci2, threshold0, calhes)); - return rcpp_result_gen; -END_RCPP -} -// PoisthNorm_paraOptall -List PoisthNorm_paraOptall(arma::mat& Y, arma::mat& X, arma::vec& alpha0, arma::vec& alpha, arma::mat& preci1, arma::vec& threshold0, double preci2, bool sizescale, bool calhes); -RcppExport SEXP _GeoDiff_PoisthNorm_paraOptall(SEXP YSEXP, SEXP XSEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP threshold0SEXP, SEXP preci2SEXP, SEXP sizescaleSEXP, SEXP calhesSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat& >::type Y(YSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); - Rcpp::traits::input_parameter< arma::mat& >::type preci1(preci1SEXP); - Rcpp::traits::input_parameter< arma::vec& >::type threshold0(threshold0SEXP); - Rcpp::traits::input_parameter< double >::type preci2(preci2SEXP); - Rcpp::traits::input_parameter< bool >::type sizescale(sizescaleSEXP); - Rcpp::traits::input_parameter< bool >::type calhes(calhesSEXP); - rcpp_result_gen = Rcpp::wrap(PoisthNorm_paraOptall(Y, X, alpha0, alpha, preci1, threshold0, preci2, sizescale, calhes)); - return rcpp_result_gen; -END_RCPP -} -// dnbinom_mu_vec -arma::vec dnbinom_mu_vec(arma::vec x, double sz, arma::vec mu, int lg); -RcppExport SEXP _GeoDiff_dnbinom_mu_vec(SEXP xSEXP, SEXP szSEXP, SEXP muSEXP, SEXP lgSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::vec >::type x(xSEXP); - Rcpp::traits::input_parameter< double >::type sz(szSEXP); - Rcpp::traits::input_parameter< arma::vec >::type mu(muSEXP); - Rcpp::traits::input_parameter< int >::type lg(lgSEXP); - rcpp_result_gen = Rcpp::wrap(dnbinom_mu_vec(x, sz, mu, lg)); - return rcpp_result_gen; -END_RCPP -} - -static const R_CallMethodDef CallEntries[] = { - {"_GeoDiff_NBthDE_paraOptfeat", (DL_FUNC) &_GeoDiff_NBthDE_paraOptfeat, 9}, - {"_GeoDiff_NBthDE_paraOptall", (DL_FUNC) &_GeoDiff_NBthDE_paraOptall, 10}, - {"_GeoDiff_NBthmDE_grad", (DL_FUNC) &_GeoDiff_NBthmDE_grad, 10}, - {"_GeoDiff_NBthmDE_gradM", (DL_FUNC) &_GeoDiff_NBthmDE_gradM, 10}, - {"_GeoDiff_condi_u", (DL_FUNC) &_GeoDiff_condi_u, 4}, - {"_GeoDiff_NBthmDE_mh", (DL_FUNC) &_GeoDiff_NBthmDE_mh, 9}, - {"_GeoDiff_NBthmDE_fparaOptfeat", (DL_FUNC) &_GeoDiff_NBthmDE_fparaOptfeat, 11}, - {"_GeoDiff_NBthmDE_uOpt", (DL_FUNC) &_GeoDiff_NBthmDE_uOpt, 9}, - {"_GeoDiff_PoisthNorm_paraOptfeat", (DL_FUNC) &_GeoDiff_PoisthNorm_paraOptfeat, 8}, - {"_GeoDiff_PoisthNorm_paraOptall", (DL_FUNC) &_GeoDiff_PoisthNorm_paraOptall, 9}, - {"_GeoDiff_dnbinom_mu_vec", (DL_FUNC) &_GeoDiff_dnbinom_mu_vec, 4}, - {NULL, NULL, 0} -}; - -RcppExport void R_init_GeoDiff(DllInfo *dll) { - R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); - R_useDynamicSymbols(dll, FALSE); -} diff --git a/src-i386/dnbinom_mu_vec.cpp b/src-i386/dnbinom_mu_vec.cpp deleted file mode 100644 index dc857b5..0000000 --- a/src-i386/dnbinom_mu_vec.cpp +++ /dev/null @@ -1,14 +0,0 @@ -#include -// [[Rcpp::depends(RcppArmadillo)]] -using namespace Rcpp; - - -// [[Rcpp::export]] -arma::vec dnbinom_mu_vec(arma::vec x, double sz, arma::vec mu, int lg){ - int N = x.n_elem; - arma::vec prob(N); - for(int i=0; i #include "GeoDiff.h" +#include #include +#include +#include + +using namespace std::chrono; + + +// written by Lei Yang (lyang@nanostring.com) and Ned Booker (ned@procogia.com) +// some of the parameters are not clearly named (Ned doesn't know what biological significance they have) +// see Lei's paper (see NBthDE_model_description.pdf in this repo). +// this code defines an optimisation function (NBthDE_paranll) +// defines a function, given some data, that returns the optimised parameters of that function (NBthDE_paraOptfeat) +// and defines a function to iterate through all the columns of a given + // [[Rcpp::depends(RcppArmadillo)]] #include @@ -12,172 +27,145 @@ using namespace roptim; // (useful for testing and development). The R code will be automatically // run after the compilation. // +// original dnbinom_mu vector function - makes N separate calls to the built in +// R dnbimon_mu function - this is fairly slow (calculates everything and then takes logs) +arma::vec ref_dnbinom_mu_vec(const arma::vec &y, + const double r, + const arma::vec &tmp1){ + int N = y.n_elem; + arma::vec prob(N); + for(int i=0; i(tmpneg1.n_elem); + for(int l=0;l(n+2); - - arma::vec beta = x(arma::span(0,n-1)); - + arma::vec beta = x(arma::span(0,n-1)); //subset of vecotr x + double r = x(n); double threshold = x(n+1); - - - arma::vec tmp0 = arma::exp2(X*beta); - - // Rcout << "tmp0:" << tmp0(arma::span(0,4)) << "\n"; - + + arma::vec tmpneg1 = X*beta; // calculate tmp0_i = 2^(X_ij * beta_j) in stages to speed it up + arma::vec tmp0 = arma::zeros(tmpneg1.n_elem); + for(int l=0;l(tmp4.n_elem); + for(int k = 0; k < m; k++){ + pLr(k) = -log(tmp4(k)); for(int j = 0; j < y(k); j++){ pLr(k) += 1.0/(j+r); } } + pLr += -(y-tmp1)/(r+tmp1); - gr(n) = -arma::sum(pLr); - arma::mat tmp3 = tmp2.t()*alpha0; + gr(n+1) = -tmp3(0,0)+(threshold-threshold0)*preci2; - -// Rcout << "gr:" << gr << "\n"; - } - + + } + }; - -// // [[Rcpp::export]] -// double test(arma::mat X, arma::vec y, arma::vec& alpha0, -// arma::vec alpha, arma::vec x, arma::mat preci1, -// double threshold0, double preci2){ -// NBthDE_paranll f; -// f.X=X; -// f.y=y; -// f.alpha0 = alpha0; -// f.alpha = alpha; -// f.preci1=preci1; -// f.threshold0=threshold0; -// f.preci2=preci2; -// -// return(f(x)); -// } -// -// // [[Rcpp::export]] -// arma::vec test2(arma::mat X, arma::vec y, arma::vec alpha0, -// arma::vec alpha, arma::vec x, arma::mat preci1, -// double threshold0, double preci2){ -// int n = X.n_cols; -// int m = y.n_elem; -// -// -// arma::vec gr = arma::zeros(n+2); -// -// arma::vec beta = x(arma::span(0,n-1)); -// -// double r = x(n); -// double threshold = x(n+1); -// -// -// arma::vec tmp0 = arma::exp2(X*beta); -// -// // Rcout << "tmp0:" << tmp0(arma::span(0,4)) << "\n"; -// -// arma::vec tmp1 = alpha0*threshold+alpha%tmp0; -// -// // Rcout << "tmp1:" << tmp1(arma::span(0,4)) << "\n"; -// -// arma::vec tmp2 = (y/tmp1-1.0)/(1.0+tmp1/r); -// -// // Rcout << "tmp2:" << tmp2(arma::span(0,4)) << "\n"; -// -// gr(arma::span(0,n-1)) = (-log(2.0)*(tmp2%alpha%tmp0).t()*X+beta.t()*preci1).t(); -// -// arma::vec pLr = -arma::log(1.0+tmp1/r); -// -// for(int k = 0; k < y.n_elem; k++){ -// for(int j = 0; j < y(k); j++){ -// pLr(k) += 1.0/(j+r); -// } -// } -// -// pLr += -(y-tmp1)/(r+tmp1); -// -// gr(n) = -arma::sum(pLr); -// -// arma::mat tmp3 = tmp2.t()*alpha0; -// gr(n+1) = -tmp3(0,0)+(threshold-threshold0)*preci2; -// -// Rcout << "gr:" << gr << "\n"; -// -// return(gr); -// } - - - + // [[Rcpp::export]] -List NBthDE_paraOptfeat(arma::mat& X, - arma::vec y, - arma::vec alpha0, - arma::vec alpha, - arma::mat& preci1, - double threshold0, - double preci2, - arma::vec& x0, - bool calhes) { +List NBthDE_paraOptfeat(arma::mat& X, //X = model.matrix(form, data = annot) in R code (fitNBthDE_funct in NBthDE.R) + arma::vec y, //data vector part of t(object[features_high, ]) in R code (fitNBthDE_funct in NBthDE.R) + arma::vec alpha0, //sizefact_BG in R code + arma::vec alpha,//sizefact in R code + arma::mat& preci1, //related to preci1con (see NBthDE.R lines 311-317) + double threshold0, //threshold_mean * probenum[features_high] + double preci2, //(preci2 in fitNBthDE_funct in NBthDE.R (defaults to 10000)) + arma::vec& x0, //startpara <- c(rep(0, ncol(X)), 1, (1.0 or threshold_mean)) + bool calhes) { //(iter == iterations) (see fitNBthDE_funct in NBthDE.R for details) NBthDE_paranll f; f.X=X; f.y=y; @@ -186,117 +174,103 @@ List NBthDE_paraOptfeat(arma::mat& X, f.preci1=preci1; f.threshold0=threshold0; f.preci2=preci2; - + int n = X.n_cols; - - arma::vec lower = arma::ones(n+2) * (-100); lower(n) = 0.01; lower(n+1) = 0.01; arma::vec upper = arma::ones(n+2) * 100; upper(n) = 1000; upper(n+1) = 1000000; - + Roptim opt("L-BFGS-B"); opt.set_lower(lower); opt.set_upper(upper); - //opt.control.maxit = maxit; - + + opt.set_hessian(calhes); - - // opt.set_hessian(true); + opt.control.pgtol=1e-3; arma::vec x = x0; - // arma::zeros(n+2); - // x(arma::span(0,n-1))=arma::solve(X, arma::log2(y/alpha + 0.001)); - // x(n) = 1; - // x(n+1)=threshold0; - + opt.minimize(f, x); - - // arma::mat hes = opt.hessian(); - // double hes_det = arma::log_det(hes); - // double hes_det1 = arma::log_det(hes(arma::span(1,n-1), arma::span(1,n-1))); - + + return List::create(Named("par") = opt.par(), Named("conv") = opt.convergence(), Named("hes") = opt.hessian()); - - + + } - - - // [[Rcpp::depends(RcppArmadillo)]] // [[Rcpp::export]] -List NBthDE_paraOptall(arma::mat& Y, - arma::mat& X, - arma::vec& alpha0, - arma::vec& alpha, - arma::mat& preci1, - arma::vec& threshold0, - double preci2, - arma::vec& x0, - bool sizescale, - bool calhes){ - +List NBthDE_paraOptall(arma::sp_mat &Y, //t(object[features_high, ]) in R code (fitNBthDE_funct in NBthDE.R) + arma::mat &X, // X = model.matrix(form, data = annot) in R code (fitNBthDE_funct in NBthDE.R) + arma::vec &alpha0, //sizefact_BG in R code + arma::vec &alpha, //sizefact in R code + arma::mat &preci1, //related to preci1con (see NBthDE.R lines 311-317) + arma::vec &threshold0, //threshold_mean * probenum[features_high] + double preci2, //(preci2 in fitNBthDE_funct in NBthDE.R (defaults to 10000)) + arma::vec &x0, //startpara <- c(rep(0, ncol(X)), 1, (1.0 or threshold_mean)) + bool sizescale, //sizescalebythreshold (defaults to FALSE) + bool calhes){ //(iter == iterations) (see fitNBthDE_funct in NBthDE.R for details) + int n = X.n_cols; int m = Y.n_cols; + int n_rows = Y.n_rows; arma::mat par(n+2,m); List hes(m); - - + + arma::vec conv(m); - + Rcout << "number of columns: "<< m << " \n"; + int failcount = 0; if(sizescale){ for(int i=0; i < m; i++){ - List result = NBthDE_paraOptfeat(X, Y.col(i), - threshold0(i)*alpha0, threshold0(i)*alpha, - preci1, 1.0, preci2, x0, calhes); - - par.col(i) = (as(result["par"])); - hes[i] = result["hes"]; - conv(i) = result["conv"]; + try{ + arma::vec Ycol(n_rows); + for(int k=0; k(result["par"])); + hes[i] = result["hes"]; + conv(i) = result["conv"]; + } + catch (...){ + failcount++; + } } } else { for(int i=0; i < m; i++){ - List result = NBthDE_paraOptfeat(X, Y.col(i), - alpha0, alpha, - preci1, threshold0(i), preci2, x0, calhes); - - par.col(i) = (as(result["par"])); - hes[i] = result["hes"]; - conv(i) = result["conv"]; + try{ + arma::vec Ycol(n_rows); + for(int k=0; k(result["par"])); + hes[i] = result["hes"]; + conv(i) = result["conv"]; + } + catch (...){ + failcount++; + } } } + Rcout << "failed columns: " << failcount << "\n"; return List::create(Named("par") = par, Named("conv") = conv, Named("hes") = hes); } - - - -/*** R -#save(mat, Z, alpha0, alpha, para_fix ,Umat, threshold0, preci2, file="testData.Rdata") -#load("testData.Rdata") -#test(mat, Z, Y, alpha0=alpha0, -# alpha=alpha, x=para_fix0, NBmod$preci1, threshold0, preci2, Umat[((1:10)*20),]) - - -#lik_fun2 <- lik_probe2(mat, Z, Y, alpha0=alpha0, alpha=alpha, Umat[((1:10)*20),], threshold0, preci2) - -#lik_fun2(para_fix0) -# -# microbenchmark::microbenchmark(test(mat, Z, Y, alpha0=alpha0, alpha=alpha, x=para_fix, threshold0, preci2, Umat[((1:20)*20),]), lik_fun2(para_fix)) -# -# -# -# system.time(result1<- optim(para_fix0, lik_fun2, lower=c(rep(-Inf,ncol(mat)), 0.01,0.01), -# method="L-BFGS-B")) -# - -#system.time(result2 <- mleprobe2(mat, Z, Y, alpha0, alpha, preci1, threshold0, preci2, Umat[((1:20)*10),], para_fix0, FALSE)) - -*/ diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 55ff3c8..8e678fc 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -31,12 +31,12 @@ BEGIN_RCPP END_RCPP } // NBthDE_paraOptall -List NBthDE_paraOptall(arma::mat& Y, arma::mat& X, arma::vec& alpha0, arma::vec& alpha, arma::mat& preci1, arma::vec& threshold0, double preci2, arma::vec& x0, bool sizescale, bool calhes); +List NBthDE_paraOptall(arma::sp_mat& Y, arma::mat& X, arma::vec& alpha0, arma::vec& alpha, arma::mat& preci1, arma::vec& threshold0, double preci2, arma::vec& x0, bool sizescale, bool calhes); RcppExport SEXP _GeoDiff_NBthDE_paraOptall(SEXP YSEXP, SEXP XSEXP, SEXP alpha0SEXP, SEXP alphaSEXP, SEXP preci1SEXP, SEXP threshold0SEXP, SEXP preci2SEXP, SEXP x0SEXP, SEXP sizescaleSEXP, SEXP calhesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::mat& >::type Y(YSEXP); + Rcpp::traits::input_parameter< arma::sp_mat& >::type Y(YSEXP); Rcpp::traits::input_parameter< arma::mat& >::type X(XSEXP); Rcpp::traits::input_parameter< arma::vec& >::type alpha0(alpha0SEXP); Rcpp::traits::input_parameter< arma::vec& >::type alpha(alphaSEXP); diff --git a/src/dnbinom_mu_vec.cpp b/src/dnbinom_mu_vec.cpp index dc857b5..da5e69e 100644 --- a/src/dnbinom_mu_vec.cpp +++ b/src/dnbinom_mu_vec.cpp @@ -7,6 +7,7 @@ using namespace Rcpp; arma::vec dnbinom_mu_vec(arma::vec x, double sz, arma::vec mu, int lg){ int N = x.n_elem; arma::vec prob(N); + //Rcpp::dnbinom_mu(x, sz, mu, lg) for(int i=0; i NSGMS - # Calling QuanRange this early should error since fitPoisBG(_sp) hasn't been run yet. - expect_error( - QuanRange(NSGMS, split = FALSE, probs = c(0.75, 0.8, 0.9, 0.95)), - "Please run \`fitPoisBG\` first." - ) - # Two datasets to analyze: without (NSGMS) and with (NSGMS_sp) slide groupings - # Estimate Poisson background sample-feature factor mode - NSGMS <- fitPoisBG(NSGMS) - NSGMS <- aggreprobe(NSGMS, use = "cor") - - # Estimate Poisson background sample-feature factor model for multiple slides - NSGMS_sp <- fitPoisBG(NSGMS, groupvar = "slide name", size_scale = "sum") - # Calling QuanRange on NSGMS with split=TRUE should error - expect_error( - QuanRange(NSGMS, split = TRUE, probs = c(0.75, 0.8, 0.9, 0.95)), - "Please run `fitPoisBG` first with `groupvar`." - ) - - # Case 1: "single" slide consideration - test_probs <- c(0.75, 0.8, 0.9, 0.95) - case1 <- QuanRange(NSGMS, - split = FALSE, - probs = test_probs - ) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case1, "NanoStringGeoMxSet")) - # with length same as length of sample IDs (rownames) in phenoData - # for each probs input. - for (p in test_probs) { - p_len <- length(na.omit(pData(case1)[, which(colnames(pData(case1)) == p)])) # makes sure no NAs are present - expect_true(length(row.names(pData(case1))) == p_len) - } - # The colname is the input prob. - expect_true(all(test_probs %in% colnames(pData(case1)))) - - # Case 2: "multiple" slides consideration - case2 <- QuanRange(NSGMS_sp, - split = TRUE, - probs = test_probs - ) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case2, "NanoStringGeoMxSet")) - # with length same as length of sample IDs (rownames) in phenoData - # for each probs input. - unique_ids <- unique(pData(NSGMS_sp)$`slide name`) # pull out the unique ids - - for (p in test_probs) { - p_len <- length(na.omit(pData(case2)[, which(colnames(pData(case2)) == p)])) # makes sure no NAs are present - expect_true(length(row.names(pData(case2))) == p_len) - } - # The colname is the input prob. - expect_true(all(test_probs %in% colnames(pData(case2)))) - - # Expect that quantRange values are differnt between single and multiple cases - expect_false(all(pData(case1)$`0.8` == pData(case2)$`0.8`)) + + #### Specs for QuanRange + # 1 The function outputs a GeoMx S4 class + # with length same as length of sample IDs (rownames) in phenoData for each probs input. + # The colname is the input prob. + + + library(dplyr) + ### Initializing CTA objects before running tests + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + withr::local_dir(tmp_dir) + # Run data through (required) upstream functions + data("demoData") # for tests of structure of demoData itself, see test-scoretest.R + NSGMS <- demoData # NanoStringGeoMxSet => NSGMS + # Calling QuanRange this early should error since fitPoisBG(_sp) hasn't been run yet. + expect_error( + QuanRange(NSGMS, split = FALSE, probs = c(0.75, 0.8, 0.9, 0.95)), + "Please run \`fitPoisBG\` first." + ) + # Two datasets to analyze: without (NSGMS) and with (NSGMS_sp) slide groupings + # Estimate Poisson background sample-feature factor mode + NSGMS <- fitPoisBG(NSGMS) + NSGMS <- aggreprobe(NSGMS, use = "cor") + + # Estimate Poisson background sample-feature factor model for multiple slides + NSGMS_sp <- fitPoisBG(NSGMS, groupvar = "slide name", size_scale = "sum") + # Calling QuanRange on NSGMS with split=TRUE should error + expect_error( + QuanRange(NSGMS, split = TRUE, probs = c(0.75, 0.8, 0.9, 0.95)), + "Please run `fitPoisBG` first with `groupvar`." + ) + + # Case 1: "single" slide consideration + test_probs <- c(0.75, 0.8, 0.9, 0.95) + case1 <- QuanRange(NSGMS, + split = FALSE, + probs = test_probs + ) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case1, "NanoStringGeoMxSet")) + # with length same as length of sample IDs (rownames) in phenoData + # for each probs input. + for (p in test_probs) { + p_len <- length(na.omit(pData(case1)[, which(colnames(pData(case1)) == p)])) # makes sure no NAs are present + expect_true(length(row.names(pData(case1))) == p_len) + } + # The colname is the input prob. + expect_true(all(test_probs %in% colnames(pData(case1)))) + + # Case 2: "multiple" slides consideration + case2 <- QuanRange(NSGMS_sp, + split = TRUE, + probs = test_probs + ) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case2, "NanoStringGeoMxSet")) + # with length same as length of sample IDs (rownames) in phenoData + # for each probs input. + unique_ids <- unique(pData(NSGMS_sp)$`slide name`) # pull out the unique ids + + for (p in test_probs) { + p_len <- length(na.omit(pData(case2)[, which(colnames(pData(case2)) == p)])) # makes sure no NAs are present + expect_true(length(row.names(pData(case2))) == p_len) + } + # The colname is the input prob. + expect_true(all(test_probs %in% colnames(pData(case2)))) + + # Expect that quantRange values are differnt between single and multiple cases + expect_false(all(pData(case1)$`0.8` == pData(case2)$`0.8`)) }) ## 2 It returns an error without running fitPoisBG. test_that("It returns an error without running fitPoisBG.", { - expect_error( - QuanRange(demoData, probs = c(0.75, 0.8, 0.9, 0.95)), - "Please run `fitPoisBG` first" - ) - expect_error( - QuanRange(demoData, probs = c(0.75, 0.8, 0.9, 0.95), split = TRUE), - "Please run `fitPoisBG` first" - ) + expect_error( + QuanRange(demoData, probs = c(0.75, 0.8, 0.9, 0.95)), + "Please run `fitPoisBG` first" + ) + expect_error( + QuanRange(demoData, probs = c(0.75, 0.8, 0.9, 0.95), split = TRUE), + "Please run `fitPoisBG` first" + ) }) ## 3 It returns an error if split is TRUE but no corresponding fitPoisBG is called previously. test_that("It returns an error if split is TRUE but no corresponding fitPoisBG is called previously.", { - res <- fitPoisBG(demoData, size_scale = "first") - expect_error( - QuanRange(res, split = TRUE, probs = c(0.75, 0.8, 0.9, 0.95)), - "Please run `fitPoisBG` first with `groupvar`" - ) + res <- fitPoisBG(demoData, size_scale = "first") + expect_error( + QuanRange(res, split = TRUE, probs = c(0.75, 0.8, 0.9, 0.95)), + "Please run `fitPoisBG` first with `groupvar`" + ) }) diff --git a/tests/testthat/test-aggreprobe.R b/tests/testthat/test-aggreprobe.R index 5b5c218..4b93a02 100644 --- a/tests/testthat/test-aggreprobe.R +++ b/tests/testthat/test-aggreprobe.R @@ -20,69 +20,69 @@ bothAgg <- aggreprobe(demoData, split=FALSE, use="both") # Spec 1: The function shall aggregate the probes depending on the argument provided. test_that("Aggreprobe function aggregates the probes by use method", { - expect_false(all(exprs(scoreAgg) == exprs(corAgg))) - expect_false(all(exprs(corAgg) == exprs(bothAgg))) - expect_false(all(exprs(scoreAgg) == exprs(bothAgg))) + expect_false(all(exprs(scoreAgg) == exprs(corAgg))) + expect_false(all(exprs(corAgg) == exprs(bothAgg))) + expect_false(all(exprs(scoreAgg) == exprs(bothAgg))) }) aggdObjs <- list(score=scoreAgg, cor=corAgg, both=bothAgg) for (used in names(aggdObjs)) { - aggd <- aggdObjs[[used]] - negAggd <- aggd[which(fData(aggd)$CodeClass == "Negative"), ] - negAggd <- negAggd[featureNames(demoNeg), ] - # Spec 2: The function returns a GeoMxSet object when given a GeoMxSet - # object as input. - test_that(paste0(used, ": aggreprobe function aggregates by use method"), { - expect_true(inherits(aggd, "NanoStringGeoMxSet")) - }) - # Spec 3: For negative probes, the expression matrix and the target - # feature data available prior to collapsing shall match after - # collapsing except TargetName. - test_that(paste0(used, ": neg probes are not collapsed"), { - targetLabels <- intersect(fvarLabels(demoNeg), fvarLabels(negAggd)) - targetLabels <- targetLabels[targetLabels != "TargetName"] - expect_equal(exprs(negAggd), exprs(demoNeg)) - expect_equal( - fData(negAggd)[, targetLabels], fData(demoNeg)[, targetLabels]) - }) - # Spec 4: TargetName for negative probes shall be updated to probe IDs - # after collapsing. - test_that(paste0(used, ": neg probe target names replaced by probe IDs"), { - expect_equal(fData(negAggd)[["TargetName"]], fData(demoNeg)[["RTS_ID"]]) - }) - # Spec 5: For the non-negative probes, selected by the use method will be - # aggregated by sum into one target count. - test_that(paste0(used, "aggregation is by sum"), { - endoAggd <- aggd[which(fData(aggd)$CodeClass != "Negative"), ] - testNames <- sample(featureNames(endoAggd), 50) - for (testName in testNames) { - probeNames <- unlist(fData(endoAggd)[testName, "proberemained"]) - expectedCount <- - apply(exprs(demoData)[probeNames, , drop=FALSE], 2, sum) - expect_equal(exprs(endoAggd)[testName, ], expectedCount) - } - }) - # Spec 6: The resulting object shall have the same size of feature names - # as negative probe names plus non-negative target names. - test_that(paste0(used, "feature length is correct"), { - endoObj <- demoData[which(fData(demoData)$CodeClass != "Negative"), ] - featLen <- - length(unique(fData(endoObj)[["TargetName"]])) + dim(demoNeg)[1L] - expect_equal(dim(aggd)[1L], featLen) - }) - # Spec 7: Single probe targets shall be returned without aggregation - test_that(paste0(used, "WTA data (single probe) is not aggregated"), { - data("kidney") - all0probeidx <- which(rowSums(exprs(kidney))==0) - kidney <- kidney[-all0probeidx, ] - kidney <- fitPoisBG(kidney, size_scale = "sum") - aggdKid <- aggreprobe(kidney, split=FALSE, use = used) - endoKid <- kidney[which(fData(kidney)$CodeClass != "Negative"), ] - negKid <- kidney[which(fData(kidney)$CodeClass == "Negative"), ] - kidLen <- - length(unique(fData(endoKid)[["TargetName"]])) + dim(negKid)[1L] - expect_equal(dim(aggdKid)[1L], kidLen) - endoAggdKid <- aggdKid[which(fData(aggdKid)$CodeClass != "Negative"), ] - expect_true(all(exprs(endoAggdKid)[fData(endoKid)$TargetName, ] == exprs(endoKid))) - }) + aggd <- aggdObjs[[used]] + negAggd <- aggd[which(fData(aggd)$CodeClass == "Negative"), ] + negAggd <- negAggd[featureNames(demoNeg), ] + # Spec 2: The function returns a GeoMxSet object when given a GeoMxSet + # object as input. + test_that(paste0(used, ": aggreprobe function aggregates by use method"), { + expect_true(inherits(aggd, "NanoStringGeoMxSet")) + }) + # Spec 3: For negative probes, the expression matrix and the target + # feature data available prior to collapsing shall match after + # collapsing except TargetName. + test_that(paste0(used, ": neg probes are not collapsed"), { + targetLabels <- intersect(fvarLabels(demoNeg), fvarLabels(negAggd)) + targetLabels <- targetLabels[targetLabels != "TargetName"] + expect_equal(exprs(negAggd), exprs(demoNeg)) + expect_equal( + fData(negAggd)[, targetLabels], fData(demoNeg)[, targetLabels]) + }) + # Spec 4: TargetName for negative probes shall be updated to probe IDs + # after collapsing. + test_that(paste0(used, ": neg probe target names replaced by probe IDs"), { + expect_equal(fData(negAggd)[["TargetName"]], fData(demoNeg)[["RTS_ID"]]) + }) + # Spec 5: For the non-negative probes, selected by the use method will be + # aggregated by sum into one target count. + test_that(paste0(used, "aggregation is by sum"), { + endoAggd <- aggd[which(fData(aggd)$CodeClass != "Negative"), ] + testNames <- sample(featureNames(endoAggd), 50) + for (testName in testNames) { + probeNames <- unlist(fData(endoAggd)[testName, "proberemained"]) + expectedCount <- + apply(exprs(demoData)[probeNames, , drop=FALSE], 2, sum) + expect_equal(exprs(endoAggd)[testName, ], expectedCount) + } + }) + # Spec 6: The resulting object shall have the same size of feature names + # as negative probe names plus non-negative target names. + test_that(paste0(used, "feature length is correct"), { + endoObj <- demoData[which(fData(demoData)$CodeClass != "Negative"), ] + featLen <- + length(unique(fData(endoObj)[["TargetName"]])) + dim(demoNeg)[1L] + expect_equal(dim(aggd)[1L], featLen) + }) + # Spec 7: Single probe targets shall be returned without aggregation + test_that(paste0(used, "WTA data (single probe) is not aggregated"), { + data("kidney") + all0probeidx <- which(rowSums(exprs(kidney))==0) + kidney <- kidney[-all0probeidx, ] + kidney <- fitPoisBG(kidney, size_scale = "sum") + aggdKid <- aggreprobe(kidney, split=FALSE, use = used) + endoKid <- kidney[which(fData(kidney)$CodeClass != "Negative"), ] + negKid <- kidney[which(fData(kidney)$CodeClass == "Negative"), ] + kidLen <- + length(unique(fData(endoKid)[["TargetName"]])) + dim(negKid)[1L] + expect_equal(dim(aggdKid)[1L], kidLen) + endoAggdKid <- aggdKid[which(fData(aggdKid)$CodeClass != "Negative"), ] + expect_true(all(exprs(endoAggdKid)[fData(endoKid)$TargetName, ] == exprs(endoKid))) + }) } diff --git a/tests/testthat/test-coefNBth.R b/tests/testthat/test-coefNBth.R index ee44876..9d62904 100644 --- a/tests/testthat/test-coefNBth.R +++ b/tests/testthat/test-coefNBth.R @@ -1,34 +1,34 @@ test_that("coefNBth produces desired results from output of fitNBthDE", { - + #### Specs for coefNBth - - + + ## 1. when fullpara=TRUE, the output parameters should be regression coefficients, threshold and r in a list. ## Both threshold and r are positive. ## 2. when fullpara=FALSE, the output parameters should be regression coefficients only in a list - + library(dplyr) ### Initializing CTA objects before running tests # Create temporary directory that will get destroyed after this block is executed. tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") withr::local_dir(tmp_dir) # Run data through (required) upstream functions - - + + data(NBthDEmod2) coeffull <- coefNBth(NBthDEmod2, fullpara=TRUE) coefreg <- coefNBth(NBthDEmod2, fullpara=FALSE) - + ## 1. when fullpara=TRUE, the output parameters should be regression coefficients, threshold and r in a list. ## Both threshold and r are positive. - - + + expect_true(all(c(colnames(NBthDEmod2$X), c("r", "threshold")) == rownames(coeffull$estimate))) expect_true(all(coeffull$estimate["r", ] > 0)) expect_true(all(coeffull$estimate["threshold", ] > 0)) - + ## 2. when fullpara=FALSE, the output parameters should be regression coefficients only in a list - + expect_true(all(colnames(NBthDEmod2$X) == rownames(coefreg$estimate))) }) @@ -36,33 +36,33 @@ test_that("coefNBth produces desired results from output of fitNBthDE", { test_that("coefNBth produces desired results from output of fitNBthmDE", { - + #### Specs for coefNBth - - + + ## 1. when fullpara=TRUE, the output parameters should be regression coefficients, threshold and r in a list. ## Both threshold and r are positive. ## 2. when fullpara=FALSE, the output parameters should be regression coefficients only in a list - + library(dplyr) ### Initializing CTA objects before running tests # Create temporary directory that will get destroyed after this block is executed. tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") withr::local_dir(tmp_dir) - + data(NBthmDEmod2) coefmfull <- coefNBth(NBthmDEmod2, fullpara=TRUE) coefmreg <- coefNBth(NBthmDEmod2, fullpara=FALSE) - + ## 1. when fullpara=TRUE, the output parameters should be regression coefficients, threshold and r in a list. ## Both threshold and r are positive. - - + + expect_true(all(c(colnames(NBthmDEmod2$X), c("r", "threshold")) == rownames(coefmfull$estimate))) expect_true(all(coefmfull$estimate["r", ] > 0)) expect_true(all(coefmfull$estimate["threshold", ] > 0)) - + ## 2. when fullpara=FALSE, the output parameters should be regression coefficients only in a list - + expect_true(all(colnames(NBthmDEmod2$X) == rownames(coefmreg$estimate))) }) diff --git a/tests/testthat/test-contrastNBth.R b/tests/testthat/test-contrastNBth.R index bb766d0..5f23ea4 100644 --- a/tests/testthat/test-contrastNBth.R +++ b/tests/testthat/test-contrastNBth.R @@ -1,13 +1,13 @@ test_that("contrastNBth produces desired results from output of fitNBthDE", { - + #### Specs for contrastNBth - - + + ## 1. The function takes in a DE model as an input from fitNBthDE or fitNBthmDE ## 2. The user input test:statistical test, choose from c("two-sided", ">", "<") ## 3. In the output list, the p values of '>' and '<' for the same variable/feature should add up to 1 - - + + library(dplyr) ### Initializing CTA objects before running tests # Create temporary directory that will get destroyed after this block is executed. @@ -15,39 +15,39 @@ test_that("contrastNBth produces desired results from output of fitNBthDE", { withr::local_dir(tmp_dir) # Run data through (required) upstream functions data(NBthDEmod2) # - + coeffull <- contrastNBth(NBthDEmod2) coeftest <- contrastNBth(NBthDEmod2, method=matrix(c(0,1), 2, 1), baseline=0) - + coeftestupper <- contrastNBth(NBthDEmod2, method=matrix(c(0,1), 2, 1), baseline=0, test = ">") - + coeftestlower <- contrastNBth(NBthDEmod2, method=matrix(c(0,1), 2, 1), baseline=0, test = "<") - - - + + + expect_true(all(coeffull$estimate[2,] == coeftest$estimate[1,])) - + ## 3. In the output list, the p values of '>' and '<' for the same variable/feature should add up to 1 - + expect_equal(unname(coeftestlower$p_value+coeftestupper$p_value), rep(1, length(coeftestlower$p_value))) - - + + }) test_that("contrastNBth produces desired results from output of fitNBthmDE", { - + #### Specs for contrastNBth - - + + ## 1. The function takes in a DE model as an input from fitNBthDE or fitNBthmDE ## 2. The user input test:statistical test, choose from c("two-sided", ">", "<") ## 3. In the output list, the p values of '>' and '<' for the same variable/feature should add up to 1 - - + + library(dplyr) ### Initializing CTA objects before running tests # Create temporary directory that will get destroyed after this block is executed. @@ -55,22 +55,22 @@ test_that("contrastNBth produces desired results from output of fitNBthmDE", { withr::local_dir(tmp_dir) # Run data through (required) upstream functions data(NBthmDEmod2) # - + coefmfull <- contrastNBth(NBthmDEmod2) coefmtest <- contrastNBth(NBthmDEmod2, method=matrix(c(0,1), 2, 1), baseline=0) - + coefmtestupper <- contrastNBth(NBthmDEmod2, method=matrix(c(0,1), 2, 1), baseline=0, test = ">") - + coefmtestlower <- contrastNBth(NBthmDEmod2, method=matrix(c(0,1), 2, 1), baseline=0, test = "<") - - - + + + expect_true(all(coefmfull$estimate[2,] == coefmtest$estimate[1,])) - + ## 3. In the output list, the p values of '>' and '<' for the same variable/feature should add up to 1 - + expect_equal(unname(coefmtestlower$p_value+coefmtestupper$p_value), rep(1, length(coefmtestlower$p_value))) - - + + }) diff --git a/tests/testthat/test-diagPoisBG.R b/tests/testthat/test-diagPoisBG.R index 6292b3e..c7cee6b 100644 --- a/tests/testthat/test-diagPoisBG.R +++ b/tests/testthat/test-diagPoisBG.R @@ -22,26 +22,26 @@ res <- diagPoisBG(res, generate_ppplot = FALSE) # 2 when padj=FALSE, each element of sum of lowtail_prob and uptail_prob in the assay slot named lowtail_prob and uptail_prob equals to 1 # test basic structure: test_that("single-slide diagPoisBG returns a well-formatted geomxset object", { - withr::local_dir(tmp_dir) - expect_true(class(res) == "NanoStringGeoMxSet") - - # matrix of lower tail probability in assayData slot called lowtail_prob : lowtail_prob - expect_true(is.matrix(assayDataElement(res, "lowtail_prob"))) - - # matrix of upper tail probability in assayData slot called uptail_prob: uptail_prob - expect_true(is.matrix(assayDataElement(res, "uptail_prob"))) - - # the dispersion parameter in experimentData named disper: disper - expect_true(notes(res)$disper > 0) - expect_equal(length(notes(res)$disper), 1) - - # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called low_outlier : low_outlier - expect_true(is.matrix(assayDataElement(res, "low_outlier"))) - expect_true(length(setdiff(assayDataElement(res, "low_outlier"), c(0, 1))) == 0) - - # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called up_outlier : up_outlier - expect_true(is.matrix(assayDataElement(res, "up_outlier"))) - expect_true(length(setdiff(assayDataElement(res, "up_outlier"), c(0, 1))) == 0) + withr::local_dir(tmp_dir) + expect_true(class(res) == "NanoStringGeoMxSet") + + # matrix of lower tail probability in assayData slot called lowtail_prob : lowtail_prob + expect_true(is.matrix(assayDataElement(res, "lowtail_prob"))) + + # matrix of upper tail probability in assayData slot called uptail_prob: uptail_prob + expect_true(is.matrix(assayDataElement(res, "uptail_prob"))) + + # the dispersion parameter in experimentData named disper: disper + expect_true(notes(res)$disper > 0) + expect_equal(length(notes(res)$disper), 1) + + # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called low_outlier : low_outlier + expect_true(is.matrix(assayDataElement(res, "low_outlier"))) + expect_true(length(setdiff(assayDataElement(res, "low_outlier"), c(0, 1))) == 0) + + # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called up_outlier : up_outlier + expect_true(is.matrix(assayDataElement(res, "up_outlier"))) + expect_true(length(setdiff(assayDataElement(res, "up_outlier"), c(0, 1))) == 0) }) @@ -53,57 +53,57 @@ res <- diagPoisBG(res, split = TRUE) # test basic structure: test_that("multi-slide diagPoisBG returns a well-formatted geomxset object", { - withr::local_dir(tmp_dir) - expect_true(class(res) == "NanoStringGeoMxSet") - - # matrix of lower tail probability in assayData slot called lowtail_prob : lowtail_prob - expect_true(is.matrix(assayDataElement(res, "lowtail_prob"))) - - # matrix of upper tail probability in assayData slot called uptail_prob: uptail_prob - expect_true(is.matrix(assayDataElement(res, "uptail_prob"))) - - # the dispersion parameter in experimentData named disper: disper - expect_true(notes(res)$disper > 0) - expect_equal(length(notes(res)$disper), 1) - - # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called low_outlier : low_outlier - expect_true(is.matrix(assayDataElement(res, "low_outlier"))) - expect_true(length(setdiff(assayDataElement(res, "low_outlier"), c(0, 1))) == 0) - - # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called up_outlier : up_outlier - expect_true(is.matrix(assayDataElement(res, "up_outlier"))) - expect_true(length(setdiff(assayDataElement(res, "up_outlier"), c(0, 1))) == 0) + withr::local_dir(tmp_dir) + expect_true(class(res) == "NanoStringGeoMxSet") + + # matrix of lower tail probability in assayData slot called lowtail_prob : lowtail_prob + expect_true(is.matrix(assayDataElement(res, "lowtail_prob"))) + + # matrix of upper tail probability in assayData slot called uptail_prob: uptail_prob + expect_true(is.matrix(assayDataElement(res, "uptail_prob"))) + + # the dispersion parameter in experimentData named disper: disper + expect_true(notes(res)$disper > 0) + expect_equal(length(notes(res)$disper), 1) + + # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called low_outlier : low_outlier + expect_true(is.matrix(assayDataElement(res, "low_outlier"))) + expect_true(length(setdiff(assayDataElement(res, "low_outlier"), c(0, 1))) == 0) + + # matrix of outlier indicator (Yes: 1; No: 0) in assayData slot called up_outlier : up_outlier + expect_true(is.matrix(assayDataElement(res, "up_outlier"))) + expect_true(length(setdiff(assayDataElement(res, "up_outlier"), c(0, 1))) == 0) }) ## test that values haven't changed from June 2021 initial release: test_that("diagPoisBG is stable", { - withr::local_dir(tmp_dir) - res <- fitPoisBG(demoData, size_scale = "first") - res <- diagPoisBG(res, generate_ppplot = FALSE) - expect_equal(notes(res)$disper, 1.323681, tol = 1e-5) + withr::local_dir(tmp_dir) + res <- fitPoisBG(demoData, size_scale = "first") + res <- diagPoisBG(res, generate_ppplot = FALSE) + expect_equal(notes(res)$disper, 1.323681, tol = 1e-5) }) ## 3 It returns an error without running fitPoisBG. test_that("It returns an error without running fitPoisBG.", { - withr::local_dir(tmp_dir) - expect_error( - diagPoisBG(demoData, generate_ppplot = FALSE), - "Please run `fitPoisBG` first" - ) - expect_error( - diagPoisBG(demoData, generate_ppplot = FALSE, split = TRUE), - "Please run `fitPoisBG` first" - ) + withr::local_dir(tmp_dir) + expect_error( + diagPoisBG(demoData, generate_ppplot = FALSE), + "Please run `fitPoisBG` first" + ) + expect_error( + diagPoisBG(demoData, generate_ppplot = FALSE, split = TRUE), + "Please run `fitPoisBG` first" + ) }) ## 4 It returns an error if split is TRUE but no corresponding fitPoisBG is called previously. test_that("It returns an error if split is TRUE but no corresponding fitPoisBG is called previously.", { - withr::local_dir(tmp_dir) - res <- fitPoisBG(demoData, size_scale = "first") - expect_error( - diagPoisBG(res, split = TRUE, generate_ppplot = FALSE), - "Please run `fitPoisBG` first with `groupvar`" - ) + withr::local_dir(tmp_dir) + res <- fitPoisBG(demoData, size_scale = "first") + expect_error( + diagPoisBG(res, split = TRUE, generate_ppplot = FALSE), + "Please run `fitPoisBG` first with `groupvar`" + ) }) diff --git a/tests/testthat/test-fitNBth.R b/tests/testthat/test-fitNBth.R index 368b3a5..b43eb6e 100644 --- a/tests/testthat/test-fitNBth.R +++ b/tests/testthat/test-fitNBth.R @@ -1,225 +1,225 @@ test_that("fitNBth produces desired results, CTA", { - - #### Specs for fitNBth - # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value - # 2 The function outputs a GeoMx S4 class with - # para0 in the experimentData as NA. - # 3 The function outputs a GeoMx S4 class - # with para, a matrix of estimated parameters, in the featureData. - # This matrix has feature_high_fitNBth in columns(same as features_high) - # and parameters(signal, r) in columns. - # 4 The function outputs sizefact_fitNBth in the phenoData, which is - # positive, same length as sizefact_BG - # 5 The function outputs threshold in the experimentData. When - # threshold_fix=TRUE, threshold in the output is the same as - # threshold_start. - - library(dplyr) - ### Initializing CTA objects before running tests - # Create temporary directory that will get destroyed after this block is executed. - tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") - withr::local_dir(tmp_dir) - # Run data through (required) upstream functions - data("demoData") # for tests of structure of demoData itself, see test-scoretest.R - - # susbet samples - demoData <- demoData[, c(1:5, 33:37)] - set.seed(98070) - NSGMS <- fitPoisBG(demoData, groupvar = "slide name", size_scale = "sum") - NSGMS <- aggreprobe(NSGMS, use = "cor") - NSGMS <- BGScoreTest(NSGMS, split = TRUE) - # Negative and Non-Negative facets: - NSGMS_neg <- NSGMS[which(fData(NSGMS)$CodeClass == "Negative"), ] - NSGMS_pos <- NSGMS[-which(fData(NSGMS)$CodeClass == "Negative"), ] - # feature factors per groupvar (i.e., slide name) - scores_sp <- fData(NSGMS_pos)[, grep("scores_", fvarLabels(NSGMS_pos))] - # scaling factors - features_high <- apply(scores_sp, 2, function(x){ - ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) - }) |> (function(x) apply(x, 1, function(y) all(y)))() |> - which() |> - names() - featfact_sp <- fData(NSGMS_neg)[, grep("featfact_", fvarLabels(NSGMS_neg))] - thmean <- (featfact_sp |> colMeans())[1] # picks the first slide name's value - - ### Case 1: run examplar function from vignette and check each specification - case1 <- fitNBth(NSGMS, - features_high = features_high, - sizefact_BG = NSGMS_neg$sizefact_sp, - threshold_start = unname(thmean), - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - threshold_fix = FALSE, # default but calling it explicitly here - tol = 1e-8 - ) - - # expect same results without specifying the values. - set.seed(123) - case1_df <- fitNBth(NSGMS, - split = TRUE, - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - threshold_fix = FALSE, # default but calling it explicitly here - tol = 1e-8 - ) - # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value - # expect same results without specifying the values. - test_that("expect same results without specifying the values.", { - expect_true(all.equal(case1, case1_df)) - }) - - # 2 The function outputs a GeoMx S4 class... - expect_true(inherits(case1, "NanoStringGeoMxSet")) - # ...with para0 in the experimentData as 'NA'. - expect_false(is.na(notes(case1)$para0)) # not NA - expect_true(notes(case1)$para0 == "NA") # "NA" - - # 3 The function outputs a GeoMx S4 class... - # (tested above) - # with para, a matrix of estimated parameters, in the featureData. - expect_true("para" %in% colnames(fData(case1))) - expect_true(inherits(fData(case1)$para, "matrix")) - # This matrix has feature_high_fitNBth in columns(same as features_high) - to_test <- fData(case1)$para[fData(case1)$feature_high_fitNBth == 1, ] - expect_true(nrow(to_test) == length(features_high)) - expect_true(all(row.names(to_test) == features_high)) - # and parameters(signal, r) in columns. - expect_true(all(c("signal", "r") == colnames(fData(case1)$para))) - - # 4 The function outputs sizefact_fitNBth in the phenoData, which is - # positive, same length as sizefact_BG - expect_true("sizefact_fitNBth" %in% colnames(pData(case1))) - expect_true(all(pData(case1)$sizefact_fitNBth >= 0)) # 0 is positive - expect_true(length(pData(case1)$sizefact_fitNBth) == length(NSGMS_neg$sizefact)) - - # 5 The function outputs threshold in the experimentData. - expect_false("threshold" %in% names(notes(NSGMS))) # no threshold in experimentalData originally - expect_true("threshold" %in% names(notes(case1))) - # expect_true(is.numeric(notes(case1)$threshold)) # not strictly a spec - # When threshold_fix=TRUE, threshold in the output is the same as - # threshold_start. - case1_1 <- fitNBth(NSGMS, - features_high = features_high, - sizefact_BG = NSGMS_neg$sizefact, - threshold_start = thmean, - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - threshold_fix = TRUE, - tol = 1e-8 - ) - expect_true(notes(case1_1)$threshold == thmean) + + #### Specs for fitNBth + # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value + # 2 The function outputs a GeoMx S4 class with + # para0 in the experimentData as NA. + # 3 The function outputs a GeoMx S4 class + # with para, a matrix of estimated parameters, in the featureData. + # This matrix has feature_high_fitNBth in columns(same as features_high) + # and parameters(signal, r) in columns. + # 4 The function outputs sizefact_fitNBth in the phenoData, which is + # positive, same length as sizefact_BG + # 5 The function outputs threshold in the experimentData. When + # threshold_fix=TRUE, threshold in the output is the same as + # threshold_start. + + library(dplyr) + ### Initializing CTA objects before running tests + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + withr::local_dir(tmp_dir) + # Run data through (required) upstream functions + data("demoData") # for tests of structure of demoData itself, see test-scoretest.R + + # susbet samples + demoData <- demoData[, c(1:5, 33:37)] + set.seed(98070) + NSGMS <- fitPoisBG(demoData, groupvar = "slide name", size_scale = "sum") + NSGMS <- aggreprobe(NSGMS, use = "cor") + NSGMS <- BGScoreTest(NSGMS, split = TRUE) + # Negative and Non-Negative facets: + NSGMS_neg <- NSGMS[which(fData(NSGMS)$CodeClass == "Negative"), ] + NSGMS_pos <- NSGMS[-which(fData(NSGMS)$CodeClass == "Negative"), ] + # feature factors per groupvar (i.e., slide name) + scores_sp <- fData(NSGMS_pos)[, grep("scores_", fvarLabels(NSGMS_pos))] + # scaling factors + features_high <- apply(scores_sp, 2, function(x){ + ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) + }) |> (function(x) apply(x, 1, function(y) all(y)))() |> + which() |> + names() + featfact_sp <- fData(NSGMS_neg)[, grep("featfact_", fvarLabels(NSGMS_neg))] + thmean <- (featfact_sp |> colMeans())[1] # picks the first slide name's value + + ### Case 1: run examplar function from vignette and check each specification + case1 <- fitNBth(NSGMS, + features_high = features_high, + sizefact_BG = NSGMS_neg$sizefact_sp, + threshold_start = unname(thmean), + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + threshold_fix = FALSE, # default but calling it explicitly here + tol = 1e-8 + ) + + # expect same results without specifying the values. + set.seed(123) + case1_df <- fitNBth(NSGMS, + split = TRUE, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + threshold_fix = FALSE, # default but calling it explicitly here + tol = 1e-8 + ) + # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value + # expect same results without specifying the values. + test_that("expect same results without specifying the values.", { + expect_true(all.equal(case1, case1_df)) + }) + + # 2 The function outputs a GeoMx S4 class... + expect_true(inherits(case1, "NanoStringGeoMxSet")) + # ...with para0 in the experimentData as 'NA'. + expect_false(is.na(notes(case1)$para0)) # not NA + expect_true(notes(case1)$para0 == "NA") # "NA" + + # 3 The function outputs a GeoMx S4 class... + # (tested above) + # with para, a matrix of estimated parameters, in the featureData. + expect_true("para" %in% colnames(fData(case1))) + expect_true(inherits(fData(case1)$para, "matrix")) + # This matrix has feature_high_fitNBth in columns(same as features_high) + to_test <- fData(case1)$para[fData(case1)$feature_high_fitNBth == 1, ] + expect_true(nrow(to_test) == length(features_high)) + expect_true(all(row.names(to_test) == features_high)) + # and parameters(signal, r) in columns. + expect_true(all(c("signal", "r") == colnames(fData(case1)$para))) + + # 4 The function outputs sizefact_fitNBth in the phenoData, which is + # positive, same length as sizefact_BG + expect_true("sizefact_fitNBth" %in% colnames(pData(case1))) + expect_true(all(pData(case1)$sizefact_fitNBth >= 0)) # 0 is positive + expect_true(length(pData(case1)$sizefact_fitNBth) == length(NSGMS_neg$sizefact)) + + # 5 The function outputs threshold in the experimentData. + expect_false("threshold" %in% names(notes(NSGMS))) # no threshold in experimentalData originally + expect_true("threshold" %in% names(notes(case1))) + # expect_true(is.numeric(notes(case1)$threshold)) # not strictly a spec + # When threshold_fix=TRUE, threshold in the output is the same as + # threshold_start. + case1_1 <- fitNBth(NSGMS, + features_high = features_high, + sizefact_BG = NSGMS_neg$sizefact, + threshold_start = thmean, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + threshold_fix = TRUE, + tol = 1e-8 + ) + expect_true(notes(case1_1)$threshold == thmean) }) test_that("fitNBth produces desired results, WTA", { - - ### Same overall workflow as above but with the WTA kidney dataset - - library(dplyr) - ### Initializing WTA objects before running tests - # Create temporary directory that will get destroyed after this block is executed. - tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") - withr::local_dir(tmp_dir) - # Run data through (required) upstream functions - data("kidney") - set.seed(98070) - NSGMS <- kidney[, kidney$`slide name` %in% c("disease1B", "disease2B")] - NSGMS <- NSGMS[, c(1:5, 11:15)] - NSGMS <- fitPoisBG(NSGMS, groupvar = "slide name", size_scale = "sum") - all0probeidx <- which(rowSums(exprs(NSGMS))==0) - NSGMS <- NSGMS[-all0probeidx, ] - NSGMS <- aggreprobe(NSGMS, use = "cor") - # Negative and Non-Negative facets: - NSGMS_neg <- NSGMS[which(fData(NSGMS)$CodeClass == "Negative"), ] - NSGMS_pos <- NSGMS[-which(fData(NSGMS)$CodeClass == "Negative"), ] - # feature factors per groupvar (i.e., slide name) - featfact_sp <- fData(NSGMS_neg)[, grep("featfact_", fvarLabels(NSGMS_neg))] - # scaling factors - posdat <- Biobase::exprs(NSGMS_pos) - gene_sum <- rowSums(posdat) - features_high <- ((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))) |> - which() |> - names() - set.seed(123) - genes_high <- sample(features_high, 1500) # subset - thmean <- 1 * (featfact_sp |> colMeans())[1] # picks the first slide name's value - - ### Case 1: run examplar function from vignette and check each specification - set.seed(123) - case1 <- fitNBth(NSGMS, - features_high = genes_high, - sizefact_BG = NSGMS_neg$sizefact_sp, - threshold_start = unname(thmean), - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - threshold_fix = FALSE, # default but calling it explicitly here - tol = 1e-8 - ) - # expect same results without specifying the values. - set.seed(123) - case1_df <- fitNBth(NSGMS, - split = TRUE, - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - threshold_fix = FALSE, # default but calling it explicitly here - tol = 1e-8 - ) - # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value - # expect same results without specifying the values. - test_that("expect same results without specifying the values.", { - expect_true(all.equal(case1, case1_df)) - }) - - - # 2 The function outputs a GeoMx S4 class... - expect_true(inherits(case1, "NanoStringGeoMxSet")) - # ...with para0 in the experimentData as 'NA'. - expect_false(is.na(notes(case1)$para0)) # not NA - expect_true(notes(case1)$para0 == "NA") # "NA" - - # 3 The function outputs a GeoMx S4 class... - # (tested above) - # with para, a matrix of estimated parameters, in the featureData. - expect_true("para" %in% colnames(fData(case1))) - expect_true(inherits(fData(case1)$para, "matrix")) - # This matrix has feature_high_fitNBth in columns(same as features_high) - to_test <- fData(case1)$para[fData(case1)$feature_high_fitNBth == 1, ] - expect_true(nrow(to_test) == length(genes_high)) - expect_true(all(sort(row.names(to_test)) == sort(genes_high))) - # and parameters(signal, r) in columns. - expect_true(all(c("signal", "r") == colnames(fData(case1)$para))) - - # 4 The function outputs sizefact_fitNBth in the phenoData, which is - # positive, same length as sizefact_BG - expect_true("sizefact_fitNBth" %in% colnames(pData(case1))) - expect_true(all(pData(case1)$sizefact_fitNBth >= 0)) # 0 is positive - expect_true(length(pData(case1)$sizefact_fitNBth) == length(NSGMS_neg$sizefact)) - - # 5 The function outputs threshold in the experimentData. - expect_false("threshold" %in% names(notes(NSGMS))) # no threshold in experimentalData originally - expect_true("threshold" %in% names(notes(case1))) - # expect_true(is.numeric(notes(case1)$threshold)) # not strictly a spec - # When threshold_fix=TRUE, threshold in the output is the same as - # threshold_start. - case1_1 <- fitNBth(NSGMS, - features_high = genes_high, - sizefact_BG = NSGMS_neg$sizefact_sp, - threshold_start = thmean, - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - threshold_fix = TRUE, - tol = 1e-8 - ) - expect_true(notes(case1_1)$threshold == thmean) + + ### Same overall workflow as above but with the WTA kidney dataset + + library(dplyr) + ### Initializing WTA objects before running tests + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + withr::local_dir(tmp_dir) + # Run data through (required) upstream functions + data("kidney") + set.seed(98070) + NSGMS <- kidney[, kidney$`slide name` %in% c("disease1B", "disease2B")] + NSGMS <- NSGMS[, c(1:5, 11:15)] + NSGMS <- fitPoisBG(NSGMS, groupvar = "slide name", size_scale = "sum") + all0probeidx <- which(rowSums(exprs(NSGMS))==0) + NSGMS <- NSGMS[-all0probeidx, ] + NSGMS <- aggreprobe(NSGMS, use = "cor") + # Negative and Non-Negative facets: + NSGMS_neg <- NSGMS[which(fData(NSGMS)$CodeClass == "Negative"), ] + NSGMS_pos <- NSGMS[-which(fData(NSGMS)$CodeClass == "Negative"), ] + # feature factors per groupvar (i.e., slide name) + featfact_sp <- fData(NSGMS_neg)[, grep("featfact_", fvarLabels(NSGMS_neg))] + # scaling factors + posdat <- Biobase::exprs(NSGMS_pos) + gene_sum <- rowSums(posdat) + features_high <- ((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))) |> + which() |> + names() + set.seed(123) + genes_high <- sample(features_high, 1500) # subset + thmean <- 1 * (featfact_sp |> colMeans())[1] # picks the first slide name's value + + ### Case 1: run examplar function from vignette and check each specification + set.seed(123) + case1 <- fitNBth(NSGMS, + features_high = genes_high, + sizefact_BG = NSGMS_neg$sizefact_sp, + threshold_start = unname(thmean), + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + threshold_fix = FALSE, # default but calling it explicitly here + tol = 1e-8 + ) + # expect same results without specifying the values. + set.seed(123) + case1_df <- fitNBth(NSGMS, + split = TRUE, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + threshold_fix = FALSE, # default but calling it explicitly here + tol = 1e-8 + ) + # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value + # expect same results without specifying the values. + test_that("expect same results without specifying the values.", { + expect_true(all.equal(case1, case1_df)) + }) + + + # 2 The function outputs a GeoMx S4 class... + expect_true(inherits(case1, "NanoStringGeoMxSet")) + # ...with para0 in the experimentData as 'NA'. + expect_false(is.na(notes(case1)$para0)) # not NA + expect_true(notes(case1)$para0 == "NA") # "NA" + + # 3 The function outputs a GeoMx S4 class... + # (tested above) + # with para, a matrix of estimated parameters, in the featureData. + expect_true("para" %in% colnames(fData(case1))) + expect_true(inherits(fData(case1)$para, "matrix")) + # This matrix has feature_high_fitNBth in columns(same as features_high) + to_test <- fData(case1)$para[fData(case1)$feature_high_fitNBth == 1, ] + expect_true(nrow(to_test) == length(genes_high)) + expect_true(all(sort(row.names(to_test)) == sort(genes_high))) + # and parameters(signal, r) in columns. + expect_true(all(c("signal", "r") == colnames(fData(case1)$para))) + + # 4 The function outputs sizefact_fitNBth in the phenoData, which is + # positive, same length as sizefact_BG + expect_true("sizefact_fitNBth" %in% colnames(pData(case1))) + expect_true(all(pData(case1)$sizefact_fitNBth >= 0)) # 0 is positive + expect_true(length(pData(case1)$sizefact_fitNBth) == length(NSGMS_neg$sizefact)) + + # 5 The function outputs threshold in the experimentData. + expect_false("threshold" %in% names(notes(NSGMS))) # no threshold in experimentalData originally + expect_true("threshold" %in% names(notes(case1))) + # expect_true(is.numeric(notes(case1)$threshold)) # not strictly a spec + # When threshold_fix=TRUE, threshold in the output is the same as + # threshold_start. + case1_1 <- fitNBth(NSGMS, + features_high = genes_high, + sizefact_BG = NSGMS_neg$sizefact_sp, + threshold_start = thmean, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + threshold_fix = TRUE, + tol = 1e-8 + ) + expect_true(notes(case1_1)$threshold == thmean) }) diff --git a/tests/testthat/test-fitNBthDE.R b/tests/testthat/test-fitNBthDE.R index fe5f2b3..600b021 100644 --- a/tests/testthat/test-fitNBthDE.R +++ b/tests/testthat/test-fitNBthDE.R @@ -1,5 +1,5 @@ test_that("fitNBthDE produces desired results, CTA", { - + #### Specs for fitNBth # 1 The function outputs para0, a matrix of estimated parameters in # iter=1. This matrix has features_high in the columns and @@ -12,7 +12,7 @@ test_that("fitNBthDE produces desired results, CTA", { # 3 The function outputs sizefact, a vector of size factors, # when sizescalebythreshold=FALSE, sizefact is the same as # sizefact_start. - + library(dplyr) ### Initializing CTA objects before running tests # Create temporary directory that will get destroyed after this block is executed. @@ -20,7 +20,7 @@ test_that("fitNBthDE produces desired results, CTA", { withr::local_dir(tmp_dir) # Run data through (required) upstream functions data("demoData") # for tests of structure of demoData itself, see test-scoretest.R - + # susbet samples demoData <- demoData[, c(1:5, 33:37)] set.seed(413) @@ -34,9 +34,9 @@ test_that("fitNBthDE produces desired results, CTA", { sc1_scores <- fData(demo_pos)[, "scores"] names(sc1_scores) <- fData(demo_pos)[, "TargetName"] features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & - (sc1_scores < quantile(sc1_scores, probs = 0.95))) |> - which() |> - names() + (sc1_scores < quantile(sc1_scores, probs = 0.95))) |> + which() |> + names() demoData <- fitNBth(demoData, features_high = features_high, sizefact_BG = demo_neg$sizefact, @@ -48,30 +48,30 @@ test_that("fitNBthDE produces desired results, CTA", { tol = 1e-8) ROIs_high <- sampleNames(demoData)[which(demoData$sizefact_fitNBth * thmean > 2)] features_all <- rownames(demo_pos) - + pData(demoData)$group <- c(rep(1, 5), rep(2, 5)) - + ### Case 1: - + features_high <- features_all - + NBthDEmod1 <- fitNBthDE( - form = ~group, - split = FALSE, - object = demoData, - ROIs_high = ROIs_high, - features_high = features_high, - features_all = features_all, - sizefact_start = demoData[, ROIs_high][["sizefact_fitNBth"]], - sizefact_BG = demoData[, ROIs_high][["sizefact"]], - preci2 = 10000, - prior_type = "contrast", - covrob = FALSE, - preci1con = 1 / 25, - sizescalebythreshold = TRUE, - iterations = 1 + form = ~group, + split = FALSE, + object = demoData, + ROIs_high = ROIs_high, + features_high = features_high, + features_all = features_all, + sizefact_start = demoData[, ROIs_high][["sizefact_fitNBth"]], + sizefact_BG = demoData[, ROIs_high][["sizefact"]], + preci2 = 10000, + prior_type = "contrast", + covrob = FALSE, + preci1con = 1 / 25, + sizescalebythreshold = TRUE, + iterations = 1 ) - + # 1 The function outputs para0,... # a matrix of estimated parameters in iter=1. expect_true(all(features_high == features_all)) @@ -86,14 +86,14 @@ test_that("fitNBthDE produces desired results, CTA", { # Both threshold and r are positive. expect_true(all(para0["r", ] > 0)) expect_true(all(para0["threshold", ] > 0)) - + ### Case 2: - + features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) |> which() |> names() - + NBthDEmod2 <- fitNBthDE( form = ~group, split = FALSE, @@ -110,7 +110,7 @@ test_that("fitNBthDE produces desired results, CTA", { sizescalebythreshold = TRUE, iterations = 2 ) - + # 2 The function outputs para,... # a matrix of estimated parameters in iter=2. expect_true("para" %in% names(NBthDEmod2)) @@ -124,15 +124,15 @@ test_that("fitNBthDE produces desired results, CTA", { # Both threshold and r are positive. expect_true(all(para["r", ] > 0)) expect_true(all(para["threshold", ] > 0)) - + # 3 The function outputs sizefact,... # a vector of size factors, expect_true("sizefact" %in% names(NBthDEmod2)) expect_true(is.vector(NBthDEmod2[["sizefact"]])) # when sizescalebythreshold=FALSE,... - + ### Case 3: - + sizefact_start = demoData[, ROIs_high][["sizefact_fitNBth"]] set.seed(123) NBthDEmod3 <- fitNBthDE( @@ -151,21 +151,100 @@ test_that("fitNBthDE produces desired results, CTA", { sizescalebythreshold = TRUE, sizefactrec = FALSE ) - - + + # sizefact is the same as sizefact_start. expect_true("sizefact" %in% names(NBthDEmod3)) expect_true(is.vector(NBthDEmod3[["sizefact"]])) expect_true(length(NBthDEmod3[["sizefact"]]) == length(sizefact_start)) expect_true(all(NBthDEmod3[["sizefact"]] == sizefact_start)) + + +}) - +test_that("fitNBthDE works with dgCMatrix format",{ + data("demoData") + demoData <- demoData[, c(1:5, 33:37)] + set.seed(413) + demoData <- fitPoisBG(demoData, size_scale = "sum") + demoData <- aggreprobe(demoData, use = "cor") + negdat <- demoData[which(Biobase::fData(demoData)$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(negdat) + countmat = as(countmat, "dgCMatrix") + result <- fitPoisBG( + object = countmat, + iterations = 10, + tol = 1e-3, + size_scale = "sum") + demoData[["sizefact"]] <- result$sizefact[Biobase::sampleNames(demoData)] + Biobase::fData(demoData)[["featfact"]] <- NA + Biobase::fData(demoData)[["featfact"]][match(names(result$featfact), Biobase::featureNames(demoData), nomatch = 0)] <- result$featfact + # Case 1: adjustment factor 5, no outlier removal, no prior + demoData <- BGScoreTest(demoData, + adj = 5, + removeoutlier = FALSE, useprior = FALSE) + demoData$slidename <- substr(demoData[["slide name"]], 12, 17) + thmean <- 1 * mean(fData(demoData)$featfact, na.rm = TRUE) + demo_pos <- demoData[which(!fData(demoData)$CodeClass == "Negative"), ] + demo_neg <- demoData[which(fData(demoData)$CodeClass == "Negative"), ] + sc1_scores <- fData(demo_pos)[, "scores"] + names(sc1_scores) <- fData(demo_pos)[, "TargetName"] + features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & + (sc1_scores < quantile(sc1_scores, probs = 0.95))) |> + which() |> + names() + demoData <- fitNBth(demoData, + features_high = features_high, + sizefact_BG = demo_neg$sizefact, + threshold_start = thmean, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + tol = 1e-8) + ROIs_high <- sampleNames(demoData)[which(demoData$sizefact_fitNBth * thmean > 2)] + features_all <- rownames(demo_pos) + + pData(demoData)$group <- c(rep(1, 5), rep(2, 5)) + + ### Case 1: + + features_high <- features_all + + NBthDEmod1 <- fitNBthDE( + form = ~group, + split = FALSE, + object = demoData, + ROIs_high = ROIs_high, + features_high = features_high, + features_all = features_all, + sizefact_start = demoData[, ROIs_high][["sizefact_fitNBth"]], + sizefact_BG = demoData[, ROIs_high][["sizefact"]], + preci2 = 10000, + prior_type = "contrast", + covrob = FALSE, + preci1con = 1 / 25, + sizescalebythreshold = TRUE, + iterations = 1 + ) + + # 1 The function outputs para0,... + # a matrix of estimated parameters in iter=1. + expect_true(all(features_high == features_all)) + expect_true("para0" %in% names(NBthDEmod1)) + expect_true(inherits(NBthDEmod1[["para0"]], "matrix")) + # This matrix has features_high in the columns + para0 <- NBthDEmod1[["para0"]] + expect_true(ncol(para0) == length(features_high)) + expect_true(all(colnames(para0) == features_high)) + }) -test_that("fitNBthDE produces desired results, WTA", { +test_that("fitNBthDE produces desired results, WTA", { + ### Same overall workflow as above but with the WTA kidney dataset - + library(dplyr) ### Initializing WTA objects before running tests # Create temporary directory that will get destroyed after this block is executed. @@ -196,28 +275,28 @@ test_that("fitNBthDE produces desired results, WTA", { set.seed(123) genes_high <- sample(features_high, 1500) # subset thmean <- 1 * (featfact_sp |> colMeans())[1] # picks the first slide name's value - + kidney <- fitNBth(kidney, - features_high = genes_high, - sizefact_BG = kidney_neg$sizefact_sp, - threshold_start = thmean, - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - #threshold_fix = FALSE, # default but calling it explicitly here - tol = 1e-8 + features_high = genes_high, + sizefact_BG = kidney_neg$sizefact_sp, + threshold_start = thmean, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + #threshold_fix = FALSE, # default but calling it explicitly here + tol = 1e-8 ) - + ROIs_high <- sampleNames(kidney)[which(kidney$sizefact_fitNBth * thmean > 2)] features_all <- rownames(kidney_pos) - + pData(kidney)$group <- c(rep(1, 38), rep(2, 38)) - + ### Case 1: - + features_high <- features_all - + NBthDEmod1 <- fitNBthDE( form = ~group, split = FALSE, @@ -234,7 +313,7 @@ test_that("fitNBthDE produces desired results, WTA", { sizescalebythreshold = TRUE, iterations = 1 ) - + # 1 The function outputs para0,... # a matrix of estimated parameters in iter=1. expect_true(all(features_high == features_all)) @@ -249,13 +328,13 @@ test_that("fitNBthDE produces desired results, WTA", { # Both threshold and r are positive. expect_true(all(para0["r", ] > 0)) expect_true(all(para0["threshold", ] > 0)) - + ### Case 2: - + features_high <- ((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))) |> which() |> names() - + NBthDEmod2 <- fitNBthDE( form = ~group, split = FALSE, @@ -272,7 +351,7 @@ test_that("fitNBthDE produces desired results, WTA", { sizescalebythreshold = TRUE, iterations = 2 ) - + # 2 The function outputs para,... # a matrix of estimated parameters in iter=2. expect_true("para" %in% names(NBthDEmod2)) @@ -286,15 +365,15 @@ test_that("fitNBthDE produces desired results, WTA", { # Both threshold and r are positive. expect_true(all(para["r", ] > 0)) expect_true(all(para["threshold", ] > 0)) - + # 3 The function outputs sizefact,... # a vector of size factors, expect_true("sizefact" %in% names(NBthDEmod2)) expect_true(is.vector(NBthDEmod1[["sizefact"]])) # when sizescalebythreshold=FALSE,... - + ### Case 3: - + sizefact_start = kidney[, ROIs_high][["sizefact_fitNBth"]] set.seed(123) NBthDEmod3 <- fitNBthDE( @@ -313,26 +392,234 @@ test_that("fitNBthDE produces desired results, WTA", { sizescalebythreshold = TRUE, sizefactrec = FALSE ) - - + + # sizefact is the same as sizefact_start. expect_true("sizefact" %in% names(NBthDEmod3)) expect_true(is.vector(NBthDEmod3[["sizefact"]])) expect_true(length(NBthDEmod3[["sizefact"]]) == length(sizefact_start)) expect_true(all(NBthDEmod3[["sizefact"]] == sizefact_start)) + + +}) +test_that("coefNBth produces desired results from output of fitNBthmDE", { + library(dplyr) + ### Initializing CTA objects before running tests + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + withr::local_dir(tmp_dir) + # Run data through (required) upstream functions + data("kidney") + set.seed(413) + kidney <- kidney[, kidney$`slide name` %in% c("disease1B", "disease2B")] + #kidney <- kidney[, c(1:10, 11:20)] + kidney <- fitPoisBG(kidney, size_scale = "sum") + kidney <- fitPoisBG(kidney, groupvar = "slide name", size_scale = "sum") + all0probeidx <- which(rowSums(exprs(kidney))==0) + kidney <- kidney[-all0probeidx, ] + kidney <- aggreprobe(kidney, use = "cor") + kidney <- BGScoreTest(kidney) + # Negative and Non-Negative facets: + kidney_neg <- kidney[which(fData(kidney)$CodeClass == "Negative"), ] + kidney_pos <- kidney[-which(fData(kidney)$CodeClass == "Negative"), ] + # feature factors per groupvar (i.e., slide name) + featfact_sp <- fData(kidney_neg)[, grep("featfact_", fvarLabels(kidney_neg))] + # scaling factors + posdat <- Biobase::exprs(kidney_pos) + gene_sum <- rowSums(posdat) + features_high <- ((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))) |> + which() |> + names() + set.seed(123) + genes_high <- sample(features_high, 1500) # subset + thmean <- 1 * (featfact_sp |> colMeans())[1] # picks the first slide name's value + + kidney <- fitNBth(kidney, + features_high = genes_high, + sizefact_BG = kidney_neg$sizefact_sp, + threshold_start = thmean, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + #threshold_fix = FALSE, # default but calling it explicitly here + tol = 1e-8 + ) + + ROIs_high <- sampleNames(kidney)[which(kidney$sizefact_fitNBth * thmean > 2)] + features_all <- rownames(kidney_pos) + + pData(kidney)$group <- c(rep(1, 38), rep(2, 38)) + + ### Case 1: + + features_high <- features_all + features_high <- ((gene_sum > quantile(gene_sum, probs = 0.5)) & (gene_sum < quantile(gene_sum, probs = 0.95))) |> + which() |> + names() + + NBthDEmod2 <- fitNBthDE( + form = ~group, + split = FALSE, + object = kidney, + ROIs_high = ROIs_high, + features_high = features_high, + features_all = features_all, + sizefact_start = kidney[, ROIs_high][["sizefact_fitNBth"]], + sizefact_BG = kidney[, ROIs_high][["sizefact"]], + preci2 = 10000, + prior_type = "contrast", + covrob = FALSE, + preci1con = 1 / 25, + sizescalebythreshold = TRUE, + iterations = 2 + ) + + coefmfull <- coefNBth(NBthDEmod2, fullpara=TRUE) + coefmreg <- coefNBth(NBthDEmod2, fullpara=FALSE) + + ## 1. when fullpara=TRUE, the output parameters should be regression coefficients, threshold and r in a list. + ## Both threshold and r are positive. + + + expect_true(all(c(colnames(NBthDEmod2$X), c("r", "threshold")) == rownames(coefmfull$estimate))) + expect_true(all(coefmfull$estimate["r", ] > 0)) + expect_true(all(coefmfull$estimate["threshold", ] > 0)) + + ## 2. when fullpara=FALSE, the output parameters should be regression coefficients only in a list + + expect_true(all(colnames(NBthDEmod2$X) == rownames(coefmreg$estimate))) + + ## 3. The user input test:statistical test, choose from c("two-sided", ">", "<") + ## 4. In the output list, the p values of '>' and '<' for the same variable/feature should add up to 1 + coeffull <- contrastNBth(NBthDEmod2) + coeftest <- contrastNBth(NBthDEmod2, method=matrix(c(0,1), 2, 1), baseline=0) + + coeftestupper <- contrastNBth(NBthDEmod2, method=matrix(c(0,1), 2, 1), baseline=0, test = ">") + + coeftestlower <- contrastNBth(NBthDEmod2, method=matrix(c(0,1), 2, 1), baseline=0, test = "<") + + + + expect_true(all(coeffull$estimate[2,] == coeftest$estimate[1,])) + + ## 5. In the output list, the p values of '>' and '<' for the same variable/feature should add up to 1 + + expect_equal(unname(coeftestlower$p_value+coeftestupper$p_value), + rep(1, length(coeftestlower$p_value))) +}) - - - - - - - - - - +test_that("coefNBth produces desired results from output of fitNBthmDE and parallel works properly", { + library(dplyr) + ### Initializing CTA objects before running tests + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + withr::local_dir(tmp_dir) + # Run data through (required) upstream functions + library(Rfast) + data("test_data") + + ## load data + #library(GeoDiff) + library(Matrix) + library(magrittr) + library(parallel) + # + # 1. For each negative probe, calculate total count for all cells. Calculate the median mu. + neg0 <- test_data$neg0 + mu <- median(rowSums(neg0)) + + # 2. For each positive probe, calculate total count for all cells. + raw0 <- test_data$raw0 + pos_count <- rowSums(raw0) + + # 3. Select positive probes with total count less than mu, call them low positive probes + indx_low_pos <- which(pos_count < mu) + mean(pos_count < mu) + + # 4. Combine low positive probes and negative probes, fit the Poisson Background model, implement the common diagnostics procedure + negmod <- fitPoisBG(rbind(neg0, raw0[indx_low_pos, ]), size_scale = "sum") # use sum in SMI data. use first will lead to distortion in data + negdiag2 <- diagPoisBG(negmod, generate_ppplot = FALSE) + + + # 5. perform score tests + negmod2 <- fitPoisBG(neg0, size_scale = "sum") # use sum in SMI data. use first will lead to distortion in data + negmod2$sizefact <- negmod$sizefact + + sc <- GeoDiff::BGScoreTest(raw0, negmod2, adj = 1, removeoutlier = FALSE, useprior = TRUE) + # and maybe try different combinations of removeoutlier and useprior + + features_high <- ((sc$scores > quantile(sc$scores, probs = 0.4)) & (sc$scores < quantile(sc$scores, probs = 0.95))) %>% + which() %>% + names() + + # calculate the sizefact + # estimate a_j from the poisson threshold model + sizefact0 <- negmod$sizefact + gamma0 <- mean(negmod2$featfact) + gamma_features <- rowSums(raw0[features_high,]) - gamma0 + sizefact <- (colSums(raw0[features_high,])-length(features_high)*gamma0*sizefact0)/sum(gamma_features) + + # confirm the sum is 1 + sum(sizefact0) + sum(sizefact) + + # percentage of negative + sum(sizefact<0)/length(sizefact) + + # replace negative by 0 + sizefact[sizefact<0] <- 0 + + # rescale + gamma_features <- gamma_features*sum(sizefact) + sizefact <- sizefact/sum(sizefact) + annot <- test_data$annot + annot <- as.data.frame(annot) + rownames(annot) <- colnames(raw0) + + annot$fov|>table() + + high_ROIs <- names(which(sizefact[annot$fov%in%c(1:2)]>0)) + + features_all <- rownames(raw0) + + NBthDEmod2 <- fitNBthDE(form = ~factor(fov), + annot=annot[high_ROIs, ], + object=raw0[features_all,high_ROIs], + probenum = rep(1, length(features_all)), + features_high = features_high, + features_all = features_all, + sizefact_start=sizefact[high_ROIs], + sizefact_BG=sizefact0[high_ROIs], + threshold_mean = gamma0, + preci2=10000, + prior_type="contrast", + covrob=FALSE, + preci1con=1/25, + sizefactrec=FALSE, + sizescalebythreshold=TRUE, + run_parallel = TRUE, + n_parallel = (parallel::detectCores())) + expect_error( + NBthDEmod2 <- fitNBthDE(form = ~factor(fov), + annot=annot[high_ROIs, ], + object=raw0[features_all,high_ROIs], + probenum = rep(1, length(features_all)), + features_high = features_high, + features_all = features_all, + sizefact_start=sizefact[high_ROIs], + sizefact_BG=sizefact0[high_ROIs], + threshold_mean = gamma0, + preci2=10000, + prior_type="contrast", + covrob=FALSE, + preci1con=1/25, + sizefactrec=FALSE, + sizescalebythreshold=TRUE, + run_parallel = TRUE, + n_parallel = (parallel::detectCores()+1))) + }) - diff --git a/tests/testthat/test-fitNBthmDE.R b/tests/testthat/test-fitNBthmDE.R index 57e8cbe..399dfea 100644 --- a/tests/testthat/test-fitNBthmDE.R +++ b/tests/testthat/test-fitNBthmDE.R @@ -2,15 +2,15 @@ ### fitNBthmDE with random intercept effect and random slope effect test_that("fitNBthmDE produces desired results, CTA", { - - + + #### Specs for fitNBthmDE: # 1 The function outputs para. # This matrix has features_all in the columns # and parameters(regression coefficients, threshold, r) in the rows. # Both threshold and r are positive. - - + + library(Biobase) library(dplyr) # Preamble/load example data @@ -20,8 +20,8 @@ test_that("fitNBthmDE produces desired results, CTA", { # Change to the temporary directory (will set back to getwd() once block is executed.) withr::local_dir(tmp_dir) expect_true(inherits(demoData, "NanoStringGeoMxSet")) - - + + # susbet samples demoData <- demoData[, c(1:5, 33:37)] demoData <- fitPoisBG(demoData, size_scale = "sum") @@ -70,8 +70,8 @@ test_that("fitNBthmDE produces desired results, CTA", { covrob=FALSE, preci1con=1/25, sizescalebythreshold=TRUE) - - + + ### Case 1: run random intercept model NBthmDEmod1 <- fitNBthmDE(form = ~ group + (1 | `slide name`), split = FALSE, @@ -85,45 +85,45 @@ test_that("fitNBthmDE produces desired results, CTA", { preci2=10000, sizescale = TRUE, controlRandom=list(nu=12, nmh_e=400, thin_e=60)) - + # 1: The function outputs para... expect_true("para" %in% names(NBthmDEmod1)) - + # This matrix has features_all in the columns expect_true(all(features_all[1:5] == colnames(NBthmDEmod1$para))) - + # and parameters(regression coefficients, threshold, r) in the rows. expect_true(all(c("(Intercept)", "group", "r", "threshold") %in% rownames(NBthmDEmod1$para))) - + # Both threshold and r are positive. expect_true(all(NBthmDEmod1$para["threshold",] > 0)) expect_true(all(NBthmDEmod1$para["r",] > 0)) - - - + + + ### Case 2: run random slope model NBthmDEmod1slope <- fitNBthmDE(form = ~ group + (1 + group | `slide name`), - split = FALSE, - object = demoData, - ROIs_high = ROIs_high, - features_all = features_all[1:5], - sizefact = demoData[, ROIs_high][["sizefact_fitNBth"]], - sizefact_BG = demoData[, ROIs_high][["sizefact"]], - preci1=NBthDEmod2$preci1, - threshold_mean = thmean, - preci2=10000, - sizescale = TRUE, - controlRandom=list(nu=12, nmh_e=400, thin_e=60)) - + split = FALSE, + object = demoData, + ROIs_high = ROIs_high, + features_all = features_all[1:5], + sizefact = demoData[, ROIs_high][["sizefact_fitNBth"]], + sizefact_BG = demoData[, ROIs_high][["sizefact"]], + preci1=NBthDEmod2$preci1, + threshold_mean = thmean, + preci2=10000, + sizescale = TRUE, + controlRandom=list(nu=12, nmh_e=400, thin_e=60)) + # 1: The function outputs para... expect_true("para" %in% names(NBthmDEmod1slope)) - + # This matrix has features_all in the columns expect_true(all(features_all[1:5] == colnames(NBthmDEmod1slope$para))) - + # and parameters(regression coefficients, threshold, r) in the rows. expect_true(all(c("(Intercept)", "group", "r", "threshold") %in% rownames(NBthmDEmod1slope$para))) - + # Both threshold and r are positive. expect_true(all(NBthmDEmod1slope$para["threshold",] > 0)) expect_true(all(NBthmDEmod1slope$para["r",] > 0)) @@ -134,10 +134,10 @@ test_that("fitNBthmDE produces desired results, CTA", { test_that("fitNBthmDE produces desired results, WTA", { - - + + ### Same overall workflow as above but with the WTA kidney dataset - + library(dplyr) ### Initializing WTA objects before running tests # Create temporary directory that will get destroyed after this block is executed. @@ -153,13 +153,13 @@ test_that("fitNBthmDE produces desired results, WTA", { rownames(fData(kidney))[which(!fData(kidney)$Negative)] <- fData(kidney)[which(!fData(kidney)$Negative), "TargetName"] featureNames(kidney) <- rownames(fData(kidney)) rownames(exprs(kidney)) <- rownames(fData(kidney)) - + kidney <- fitPoisBG(kidney, size_scale = "sum") kidney <- fitPoisBG(kidney, groupvar = "slide name", size_scale = "sum") all0probeidx <- which(rowSums(exprs(kidney))==0) kidney <- kidney[-all0probeidx, ] kidney <- aggreprobe(kidney, use = "cor") - + # Negative Binomial threshold model set.seed(123) kidney <- fitNBth(kidney, @@ -196,8 +196,8 @@ test_that("fitNBthmDE produces desired results, WTA", { covrob=FALSE, preci1con=1/25, sizescalebythreshold=TRUE) - - + + ### Case 1: run examplar function from vignette and check each specification # random intercept model NBthmDEmod2 <- fitNBthmDE(object = kidney, @@ -212,22 +212,22 @@ test_that("fitNBthmDE produces desired results, WTA", { preci2=10000, sizescale = TRUE, controlRandom=list(nu=12, nmh_e=400, thin_e=60)) - + # 1: The function outputs para... expect_true("para" %in% names(NBthmDEmod2)) - + # This matrix has features_all in the columns expect_true(all(features_high[1:5] == colnames(NBthmDEmod2$para))) - + # and parameters(regression coefficients, threshold, r) in the rows. expect_true(all(c("(Intercept)", "regiontubule", "r", "threshold") %in% rownames(NBthmDEmod2$para))) - + # Both threshold and r are positive. expect_true(all(NBthmDEmod2$para["threshold",] > 0)) expect_true(all(NBthmDEmod2$para["r",] > 0)) - - - + + + ### Case 2: run examplar function from vignette and check each specification # random slope model NBthmDEmod2slope <- fitNBthmDE(object = kidney, @@ -244,13 +244,13 @@ test_that("fitNBthmDE produces desired results, WTA", { controlRandom=list(nu=12, nmh_e=400, thin_e=60)) # 1: The function outputs para... expect_true("para" %in% names(NBthmDEmod2slope)) - + # This matrix has features_all in the columns expect_true(all(features_high[1:5] == colnames(NBthmDEmod2slope$para))) - + # and parameters(regression coefficients, threshold, r) in the rows. expect_true(all(c("(Intercept)", "regiontubule", "r", "threshold") %in% rownames(NBthmDEmod2slope$para))) - + # Both threshold and r are positive. expect_true(all(NBthmDEmod2slope$para["threshold",] > 0)) expect_true(all(NBthmDEmod2slope$para["r",] > 0)) diff --git a/tests/testthat/test-fitPoisBG.R b/tests/testthat/test-fitPoisBG.R index 7615a6f..62e7a57 100644 --- a/tests/testthat/test-fitPoisBG.R +++ b/tests/testthat/test-fitPoisBG.R @@ -14,34 +14,57 @@ res <- fitPoisBG(demoData, size_scale = "first") # spec: "The function outputs a GeoMx S4 class with length same as length of ROIs, sizefact, in phenoData. # The value is NA for non-negative probes." test_that("fitPoisBG returns a well-formatted geomxset object", { - expect_true(class(res) == "NanoStringGeoMxSet") - expect_true(nrow(phenoData(res)) == nrow(phenoData(demoData))) - expect_true(nrow(featureData(res)) == nrow(featureData(demoData))) - # 1 The function outputs a GeoMx S4 class with length same as length of ROIs, sizefact, in phenoData. - expect_true("sizefact" %in% varLabels(res)) - expect_false(any(is.na(res[["sizefact"]]))) - # 2 The function outputs a GeoMx S4 class with length same as length of negative probes, featfact, in featureData. The value is NA for non-negative probes - expect_true(all(is.na(fData(res)$featfact[fData(res)$featfact == "Endogenous"]))) - expect_identical(!is.na(fData(res)$featfact), fData(res)$CodeClass == "Negative") + expect_true(class(res) == "NanoStringGeoMxSet") + expect_true(nrow(phenoData(res)) == nrow(phenoData(demoData))) + expect_true(nrow(featureData(res)) == nrow(featureData(demoData))) + # 1 The function outputs a GeoMx S4 class with length same as length of ROIs, sizefact, in phenoData. + expect_true("sizefact" %in% varLabels(res)) + expect_false(any(is.na(res[["sizefact"]]))) + # 2 The function outputs a GeoMx S4 class with length same as length of negative probes, featfact, in featureData. The value is NA for non-negative probes + expect_true(all(is.na(fData(res)$featfact[fData(res)$featfact == "Endogenous"]))) + expect_identical(!is.na(fData(res)$featfact), fData(res)$CodeClass == "Negative") }) +test_that("fitPoisBG functions with no errors with dgCMatrix",{ + + data("demoData") + negdat <- demoData[which(Biobase::fData(demoData)$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(negdat) + countmat = as(countmat, "dgCMatrix") + result <- fitPoisBG( + object = countmat, + iterations = 10, + tol = 1e-3, + size_scale = "first") + demoData[["sizefact"]] <- result$sizefact[Biobase::sampleNames(demoData)] + Biobase::fData(demoData)[["featfact"]] <- NA + Biobase::fData(demoData)[["featfact"]][match(names(result$featfact), Biobase::featureNames(demoData), nomatch = 0)] <- result$featfact + demoData <- aggreprobe(demoData, use = "cor") + expect_true(class(demoData) == "NanoStringGeoMxSet") + expect_true(nrow(phenoData(demoData)) == nrow(phenoData(demoData))) + expect_true(nrow(featureData(demoData)) == nrow(featureData(demoData))) + # 1 The function outputs a GeoMx S4 class with length same as length of ROIs, sizefact, in phenoData. + expect_true("sizefact" %in% names(result)) + expect_false(any(is.na(result[["sizefact"]]))) +}) +# the test ensures that the sizefact is the same length as the ROIs (important for the function to execute correctly) ## test size factors are correct: test_that("sizefact is correct", { - # Spec 3: If size_scale="first", sizefact[1]=1 - res <- fitPoisBG(demoData, size_scale = "first") - expect_equal(pData(res)$sizefact[1], 1, tol = 1e-5) - - # Spec 4: If size_scale="sum", sum(sizefact)=1 - res <- fitPoisBG(demoData, size_scale = "sum") - expect_equal(sum(pData(res)$sizefact), 1, tol = 1e-5) + # Spec 3: If size_scale="first", sizefact[1]=1 + res <- fitPoisBG(demoData, size_scale = "first") + expect_equal(pData(res)$sizefact[1], 1, tol = 1e-5) + + # Spec 4: If size_scale="sum", sum(sizefact)=1 + res <- fitPoisBG(demoData, size_scale = "sum") + expect_equal(sum(pData(res)$sizefact), 1, tol = 1e-5) }) ## test that values haven't changed from June 2021 initial release: test_that("fitPoisBG is stable", { - res <- fitPoisBG(demoData, size_scale = "sum") - expect_equal(pData(res)$sizefact[c(1, 10, 50)], c(0.011925349, 0.013114282, 0.007818129), tol = 1e-5) - expect_equal(fData(res)$featfact[c(7932, 7933, 7934)], c(319, 380, 299), tol = 1e-2) + res <- fitPoisBG(demoData, size_scale = "sum") + expect_equal(pData(res)$sizefact[c(1, 10, 50)], c(0.011925349, 0.013114282, 0.007818129), tol = 1e-5) + expect_equal(fData(res)$featfact[c(7932, 7933, 7934)], c(319, 380, 299), tol = 1e-2) }) # specs @@ -52,10 +75,10 @@ test_that("fitPoisBG is stable", { res <- fitPoisBG(demoData, size_scale = "first") test_that("The function returns an error", { - expect_error( - fitPoisBG(demoData, size_scale = "first", groupvar = "slidename"), - "is not found in the S4 object" - ) + expect_error( + fitPoisBG(demoData, size_scale = "first", groupvar = "slidename"), + "is not found in the S4 object" + ) }) # specs @@ -66,10 +89,10 @@ test_that("The function returns an error", { res <- fitPoisBG(demoData, size_scale = "first") test_that("The function returns a warning messag", { - expect_warning( - fitPoisBG(demoData, size_scale = "first", groupvar = "segment"), - "has only one value" - ) + expect_warning( + fitPoisBG(demoData, size_scale = "first", groupvar = "segment"), + "has only one value" + ) }) # specs: @@ -91,38 +114,38 @@ res <- fitPoisBG(demoData, size_scale = "first", groupvar = "slide name") # - The function outputs a GeoMx S4 class with length same as length of negative probes, featfact, in featureData for each unique slide value. # - the group variable name for slide id of ROIs in experimentData: fitPoisBG_sp_var test_that("fitPoisBG returns a well-formatted geomxset object", { - expect_true(class(res) == "NanoStringGeoMxSet") - # 1 The function outputs a GeoMx S4 class with length same as length of ROIs, sizefact, in phenoData - expect_true(nrow(phenoData(res)) == nrow(phenoData(demoData))) - expect_true(nrow(featureData(res)) == nrow(featureData(demoData))) - expect_true(all(is.na(fData(res)$featfact[fData(res)$featfact != "Negative"]))) - # 2 The function outputs a GeoMx S4 class with length same as length of negative probes, featfact, in featureData. - # The value is NA for non-negative probes. - for (i in grep("featfact_", fvarLabels(res))) { - expect_identical(!is.na(fData(res)[, i]), fData(res)$CodeClass == "Negative") - } - expect_identical( - fvarLabels(res)[grep("featfact_", fvarLabels(res))], - paste0("featfact_", unique(demoData[["slide name"]])) - ) - expect_equal(notes(res)$fitPoisBG_sp_var, "slide name") + expect_true(class(res) == "NanoStringGeoMxSet") + # 1 The function outputs a GeoMx S4 class with length same as length of ROIs, sizefact, in phenoData + expect_true(nrow(phenoData(res)) == nrow(phenoData(demoData))) + expect_true(nrow(featureData(res)) == nrow(featureData(demoData))) + expect_true(all(is.na(fData(res)$featfact[fData(res)$featfact != "Negative"]))) + # 2 The function outputs a GeoMx S4 class with length same as length of negative probes, featfact, in featureData. + # The value is NA for non-negative probes. + for (i in grep("featfact_", fvarLabels(res))) { + expect_identical(!is.na(fData(res)[, i]), fData(res)$CodeClass == "Negative") + } + expect_identical( + fvarLabels(res)[grep("featfact_", fvarLabels(res))], + paste0("featfact_", unique(demoData[["slide name"]])) + ) + expect_equal(notes(res)$fitPoisBG_sp_var, "slide name") }) ## test size factors are correct: test_that("sizefact is correct", { - # 3 Spec: If size_scale="first", sizefact[1]=1 - res <- fitPoisBG(demoData, size_scale = "first", groupvar = "slide name") - expect_equal(pData(res)$sizefact[1], 1, tol = 1e-5) - - # 4 Spec: If size_scale="sum", sum(sizefact)=1 - res <- fitPoisBG(demoData, size_scale = "sum", groupvar = "slide name") - expect_equal(sum(pData(res)$sizefact), 1, tol = 1e-5) + # 3 Spec: If size_scale="first", sizefact[1]=1 + res <- fitPoisBG(demoData, size_scale = "first", groupvar = "slide name") + expect_equal(pData(res)$sizefact[1], 1, tol = 1e-5) + + # 4 Spec: If size_scale="sum", sum(sizefact)=1 + res <- fitPoisBG(demoData, size_scale = "sum", groupvar = "slide name") + expect_equal(sum(pData(res)$sizefact), 1, tol = 1e-5) }) ## test that values haven't changed from June 2021 initial release: test_that("fitPoisBG is stable", { - res <- fitPoisBG(demoData, size_scale = "sum", groupvar = "slide name") - expect_equal(pData(res)$sizefact[c(1, 10, 50)], c(0.011925349, 0.013114282, 0.007818129), tol = 1e-5) - expect_equal(fData(res)$"featfact_6panel-old-slide1 (PTL-10891)"[c(7932:7934)], c(313.8457, 438.5242, 356.8383), tol = 1e-2) + res <- fitPoisBG(demoData, size_scale = "sum", groupvar = "slide name") + expect_equal(pData(res)$sizefact[c(1, 10, 50)], c(0.011925349, 0.013114282, 0.007818129), tol = 1e-5) + expect_equal(fData(res)$"featfact_6panel-old-slide1 (PTL-10891)"[c(7932:7934)], c(313.8457, 438.5242, 356.8383), tol = 1e-2) }) diff --git a/tests/testthat/test-fitPoisthNorm.R b/tests/testthat/test-fitPoisthNorm.R index 67c6967..9a7a627 100644 --- a/tests/testthat/test-fitPoisthNorm.R +++ b/tests/testthat/test-fitPoisthNorm.R @@ -3,469 +3,469 @@ test_that("fitPoisthNorm when split = FALSE produces desired results", { - - #### Specs for fitPoisthNorm - # 1 Without providing values for ROIs_high, features_high, features_all, sizefact_start, sizefact_BG, the function returns the same value - # 2 user need to set iterations =2 for now - # 3 The function outputs a GeoMx S4 class with para0_norm, matrix of estimated parameters, in the featureData. - # This matrix para0_norm has the following structure: - # 3.1) 1 row for each feature (row name). If a feature is not in features_high, all columns will be NA. - # 3.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. - # 3.3) the n columns will have log2 expression (if feature is in features_high) or NA (otherwise). - # 3.4) the n+1th column contains the threshold for each feature in features_high and NA otherwise. - # 4 The function outputs a GeoMx S4 class with para_norm, matrix of estimated parameters, in the featureData. This matrix para_norm has the following structure: - # 4.1) 1 row for each feature (row name) which is equal to the length of features_all - # 4.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. - # 4.3) the n columns will have log2 expression. - # 4.4) the n+1th column contains the threshold for each feature in features_all. - # 5 The function outputs a column called conv0 in featureData, with values in [NA, 0, 1] and length of 0s and 1s are the same as the length of features_high. - # 6 The function outputs a column called conv in featureData, length same as features_all, and has values [NA, 0, 1]. The length of NAs equals the number of negative probes. - - - - # 7 when confac=0 and prior_type="contrast", preci1_norm value in - # experimentData will be single value repeated over an n-by-n matrix (where n is the length of ROI_high). - # This single value is equivalent, within 10 digits, to preci1con/n^2. - - library(dplyr) - ### Initializing CTA objects before running tests - # Create temporary directory that will get destroyed after this block is executed. - tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") - withr::local_dir(tmp_dir) - # Run data through (required) upstream functions - data("demoData") # for tests of structure of demoData itself, see test-scoretest.R - set.seed(98070) - demoData <- demoData[, c(1:5, 33:37)] - NSGMS <- fitPoisBG(demoData) # "single" slide - NSGMS <- aggreprobe(NSGMS, use = "cor") - NSGMS <- BGScoreTest(NSGMS) - - # Negative and Non-Negative facets: - NSGMS_neg <- NSGMS[which(fData(NSGMS)$CodeClass == "Negative"), ] - NSGMS_pos <- NSGMS[-which(fData(NSGMS)$CodeClass == "Negative"), ] - # feature factors - featfact <- fData(NSGMS_neg)[, grep("featfact", fvarLabels(NSGMS_neg))] - # scaling factors - posdat <- Biobase::exprs(NSGMS_pos) - sc1_scores <- fData(NSGMS_pos)[, "scores"] - names(sc1_scores) <- fData(NSGMS_pos)[, "TargetName"] - - features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) |> - which() |> - names() - - backmean <- mean(featfact) - # Negative Binomial threshold model - NSGMS <- fitNBth(NSGMS, - features_high = features_high, - sizefact_BG = NSGMS_neg$sizefact, - threshold_start = backmean, - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - threshold_fix = FALSE, # default but calling it explicitly here - tol = 1e-8 - ) - high_ROIs <- sampleNames(NSGMS)[which((quantile(fData(NSGMS)[["para"]][, 1], - probs = 0.90, na.rm = TRUE - ) - notes(NSGMS)[["threshold"]]) * NSGMS$sizefact_fitNBth > 2)] - - features_all <- featureNames(NSGMS_pos) - - # Case 1: Similar to vignette but only treated as a single slide & iterations = 3 - # 2 User need to set iterations =2 for now + + #### Specs for fitPoisthNorm + # 1 Without providing values for ROIs_high, features_high, features_all, sizefact_start, sizefact_BG, the function returns the same value + # 2 user need to set iterations =2 for now + # 3 The function outputs a GeoMx S4 class with para0_norm, matrix of estimated parameters, in the featureData. + # This matrix para0_norm has the following structure: + # 3.1) 1 row for each feature (row name). If a feature is not in features_high, all columns will be NA. + # 3.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. + # 3.3) the n columns will have log2 expression (if feature is in features_high) or NA (otherwise). + # 3.4) the n+1th column contains the threshold for each feature in features_high and NA otherwise. + # 4 The function outputs a GeoMx S4 class with para_norm, matrix of estimated parameters, in the featureData. This matrix para_norm has the following structure: + # 4.1) 1 row for each feature (row name) which is equal to the length of features_all + # 4.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. + # 4.3) the n columns will have log2 expression. + # 4.4) the n+1th column contains the threshold for each feature in features_all. + # 5 The function outputs a column called conv0 in featureData, with values in [NA, 0, 1] and length of 0s and 1s are the same as the length of features_high. + # 6 The function outputs a column called conv in featureData, length same as features_all, and has values [NA, 0, 1]. The length of NAs equals the number of negative probes. + + + + # 7 when confac=0 and prior_type="contrast", preci1_norm value in + # experimentData will be single value repeated over an n-by-n matrix (where n is the length of ROI_high). + # This single value is equivalent, within 10 digits, to preci1con/n^2. + + library(dplyr) + ### Initializing CTA objects before running tests + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + withr::local_dir(tmp_dir) + # Run data through (required) upstream functions + data("demoData") # for tests of structure of demoData itself, see test-scoretest.R + set.seed(98070) + demoData <- demoData[, c(1:5, 33:37)] + NSGMS <- fitPoisBG(demoData) # "single" slide + NSGMS <- aggreprobe(NSGMS, use = "cor") + NSGMS <- BGScoreTest(NSGMS) + + # Negative and Non-Negative facets: + NSGMS_neg <- NSGMS[which(fData(NSGMS)$CodeClass == "Negative"), ] + NSGMS_pos <- NSGMS[-which(fData(NSGMS)$CodeClass == "Negative"), ] + # feature factors + featfact <- fData(NSGMS_neg)[, grep("featfact", fvarLabels(NSGMS_neg))] + # scaling factors + posdat <- Biobase::exprs(NSGMS_pos) + sc1_scores <- fData(NSGMS_pos)[, "scores"] + names(sc1_scores) <- fData(NSGMS_pos)[, "TargetName"] + + features_high <- ((sc1_scores > quantile(sc1_scores, probs = 0.4)) & (sc1_scores < quantile(sc1_scores, probs = 0.95))) |> + which() |> + names() + + backmean <- mean(featfact) + # Negative Binomial threshold model + NSGMS <- fitNBth(NSGMS, + features_high = features_high, + sizefact_BG = NSGMS_neg$sizefact, + threshold_start = backmean, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + threshold_fix = FALSE, # default but calling it explicitly here + tol = 1e-8 + ) + high_ROIs <- sampleNames(NSGMS)[which((quantile(fData(NSGMS)[["para"]][, 1], + probs = 0.90, na.rm = TRUE + ) - notes(NSGMS)[["threshold"]]) * NSGMS$sizefact_fitNBth > 2)] + + features_all <- featureNames(NSGMS_pos) + + # Case 1: Similar to vignette but only treated as a single slide & iterations = 3 + # 2 User need to set iterations =2 for now + expect_error( + fitPoisthNorm( + object = NSGMS, + split = FALSE, + iterations = 3, # note: not the default of 2 + ROIs_high = high_ROIs, + features_high = features_high, + features_all = features_all, + sizefact_start = NSGMS[, high_ROIs][["sizefact_fitNBth"]], + sizefact_BG = NSGMS[, high_ROIs][["sizefact"]], + threshold_mean = backmean, + preci2 = 10000, + prior_type = "contrast", + confac = 1, # default but called explicitly here for the test + preci1con = 1 / 25 + ), + "Only iterations=2 is allowed" + ) + + set.seed(98070) + case1 <- fitPoisthNorm( + object = NSGMS, + split = FALSE, + iterations = 2, + ROIs_high = high_ROIs, + features_high = features_high, + features_all = features_all, + sizefact_start = NSGMS[, high_ROIs][["sizefact_fitNBth"]], + sizefact_BG = NSGMS[, high_ROIs][["sizefact"]], + threshold_mean = backmean, + sizescalebythreshold = TRUE, + preci2 = 10000, + prior_type = "contrast", + confac = 1, # default but called explicitly here for the test + preci1con = 1 / 25 + ) + + set.seed(98070) + NSGMS <- BGScoreTest(NSGMS) + case1_df <- fitPoisthNorm( + object = NSGMS, + split = FALSE, + iterations = 2, + sizescalebythreshold = TRUE, + preci2 = 10000, + prior_type = "contrast", + confac = 1, + preci1con = 1 / 25 + ) + + # 1 Without providing values for ROIs_high, features_high, features_all, sizefact_start, sizefact_BG, the function returns the same value # expect same results without specifying the values. + test_that("expect same results without specifying the values.", { + expect_true(all.equal(case1, case1_df)) + }) + + + # 3 The function outputs a GeoMx S4 class... + expect_true(inherits(case1, "NanoStringGeoMxSet")) + # ...with para0_norm, matrix of estimated parameters, in the featureData. + expect_true("para0_norm" %in% colnames(fData(case1))) + expect_true(inherits(fData(case1)$para0_norm, "matrix")) + # This matrix para0_norm has the following structure: + # 3.1) 1 row for each feature (row name). If a feature is not in features_high, all columns will be NA. + para0_norm <- fData(case1)$para0_norm + expect_true(nrow(para0_norm) == dim(case1)[1]) + expect_true(all(is.na(para0_norm[setdiff(row.names(para0_norm), features_high), ]))) # i.e., get non-features_high rows and check if all are NAs + # 3.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. + expect_true(all(colnames(para0_norm) == paste0("var", 1:(length(high_ROIs) + 1)))) + # 3.3) the n columns will have log2 expression (if feature is in features_high) or NA (otherwise). + expect_false(any(is.na(para0_norm[features_high, 1:length(high_ROIs)]))) + expect_true(all(is.na(para0_norm[setdiff(row.names(para0_norm), features_high), 1:length(high_ROIs)]))) + # 3.4) the n+1th column contains the threshold for each feature in features_high and NA otherwise. + expect_false(any(is.na(para0_norm[features_high, (length(high_ROIs) + 1)]))) + expect_true(all(is.na(para0_norm[setdiff(row.names(para0_norm), features_high), (length(high_ROIs) + 1)]))) + + # 4 The function outputs a GeoMx S4 class... + # (tested above) + # with para_norm, matrix of estimated parameters, in the featureData. + expect_true("para_norm" %in% colnames(fData(case1))) + expect_true(inherits(fData(case1)$para_norm, "matrix")) + # This matrix para_norm has the following structure: + # 4.1) 1 row for each feature (row name) which is equal to the length of features_all + para_norm <- fData(case1)$para_norm + expect_true(nrow(para_norm) == dim(case1)[1]) + # 4.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. + expect_true(all(colnames(para_norm) == paste0("var", 1:(length(high_ROIs) + 1)))) + # 4.3) the n columns will have log2 expression. + expect_false(any(is.na(para_norm[features_all, 1:length(high_ROIs)]))) + # 4.4) the n+1th column contains the threshold for each feature in features_all. + expect_false(any(is.na(para_norm[features_all, (length(high_ROIs) + 1)]))) + + # 5 The function outputs a column called conv0 in featureData, with values in [NA, 0] and length of 0s are the same as the length of features_high. + expect_true("conv0" %in% colnames(fData(case1))) + unique_values <- as.character(unique(fData(case1)$conv0)) + expect_true(all(unique_values %in% c("0", "1", NA))) + to_test <- fData(case1)[fData(case1)$feature_high == 1, ] + expect_true(nrow(to_test) == length(features_high)) + length_na <- length(which(is.na(fData(case1)$conv0))) + expect_true(length_na == length(features_all) - length(features_high) + nrow(NSGMS_neg)) + + # 6 The function outputs a column called conv in featureData, length same as features_all, and has values [NA, 0, 1]. The length of NAs equals the number of negative probes. + expect_true("conv" %in% colnames(fData(case1))) + expect_true(length(fData(case1)$conv) == length(fData(case1)$features_all)) + unique_values <- as.character(unique(fData(case1)$conv)) + expect_true(all(unique_values %in% c("0", "1", NA))) + expect_true(any(is.na(unique_values))) + length_na <- length(which(is.na(fData(case1)$conv))) + expect_true(length_na == nrow(NSGMS_neg)) + + + + # 7 when confac=0 and prior_type="contrast", preci1_norm value in + # experimentData will be single value repeated over an n-by-n matrix (where n is the length of ROI_high). + # This single value is equivalent, within 10 digits, to preci1con/n^2. + case1_1 <- fitPoisthNorm( + object = NSGMS, + split = FALSE, + iterations = 2, + ROIs_high = high_ROIs, + features_high = features_high, + features_all = features_all, + sizefact_start = NSGMS[, high_ROIs][["sizefact_fitNBth"]], + sizefact_BG = NSGMS[, high_ROIs][["sizefact"]], + sizescalebythreshold = TRUE, + threshold_mean = backmean, + preci2 = 10000, + prior_type = "contrast", + confac = 0, + preci1con = 1 / 25 + ) + + + expect_false("preci1_norm" %in% names(notes(NSGMS))) # original object + expect_true("preci1_norm" %in% names(notes(case1))) # case1 + expect_true("preci1_norm" %in% names(notes(case1_1))) # case1 + + preci1_norm <- notes(case1_1)$preci1_norm + expect_true(inherits(preci1_norm, "matrix")) + expect_true(nrow(preci1_norm) == length(high_ROIs)) + expect_true(ncol(preci1_norm) == length(high_ROIs)) + the_testing_value <- (1 / 25) / (length(high_ROIs)^2) + expect_true(length(unique(as.numeric(preci1_norm))) == 1) + expect_true(round(unique(as.numeric(preci1_norm)), 10) == round(the_testing_value, 10)) + + # 8 It returns an error without running fitPoisBG. + test_that("It returns an error without running fitPoisBG.", { expect_error( - fitPoisthNorm( - object = NSGMS, - split = FALSE, - iterations = 3, # note: not the default of 2 - ROIs_high = high_ROIs, - features_high = features_high, - features_all = features_all, - sizefact_start = NSGMS[, high_ROIs][["sizefact_fitNBth"]], - sizefact_BG = NSGMS[, high_ROIs][["sizefact"]], - threshold_mean = backmean, - preci2 = 10000, - prior_type = "contrast", - confac = 1, # default but called explicitly here for the test - preci1con = 1 / 25 - ), - "Only iterations=2 is allowed" - ) - - set.seed(98070) - case1 <- fitPoisthNorm( - object = NSGMS, + fitPoisthNorm( + object = demoData, split = FALSE, iterations = 2, - ROIs_high = high_ROIs, - features_high = features_high, - features_all = features_all, - sizefact_start = NSGMS[, high_ROIs][["sizefact_fitNBth"]], - sizefact_BG = NSGMS[, high_ROIs][["sizefact"]], - threshold_mean = backmean, - sizescalebythreshold = TRUE, + threshold_mean = 1, + preci2 = 10000, + prior_type = "contrast", + confac = 0, + preci1con = 1 / 25 + ), + "Please run `fitPoisBG` first." + ) + expect_error( + fitPoisthNorm( + object = demoData, + split = TRUE, + iterations = 2, + threshold_mean = 1, preci2 = 10000, prior_type = "contrast", - confac = 1, # default but called explicitly here for the test + confac = 0, preci1con = 1 / 25 + ), + "Please run `fitPoisBG` first with `groupvar`." ) - - set.seed(98070) - NSGMS <- BGScoreTest(NSGMS) - case1_df <- fitPoisthNorm( - object = NSGMS, + demoData_fit <- fitPoisBG(demoData, split = FALSE) + expect_error( + fitPoisthNorm( + object = demoData_fit, split = FALSE, iterations = 2, - sizescalebythreshold = TRUE, + threshold_mean = 1, preci2 = 10000, prior_type = "contrast", - confac = 1, + confac = 0, preci1con = 1 / 25 + ), + "Please run `fitNBth` first." ) - - # 1 Without providing values for ROIs_high, features_high, features_all, sizefact_start, sizefact_BG, the function returns the same value # expect same results without specifying the values. - test_that("expect same results without specifying the values.", { - expect_true(all.equal(case1, case1_df)) - }) - - - # 3 The function outputs a GeoMx S4 class... - expect_true(inherits(case1, "NanoStringGeoMxSet")) - # ...with para0_norm, matrix of estimated parameters, in the featureData. - expect_true("para0_norm" %in% colnames(fData(case1))) - expect_true(inherits(fData(case1)$para0_norm, "matrix")) - # This matrix para0_norm has the following structure: - # 3.1) 1 row for each feature (row name). If a feature is not in features_high, all columns will be NA. - para0_norm <- fData(case1)$para0_norm - expect_true(nrow(para0_norm) == dim(case1)[1]) - expect_true(all(is.na(para0_norm[setdiff(row.names(para0_norm), features_high), ]))) # i.e., get non-features_high rows and check if all are NAs - # 3.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. - expect_true(all(colnames(para0_norm) == paste0("var", 1:(length(high_ROIs) + 1)))) - # 3.3) the n columns will have log2 expression (if feature is in features_high) or NA (otherwise). - expect_false(any(is.na(para0_norm[features_high, 1:length(high_ROIs)]))) - expect_true(all(is.na(para0_norm[setdiff(row.names(para0_norm), features_high), 1:length(high_ROIs)]))) - # 3.4) the n+1th column contains the threshold for each feature in features_high and NA otherwise. - expect_false(any(is.na(para0_norm[features_high, (length(high_ROIs) + 1)]))) - expect_true(all(is.na(para0_norm[setdiff(row.names(para0_norm), features_high), (length(high_ROIs) + 1)]))) - - # 4 The function outputs a GeoMx S4 class... - # (tested above) - # with para_norm, matrix of estimated parameters, in the featureData. - expect_true("para_norm" %in% colnames(fData(case1))) - expect_true(inherits(fData(case1)$para_norm, "matrix")) - # This matrix para_norm has the following structure: - # 4.1) 1 row for each feature (row name) which is equal to the length of features_all - para_norm <- fData(case1)$para_norm - expect_true(nrow(para_norm) == dim(case1)[1]) - # 4.2) n+1 columns labeled var1, var2, ..., var, var where n is the length of ROIs_high elements. - expect_true(all(colnames(para_norm) == paste0("var", 1:(length(high_ROIs) + 1)))) - # 4.3) the n columns will have log2 expression. - expect_false(any(is.na(para_norm[features_all, 1:length(high_ROIs)]))) - # 4.4) the n+1th column contains the threshold for each feature in features_all. - expect_false(any(is.na(para_norm[features_all, (length(high_ROIs) + 1)]))) - - # 5 The function outputs a column called conv0 in featureData, with values in [NA, 0] and length of 0s are the same as the length of features_high. - expect_true("conv0" %in% colnames(fData(case1))) - unique_values <- as.character(unique(fData(case1)$conv0)) - expect_true(all(unique_values %in% c("0", "1", NA))) - to_test <- fData(case1)[fData(case1)$feature_high == 1, ] - expect_true(nrow(to_test) == length(features_high)) - length_na <- length(which(is.na(fData(case1)$conv0))) - expect_true(length_na == length(features_all) - length(features_high) + nrow(NSGMS_neg)) - - # 6 The function outputs a column called conv in featureData, length same as features_all, and has values [NA, 0, 1]. The length of NAs equals the number of negative probes. - expect_true("conv" %in% colnames(fData(case1))) - expect_true(length(fData(case1)$conv) == length(fData(case1)$features_all)) - unique_values <- as.character(unique(fData(case1)$conv)) - expect_true(all(unique_values %in% c("0", "1", NA))) - expect_true(any(is.na(unique_values))) - length_na <- length(which(is.na(fData(case1)$conv))) - expect_true(length_na == nrow(NSGMS_neg)) - - - - # 7 when confac=0 and prior_type="contrast", preci1_norm value in - # experimentData will be single value repeated over an n-by-n matrix (where n is the length of ROI_high). - # This single value is equivalent, within 10 digits, to preci1con/n^2. - case1_1 <- fitPoisthNorm( + }) + + + # 9 It returns an error if split is TRUE but no corresponding fitPoisBG is called previously. + test_that("It returns an error if split is TRUE but no corresponding fitPoisBG is called previously.", { + expect_error( + fitPoisthNorm( object = NSGMS, - split = FALSE, + split = TRUE, iterations = 2, ROIs_high = high_ROIs, features_high = features_high, features_all = features_all, sizefact_start = NSGMS[, high_ROIs][["sizefact_fitNBth"]], sizefact_BG = NSGMS[, high_ROIs][["sizefact"]], - sizescalebythreshold = TRUE, threshold_mean = backmean, preci2 = 10000, prior_type = "contrast", confac = 0, preci1con = 1 / 25 + ), + "Please run `fitPoisBG` first with `groupvar`" ) - - - expect_false("preci1_norm" %in% names(notes(NSGMS))) # original object - expect_true("preci1_norm" %in% names(notes(case1))) # case1 - expect_true("preci1_norm" %in% names(notes(case1_1))) # case1 - - preci1_norm <- notes(case1_1)$preci1_norm - expect_true(inherits(preci1_norm, "matrix")) - expect_true(nrow(preci1_norm) == length(high_ROIs)) - expect_true(ncol(preci1_norm) == length(high_ROIs)) - the_testing_value <- (1 / 25) / (length(high_ROIs)^2) - expect_true(length(unique(as.numeric(preci1_norm))) == 1) - expect_true(round(unique(as.numeric(preci1_norm)), 10) == round(the_testing_value, 10)) - - # 8 It returns an error without running fitPoisBG. - test_that("It returns an error without running fitPoisBG.", { - expect_error( - fitPoisthNorm( - object = demoData, - split = FALSE, - iterations = 2, - threshold_mean = 1, - preci2 = 10000, - prior_type = "contrast", - confac = 0, - preci1con = 1 / 25 - ), - "Please run `fitPoisBG` first." - ) - expect_error( - fitPoisthNorm( - object = demoData, - split = TRUE, - iterations = 2, - threshold_mean = 1, - preci2 = 10000, - prior_type = "contrast", - confac = 0, - preci1con = 1 / 25 - ), - "Please run `fitPoisBG` first with `groupvar`." - ) - demoData_fit <- fitPoisBG(demoData, split = FALSE) - expect_error( - fitPoisthNorm( - object = demoData_fit, - split = FALSE, - iterations = 2, - threshold_mean = 1, - preci2 = 10000, - prior_type = "contrast", - confac = 0, - preci1con = 1 / 25 - ), - "Please run `fitNBth` first." - ) - }) - - - # 9 It returns an error if split is TRUE but no corresponding fitPoisBG is called previously. - test_that("It returns an error if split is TRUE but no corresponding fitPoisBG is called previously.", { - expect_error( - fitPoisthNorm( - object = NSGMS, - split = TRUE, - iterations = 2, - ROIs_high = high_ROIs, - features_high = features_high, - features_all = features_all, - sizefact_start = NSGMS[, high_ROIs][["sizefact_fitNBth"]], - sizefact_BG = NSGMS[, high_ROIs][["sizefact"]], - threshold_mean = backmean, - preci2 = 10000, - prior_type = "contrast", - confac = 0, - preci1con = 1 / 25 - ), - "Please run `fitPoisBG` first with `groupvar`" - ) - }) + }) }) test_that("fitPoisthNorm when split = TRUE produces desired results", { - - #### Specs for fitPoisthNorm_sp - # 1. Given a GeoMx S4 object, fitPoisthNorm_sp runs the Poisson model-based - # normalization and log2 transformation on each element in "groupvar" individually. As such, - # the results for a given grouping/facet of the data should match the fitPoisthNorm - # results when an object is subset down to a single slide. Specifically, the following - # should be true: - # 1.1 For a given element in groupvar, the corresponding column in the "threshold0" matrix, which is within featureData, should be identical to the single-patient case's fetureData's para0_norm[,n+1]th column. - # 1.2 For a given element in groupvar, the corresponding column in the "threshold" matrix, which is within featureData, should be identical to the single-patient case's fetureData's para_norm[,n+1]th column. - # 1.3 For a given element in groupvar, the normalized matrix "normmat0_sp", in the assayData slot, should be identical to that element's "normmat0" matrix, also in the assayData slot, for all samples within that element. In other words, the matrix within the "single slide" results (normmat0) should be a subset of the "multiple slide" results (normmat_sp). - # 1.4 For a given element in groupvar, the normaized matrix "normmat_sp", in the assayData slot, should be identical to that element's "normmat" matrix, also in the assayData slot, for all samples within that element. In other words, the matrix within the "single slide" results (normmat) should be a subset of the "multiple slide" results (normmat_sp). - # 1.5 For a given element in groupvar, the vector of sizefact, located in phenoData's sizefact_norm column, is identical to that element's sizefact_norm vector from running fitPoisthNorm (i.e., single grouping case). - # 1.6 For a given element in groupvar, the vector of sizefact0, located in phenoData's sizefact_norm column, is identical to that element's sizefact_norm0 vector from running fitPoisthNorm (i.e., single grouping case). - - - # First, create an NanoStringGeoMxSet object as in the fitPoisthNorm test but split into individual - # objects based on "Subject ID" (i.e., groupvar). - library(dplyr) - ### Initializing CTA objects before running tests - # Create temporary directory that will get destroyed after this block is executed. - tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") - withr::local_dir(tmp_dir) - # Run data through (required) upstream functions - data("demoData") # for tests of structure of demoData itself, see test-scoretest.R - set.seed(98070) - demoData <- demoData[, c(1:5, 33:37)] - NSGMS_sp <- demoData - # Estimate Poisson background sample-feature factor model for multiple slides (sp) - NSGMS_sp <- fitPoisBG(NSGMS_sp, groupvar = "slide name", size_scale = "sum") - NSGMS_sp <- aggreprobe(NSGMS_sp, use = "cor") - NSGMS_sp <- BGScoreTest(NSGMS_sp, split = TRUE) - - # Negative and Non-Negative facets of each: - NSGMS_sp_neg <- NSGMS_sp[which(fData(NSGMS_sp)$CodeClass == "Negative"), ] - NSGMS_sp_pos <- NSGMS_sp[-which(fData(NSGMS_sp)$CodeClass == "Negative"), ] - - # feature factors, features, and backmeans: - featfact_sp <- fData(NSGMS_sp_neg)[, grep("featfact_", fvarLabels(NSGMS_sp_neg))] - posdat_sp <- Biobase::exprs(NSGMS_sp_pos) - sc1_scores_sp <- fData(NSGMS_sp_pos)[, grep("scores", colnames(fData(NSGMS_sp_pos)))] - rownames(sc1_scores_sp) <- fData(NSGMS_sp_pos)[, "TargetName"] - features_high_sp <- apply(sc1_scores_sp, 2, function(x) { - ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) - }) - features_high_sp <- names(which(apply(features_high_sp, 1, all))) - backmean_sp <- (featfact_sp |> colMeans())[1] - - # Fit NB - NSGMS_sp <- fitNBth(NSGMS_sp, - features_high = features_high_sp, - sizefact_BG = NSGMS_sp_neg$sizefact, - threshold_start = backmean_sp, - iterations = 5, - start_para = c(200, 1), - lower_sizefact = 0, - lower_threshold = 100, - tol = 1e-8 - ) - - # Get high ROIs and all features for each: - message("The Workflow_CTA_demoData_S4.Rmd file doesn't consider multiple slide case for determining high ROIs. Will subset data by slide name manually!") - unique_pts <- unique(NSGMS_sp$`slide name`) - high_ROIs_sp <- sampleNames(NSGMS_sp)[which(NSGMS_sp$sizefact_fitNBth * mean(colMeans(fData(NSGMS_sp)[, grep("featfact_", colnames(fData(NSGMS_sp)))], na.rm = TRUE)) > 2)] - features_all_sp <- featureNames(NSGMS_sp_pos) - - # Now run fitPoisthNorm_sp on NSGMS_sp - set.seed(98070) - case_sp <- fitPoisthNorm( - object = NSGMS_sp, - split = TRUE, - ROIs_high = high_ROIs_sp, - features_high = features_high_sp, - features_all = features_all_sp, - sizefact_start = NSGMS_sp[, high_ROIs_sp][["sizefact_fitNBth"]], - sizefact_BG = NSGMS_sp[, high_ROIs_sp][["sizefact_sp"]], - sizescalebythreshold = TRUE, - threshold_mean = backmean_sp, - preci2 = 10000, - prior_type = "contrast", - preci1con = 1 / 25 - ) - - set.seed(98070) - case_sp_df <- fitPoisthNorm( - object = NSGMS_sp, - split = TRUE, - iterations = 2, - sizescalebythreshold = TRUE, - preci2 = 10000, - prior_type = "contrast", - confac = 1, # default but called explicitly here for the test - preci1con = 1 / 25 - ) - - # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value - # expect same results without specifying the values. - test_that("expect same results without specifying the values.", { - expect_true(all.equal(case_sp, case_sp_df)) - }) - # Subset NSGMS_sp into just the first patient and run fitPoisthNorm_sp separately. - p <- unique_pts[1] - NSGMS_pt1 <- NSGMS_sp[, which(phenoData(NSGMS_sp)[["slide name"]] == p)] - high_ROIs_pt1 <- sampleNames(NSGMS_pt1)[which(NSGMS_pt1$sizefact_fitNBth * mean(fData(NSGMS_pt1)[, which(colnames(fData(NSGMS_pt1)) == paste0("featfact_", p))], na.rm = TRUE) > 2)] - - set.seed(98070) - case_pt1 <- fitPoisthNorm( - object = NSGMS_pt1, - split = FALSE, - iterations = 2, - ROIs_high = high_ROIs_pt1, - features_high = features_high_sp, - features_all = features_all_sp, - sizefact_start = NSGMS_pt1[, high_ROIs_pt1][["sizefact_fitNBth"]], - sizefact_BG = NSGMS_pt1[, high_ROIs_pt1][["sizefact_sp"]], - threshold_mean = backmean_sp, - sizescalebythreshold = TRUE, - preci2 = 10000, - prior_type = "contrast", - confac = 1, # default but called explicitly here for the test - preci1con = 1 / 25 - ) - - ## Run tests to compare - # 2.1 For a given element in groupvar, the corresponding column in the "threshold0" matrix, which is within featureData, - # should be identical to the single-patient case's fetureData's para0_norm[,n+1]th column. - threshold0_sp_mat <- fData(case_sp)$threshold0 # pull out the matrix from fData(case_sp) - sp_compare <- threshold0_sp_mat[, which(colnames(threshold0_sp_mat) == unique_pts[1])] # i.e., pt1 pulled out of sp - pt1_compare <- fData(case_pt1)$para0_norm[, length(high_ROIs_pt1) + 1] - expect_true(identical(sp_compare, pt1_compare)) - rm(threshold0_sp_mat) - rm(sp_compare) - rm(pt1_compare) - - # 2.2 For a given element in groupvar, the corresponding column in the "threshold" matrix, which is within featureData, - # should be identical to the single-patient case's fetureData's para_norm[,n+1]th column. - threshold_sp_mat <- fData(case_sp)$threshold # pull out the matrix from fData(case_sp) - sp_compare <- threshold_sp_mat[, which(colnames(threshold_sp_mat) == unique_pts[1])] # i.e., pt1 pulled out of sp - pt1_compare <- fData(case_pt1)$para_norm[, length(high_ROIs_pt1) + 1] - expect_true(identical(sp_compare, pt1_compare)) - rm(threshold_sp_mat) - rm(sp_compare) - rm(pt1_compare) - - # 2.3 For a given element in groupvar, the normalized matrix "normmat0_sp", in the assayData slot, should be identical to - # that element's "normmat0" matrix, also in the assayData slot, for all samples within that element. In other words, - # the matrix within the "single slide" results (normmat0) should be a subset of the "multiple slide" results (normmat_sp). - sp_compare <- assayData(case_sp)$normmat0_sp[, high_ROIs_pt1] - pt1_compare <- assayData(case_pt1)$normmat0[, high_ROIs_pt1] - expect_true(identical(sp_compare, pt1_compare)) - rm(sp_compare) - rm(pt1_compare) - - # 2.4 For a given element in groupvar, the normaized matrix "normmat_sp", in the assayData slot, should be identical to - # that element's "normmat" matrix, also in the assayData slot, for all samples within that element. In other words, - # the matrix within the "single slide" results (normmat) should be a subset of the "multiple slide" results (normmat_sp). - sp_compare <- assayData(case_sp)$normmat_sp[, high_ROIs_pt1] - pt1_compare <- assayData(case_pt1)$normmat[, high_ROIs_pt1] - expect_true(identical(sp_compare, pt1_compare)) - rm(sp_compare) - rm(pt1_compare) - - # 2.5 For a given element in groupvar, the vector of sizefact, located in phenoData's sizefact_norm column, is identical to - # that element's sizefact_norm vector from running fitPoisthNorm (i.e., single grouping case). - sp_compare <- pData( - case_sp[, which(pData(case_sp)[["slide name"]] == p)] - )$sizefact_norm - pt1_compare <- pData(case_pt1)$sizefact_norm - expect_true(identical(sp_compare, pt1_compare)) - rm(sp_compare) - rm(pt1_compare) - - # 2.6 For a given element in groupvar, the vector of sizefact0, located in phenoData's sizefact_norm column, is identical to - # that element's sizefact_norm0 vector from running fitPoisthNorm (i.e., single grouping case). - sp_compare <- pData( - case_sp[, which(pData(case_sp)[["slide name"]] == p)] - )$sizefact0_norm - pt1_compare <- pData(case_pt1)$sizefact0_norm - expect_true(identical(sp_compare, pt1_compare)) - rm(sp_compare) - rm(pt1_compare) + + #### Specs for fitPoisthNorm_sp + # 1. Given a GeoMx S4 object, fitPoisthNorm_sp runs the Poisson model-based + # normalization and log2 transformation on each element in "groupvar" individually. As such, + # the results for a given grouping/facet of the data should match the fitPoisthNorm + # results when an object is subset down to a single slide. Specifically, the following + # should be true: + # 1.1 For a given element in groupvar, the corresponding column in the "threshold0" matrix, which is within featureData, should be identical to the single-patient case's fetureData's para0_norm[,n+1]th column. + # 1.2 For a given element in groupvar, the corresponding column in the "threshold" matrix, which is within featureData, should be identical to the single-patient case's fetureData's para_norm[,n+1]th column. + # 1.3 For a given element in groupvar, the normalized matrix "normmat0_sp", in the assayData slot, should be identical to that element's "normmat0" matrix, also in the assayData slot, for all samples within that element. In other words, the matrix within the "single slide" results (normmat0) should be a subset of the "multiple slide" results (normmat_sp). + # 1.4 For a given element in groupvar, the normaized matrix "normmat_sp", in the assayData slot, should be identical to that element's "normmat" matrix, also in the assayData slot, for all samples within that element. In other words, the matrix within the "single slide" results (normmat) should be a subset of the "multiple slide" results (normmat_sp). + # 1.5 For a given element in groupvar, the vector of sizefact, located in phenoData's sizefact_norm column, is identical to that element's sizefact_norm vector from running fitPoisthNorm (i.e., single grouping case). + # 1.6 For a given element in groupvar, the vector of sizefact0, located in phenoData's sizefact_norm column, is identical to that element's sizefact_norm0 vector from running fitPoisthNorm (i.e., single grouping case). + + + # First, create an NanoStringGeoMxSet object as in the fitPoisthNorm test but split into individual + # objects based on "Subject ID" (i.e., groupvar). + library(dplyr) + ### Initializing CTA objects before running tests + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + withr::local_dir(tmp_dir) + # Run data through (required) upstream functions + data("demoData") # for tests of structure of demoData itself, see test-scoretest.R + set.seed(98070) + demoData <- demoData[, c(1:5, 33:37)] + NSGMS_sp <- demoData + # Estimate Poisson background sample-feature factor model for multiple slides (sp) + NSGMS_sp <- fitPoisBG(NSGMS_sp, groupvar = "slide name", size_scale = "sum") + NSGMS_sp <- aggreprobe(NSGMS_sp, use = "cor") + NSGMS_sp <- BGScoreTest(NSGMS_sp, split = TRUE) + + # Negative and Non-Negative facets of each: + NSGMS_sp_neg <- NSGMS_sp[which(fData(NSGMS_sp)$CodeClass == "Negative"), ] + NSGMS_sp_pos <- NSGMS_sp[-which(fData(NSGMS_sp)$CodeClass == "Negative"), ] + + # feature factors, features, and backmeans: + featfact_sp <- fData(NSGMS_sp_neg)[, grep("featfact_", fvarLabels(NSGMS_sp_neg))] + posdat_sp <- Biobase::exprs(NSGMS_sp_pos) + sc1_scores_sp <- fData(NSGMS_sp_pos)[, grep("scores", colnames(fData(NSGMS_sp_pos)))] + rownames(sc1_scores_sp) <- fData(NSGMS_sp_pos)[, "TargetName"] + features_high_sp <- apply(sc1_scores_sp, 2, function(x) { + ((x > quantile(x, probs = 0.4)) & (x < quantile(x, probs = 0.95))) + }) + features_high_sp <- names(which(apply(features_high_sp, 1, all))) + backmean_sp <- (featfact_sp |> colMeans())[1] + + # Fit NB + NSGMS_sp <- fitNBth(NSGMS_sp, + features_high = features_high_sp, + sizefact_BG = NSGMS_sp_neg$sizefact, + threshold_start = backmean_sp, + iterations = 5, + start_para = c(200, 1), + lower_sizefact = 0, + lower_threshold = 100, + tol = 1e-8 + ) + + # Get high ROIs and all features for each: + message("The Workflow_CTA_demoData_S4.Rmd file doesn't consider multiple slide case for determining high ROIs. Will subset data by slide name manually!") + unique_pts <- unique(NSGMS_sp$`slide name`) + high_ROIs_sp <- sampleNames(NSGMS_sp)[which(NSGMS_sp$sizefact_fitNBth * mean(colMeans(fData(NSGMS_sp)[, grep("featfact_", colnames(fData(NSGMS_sp)))], na.rm = TRUE)) > 2)] + features_all_sp <- featureNames(NSGMS_sp_pos) + + # Now run fitPoisthNorm_sp on NSGMS_sp + set.seed(98070) + case_sp <- fitPoisthNorm( + object = NSGMS_sp, + split = TRUE, + ROIs_high = high_ROIs_sp, + features_high = features_high_sp, + features_all = features_all_sp, + sizefact_start = NSGMS_sp[, high_ROIs_sp][["sizefact_fitNBth"]], + sizefact_BG = NSGMS_sp[, high_ROIs_sp][["sizefact_sp"]], + sizescalebythreshold = TRUE, + threshold_mean = backmean_sp, + preci2 = 10000, + prior_type = "contrast", + preci1con = 1 / 25 + ) + + set.seed(98070) + case_sp_df <- fitPoisthNorm( + object = NSGMS_sp, + split = TRUE, + iterations = 2, + sizescalebythreshold = TRUE, + preci2 = 10000, + prior_type = "contrast", + confac = 1, # default but called explicitly here for the test + preci1con = 1 / 25 + ) + + # 1 Without providing values for features_high, sizefact_BG, threshold_start, the function returns the same value + # expect same results without specifying the values. + test_that("expect same results without specifying the values.", { + expect_true(all.equal(case_sp, case_sp_df)) + }) + # Subset NSGMS_sp into just the first patient and run fitPoisthNorm_sp separately. + p <- unique_pts[1] + NSGMS_pt1 <- NSGMS_sp[, which(phenoData(NSGMS_sp)[["slide name"]] == p)] + high_ROIs_pt1 <- sampleNames(NSGMS_pt1)[which(NSGMS_pt1$sizefact_fitNBth * mean(fData(NSGMS_pt1)[, which(colnames(fData(NSGMS_pt1)) == paste0("featfact_", p))], na.rm = TRUE) > 2)] + + set.seed(98070) + case_pt1 <- fitPoisthNorm( + object = NSGMS_pt1, + split = FALSE, + iterations = 2, + ROIs_high = high_ROIs_pt1, + features_high = features_high_sp, + features_all = features_all_sp, + sizefact_start = NSGMS_pt1[, high_ROIs_pt1][["sizefact_fitNBth"]], + sizefact_BG = NSGMS_pt1[, high_ROIs_pt1][["sizefact_sp"]], + threshold_mean = backmean_sp, + sizescalebythreshold = TRUE, + preci2 = 10000, + prior_type = "contrast", + confac = 1, # default but called explicitly here for the test + preci1con = 1 / 25 + ) + + ## Run tests to compare + # 2.1 For a given element in groupvar, the corresponding column in the "threshold0" matrix, which is within featureData, + # should be identical to the single-patient case's fetureData's para0_norm[,n+1]th column. + threshold0_sp_mat <- fData(case_sp)$threshold0 # pull out the matrix from fData(case_sp) + sp_compare <- threshold0_sp_mat[, which(colnames(threshold0_sp_mat) == unique_pts[1])] # i.e., pt1 pulled out of sp + pt1_compare <- fData(case_pt1)$para0_norm[, length(high_ROIs_pt1) + 1] + expect_true(identical(sp_compare, pt1_compare)) + rm(threshold0_sp_mat) + rm(sp_compare) + rm(pt1_compare) + + # 2.2 For a given element in groupvar, the corresponding column in the "threshold" matrix, which is within featureData, + # should be identical to the single-patient case's fetureData's para_norm[,n+1]th column. + threshold_sp_mat <- fData(case_sp)$threshold # pull out the matrix from fData(case_sp) + sp_compare <- threshold_sp_mat[, which(colnames(threshold_sp_mat) == unique_pts[1])] # i.e., pt1 pulled out of sp + pt1_compare <- fData(case_pt1)$para_norm[, length(high_ROIs_pt1) + 1] + expect_true(identical(sp_compare, pt1_compare)) + rm(threshold_sp_mat) + rm(sp_compare) + rm(pt1_compare) + + # 2.3 For a given element in groupvar, the normalized matrix "normmat0_sp", in the assayData slot, should be identical to + # that element's "normmat0" matrix, also in the assayData slot, for all samples within that element. In other words, + # the matrix within the "single slide" results (normmat0) should be a subset of the "multiple slide" results (normmat_sp). + sp_compare <- assayData(case_sp)$normmat0_sp[, high_ROIs_pt1] + pt1_compare <- assayData(case_pt1)$normmat0[, high_ROIs_pt1] + expect_true(identical(sp_compare, pt1_compare)) + rm(sp_compare) + rm(pt1_compare) + + # 2.4 For a given element in groupvar, the normaized matrix "normmat_sp", in the assayData slot, should be identical to + # that element's "normmat" matrix, also in the assayData slot, for all samples within that element. In other words, + # the matrix within the "single slide" results (normmat) should be a subset of the "multiple slide" results (normmat_sp). + sp_compare <- assayData(case_sp)$normmat_sp[, high_ROIs_pt1] + pt1_compare <- assayData(case_pt1)$normmat[, high_ROIs_pt1] + expect_true(identical(sp_compare, pt1_compare)) + rm(sp_compare) + rm(pt1_compare) + + # 2.5 For a given element in groupvar, the vector of sizefact, located in phenoData's sizefact_norm column, is identical to + # that element's sizefact_norm vector from running fitPoisthNorm (i.e., single grouping case). + sp_compare <- pData( + case_sp[, which(pData(case_sp)[["slide name"]] == p)] + )$sizefact_norm + pt1_compare <- pData(case_pt1)$sizefact_norm + expect_true(identical(sp_compare, pt1_compare)) + rm(sp_compare) + rm(pt1_compare) + + # 2.6 For a given element in groupvar, the vector of sizefact0, located in phenoData's sizefact_norm column, is identical to + # that element's sizefact_norm0 vector from running fitPoisthNorm (i.e., single grouping case). + sp_compare <- pData( + case_sp[, which(pData(case_sp)[["slide name"]] == p)] + )$sizefact0_norm + pt1_compare <- pData(case_pt1)$sizefact0_norm + expect_true(identical(sp_compare, pt1_compare)) + rm(sp_compare) + rm(pt1_compare) }) diff --git a/tests/testthat/test-scoretest.R b/tests/testthat/test-scoretest.R index f16819a..c2569c9 100644 --- a/tests/testthat/test-scoretest.R +++ b/tests/testthat/test-scoretest.R @@ -2,557 +2,617 @@ ### BGScoreTest for single slide and multiple slides test_that("BGScoreTest for single slide produces desired results", { + + # Desired results occurs when: + # 1 The function outputs a GeoMx S4 class with p values in featureData with length same as length of targets. The p value is NA for negative probes. + # 2 The function outputs a GeoMx S4 class with score values in featureData with length same as length of targets. The score value is NA for negative probes. + # 3 All p values are between 0 and 1 (inclusive) for non-negative features. + # 4 The length of non-NA p values is equal to the number of non-negative probes. + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + # 6 The order of pvalues is the same as scores. + + # Preamble/load example data + data("demoData") + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + # Change to the temporary directory (will set back to getwd() once block is executed.) + withr::local_dir(tmp_dir) + expect_true(inherits(demoData, "NanoStringGeoMxSet")) + + # First run tests to ensure that the input data is as expected + expect_true(nrow(pData(demoData)) == 88) + expect_true(ncol(pData(demoData)) == 6) + expect_true(nrow(pData(protocolData(demoData))) == 88) + expect_true(ncol(pData(protocolData(demoData))) == 21) + expect_true(inherits(assayData(demoData)[["exprs"]], "matrix")) + expect_true(nrow(assayData(demoData)[["exprs"]]) == 8707) + expect_true(ncol(assayData(demoData)[["exprs"]]) == 88) + + # Next estimate Poisson background sample-feature factor model + set.seed(98070) + demoData <- fitPoisBG(demoData) + demoData <- aggreprobe(demoData, use = "cor") + # Case 1: adjustment factor 5, no outlier removal, no prior + case1 <- BGScoreTest(demoData, + adj = 5, + removeoutlier = FALSE, useprior = FALSE + ) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case1, "NanoStringGeoMxSet")) + # ...with p values in featureData... + expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' + expect_true("pvalues" %in% colnames(fData(case1))) # new object does have 'pvalues' + # ...with length same as length of targets. + expect_true(length(featureNames(case1)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case1_negatives <- case1[which(fData(case1)$CodeClass == "Negative"), ] + expect_true(all(is.na(fData(case1_negatives)$pvalues))) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' + expect_true("scores" %in% colnames(fData(case1))) # new object does have 'scores' + # ...with length same as length of targets. + # (tested above) + # The score value is NA for negative probes. + expect_true(all(is.na(fData(case1_negatives)$scores))) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case1_positives <- case1[fData(case1)[["Negative"]] == FALSE, ] # non-negative features (endog + control) + expect_true(all(fData(case1_positives)$pvalues >= 0 | fData(case1_positives)$pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case1)$pvalues))) == nrow(case1_positives)) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case1)$scores))) == nrow(case1_positives)) + + # 6 The order of pvalues is the same as scores. + expect_identical( + pnorm(fData(case1_positives)[["scores"]], lower.tail = FALSE), + fData(case1_positives)[["pvalues"]] + ) + + # Case 2: adjustment factor 5, outlier removal, with prior + # This runs the same tests as above but with different parameters. + case2 <- BGScoreTest(demoData, + adj = 5, + removeoutlier = TRUE, useprior = TRUE + ) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case2, "NanoStringGeoMxSet")) + # ...with p values in featureData... + expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' + expect_true("pvalues" %in% colnames(fData(case2))) # new object does have 'pvalues' + # ...with length same as length of targets. + expect_true(length(featureNames(case2)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case2_negatives <- case2[which(fData(case2)$CodeClass == "Negative"), ] + expect_true(all(is.na(fData(case2_negatives)$pvalues))) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' + expect_true("scores" %in% colnames(fData(case2))) # new object does have 'scores' + # ...with length same as length of targets. + # (tested above) + # The score value is NA for negative probes. + expect_true(all(is.na(fData(case2_negatives)$scores))) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case2_positives <- case1[fData(case2)[["Negative"]] == FALSE, ] # positive features + expect_true(all(fData(case2_positives)$pvalues >= 0 | fData(case2_positives)$pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case2)$pvalues))) == nrow(case2_positives)) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case2)$scores))) == nrow(case2_positives)) + + # 6 The order of pvalues is the same as scores. + expect_identical( + pnorm(fData(case2_positives)[["scores"]], lower.tail = FALSE), + fData(case2_positives)[["pvalues"]] + ) + + # Case 3: adjustment factor 5, outlier removal, without prior + # This runs the same tests as above but with different parameters. + case3 <- BGScoreTest(demoData, + adj = 5, + removeoutlier = TRUE, useprior = FALSE + ) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case3, "NanoStringGeoMxSet")) + # ...with p values in featureData... + expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' + expect_true("pvalues" %in% colnames(fData(case3))) # new object does have 'pvalues' + # ...with length same as length of targets. + expect_true(length(featureNames(case3)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case3_negatives <- case3[which(fData(case3)$CodeClass == "Negative"), ] + expect_true(all(is.na(fData(case3_negatives)$pvalues))) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' + expect_true("scores" %in% colnames(fData(case3))) # new object does have 'scores' + # ...with length same as length of targets. + # (tested above) + # The score value is NA for negative probes. + expect_true(all(is.na(fData(case3_negatives)$scores))) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case3_positives <- case1[fData(case3)[["Negative"]] == FALSE, ] # positive features + expect_true(all(fData(case3_positives)$pvalues >= 0 | fData(case3_positives)$pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case3)$pvalues))) == nrow(case3_positives)) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case3)$scores))) == nrow(case3_positives)) + + # 6 The order of pvalues is the same as scores. + expect_identical( + pnorm(fData(case3_positives)[["scores"]], lower.tail = FALSE), + fData(case3_positives)[["pvalues"]] + ) + + # Case 4: adjustment factor 5, no outlier removal, with prior + # This runs the same tests as above but with different parameters. + case4 <- BGScoreTest(demoData, + adj = 5, + removeoutlier = FALSE, useprior = TRUE + ) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case4, "NanoStringGeoMxSet")) + # ...with p values in featureData... + expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' + expect_true("pvalues" %in% colnames(fData(case4))) # new object does have 'pvalues' + # ...with length same as length of targets. + expect_true(length(featureNames(case4)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case4_negatives <- case4[which(fData(case4)$CodeClass == "Negative"), ] + expect_true(all(is.na(fData(case4_negatives)$pvalues))) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' + expect_true("scores" %in% colnames(fData(case4))) # new object does have 'scores' + # ...with length same as length of targets. + # (tested above) + # The score value is NA for negative probes. + expect_true(all(is.na(fData(case4_negatives)$scores))) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case4_positives <- case1[fData(case4)[["Negative"]] == FALSE, ] # positive features + expect_true(all(fData(case4_positives)$pvalues >= 0 | fData(case4_positives)$pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case4)$pvalues))) == nrow(case4_positives)) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case4)$scores))) == nrow(case4_positives)) + + # 6 The order of pvalues is the same as scores. + expect_identical( + pnorm(fData(case4_positives)[["scores"]], lower.tail = FALSE), + fData(case4_positives)[["pvalues"]] + ) + + # four different settings should yield different results if outliers are present. + expect_false(identical(fData(case1)[["pvalues"]], fData(case2)[["pvalues"]])) + expect_false(identical(fData(case1)[["pvalues"]], fData(case3)[["pvalues"]])) + expect_false(identical(fData(case1)[["pvalues"]], fData(case4)[["pvalues"]])) + expect_false(identical(fData(case2)[["pvalues"]], fData(case3)[["pvalues"]])) + expect_false(identical(fData(case2)[["pvalues"]], fData(case4)[["pvalues"]])) + expect_false(identical(fData(case3)[["pvalues"]], fData(case4)[["pvalues"]])) +}) - # Desired results occurs when: - # 1 The function outputs a GeoMx S4 class with p values in featureData with length same as length of targets. The p value is NA for negative probes. - # 2 The function outputs a GeoMx S4 class with score values in featureData with length same as length of targets. The score value is NA for negative probes. - # 3 All p values are between 0 and 1 (inclusive) for non-negative features. - # 4 The length of non-NA p values is equal to the number of non-negative probes. - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - # 6 The order of pvalues is the same as scores. - - # Preamble/load example data - data("demoData") - # Create temporary directory that will get destroyed after this block is executed. - tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") - # Change to the temporary directory (will set back to getwd() once block is executed.) - withr::local_dir(tmp_dir) - expect_true(inherits(demoData, "NanoStringGeoMxSet")) - - # First run tests to ensure that the input data is as expected - expect_true(nrow(pData(demoData)) == 88) - expect_true(ncol(pData(demoData)) == 6) - expect_true(nrow(pData(protocolData(demoData))) == 88) - expect_true(ncol(pData(protocolData(demoData))) == 21) - expect_true(inherits(assayData(demoData)[["exprs"]], "matrix")) - expect_true(nrow(assayData(demoData)[["exprs"]]) == 8707) - expect_true(ncol(assayData(demoData)[["exprs"]]) == 88) - # Next estimate Poisson background sample-feature factor model - set.seed(98070) - demoData <- fitPoisBG(demoData) - demoData <- aggreprobe(demoData, use = "cor") - # Case 1: adjustment factor 5, no outlier removal, no prior - case1 <- BGScoreTest(demoData, - adj = 5, - removeoutlier = FALSE, useprior = FALSE +test_that("BGScoreTest dgCMatrix sparse matrix format data runs without errors", { + + data("demoData") + negdat <- demoData[which(Biobase::fData(demoData)$CodeClass == "Negative"), ] + countmat <- Biobase::exprs(negdat) + countmat = as(countmat, "dgCMatrix") + result <- fitPoisBG( + object = countmat, + iterations = 10, + tol = 1e-3, + size_scale = "sum") + demoData[["sizefact"]] <- result$sizefact[Biobase::sampleNames(demoData)] + Biobase::fData(demoData)[["featfact"]] <- NA + Biobase::fData(demoData)[["featfact"]][match(names(result$featfact), Biobase::featureNames(demoData), nomatch = 0)] <- result$featfact + demoData <- aggreprobe(demoData, use = "cor") + # Case 1: adjustment factor 5, no outlier removal, no prior + case1_1 <- BGScoreTest(demoData, + adj = 5, + removeoutlier = FALSE, useprior = FALSE + ) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case1_1, "NanoStringGeoMxSet")) + # ...with p values in featureData... + expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' + expect_true("pvalues" %in% colnames(fData(case1_1))) # new object does have 'pvalues' + # ...with length same as length of targets. + expect_true(length(featureNames(case1_1)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case1_1_negatives <- case1_1[which(fData(case1_1)$CodeClass == "Negative"), ] + expect_true(all(is.na(fData(case1_1_negatives)$pvalues))) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' + expect_true("scores" %in% colnames(fData(case1_1))) # new object does have 'scores' + # ...with length same as length of targets. + # (tested above) + # The score value is NA for negative probes. + expect_true(all(is.na(fData(case1_1_negatives)$scores))) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case1_1_positives <- case1_1[fData(case1_1)[["Negative"]] == FALSE, ] # non-negative features (endog + control) + expect_true(all(fData(case1_1_positives)$pvalues >= 0 | fData(case1_1_positives)$pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case1_1)$pvalues))) == nrow(case1_1_positives)) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + expect_true(length(which(!is.na(fData(case1_1)$scores))) == nrow(case1_1_positives)) + + # 6 The order of pvalues is the same as scores. + expect_identical( + pnorm(fData(case1_1_positives)[["scores"]], lower.tail = FALSE), + fData(case1_1_positives)[["pvalues"]] + ) +}) +test_that("BGScoreTest for multiple slides produces desired results", { + + # Desired results occurs when: + # 1 The function outputs a GeoMx S4 class with p values in featureData with length same as length of targets for each unique id value. The p value is NA for negative probes. + # 2 The function outputs a GeoMx S4 class with score values in featureData with length same as length of targets for each unique id value. The score value is NA for negative probes. + # 3 All p values are between 0 and 1 (inclusive) for non-negative features. + # 4 The order of each column of pvalues is the same as each column of scores for each unique id value. + + # Preamble/load example data + # Create temporary directory that will get destroyed after this block is executed. + tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") + # Change to the temporary directory (will set back to getwd() once block is executed.) + withr::local_dir(tmp_dir) + data("demoData") # input structure checked above and not repeated here + # Estimate Poisson background sample-feature factor model for multiple slides + set.seed(98070) + demoData <- fitPoisBG(demoData, groupvar = "slide name", size_scale = "sum") + demoData <- diagPoisBG(demoData, split = TRUE) + demoData <- aggreprobe(demoData, use = "cor") + + # Case 1: adjustment factor 5, no prior, no outlier removal + case1 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = FALSE, removeoutlier = FALSE) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case1, "NanoStringGeoMxSet")) + # ...with p values in featureData... + unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids + expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case1)))) + # ...with length same as length of targets for each unique id value. + expect_true(length(featureNames(case1)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case1_negatives <- case1[which(fData(case1)$CodeClass == "Negative"), ] + expect_true( + all(is.na(fData(case1_negatives)[, grepl("pvalues_", colnames(fData(case1_negatives)))])) + ) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case1)))) + # ...with length same as length of targets for each unique id value. + # (tested above) + # The score value is NA for negative probes. + expect_true( + all(is.na(fData(case1_negatives)[, grepl("scores_", colnames(fData(case1_negatives)))])) + ) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case1_positives <- case1[fData(case1)[["Negative"]] == FALSE, ] + pos_pvalues <- as.numeric(as.matrix(fData(case1_positives)[, grepl("pvalues_", colnames(fData(case1_positives)))])) + expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + compute_length_non_nas_per_column <- function(df) { + return( + as.numeric(apply(df, 2, function(x) { + length(which(!is.na(x))) + })) ) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case1, "NanoStringGeoMxSet")) - # ...with p values in featureData... - expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' - expect_true("pvalues" %in% colnames(fData(case1))) # new object does have 'pvalues' - # ...with length same as length of targets. - expect_true(length(featureNames(case1)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case1_negatives <- case1[which(fData(case1)$CodeClass == "Negative"), ] - expect_true(all(is.na(fData(case1_negatives)$pvalues))) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' - expect_true("scores" %in% colnames(fData(case1))) # new object does have 'scores' - # ...with length same as length of targets. - # (tested above) - # The score value is NA for negative probes. - expect_true(all(is.na(fData(case1_negatives)$scores))) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case1_positives <- case1[fData(case1)[["Negative"]] == FALSE, ] # non-negative features (endog + control) - expect_true(all(fData(case1_positives)$pvalues >= 0 | fData(case1_positives)$pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case1)$pvalues))) == nrow(case1_positives)) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case1)$scores))) == nrow(case1_positives)) - - # 6 The order of pvalues is the same as scores. + } + to_test <- compute_length_non_nas_per_column( + df = fData(case1)[, grepl("pvalues_", colnames(fData(case1)))] + ) + expect_true(all(to_test %in% nrow(case1_positives))) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + to_test <- compute_length_non_nas_per_column( + df = fData(case1)[, grepl("scores_", colnames(fData(case1)))] + ) + expect_true(all(to_test %in% nrow(case1_positives))) + + # 6 The order of pvalues is the same as scores. + # This will loop through the different slides (i.e., IDs). + for (id in unique_ids) { expect_identical( - pnorm(fData(case1_positives)[["scores"]], lower.tail = FALSE), - fData(case1_positives)[["pvalues"]] + pnorm(fData(case1_positives)[[paste0("scores_", id)]], lower.tail = FALSE), + fData(case1_positives)[[paste0("pvalues_", id)]] ) - - # Case 2: adjustment factor 5, outlier removal, with prior - # This runs the same tests as above but with different parameters. - case2 <- BGScoreTest(demoData, - adj = 5, - removeoutlier = TRUE, useprior = TRUE + } + + # Case 2: adjustment factor 5, no prior, outlier removal + case2 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = FALSE, removeoutlier = TRUE) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case2, "NanoStringGeoMxSet")) + # ...with p values in featureData... + unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids + expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case2)))) + # ...with length same as length of targets for each unique id value. + expect_true(length(featureNames(case2)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case2_negatives <- case2[which(fData(case2)$CodeClass == "Negative"), ] + expect_true( + all(is.na(fData(case2_negatives)[, grepl("pvalues_", colnames(fData(case2_negatives)))])) + ) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case2)))) + # ...with length same as length of targets for each unique id value. + # (tested above) + # The score value is NA for negative probes. + expect_true( + all(is.na(fData(case2_negatives)[, grepl("scores_", colnames(fData(case2_negatives)))])) + ) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case2_positives <- case2[fData(case2)[["Negative"]] == FALSE, ] + pos_pvalues <- as.numeric(as.matrix(fData(case2_positives)[, grepl("pvalues_", colnames(fData(case2_positives)))])) + expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + compute_length_non_nas_per_column <- function(df) { + return( + as.numeric(apply(df, 2, function(x) { + length(which(!is.na(x))) + })) ) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case2, "NanoStringGeoMxSet")) - # ...with p values in featureData... - expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' - expect_true("pvalues" %in% colnames(fData(case2))) # new object does have 'pvalues' - # ...with length same as length of targets. - expect_true(length(featureNames(case2)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case2_negatives <- case2[which(fData(case2)$CodeClass == "Negative"), ] - expect_true(all(is.na(fData(case2_negatives)$pvalues))) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' - expect_true("scores" %in% colnames(fData(case2))) # new object does have 'scores' - # ...with length same as length of targets. - # (tested above) - # The score value is NA for negative probes. - expect_true(all(is.na(fData(case2_negatives)$scores))) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case2_positives <- case1[fData(case2)[["Negative"]] == FALSE, ] # positive features - expect_true(all(fData(case2_positives)$pvalues >= 0 | fData(case2_positives)$pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case2)$pvalues))) == nrow(case2_positives)) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case2)$scores))) == nrow(case2_positives)) - - # 6 The order of pvalues is the same as scores. + } + to_test <- compute_length_non_nas_per_column( + df = fData(case2)[, grepl("pvalues_", colnames(fData(case2)))] + ) + expect_true(all(to_test %in% nrow(case2_positives))) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + to_test <- compute_length_non_nas_per_column( + df = fData(case2)[, grepl("scores_", colnames(fData(case2)))] + ) + expect_true(all(to_test %in% nrow(case2_positives))) + + # 6 The order of pvalues is the same as scores. + # This will loop through the different slides (i.e., IDs). + for (id in unique_ids) { expect_identical( - pnorm(fData(case2_positives)[["scores"]], lower.tail = FALSE), - fData(case2_positives)[["pvalues"]] + pnorm(fData(case2_positives)[[paste0("scores_", id)]], lower.tail = FALSE), + fData(case2_positives)[[paste0("pvalues_", id)]] ) - - # Case 3: adjustment factor 5, outlier removal, without prior - # This runs the same tests as above but with different parameters. - case3 <- BGScoreTest(demoData, - adj = 5, - removeoutlier = TRUE, useprior = FALSE + } + + + # Case 3: adjustment factor 5, with prior, no outlier removal + case3 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = TRUE, removeoutlier = FALSE) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case3, "NanoStringGeoMxSet")) + # ...with p values in featureData... + unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids + expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case3)))) + # ...with length same as length of targets for each unique id value. + expect_true(length(featureNames(case3)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case3_negatives <- case3[which(fData(case3)$CodeClass == "Negative"), ] + expect_true( + all(is.na(fData(case3_negatives)[, grepl("pvalues_", colnames(fData(case3_negatives)))])) + ) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case3)))) + # ...with length same as length of targets for each unique id value. + # (tested above) + # The score value is NA for negative probes. + expect_true( + all(is.na(fData(case3_negatives)[, grepl("scores_", colnames(fData(case3_negatives)))])) + ) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case3_positives <- case3[fData(case3)[["Negative"]] == FALSE, ] + pos_pvalues <- as.numeric(as.matrix(fData(case3_positives)[, grepl("pvalues_", colnames(fData(case3_positives)))])) + expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + compute_length_non_nas_per_column <- function(df) { + return( + as.numeric(apply(df, 2, function(x) { + length(which(!is.na(x))) + })) ) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case3, "NanoStringGeoMxSet")) - # ...with p values in featureData... - expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' - expect_true("pvalues" %in% colnames(fData(case3))) # new object does have 'pvalues' - # ...with length same as length of targets. - expect_true(length(featureNames(case3)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case3_negatives <- case3[which(fData(case3)$CodeClass == "Negative"), ] - expect_true(all(is.na(fData(case3_negatives)$pvalues))) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' - expect_true("scores" %in% colnames(fData(case3))) # new object does have 'scores' - # ...with length same as length of targets. - # (tested above) - # The score value is NA for negative probes. - expect_true(all(is.na(fData(case3_negatives)$scores))) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case3_positives <- case1[fData(case3)[["Negative"]] == FALSE, ] # positive features - expect_true(all(fData(case3_positives)$pvalues >= 0 | fData(case3_positives)$pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case3)$pvalues))) == nrow(case3_positives)) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case3)$scores))) == nrow(case3_positives)) - - # 6 The order of pvalues is the same as scores. + } + to_test <- compute_length_non_nas_per_column( + df = fData(case3)[, grepl("pvalues_", colnames(fData(case3)))] + ) + expect_true(all(to_test %in% nrow(case3_positives))) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + to_test <- compute_length_non_nas_per_column( + df = fData(case3)[, grepl("scores_", colnames(fData(case3)))] + ) + expect_true(all(to_test %in% nrow(case3_positives))) + + # 6 The order of pvalues is the same as scores. + # This will loop through the different slides (i.e., IDs). + for (id in unique_ids) { expect_identical( - pnorm(fData(case3_positives)[["scores"]], lower.tail = FALSE), - fData(case3_positives)[["pvalues"]] + pnorm(fData(case3_positives)[[paste0("scores_", id)]], lower.tail = FALSE), + fData(case3_positives)[[paste0("pvalues_", id)]] ) - - # Case 4: adjustment factor 5, no outlier removal, with prior - # This runs the same tests as above but with different parameters. - case4 <- BGScoreTest(demoData, - adj = 5, - removeoutlier = FALSE, useprior = TRUE + } + + # Case 4: adjustment factor 5, no prior, outlier removal + case4 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = TRUE, removeoutlier = TRUE) + + # 1 The function outputs a GeoMx S4 class... + expect_true(inherits(case4, "NanoStringGeoMxSet")) + # ...with p values in featureData... + unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids + expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case4)))) + # ...with length same as length of targets for each unique id value. + expect_true(length(featureNames(case4)) == length(featureNames(demoData))) + # The p value is NA for negative probes. + case4_negatives <- case4[which(fData(case4)$CodeClass == "Negative"), ] + expect_true( + all(is.na(fData(case4_negatives)[, grepl("pvalues_", colnames(fData(case4_negatives)))])) + ) + + # 2 The function outputs a GeoMx S4 class... + # (testing above)... + # ...with score values in featureData... + expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' + expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case4)))) + # ...with length same as length of targets for each unique id value. + # (tested above) + # The score value is NA for negative probes. + expect_true( + all(is.na(fData(case4_negatives)[, grepl("scores_", colnames(fData(case4_negatives)))])) + ) + + # 3 All p values are between 0 and 1 (inclusive) + # for non-negative features. + case4_positives <- case4[fData(case4)[["Negative"]] == FALSE, ] + pos_pvalues <- as.numeric(as.matrix(fData(case4_positives)[, grepl("pvalues_", colnames(fData(case4_positives)))])) + expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) + + # 4 The length of non-NA p values is equal to the number of non-negative probes. + compute_length_non_nas_per_column <- function(df) { + return( + as.numeric(apply(df, 2, function(x) { + length(which(!is.na(x))) + })) ) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case4, "NanoStringGeoMxSet")) - # ...with p values in featureData... - expect_false("pvalues" %in% colnames(fData(demoData))) # original does not have 'pvalues' - expect_true("pvalues" %in% colnames(fData(case4))) # new object does have 'pvalues' - # ...with length same as length of targets. - expect_true(length(featureNames(case4)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case4_negatives <- case4[which(fData(case4)$CodeClass == "Negative"), ] - expect_true(all(is.na(fData(case4_negatives)$pvalues))) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false("scores" %in% colnames(fData(demoData))) # original does not have 'scores' - expect_true("scores" %in% colnames(fData(case4))) # new object does have 'scores' - # ...with length same as length of targets. - # (tested above) - # The score value is NA for negative probes. - expect_true(all(is.na(fData(case4_negatives)$scores))) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case4_positives <- case1[fData(case4)[["Negative"]] == FALSE, ] # positive features - expect_true(all(fData(case4_positives)$pvalues >= 0 | fData(case4_positives)$pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case4)$pvalues))) == nrow(case4_positives)) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - expect_true(length(which(!is.na(fData(case4)$scores))) == nrow(case4_positives)) - - # 6 The order of pvalues is the same as scores. + } + to_test <- compute_length_non_nas_per_column( + df = fData(case4)[, grepl("pvalues_", colnames(fData(case4)))] + ) + expect_true(all(to_test %in% nrow(case4_positives))) + + # 5 The length of non-NA scores values is equal to the number of non-negative probes. + to_test <- compute_length_non_nas_per_column( + df = fData(case4)[, grepl("scores_", colnames(fData(case4)))] + ) + expect_true(all(to_test %in% nrow(case4_positives))) + + # 6 The order of pvalues is the same as scores. + # This will loop through the different slides (i.e., IDs). + for (id in unique_ids) { expect_identical( - pnorm(fData(case4_positives)[["scores"]], lower.tail = FALSE), - fData(case4_positives)[["pvalues"]] - ) - - # four different settings should yield different results if outliers are present. - expect_false(identical(fData(case1)[["pvalues"]], fData(case2)[["pvalues"]])) - expect_false(identical(fData(case1)[["pvalues"]], fData(case3)[["pvalues"]])) - expect_false(identical(fData(case1)[["pvalues"]], fData(case4)[["pvalues"]])) - expect_false(identical(fData(case2)[["pvalues"]], fData(case3)[["pvalues"]])) - expect_false(identical(fData(case2)[["pvalues"]], fData(case4)[["pvalues"]])) - expect_false(identical(fData(case3)[["pvalues"]], fData(case4)[["pvalues"]])) -}) - -test_that("BGScoreTest for multiple slides produces desired results", { - - # Desired results occurs when: - # 1 The function outputs a GeoMx S4 class with p values in featureData with length same as length of targets for each unique id value. The p value is NA for negative probes. - # 2 The function outputs a GeoMx S4 class with score values in featureData with length same as length of targets for each unique id value. The score value is NA for negative probes. - # 3 All p values are between 0 and 1 (inclusive) for non-negative features. - # 4 The order of each column of pvalues is the same as each column of scores for each unique id value. - - # Preamble/load example data - # Create temporary directory that will get destroyed after this block is executed. - tmp_dir <- withr::local_tempdir(pattern = "tmp_dir") - # Change to the temporary directory (will set back to getwd() once block is executed.) - withr::local_dir(tmp_dir) - data("demoData") # input structure checked above and not repeated here - # Estimate Poisson background sample-feature factor model for multiple slides - set.seed(98070) - demoData <- fitPoisBG(demoData, groupvar = "slide name", size_scale = "sum") - demoData <- diagPoisBG(demoData, split = TRUE) - demoData <- aggreprobe(demoData, use = "cor") - - # Case 1: adjustment factor 5, no prior, no outlier removal - case1 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = FALSE, removeoutlier = FALSE) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case1, "NanoStringGeoMxSet")) - # ...with p values in featureData... - unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids - expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case1)))) - # ...with length same as length of targets for each unique id value. - expect_true(length(featureNames(case1)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case1_negatives <- case1[which(fData(case1)$CodeClass == "Negative"), ] - expect_true( - all(is.na(fData(case1_negatives)[, grepl("pvalues_", colnames(fData(case1_negatives)))])) - ) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case1)))) - # ...with length same as length of targets for each unique id value. - # (tested above) - # The score value is NA for negative probes. - expect_true( - all(is.na(fData(case1_negatives)[, grepl("scores_", colnames(fData(case1_negatives)))])) - ) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case1_positives <- case1[fData(case1)[["Negative"]] == FALSE, ] - pos_pvalues <- as.numeric(as.matrix(fData(case1_positives)[, grepl("pvalues_", colnames(fData(case1_positives)))])) - expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - compute_length_non_nas_per_column <- function(df) { - return( - as.numeric(apply(df, 2, function(x) { - length(which(!is.na(x))) - })) - ) - } - to_test <- compute_length_non_nas_per_column( - df = fData(case1)[, grepl("pvalues_", colnames(fData(case1)))] + pnorm(fData(case4_positives)[[paste0("scores_", id)]], lower.tail = FALSE), + fData(case4_positives)[[paste0("pvalues_", id)]] ) - expect_true(all(to_test %in% nrow(case1_positives))) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - to_test <- compute_length_non_nas_per_column( - df = fData(case1)[, grepl("scores_", colnames(fData(case1)))] - ) - expect_true(all(to_test %in% nrow(case1_positives))) - - # 6 The order of pvalues is the same as scores. - # This will loop through the different slides (i.e., IDs). - for (id in unique_ids) { - expect_identical( - pnorm(fData(case1_positives)[[paste0("scores_", id)]], lower.tail = FALSE), - fData(case1_positives)[[paste0("pvalues_", id)]] - ) - } - - # Case 2: adjustment factor 5, no prior, outlier removal - case2 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = FALSE, removeoutlier = TRUE) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case2, "NanoStringGeoMxSet")) - # ...with p values in featureData... - unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids - expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case2)))) - # ...with length same as length of targets for each unique id value. - expect_true(length(featureNames(case2)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case2_negatives <- case2[which(fData(case2)$CodeClass == "Negative"), ] - expect_true( - all(is.na(fData(case2_negatives)[, grepl("pvalues_", colnames(fData(case2_negatives)))])) - ) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case2)))) - # ...with length same as length of targets for each unique id value. - # (tested above) - # The score value is NA for negative probes. - expect_true( - all(is.na(fData(case2_negatives)[, grepl("scores_", colnames(fData(case2_negatives)))])) - ) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case2_positives <- case2[fData(case2)[["Negative"]] == FALSE, ] - pos_pvalues <- as.numeric(as.matrix(fData(case2_positives)[, grepl("pvalues_", colnames(fData(case2_positives)))])) - expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - compute_length_non_nas_per_column <- function(df) { - return( - as.numeric(apply(df, 2, function(x) { - length(which(!is.na(x))) - })) - ) - } - to_test <- compute_length_non_nas_per_column( - df = fData(case2)[, grepl("pvalues_", colnames(fData(case2)))] - ) - expect_true(all(to_test %in% nrow(case2_positives))) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - to_test <- compute_length_non_nas_per_column( - df = fData(case2)[, grepl("scores_", colnames(fData(case2)))] - ) - expect_true(all(to_test %in% nrow(case2_positives))) - - # 6 The order of pvalues is the same as scores. - # This will loop through the different slides (i.e., IDs). - for (id in unique_ids) { - expect_identical( - pnorm(fData(case2_positives)[[paste0("scores_", id)]], lower.tail = FALSE), - fData(case2_positives)[[paste0("pvalues_", id)]] - ) - } - - - # Case 3: adjustment factor 5, with prior, no outlier removal - case3 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = TRUE, removeoutlier = FALSE) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case3, "NanoStringGeoMxSet")) - # ...with p values in featureData... - unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids - expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case3)))) - # ...with length same as length of targets for each unique id value. - expect_true(length(featureNames(case3)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case3_negatives <- case3[which(fData(case3)$CodeClass == "Negative"), ] - expect_true( - all(is.na(fData(case3_negatives)[, grepl("pvalues_", colnames(fData(case3_negatives)))])) - ) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case3)))) - # ...with length same as length of targets for each unique id value. - # (tested above) - # The score value is NA for negative probes. - expect_true( - all(is.na(fData(case3_negatives)[, grepl("scores_", colnames(fData(case3_negatives)))])) - ) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case3_positives <- case3[fData(case3)[["Negative"]] == FALSE, ] - pos_pvalues <- as.numeric(as.matrix(fData(case3_positives)[, grepl("pvalues_", colnames(fData(case3_positives)))])) - expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - compute_length_non_nas_per_column <- function(df) { - return( - as.numeric(apply(df, 2, function(x) { - length(which(!is.na(x))) - })) - ) - } - to_test <- compute_length_non_nas_per_column( - df = fData(case3)[, grepl("pvalues_", colnames(fData(case3)))] - ) - expect_true(all(to_test %in% nrow(case3_positives))) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - to_test <- compute_length_non_nas_per_column( - df = fData(case3)[, grepl("scores_", colnames(fData(case3)))] - ) - expect_true(all(to_test %in% nrow(case3_positives))) - - # 6 The order of pvalues is the same as scores. - # This will loop through the different slides (i.e., IDs). - for (id in unique_ids) { - expect_identical( - pnorm(fData(case3_positives)[[paste0("scores_", id)]], lower.tail = FALSE), - fData(case3_positives)[[paste0("pvalues_", id)]] - ) - } - - # Case 4: adjustment factor 5, no prior, outlier removal - case4 <- BGScoreTest(demoData, split = TRUE, adj = 5, useprior = TRUE, removeoutlier = TRUE) - - # 1 The function outputs a GeoMx S4 class... - expect_true(inherits(case4, "NanoStringGeoMxSet")) - # ...with p values in featureData... - unique_ids <- unique(pData(demoData)$`slide name`) # pull out the unique ids - expect_false(all(paste0("pvalues_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("pvalues_", unique_ids) %in% colnames(fData(case4)))) - # ...with length same as length of targets for each unique id value. - expect_true(length(featureNames(case4)) == length(featureNames(demoData))) - # The p value is NA for negative probes. - case4_negatives <- case4[which(fData(case4)$CodeClass == "Negative"), ] - expect_true( - all(is.na(fData(case4_negatives)[, grepl("pvalues_", colnames(fData(case4_negatives)))])) - ) - - # 2 The function outputs a GeoMx S4 class... - # (testing above)... - # ...with score values in featureData... - expect_false(all(paste0("scores_", unique_ids) %in% colnames(fData(demoData)))) # original does not have 'pvalues_' - expect_true(all(paste0("scores_", unique_ids) %in% colnames(fData(case4)))) - # ...with length same as length of targets for each unique id value. - # (tested above) - # The score value is NA for negative probes. - expect_true( - all(is.na(fData(case4_negatives)[, grepl("scores_", colnames(fData(case4_negatives)))])) - ) - - # 3 All p values are between 0 and 1 (inclusive) - # for non-negative features. - case4_positives <- case4[fData(case4)[["Negative"]] == FALSE, ] - pos_pvalues <- as.numeric(as.matrix(fData(case4_positives)[, grepl("pvalues_", colnames(fData(case4_positives)))])) - expect_true(all(pos_pvalues >= 0 | pos_pvalues <= 1)) - - # 4 The length of non-NA p values is equal to the number of non-negative probes. - compute_length_non_nas_per_column <- function(df) { - return( - as.numeric(apply(df, 2, function(x) { - length(which(!is.na(x))) - })) - ) - } - to_test <- compute_length_non_nas_per_column( - df = fData(case4)[, grepl("pvalues_", colnames(fData(case4)))] - ) - expect_true(all(to_test %in% nrow(case4_positives))) - - # 5 The length of non-NA scores values is equal to the number of non-negative probes. - to_test <- compute_length_non_nas_per_column( - df = fData(case4)[, grepl("scores_", colnames(fData(case4)))] - ) - expect_true(all(to_test %in% nrow(case4_positives))) - - # 6 The order of pvalues is the same as scores. - # This will loop through the different slides (i.e., IDs). - for (id in unique_ids) { - expect_identical( - pnorm(fData(case4_positives)[[paste0("scores_", id)]], lower.tail = FALSE), - fData(case4_positives)[[paste0("pvalues_", id)]] - ) - } - - # four different settings should yield different results if outliers are present. - pvar_names <- fvarLabels(case1)[grepl("pvalues_", fvarLabels(case1))] - - expect_false(identical(fData(case1)[pvar_names], fData(case2)[pvar_names])) - expect_false(identical(fData(case1)[pvar_names], fData(case3)[pvar_names])) - expect_false(identical(fData(case1)[pvar_names], fData(case4)[pvar_names])) - expect_false(identical(fData(case2)[pvar_names], fData(case3)[pvar_names])) - expect_false(identical(fData(case2)[pvar_names], fData(case4)[pvar_names])) - expect_false(identical(fData(case3)[pvar_names], fData(case4)[pvar_names])) + } + + # four different settings should yield different results if outliers are present. + pvar_names <- fvarLabels(case1)[grepl("pvalues_", fvarLabels(case1))] + + expect_false(identical(fData(case1)[pvar_names], fData(case2)[pvar_names])) + expect_false(identical(fData(case1)[pvar_names], fData(case3)[pvar_names])) + expect_false(identical(fData(case1)[pvar_names], fData(case4)[pvar_names])) + expect_false(identical(fData(case2)[pvar_names], fData(case3)[pvar_names])) + expect_false(identical(fData(case2)[pvar_names], fData(case4)[pvar_names])) + expect_false(identical(fData(case3)[pvar_names], fData(case4)[pvar_names])) }) ## 7 It returns an error without running fitPoisBG. test_that("It returns an error without running fitPoisBG.", { - # Preamble/load example data - data("kidney") - all0probeidx <- which(rowSums(exprs(kidney))==0) - kidney <- kidney[-all0probeidx, ] - kidney <- aggreprobe(kidney, use = "cor") - expect_error( - BGScoreTest(kidney), - "Please run `fitPoisBG` first" - ) - expect_error( - BGScoreTest(kidney, split = TRUE), - "Please run `fitPoisBG` first" - ) - data("demoData") - expect_error( - expect_warning(BGScoreTest(demoData), - "No `probenum` is found."), - "Please run `fitPoisBG` first." - ) - expect_error( - expect_warning(BGScoreTest(demoData, split = TRUE), - "No `probenum` is found."), - "Please run `fitPoisBG` first with `groupvar`." - ) + # Preamble/load example data + data("kidney") + all0probeidx <- which(rowSums(exprs(kidney))==0) + kidney <- kidney[-all0probeidx, ] + kidney <- aggreprobe(kidney, use = "cor") + expect_error( + BGScoreTest(kidney), + "Please run `fitPoisBG` first" + ) + expect_error( + BGScoreTest(kidney, split = TRUE), + "Please run `fitPoisBG` first" + ) + data("demoData") + expect_error( + expect_warning(BGScoreTest(demoData), + "No `probenum` is found."), + "Please run `fitPoisBG` first." + ) + expect_error( + expect_warning(BGScoreTest(demoData, split = TRUE), + "No `probenum` is found."), + "Please run `fitPoisBG` first with `groupvar`." + ) }) ## 8 It returns an error if split is TRUE but no corresponding fitPoisBG is called previously. test_that("It returns an error if split is TRUE but no corresponding fitPoisBG is called previously.", { - # Preamble/load example data - data("kidney") - all0probeidx <- which(rowSums(exprs(kidney))==0) - kidney <- kidney[-all0probeidx, ] - kidney <- aggreprobe(kidney, use = "cor") - res <- fitPoisBG(kidney, size_scale = "first") - expect_error( - BGScoreTest(res, split = TRUE), - "Please run `fitPoisBG` first with `groupvar`" - ) - - # Preamble/load example data - data("demoData") - res <- fitPoisBG(demoData, size_scale = "first") - expect_error( - expect_warning(BGScoreTest(res, split = TRUE), - "No `probenum` is found."), - "Please run `fitPoisBG` first with `groupvar`." - ) + # Preamble/load example data + data("kidney") + all0probeidx <- which(rowSums(exprs(kidney))==0) + kidney <- kidney[-all0probeidx, ] + kidney <- aggreprobe(kidney, use = "cor") + res <- fitPoisBG(kidney, size_scale = "first") + expect_error( + BGScoreTest(res, split = TRUE), + "Please run `fitPoisBG` first with `groupvar`" + ) + + # Preamble/load example data + data("demoData") + res <- fitPoisBG(demoData, size_scale = "first") + expect_error( + expect_warning(BGScoreTest(res, split = TRUE), + "No `probenum` is found."), + "Please run `fitPoisBG` first with `groupvar`." + ) }) diff --git a/vignettes/Workflow_WTA_kidney.Rmd b/vignettes/Workflow_WTA_kidney.Rmd index 158af65..69e16b4 100644 --- a/vignettes/Workflow_WTA_kidney.Rmd +++ b/vignettes/Workflow_WTA_kidney.Rmd @@ -275,7 +275,7 @@ Running the DE model with default values. ```{r} NBthDEmod <- fitNBthDE(form = ~region, - split = FALSE, + split = FALSE, object = kidney) str(NBthDEmod)