├── src ├── .gitignore ├── backend.h ├── ctzRcpp.cpp ├── omega.cpp ├── comparison.cpp ├── lr2propr.cpp ├── lrv.cpp ├── lrm.cpp └── graflex.cpp ├── .gitignore ├── data └── marg.abs.rda ├── old_tests ├── testthat.R └── testthat │ ├── test-getNormTheta.R │ ├── test-propr-parallel.R │ ├── test-multiomic.R │ ├── test-aldex2propr.R │ ├── test-propd.R │ └── test-Fstat.R ├── .Rbuildignore ├── man ├── getPermutedTheta.Rd ├── getPermutedThetaMod.Rd ├── as_safe_matrix.Rd ├── packageCheck.Rd ├── getMatrix.Rd ├── getResults.Rd ├── progress.Rd ├── getMovingAverage.Rd ├── getFdrRandcounts.propd.run.Rd ├── getFdrRandcounts.propr.run.Rd ├── getFdrRandcounts.propd.parallel.Rd ├── getFdrRandcounts.propr.parallel.Rd ├── results_to_matrix.Rd ├── lrv_with_shrinkage.Rd ├── ratios.Rd ├── countValuesBeyondThreshold.Rd ├── runGraflex.Rd ├── getRatios.Rd ├── getCutoffFDR.Rd ├── simple_zero_replacement.Rd ├── marg.abs.Rd ├── getAdjacencyFstat.Rd ├── compute_iqlr.Rd ├── getCutoffFstat.Rd ├── getSignificantResultsFstat.Rd ├── updatePermutes.Rd ├── search_tree.Rd ├── runNormalization.Rd ├── runPostHoc.Rd ├── getAdjacencyFDR.Rd ├── logratio_without_alpha.Rd ├── logratio_with_alpha.Rd ├── pcor.bshrink.Rd ├── getSignificantResultsFDR.Rd ├── logratio.Rd ├── calculate_theta.Rd ├── index_reference.Rd ├── selectReference.Rd ├── aldex2propr.Rd ├── selectRatios.Rd ├── updateCutoffs.Rd ├── propr.Rd └── propd.Rd ├── tests ├── testthat.R └── testthat │ ├── test-RCPP-ctzRcpp.R │ ├── test-RCPP-half2mat.R │ ├── test-RCPP-wtmRcpp-wtvRcpp.R │ ├── test-SHARED-zero.R │ ├── test-RCPP-count.R │ ├── test-GET-getRatios.R │ ├── test-PROPR-phi-rho-phs-cor.R │ ├── test-PROPR-backend.R │ ├── test-SHARED-lrv.R │ ├── test-PROPR-clr-alr-vlr.R │ ├── test-SHARED-getCutoff-propd.R │ ├── test-SHARED-getResults-propd.R │ ├── test-SHARED-getCutoff-propr.R │ ├── test-PROPR-pcorbshrink.R │ ├── test-SHARED-getResults-propr.R │ ├── test-SHARED-updatepermutes.R │ ├── test-SHARED-getAdjacency-propd.R │ ├── test-PROPR-pcor.R │ ├── test-PROPD-theta.R │ ├── test-PROPD-updateF.R │ ├── test-GET-getMatrix.R │ ├── test-PROPR-pcorshrink.R │ ├── test-PROPR-ivar.R │ ├── test-PROPD-weight.R │ └── test-SHARED-getAdjacency-propr.R ├── propr.Rproj ├── cran-comments.md ├── R ├── 3-shared-zero.R ├── 1-propr-help.R ├── 5-selectReference.R ├── 2-propd-OOP.R ├── 3-shared-graflex.R ├── 2-propd-help.R ├── 3-shared-updatePermutes.R ├── 1-propr-OOP.R ├── 3-shared-getMatrix.R ├── 3-shared-getRatios.R ├── 9-global.R ├── 3-shared-getAdjacency.R ├── RcppExports.R ├── 4-aldex2propr.R ├── 2-propd.R ├── 2c-propd-experimental.R ├── 3-shared-getCutoff.R └── 3-shared-getResults.R ├── NAMESPACE ├── data-raw └── data-abs.R ├── DESCRIPTION ├── OLDNEWS.md └── old_vignettes └── d_advanced.Rmd /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dll 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | inst/doc 5 | -------------------------------------------------------------------------------- /data/marg.abs.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tpq/propr/HEAD/data/marg.abs.rda -------------------------------------------------------------------------------- /old_tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | test_check("propr") 5 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^README\.Rmd$ 4 | ^README-.*\.png$ 5 | ^OLDNEWS\.md$ 6 | ^cran-comments\.md$ 7 | ^data-raw$ 8 | ^old_tests$ 9 | ^old_vignettes$ 10 | ^CRAN-RELEASE$ 11 | -------------------------------------------------------------------------------- /src/backend.h: -------------------------------------------------------------------------------- 1 | #ifndef BACKEND 2 | #define BACKEND 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | NumericMatrix covRcpp(NumericMatrix & X, const int norm_type); 10 | double wtmRcpp(NumericVector x, NumericVector w); 11 | double wtvRcpp(NumericVector x, NumericVector w); 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /man/getPermutedTheta.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{getPermutedTheta} 4 | \alias{getPermutedTheta} 5 | \title{Get the theta values for a given permutation} 6 | \usage{ 7 | getPermutedTheta(object, k) 8 | } 9 | \description{ 10 | Get the theta values for a given permutation 11 | } 12 | -------------------------------------------------------------------------------- /man/getPermutedThetaMod.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{getPermutedThetaMod} 4 | \alias{getPermutedThetaMod} 5 | \title{Get the theta mod values for a given permutation} 6 | \usage{ 7 | getPermutedThetaMod(object, k) 8 | } 9 | \description{ 10 | Get the theta mod values for a given permutation 11 | } 12 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | # This file is part of the standard setup for testthat. 2 | # It is recommended that you do not modify it. 3 | # 4 | # Where should you do additional test configuration? 5 | # Learn more about the roles of various files in: 6 | # * https://r-pkgs.org/tests.html 7 | # * https://testthat.r-lib.org/reference/test_package.html#special-files 8 | 9 | library(testthat) 10 | library(propr) 11 | 12 | test_check("propr") 13 | -------------------------------------------------------------------------------- /man/as_safe_matrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/9-global.R 3 | \name{as_safe_matrix} 4 | \alias{as_safe_matrix} 5 | \title{Ensure Matrix Has Dim Names} 6 | \usage{ 7 | as_safe_matrix(counts) 8 | } 9 | \arguments{ 10 | \item{counts}{A data matrix representing counts.} 11 | } 12 | \value{ 13 | A matrix with dim names. 14 | } 15 | \description{ 16 | Makes sure input data has correct format. For back-end use only. 17 | } 18 | -------------------------------------------------------------------------------- /man/packageCheck.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/9-global.R 3 | \name{packageCheck} 4 | \alias{packageCheck} 5 | \title{Package Check} 6 | \usage{ 7 | packageCheck(package) 8 | } 9 | \arguments{ 10 | \item{package}{A character string. An R package.} 11 | } 12 | \value{ 13 | Returns TRUE if no error. 14 | } 15 | \description{ 16 | Checks whether the user has the required package installed. 17 | For back-end use only. 18 | } 19 | -------------------------------------------------------------------------------- /man/getMatrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getMatrix.R 3 | \name{getMatrix} 4 | \alias{getMatrix} 5 | \title{Get Matrix from Object} 6 | \usage{ 7 | getMatrix(object) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{propr} or \code{propd} object.} 11 | } 12 | \value{ 13 | A matrix. 14 | } 15 | \description{ 16 | This function provides a unified wrapper to retrieve a matrix 17 | of \code{propr} or \code{propd} values. 18 | } 19 | -------------------------------------------------------------------------------- /man/getResults.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getResults.R 3 | \name{getResults} 4 | \alias{getResults} 5 | \title{Get Results from Object} 6 | \usage{ 7 | getResults(object) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{propr} or \code{propd} object.} 11 | } 12 | \value{ 13 | A \code{data.frame} of results. 14 | } 15 | \description{ 16 | This function provides a unified wrapper to retrieve results 17 | from a \code{propr} or \code{propd} object. 18 | } 19 | -------------------------------------------------------------------------------- /man/progress.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/9-global.R 3 | \name{progress} 4 | \alias{progress} 5 | \title{Make Progress Bar} 6 | \usage{ 7 | progress(i, k, numTicks) 8 | } 9 | \arguments{ 10 | \item{i}{The current iteration.} 11 | 12 | \item{k}{Total iterations.} 13 | 14 | \item{numTicks}{The result of \code{progress}.} 15 | } 16 | \value{ 17 | The next \code{numTicks} argument. 18 | } 19 | \description{ 20 | Makes a progress bar. For back-end use only. 21 | } 22 | -------------------------------------------------------------------------------- /tests/testthat/test-RCPP-ctzRcpp.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | mat <- matrix(sample(0:10, replace = TRUE, size = 150), 10, 15) 5 | cts <- apply(mat, 2, function(x) sum(x == 0)) 6 | 7 | df <- data.frame(propr:::labRcpp(ncol(mat)), 8 | "Z" = propr:::ctzRcpp(mat)) 9 | 10 | test_that("ctzRcpp correctly counts joint zero frequency", { 11 | 12 | for(i in 1:nrow(df)){ 13 | expect_equal( 14 | df$Z[i], 15 | cts[df$Partner[i]] + cts[df$Pair[i]] 16 | ) 17 | } 18 | }) 19 | -------------------------------------------------------------------------------- /propr.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --use-valgrind 22 | PackageRoxygenize: rd,collate,namespace 23 | -------------------------------------------------------------------------------- /man/getMovingAverage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getCutoff.R 3 | \name{getMovingAverage} 4 | \alias{getMovingAverage} 5 | \title{Caclulate the moving average of a vector.} 6 | \usage{ 7 | getMovingAverage(values, window_size = 1) 8 | } 9 | \arguments{ 10 | \item{values}{A numeric vector.} 11 | 12 | \item{window_size}{An integer. The size of the window to calculate the 13 | moving average. Default is 1.} 14 | } 15 | \description{ 16 | Caclulate the moving average of a vector. 17 | } 18 | -------------------------------------------------------------------------------- /man/getFdrRandcounts.propd.run.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{getFdrRandcounts.propd.run} 4 | \alias{getFdrRandcounts.propd.run} 5 | \title{This function counts the permuted values greater or less than each cutoff, 6 | using a single core, for a propd object.} 7 | \usage{ 8 | getFdrRandcounts.propd.run(object, cutoffs) 9 | } 10 | \description{ 11 | This function counts the permuted values greater or less than each cutoff, 12 | using a single core, for a propd object. 13 | } 14 | -------------------------------------------------------------------------------- /man/getFdrRandcounts.propr.run.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{getFdrRandcounts.propr.run} 4 | \alias{getFdrRandcounts.propr.run} 5 | \title{This function counts the permuted values greater or less than each cutoff, 6 | using a single core, for a propr object.} 7 | \usage{ 8 | getFdrRandcounts.propr.run(object, cutoffs) 9 | } 10 | \description{ 11 | This function counts the permuted values greater or less than each cutoff, 12 | using a single core, for a propr object. 13 | } 14 | -------------------------------------------------------------------------------- /tests/testthat/test-RCPP-half2mat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | N <- 100 5 | a <- seq(from = 5, to = 15, length.out = N) 6 | b <- a * rnorm(N, mean = 1, sd = 0.1) 7 | c <- rnorm(N, mean = 10) 8 | d <- rnorm(N, mean = 10) 9 | e <- rep(10, N) 10 | X <- data.frame(a, b, c, d, e) 11 | 12 | pr <- propr(X, metric = "rho") 13 | rho <- getMatrix(pr) 14 | diag(rho) <- 0 15 | 16 | test_that("half-matrix correctly turned into matrix", { 17 | 18 | expect_equal( 19 | rho[1:16], 20 | propr:::half2mat(propr:::lltRcpp(rho))[1:16] 21 | ) 22 | }) 23 | -------------------------------------------------------------------------------- /tests/testthat/test-RCPP-wtmRcpp-wtvRcpp.R: -------------------------------------------------------------------------------- 1 | # library(testthat) 2 | # library(propr) 3 | # 4 | # if(requireNamespace("SDMTools", quietly = TRUE)){ 5 | # 6 | # x <- abs(rnorm(20)) 7 | # w <- abs(rnorm(20)) 8 | # 9 | # test_that("weighted mean matches SDMTools", { 10 | # 11 | # expect_equal( 12 | # SDMTools::wt.mean(x, w), 13 | # propr:::wtmRcpp(x, w) 14 | # ) 15 | # }) 16 | # 17 | # test_that("weighted variance matches SDMTools", { 18 | # 19 | # expect_equal( 20 | # SDMTools::wt.var(x, w), 21 | # propr:::wtvRcpp(x, w) 22 | # ) 23 | # }) 24 | # } 25 | -------------------------------------------------------------------------------- /man/getFdrRandcounts.propd.parallel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{getFdrRandcounts.propd.parallel} 4 | \alias{getFdrRandcounts.propd.parallel} 5 | \title{This function counts the permuted values greater or less than each cutoff, 6 | using parallel processing, for a propd object.} 7 | \usage{ 8 | getFdrRandcounts.propd.parallel(object, cutoffs, ncores) 9 | } 10 | \description{ 11 | This function counts the permuted values greater or less than each cutoff, 12 | using parallel processing, for a propd object. 13 | } 14 | -------------------------------------------------------------------------------- /man/getFdrRandcounts.propr.parallel.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{getFdrRandcounts.propr.parallel} 4 | \alias{getFdrRandcounts.propr.parallel} 5 | \title{This function counts the permuted values greater or less than each cutoff, 6 | using parallel processing, for a propr object} 7 | \usage{ 8 | getFdrRandcounts.propr.parallel(object, cutoffs, ncores) 9 | } 10 | \description{ 11 | This function counts the permuted values greater or less than each cutoff, 12 | using parallel processing, for a propr object 13 | } 14 | -------------------------------------------------------------------------------- /old_tests/testthat/test-getNormTheta.R: -------------------------------------------------------------------------------- 1 | library(propr) 2 | 3 | test_that("getNormTheta works as expected", { 4 | 5 | x <- matrix(1:30, 5, 6) 6 | y <- c("A", "A", "A", "B", "B") 7 | pd <- propd(x, y) 8 | 9 | # Get per-feature theta for first feature manually 10 | thetaFor1 <- pd@results[pd@results$Pair == 1, ] 11 | theta.1 <- thetaFor1$theta 12 | names(theta.1) <- colnames(pd@counts)[thetaFor1$Partner] 13 | 14 | # Get per-feature theta for first feature 15 | norm.1 <- getNormTheta(pd, x[,1]) 16 | 17 | expect_equal( 18 | theta.1, 19 | norm.1[-1] # first entry is DP with self = 1 20 | ) 21 | }) 22 | -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-zero.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | test_that("simple_zero_replacement replaces zeros correctly", { 5 | 6 | # Example data with zeros 7 | data_with_zeros <- matrix(c(1, 2, 3, 0, 5, 6, 0, 8, 9), nrow = 3, byrow = TRUE) 8 | 9 | # Apply the simple_zero_replacement function to the example data 10 | replaced_data <- simple_zero_replacement(data_with_zeros) 11 | 12 | # Define the expected output after zero replacement 13 | expected_output <- matrix(c(1, 2, 3, 1, 5, 6, 1, 8, 9), nrow = 3, byrow = TRUE) 14 | 15 | # Compare the output with the expected output 16 | expect_identical(replaced_data, expected_output) 17 | 18 | }) -------------------------------------------------------------------------------- /man/results_to_matrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getMatrix.R 3 | \name{results_to_matrix} 4 | \alias{results_to_matrix} 5 | \title{Get Matrix from Results} 6 | \usage{ 7 | results_to_matrix(results, what = "theta", features = NULL) 8 | } 9 | \arguments{ 10 | \item{results}{A \code{data.frame} of results.} 11 | 12 | \item{what}{A character string. The column name of the results data frame to be converted into a matrix.} 13 | 14 | \item{features}{A vector of features. Default is NULL.} 15 | } 16 | \value{ 17 | A matrix. 18 | } 19 | \description{ 20 | This function converts the results data frame into a matrix. 21 | } 22 | -------------------------------------------------------------------------------- /old_tests/testthat/test-propr-parallel.R: -------------------------------------------------------------------------------- 1 | library(propr) 2 | library(parallel) 3 | 4 | describe("updateCutoffs.propr()", { 5 | 6 | num_rows <- 5 7 | num_cols <- 10 8 | 9 | # Make count-like data 10 | counts <- rnbinom(num_rows * num_cols, size = 0.1, mu = 10) + 1 11 | dat <- matrix(counts, nrow = num_rows) 12 | 13 | pr <- propr(dat, "phs", p = 20) 14 | 15 | singleCoreResult <- updateCutoffs(pr, ncores = 1) 16 | multiCoreResult <- updateCutoffs(pr, ncores = 2) 17 | 18 | describe("with multiple cores", { 19 | it("matches the single core version of the function", { 20 | expect_equal(multiCoreResult@fdr, singleCoreResult@fdr) 21 | }) 22 | }) 23 | }) 24 | -------------------------------------------------------------------------------- /man/lrv_with_shrinkage.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/2a-propd-backend.R 3 | \name{lrv_with_shrinkage} 4 | \alias{lrv_with_shrinkage} 5 | \title{Calculate Logratio Variance with shrinkage} 6 | \usage{ 7 | lrv_with_shrinkage(ct, shrink = TRUE) 8 | } 9 | \arguments{ 10 | \item{ct}{A count matrix.} 11 | 12 | \item{shrink}{A logical value indicating whether to apply shrinkage.} 13 | } 14 | \value{ 15 | A shrunk logratio variance matrix. 16 | } 17 | \description{ 18 | This function computes the logratio variance (LRV) with the option 19 | to apply shrinkage. It uses the `corpcor` package to compute a shrunk 20 | covariance matrix and then converts it to a logratio variance matrix. 21 | } 22 | -------------------------------------------------------------------------------- /tests/testthat/test-RCPP-count.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | test_that("count_greater_than and count_less_than work properly", { 5 | 6 | # define values 7 | values <- c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) 8 | 9 | expect_equal(propr:::count_greater_than(values, 5), 5) 10 | expect_equal(propr:::count_greater_than(values, 8), 2) 11 | expect_equal(propr:::count_less_than(values, 5),4) 12 | expect_equal(propr:::count_less_than(values, 8), 7) 13 | 14 | expect_equal(propr:::count_greater_equal_than(values, 5), 6) 15 | expect_equal(propr:::count_greater_equal_than(values, 8), 3) 16 | expect_equal(propr:::count_less_equal_than(values, 5), 5) 17 | expect_equal(propr:::count_less_equal_than(values, 8), 8) 18 | }) -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## Test environments 2 | * local ubuntu 14.04, R 3.3.1 3 | * local ubuntu 16.04, R 3.3.1 4 | * win-builder (devel and release) 5 | 6 | ## R CMD check results 7 | 8 | 0 errors | 0 warnings | 1 note 9 | 10 | * Possibly mis-spelled words in DESCRIPTION: 11 | 12 | I have reviewed the DESCRIPTION and attest it does not contain any mis-spellings. 13 | 14 | * Found the following (possibly) invalid URLs: 15 | 16 | I have reviewed the URLs and attest that all are valid. 17 | 18 | ## Reverse dependencies 19 | 20 | I checked all reverse dependencies. 21 | 31 | -------------------------------------------------------------------------------- /man/ratios.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getRatios.R 3 | \name{ratios} 4 | \alias{ratios} 5 | \title{Recast Matrix as Feature (Log-)Ratios} 6 | \usage{ 7 | ratios(matrix, alpha = NA) 8 | } 9 | \arguments{ 10 | \item{matrix}{A matrix. The data to recast.} 11 | 12 | \item{alpha}{A double. See vignette for details. Leave missing 13 | to skip Box-Cox transformation.} 14 | } 15 | \value{ 16 | A matrix of (log-)ratios. 17 | } 18 | \description{ 19 | The \code{ratios} function recasts a matrix with N feature columns 20 | as a new matrix with N * (N - 1) / 2 feature (log-)ratio columns. 21 | } 22 | \details{ 23 | When the \code{alpha} argument is provided, this function returns 24 | the (log-)ratios as \code{(partner^alpha - pair^alpha) / alpha}. 25 | } 26 | -------------------------------------------------------------------------------- /man/countValuesBeyondThreshold.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{countValuesBeyondThreshold} 4 | \alias{countValuesBeyondThreshold} 5 | \title{Count Values Greater or Less Than a Threshold} 6 | \usage{ 7 | countValuesBeyondThreshold(values, cutoff, direct) 8 | } 9 | \arguments{ 10 | \item{values}{A numeric vector.} 11 | 12 | \item{cutoff}{A numeric value.} 13 | 14 | \item{direct}{A logical value. If \code{TRUE}, direct relationship is considered.} 15 | } 16 | \value{ 17 | The number of values greater or less than the threshold. 18 | } 19 | \description{ 20 | This function counts the number of values greater or less than a threshold. 21 | The direction depends on if a direct or inverse relationship is asked, 22 | as well as the sign of the threshold. 23 | } 24 | -------------------------------------------------------------------------------- /man/runGraflex.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-graflex.R 3 | \name{runGraflex} 4 | \alias{runGraflex} 5 | \title{Calculate odds ratio and FDR} 6 | \usage{ 7 | runGraflex(A, K, p = 100, ncores = 1) 8 | } 9 | \arguments{ 10 | \item{A}{An adjacency matrix.} 11 | 12 | \item{K}{A knowledge database where each row is a graph node 13 | and each column is a concept.} 14 | 15 | \item{p}{An integer. The number of permutation.} 16 | } 17 | \description{ 18 | This function calls \code{\link{graflex}} for each 19 | concept (i.e., column) in the database \code{K}. 20 | } 21 | \details{ 22 | For each concept, this function calculates the odds ratio 23 | and determines the false discovery rate (FDR) by counting 24 | the number of the actual OR was greater or less than a 25 | permuted OR. 26 | } 27 | -------------------------------------------------------------------------------- /src/ctzRcpp.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // Function to count joint zero frequency 5 | // [[Rcpp::export]] 6 | NumericVector ctzRcpp(NumericMatrix & X){ 7 | 8 | int nfeats = X.ncol(); 9 | int nsubjs = X.nrow(); 10 | int llt = nfeats * (nfeats - 1) / 2; 11 | 12 | // Count zero frequency per feature 13 | Rcpp::NumericVector zeroes(nfeats); 14 | for(int i = 0; i < nfeats; i++){ 15 | for(int j = 0; j < nsubjs; j++){ 16 | if(X(j, i) == 0){ 17 | zeroes(i) += 1; 18 | } 19 | } 20 | } 21 | 22 | // Count joint zero frequency 23 | Rcpp::NumericVector result(llt); 24 | int counter = 0; 25 | for(int i = 1; i < nfeats; i++){ 26 | for(int j = 0; j < i; j++){ 27 | result(counter) = zeroes(i) + zeroes(j); 28 | counter += 1; 29 | } 30 | } 31 | 32 | return result; 33 | } 34 | -------------------------------------------------------------------------------- /man/getRatios.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getRatios.R 3 | \name{getRatios} 4 | \alias{getRatios} 5 | \title{Get (Log-)ratios from Object} 6 | \usage{ 7 | getRatios(object, switch = TRUE) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{propr} or \code{propd} object.} 11 | 12 | \item{switch}{A boolean. For \code{propd}, toggles whether all ratios 13 | should have same orientation with respect to log-ratio means.} 14 | } 15 | \value{ 16 | A \code{data.frame} of (log-)ratios. 17 | } 18 | \description{ 19 | This function provides a unified wrapper to retrieve (log-)ratios 20 | from \code{propr} and \code{propd} objects. 21 | } 22 | \details{ 23 | When the \code{propd} object is made using \code{alpha}, this function returns 24 | the (log-)ratios as \code{(partner^alpha - pair^alpha) / alpha}. 25 | } 26 | -------------------------------------------------------------------------------- /man/getCutoffFDR.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getCutoff.R 3 | \name{getCutoffFDR} 4 | \alias{getCutoffFDR} 5 | \title{Get a meaningful cutoff based on the FDR values from permutation tests.} 6 | \usage{ 7 | getCutoffFDR(object, fdr = 0.05, window_size = 1) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{propd} or \code{propr} object.} 11 | 12 | \item{fdr}{A float value for the false discovery rate. 13 | Default is 0.05.} 14 | 15 | \item{window_size}{An integer. Default is 1. When it is greater than 1, 16 | the function will return a meaningful cutoff based on the moving 17 | average of the FDR values. This is useful when the FDR values are 18 | noisy and the user wants to smooth them out.} 19 | } 20 | \value{ 21 | A cutoff value. 22 | } 23 | \description{ 24 | Get a meaningful cutoff based on the FDR values from permutation tests. 25 | } 26 | -------------------------------------------------------------------------------- /man/simple_zero_replacement.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-zero.R 3 | \name{simple_zero_replacement} 4 | \alias{simple_zero_replacement} 5 | \title{Simple Zero Replacement in a Count Matrix} 6 | \usage{ 7 | simple_zero_replacement(ct) 8 | } 9 | \arguments{ 10 | \item{ct}{A data matrix containing numerical values.} 11 | } 12 | \value{ 13 | A matrix with zero values replaced by the next smallest non-zero value. 14 | If no zeros are found, the function returns the original matrix. 15 | } 16 | \description{ 17 | This function replaces zeros with the next smallest non-zero value in the 18 | input count matrix. If the matrix contains no zeros, it produces an 19 | informational message indicating that no replacements were made. 20 | } 21 | \examples{ 22 | # Sample input count data with zeros 23 | data <- matrix(c(0, 2, 3, 4, 5, 0), nrow = 2, byrow = TRUE) 24 | } 25 | -------------------------------------------------------------------------------- /man/marg.abs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/9-global.R 3 | \docType{data} 4 | \name{marg.abs} 5 | \alias{marg.abs} 6 | \title{Example Absolute mRNA} 7 | \format{ 8 | An object of class \code{data.frame} with 16 rows and 3031 columns. 9 | } 10 | \usage{ 11 | data(marg.abs) 12 | } 13 | \description{ 14 | Data generated with supplemental script provided by 15 | . Data originally 16 | sourced from . 17 | A time series of yeast mRNA abundance after removal 18 | of a key nutrient. Absolute abundance estimated 19 | by multiplying microarray signal (relative to first 20 | time point) by the initial nCounter-calibrated and 21 | copy-per-cell-adjusted RNA-seq abundance (averaged 22 | across two replicates). Divide absolute abundances 23 | by total sample abundance to make data relative. 24 | } 25 | \keyword{datasets} 26 | -------------------------------------------------------------------------------- /man/getAdjacencyFstat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getAdjacency.R 3 | \name{getAdjacencyFstat} 4 | \alias{getAdjacencyFstat} 5 | \title{Get Adjacency Matrix as indicated by F-statistics} 6 | \usage{ 7 | getAdjacencyFstat(object, pval = 0.05, fdr_adjusted = TRUE) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{propd} or \code{propr} object.} 11 | 12 | \item{pval}{A float value for the p-value. Default is 0.05.} 13 | 14 | \item{fdr_adjusted}{A boolean. If TRUE, use the the FDR- adjusted p-values. 15 | Otherwise, get significant pairs based on the theoretical F-statistic cutoff.} 16 | } 17 | \value{ 18 | An adjacency matrix. 19 | } 20 | \description{ 21 | This function gets the significant pairs, according to the F-statistics. 22 | Then it fills the adjacency matrix with 1 if pair is significant, otherwise 0. 23 | Note that it can only be applied to theta_d, as updateF only works for theta_d. 24 | } 25 | -------------------------------------------------------------------------------- /R/3-shared-zero.R: -------------------------------------------------------------------------------- 1 | #' Simple Zero Replacement in a Count Matrix 2 | #' 3 | #' This function replaces zeros with the next smallest non-zero value in the 4 | #' input count matrix. If the matrix contains no zeros, it produces an 5 | #' informational message indicating that no replacements were made. 6 | #' 7 | #' @param ct A data matrix containing numerical values. 8 | #' @return A matrix with zero values replaced by the next smallest non-zero value. 9 | #' If no zeros are found, the function returns the original matrix. 10 | #' @examples 11 | #' # Sample input count data with zeros 12 | #' data <- matrix(c(0, 2, 3, 4, 5, 0), nrow = 2, byrow = TRUE) 13 | #' @export 14 | simple_zero_replacement <- function(ct) { 15 | if (any(ct == 0)) { 16 | message("Alert: replacing zeros with minimun value.") 17 | zeros <- ct == 0 18 | ct[zeros] <- min(ct[!zeros]) 19 | } else{ 20 | message("Alert: No 0s found that need replacement.") 21 | } 22 | return(ct) 23 | } 24 | -------------------------------------------------------------------------------- /man/compute_iqlr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/1a-propr-backend.R 3 | \name{compute_iqlr} 4 | \alias{compute_iqlr} 5 | \title{Compute IQLR (Interquartile Range Log Ratio) Features} 6 | \usage{ 7 | compute_iqlr(counts) 8 | } 9 | \arguments{ 10 | \item{counts}{A data matrix representing counts. 11 | It is assumed that the matrix contains numerical values only.} 12 | } 13 | \value{ 14 | A numeric vector representing the indices of features selected by IQLR. 15 | } 16 | \description{ 17 | This function computes the IQLR features from the input count matrix. 18 | The IQLR is based on the log-ratio transformation of the counts, and 19 | it selects features with variance values falling within the 20 | interquartile range. 21 | } 22 | \examples{ 23 | # Sample input count data 24 | data <- matrix(c(1, 2, 3, 4, 0, 6), nrow = 2, byrow = TRUE) 25 | 26 | # Compute IQLR features 27 | iqlr_features <- compute_iqlr(data) 28 | 29 | } 30 | -------------------------------------------------------------------------------- /man/getCutoffFstat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getCutoff.R 3 | \name{getCutoffFstat} 4 | \alias{getCutoffFstat} 5 | \title{Calculate a theta Cutoff based on the F-statistic.} 6 | \usage{ 7 | getCutoffFstat(object, pval = 0.05, fdr_adjusted = FALSE) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{\link{propd}} object.} 11 | 12 | \item{pval}{A p-value at which to calculate a theta cutoff.} 13 | 14 | \item{fdr_adjusted}{A boolean. Toggles whether to calculate the theta 15 | cutoff for an FDR-adjusted p-value.} 16 | } 17 | \value{ 18 | A cutoff of theta from [0, 1]. 19 | } 20 | \description{ 21 | This function uses the F distribution to calculate a cutoff of 22 | theta for a p-value given by the \code{pval} argument. 23 | } 24 | \details{ 25 | If the argument \code{fdr = TRUE}, this function returns the 26 | empiric cutoff that corresponds to the FDR-adjusted p-value 27 | stored in the \code{@results$FDR} slot. 28 | } 29 | -------------------------------------------------------------------------------- /tests/testthat/test-GET-getRatios.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | test_that("ratios work when compared with alr", { 5 | 6 | m <- matrix(1:30, 5, 6) 7 | rat1 <- propr(m, ivar = 1)@logratio[,"6"] # ratio as ALR 8 | rat2 <- getRatios(propr(m))[,"6/1"] # ratio from getRatios 9 | 10 | expect_equal( 11 | rat1, 12 | rat2 13 | ) 14 | }) 15 | 16 | test_that("ratios function works correctly", { 17 | 18 | # Sample input data 19 | data <- matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, byrow = TRUE) 20 | 21 | # Test case 1: Without alpha parameter 22 | expected_output_case1 <- log(data[, 2] / data[, 1]) 23 | result_case1 <- ratios(data)[,1] 24 | expect_equal(result_case1, expected_output_case1) 25 | 26 | # Test case 2: With alpha parameter 27 | alpha <- 2 28 | expected_output_case2 <- (data[, 2]^alpha - data[, 1]^alpha) / alpha 29 | result_case2 <- ratios(data, alpha = alpha)[,1] 30 | expect_equal(result_case2, expected_output_case2) 31 | }) 32 | -------------------------------------------------------------------------------- /man/getSignificantResultsFstat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getResults.R 3 | \name{getSignificantResultsFstat} 4 | \alias{getSignificantResultsFstat} 5 | \title{Get Significant Results based on the F-stats.} 6 | \usage{ 7 | getSignificantResultsFstat(object, pval = 0.05, fdr_adjusted = TRUE) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{propd} or \code{propr} object.} 11 | 12 | \item{pval}{A float value for the p-value. Default is 0.05.} 13 | 14 | \item{fdr_adjusted}{A boolean. If TRUE, use the the FDR- adjusted p-values. 15 | Otherwise, get significant pairs based on the theoretical F-statistic cutoff.} 16 | } 17 | \value{ 18 | A \code{data.frame} of results. 19 | } 20 | \description{ 21 | This function provides a unified wrapper to retrieve results 22 | from a \code{propd} object keeping only the statistically 23 | significant pairs. Note that it can only be applied to theta_d, 24 | as updateF only works for theta_d. 25 | } 26 | -------------------------------------------------------------------------------- /man/updatePermutes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updatePermutes.R 3 | \name{updatePermutes} 4 | \alias{updatePermutes} 5 | \title{Create permuted data} 6 | \usage{ 7 | updatePermutes( 8 | object, 9 | p = 100, 10 | permutation_option = c("feature-wise", "sample-wise") 11 | ) 12 | } 13 | \arguments{ 14 | \item{object}{A \code{propr} or \code{propd} object.} 15 | 16 | \item{p}{The number of permutations to perform. Default is 100.} 17 | 18 | \item{permutation_option}{A character string indicating if permute the data 19 | sample-wise or feature-wise. Default is "feature-wise". Note that this flag 20 | is only relevant for \code{propr} objects.} 21 | } 22 | \value{ 23 | A \code{propr} or \code{propd} object with the permutes slot updated. 24 | } 25 | \description{ 26 | This function creates p permuted data matrices 27 | } 28 | \details{ 29 | This function wraps \code{updatePermutes.propr} and 30 | \code{updatePermutes.propd}. 31 | } 32 | -------------------------------------------------------------------------------- /man/search_tree.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/5-selectRatios.R 3 | \name{search_tree} 4 | \alias{search_tree} 5 | \title{Search Tree Function} 6 | \usage{ 7 | search_tree(data, Z, nclust = ncol(data)/10, nsearch = 1, lrm = NULL) 8 | } 9 | \arguments{ 10 | \item{data}{The input data matrix for clustering.} 11 | 12 | \item{Z}{The matrix used to fit vegan model.} 13 | 14 | \item{nclust}{The number of clusters to create during hierarchical clustering. 15 | Default is calculated as ncol(data) / 10.} 16 | 17 | \item{nsearch}{The number of best clusters to search for. Default is 1.} 18 | 19 | \item{lrm}{The Log Ratio Matrix. Default is NULL.} 20 | } 21 | \value{ 22 | A numeric vector containing the percentage of variance explained 23 | by CCA for each cluster identified. 24 | } 25 | \description{ 26 | This function performs a hierarchical clustering on the given data and 27 | identifies the best clusters based on variance explained by 28 | Canonical Correspondence Analysis (CCA). 29 | } 30 | -------------------------------------------------------------------------------- /man/runNormalization.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/2c-propd-experimental.R 3 | \name{runNormalization} 4 | \alias{runNormalization} 5 | \title{Get Per-Feature Theta} 6 | \usage{ 7 | runNormalization(object, norm.factors) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{\link{propd}} object.} 11 | 12 | \item{norm.factors}{A numeric vector. The effective library size 13 | normalization factors (e.g., from edgeR or DESeq2).} 14 | } 15 | \value{ 16 | A numeric vector. A theta for each feature. 17 | } 18 | \description{ 19 | This function calculates the differential proportionality 20 | between each feature and a set of normalization factors. When the 21 | normalization factors correctly remove the compositional bias, the 22 | resultant thetas indicate differential expression (DE). However, unlike 23 | other DE tests, the p-value for differential proportionality is 24 | not linked to the normalization factors. Here, normalization factors 25 | only affect the interpretation, not the statistics. 26 | } 27 | -------------------------------------------------------------------------------- /man/runPostHoc.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/2c-propd-experimental.R 3 | \name{runPostHoc} 4 | \alias{runPostHoc} 5 | \title{Perform Post-Hoc Testing} 6 | \usage{ 7 | runPostHoc(object) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{\link{propd}} object.} 11 | } 12 | \value{ 13 | A \code{\link{propd}} object. 14 | } 15 | \description{ 16 | After running an ANOVA of more than 2 groups, it is useful 17 | to know which of the groups differ from the others. This 18 | question is often answered with post-hoc testing. This 19 | function implements post-hoc pairwise differential 20 | proportionality analyses for more than 2 groups. 21 | } 22 | \details{ 23 | The ANOVA p-values are adjusted once (column-wise) during 24 | the original multi-group analysis. The post-hoc p-values 25 | are adjusted once (row-wise) for the number 26 | of post-hoc tests. The post-hoc adjustment 27 | is p times the number of post-hoc tests. 28 | 29 | Please note that a significant post-hoc test without 30 | a significant ANOVA test is not significant! 31 | } 32 | -------------------------------------------------------------------------------- /man/getAdjacencyFDR.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getAdjacency.R 3 | \name{getAdjacencyFDR} 4 | \alias{getAdjacencyFDR} 5 | \title{Get Adjacency Matrix as indicated by permutation tests.} 6 | \usage{ 7 | getAdjacencyFDR(object, fdr = 0.05, window_size = 1) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{propd} or \code{propr} object.} 11 | 12 | \item{fdr}{A float value for the false discovery rate. Default is 0.05.} 13 | 14 | \item{window_size}{An integer. Default is 1. When it is greater than 1, the FDR 15 | values would be smoothed out by a moving average of the given window size.} 16 | } 17 | \value{ 18 | An adjacency matrix. 19 | } 20 | \description{ 21 | This function gets the significant pairs according to the permutation tests. Then it fills 22 | the adjacency matrix with 1 if pair is significant, otherwise 0. The significance is determined 23 | by the cutoff value for which the false discovery rate (FDR) is less or equal than the given 24 | value 'fdr'. The significant pairs are those that have a value greater/less or equal than the 25 | cutoff, depending on the metric. 26 | } 27 | -------------------------------------------------------------------------------- /man/logratio_without_alpha.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/1a-propr-backend.R 3 | \name{logratio_without_alpha} 4 | \alias{logratio_without_alpha} 5 | \title{Perform log-ratio transformation without alpha parameter} 6 | \usage{ 7 | logratio_without_alpha(ct, use) 8 | } 9 | \arguments{ 10 | \item{ct}{A data matrix for which the log-ratio transformation will be 11 | performed. It is assumed that the matrix contains numerical values only.} 12 | 13 | \item{use}{An integer vector specifying the subset of columns to be used 14 | for the log-ratio transformation.} 15 | } 16 | \value{ 17 | A matrix containing the log-ratio transformed data. 18 | } 19 | \description{ 20 | This function applies a log-ratio transformation to a given data matrix 21 | without using an alpha parameter. The log-ratio transformation is based 22 | on a selected subset of columns specified by the `use` argument. 23 | } 24 | \examples{ 25 | # Sample input data 26 | data <- matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, byrow = TRUE) 27 | 28 | # Applying log-ratio transformation to rows using columns 2 and 3 as reference 29 | result <- logratio_without_alpha(data, use = c(2, 3)) 30 | 31 | } 32 | -------------------------------------------------------------------------------- /src/omega.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // Calculate lrv weight modifier 5 | // [[Rcpp::export]] 6 | NumericVector omega(NumericMatrix & W){ 7 | 8 | int nfeats = W.ncol(); 9 | int llt = nfeats * (nfeats - 1) / 2; 10 | Rcpp::NumericVector result(llt); 11 | Rcpp::NumericVector Wij(nfeats); 12 | int counter = 0; 13 | double n = 0; 14 | 15 | for(int i = 1; i < nfeats; i++){ 16 | for(int j = 0; j < i; j++){ 17 | Wij = 2 * W(_, i) * W(_, j) / (W(_, i) + W(_, j)); 18 | n = sum(Wij); 19 | result(counter) = n - sum(pow(Wij, 2)) / n; 20 | counter += 1; 21 | } 22 | } 23 | 24 | return result; 25 | } 26 | 27 | // Calculate lrv weight modifier (population-level for F-stat and F-mod) 28 | // [[Rcpp::export]] 29 | NumericVector Omega(NumericMatrix & W){ 30 | 31 | int nfeats = W.ncol(); 32 | int llt = nfeats * (nfeats - 1) / 2; 33 | Rcpp::NumericVector result(llt); 34 | Rcpp::NumericVector Wij(nfeats); 35 | int counter = 0; 36 | 37 | for(int i = 1; i < nfeats; i++){ 38 | for(int j = 0; j < i; j++){ 39 | Wij = 2 * W(_, i) * W(_, j) / (W(_, i) + W(_, j)); 40 | result(counter) = sum(Wij); 41 | counter += 1; 42 | } 43 | } 44 | 45 | return result; 46 | } 47 | -------------------------------------------------------------------------------- /old_tests/testthat/test-multiomic.R: -------------------------------------------------------------------------------- 1 | library(propr) 2 | data(iris) 3 | met.rel <- iris[,1:2] 4 | mic.rel <- iris[,3:4] 5 | 6 | # Analyze multi-omics via back-end 7 | clr <- function(x) sweep(log(x), 1, rowMeans(log(x)), "-") 8 | REL <- cbind(clr(met.rel), clr(mic.rel)) 9 | pr.r <- propr:::lr2rho(as.matrix(REL)) 10 | colnames(pr.r) <- colnames(REL) 11 | rownames(pr.r) <- colnames(REL) 12 | 13 | # Analyze multi-omics with wrapper 14 | ivarNA <- propr(REL, ivar = NA) 15 | 16 | test_that("ivar = NA works as expected", { 17 | 18 | expect_equal( 19 | NA, 20 | ivarNA@ivar 21 | ) 22 | 23 | expect_equal( 24 | pr.r, 25 | ivarNA@matrix 26 | ) 27 | 28 | expect_equal( 29 | ivarNA@counts, 30 | ivarNA@logratio 31 | ) 32 | }) 33 | 34 | # Test updateCutoffs for the ivar = NA wrapper 35 | set.seed(1) 36 | pr_auto <- propr(iris[,1:4]) 37 | clr <- function(x) sweep(log(x), 1, rowMeans(log(x)), "-") 38 | myCLR <- clr(iris[,1:4]) 39 | set.seed(1) 40 | pr_manual <- propr(myCLR, ivar = NA) 41 | pr_auto <- updateCutoffs(pr_auto, cutoff = seq(0, 1, .05)) 42 | pr_manual <- updateCutoffs(pr_manual, cutoff = seq(0, 1, .05)) 43 | 44 | test_that("ivar = NA will work with FDR", { 45 | 46 | expect_equal( 47 | pr_auto@fdr, 48 | pr_manual@fdr 49 | ) 50 | }) 51 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(aldex2propr) 4 | export(calculate_theta) 5 | export(compute_iqlr) 6 | export(getAdjacencyFDR) 7 | export(getAdjacencyFstat) 8 | export(getCutoffFDR) 9 | export(getCutoffFstat) 10 | export(getMatrix) 11 | export(getRatios) 12 | export(getResults) 13 | export(getSignificantResultsFDR) 14 | export(getSignificantResultsFDR.propd) 15 | export(getSignificantResultsFDR.propr) 16 | export(getSignificantResultsFstat) 17 | export(index_reference) 18 | export(logratio) 19 | export(logratio_with_alpha) 20 | export(logratio_without_alpha) 21 | export(pcor.bshrink) 22 | export(propd) 23 | export(propr) 24 | export(ratios) 25 | export(results_to_matrix) 26 | export(runGraflex) 27 | export(runNormalization) 28 | export(runPostHoc) 29 | export(search_tree) 30 | export(selectRatios) 31 | export(selectReference) 32 | export(setActive) 33 | export(setDisjointed) 34 | export(setEmergent) 35 | export(simple_zero_replacement) 36 | export(updateCutoffs) 37 | export(updateCutoffs.propd) 38 | export(updateCutoffs.propr) 39 | export(updateF) 40 | export(updatePermutes) 41 | exportClasses(propd) 42 | exportClasses(propr) 43 | exportMethods(show) 44 | importFrom(Rcpp,sourceCpp) 45 | importFrom(methods,new) 46 | importFrom(methods,show) 47 | useDynLib(propr, .registration = TRUE) 48 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPR-phi-rho-phs-cor.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | N <- 100 5 | a <- seq(from = 5, to = 15, length.out = N) 6 | b <- a * rnorm(N, mean = 1, sd = 0.1) 7 | c <- rnorm(N, mean = 10) 8 | d <- rnorm(N, mean = 10) 9 | e <- rep(10, N) 10 | X <- data.frame(a, b, c, d, e) 11 | 12 | # get phi 13 | pr <- propr(X, metric = "phi") 14 | phi <- getMatrix(pr) 15 | 16 | # get rho 17 | pr <- propr(X, metric = "rho") 18 | rho <- getMatrix(pr) 19 | 20 | # get phs 21 | pr <- propr(X, metric = "phs") 22 | phs <- getMatrix(pr) 23 | 24 | # get cor 25 | pr <- propr(X, metric = "cor") 26 | cor <- getMatrix(pr) 27 | 28 | # get beta 29 | counts.clr <- t(apply(X, 1, function(x) log(x) - mean(log(x)))) 30 | counts.clr.var <- apply(counts.clr, 2, var) 31 | A_j <- matrix(rep(counts.clr.var, length(counts.clr.var)), nrow = length(counts.clr.var)) 32 | A_i <- counts.clr.var 33 | beta <- sqrt(sweep(A_j, 2, A_i, "/")) 34 | 35 | # calculate alt rho, phs, cor 36 | rho_ <- 1 - phi / (1 + beta^2) 37 | phs_ <- (1 - rho_) / (1 + rho_) 38 | cor_ <- (1 + beta^2 - phi) / (2 * beta) 39 | 40 | test_that("calculating rho from phi matches rho", { 41 | 42 | expect_equal( 43 | rho_, 44 | rho 45 | ) 46 | 47 | expect_equal( 48 | phs_, 49 | phs 50 | ) 51 | 52 | expect_equal( 53 | cor_, 54 | cor 55 | ) 56 | 57 | }) 58 | -------------------------------------------------------------------------------- /R/1-propr-help.R: -------------------------------------------------------------------------------- 1 | #' The propr Package 2 | #' 3 | #' @description 4 | #' Welcome to the \code{propr} package! 5 | #' 6 | #' To learn more about calculating proportionality, see 7 | #' Details. 8 | #' 9 | #' To learn more about differential proportionality, see 10 | #' \code{\link{propd}}. 11 | #' 12 | #' To learn more about compositional data analysis, see 13 | #' \code{citation("propr")}. 14 | #' 15 | #' @slot counts A data.frame. Stores the original "count matrix" input. 16 | #' @slot alpha A double. Stores the alpha value used for transformation. 17 | #' @slot metric A character string. The metric used to calculate proportionality. 18 | #' @slot ivar A vector. The reference used to calculate proportionality. 19 | #' @slot logratio A data.frame. Stores the transformed "count matrix". 20 | #' @slot matrix A matrix. Stores the proportionality matrix. 21 | #' @slot pairs A vector. Indexes the proportional pairs of interest. 22 | #' @slot results A data.frame. Stores the pairwise \code{propr} measurements. 23 | #' @slot permutes A list. Stores the shuffled transformed "count matrix" 24 | #' instances, used to reproduce permutations of \code{propr}. 25 | #' @slot fdr A data.frame. Stores the FDR cutoffs for \code{propr}. 26 | #' 27 | #' @param object A \code{propr} object. 28 | #' 29 | #' @name propr 30 | #' @useDynLib propr, .registration = TRUE 31 | #' @importFrom methods show new 32 | #' @importFrom Rcpp sourceCpp 33 | NULL 34 | -------------------------------------------------------------------------------- /R/5-selectReference.R: -------------------------------------------------------------------------------- 1 | #' Select Optimal Reference Component 2 | #' 3 | #' This function selects the optimal reference component from the log-ratio 4 | #' transformed data matrix based on the provided \code{ivar} (index variable) 5 | #' and \code{alpha} values. 6 | #' 7 | #' The function transforms the input \code{counts} matrix into log space using 8 | #' the \code{logratio} function. Then, it calculates the variance of each 9 | #' component and identifies the component with the minimum variance, 10 | #' which is considered the optimal reference. 11 | #' 12 | #' @inheritParams propr 13 | #' @return The column name or index of the optimal reference component. 14 | #' @examples 15 | #' # Sample counts matrix 16 | #' counts_matrix <- matrix(c(10, 20, 30, 40, 0, 50, 60, 70, 0), nrow = 3, byrow = TRUE) 17 | #' colnames(counts_matrix) <- c("A", "B", "C") 18 | #' rownames(counts_matrix) <- c("Sample1", "Sample2", "Sample3") 19 | #' 20 | #' # Select optimal reference component 21 | #' selectReference(counts_matrix, ivar = "A", alpha = 0.5) 22 | #' 23 | #' @export 24 | selectReference <- function(counts, ivar, alpha) { 25 | # replace zeros 26 | counts <- simple_zero_replacement(counts) 27 | # Transform data into log space 28 | lr <- logratio(counts, ivar, alpha) 29 | 30 | # Calculate var of each component 31 | vars <- apply(lr, 2, stats::var) 32 | if (!is.null(colnames(counts))) { 33 | colnames(counts)[which.min(vars)] 34 | } else{ 35 | which.min(vars) 36 | } 37 | } 38 | -------------------------------------------------------------------------------- /man/logratio_with_alpha.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/1a-propr-backend.R 3 | \name{logratio_with_alpha} 4 | \alias{logratio_with_alpha} 5 | \title{Perform log-ratio transformation with alpha parameter} 6 | \usage{ 7 | logratio_with_alpha(ct, use, alpha) 8 | } 9 | \arguments{ 10 | \item{ct}{A data matrix for which the log-ratio transformation will be 11 | performed. It is assumed that the matrix contains numerical values only.} 12 | 13 | \item{use}{An integer vector specifying the subset of columns to be used 14 | for the log-ratio transformation.} 15 | 16 | \item{alpha}{The alpha parameter used in the transformation.} 17 | } 18 | \value{ 19 | A matrix containing the log-ratio transformed data. 20 | } 21 | \description{ 22 | This function applies a log-ratio transformation to a given data matrix 23 | using an alpha parameter. The log-ratio transformation is based on a 24 | selected subset of columns specified by the `use` argument. 25 | The transformation formula is: \code{log(x/ref) = log(x) - log(ref) = 26 | [x^alpha-1]/alpha - [ref^alpha-1]/alpha}, where \code{x} represents the 27 | data matrix and \code{ref} is the reference value calculated as the mean 28 | of the selected subset of columns. 29 | } 30 | \examples{ 31 | # Sample input data 32 | data <- matrix(c(1, 2, 3, 4, 5, 6), nrow = 2, byrow = TRUE) 33 | 34 | # Applying log-ratio transformation with alpha = 2 to rows using columns 2 and 3 35 | result <- logratio_with_alpha(data, use = c(2, 3), alpha = 2) 36 | 37 | } 38 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPR-backend.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | # define data 5 | data <- matrix(c(1:12), ncol=4) 6 | colnames(data) <- c("A", "B", "C", "D") 7 | 8 | 9 | test_that("index_reference works properly", { 10 | 11 | expect_identical( 12 | as.integer(index_reference(data, 2)), 13 | as.integer(2) 14 | ) 15 | expect_identical( 16 | as.integer(index_reference(data, c("A", "C"))), 17 | as.integer(c(1, 3)) 18 | ) 19 | expect_identical( 20 | as.integer(index_reference(data, "clr")), 21 | as.integer(c(1, 2, 3, 4)) 22 | ) 23 | 24 | }) 25 | 26 | test_that("logratio_without_alpha performs log-ratio transformation correctly", { 27 | 28 | # when ivar is 2 29 | transformed_data <- logratio_without_alpha(data, use = 2) 30 | expect_identical( 31 | as.numeric(round(transformed_data[1,1], 6)), 32 | round(log(1/4), 6) 33 | ) 34 | expect_identical( 35 | as.numeric(round(transformed_data[2,1], 6)), 36 | round(log(2/5), 6) 37 | ) 38 | 39 | # when ivar is 1,3 40 | transformed_data <- logratio_without_alpha(data, use = c(1,3)) 41 | expected <- t(apply(data, 1, function(x) log(x) - mean(log(x[c(1,3)])))) 42 | expect_true( 43 | all(round(transformed_data, 6) == round(expected, 6)) 44 | ) 45 | 46 | # when ivar is clr 47 | transformed_data <- logratio_without_alpha(data, use = c(1,2,3,4)) 48 | expected <- t(apply(data, 1, function(x) log(x) - mean(log(x)))) 49 | expect_true( 50 | all(round(transformed_data, 6) == round(expected, 6)) 51 | ) 52 | 53 | }) 54 | -------------------------------------------------------------------------------- /man/pcor.bshrink.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/1a-propr-backend.R 3 | \name{pcor.bshrink} 4 | \alias{pcor.bshrink} 5 | \title{Basis Covariance Shrinkage and Partial Correlation Calculation} 6 | \usage{ 7 | pcor.bshrink(ct, outtype = c("clr", "alr")) 8 | } 9 | \arguments{ 10 | \item{ct}{A data matrix representing the counts. Each row should represent 11 | observations, and each column should represent different variables.} 12 | 13 | \item{outtype}{A character vector specifying the output type. It can take 14 | either "clr" (centered log-ratio) or "alr" (additive log-ratio). Since 15 | the reference does not affect the logratio partial correlation coefficients, 16 | the index of the reference is not needed for "alr". Also, "clr" is recommended 17 | because of the same reason, at the same time avoiding losing one dimension.} 18 | } 19 | \value{ 20 | A matrix representing the shrunk partial correlation matrix. 21 | } 22 | \description{ 23 | This function performs covariance shrinkage on the basis matrix 24 | and calculates the partial correlation matrix. The function can 25 | output the results in two formats: centered log-ratio (clr) or 26 | additive log-ratio (alr). 27 | } 28 | \examples{ 29 | # Sample input count data 30 | data <- iris[,1:4] 31 | 32 | # Calculate partial correlation matrix using clr transformation 33 | result_clr <- pcor.bshrink(data, outtype = "clr") 34 | 35 | # Calculate partial correlation matrix using alr transformation 36 | result_alr <- pcor.bshrink(data, outtype = "alr") 37 | 38 | } 39 | -------------------------------------------------------------------------------- /data-raw/data-abs.R: -------------------------------------------------------------------------------- 1 | RNA.seq <- read.csv("./data-raw/data/RNA.seq.csv", header=T, skip=1) 2 | microarray <- read.csv("./data-raw/data/microarray.csv", header=T, skip=3) 3 | names(microarray) <- sub("T", "timepoint", names(microarray)) 4 | go <- read.csv("./data-raw/data/Complex_annotation", header=T, sep="\t") 5 | names(go)[6] <- "Systematic.name" 6 | 7 | # Average the sums all the copies-per-cell ("cpc") counts for MM1 and MM2, 8 | # treating any NAs as 0 9 | tmp <- data.frame(Systematic.name=RNA.seq$Systematic.name, 10 | RNA.seq=rowSums( 11 | RNA.seq[,grep("MM[12].*cpc.*", names(RNA.seq))], 12 | na.rm=TRUE 13 | )/2 14 | ) 15 | 16 | # Drop any mRNAs that have a zero count in the RNA-seq 17 | tmp <- subset(tmp, RNA.seq > 0) 18 | 19 | # Do an inner join of Abs and the microarray data based on the Systematic names 20 | tmp <- merge(tmp, microarray, by="Systematic.name") 21 | 22 | # Now use the relative abundances at each microarray timepoint to multiply 23 | # the initial mRNA copies per cell. Remove any rows that contain NAs 24 | multipliers <- as.matrix(tmp[, grep("timepoint", names(tmp))]) 25 | Abs <- data.frame(tmp$RNA.seq * multipliers) 26 | rownames(Abs) <- tmp[,"Systematic.name"] 27 | Abs <- na.omit(Abs) 28 | Abs.t <- as.data.frame(t(Abs)) 29 | 30 | Rel <- sweep(Abs,2,colSums(Abs, na.rm=TRUE),"/") 31 | Rel.t <- as.data.frame(t(Rel)) 32 | 33 | marg.abs <- Abs.t 34 | 35 | devtools::use_data(marg.abs) 36 | -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-lrv.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | # use iris data 5 | counts <- iris[, 1:4] 6 | counts <- as.matrix(counts) 7 | group <- iris[, 5] 8 | 9 | test_that("lrv_with_shrinkage and lrv match, when shrinkage is false", { 10 | 11 | # calculate lrv without shrinkage 12 | lrv1 <- propr:::lrv(counts, counts, FALSE, NA, counts, counts) 13 | lrv2 <- propr:::lrv_with_shrinkage(counts, shrink=FALSE) 14 | 15 | # check if they are equal 16 | expect_equal(lrv1, lrv2) 17 | }) 18 | 19 | test_that("lrv with_shrinkage and lrv do not match, when shrinkage is true", { 20 | # calculate lrv with shrinkage 21 | lrv1 <- propr:::lrv(counts, counts, FALSE, NA, counts, counts) 22 | lrv2 <- propr:::lrv_with_shrinkage(counts, shrink=TRUE) 23 | 24 | # check if they are not equal 25 | expect_false(identical(lrv1, lrv2)) 26 | }) 27 | 28 | test_that("lrv_with_shrinkage and lrv match for within group", { 29 | # define inputs 30 | ct <- as.matrix(counts) 31 | w <- ct 32 | groups <- lapply(unique(group), function(g) g == group) 33 | ngrp <- length(unique(group)) 34 | 35 | # calculate lrv for group 1 36 | lrv1 <- propr:::lrv(ct[groups[[1]],], w[groups[[1]],], FALSE, NA, ct, w) 37 | lrv2 <- propr:::lrv_with_shrinkage(ct[groups[[1]],], shrink=FALSE) 38 | expect_equal(lrv1, lrv2) 39 | 40 | # calculate lrv for group 2 41 | lrv1 <- propr:::lrv(ct[groups[[2]],], w[groups[[2]],], FALSE, NA, ct, w) 42 | lrv2 <- propr:::lrv_with_shrinkage(ct[groups[[2]],], shrink=FALSE) 43 | expect_equal(lrv1, lrv2) 44 | }) -------------------------------------------------------------------------------- /tests/testthat/test-PROPR-clr-alr-vlr.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | N <- 100 5 | a <- seq(from = 5, to = 15, length.out = N) 6 | b <- a * rnorm(N, mean = 1, sd = 0.1) 7 | c <- rnorm(N, mean = 10) 8 | d <- rnorm(N, mean = 10) 9 | e <- rep(10, N) 10 | X <- data.frame(a, b, c, d, e) 11 | 12 | # VLR using propr with CLR ivar 13 | X.clr <- propr(X, ivar = "clr")@logratio 14 | Cov <- stats::var(X.clr) 15 | D <- ncol(X.clr) 16 | VarCol <- matrix(rep(diag(Cov), D), ncol = D) 17 | VLR.clr <- -2 * Cov + VarCol + t(VarCol) 18 | 19 | # VLR using propr with ALR ivar 20 | X.alr <- propr(X, ivar = 5)@logratio 21 | Cov <- stats::var(X.alr) 22 | D <- ncol(X.alr) 23 | VarCol <- matrix(rep(diag(Cov), D), ncol = D) 24 | VLR.alr <- -2 * Cov + VarCol + t(VarCol) 25 | 26 | # VLR using propr VLR functions 27 | X.vlr1 <- propr(X, metric = "vlr")@matrix 28 | X.vlr2 <- propr(X / rowSums(X), metric = "vlr")@matrix 29 | X.vlr3 <- propr:::vlrRcpp(as.matrix(X[])) 30 | rownames(X.vlr3) <- colnames(X) 31 | colnames(X.vlr3) <- colnames(X) 32 | X.vlr4 <- propr:::lr2vlr(as.matrix(X.clr)) 33 | rownames(X.vlr4) <- colnames(X) 34 | colnames(X.vlr4) <- colnames(X) 35 | 36 | test_that("vlr shows subcompositional coherence", { 37 | 38 | expect_equal( 39 | X.vlr1, # propr(how = "vlr") 40 | X.vlr2 # propr(how = "vlr") 41 | ) 42 | 43 | expect_equal( 44 | X.vlr1, # propr(how = "vlr") 45 | X.vlr3 # vlrRcpp 46 | ) 47 | 48 | expect_equal( 49 | X.vlr3, # vlrRcpp 50 | X.vlr4 # lr2vlr 51 | ) 52 | 53 | expect_equal( 54 | X.vlr3, # vlrRcpp 55 | VLR.clr 56 | ) 57 | 58 | expect_equal( 59 | X.vlr3, # vlrRcpp 60 | VLR.alr 61 | ) 62 | 63 | expect_equal( 64 | VLR.clr, 65 | VLR.alr 66 | ) 67 | }) 68 | -------------------------------------------------------------------------------- /man/getSignificantResultsFDR.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-getResults.R 3 | \name{getSignificantResultsFDR} 4 | \alias{getSignificantResultsFDR} 5 | \alias{getSignificantResultsFDR.propr} 6 | \alias{getSignificantResultsFDR.propd} 7 | \title{Get Significant Results from Object based on the permutation tests.} 8 | \usage{ 9 | getSignificantResultsFDR(object, fdr = 0.05, window_size = 1) 10 | 11 | getSignificantResultsFDR.propr(object, fdr = 0.05, window_size = 1) 12 | 13 | getSignificantResultsFDR.propd(object, fdr = 0.05, window_size = 1) 14 | } 15 | \arguments{ 16 | \item{object}{A \code{propd} or \code{propr} object.} 17 | 18 | \item{fdr}{A float value for the false discovery rate. Default is 0.05.} 19 | 20 | \item{window_size}{An integer. Default is 1. When it is greater than 1, the FDR 21 | values would be smoothed out by a moving average of the given window size.} 22 | } 23 | \value{ 24 | A \code{data.frame} of results. 25 | } 26 | \description{ 27 | This function retrieves results from a \code{propr} or \code{propd} object keeping only the 28 | statistically significant pairs. The significance is determined by the cutoff value for which 29 | the false discovery rate (FDR) is less or equal than the given value 'fdr'. The significant 30 | pairs are those that have a value greater/less or equal than the cutoff, depending on the metric. 31 | } 32 | \section{Methods}{ 33 | 34 | \code{getSignificantResultsFDR.propr:} 35 | This function retrieves results from a \code{propr} object keeping 36 | only the statistically significant pairs. 37 | 38 | 39 | \code{getSignificantResultsFDR.propd:} 40 | This function retrieves results from a \code{propd} object keeping 41 | only the statistically significant pairs. 42 | } 43 | 44 | -------------------------------------------------------------------------------- /man/logratio.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/1a-propr-backend.R 3 | \name{logratio} 4 | \alias{logratio} 5 | \title{Perform log-ratio transformation} 6 | \usage{ 7 | logratio(counts, ivar, alpha = NA) 8 | } 9 | \arguments{ 10 | \item{counts}{A data matrix representing counts. 11 | It is assumed that the matrix contains numerical values only.} 12 | 13 | \item{ivar}{An indicator specifying the method for log-ratio transformation. 14 | It can take the following values: 15 | - "clr" (default): Centered log-ratio transformation. 16 | - "alr": Additive log-ratio transformation ("pcor.bshrink" metric only). 17 | - "iqlr": Inter-quartile log-ratio transformation from ALDEx2. 18 | - The explicit name(s) or index(es) of variable(s) to use as a reference. 19 | - Use NA to skip log-ratio transformation and any other pre-processing, like 20 | zero replacement. This is useful when the input data is already pre-processed.} 21 | 22 | \item{alpha}{The alpha parameter used in the alpha log-ratio transformation.} 23 | } 24 | \value{ 25 | A matrix with log-ratio transformed values. 26 | } 27 | \description{ 28 | This function applies a log-ratio transformation to a given data matrix 29 | with or without using an alpha parameter. 30 | } 31 | \examples{ 32 | # Sample counts matrix 33 | counts_matrix <- matrix(c(10, 20, 30, 40, 50, 60, 70, 80, 90), nrow = 3, byrow = TRUE) 34 | colnames(counts_matrix) <- c("A", "B", "C") 35 | rownames(counts_matrix) <- c("Sample1", "Sample2", "Sample3") 36 | 37 | # Perform log-ratio transformation without alpha 38 | logratio(counts_matrix, ivar = "A") 39 | 40 | # Perform log-ratio transformation with alpha 0.5 41 | logratio(counts_matrix, ivar = "A", alpha = 0.5) 42 | 43 | # Skip log-ratio transformation 44 | logratio(counts_matrix, ivar = NA) 45 | 46 | } 47 | -------------------------------------------------------------------------------- /man/calculate_theta.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/2a-propd-backend.R 3 | \name{calculate_theta} 4 | \alias{calculate_theta} 5 | \title{Calculate Theta and Related Statistics} 6 | \usage{ 7 | calculate_theta( 8 | counts, 9 | group, 10 | alpha = NA, 11 | lrv = NA, 12 | only = "all", 13 | weighted = FALSE, 14 | shrink = FALSE 15 | ) 16 | } 17 | \arguments{ 18 | \item{counts}{A data matrix representing counts. 19 | It is assumed that the matrix contains numerical values only.} 20 | 21 | \item{group}{A character vector representing group labels indicating the 22 | assignment of each count to different groups.} 23 | 24 | \item{alpha}{The alpha parameter used in the alpha log-ratio transformation.} 25 | 26 | \item{lrv}{If LRV is provided, it is not computed within the function.} 27 | 28 | \item{only}{A character vector specifying the type of theta to calculate.} 29 | 30 | \item{weighted}{A logical value indicating whether weighted calculations 31 | should be performed.} 32 | 33 | \item{shrink}{A logical value indicating whether to apply shrinkage} 34 | } 35 | \value{ 36 | A data frame containing the computed theta values and 37 | related statistics, depending on the `only` parameter. 38 | } 39 | \description{ 40 | This function calculates theta and related statistics based on the input 41 | count matrix and other parameters. The function provides various options 42 | for calculating theta (theta_d, theta_e, theta_f, theta_g). 43 | } 44 | \examples{ 45 | # Sample input count data and group assignments 46 | data <- iris[1:100, 1:4] 47 | group <- iris[1:100, 5] 48 | 49 | # Calculate all theta types 50 | result_all <- calculate_theta(data, group, alpha = 0.5) 51 | 52 | # Calculate only theta_d 53 | result_theta_d <- calculate_theta(data, group, alpha = 0.5, only = "theta_d") 54 | 55 | } 56 | -------------------------------------------------------------------------------- /R/2-propd-OOP.R: -------------------------------------------------------------------------------- 1 | #' @rdname propd 2 | #' @export 3 | setClass( 4 | "propd", 5 | slots = c( 6 | counts = "data.frame", 7 | alpha = "numeric", 8 | group = "character", 9 | weighted = "logical", 10 | weights = "data.frame", 11 | active = "character", 12 | Fivar = "ANY", 13 | dfz = "numeric", 14 | results = "data.frame", 15 | permutes = "data.frame", 16 | fdr = "data.frame", 17 | shrink = "logical" 18 | ) 19 | ) 20 | 21 | #' @rdname propd 22 | #' @section Methods (by generic): 23 | #' \code{show:} Method to show \code{propd} object. 24 | #' @export 25 | setMethod("show", "propd", 26 | function(object) { 27 | cat( 28 | ifelse(object@weighted, "Weighted", "Not weighted"), 29 | "and", 30 | ifelse( 31 | is.na(object@alpha), 32 | "not alpha-transformed", 33 | "alpha-transformed" 34 | ), 35 | "\n" 36 | ) 37 | 38 | cat( 39 | "@counts summary:", 40 | nrow(object@counts), 41 | "subjects by", 42 | ncol(object@counts), 43 | "features\n" 44 | ) 45 | 46 | cat( 47 | "@group summary:", 48 | length(unique(object@group)), 49 | "unique groups (", 50 | paste(table(object@group), collapse = " x "), 51 | ")\n" 52 | ) 53 | 54 | cat("@results summary:", 55 | nrow(object@results), 56 | "feature pairs (", 57 | object@active, 58 | ")\n") 59 | 60 | cat("@fdr summary:", 61 | ncol(object@permutes), "iterations\n") 62 | 63 | if (nrow(object@fdr) > 0) { 64 | print(object@fdr) 65 | } 66 | 67 | cat("See ?propd for object methods\n") 68 | }) 69 | -------------------------------------------------------------------------------- /man/index_reference.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/1a-propr-backend.R 3 | \name{index_reference} 4 | \alias{index_reference} 5 | \title{Index Reference for Selecting Features} 6 | \usage{ 7 | index_reference(counts, ivar) 8 | } 9 | \arguments{ 10 | \item{counts}{A data matrix representing counts. 11 | It is assumed that the matrix contains numerical values only.} 12 | 13 | \item{ivar}{An indicator specifying the method for log-ratio transformation. 14 | It can take the following values: 15 | - "clr" (default): Centered log-ratio transformation. 16 | - "alr": Additive log-ratio transformation ("pcor.bshrink" metric only). 17 | - "iqlr": Inter-quartile log-ratio transformation from ALDEx2. 18 | - The explicit name(s) or index(es) of variable(s) to use as a reference. 19 | - Use NA to skip log-ratio transformation and any other pre-processing, like 20 | zero replacement. This is useful when the input data is already pre-processed.} 21 | } 22 | \value{ 23 | A numeric vector representing the indices of features selected. 24 | } 25 | \description{ 26 | This function computes an index reference for selecting features from the 27 | input count matrix based on the provided `ivar` argument. The index 28 | reference can be obtained using different options, such as selecting all 29 | features, using a user-defined vector of indices, selecting features by 30 | name, using the "clr" transformation, or computing the IQLR 31 | (Interquartile Range Log Ratio) features. 32 | } 33 | \examples{ 34 | # Sample input count data 35 | data <- matrix(c(1, 2, 3, 4, 0, 6), nrow = 2, byrow = TRUE) 36 | 37 | # Index reference using all features 38 | all_features <- index_reference(data, ivar = "all") 39 | 40 | # Index reference using custom numeric vector 41 | custom_indices <- index_reference(data, ivar = c(1, 3)) 42 | 43 | # Index reference using IQLR features 44 | iqlr_features <- index_reference(data, ivar = "iqlr") 45 | 46 | } 47 | -------------------------------------------------------------------------------- /src/comparison.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | using namespace Rcpp; 3 | 4 | // Count the number of elements in vector `x` that are strictly less than the 5 | // `cutoff`. 6 | // 7 | // [[Rcpp::export]] 8 | int count_less_than(NumericVector x, double cutoff) { 9 | // See `?Memory-limits`: R vectors are limited in size to the max value of a 10 | // signed int, as they use signed int for their size. If all values of `x` 11 | // are greater than cutoff, then we would get a count of INT_MAX, so the count 12 | // shouldn't overflow. 13 | int count = 0; 14 | int len = x.size(); 15 | 16 | for (int i = 0; i < len; ++i) { 17 | // Returns 1 if it's less than cutoff, zero otherwise. Add it to the count. 18 | count += x[i] < cutoff; 19 | } 20 | 21 | return count; 22 | } 23 | 24 | // Count the number of elements in vector `x` that are strictly greater than the 25 | // `cutoff`. 26 | // 27 | // [[Rcpp::export]] 28 | int count_greater_than(NumericVector x, double cutoff) { 29 | int count = 0; 30 | int len = x.size(); 31 | 32 | for (int i = 0; i < len; ++i) { 33 | // Returns 1 if it's less than cutoff, zero otherwise. Add it to the count. 34 | count += x[i] > cutoff; 35 | } 36 | 37 | return count; 38 | } 39 | 40 | // Count the number of elements in vector `x` that are less or equal than the 41 | // `cutoff`. 42 | // 43 | // [[Rcpp::export]] 44 | int count_less_equal_than(NumericVector x, double cutoff) { 45 | int count = 0; 46 | int len = x.size(); 47 | 48 | for (int i = 0; i < len; ++i) { 49 | count += x[i] <= cutoff; 50 | } 51 | 52 | return count; 53 | } 54 | 55 | // Count the number of elements in vector `x` that are greater or equal than the 56 | // `cutoff`. 57 | // 58 | // [[Rcpp::export]] 59 | int count_greater_equal_than(NumericVector x, double cutoff) { 60 | int count = 0; 61 | int len = x.size(); 62 | 63 | for (int i = 0; i < len; ++i) { 64 | count += x[i] >= cutoff; 65 | } 66 | 67 | return count; 68 | } -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-getCutoff-propd.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | library(MASS) 4 | 5 | # define data 6 | data(crabs) 7 | x <- crabs[,4:8] # data matrix with 5 variables 8 | y <- crabs[,1] # group vector 9 | 10 | test_that("getCutoffFDR gets the correct cutoff", { 11 | 12 | # get propr object and update cutoffs 13 | set.seed(0) 14 | pr <- propd(x, as.character(y), p=10) 15 | pr <- updateCutoffs(pr, number_of_cutoffs=10) 16 | 17 | # get cutoff 18 | cutoff <- getCutoffFDR(pr, fdr = 0.05, window_size = 1) 19 | 20 | # check that the cutoff is correct 21 | expect_equal(round(cutoff, 4), 0.9738) # for the moment the expected value is manually calculated 22 | }) 23 | 24 | test_that("getCutoffFstat gets the correct cutoff when FDR correction is considered", { 25 | 26 | # get propr object and update cutoffs 27 | set.seed(0) 28 | pr <- propd(x, as.character(y), p=10) 29 | pr <- updateF(pr, moderated=F) 30 | 31 | # get cutoff 32 | cutoff_expected <- max(pr@results$theta[pr@results$FDR <= 0.05]) 33 | cutoff_actual <- getCutoffFstat(pr, pval = 0.05, fdr = TRUE) 34 | 35 | # check that the cutoff is correct 36 | expect_equal(round(cutoff_actual, 6), round(cutoff_expected, 6)) 37 | }) 38 | 39 | test_that("getCutoffFstat gets the correct cutoff when FDR correction is not considered", { 40 | 41 | # get propr object and update cutoffs 42 | set.seed(0) 43 | pr <- propd(x, as.character(y), p=10) 44 | pr <- updateF(pr, moderated=F) 45 | 46 | # get cutoff 47 | pval <- 0.05 48 | K <- length(unique(pr@group)) 49 | N <- length(pr@group) + pr@dfz # population-level metric (i.e., N) 50 | Q <- stats::qf(pval, K - 1, N - K, lower.tail = FALSE) 51 | cutoff_expected <- (N - 2) / (Q + (N - 2)) 52 | cutoff_actual <- getCutoffFstat(pr, fdr = FALSE) 53 | 54 | # check that the cutoff is correct 55 | expect_equal(round(cutoff_actual, 6), round(cutoff_expected, 6)) 56 | }) -------------------------------------------------------------------------------- /R/3-shared-graflex.R: -------------------------------------------------------------------------------- 1 | #' Calculate odds ratio and FDR 2 | #' 3 | #' This function calls \code{\link{graflex}} for each 4 | #' concept (i.e., column) in the database \code{K}. 5 | #' 6 | #' For each concept, this function calculates the odds ratio 7 | #' and determines the false discovery rate (FDR) by counting 8 | #' the number of the actual OR was greater or less than a 9 | #' permuted OR. 10 | #' 11 | #' @param A An adjacency matrix. 12 | #' @param K A knowledge database where each row is a graph node 13 | #' and each column is a concept. 14 | #' @param p An integer. The number of permutation. 15 | #' 16 | #' @export 17 | runGraflex <- function(A, K, p=100, ncores=1) { 18 | if (nrow(A) != nrow(K)) 19 | stop("'A' and 'K' must have identical rows.") 20 | if (nrow(A) != ncol(A)) 21 | stop("'A' must be a square matrix.") 22 | if (all(rownames(A) != rownames(K))) 23 | stop("'A' and 'K' must have the same row names.") 24 | 25 | if (ncores == 1){ 26 | # for each knowledge network, calculate odds ratio and FDR 27 | res <- lapply(1:ncol(K), function(k) { 28 | graflex(A, K[,k], p=p) # this calls the modified graflex function implemented in Rcpp C++ 29 | }) 30 | 31 | } else { 32 | packageCheck("parallel") 33 | cl <- parallel::makeCluster(ncores) 34 | parallel::clusterExport(cl, varlist = c("A", "K", "p"), envir = environment()) 35 | res <- parallel::parLapply(cl, 1:ncol(K), function(k) { 36 | graflex(A, K[,k], p=p) 37 | }) 38 | parallel::stopCluster(cl) 39 | } 40 | 41 | # parse resulting data frame 42 | res <- do.call("rbind", res) 43 | res <- cbind(res, rep(p, ncol(K))) 44 | res <- cbind(res, colnames(K)) 45 | res <- as.data.frame(res) 46 | colnames(res) <- c("Neither", "G.only", "A.only", "Both", "Odds", "LogOR", "FDR.under", "FDR.over", "Permutes", "Concept") 47 | # change the values to numeric, except for the concept column 48 | res[,1:9] <- lapply(res[,1:9], as.numeric) 49 | 50 | return(res) 51 | } 52 | -------------------------------------------------------------------------------- /R/2-propd-help.R: -------------------------------------------------------------------------------- 1 | #' The propd Method 2 | #' 3 | #' @description 4 | #' Welcome to the \code{propd} method! 5 | #' 6 | #' Let \eqn{X} and \eqn{Y} be non-zero positive feature vectors 7 | #' measured across \eqn{N} samples belonging to one of two groups, 8 | #' sized \eqn{N1} and \eqn{N2}. We use VLR to denote the variance 9 | #' of the log of the ratio of the vectors \eqn{X} over \eqn{Y}. 10 | #' We define theta as the weighted sum of the within-group VLR 11 | #' divided by the weighted total VLR. 12 | #' 13 | #' The \code{propd} method calculates theta. This fails in 14 | #' the setting of zero counts. The \code{propd} method 15 | #' will use a Box-Cox transformation to approximate VLR based on 16 | #' the parameter \eqn{\alpha}, if provided. We refer the user to 17 | #' the vignette for more details. 18 | #' 19 | #' Note that Group 1 always refers to the first element of the 20 | #' \code{group} vector argument supplied to \code{propd}. 21 | #' 22 | #' @slot counts A data.frame. Stores the original "count matrix" input. 23 | #' @slot alpha A double. Stores the alpha value used for transformation. 24 | #' @slot group A character vector. Stores the original group labels. 25 | #' @slot weighted A logical. Stores whether the theta is weighted. 26 | #' @slot weights A matrix. If weighted, stores the limma-based weights. 27 | #' @slot active A character. Stores the name of the active theta type. 28 | #' @slot Fivar ANY. Stores the reference used to moderate theta. 29 | #' @slot dfz A double. Stores the prior df used to moderate theta. 30 | #' @slot results A data.frame. Stores the pairwise \code{propd} measurements. 31 | #' @slot permutes A data.frame. Stores the shuffled group labels, 32 | #' used to reproduce permutations of \code{propd}. 33 | #' @slot fdr A data.frame. Stores the FDR cutoffs for \code{propd}. 34 | #' 35 | #' @param object A \code{propd} object. 36 | #' @param propd A \code{propd} object. 37 | #' 38 | #' @name propd 39 | #' @importFrom methods show new 40 | #' @importFrom Rcpp sourceCpp 41 | NULL 42 | -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-getResults-propd.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | library(MASS) 4 | 5 | # define data 6 | data(crabs) 7 | x <- crabs[,4:8] # data matrix with 5 variables 8 | y <- crabs[,1] # group vector 9 | 10 | test_that("getResults works as expected", { 11 | 12 | # get propd object 13 | pr <- propd(x, as.character(y), p=10) 14 | 15 | # get results 16 | results <- getResults(pr) 17 | 18 | # check that the values are correct 19 | expect_equal(pr@results[,-c(1:2)], results[,-c(1:2)]) 20 | 21 | # check that the variable names are corretly replaced 22 | expect_equal(results[,1], colnames(x)[pr@results[,1]]) 23 | expect_equal(results[,2], colnames(x)[pr@results[,2]]) 24 | 25 | # check that the order of pairs are as expected 26 | ord <- list(c(2,1), c(3,1), c(3,2), c(4,1), c(4,2), c(4,3), c(5,1), c(5,2), c(5,3), c(5,4)) 27 | for (i in 1:10) { 28 | expect_equal(results[i,1], colnames(x)[ord[[i]][1]]) 29 | expect_equal(results[i,2], colnames(x)[ord[[i]][2]]) 30 | } 31 | }) 32 | 33 | test_that("getSignificantResultsFDR works as expected", { 34 | 35 | # get propd object 36 | pr <- propd(x, as.character(y), p=10) 37 | pr <- updateCutoffs(pr, number_of_cutoffs=10) 38 | 39 | # get expected results 40 | cutoff <- getCutoffFDR(pr, fdr = 0.05, window_size = 1) 41 | expected <- pr@results[which(pr@results$theta <= cutoff),] 42 | 43 | # get significant results 44 | results <- getSignificantResultsFDR(pr, fdr = 0.05) 45 | 46 | # check that the values are correct 47 | expect_equal(results$theta, expected$theta) 48 | }) 49 | 50 | test_that("getSignificantResultsFstat works as expected", { 51 | 52 | # get propd object 53 | pr <- propd(x, as.character(y), p=10) 54 | pr <- updateF(pr) 55 | 56 | # expect that the Fstat values are smaller or equal than the cutoff 57 | expect_true(all(getSignificantResultsFstat(pr, fdr=F)$theta <= getCutoffFstat(pr, fdr=F))) 58 | expect_true(all(getSignificantResultsFstat(pr, fdr=T)$fdr <= 0.05)) 59 | 60 | }) 61 | -------------------------------------------------------------------------------- /man/selectReference.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/5-selectReference.R 3 | \name{selectReference} 4 | \alias{selectReference} 5 | \title{Select Optimal Reference Component} 6 | \usage{ 7 | selectReference(counts, ivar, alpha) 8 | } 9 | \arguments{ 10 | \item{counts}{A data matrix representing counts. 11 | It is assumed that the matrix contains numerical values only.} 12 | 13 | \item{ivar}{An indicator specifying the method for log-ratio transformation. 14 | It can take the following values: 15 | - "clr" (default): Centered log-ratio transformation. 16 | - "alr": Additive log-ratio transformation ("pcor.bshrink" metric only). 17 | - "iqlr": Inter-quartile log-ratio transformation from ALDEx2. 18 | - The explicit name(s) or index(es) of variable(s) to use as a reference. 19 | - Use NA to skip log-ratio transformation and any other pre-processing, like 20 | zero replacement. This is useful when the input data is already pre-processed.} 21 | 22 | \item{alpha}{The alpha parameter used in the alpha log-ratio transformation.} 23 | } 24 | \value{ 25 | The column name or index of the optimal reference component. 26 | } 27 | \description{ 28 | This function selects the optimal reference component from the log-ratio 29 | transformed data matrix based on the provided \code{ivar} (index variable) 30 | and \code{alpha} values. 31 | } 32 | \details{ 33 | The function transforms the input \code{counts} matrix into log space using 34 | the \code{logratio} function. Then, it calculates the variance of each 35 | component and identifies the component with the minimum variance, 36 | which is considered the optimal reference. 37 | } 38 | \examples{ 39 | # Sample counts matrix 40 | counts_matrix <- matrix(c(10, 20, 30, 40, 0, 50, 60, 70, 0), nrow = 3, byrow = TRUE) 41 | colnames(counts_matrix) <- c("A", "B", "C") 42 | rownames(counts_matrix) <- c("Sample1", "Sample2", "Sample3") 43 | 44 | # Select optimal reference component 45 | selectReference(counts_matrix, ivar = "A", alpha = 0.5) 46 | 47 | } 48 | -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-getCutoff-propr.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | # define data matrix 5 | set.seed(123) 6 | N <- 100 7 | a <- seq(from = 5, to = 15, length.out = N) 8 | b <- a * rnorm(N, mean = 1, sd = 0.1) 9 | c <- rnorm(N, mean = 10) 10 | d <- rnorm(N, mean = 10) 11 | e <- rep(10, N) 12 | X <- data.frame(a, b, c, d, e) 13 | 14 | test_that("test that getCutoff gets the correct cutoff - sample wise", { 15 | 16 | # get propr object and update cutoffs 17 | set.seed(0) 18 | pr <- propr(X, metric = "pcor.bshrink", p=10, permutation_option = "sample-wise") 19 | pr <- updateCutoffs(pr, number_of_cutoffs=10, tails='right') 20 | 21 | # get cutoff 22 | cutoff <- getCutoffFDR(pr, fdr = 0.05, window_size = 1) 23 | 24 | # check that cutoff is correct 25 | expect_equal(round(cutoff, 4), 0.6573) # for the moment the expected value is manually calculated 26 | }) 27 | 28 | test_that("test that getCutoff gets the correct cutoff - feature wise", { 29 | 30 | # get propr object and update cutoffs 31 | set.seed(0) 32 | pr <- propr(X, metric = "pcor.bshrink", p=10) 33 | pr <- updateCutoffs(pr, number_of_cutoffs=10, tails='right') 34 | 35 | # get cutoff 36 | cutoff <- getCutoffFDR(pr, fdr = 0.05, window_size = 1) 37 | 38 | # check that cutoff is correct 39 | expect_equal(round(cutoff, 4), 0.7762) # for the moment the expected value is manually calculated 40 | }) 41 | 42 | test_that("test that moving average works as expected", { 43 | 44 | x <- c(NA, 1, 1, 2, NA, 2, 3, 3, 3, 4, 4, 5) 45 | 46 | # define expected moving average 47 | y1 <- x 48 | y2 <- c(NA, 1, 1.5, 2, NA, 2.5, 3, 3, 3.5, 4, 4.5, 5) 49 | y3 <- c(NA, 1, 1.33, 1.5, NA, 2.5, 2.67, 3, 3.33, 3.67, 4.33, 4.5) 50 | y4 <- c(NA, 1.33, 1.33, 1.67, NA, 2.67, 2.75, 3.25, 3.5, 4, 4.33, 4.5) 51 | 52 | # check 53 | expect_equal(round(propr:::getMovingAverage(x, 1),2), round(y1,2)) 54 | expect_equal(round(propr:::getMovingAverage(x, 2),2), round(y2,2)) 55 | expect_equal(round(propr:::getMovingAverage(x, 3),2), round(y3,2)) 56 | expect_equal(round(propr:::getMovingAverage(x, 4),2), round(y4,2)) 57 | }) 58 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: propr 2 | Title: An R package to calculate proportionality and other measures for compositional data 3 | Version: 5.1.8 4 | URL: https://github.com/tpq/propr 5 | BugReports: https://github.com/tpq/propr/issues 6 | Authors@R: c( 7 | person("Thomas", "Quinn", email = "contacttomquinn@gmail.com", role = c("aut", "cre")), 8 | person("Suzanne", "Jin", email = "suzanne.jin.yao@gmail.com", role = "aut"), 9 | person("Ionas", "Erb", email = "ionas.erb@crg.eu", role = "aut"), 10 | person("David", "Lovell", email = "david.lovell@qut.edu.au", role = "aut"), 11 | person("Anders", "Bilgrau", email = "anders.ellern.bilgrau@gmail.com", role = "ctb"), 12 | person("Greg", "Gloor", email = "ggloor@uwo.ca", role = "ctb"), 13 | person("Ryan", "Moore", email = "rmm1047@gmail.com", role = "ctb") 14 | ) 15 | Description: The bioinformatic evaluation of gene co-expression often begins with 16 | correlation-based analyses. However, conventional correlation measures lack validity 17 | when applied to compositional data, including count data generated by next-generation 18 | sequencing. Here we implemented valid alternatives for measuring association between 19 | vectors of compositional data. These include several metrics for proportionality, such as 20 | phi [Lovell et al (2015) ] and 21 | rho [Erb and Notredame (2016) ]. It also implements a 22 | regularized version of logratio partial correlations [Jin et al (2023) ]. 23 | Moreover, this package implements several metrics for 24 | differential proportionality [Erb et al (2017) ]. 25 | License: GPL-2 26 | LazyData: true 27 | VignetteBuilder: knitr 28 | RoxygenNote: 7.3.2 29 | Encoding: UTF-8 30 | Depends: 31 | methods, 32 | R (>= 3.2.2) 33 | Imports: 34 | corpcor, 35 | ppcor, 36 | Rcpp, 37 | stats 38 | Suggests: 39 | ALDEx2, 40 | fastcluster, 41 | knitr, 42 | limma, 43 | parallel, 44 | rmarkdown, 45 | testthat (>= 3.0.0), 46 | vegan 47 | LinkingTo: 48 | Rcpp 49 | Config/testthat/edition: 3 50 | -------------------------------------------------------------------------------- /R/3-shared-updatePermutes.R: -------------------------------------------------------------------------------- 1 | #' Create permuted data 2 | #' 3 | #' This function creates p permuted data matrices 4 | #' 5 | #' This function wraps \code{updatePermutes.propr} and 6 | #' \code{updatePermutes.propd}. 7 | #' 8 | #' @param object A \code{propr} or \code{propd} object. 9 | #' @param p The number of permutations to perform. Default is 100. 10 | #' @param permutation_option A character string indicating if permute the data 11 | #' sample-wise or feature-wise. Default is "feature-wise". Note that this flag 12 | #' is only relevant for \code{propr} objects. 13 | #' @return A \code{propr} or \code{propd} object with the permutes slot updated. 14 | #' @export 15 | updatePermutes <- function(object, p=100, permutation_option = c("feature-wise", "sample-wise")) { 16 | if (inherits(object, "propr")) { 17 | updatePermutes.propr(object, p, permutation_option) 18 | 19 | } else if (inherits(object, "propd")) { 20 | updatePermutes.propd(object, p) 21 | 22 | } else{ 23 | stop("Provided 'object' not recognized.") 24 | } 25 | } 26 | 27 | updatePermutes.propr <- function(object, p, permutation_option = c("feature-wise", "sample-wise")) { 28 | message("Alert: Fixing permutations to active random seed.") 29 | ct <- object@counts 30 | permutes <- vector("list", p) 31 | for (ins in 1:p){ 32 | if (permutation_option[1] == "feature-wise") { 33 | # Permute features 34 | permutes[[ins]] <- apply(ct, 2, sample) 35 | } else if (permutation_option[1] == "sample-wise") { 36 | # Permute samples 37 | permutes[[ins]] <- t(apply(ct, 1, sample)) 38 | } else { 39 | stop("Invalid permutation option. Choose either 'feature-wise' or 'sample-wise'.") 40 | } 41 | } 42 | object@permutes <- permutes 43 | return(object) 44 | } 45 | 46 | updatePermutes.propd <- function(object, p) { 47 | message("Alert: Fixing permutations to active random seed.") 48 | ct <- object@counts 49 | permutes <- as.data.frame(matrix(0, nrow = nrow(ct), ncol = p)) 50 | for (col in 1:p){ 51 | permutes[, col] <- sample(1:nrow(ct)) 52 | } 53 | object@permutes <- permutes 54 | return(object) 55 | } 56 | -------------------------------------------------------------------------------- /man/aldex2propr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/4-aldex2propr.R 3 | \name{aldex2propr} 4 | \alias{aldex2propr} 5 | \title{Import \code{ALDEx2} Object} 6 | \usage{ 7 | aldex2propr(aldex.clr, how = "rho", select) 8 | } 9 | \arguments{ 10 | \item{aldex.clr}{An \code{aldex.clr} object.} 11 | 12 | \item{how}{A character string. The proportionality metric 13 | used to build the \code{propr} object. Choose from 14 | "rho", "phi", or "phs".} 15 | 16 | \item{select}{Optional. Use this to subset the final 17 | proportionality matrix without altering the result.} 18 | } 19 | \value{ 20 | Returns a \code{propr} object. 21 | } 22 | \description{ 23 | This method constructs a \code{propr} object from an 24 | \code{aldex.clr} object. See Details. 25 | } 26 | \details{ 27 | The \code{ALDEx2} package has two exceptional features useful 28 | in proportionality analysis too. First, \code{ALDEx2} offers 29 | a number of extra log-ratio transformations, toggled 30 | by the \code{denom} argument in \code{aldex.clr}. Second, 31 | \code{ALDEx2} estimates per-feature technical variation 32 | within each sample using Monte-Carlo instances drawn 33 | from the Dirichlet distribution. 34 | 35 | The \code{aldex2propr} function takes advantage of both 36 | of these features by constructing a \code{propr} object 37 | directly from an \code{aldex.clr} object. When interpreting 38 | the resultant \code{propr} object, keep in mind that 39 | \code{ALDEx2} adds 0.5 to all \code{@counts} regardless 40 | of whether the counts contain any zeros. Otherwise, 41 | the \code{@logratio} slot contains the log-ratio 42 | transformed counts as averaged across all Monte Carlo 43 | instances. Likewise, the \code{@matrix} slot gets 44 | filled with the proportionality matrix as averaged 45 | across all Monte Carlo instances. 46 | 47 | The \code{select} argument subsets the feature matrix 48 | after log-ratio transformation but before calculating 49 | proportionality. This reduces the run-time and RAM 50 | overhead without impacting the final result. Removing 51 | lowly abundant features prior to log-ratio transformation 52 | could otherwise change the proportionality measure. 53 | } 54 | -------------------------------------------------------------------------------- /man/selectRatios.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/5-selectRatios.R 3 | \name{selectRatios} 4 | \alias{selectRatios} 5 | \title{Pairwise Ratio Selection} 6 | \usage{ 7 | selectRatios( 8 | counts, 9 | ndim = 3, 10 | nclust = 2 * round(sqrt(ncol(counts))), 11 | nsearch = 3, 12 | ndenom = 4 13 | ) 14 | } 15 | \arguments{ 16 | \item{counts}{A data.frame or matrix. A "count matrix" with 17 | subjects as rows and features as columns. Note that this matrix 18 | does not necessarily have to contain counts.} 19 | 20 | \item{ndim}{An integer. The number of ratios to find.} 21 | 22 | \item{nclust}{An integer. The number of clusters to build from the data.} 23 | 24 | \item{nsearch}{An integer. The number of clusters to search exhaustively.} 25 | 26 | \item{ndenom}{An integer. The number of best denominators to use 27 | when searching for the best numerators.} 28 | } 29 | \value{ 30 | A list of: (1) "best", the best ratios and the variance they explain, 31 | (2) "all", all ratios tested and the variance they explain, 32 | (3) "Z", the standardized data used by the constrained PCA, and 33 | (4) "Y", the final ratios used to constrain the PCA. 34 | } 35 | \description{ 36 | This function finds which feature ratios explain the most variance. 37 | This is a computationally expensive procedure that we approximate 38 | with the heuristic described below. 39 | } 40 | \details{ 41 | This function resembles the method described by Michael Greenacre 42 | in "Variable Selection in Compositional Data Analysis Using 43 | Pairwise Logratios", except that we have modified the method 44 | to use a heuristic that scales to high-dimensional data. 45 | 46 | For each ratio, the heuristic will search CLR-based clusters 47 | for the best denominator, and then will search ALR-based clusters 48 | for the best numerator. It does this by dividing the 49 | transformed data into \code{nclust} clusters, calculating 50 | \code{vegan::rda} on the geometric mean of each cluster, then 51 | searching the best clusters exhaustively. The \code{ndenom} 52 | argument toggles how many best denominators to use during the 53 | next step. This process is repeated \code{ndim} times, finding 54 | that number of ratios that explain the most variance. 55 | } 56 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPR-pcorbshrink.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | library(corpcor) 4 | 5 | # define data 6 | N <- 100 7 | a <- seq(from = 5, to = 15, length.out = N) 8 | b <- a * rnorm(N, mean = 1, sd = 0.1) 9 | c <- rnorm(N, mean = 10) 10 | d <- rnorm(N, mean = 10) 11 | e <- rep(10, N) 12 | X <- data.frame(a, b, c, d, e) 13 | for (i in 1:4){ 14 | X[sample(1:N, 10),i] <- 0 15 | } 16 | 17 | test_that("pcor.bshrink is correct when ivar is clr or alr",{ 18 | 19 | for (ivar in c("clr", "alr")){ 20 | 21 | # compute pcor manually 22 | ct <- simple_zero_replacement(X) 23 | out <- propr:::pcor.bshrink(ct, ivar) 24 | mat <- out$matrix 25 | lambda <- out$lambda 26 | 27 | # compute pcor 28 | pr <- propr(X, metric = "pcor.bshrink", ivar=ivar) 29 | 30 | # expect counts to have zeros replaced 31 | expect_true( 32 | all(pr@counts == ct) 33 | ) 34 | 35 | # NOTE that the data is not logratio transformed while computing pcor.bshrink 36 | # it is internally handled by covariance conversion. 37 | # so pr@logratio should be equal to pr@counts 38 | expect_true( 39 | all(pr@logratio == ct) 40 | ) 41 | 42 | # expect computed coefficients are equal 43 | expect_true( 44 | all(round(pr@matrix, 8) == round(mat, 8)) 45 | ) 46 | 47 | # expect same lambda 48 | expect_equal( 49 | pr@lambda, 50 | lambda 51 | ) 52 | 53 | # check dimensions are correct 54 | expect_equal(ncol(pr@matrix), 5) 55 | expect_equal(nrow(pr@matrix), 5) 56 | } 57 | 58 | }) 59 | 60 | test_that("test that pcor.bshrink gives error when ivar is NA", { 61 | expect_error( 62 | propr(X, metric = "pcor.bshrink", ivar=NA) 63 | ) 64 | }) 65 | 66 | test_that("pcor.bshrink with alr and clr are the same", { 67 | 68 | # compute pcor with alr 69 | pr_alr <- suppressWarnings(propr(X, metric = "pcor.bshrink", ivar='alr')) 70 | pcor_alr <- getMatrix(pr_alr)[1:4, 1:4] 71 | 72 | # compute pcor with clr 73 | pr_clr <- propr(X, metric = "pcor.bshrink", ivar="clr") 74 | pcor_clr <- getMatrix(pr_clr)[1:4, 1:4] 75 | 76 | # expect that the coefficients are the same 77 | expect_equal( 78 | round(pcor_alr, 8), 79 | round(pcor_clr, 8) 80 | ) 81 | 82 | }) 83 | -------------------------------------------------------------------------------- /R/1-propr-OOP.R: -------------------------------------------------------------------------------- 1 | #' @rdname propr 2 | #' @export 3 | setClass( 4 | "propr", 5 | slots = c( 6 | counts = "data.frame", 7 | alpha = "numeric", 8 | metric = "character", 9 | direct = "logical", 10 | has_meaningful_negative_values = "logical", 11 | permutation_option = "character", 12 | ivar = "ANY", 13 | lambda = "ANY", 14 | logratio = "data.frame", 15 | matrix = "matrix", 16 | pairs = "numeric", 17 | results = "data.frame", 18 | permutes = "list", 19 | fdr = "data.frame", 20 | tails = "character" 21 | ) 22 | ) 23 | 24 | #' @rdname propr 25 | #' @section Methods (by generic): 26 | #' \code{show:} Method to show \code{propr} object. 27 | #' @export 28 | setMethod("show", "propr", 29 | function(object) { 30 | cat( 31 | "Not weighted", 32 | "and", 33 | ifelse( 34 | is.na(object@alpha), 35 | "not alpha-transformed", 36 | "alpha-transformed" 37 | ), 38 | "\n" 39 | ) 40 | 41 | cat( 42 | "@counts summary:", 43 | nrow(object@counts), 44 | "subjects by", 45 | ncol(object@counts), 46 | "features\n" 47 | ) 48 | 49 | cat( 50 | "@logratio summary:", 51 | nrow(object@logratio), 52 | "subjects by", 53 | ncol(object@logratio), 54 | "features\n" 55 | ) 56 | 57 | cat( 58 | "@matrix summary:", 59 | nrow(object@matrix), 60 | "features by", 61 | ncol(object@matrix), 62 | "features\n" 63 | ) 64 | 65 | if (length(object@pairs) > 0 | 66 | nrow(object@matrix) == 0) { 67 | cat("@pairs summary:", length(object@pairs), "feature pairs\n") 68 | 69 | } else{ 70 | cat("@pairs summary: index with `[` method\n") 71 | } 72 | 73 | cat("@fdr summary:", 74 | ncol(object@permutes), "iterations\n") 75 | 76 | if (nrow(object@fdr) > 0) { 77 | print(object@fdr) 78 | } 79 | 80 | cat("See ?propr for object methods\n") 81 | }) 82 | -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-getResults-propr.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | # define data matrix 5 | set.seed(123) 6 | N <- 100 7 | a <- seq(from = 5, to = 15, length.out = N) 8 | b <- a * rnorm(N, mean = 1, sd = 0.1) 9 | c <- rnorm(N, mean = 10) 10 | d <- rnorm(N, mean = 10) 11 | e <- rep(10, N) 12 | X <- data.frame(a, b, c, d, e) 13 | 14 | test_that("test that getResults works as expected", { 15 | 16 | # get propr object 17 | pr <- propr(X, metric = "pcor.bshrink", p=10) 18 | 19 | # get results 20 | results <- getResults(pr) 21 | 22 | # check that the values are correct 23 | expect_equal(pr@results[,c(3:7)], results[,c(3:7)]) 24 | 25 | # check that the variable names are corretly replaced 26 | expect_equal(results[,1], colnames(X)[pr@results[,1]]) 27 | expect_equal(results[,2], colnames(X)[pr@results[,2]]) 28 | 29 | # check that the order of pairs are as expected 30 | ord <- list(c(2,1), c(3,1), c(3,2), c(4,1), c(4,2), c(4,3), c(5,1), c(5,2), c(5,3), c(5,4)) 31 | for (i in 1:10) { 32 | expect_equal(results[i,1], colnames(X)[ord[[i]][1]]) 33 | expect_equal(results[i,2], colnames(X)[ord[[i]][2]]) 34 | } 35 | }) 36 | 37 | test_that("test that getSignificantResultsFDR works as expected - pcor.bshrink", { 38 | 39 | # get propr object 40 | pr <- propr(X, metric = "pcor.bshrink", p=10) 41 | pr <- updateCutoffs(pr, number_of_cutoffs=10) 42 | 43 | # get expected results 44 | cutoff <- getCutoffFDR(pr, fdr = 0.05, window_size = 1) 45 | expected <- pr@results$propr[which(abs(pr@results$propr) >= cutoff)] 46 | 47 | # get significant results 48 | results <- getSignificantResultsFDR(pr, fdr = 0.05) 49 | 50 | # check that the values are correct 51 | expect_equal(results$propr, expected) 52 | }) 53 | 54 | test_that("test that getSignificantResultsFDR works as expected - rho", { 55 | 56 | # get propr object 57 | pr <- propr(X, metric = "rho", p=10) 58 | pr <- updateCutoffs(pr, number_of_cutoffs=10) 59 | 60 | # get expected results 61 | cutoff <- getCutoffFDR(pr, fdr = 0.05, window_size = 1) 62 | expected <- pr@results$propr[which(pr@results$propr >= cutoff)] 63 | 64 | # get significant results 65 | results <- getSignificantResultsFDR(pr, fdr = 0.05) 66 | 67 | # check that the values are correct 68 | expect_equal(results$propr, expected) 69 | }) -------------------------------------------------------------------------------- /R/3-shared-getMatrix.R: -------------------------------------------------------------------------------- 1 | #' Get Matrix from Object 2 | #' 3 | #' This function provides a unified wrapper to retrieve a matrix 4 | #' of \code{propr} or \code{propd} values. 5 | #' 6 | #' @inheritParams getResults 7 | #' 8 | #' @return A matrix. 9 | #' 10 | #' @export 11 | getMatrix <- function(object) { 12 | 13 | if(class(object) == "propr"){ 14 | mat <- object@matrix 15 | 16 | }else if(class(object) == "propd"){ 17 | mat <- results_to_matrix(object@results, features=colnames(object@counts)) 18 | 19 | }else{ 20 | stop("Provided 'object' not recognized.") 21 | } 22 | 23 | return(mat) 24 | } 25 | 26 | #' Get Matrix from Results 27 | #' 28 | #' This function converts the results data frame into a matrix. 29 | #' 30 | #' @param results A \code{data.frame} of results. 31 | #' @param what A character string. The column name of the results data frame to be converted into a matrix. 32 | #' @param features A vector of features. Default is NULL. 33 | #' 34 | #' @return A matrix. 35 | #' 36 | #' @export 37 | results_to_matrix <- function(results, what='theta', features = NULL) { 38 | 39 | # if pair and partner are already named 40 | if (!is.numeric(results$Pair) && !is.numeric(results$Partner)) { 41 | if (is.null(features)) { 42 | features <- unique(c(results$Pair, results$Partner)) 43 | } 44 | nfeatures <- length(features) 45 | pair <- match(results$Pair, features) 46 | partner <- match(results$Partner, features) 47 | if (any(is.na(pair)) || any(is.na(partner))) { 48 | stop("Some features are not found in the results data frame.") 49 | } 50 | 51 | # if pair and partner are still indices 52 | } else { 53 | if (is.null(features)) { 54 | features <- sort(unique(c(results$Pair, results$Partner))) 55 | nfeatures <- max(features) 56 | } else { 57 | if (length(features) != max(results$Pair, results$Partner)) { 58 | stop("The length of 'features' does not match the number of features in the results data frame.") 59 | } 60 | nfeatures <- length(features) 61 | } 62 | pair <- results$Pair 63 | partner <- results$Partner 64 | } 65 | 66 | # convert the results data frame into a matrix 67 | mat <- vector2mat(results[,what], pair, partner, nfeatures) 68 | diag(mat) <- 0 69 | if (!is.numeric(features)) rownames(mat) <- colnames(mat) <- features 70 | 71 | return(mat) 72 | } -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-updatepermutes.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | 5 | test_that("propr - test that permute stay the same only when seed is given",{ 6 | 7 | # define data matrix 8 | N <- 100 9 | a <- seq(from = 5, to = 15, length.out = N) 10 | b <- a * rnorm(N, mean = 1, sd = 0.1) 11 | c <- rnorm(N, mean = 10) 12 | d <- rnorm(N, mean = 10) 13 | e <- rep(10, N) 14 | X <- data.frame(a, b, c, d, e) 15 | 16 | # test when seed is given 17 | set.seed(0) 18 | pr1 <- propr(X, metric = "pcor.bshrink", p=10) 19 | set.seed(0) 20 | pr2 <- propr(X, metric = "pcor.bshrink", p=10) 21 | expect_equal( 22 | pr1@permutes, 23 | pr2@permutes 24 | ) 25 | 26 | # test when seed is not given 27 | pr1 <- propr(X, metric = "pcor.bshrink", p=10) 28 | pr2 <- propr(X, metric = "pcor.bshrink", p=10) 29 | expect_false( 30 | isTRUE(all.equal( 31 | pr1@permutes, 32 | pr2@permutes 33 | )) 34 | ) 35 | }) 36 | 37 | test_that("propd - test that permute stay the same only when seed is given",{ 38 | 39 | # define data 40 | x <- iris[,1:4] # data matrix with 4 variables 41 | y <- iris[,5] # group vector 42 | v <- vegan::rda(log(x[,1]/x[,2]) ~ y) 43 | 44 | # test when seed is given 45 | set.seed(0) 46 | pd1 <- propd(x, as.character(y), p=10) 47 | set.seed(0) 48 | pd2 <- propd(x, as.character(y), p=10) 49 | expect_equal( 50 | pd1@permutes, 51 | pd2@permutes 52 | ) 53 | 54 | # test when seed is not given 55 | pd1 <- propd(x, as.character(y), p=10) 56 | pd2 <- propd(x, as.character(y), p=10) 57 | expect_false( 58 | isTRUE(all.equal( 59 | pd1@permutes, 60 | pd2@permutes 61 | )) 62 | ) 63 | }) 64 | 65 | test_that("propr - test that permute conserves gene-wise or sample-wise totals", { 66 | # define data matrix 67 | N <- 100 68 | a <- seq(from = 5, to = 15, length.out = N) 69 | b <- a * rnorm(N, mean = 1, sd = 0.1) 70 | c <- rnorm(N, mean = 10) 71 | d <- rnorm(N, mean = 10) 72 | e <- rep(10, N) 73 | X <- data.frame(a, b, c, d, e) 74 | 75 | # test feature-wise permutation 76 | set.seed(0) 77 | pr1 <- propr(X, metric = "pcor.bshrink", p=10, permutation_option = "feature-wise") 78 | expect_equal( 79 | as.vector(colSums(pr1@permutes[[1]])), 80 | as.vector(colSums(X)) 81 | ) 82 | 83 | # test sample-wise permutation 84 | set.seed(0) 85 | pr2 <- propr(X, metric = "pcor.bshrink", p=10, permutation_option = "sample-wise") 86 | expect_equal( 87 | as.vector(rowSums(pr2@permutes[[1]])), 88 | as.vector(rowSums(X)) 89 | ) 90 | }) 91 | -------------------------------------------------------------------------------- /old_tests/testthat/test-aldex2propr.R: -------------------------------------------------------------------------------- 1 | if(requireNamespace("ALDEx2", quietly = TRUE) & 2 | requireNamespace("Biobase", quietly = TRUE)){ 3 | 4 | if(as.numeric(gsub("\\.", "", packageVersion("ALDEx2"))) >= 1101){ 5 | 6 | library(propr) 7 | library(ALDEx2) 8 | 9 | data(mail) 10 | x <- aldex.clr(as.data.frame(t(mail)), conds = rep("A", 5)) 11 | y <- aldex.clr(as.data.frame(t(mail)), conds = rep("A", 5), denom = 2) 12 | 13 | data(marg.abs) 14 | z <- ALDEx2:::iqlr.features(t(marg.abs[, 1:50]), conds = rep("A", 16)) 15 | 16 | propr.phisym <- function (X){ 17 | 18 | Cov <- stats::var(X) 19 | tmp <- 2 * Cov / outer(diag(Cov), diag(Cov), "+") 20 | return((1-tmp)/(1+tmp)) 21 | } 22 | 23 | codaSeq.phi <- function(aldex.clr){ 24 | 25 | sym.phi <- propr.phisym(t(sapply(getMonteCarloInstances(aldex.clr), 26 | function(y){y[,1]}))) 27 | 28 | for(i in 2:numMCInstances(aldex.clr)){ 29 | sym.phi <- sym.phi + propr.phisym(t(sapply(getMonteCarloInstances(aldex.clr), 30 | function(y){y[,i]}))) 31 | } 32 | 33 | lt <- which(col(sym.phi) df$lrm1[i]) { 32 | lr[, i] <- -1 * lr[, i] 33 | colnames(lr)[i] <- switchRatio(colnames(lr)[i]) 34 | } 35 | } 36 | } 37 | 38 | return(lr) 39 | } 40 | 41 | #' Recast Matrix as Feature (Log-)Ratios 42 | #' 43 | #' The \code{ratios} function recasts a matrix with N feature columns 44 | #' as a new matrix with N * (N - 1) / 2 feature (log-)ratio columns. 45 | #' 46 | #' When the \code{alpha} argument is provided, this function returns 47 | #' the (log-)ratios as \code{(partner^alpha - pair^alpha) / alpha}. 48 | #' 49 | #' @param matrix A matrix. The data to recast. 50 | #' @param alpha A double. See vignette for details. Leave missing 51 | #' to skip Box-Cox transformation. 52 | #' 53 | #' @return A matrix of (log-)ratios. 54 | #' 55 | #' @export 56 | ratios <- function(matrix, alpha = NA) { 57 | lab <- labRcpp(ncol(matrix)) 58 | 59 | # Replace count zeros if appropriate 60 | if (any(as.matrix(matrix) == 0) & is.na(alpha)) { 61 | matrix <- simple_zero_replacement(matrix) 62 | } 63 | 64 | # Get (log-)ratios [based on alpha] 65 | if (is.na(alpha)) { 66 | ratios <- log(matrix[, lab$Partner] / matrix[, lab$Pair]) 67 | } else{ 68 | message("Alert: Using alpha transformation to approximate log-ratios.") 69 | ratios <- 70 | (matrix[, lab$Partner] ^ alpha - matrix[, lab$Pair] ^ alpha) / alpha 71 | } 72 | 73 | # Name columns 74 | if (!is.null(colnames(matrix))) { 75 | colnames(ratios) <- 76 | paste0(colnames(matrix)[lab$Partner], 77 | "/", colnames(matrix)[lab$Pair]) 78 | } 79 | 80 | return(ratios) 81 | } 82 | -------------------------------------------------------------------------------- /R/9-global.R: -------------------------------------------------------------------------------- 1 | #' Example Absolute mRNA 2 | #' 3 | #' Data generated with supplemental script provided by 4 | #' . Data originally 5 | #' sourced from . 6 | #' A time series of yeast mRNA abundance after removal 7 | #' of a key nutrient. Absolute abundance estimated 8 | #' by multiplying microarray signal (relative to first 9 | #' time point) by the initial nCounter-calibrated and 10 | #' copy-per-cell-adjusted RNA-seq abundance (averaged 11 | #' across two replicates). Divide absolute abundances 12 | #' by total sample abundance to make data relative. 13 | #' 14 | #' @usage data(marg.abs) 15 | "marg.abs" 16 | 17 | #' Ensure Matrix Has Dim Names 18 | #' 19 | #' Makes sure input data has correct format. For back-end use only. 20 | #' 21 | #' @param counts A data matrix representing counts. 22 | #' @return A matrix with dim names. 23 | as_safe_matrix <- 24 | function(counts) { 25 | if ("data.frame" %in% class(counts)) 26 | counts <- as.matrix(counts) 27 | if (is.null(colnames(counts))) 28 | colnames(counts) <- as.character(1:ncol(counts)) 29 | if (is.null(rownames(counts))) 30 | rownames(counts) <- as.character(1:nrow(counts)) 31 | if (any(is.na(counts))) 32 | stop("Remove NAs from 'counts' before proceeding.") 33 | return(counts) 34 | } 35 | 36 | #' Make Progress Bar 37 | #' 38 | #' Makes a progress bar. For back-end use only. 39 | #' 40 | #' @param i The current iteration. 41 | #' @param k Total iterations. 42 | #' @param numTicks The result of \code{progress}. 43 | #' @return The next \code{numTicks} argument. 44 | progress <- function(i, k, numTicks) { 45 | if (i == 1) 46 | numTicks <- 0 47 | 48 | if (numTicks == 0) 49 | cat("|-") 50 | 51 | while (i > numTicks * (k / 40)) { 52 | cat("-") 53 | if (numTicks == 10) 54 | cat("(25%)") 55 | if (numTicks == 20) 56 | cat("(50%)") 57 | if (numTicks == 30) 58 | cat("(75%)") 59 | numTicks <- numTicks + 1 60 | } 61 | 62 | if (i == k) 63 | cat("-|\n") 64 | 65 | return(numTicks) 66 | } 67 | 68 | #' Package Check 69 | #' 70 | #' Checks whether the user has the required package installed. 71 | #' For back-end use only. 72 | #' 73 | #' @param package A character string. An R package. 74 | #' @return Returns TRUE if no error. 75 | packageCheck <- function(package) { 76 | if (!requireNamespace(package, quietly = TRUE)) { 77 | stop( 78 | "Uh oh! This method depends on ", 79 | package, 80 | "! ", 81 | "\nTry running: install.packages('", 82 | package, 83 | "')", 84 | "\nor: BiocManager::install('", 85 | package, 86 | "')" 87 | ) 88 | } 89 | TRUE 90 | } 91 | -------------------------------------------------------------------------------- /man/updateCutoffs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/3-shared-updateCutoffs.R 3 | \name{updateCutoffs} 4 | \alias{updateCutoffs} 5 | \alias{updateCutoffs.propr} 6 | \alias{updateCutoffs.propd} 7 | \title{Update FDR by Permutation} 8 | \usage{ 9 | updateCutoffs( 10 | object, 11 | number_of_cutoffs = 100, 12 | custom_cutoffs = NA, 13 | tails = "right", 14 | ncores = 1 15 | ) 16 | 17 | updateCutoffs.propr( 18 | object, 19 | number_of_cutoffs = 100, 20 | custom_cutoffs = NA, 21 | tails = "right", 22 | ncores = 1 23 | ) 24 | 25 | updateCutoffs.propd( 26 | object, 27 | number_of_cutoffs = 100, 28 | custom_cutoffs = NA, 29 | ncores = 1 30 | ) 31 | } 32 | \arguments{ 33 | \item{object}{A \code{propr} or \code{propd} object.} 34 | 35 | \item{number_of_cutoffs}{An integer. The number of cutoffs to test. Given this number, 36 | the cutoffs will be determined based on the quantile of the data. In this way, the 37 | cutoffs will be evenly spaced across the data.} 38 | 39 | \item{custom_cutoffs}{A numeric vector. When provided, this vector is used as the set of 40 | cutoffs to test, and 'number_of_cutoffs' is ignored.} 41 | 42 | \item{tails}{'right' or 'both'. 'right' is for one-sided on the right. 'both' for 43 | symmetric two-sided test. This is only relevant for \code{propr} objects, as 44 | \code{propd} objects are always one-sided and only have positive values. Default 45 | is 'right'.} 46 | 47 | \item{ncores}{An integer. The number of parallel cores to use.} 48 | } 49 | \value{ 50 | A \code{propr} or \code{propd} object with the FDR slot updated. 51 | } 52 | \description{ 53 | This function updates the FDR for each cutoff. By default, the set of cutoffs are determined 54 | based on the quantile of the data, so that the cutoffs are evenly spaced across the data. 55 | The FDR is calculated as the ratio between the number of permuted values beyond the cutoff 56 | and the number of true values beyond the the cutoff. 57 | When tails is set to 'right', the FDR is calculated only on the positive side of the data. 58 | When tails is set to 'both', the FDR is calculated on both sides of the data. 59 | } 60 | \section{Methods}{ 61 | 62 | \code{updateCutoffs.propr:} 63 | Use the \code{propr} object to permute correlation-like metrics 64 | (ie. rho, phi, phs, cor, pcor, pcor.shrink, pcor.bshrink), 65 | across a number of cutoffs. Since the permutations get saved 66 | when the object is created, calling \code{updateCutoffs} 67 | will use the same random seed each time. 68 | 69 | 70 | \code{updateCutoffs.propd:} 71 | Use the \code{propd} object to permute theta across a 72 | number of theta cutoffs. Since the permutations get saved 73 | when the object is created, calling \code{updateCutoffs} 74 | will use the same random seed each time. 75 | } 76 | 77 | -------------------------------------------------------------------------------- /src/lr2propr.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "backend.h" 4 | using namespace Rcpp; 5 | 6 | // Function for vlr 7 | // [[Rcpp::export]] 8 | NumericMatrix lr2vlr(NumericMatrix lr){ 9 | 10 | // Calculate variation matrix 11 | NumericMatrix x = clone(lr); 12 | NumericMatrix X = covRcpp(x, 0); 13 | int nfeats = lr.ncol(); 14 | 15 | // Find diagonal 16 | NumericVector diag(nfeats); 17 | for(int j = 0; j < nfeats; j++){ 18 | diag[j] = X(j, j); 19 | } 20 | 21 | // Calculate vlr 22 | for(int i = 0; i < nfeats; i++){ 23 | for(int j = 0; j < nfeats; j++){ 24 | X(i, j) = -2 * X(i, j) + diag[i] + diag[j]; 25 | } 26 | } 27 | 28 | return X; 29 | } 30 | 31 | // Function for phi 32 | // [[Rcpp::export]] 33 | NumericMatrix lr2phi(NumericMatrix lr){ 34 | 35 | // Make vlr from log-ratio data 36 | NumericMatrix x = clone(lr); 37 | NumericMatrix mat = lr2vlr(x); 38 | int nsubjs = lr.nrow(); 39 | 40 | // Calculate phi = vlr[i, j] / var[, i] 41 | for(int i = 0; i < mat.ncol(); i++){ 42 | 43 | double vari = sum(pow(lr(_, i) - mean(lr(_, i)), 2.0)) / (nsubjs - 1); 44 | mat(_, i) = mat(_, i) / vari; 45 | mat(i, i) = 0; // Force diagonal = 0 46 | } 47 | 48 | return mat; 49 | } 50 | 51 | // Function for rho 52 | // [[Rcpp::export]] 53 | NumericMatrix lr2rho(NumericMatrix lr){ 54 | 55 | // Make vlr from log-ratio data 56 | NumericMatrix x = clone(lr); 57 | NumericMatrix mat = lr2vlr(x); 58 | int nsubjs = lr.nrow(); 59 | int nfeats = lr.ncol(); 60 | 61 | // Calculate variance of the i-th lr composition 62 | NumericVector vars(nfeats); 63 | for(int i = 0; i < nfeats; i++){ 64 | 65 | vars[i] = sum(pow(lr(_, i) - mean(lr(_, i)), 2.0)) / (nsubjs - 1); 66 | } 67 | 68 | // Calculate rho = 1 - vlr[i, j] / (var[, i] + var[, j]) 69 | for(int i = 0; i < nfeats; i++){ 70 | for(int j = 0; j < nfeats; j++){ 71 | 72 | if(i == j){ 73 | mat(i, j) = 1; // Force diagonal = 1 74 | }else{ 75 | mat(i, j) = 1 - mat(i, j) / (vars[i] + vars[j]); 76 | } 77 | } 78 | } 79 | 80 | return mat; 81 | } 82 | 83 | // Function for phs 84 | // [[Rcpp::export]] 85 | NumericMatrix lr2phs(NumericMatrix lr){ 86 | 87 | // Calculate phs = (1 - rho) / (1 + rho) 88 | NumericMatrix mat = lr2rho(lr); 89 | int nfeats = mat.ncol(); 90 | for(int i = 0; i < nfeats; i++){ 91 | for(int j = 0; j < nfeats; j++){ 92 | 93 | if(i == j){ 94 | mat(i, j) = 0; // Force diagonal = 0 95 | }else{ 96 | if(mat(i, j) == 0){ 97 | mat(i, j) = R_PosInf; 98 | }else{ 99 | mat(i, j) = (1 - mat(i, j)) / (1 + mat(i, j)); 100 | } 101 | } 102 | } 103 | } 104 | 105 | return(mat); 106 | } 107 | -------------------------------------------------------------------------------- /R/3-shared-getAdjacency.R: -------------------------------------------------------------------------------- 1 | #' Get Adjacency Matrix as indicated by permutation tests. 2 | #' 3 | #' This function gets the significant pairs according to the permutation tests. Then it fills 4 | #' the adjacency matrix with 1 if pair is significant, otherwise 0. The significance is determined 5 | #' by the cutoff value for which the false discovery rate (FDR) is less or equal than the given 6 | #' value 'fdr'. The significant pairs are those that have a value greater/less or equal than the 7 | #' cutoff, depending on the metric. 8 | #' 9 | #' @param object A \code{propd} or \code{propr} object. 10 | #' @param fdr A float value for the false discovery rate. Default is 0.05. 11 | #' @param window_size An integer. Default is 1. When it is greater than 1, the FDR 12 | #' values would be smoothed out by a moving average of the given window size. 13 | #' @return An adjacency matrix. 14 | #' 15 | #' @export 16 | getAdjacencyFDR <- 17 | function(object, fdr = 0.05, window_size = 1) { 18 | 19 | # get matrix 20 | mat <- getMatrix(object) 21 | 22 | # set up some parameters 23 | direct <- FALSE 24 | if (inherits(object, "propr")) { 25 | if (object@tails == 'both') mat <- abs(mat) 26 | direct <- object@direct 27 | } 28 | 29 | # create empty matrix 30 | adj <- matrix(0, nrow = nrow(mat), ncol = ncol(mat)) 31 | rownames(adj) <- rownames(mat) 32 | colnames(adj) <- colnames(mat) 33 | 34 | # get cutoff 35 | cutoff <- getCutoffFDR(object, fdr=fdr, window_size=window_size) 36 | 37 | # fill in significant pairs 38 | if (cutoff) { 39 | if (direct) { 40 | adj[mat >= cutoff] <- 1 41 | } else { 42 | adj[mat <= cutoff] <- 1 43 | } 44 | } 45 | 46 | return(adj) 47 | } 48 | 49 | #' Get Adjacency Matrix as indicated by F-statistics 50 | #' 51 | #' This function gets the significant pairs, according to the F-statistics. 52 | #' Then it fills the adjacency matrix with 1 if pair is significant, otherwise 0. 53 | #' Note that it can only be applied to theta_d, as updateF only works for theta_d. 54 | #' 55 | #' @param object A \code{propd} or \code{propr} object. 56 | #' @param pval A float value for the p-value. Default is 0.05. 57 | #' @param fdr_adjusted A boolean. If TRUE, use the the FDR- adjusted p-values. 58 | #' Otherwise, get significant pairs based on the theoretical F-statistic cutoff. 59 | #' @return An adjacency matrix. 60 | #' 61 | #' @export 62 | getAdjacencyFstat <- 63 | function(object, pval = 0.05, fdr_adjusted = TRUE) { 64 | 65 | # get matrix 66 | mat <- getMatrix(object) 67 | 68 | # create empty adjacency matrix 69 | adj <- matrix(0, nrow = nrow(mat), ncol = ncol(mat)) 70 | rownames(adj) <- rownames(mat) 71 | colnames(adj) <- colnames(mat) 72 | 73 | # fill in significant pairs 74 | cutoff <- getCutoffFstat(object, pval, fdr_adjusted = fdr_adjusted) 75 | if (cutoff) adj[mat <= cutoff] <- 1 76 | 77 | return(adj) 78 | } 79 | -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-getAdjacency-propd.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | library(MASS) 4 | 5 | # define data 6 | data(crabs) 7 | x <- crabs[,4:8] # data matrix with 5 variables 8 | y <- crabs[,1] # group vector 9 | 10 | test_that("getAdjacencyFDR works properly for theta", { 11 | 12 | # get propd object 13 | pr <- propd(x, as.character(y), p=10) 14 | pr <- updateCutoffs(pr, number_of_cutoffs=10) 15 | 16 | # get adjacency matrix 17 | adj <- getAdjacencyFDR(pr) 18 | 19 | # get expected adjacency matrix 20 | adj_expected <- matrix(0, nrow = ncol(x), ncol = ncol(x)) 21 | adj_expected[propr:::getMatrix(pr) <= getCutoffFDR(pr)] <- 1 22 | adj_expected[diag(adj_expected)] <- 1 23 | rownames(adj_expected) <- colnames(x) 24 | colnames(adj_expected) <- colnames(x) 25 | 26 | # check that the values are correct 27 | expect_equal(adj, adj_expected) 28 | }) 29 | 30 | test_that("getAdjacencyFDR and getSignificantResultsFDR return coherent results", { 31 | 32 | # get propd object 33 | pr <- propd(x, as.character(y), p=10) 34 | pr <- updateCutoffs(pr, number_of_cutoffs=10) 35 | 36 | # get adjacency matrix 37 | adj <- getAdjacencyFDR(pr) 38 | 39 | # get significant results 40 | results <- getSignificantResultsFDR(pr) 41 | 42 | # check that the values are correct 43 | for (i in 1:nrow(results)){ 44 | expect_equal(adj[results[i,1], results[i,2]], 1) 45 | } 46 | }) 47 | 48 | test_that("getAdjacencyFstat works properly", { 49 | 50 | for (fdr_adjusted in c(TRUE, FALSE)){ 51 | 52 | # get propd object 53 | pr <- propd(x, as.character(y), p=10) 54 | pr <- updateF(pr, moderated=F) 55 | 56 | # get adjacency matrix 57 | adj <- getAdjacencyFstat(pr, fdr_adjusted=fdr_adjusted) 58 | 59 | # get expected adjacency matrix 60 | adj_expected <- matrix(0, nrow = ncol(x), ncol = ncol(x)) 61 | adj_expected[propr:::getMatrix(pr) <= getCutoffFstat(pr, fdr_adjusted=fdr_adjusted)] <- 1 62 | adj_expected[diag(adj_expected)] <- 1 63 | rownames(adj_expected) <- colnames(x) 64 | colnames(adj_expected) <- colnames(x) 65 | 66 | # check that the values are correct 67 | expect_equal(adj, adj_expected) 68 | } 69 | }) 70 | 71 | test_that("getAdjacencyFstat and getSignificantResultsFstat return coherent results", { 72 | 73 | for (fdr in c(TRUE, FALSE)){ 74 | 75 | # get propd object 76 | pr <- propd(x, as.character(y), p=10) 77 | pr <- updateF(pr, moderated=F) 78 | 79 | # get adjacency matrix 80 | adj <- getAdjacencyFstat(pr, fdr=fdr) 81 | 82 | # get significant results 83 | results <- getSignificantResultsFstat(pr, fdr=fdr) 84 | 85 | # check that the values are correct 86 | for (i in 1:nrow(results)){ 87 | expect_equal(adj[results[i,1], results[i,2]], 1) 88 | } 89 | } 90 | }) 91 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPR-pcor.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | # define data 5 | N <- 100 6 | a <- seq(from = 5, to = 15, length.out = N) 7 | b <- a * rnorm(N, mean = 1, sd = 0.1) 8 | c <- rnorm(N, mean = 10) 9 | d <- rnorm(N, mean = 10) 10 | e <- rep(10, N) 11 | X <- data.frame(a, b, c, d, e) 12 | for (i in 1:4){ 13 | X[sample(1:N, 10),i] <- 0 14 | } 15 | 16 | test_that("pcor is correct when ivar is given", { 17 | 18 | d1 <- list("clr", 5, c(1,3)) 19 | d2 <- list(c(1:5), 5, c(1,3)) 20 | 21 | for (i in 1:length(d1)){ 22 | 23 | # compute pcor manually 24 | ct <- simple_zero_replacement(X) 25 | lr <- logratio_without_alpha(ct, d2[[i]]) 26 | cov <- cov(lr) 27 | mat <- suppressWarnings(corpcor::cor2pcor(cov)) 28 | 29 | # compute pcor 30 | pr <- suppressWarnings(propr(X, metric = "pcor", ivar=d1[[i]])) 31 | 32 | # expect counts to have zeros replaced 33 | expect_true( 34 | all(pr@counts == ct) 35 | ) 36 | 37 | # expect that logratio are equal 38 | expect_true( 39 | all(pr@logratio == lr) 40 | ) 41 | 42 | # expect computed coefficients are equal 43 | expect_true( 44 | all(round(pr@matrix, 8) == round(mat, 8), na.rm=T) 45 | ) 46 | 47 | # check shrinkage is not applied 48 | expect_equal( 49 | pr@lambda, 50 | NULL 51 | ) 52 | } 53 | }) 54 | 55 | 56 | test_that("pcor is correct when ivar is NA using previously transformed data", { 57 | 58 | d1 <- list("clr", 5, c(1,3)) 59 | d2 <- list(c(1:5), 5, c(1,3)) 60 | 61 | for (i in 1:length(d1)){ 62 | 63 | # compute pcor manually 64 | ct <- simple_zero_replacement(X) 65 | lr <- logratio_without_alpha(ct, d2[[i]]) 66 | cov <- cov(lr) 67 | mat <- suppressWarnings(corpcor::cor2pcor(cov)) 68 | 69 | # compute pcor 70 | pr <- suppressWarnings(propr(lr, metric = "pcor", ivar=NA)) 71 | 72 | # expect counts to contain the previously transformed data 73 | expect_true( 74 | all(pr@counts == lr) 75 | ) 76 | 77 | # expect that the logratio slot also contains the exact input data 78 | expect_true( 79 | all(pr@logratio == lr) 80 | ) 81 | 82 | # expect computed coefficients are equal 83 | expect_true( 84 | all(round(pr@matrix, 8) == round(mat, 8), na.rm=T) 85 | ) 86 | 87 | # check shrinkage is not applied 88 | expect_equal( 89 | pr@lambda, 90 | NULL 91 | ) 92 | } 93 | }) 94 | 95 | test_that("pcor with alr and clr are the same", { 96 | 97 | # compute pcor with alr 98 | pr <- suppressWarnings(propr(X, metric = "pcor", ivar=5)) 99 | pcor_alr <- getMatrix(pr)[1:4, 1:4] 100 | 101 | # compute pcor with clr 102 | pr <- propr(X, metric = "pcor", ivar="clr") 103 | pcor_clr <- getMatrix(pr)[1:4, 1:4] 104 | 105 | expect_equal( 106 | round(pcor_alr, 8), 107 | round(pcor_clr, 8) 108 | ) 109 | 110 | }) 111 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPD-theta.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | test_that("3-group RDA agrees with theta", { 5 | 6 | # RDA with 3 groups 7 | x <- iris[,1:4] 8 | y <- iris[,5] 9 | v <- vegan::rda(log(x[,1]/x[,2]) ~ y) 10 | pd <- propd(x, as.character(y)) 11 | 12 | expect_equal( 13 | 1 - sum(v$CCA$eig) / v$tot.chi, 14 | pd@results[1,"theta"] 15 | ) 16 | }) 17 | 18 | 19 | test_that("2-group RDA agrees with theta", { 20 | 21 | # RDA with 2 groups 22 | x <- iris[1:100,1:4] 23 | y <- iris[1:100,5] 24 | v <- vegan::rda(log(x[,1]/x[,2]) ~ y) 25 | pd <- propd(x, as.character(y)) 26 | 27 | expect_equal( 28 | 1 - sum(v$CCA$eig) / v$tot.chi, 29 | pd@results[1,"theta"] 30 | ) 31 | }) 32 | 33 | 34 | # data 35 | keep <- iris$Species %in% c("setosa", "versicolor") 36 | counts <- iris[keep, 1:4] * 10 37 | group <- ifelse(iris[keep, "Species"] == "setosa", "A", "B") 38 | 39 | # calculate propd 40 | pd <- propd(counts, group, p = 5) 41 | pd_w <- propd(counts, group, p = 5, weighted = TRUE) 42 | 43 | test_that("active theta_e matches calculation using theta_d", { 44 | 45 | n1 <- 50 46 | n2 <- 50 47 | 48 | expect_equal( 49 | setActive(pd, what = "theta_e")@results$theta, 50 | 1 - pd@results$theta + pmin((n1-1) * pd@results$lrv1, (n2-1) * pd@results$lrv2) / ((n1+n2-1) * pd@results$lrv) 51 | ) 52 | 53 | # when weighted 54 | groups <- lapply(unique(group), function(g) g == group) 55 | ngrp <- length(unique(group)) 56 | # calculate weights, now according to sample reliability weights from limma 57 | design <- 58 | stats::model.matrix(~ . + 0, data = as.data.frame(group)) 59 | 60 | logX <- log(pd@counts) 61 | z.geo <- rowMeans(logX) 62 | z.lr <- as.matrix(sweep(logX, 1, z.geo, "-")) 63 | lz.sr <- t(z.lr + mean(z.geo)) #corresponds to log(z.sr) in updateF function 64 | 65 | #use quality weights from limma: 66 | aw <- limma::arrayWeights(lz.sr, design) 67 | W <- t(sweep(matrix(1, nrow(lz.sr), ncol(lz.sr)), 2, aw, `*`)) #get the correct dimensions 68 | 69 | ps <- lapply(groups, function(g) propr:::omega(W[g,])) 70 | names(ps) <- paste0("p", 1:ngrp) 71 | p <- propr:::omega(W) 72 | expect_equal( 73 | setActive(pd_w, what = "theta_e")@results$theta, 74 | 1 - pd_w@results$theta + pmin(ps[[1]] * pd_w@results$lrv1, ps[[2]] * pd_w@results$lrv2) / (p * pd_w@results$lrv) 75 | ) 76 | }) 77 | 78 | test_that("active theta_f matches calculation using theta_e", { 79 | 80 | expect_equal( 81 | setActive(pd, what = "theta_f")@results$theta, 82 | 1 - setActive(pd, what = "theta_e")@results$theta 83 | ) 84 | 85 | expect_equal( 86 | setActive(pd_w, what = "theta_f")@results$theta, 87 | 1 - setActive(pd_w, what = "theta_e")@results$theta 88 | ) 89 | }) 90 | 91 | test_that("running propd with shrinkage works", { 92 | pd <- propd(counts, group, p = 5, shrink = TRUE) 93 | 94 | # Check that pd is an S4 object and has a "results" slot 95 | expect_true(isS4(pd)) 96 | expect_true("results" %in% slotNames(pd)) 97 | }) 98 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPD-updateF.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | library(MASS) 4 | library(digest) 5 | 6 | # define data 7 | data(crabs) 8 | x <- crabs[,4:8] # data matrix with 5 variables 9 | y <- crabs[,1] # group vector 10 | 11 | test_that("updateF correctly calculates F-statistics without moderation", { 12 | 13 | # Create propd object 14 | pr <- propd(x, as.character(y), p=10) 15 | 16 | # Update F without moderation 17 | pr_f <- updateF(pr, moderated = FALSE) 18 | 19 | # Manual calculation of F-statistic 20 | N <- length(pr@group) 21 | K <- length(unique(pr@group)) 22 | expected_fstat <- (N - 2) * (1 - pr@results$theta) / pr@results$theta 23 | 24 | # Check F-statistics match 25 | expect_equal(pr_f@results$Fstat, expected_fstat) 26 | 27 | # Check that theta_mod is NA for non-moderated 28 | expect_true(all(is.na(pr_f@results$theta_mod))) 29 | 30 | # Check p-values are calculated 31 | expect_true("Pval" %in% colnames(pr_f@results)) 32 | expect_true("FDR" %in% colnames(pr_f@results)) 33 | expect_true(all(pr_f@results$Pval >= 0 & pr_f@results$Pval <= 1)) 34 | }) 35 | 36 | test_that("updateF correctly calculates F-statistics with moderation", { 37 | 38 | # Create propd object 39 | pr <- propd(x, as.character(y), p=10) 40 | 41 | # Update F with moderation 42 | pr_f_mod <- updateF(pr, moderated = TRUE) 43 | 44 | # Check that F-statistics are calculated 45 | expect_true("Fstat" %in% colnames(pr_f_mod@results)) 46 | 47 | # Check that theta_mod is calculated 48 | expect_true("theta_mod" %in% colnames(pr_f_mod@results)) 49 | expect_true(all(!is.na(pr_f_mod@results$theta_mod))) 50 | 51 | # Check p-values are calculated 52 | expect_true("Pval" %in% colnames(pr_f_mod@results)) 53 | expect_true("FDR" %in% colnames(pr_f_mod@results)) 54 | expect_true(all(pr_f_mod@results$Pval >= 0 & pr_f_mod@results$Pval <= 1)) 55 | 56 | # check snapshot values 57 | expect_equal( 58 | digest(round(pr_f_mod@results$theta_mod,4)), 59 | '24f6040126e5fa16fc6c99ffd9aa1959' 60 | ) 61 | }) 62 | 63 | test_that("updateF correctly calculates F-statistics with moderation and weighted", { 64 | 65 | # Create propd object 66 | pr <- propd(x, as.character(y), p=10, weighted = TRUE) 67 | 68 | # Update F with moderation 69 | pr_f_mod <- updateF(pr, moderated = TRUE) 70 | 71 | # Check that F-statistics are calculated 72 | expect_true("Fstat" %in% colnames(pr_f_mod@results)) 73 | 74 | # Check that theta_mod is calculated 75 | expect_true("theta_mod" %in% colnames(pr_f_mod@results)) 76 | expect_true(all(!is.na(pr_f_mod@results$theta_mod))) 77 | 78 | # Check p-values are calculated 79 | expect_true("Pval" %in% colnames(pr_f_mod@results)) 80 | expect_true("FDR" %in% colnames(pr_f_mod@results)) 81 | expect_true(all(pr_f_mod@results$Pval >= 0 & pr_f_mod@results$Pval <= 1)) 82 | 83 | # check snapshot values 84 | expect_equal( 85 | digest(round(pr_f_mod@results$theta_mod,4)), 86 | 'b89a1343290661cfab2249d506742d1e' 87 | ) 88 | }) -------------------------------------------------------------------------------- /tests/testthat/test-GET-getMatrix.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | test_that('get propd matrix work',{ 5 | 6 | # compute differential proportionality 7 | x <- iris[,1:4] # data matrix with 4 variables 8 | y <- iris[,5] # group vector 9 | pd <- propd(x, as.character(y)) 10 | pd <- updateF(pd, moderated=T) 11 | 12 | # get results 13 | results <- pd@results 14 | 15 | # get different theta matrices 16 | mat_theta <- getMatrix(pd) 17 | mat_theta_e <- getMatrix(setActive(pd, what='theta_e')) 18 | mat_theta_mod <- getMatrix(setActive(pd, what='theta_mod')) 19 | 20 | # check matrix is square and have 4 columns 21 | expect_equal(ncol(mat_theta), nrow(mat_theta)) 22 | expect_equal(ncol(mat_theta), 4) 23 | 24 | # check diagonal is zero 25 | expect_equal(mat_theta[1,1], 0) 26 | expect_equal(mat_theta[2,2], 0) 27 | 28 | # check matrix values are correct 29 | expect_equal( 30 | mat_theta[1,2], 31 | results[which(results$Partner==2 & results$Pair==1),'theta'] 32 | ) 33 | expect_equal( 34 | mat_theta[2,3], 35 | results[which(results$Partner==3 & results$Pair==2),'theta'] 36 | ) 37 | expect_equal( 38 | mat_theta_e[1,2], 39 | results[which(results$Partner==2 & results$Pair==1),'theta_e'] 40 | ) 41 | expect_equal( 42 | mat_theta_e[2,3], 43 | results[which(results$Partner==3 & results$Pair==2),'theta_e'] 44 | ) 45 | expect_equal( 46 | mat_theta_mod[1,2], 47 | results[which(results$Partner==2 & results$Pair==1),'theta_mod'] 48 | ) 49 | expect_equal( 50 | mat_theta_mod[2,3], 51 | results[which(results$Partner==3 & results$Pair==2),'theta_mod'] 52 | ) 53 | 54 | # check that theta are different from theta_e and theta_mod 55 | expect_false(all(mat_theta == mat_theta_e)) 56 | expect_false(all(mat_theta == mat_theta_mod)) 57 | }) 58 | 59 | test_that('get propr matrix work', { 60 | 61 | # create matrix and compute proportionality 62 | N <- 100 63 | a <- seq(from = 5, to = 15, length.out = N) 64 | b <- a * rnorm(N, mean = 1, sd = 0.1) 65 | c <- rnorm(N, mean = 10) 66 | d <- rnorm(N, mean = 10) 67 | e <- rep(10, N) 68 | X <- data.frame(a, b, c, d, e) 69 | pr <- propr(X, metric = "rho") 70 | 71 | # check 72 | expect_equal( 73 | pr@matrix, 74 | getMatrix(pr) 75 | ) 76 | }) 77 | 78 | test_that('results_to_matrix works - when filtered',{ 79 | 80 | # compute differential proportionality 81 | x <- iris[,1:4] # data matrix with 4 variables 82 | y <- iris[,5] # group vector 83 | pd <- propd(x, as.character(y)) 84 | pd <- updateF(pd, moderated=T) 85 | results <- getSignificantResultsFstat(pd, fdr_adjusted=TRUE) 86 | mat <- results_to_matrix(results) 87 | 88 | # check it is filtered 89 | expect_true(all(results$FDR <= 0.05)) 90 | 91 | # check values are correct 92 | expect_equal(colnames(mat), unique(c(results$Pair, results$Partner))) 93 | expect_true(results$theta[1] == mat[results$Pair[1], results$Partner[1]]) 94 | expect_true(results$theta[2] == mat[results$Pair[2], results$Partner[2]]) 95 | expect_true(results$theta[3] == mat[results$Pair[3], results$Partner[3]]) 96 | }) -------------------------------------------------------------------------------- /old_tests/testthat/test-propd.R: -------------------------------------------------------------------------------- 1 | library(propr) 2 | 3 | data(mail) 4 | 5 | test_that("lrv without weights matches vlrRcpp", { 6 | 7 | expect_equal( 8 | propr:::lltRcpp(propr:::vlrRcpp(mail[])), 9 | propr:::lrv(mail, mail) 10 | ) 11 | }) 12 | 13 | data(iris) 14 | keep <- iris$Species %in% c("setosa", "versicolor") 15 | counts <- iris[keep, 1:4] * 10 16 | group <- ifelse(iris[keep, "Species"] == "setosa", "A", "B") 17 | 18 | if(requireNamespace("limma", quietly = TRUE)){ 19 | 20 | test_that("propd returns correct theta result", { 21 | 22 | expect_equal( 23 | propr:::calculateTheta_old(counts, group)$theta, 24 | propd(counts, group, p = 3)@results$theta 25 | ) 26 | 27 | expect_equal( 28 | propr:::calculateThetaW_old(counts, group)$theta, 29 | propd(counts, group, p = 3, weighted = TRUE)@results$theta 30 | ) 31 | 32 | expect_equal( 33 | propr:::alphaTheta_old(counts, group, alpha = .1)$atheta, 34 | propd(counts, group, p = 3, alpha = .1)@results$theta 35 | ) 36 | 37 | pdaw <- propd(counts, group, p = 3, weighted = TRUE, alpha = .1) 38 | expect_equal( 39 | propr:::alphaThetaW_old(counts, group, alpha = .1, pdaw@weights)$theta, 40 | pdaw@results$theta 41 | ) 42 | }) 43 | 44 | test_that("propd calculates correct lrm result", { 45 | 46 | expect_equal( 47 | propr:::calculateTheta_old(counts, group)$lrm1, 48 | propd(counts, group, p = 3)@results$lrm1 49 | ) 50 | 51 | expect_equal( 52 | propr:::calculateThetaW_old(counts, group)$lrm1, 53 | propd(counts, group, p = 3, weighted = TRUE)@results$lrm1 54 | ) 55 | 56 | expect_equal( 57 | propr:::alphaTheta_old(counts, group, alpha = .1)$alrm1, 58 | propd(counts, group, p = 3, alpha = .1)@results$lrm1 59 | ) 60 | 61 | pdaw <- propd(counts, group, p = 3, weighted = TRUE, alpha = .1) 62 | expect_equal( 63 | propr:::alphaThetaW_old(counts, group, alpha = .1, pdaw@weights)$awlrm1, 64 | pdaw@results$lrm1 65 | ) 66 | }) 67 | } 68 | 69 | test_that("shuffling group labels does not change lrv", { 70 | 71 | expect_equal( 72 | propr:::calculateTheta(counts[sample(1:100), ], group)$lrv, 73 | propr:::calculateTheta(counts, group)$lrv 74 | ) 75 | 76 | expect_equal( 77 | propr:::calculateTheta(counts, group[sample(1:100)])$lrv, 78 | propr:::calculateTheta(counts, group)$lrv 79 | ) 80 | }) 81 | 82 | set.seed(1) 83 | theta <- propr:::calculateTheta_old(counts, group) 84 | ptheta <- propr:::permuteTheta_prime(counts, group, p = 5) 85 | pt <- propr:::calculateFDR(theta, ptheta, cutoff = seq(.95, 1, .01)) 86 | 87 | set.seed(1) 88 | pd <- propd(counts, group, p = 5) 89 | pd <- updateCutoffs(pd, cutoff = seq(.95, 1, .01)) 90 | 91 | test_that("propd FDR mirrors permuteTheta_prime", { 92 | 93 | expect_equal( 94 | pt$FDR, 95 | pd@fdr$FDR 96 | ) 97 | }) 98 | 99 | n1 <- 50 100 | n2 <- 50 101 | 102 | test_that("active theta_e matches calculation using theta_d", { 103 | 104 | expect_equal( 105 | setActive(pd, what = "theta_e")@results$theta, 106 | 1 - pd@results$theta + pmin((n1-1) * pd@results$lrv1, (n2-1) * pd@results$lrv2) / ((n1+n2-1) * pd@results$lrv) 107 | ) 108 | }) 109 | 110 | test_that("active theta_f matches calculation using theta_e", { 111 | 112 | expect_equal( 113 | setActive(pd, what = "theta_f")@results$theta, 114 | 1 - setActive(pd, what = "theta_e")@results$theta 115 | ) 116 | }) 117 | -------------------------------------------------------------------------------- /OLDNEWS.md: -------------------------------------------------------------------------------- 1 | ## propriety 1.0.1 2 | --------------------- 3 | * Replace `alphaTheta` with improved `calculateTheta` 4 | * Now calculates emergent proportionality (theta_e) 5 | * Now checks for `@theta$lrv == 0` (NaN theta) 6 | * Modified `propd` function 7 | * FDR now handled by `updateCutoffs` function 8 | * New `setDisjointed` function makes theta_d active 9 | * New `setEmergent` function makes theta_e active 10 | * Now calculates F from theta_d 11 | * Modified visualization tools 12 | * Remove "Bridged" and "Missing" pairs from figures 13 | * `geiser` function omits "Bridged" and "Missing" pairs 14 | * `gemini` function omits "Bridged" and "Missing" pairs 15 | * New `bowtie` function plots log-ratio means by group 16 | * Modified `plot` function 17 | * New `plotSkip` argument used by `pals` to skip plot 18 | * Colors edges by LRM if using theta_d 19 | * Colors edges by LRV if using theta_e 20 | 21 | ## propriety 1.0.0 22 | --------------------- 23 | * Include a sample `propd` object for vignette examples 24 | * Built using non-zero features with at least 40 counts 25 | * Add conceptualization and implementation of PAL 26 | * New `pals` function computes the popular adjacent ligand 27 | * Add table and visualization tools 28 | * New `shale` function produces table used for graphing 29 | * New `geiser` function plots VLR1 vs. VLR2 30 | * New `gemini` function plots log-fold VLR vs. LRMs 31 | * New `slice` function plots log-ratio abundance 32 | * Modified `plot` function 33 | * Labels disjointedly proportional edges in yellow 34 | * Now augments graph using an indexed `propr` object 35 | * Integer cutoff now selects top N pairs 36 | * Now supports 3D visualization 37 | * Add `propd` vignette 38 | 39 | ## propriety 0.0.7 40 | --------------------- 41 | * Modified `calculateTheta` and `alphaTheta` functions 42 | * No longer returns a sorted `data.table` object 43 | 44 | ## propriety 0.0.6 45 | --------------------- 46 | * Modified `calculateTheta` and `alphaTheta` functions 47 | * Now returns a sorted `data.table` object 48 | * Add `progress` bar and `migraph` functions 49 | * New `plot` method for `propd` object 50 | 51 | ## propriety 0.0.5 52 | --------------------- 53 | * New `half2mat` function builds matrix from half-matrix 54 | * New `propd2propr` function converts `propd` to `propr` 55 | * Allows `propd` to inherit `propr` methods 56 | 57 | ## propriety 0.0.4 58 | --------------------- 59 | * Modified `propd` function 60 | * Use `ctzRcpp` to track joint zero frequency 61 | * Use `lrmRcpp` to calculate log-ratio mean 62 | * Help file includes messy LaTeX formulae 63 | * Update documentation 64 | * README and vignette outlined with theory 65 | * Deprecate outdated C++ code 66 | 67 | ## propriety 0.0.3 68 | --------------------- 69 | * New `propd` class and function 70 | * Provides front-end for theta calculation 71 | * `alpha` argument toggles theta method 72 | * Include a unit test for new FDR 73 | * Extended proportionality statistic theta 74 | * New `alphaTheta` function 75 | * Back-end handled by the `boxRcpp` function 76 | * Included slow implementations for testing 77 | * Deprecated `alphaTheta_old` 78 | * All permutation functions now deprecated 79 | 80 | ## propriety 0.0.2 81 | --------------------- 82 | * Extended proportionality statistic theta 83 | * New `calculateFDR` function 84 | * Removed unused C++ code 85 | 86 | ## propriety 0.0.1 87 | --------------------- 88 | * Introduced proportionality statistic theta 89 | * New `calculateTheta` function 90 | * New `permuteTheta` function 91 | * Included slow implementations for testing 92 | * Deprecated `calculateTheta_old` 93 | * Deprecated `permuteTheta_old` 94 | * Added unit tests 95 | * New and old `calculateTheta` match 96 | * New and old `permuteTheta` match 97 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPR-pcorshrink.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | library(corpcor) 4 | 5 | # define data 6 | N <- 100 7 | a <- seq(from = 5, to = 15, length.out = N) 8 | b <- a * rnorm(N, mean = 1, sd = 0.1) 9 | c <- rnorm(N, mean = 10) 10 | d <- rnorm(N, mean = 10) 11 | e <- rep(10, N) 12 | X <- data.frame(a, b, c, d, e) 13 | for (i in 1:4){ 14 | X[sample(1:N, 10),i] <- 0 15 | } 16 | 17 | test_that("pcor.shrink is the same when ivar is 5, with or without the reference column", { 18 | 19 | # compute lr 20 | ct <- simple_zero_replacement(X) 21 | lr <- logratio_without_alpha(ct, 5) 22 | 23 | # compute pcor.shrink 24 | pr1 <- suppressWarnings(propr(lr, metric = "pcor.shrink", ivar=NA)) 25 | 26 | # compute pcor.shrink without 5th column 27 | pr2 <- suppressWarnings(propr(lr[1:4], metric = "pcor.shrink", ivar=NA)) 28 | 29 | # expect computed coefficients are equal 30 | expect_true( 31 | all(round(pr1@matrix, 8)[1:4,1:4] == round(pr2@matrix, 8)[1:4,1:4]) 32 | ) 33 | 34 | # check shrinkage is the same 35 | expect_equal( 36 | pr1@lambda, 37 | pr2@lambda 38 | ) 39 | 40 | }) 41 | 42 | test_that("pcor.shrink is correct when ivar is given", { 43 | 44 | d1 <- list("clr", 5, c(1,3)) 45 | d2 <- list(c(1:5), 5, c(1,3)) 46 | 47 | for (i in 1:length(d1)){ 48 | 49 | # compute pcor manually 50 | ct <- simple_zero_replacement(X) 51 | lr <- logratio_without_alpha(ct, d2[[i]]) 52 | cov <- suppressWarnings(cov.shrink(lr)) 53 | mat <- cor2pcor(cov) 54 | mat <- matrix(mat, ncol=ncol(lr), nrow=ncol(lr)) 55 | class(mat) <- "matrix" 56 | lambda <- attr(cov, "lambda") 57 | 58 | # compute pcor 59 | pr <- suppressWarnings(propr(X, metric = "pcor.shrink", ivar=d1[[i]])) 60 | 61 | # expect counts to have zeros replaced 62 | expect_true( 63 | all(pr@counts == ct) 64 | ) 65 | 66 | # expect that logratio are equal 67 | expect_true( 68 | all(pr@logratio == lr) 69 | ) 70 | 71 | # expect computed coefficients are equal 72 | expect_true( 73 | all(round(pr@matrix, 8) == round(mat, 8), na.rm=T) 74 | ) 75 | 76 | # check shrinkage is not applied 77 | expect_equal( 78 | pr@lambda, 79 | lambda 80 | ) 81 | } 82 | }) 83 | 84 | 85 | test_that("pcor.shrink is correct when ivar is NA using previously transformed data", { 86 | 87 | d1 <- list("clr", 5, c(1,3)) 88 | d2 <- list(c(1:5), 5, c(1,3)) 89 | 90 | for (i in 1:length(d1)){ 91 | 92 | # compute pcor manually 93 | ct <- simple_zero_replacement(X) 94 | lr <- logratio_without_alpha(ct, d2[[i]]) 95 | cov <- suppressWarnings(cov.shrink(lr)) 96 | mat <- cor2pcor(cov) 97 | mat <- matrix(mat, ncol=ncol(lr), nrow=ncol(lr)) 98 | class(mat) <- "matrix" 99 | lambda <- attr(cov, "lambda") 100 | 101 | # compute pcor 102 | pr <- suppressWarnings(propr(lr, metric = "pcor.shrink", ivar=NA)) 103 | 104 | # expect counts to contain the previously transformed data 105 | expect_true( 106 | all(pr@counts == lr) 107 | ) 108 | 109 | # expect that the logratio slot also contains the exact input data 110 | expect_true( 111 | all(pr@logratio == lr) 112 | ) 113 | 114 | # expect computed coefficients are equal 115 | expect_true( 116 | all(round(pr@matrix, 8) == round(mat, 8), na.rm=T) 117 | ) 118 | 119 | # check shrinkage is not applied 120 | expect_equal( 121 | pr@lambda, 122 | lambda 123 | ) 124 | } 125 | }) 126 | 127 | test_that("pcor.shrink with alr and clr are not the same", { 128 | 129 | # compute pcor.shrink with alr 130 | pr <- suppressWarnings(propr(X, metric = "pcor.shrink", ivar=5)) 131 | pcor_alr <- getMatrix(pr)[1:4, 1:4] 132 | 133 | # compute pcor.shrink with clr 134 | pr <- propr(X, metric = "pcor.shrink", ivar="clr") 135 | pcor_clr <- getMatrix(pr)[1:4, 1:4] 136 | 137 | expect_false( 138 | all(round(pcor_alr, 8) == round(pcor_clr, 8)) 139 | ) 140 | 141 | }) 142 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | wtmRcpp <- function(x, w) { 5 | .Call(`_propr_wtmRcpp`, x, w) 6 | } 7 | 8 | wtvRcpp <- function(x, w) { 9 | .Call(`_propr_wtvRcpp`, x, w) 10 | } 11 | 12 | corRcpp <- function(X) { 13 | .Call(`_propr_corRcpp`, X) 14 | } 15 | 16 | covRcpp <- function(X, norm_type = 0L) { 17 | .Call(`_propr_covRcpp`, X, norm_type) 18 | } 19 | 20 | vlrRcpp <- function(X) { 21 | .Call(`_propr_vlrRcpp`, X) 22 | } 23 | 24 | clrRcpp <- function(X) { 25 | .Call(`_propr_clrRcpp`, X) 26 | } 27 | 28 | alrRcpp <- function(X, ivar = 0L) { 29 | .Call(`_propr_alrRcpp`, X, ivar) 30 | } 31 | 32 | symRcpp <- function(X) { 33 | .Call(`_propr_symRcpp`, X) 34 | } 35 | 36 | phiRcpp <- function(X, sym = 1L) { 37 | .Call(`_propr_phiRcpp`, X, sym) 38 | } 39 | 40 | rhoRcpp <- function(X, lr, ivar = 0L) { 41 | .Call(`_propr_rhoRcpp`, X, lr, ivar) 42 | } 43 | 44 | indexPairs <- function(X, op = "==", ref = 0) { 45 | .Call(`_propr_indexPairs`, X, op, ref) 46 | } 47 | 48 | indexToCoord <- function(V, N) { 49 | .Call(`_propr_indexToCoord`, V, N) 50 | } 51 | 52 | coordToIndex <- function(row, col, N) { 53 | .Call(`_propr_coordToIndex`, row, col, N) 54 | } 55 | 56 | linRcpp <- function(rho, lr) { 57 | .Call(`_propr_linRcpp`, rho, lr) 58 | } 59 | 60 | lltRcpp <- function(X) { 61 | .Call(`_propr_lltRcpp`, X) 62 | } 63 | 64 | urtRcpp <- function(X) { 65 | .Call(`_propr_urtRcpp`, X) 66 | } 67 | 68 | labRcpp <- function(nfeats) { 69 | .Call(`_propr_labRcpp`, nfeats) 70 | } 71 | 72 | half2mat <- function(X) { 73 | .Call(`_propr_half2mat`, X) 74 | } 75 | 76 | vector2mat <- function(X, i, j, nfeats) { 77 | .Call(`_propr_vector2mat`, X, i, j, nfeats) 78 | } 79 | 80 | ratiosRcpp <- function(X) { 81 | .Call(`_propr_ratiosRcpp`, X) 82 | } 83 | 84 | results2matRcpp <- function(results, n, diagonal = 0.0) { 85 | .Call(`_propr_results2matRcpp`, results, n, diagonal) 86 | } 87 | 88 | count_less_than <- function(x, cutoff) { 89 | .Call(`_propr_count_less_than`, x, cutoff) 90 | } 91 | 92 | count_greater_than <- function(x, cutoff) { 93 | .Call(`_propr_count_greater_than`, x, cutoff) 94 | } 95 | 96 | count_less_equal_than <- function(x, cutoff) { 97 | .Call(`_propr_count_less_equal_than`, x, cutoff) 98 | } 99 | 100 | count_greater_equal_than <- function(x, cutoff) { 101 | .Call(`_propr_count_greater_equal_than`, x, cutoff) 102 | } 103 | 104 | ctzRcpp <- function(X) { 105 | .Call(`_propr_ctzRcpp`, X) 106 | } 107 | 108 | getOR <- function(A, G) { 109 | .Call(`_propr_getOR`, A, G) 110 | } 111 | 112 | getORperm <- function(A, G, perm) { 113 | .Call(`_propr_getORperm`, A, G, perm) 114 | } 115 | 116 | permuteOR <- function(A, G, p = 100L) { 117 | .Call(`_propr_permuteOR`, A, G, p) 118 | } 119 | 120 | getFDR <- function(actual, permuted) { 121 | .Call(`_propr_getFDR`, actual, permuted) 122 | } 123 | 124 | getG <- function(Gk) { 125 | .Call(`_propr_getG`, Gk) 126 | } 127 | 128 | graflex <- function(A, Gk, p = 100L) { 129 | .Call(`_propr_graflex`, A, Gk, p) 130 | } 131 | 132 | lr2vlr <- function(lr) { 133 | .Call(`_propr_lr2vlr`, lr) 134 | } 135 | 136 | lr2phi <- function(lr) { 137 | .Call(`_propr_lr2phi`, lr) 138 | } 139 | 140 | lr2rho <- function(lr) { 141 | .Call(`_propr_lr2rho`, lr) 142 | } 143 | 144 | lr2phs <- function(lr) { 145 | .Call(`_propr_lr2phs`, lr) 146 | } 147 | 148 | lrm <- function(Y, W, weighted = FALSE, a = NA_real_, Yfull = matrix(1, 1), Wfull = matrix(1, 1)) { 149 | .Call(`_propr_lrm`, Y, W, weighted, a, Yfull, Wfull) 150 | } 151 | 152 | lrv <- function(Y, W, weighted = FALSE, a = NA_real_, Yfull = matrix(1, 1), Wfull = matrix(1, 1)) { 153 | .Call(`_propr_lrv`, Y, W, weighted, a, Yfull, Wfull) 154 | } 155 | 156 | omega <- function(W) { 157 | .Call(`_propr_omega`, W) 158 | } 159 | 160 | Omega <- function(W) { 161 | .Call(`_propr_Omega`, W) 162 | } 163 | 164 | -------------------------------------------------------------------------------- /R/4-aldex2propr.R: -------------------------------------------------------------------------------- 1 | #' Import \code{ALDEx2} Object 2 | #' 3 | #' This method constructs a \code{propr} object from an 4 | #' \code{aldex.clr} object. See Details. 5 | #' 6 | #' The \code{ALDEx2} package has two exceptional features useful 7 | #' in proportionality analysis too. First, \code{ALDEx2} offers 8 | #' a number of extra log-ratio transformations, toggled 9 | #' by the \code{denom} argument in \code{aldex.clr}. Second, 10 | #' \code{ALDEx2} estimates per-feature technical variation 11 | #' within each sample using Monte-Carlo instances drawn 12 | #' from the Dirichlet distribution. 13 | #' 14 | #' The \code{aldex2propr} function takes advantage of both 15 | #' of these features by constructing a \code{propr} object 16 | #' directly from an \code{aldex.clr} object. When interpreting 17 | #' the resultant \code{propr} object, keep in mind that 18 | #' \code{ALDEx2} adds 0.5 to all \code{@@counts} regardless 19 | #' of whether the counts contain any zeros. Otherwise, 20 | #' the \code{@@logratio} slot contains the log-ratio 21 | #' transformed counts as averaged across all Monte Carlo 22 | #' instances. Likewise, the \code{@@matrix} slot gets 23 | #' filled with the proportionality matrix as averaged 24 | #' across all Monte Carlo instances. 25 | #' 26 | #' The \code{select} argument subsets the feature matrix 27 | #' after log-ratio transformation but before calculating 28 | #' proportionality. This reduces the run-time and RAM 29 | #' overhead without impacting the final result. Removing 30 | #' lowly abundant features prior to log-ratio transformation 31 | #' could otherwise change the proportionality measure. 32 | #' 33 | #' @param aldex.clr An \code{aldex.clr} object. 34 | #' @param how A character string. The proportionality metric 35 | #' used to build the \code{propr} object. Choose from 36 | #' "rho", "phi", or "phs". 37 | #' @param select Optional. Use this to subset the final 38 | #' proportionality matrix without altering the result. 39 | #' 40 | #' @return Returns a \code{propr} object. 41 | #' 42 | #' @export 43 | aldex2propr <- function(aldex.clr, how = "rho", select) { 44 | packageCheck("ALDEx2") 45 | 46 | if (!inherits(aldex.clr, "aldex.clr")) { 47 | stop("This method expects an 'aldex.clr' object.") 48 | } 49 | if (how %in% c("perb", "rho", "lr2rho")) { 50 | how <- "lr2rho" 51 | } else if (how %in% c("phit", "phi", "lr2phi")) { 52 | how <- "lr2phi" 53 | } else if (how %in% c("phis", "phis", "phs", "lr2phs")) { 54 | how <- "lr2phs" 55 | } else{ 56 | stop("Provided 'how' not supported.") 57 | } 58 | 59 | # Keep a running sum of propr instances 60 | counts <- t(as.matrix(aldex.clr@reads)) 61 | mc <- ALDEx2::getMonteCarloInstances(aldex.clr) 62 | k <- ALDEx2::numMCInstances(aldex.clr) 63 | logratio <- 0 64 | prop <- 0 65 | for (i in 1:k) { 66 | numTicks <- progress(i, k, numTicks) 67 | 68 | # Extract i-th Monte Carlo instance 69 | mci_lr <- t(sapply(mc, function(x) 70 | x[, i])) 71 | 72 | # Subset log-ratio transformed data 73 | if (!missing(select)) { 74 | if (i == 1) { 75 | # Make select boolean (it's OK if it's integer) 76 | if (is.character(select)) 77 | select <- match(select, colnames(mci_lr)) 78 | if (any(is.na(select))) 79 | stop("Uh oh! Provided select reference not found in data.") 80 | counts <- counts[, select] 81 | } 82 | 83 | mci_lr <- mci_lr[, select] 84 | } 85 | 86 | # Add i-th log-ratio transformation to cumulative sum 87 | logratio <- logratio + mci_lr 88 | 89 | # Add i-th proportionality matrix to cumulative sum 90 | prop.i <- do.call(how, list("lr" = mci_lr)) 91 | prop <- prop + prop.i 92 | } 93 | 94 | propr <- new("propr") 95 | propr@counts <- as.data.frame(counts) 96 | propr@logratio <- as.data.frame(logratio) / k 97 | propr@matrix <- prop / k 98 | 99 | message("Alert: Using 'aldex2propr' is not compatible the @results table.") 100 | propr@results <- data.frame() 101 | 102 | message("Alert: Using 'aldex2propr' disables permutation testing.") 103 | propr@permutes <- list(NULL) 104 | 105 | return(propr) 106 | } 107 | -------------------------------------------------------------------------------- /R/2-propd.R: -------------------------------------------------------------------------------- 1 | #' @param counts A data matrix representing counts. 2 | #' It is assumed that the matrix contains numerical values only. 3 | #' @param group A character vector representing group labels indicating the 4 | #' assignment of each count to different groups. 5 | #' @param alpha The alpha parameter used in the alpha log-ratio transformation. 6 | #' @param p The number of permutations to perform for calculating the false 7 | #' discovery rate (FDR). The default is 0. 8 | #' @param weighted A logical value indicating whether weighted calculations 9 | #' should be performed. 10 | #' @param shrink A logical value indicating whether to apply shrinkage 11 | #' 12 | #' @return A \code{propd} object containing the computed theta values, 13 | #' associated count matrix, group labels, and other calculated statistics. 14 | #' 15 | #' @details The \code{propd} function creates a \code{propd} object, which is 16 | #' used for differential analysis of regulatory relationships between features. 17 | #' It performs log-ratio transformation, calculates the variance of log-ratio 18 | #' (VLR), and computes the theta values using different formulas. The object 19 | #' stores the count matrix, group labels, alpha parameter, and other relevant 20 | #' information needed for further analysis and visualization. 21 | #' 22 | #' @examples 23 | #' # Sample input count data and group assignments 24 | #' data <- iris[1:100, 1:4] 25 | #' group <- iris[1:100, 5] 26 | #' 27 | #' # Create a propd object for differential analysis 28 | #' result <- propd(data, group, alpha = 0.5) 29 | #' 30 | #' @rdname propd 31 | #' @export 32 | propd <- function(counts, 33 | group, 34 | alpha = NA, 35 | p = 0, 36 | weighted = FALSE, 37 | shrink = FALSE) { 38 | ############################################################################## 39 | ### CLEAN UP ARGS 40 | ############################################################################## 41 | 42 | # Clean "count matrix" 43 | counts <- as_safe_matrix(counts) 44 | 45 | # Clean group 46 | if (inherits(group, "factor")) 47 | group <- as.character(group) 48 | if (!inherits(group, "character")) 49 | stop("Provide group labels as a character vector.") 50 | if (length(group) != nrow(counts)) 51 | stop("Too many or too few group labels.") 52 | 53 | # Throw error if scenario not supported 54 | if (shrink && weighted) { 55 | stop("Shrinkage is not available for weighted computation yet.") 56 | } 57 | 58 | # Special handling for equivalent args 59 | if (identical(alpha, 0)) 60 | alpha <- NA 61 | 62 | # Initialize @active, @weighted 63 | result <- new("propd") 64 | result@active <- "theta_d" # set theta_d active by default 65 | result@weighted <- weighted 66 | result@shrink <- shrink 67 | result@dfz <- 0 68 | 69 | # Initialize @counts, @group, @alpha 70 | result@counts <- as.data.frame(counts) 71 | result@group <- as.character(group) 72 | result@alpha <- as.numeric(alpha) 73 | result@permutes <- data.frame() 74 | 75 | ############################################################################## 76 | ### CALCULATE THETA WITH OR WITHOUT WEIGHTS 77 | ############################################################################## 78 | 79 | # Initialize @results 80 | result@results <- 81 | calculate_theta( 82 | result@counts, 83 | result@group, 84 | result@alpha, 85 | weighted = weighted, 86 | shrink = shrink 87 | ) 88 | result@results$Zeros <- ctzRcpp(counts) # count number of zeros 89 | result@results$theta <- 90 | round(result@results$theta, 14) # round floats to 1 91 | 92 | # permute data 93 | if (p > 0) result <- updatePermutes(result, p) 94 | 95 | ############################################################################## 96 | ### GIVE HELPFUL MESSAGES TO USER 97 | ############################################################################## 98 | 99 | message("Alert: Use 'setActive' to select a theta type.") 100 | message("Alert: Use 'updateCutoffs' to calculate FDR.") 101 | message("Alert: Use 'updateF' to calculate F-stat.") 102 | 103 | return(result) 104 | } 105 | -------------------------------------------------------------------------------- /tests/testthat/test-PROPR-ivar.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | data(mtcars) 5 | 6 | test_that("the data is properly handled when ivar is NA", { 7 | 8 | # compute propr object 9 | pr <- propr(mtcars, ivar=NA) 10 | 11 | # check the counts remain the same as the original input 12 | expect_equal( 13 | pr@counts, 14 | mtcars 15 | ) 16 | 17 | # check the logratios are the same 18 | expect_equal( 19 | pr@logratio, 20 | mtcars 21 | ) 22 | }) 23 | 24 | test_that("the data is properly handled when ivar is clr", { 25 | 26 | # compute propr object 27 | pr <- propr(mtcars, ivar="clr") 28 | 29 | # compute expected data 30 | ct <- simple_zero_replacement(mtcars) 31 | clr <- logratio_without_alpha(ct, c(1:ncol(ct))) 32 | 33 | # check the counts remain the same as the zero-replaced input 34 | expect_equal( 35 | pr@counts, 36 | ct 37 | ) 38 | 39 | # check the logratios are the same 40 | expect_equal( 41 | pr@logratio, 42 | clr 43 | ) 44 | }) 45 | 46 | test_that("the data is properly handled when ivar is 3", { 47 | 48 | # compute propr object 49 | pr <- propr(mtcars, ivar=3) 50 | 51 | # compute expected data 52 | ct <- simple_zero_replacement(mtcars) 53 | alr <- logratio_without_alpha(ct, 3) 54 | 55 | # check the counts remain the same as the original input 56 | expect_equal( 57 | pr@counts, 58 | ct 59 | ) 60 | 61 | # check the logratios are the same 62 | expect_equal( 63 | pr@logratio, 64 | alr 65 | ) 66 | }) 67 | 68 | test_that("the data is properly handled when ivar is 1,6", { 69 | 70 | # compute propr object 71 | pr <- propr(mtcars, ivar=c(1,6)) 72 | 73 | # compute expected data 74 | ct <- simple_zero_replacement(mtcars) 75 | alr <- logratio_without_alpha(ct, c(1,6)) 76 | 77 | # check the counts remain the same as the original input 78 | expect_equal( 79 | pr@counts, 80 | ct 81 | ) 82 | 83 | # check the logratios are the same 84 | expect_equal( 85 | pr@logratio, 86 | alr 87 | ) 88 | }) 89 | 90 | test_that("pearson correlation is correct when ivar is NA", { 91 | 92 | # compute propr object 93 | cor_propr <- propr(mtcars, metric = "cor", ivar=NA)@matrix 94 | 95 | # get correlation using cor 96 | cor_cor <- cor(mtcars, method = "pearson") 97 | 98 | expect_equal( 99 | round(cor_propr, 6), 100 | round(cor_cor, 6) 101 | ) 102 | }) 103 | 104 | test_that("pearson correlation is correct when ivar is clr", { 105 | 106 | # get correlation using propr 107 | pr <- propr(mtcars, metric = "cor", ivar="clr") 108 | 109 | # get correlation using cor 110 | ct <- simple_zero_replacement(mtcars) 111 | clr <- logratio_without_alpha(ct, c(1:ncol(ct))) 112 | ccor <- cor(clr, method = "pearson") 113 | 114 | # check the correlations are the same 115 | expect_equal( 116 | round(pr@matrix, 6), 117 | round(ccor, 6) 118 | ) 119 | }) 120 | 121 | test_that("pearson correlation is correct when ivar is 1", { 122 | 123 | # get correlation using propr 124 | pr <- suppressWarnings(propr(mtcars, metric = "cor", ivar=1)) 125 | 126 | # get correlation using cor 127 | ct <- simple_zero_replacement(mtcars) 128 | alr <- logratio_without_alpha(ct, 1) 129 | ccor <- suppressWarnings(cor(alr, method = "pearson")) 130 | 131 | # check the correlations are the same 132 | expect_equal( 133 | round(pr@matrix, 6), 134 | round(ccor, 6) 135 | ) 136 | }) 137 | 138 | test_that("pearson correlation is correct when ivar is 1,3", { 139 | 140 | # get correlation using propr 141 | pr <- suppressWarnings(propr(mtcars, metric = "cor", ivar=c(1,3))) 142 | 143 | # get correlation using cor 144 | ct <- simple_zero_replacement(mtcars) 145 | alr <- logratio_without_alpha(ct, c(1,3)) 146 | ccor <- suppressWarnings(cor(alr, method = "pearson")) 147 | 148 | # check the correlations are the same 149 | expect_equal( 150 | round(pr@matrix, 6), 151 | round(ccor, 6) 152 | ) 153 | }) 154 | -------------------------------------------------------------------------------- /R/2c-propd-experimental.R: -------------------------------------------------------------------------------- 1 | #' Get Per-Feature Theta 2 | #' 3 | #' This function calculates the differential proportionality 4 | #' between each feature and a set of normalization factors. When the 5 | #' normalization factors correctly remove the compositional bias, the 6 | #' resultant thetas indicate differential expression (DE). However, unlike 7 | #' other DE tests, the p-value for differential proportionality is 8 | #' not linked to the normalization factors. Here, normalization factors 9 | #' only affect the interpretation, not the statistics. 10 | #' 11 | #' @param object A \code{\link{propd}} object. 12 | #' @param norm.factors A numeric vector. The effective library size 13 | #' normalization factors (e.g., from edgeR or DESeq2). 14 | #' @return A numeric vector. A theta for each feature. 15 | #' @export 16 | runNormalization <- function(object, norm.factors) { 17 | if (!inherits(object, "propd")) { 18 | stop("Please provide a propd object.") 19 | } 20 | if (!identical(length(norm.factors), nrow(object@counts))) { 21 | stop("The norm factors should have one value for each subject.") 22 | } 23 | 24 | # compute thetas 25 | newCounts <- cbind(norm.factors, object@counts) 26 | newPD <- 27 | propd( 28 | newCounts, 29 | group = object@group, 30 | alpha = object@alpha, 31 | p = 0, 32 | weighted = object@weighted 33 | ) 34 | if (object@active == "theta_mod") { 35 | newPD <- updateF(newPD, moderated = TRUE) 36 | } 37 | newPD <- setActive(newPD, object@active) 38 | 39 | # parse thetas for each gene 40 | rawRes <- newPD@results 41 | perFeature <- rawRes[rawRes$Pair == 1,] 42 | if (!identical(perFeature$Partner, 2:(ncol(newCounts)))) 43 | stop("DEBUG ERROR #GET001.") 44 | thetas <- perFeature$theta 45 | names(thetas) <- colnames(object@counts) 46 | 47 | return(thetas) 48 | } 49 | 50 | #' Perform Post-Hoc Testing 51 | #' 52 | #' After running an ANOVA of more than 2 groups, it is useful 53 | #' to know which of the groups differ from the others. This 54 | #' question is often answered with post-hoc testing. This 55 | #' function implements post-hoc pairwise differential 56 | #' proportionality analyses for more than 2 groups. 57 | #' 58 | #' The ANOVA p-values are adjusted once (column-wise) during 59 | #' the original multi-group analysis. The post-hoc p-values 60 | #' are adjusted once (row-wise) for the number 61 | #' of post-hoc tests. The post-hoc adjustment 62 | #' is p times the number of post-hoc tests. 63 | #' 64 | #' Please note that a significant post-hoc test without 65 | #' a significant ANOVA test is not significant! 66 | #' 67 | #' @param object A \code{\link{propd}} object. 68 | #' @return A \code{\link{propd}} object. 69 | #' @export 70 | runPostHoc <- function(object) { 71 | groups <- unique(object@group) 72 | if (!length(groups) > 2) { 73 | stop("This function requires more than 2 groups.") 74 | } 75 | 76 | if (!"Pval" %in% colnames(object@results)) { 77 | message("Alert: Calculating ANOVA p-values without moderation.") 78 | object <- updateF(object) 79 | } 80 | 81 | for (i in 1:length(groups)) { 82 | for (j in 1:length(groups)) { 83 | if (j < i) { 84 | group1 <- groups[i] 85 | group2 <- groups[j] 86 | 87 | index <- object@group == group1 | object@group == group2 88 | x.ij <- object@counts[index, ] 89 | y.ij <- object@group[index] 90 | object.ij <- 91 | suppressMessages(propd( 92 | x.ij, 93 | y.ij, 94 | alpha = object@alpha, 95 | weighted = object@weighted 96 | )) 97 | 98 | if (is.na(object@Fivar) | is.null(object@Fivar)) { 99 | mod <- FALSE 100 | } else{ 101 | mod <- TRUE 102 | } 103 | 104 | object.ij <- 105 | suppressMessages(updateF(object.ij, moderated = mod)) 106 | new_result <- data.frame(object.ij@results$Pval) 107 | colnames(new_result) <- 108 | paste0(group1, ".vs.", group2, ".adj") 109 | ntests <- length(groups) * (length(groups) - 1) / 2 110 | object@results <- cbind(object@results, new_result * ntests) 111 | } 112 | } 113 | } 114 | 115 | message("Alert: Use 'getResults' function to obtain post-hoc tests.") 116 | message("Alert: Use 'Pval' column for ANOVA significance.") 117 | return(object) 118 | } 119 | -------------------------------------------------------------------------------- /src/lrv.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "backend.h" 4 | using namespace Rcpp; 5 | 6 | // Calculate lrv with or without weights 7 | // [[Rcpp::export]] 8 | NumericVector lrv(NumericMatrix & Y, 9 | NumericMatrix & W, 10 | bool weighted = false, 11 | double a = NA_REAL, 12 | NumericMatrix Yfull = NumericMatrix(1, 1), 13 | NumericMatrix Wfull = NumericMatrix(1, 1)){ 14 | 15 | // Output a half-matrix 16 | NumericMatrix X = clone(Y); 17 | int nfeats = X.ncol(); 18 | int llt = nfeats * (nfeats - 1) / 2; 19 | NumericVector result(llt); 20 | int counter = 0; 21 | 22 | if(!R_IsNA(a)){ // Weighted and non-weighted, alpha-transformed 23 | 24 | ////////////////////////////////////////////////////// 25 | // Check for valid Yfull argument 26 | if(Yfull.nrow() == NumericMatrix(1, 1).nrow() && 27 | Yfull.ncol() == NumericMatrix(1, 1).ncol()){ 28 | 29 | stop("User must provide valid Yfull argument for alpha-transformation."); 30 | } 31 | 32 | // Raise all of X to the a power 33 | for(int i = 0; i < X.nrow(); i++){ 34 | for(int j = 0; j < X.ncol(); j++){ 35 | X(i, j) = pow(X(i, j), a); 36 | } 37 | } 38 | 39 | // Raise all of Xfull to the a power 40 | NumericMatrix Xfull = clone(Yfull); 41 | int fullfeats = Xfull.ncol(); 42 | for(int i = 0; i < Xfull.nrow(); i++){ 43 | for(int j = 0; j < Xfull.ncol(); j++){ 44 | Xfull(i, j) = pow(Xfull(i, j), a); 45 | } 46 | } 47 | ////////////////////////////////////////////////////// 48 | 49 | if(weighted){ 50 | 51 | ////////////////////////////////////////////////////// 52 | // Check for valid Wfull argument 53 | if(Wfull.nrow() == NumericMatrix(1, 1).nrow() && 54 | Wfull.ncol() == NumericMatrix(1, 1).ncol()){ 55 | 56 | stop("User must provide valid Wfull argument for weighted alpha-transformation."); 57 | } 58 | ////////////////////////////////////////////////////// 59 | 60 | // Mean-center the within-group values as a fraction of the across-group means 61 | // Calculate sum(W * [i - j]^2) 62 | // Divide sum(W * [i - j]^2) by (p * a^2) 63 | Rcpp::NumericVector Wij(nfeats); 64 | Rcpp::NumericVector Wfullij(fullfeats); 65 | Rcpp::NumericVector Xiscaled(nfeats); 66 | Rcpp::NumericVector Xjscaled(nfeats); 67 | for(int i = 1; i < nfeats; i++){ 68 | for(int j = 0; j < i; j++){ 69 | Wij = 2 * W(_, i) * W(_, j) / (W(_, i) + W(_, j)); 70 | Wfullij = 2 * Wfull(_, i) * Wfull(_, j) / (Wfull(_, i) + Wfull(_, j)); 71 | Xiscaled = (X(_, i) - wtmRcpp(X(_, i), Wij)) / wtmRcpp(Xfull(_, i), Wfullij); 72 | Xjscaled = (X(_, j) - wtmRcpp(X(_, j), Wij)) / wtmRcpp(Xfull(_, j), Wfullij); 73 | result(counter) = sum(Wij * pow(Xiscaled - Xjscaled, 2)) / 74 | (pow(a, 2) * (sum(Wij) - sum(pow(Wij, 2)) / sum(Wij))); 75 | counter += 1; 76 | } 77 | } 78 | 79 | }else{ 80 | 81 | // Mean-center the within-group values as a fraction of the across-group means 82 | // Calculate sum([i - j]^2) 83 | // Divide sum([i - j]^2) by ((N-1) * a^2) 84 | Rcpp::NumericVector Xiscaled(nfeats); 85 | Rcpp::NumericVector Xjscaled(nfeats); 86 | double N1 = X.nrow(); 87 | for(int i = 1; i < nfeats; i++){ 88 | for(int j = 0; j < i; j++){ 89 | Xiscaled = (X(_, i) - mean(X(_, i))) / mean(Xfull(_, i)); 90 | Xjscaled = (X(_, j) - mean(X(_, j))) / mean(Xfull(_, j)); 91 | result(counter) = sum(pow(Xiscaled - Xjscaled, 2)) / 92 | (pow(a, 2) * (N1 - 1)); 93 | counter += 1; 94 | } 95 | } 96 | } 97 | 98 | }else{ // Weighted and non-weighted, non-transformed 99 | 100 | if(weighted){ 101 | 102 | Rcpp::NumericVector Wij(nfeats); 103 | for(int i = 1; i < nfeats; i++){ 104 | for(int j = 0; j < i; j++){ 105 | Wij = 2 * W(_, i) * W(_, j) / (W(_, i) + W(_, j)); 106 | result(counter) = wtvRcpp(log(X(_, i) / X(_, j)), Wij); 107 | counter += 1; 108 | } 109 | } 110 | 111 | }else{ 112 | 113 | for(int i = 1; i < nfeats; i++){ 114 | for(int j = 0; j < i; j++){ 115 | result(counter) = var(log(X(_, i) / X(_, j))); 116 | counter += 1; 117 | } 118 | } 119 | } 120 | } 121 | 122 | return result; 123 | } 124 | -------------------------------------------------------------------------------- /old_tests/testthat/test-Fstat.R: -------------------------------------------------------------------------------- 1 | if(requireNamespace("limma", quietly = TRUE) & 2 | requireNamespace("SDMTools", quietly = TRUE)){ 3 | 4 | testFmod <- function(counts, group, a = .05){ 5 | 6 | library(propr) 7 | library(limma) 8 | 9 | M <- counts 10 | 11 | gr <- group 12 | ce=which(group == unique(group)[1]) 13 | co=which(group == unique(group)[2]) 14 | cere=ce 15 | cort=co 16 | nce=length(cere) 17 | nco=length(cort) 18 | 19 | design=matrix(0,dim(M)[1],2) 20 | design[1:length(cere),1]=rep(1,length(cere)) 21 | design[(length(cere)+1):dim(M)[1],2]=rep(1,length(cort)) 22 | 23 | #geometric mean "gene": 24 | z=exp(apply(log(M),1,mean)) 25 | #ratios used for the hierarchical model: 26 | Mz=M/z 27 | 28 | scaledcounts=t(Mz*mean(z)) 29 | u=voom(scaledcounts, design=design, plot=TRUE) 30 | param=lmFit(u,design) 31 | param=eBayes(param) 32 | dz=param$df.prior 33 | s2z=param$s2.prior 34 | 35 | #now we get the usual counts and weights: 36 | counts=t(M[c(cere,cort),]) 37 | v=voom(counts, design=design, plot=TRUE) 38 | colnames(v$weights)=rownames(M) 39 | 40 | #get weight of the geometric mean "gene" 41 | su=apply(v$weights,2,sum) 42 | w=t(v$weights)/su 43 | #weighted geometric mean 44 | zw=exp(apply(w*log(M)*dim(M)[2],1,mean)) 45 | #define weight of geometric mean: 46 | #wz=zw/z 47 | wz=log(zw)/log(z) 48 | 49 | res=propd(counts=M, group=gr, p = 1) 50 | Res=propd(counts=M, group=gr, p = 1, weighted = TRUE) 51 | resa=propd(counts=M, group=gr, p = 1, alpha = a) 52 | Resa=propd(counts=M, group=gr, p = 1, weighted = TRUE, alpha = a) 53 | 54 | #from these results, we need only theta and LRV: 55 | st=res@results[,c("lrv","theta")] 56 | stw=Res@results[,c("lrv","theta")] 57 | sta=resa@results[,c("lrv","theta")] 58 | stwa=Resa@results[,c("lrv","theta")] 59 | 60 | #print("(1) unweighted moderated statistic") 61 | 62 | mod=dz*s2z/st[,"lrv"] 63 | Fpmod=(1-st[,"theta"])*(dz+nce+nco)/((nce+nco)*st[,"theta"]+mod) 64 | thetamod=1/(1+Fpmod) 65 | Fmod=(nce+nco+dz-2)*Fpmod 66 | 67 | #print("(2) weighted moderated statistic") 68 | 69 | modw=dz*s2z/stw[,"lrv"] 70 | Fpmodw=(1-stw[,"theta"])*(dz+nce+nco)/((nce+nco)*stw[,"theta"]+modw) 71 | thetamodw=1/(1+Fpmodw) 72 | Fmodw=(nce+nco+dz-2)*Fpmodw 73 | 74 | #print("(3) power-transformed moderated statistic") 75 | 76 | moda=dz*s2z/sta[,"lrv"] 77 | Fpmoda=(1-sta[,"theta"])*(dz+nce+nco)/((nce+nco)*sta[,"theta"]+moda) 78 | thetamoda=1/(1+Fpmoda) 79 | Fmoda=(nce+nco+dz-2)*Fpmoda 80 | 81 | #print("(4) weighted power-transformed moderated statistic") 82 | 83 | modwa=dz*s2z/stwa[,"lrv"] 84 | Fpmodwa=(1-stwa[,"theta"])*(dz+nce+nco)/((nce+nco)*stwa[,"theta"]+modwa) 85 | thetamodwa=1/(1+Fpmodwa) 86 | Fmodwa=(nce+nco+dz-2)*Fpmodwa 87 | 88 | return(list(thetamod, thetamodw, thetamoda, thetamodwa, 89 | Fmod, Fmodw, Fmoda, Fmodwa)) 90 | } 91 | 92 | library(propr) 93 | 94 | data(iris) 95 | keep <- iris$Species %in% c("setosa", "versicolor") 96 | counts <- iris[keep, 1:4] * 10 97 | group <- ifelse(iris[keep, "Species"] == "setosa", "A", "B") 98 | 99 | pd.nn <- propd(counts, group) 100 | pd.wn <- propd(counts, group, weighted = TRUE) 101 | pd.na <- propd(counts, group, alpha = .05) 102 | pd.wa <- propd(counts, group, weighted = TRUE, alpha = .05) 103 | 104 | pd.nn <- updateF(pd.nn, moderated = TRUE) 105 | pd.wn <- updateF(pd.wn, moderated = TRUE) 106 | pd.na <- updateF(pd.na, moderated = TRUE) 107 | pd.wa <- updateF(pd.wa, moderated = TRUE) 108 | 109 | ref <- testFmod(counts, group, a = .05) 110 | 111 | test_that("updateF matches code provided by Ionas", { 112 | 113 | expect_equal( 114 | pd.nn@results$theta_mod, 115 | ref[[1]] 116 | ) 117 | 118 | expect_equal( 119 | pd.nn@results$Fstat, 120 | ref[[5]] 121 | ) 122 | 123 | # expect_equal( 124 | # pd.wn@results$theta_mod, 125 | # ref[[2]] 126 | # ) 127 | # 128 | # expect_equal( 129 | # pd.wn@results$Fstat, 130 | # ref[[6]] 131 | # ) 132 | 133 | expect_equal( 134 | pd.na@results$theta_mod, 135 | ref[[3]] 136 | ) 137 | 138 | expect_equal( 139 | pd.na@results$Fstat, 140 | ref[[7]] 141 | ) 142 | 143 | # expect_equal( 144 | # pd.wa@results$theta_mod, 145 | # ref[[4]] 146 | # ) 147 | # 148 | # expect_equal( 149 | # pd.wa@results$Fstat, 150 | # ref[[8]] 151 | # ) 152 | }) 153 | } 154 | -------------------------------------------------------------------------------- /src/lrm.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "backend.h" 4 | using namespace Rcpp; 5 | 6 | // Calculate lrm with or without weights 7 | // [[Rcpp::export]] 8 | NumericVector lrm(NumericMatrix & Y, 9 | NumericMatrix & W, 10 | bool weighted = false, 11 | double a = NA_REAL, 12 | NumericMatrix Yfull = NumericMatrix(1, 1), 13 | NumericMatrix Wfull = NumericMatrix(1, 1)){ 14 | 15 | // Output a half-matrix 16 | NumericMatrix X = clone(Y); 17 | int nfeats = X.ncol(); 18 | int llt = nfeats * (nfeats - 1) / 2; 19 | NumericVector result(llt); 20 | int counter = 0; 21 | 22 | if(!R_IsNA(a)){ // Weighted and non-weighted, alpha-transformed 23 | 24 | ////////////////////////////////////////////////////// 25 | // Check for valid Yfull argument 26 | if(Yfull.nrow() == NumericMatrix(1, 1).nrow() && 27 | Yfull.ncol() == NumericMatrix(1, 1).ncol()){ 28 | 29 | stop("User must provide valid Yfull argument for alpha-transformation."); 30 | } 31 | 32 | // Raise all of X to the a power 33 | for(int i = 0; i < X.nrow(); i++){ 34 | for(int j = 0; j < X.ncol(); j++){ 35 | X(i, j) = pow(X(i, j), a); 36 | } 37 | } 38 | 39 | // Raise all of Xfull to the a power 40 | NumericMatrix Xfull = clone(Yfull); 41 | int fullfeats = Xfull.ncol(); 42 | for(int i = 0; i < Xfull.nrow(); i++){ 43 | for(int j = 0; j < Xfull.ncol(); j++){ 44 | Xfull(i, j) = pow(Xfull(i, j), a); 45 | } 46 | } 47 | ////////////////////////////////////////////////////// 48 | 49 | if(weighted){ 50 | 51 | ////////////////////////////////////////////////////// 52 | // Check for valid Wfull argument 53 | if(Wfull.nrow() == NumericMatrix(1, 1).nrow() && 54 | Wfull.ncol() == NumericMatrix(1, 1).ncol()){ 55 | 56 | stop("User must provide valid Wfull argument for weighted alpha-transformation."); 57 | } 58 | ////////////////////////////////////////////////////// 59 | 60 | // Calculate alpha-transformed mean using the across-group means 61 | Rcpp::NumericVector Wij(nfeats); 62 | Rcpp::NumericVector Wfullij(fullfeats); 63 | Rcpp::NumericVector Xiscaled(nfeats); 64 | Rcpp::NumericVector Xjscaled(nfeats); 65 | Rcpp::NumericVector Xz(nfeats); 66 | Rcpp::NumericVector Xfullz(fullfeats); 67 | for(int i = 1; i < nfeats; i++){ 68 | for(int j = 0; j < i; j++){ 69 | Wij = 2 * W(_, i) * W(_, j) / (W(_, i) + W(_, j)); 70 | Wfullij = 2 * Wfull(_, i) * Wfull(_, j) / (Wfull(_, i) + Wfull(_, j)); 71 | Xiscaled = X(_, i) / wtmRcpp(Xfull(_, i), Wfullij); 72 | Xjscaled = X(_, j) / wtmRcpp(Xfull(_, j), Wfullij); 73 | Xz = X(_, i) - X(_, j); 74 | Xfullz = Xfull(_, i) - Xfull(_, j); 75 | double Mz = sum(Wij * (Xiscaled - Xjscaled) / sum(Wij)); 76 | double Cz = sum(Wij * Xz) / sum(Wij) + 77 | (sum(Wfullij * Xfullz) - sum(Wij * Xz)) / 78 | (sum(Wfullij) - sum(Wij)); 79 | result(counter) = (Cz/2 + Mz) / a; 80 | counter += 1; 81 | } 82 | } 83 | 84 | }else{ 85 | 86 | // Calculate alpha-transformed mean using the across-group means 87 | Rcpp::NumericVector Xz(nfeats); 88 | Rcpp::NumericVector Xfullz(fullfeats); 89 | double N1 = X.nrow(); 90 | double NT = Xfull.nrow(); 91 | for(int i = 1; i < nfeats; i++){ 92 | for(int j = 0; j < i; j++){ 93 | Xz = X(_, i) - X(_, j); 94 | Xfullz = Xfull(_, i) - Xfull(_, j); 95 | double Mz = mean(X(_, i) / mean(Xfull(_, i)) - mean(X(_, j) / mean(Xfull(_, j)))); 96 | double Cz = sum(Xz) / N1 + 97 | (sum(Xfullz) - sum(Xz)) / 98 | (NT - N1); 99 | result(counter) = (Cz/2 + Mz) / a; 100 | counter += 1; 101 | } 102 | } 103 | } 104 | 105 | }else{ // Weighted and non-weighted, non-transformed 106 | 107 | if(weighted){ 108 | 109 | Rcpp::NumericVector Wij(nfeats); 110 | for(int i = 1; i < nfeats; i++){ 111 | for(int j = 0; j < i; j++){ 112 | Wij = 2 * W(_, i) * W(_, j) / (W(_, i) + W(_, j)); 113 | result(counter) = wtmRcpp(log(X(_, i) / X(_, j)), Wij); 114 | counter += 1; 115 | } 116 | } 117 | 118 | }else{ 119 | 120 | for(int i = 1; i < nfeats; i++){ 121 | for(int j = 0; j < i; j++){ 122 | result(counter) = mean(log(X(_, i) / X(_, j))); 123 | counter += 1; 124 | } 125 | } 126 | } 127 | } 128 | 129 | return result; 130 | } 131 | -------------------------------------------------------------------------------- /src/graflex.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | using namespace Rcpp; 4 | 5 | // Optimized function to calculate the contingency table and the odds ratio 6 | // [[Rcpp::export]] 7 | NumericVector getOR(const IntegerMatrix& A, const IntegerMatrix& G) { 8 | int ncol = A.ncol(); 9 | int a = 0, b = 0, c = 0, d = 0; 10 | 11 | for (int j = 0; j < ncol - 1; ++j) { 12 | for (int i = j + 1; i < ncol; ++i) { 13 | int a_val = A(i, j), g_val = G(i, j); 14 | a += (1 - a_val) * (1 - g_val); // 00 15 | b += (1 - a_val) * g_val; // 01 16 | c += a_val * (1 - g_val); // 10 17 | d += a_val * g_val; // 11 18 | } 19 | } 20 | 21 | double odds_ratio = static_cast(a * d) / (b * c); 22 | double log_odds_ratio = std::log(odds_ratio); 23 | 24 | return NumericVector::create(a, b, c, d, odds_ratio, log_odds_ratio, R_NaN, R_NaN); 25 | } 26 | 27 | // Optimized function to calculate the contingency table and the odds ratio, given a permuted index vector 28 | // [[Rcpp::export]] 29 | NumericVector getORperm(const IntegerMatrix& A, const IntegerMatrix& G, const IntegerVector& perm) { 30 | int ncol = A.ncol(); 31 | int a = 0, b = 0, c = 0, d = 0; 32 | 33 | for (int j = 0; j < ncol - 1; ++j) { 34 | int pj = perm[j]; 35 | for (int i = j + 1; i < ncol; ++i) { 36 | int a_val = A(perm[i], pj), g_val = G(i, j); 37 | a += (1 - a_val) * (1 - g_val); 38 | b += (1 - a_val) * g_val; 39 | c += a_val * (1 - g_val); 40 | d += a_val * g_val; 41 | } 42 | } 43 | 44 | double odds_ratio = static_cast(a * d) / (b * c); 45 | double log_odds_ratio = std::log(odds_ratio); 46 | 47 | return NumericVector::create(a, b, c, d, odds_ratio, log_odds_ratio, R_NaN, R_NaN); 48 | } 49 | 50 | // Function to calculate the odds ratio and other relevant info for each permutation 51 | // [[Rcpp::export]] 52 | NumericMatrix permuteOR(const IntegerMatrix& A, const IntegerMatrix& G, int p = 100) { 53 | int ncol = A.ncol(); 54 | NumericMatrix or_table(p, 8); 55 | 56 | // calculate the odds ratio for each permutation 57 | for (int i = 0; i < p; ++i) { 58 | IntegerVector perm = sample(ncol, ncol, false) - 1; 59 | or_table(i, _) = getORperm(A, G, perm); 60 | // TODO should I downsample the pairs (up to a maximum) to be checked? 61 | // So in this case, we would check how likely we get by chance an OR from the downsampled 62 | // permuted data that is higher/lower than the OR on the downsampled empirical data 63 | } 64 | 65 | return(or_table); 66 | } 67 | 68 | // Function to calculate the FDR, given the actual odds ratio and the permuted odds ratios 69 | // [[Rcpp::export]] 70 | List getFDR(double actual, const NumericVector& permuted) { 71 | int n = permuted.size(); 72 | int count_over = 0; 73 | int count_under = 0; 74 | 75 | // Count values above and below the actual value 76 | for (int i = 0; i < n; ++i) { 77 | double current = permuted[i]; 78 | if (current >= actual) ++count_over; 79 | if (current <= actual) ++count_under; 80 | } 81 | 82 | // Calculate FDR for both "over" and "under" 83 | double fdr_over = static_cast(count_over) / n; 84 | double fdr_under = static_cast(count_under) / n; 85 | 86 | // Return both FDR values as a named list 87 | return List::create( 88 | Named("over") = fdr_over, 89 | Named("under") = fdr_under 90 | ); 91 | } 92 | 93 | // Function to calculate the G matrix from the Gk vector 94 | // [[Rcpp::export]] 95 | IntegerMatrix getG(const IntegerVector& Gk) { 96 | int n = Gk.size(); 97 | IntegerMatrix G(n, n); 98 | 99 | for (int i = 0; i < n; ++i) { 100 | int gi = Gk[i]; 101 | G(i, i) = gi * gi; 102 | for (int j = 0; j < i; ++j) { 103 | int value = gi * Gk[j]; 104 | G(i, j) = value; 105 | G(j, i) = value; 106 | } 107 | } 108 | 109 | return G; 110 | } 111 | 112 | // Function to calculate the odds ratio and FDR, given the adjacency matrix A and the knowledge graph G 113 | // [[Rcpp::export]] 114 | NumericVector graflex(const IntegerMatrix& A, const IntegerVector& Gk, int p = 100) { 115 | 116 | // Calculate Gk 117 | IntegerMatrix G = getG(Gk); 118 | 119 | // get the actual odds ratio 120 | NumericVector actual = getOR(A, G); 121 | 122 | // skip if the actual value is NaN, because then the FDR is also NaN 123 | if (!std::isnan(actual(4))) { 124 | 125 | // get distribution of odds ratios on permuted data 126 | NumericMatrix permuted = permuteOR(A, G, p); 127 | 128 | // calculate the FDR 129 | List fdr = getFDR(actual(4), permuted(_, 4)); 130 | actual(6) = as(fdr["under"]); 131 | actual(7) = as(fdr["over"]); 132 | } 133 | 134 | return actual; 135 | } 136 | -------------------------------------------------------------------------------- /R/3-shared-getCutoff.R: -------------------------------------------------------------------------------- 1 | #' Get a meaningful cutoff based on the FDR values from permutation tests. 2 | #' 3 | #' @param object A \code{propd} or \code{propr} object. 4 | #' @param fdr A float value for the false discovery rate. 5 | #' Default is 0.05. 6 | #' @param window_size An integer. Default is 1. When it is greater than 1, 7 | #' the function will return a meaningful cutoff based on the moving 8 | #' average of the FDR values. This is useful when the FDR values are 9 | #' noisy and the user wants to smooth them out. 10 | #' @return A cutoff value. 11 | #' @export 12 | getCutoffFDR <- function(object, fdr = 0.05, window_size = 1) { 13 | if (!"fdr" %in% slotNames(object)) { 14 | stop("Please run updateCutoffs() before calling this function.") 15 | } 16 | if (nrow(object@fdr) == 0) { 17 | stop("No FDR values found. Please run updateCutoffs() before calling this function.") 18 | } 19 | if (fdr < 0 | fdr > 1) { 20 | stop("Provide a FDR cutoff from [0, 1].") 21 | } 22 | 23 | # get data frame 24 | df <- object@fdr 25 | 26 | # apply moving average to FDR values, if window_size > 1 27 | if (window_size > 1) { 28 | message("Applying moving average to FDR values.") 29 | df$FDR <- getMovingAverage(df$FDR, window_size) 30 | } 31 | 32 | # get index of FDR values below the threshold 33 | index <- (df$FDR <= fdr) & (is.finite(df$FDR)) 34 | if (!any(index)) { 35 | warning("No significant cutoff found for the given FDR = ", fdr) 36 | return(FALSE) 37 | } 38 | 39 | # get cutoff 40 | direct <- FALSE 41 | if (inherits(object, "propr")) direct <- object@direct 42 | if (direct) { 43 | cutoff <- min(df$cutoff[index]) 44 | } else{ 45 | cutoff <- max(df$cutoff[index]) 46 | } 47 | 48 | return(cutoff) 49 | } 50 | 51 | #' Calculate a theta Cutoff based on the F-statistic. 52 | #' 53 | #' This function uses the F distribution to calculate a cutoff of 54 | #' theta for a p-value given by the \code{pval} argument. 55 | #' 56 | #' If the argument \code{fdr = TRUE}, this function returns the 57 | #' empiric cutoff that corresponds to the FDR-adjusted p-value 58 | #' stored in the \code{@@results$FDR} slot. 59 | #' 60 | #' @param object A \code{\link{propd}} object. 61 | #' @param pval A p-value at which to calculate a theta cutoff. 62 | #' @param fdr_adjusted A boolean. Toggles whether to calculate the theta 63 | #' cutoff for an FDR-adjusted p-value. 64 | #' @return A cutoff of theta from [0, 1]. 65 | #' @export 66 | getCutoffFstat <- function(object, pval = 0.05, fdr_adjusted = FALSE) { 67 | if (!"Fstat" %in% colnames(object@results)) { 68 | stop("Please run updateF() on propd object before.") 69 | } 70 | if (pval < 0 | pval > 1) { 71 | stop("Provide a p-value cutoff from [0, 1].") 72 | } 73 | 74 | if (fdr_adjusted) { 75 | message("Alert: Returning an empiric cutoff based on the $FDR slot.") 76 | index <- (object@results$FDR <= pval) & (is.finite(object@results$FDR)) 77 | if (any(index)) { 78 | cutoff <- max(object@results$theta[index]) 79 | } else{ 80 | warning("No significant cutoff found for the given p-value.") 81 | cutoff <- FALSE 82 | } 83 | 84 | } else{ 85 | message("Alert: Returning an cutoff based on the F-statistic.") 86 | # Compute based on theory 87 | K <- length(unique(object@group)) 88 | N <- length(object@group) + object@dfz # population-level metric (i.e., N) 89 | Q <- stats::qf(pval, K - 1, N - K, lower.tail = FALSE) 90 | # # Fstat <- (N - 2) * (1 - object@theta$theta) / object@theta$theta 91 | # # Q = Fstat 92 | # # Q = (N-2) * (1-theta) / theta 93 | # # Q / (N-2) = (1/theta) - 1 94 | # # 1/theta = Q / (N-2) + 1 = Q(N-2)/(N-2) 95 | # # theta = (N-2)/(Q+(N-2)) 96 | cutoff <- (N - 2) / (Q + (N - 2)) 97 | } 98 | 99 | return(cutoff) 100 | } 101 | 102 | #' Caclulate the moving average of a vector. 103 | #' @param values A numeric vector. 104 | #' @param window_size An integer. The size of the window to calculate the 105 | #' moving average. Default is 1. 106 | getMovingAverage <- function(values, window_size = 1) { 107 | 108 | if (any(is.na(values))) { 109 | message("Moving averages are calculated for a vector containing NAs.") 110 | } 111 | 112 | # Initialize the result vector 113 | n <- length(values) 114 | result <- numeric(n) 115 | 116 | for (i in 1:n) { 117 | # Determine the window indices 118 | if (window_size %% 2 == 0) { 119 | start_idx <- max(1, i - (window_size / 2 - 1)) 120 | end_idx <- min(n, i + window_size / 2) 121 | }else{ 122 | start_idx <- max(1, i - floor(window_size / 2)) 123 | end_idx <- min(n, i + floor(window_size / 2)) 124 | } 125 | 126 | # Calculate the average for the current window 127 | if (is.finite(values[i])){ 128 | result[i] <- mean(values[start_idx:end_idx], na.rm=TRUE) # NA values are removed, to avoid propagation of NAs 129 | }else{ 130 | result[i] <- values[i] # this keeps the NA values corresponding to that position 131 | } 132 | } 133 | 134 | return(result) 135 | } -------------------------------------------------------------------------------- /tests/testthat/test-PROPD-weight.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | fetch_weights <- function(counts, design){ 5 | #this function calculates the new default weights, i.e., sample reliability weights using limma 6 | logX <- log(counts) 7 | z.geo <- rowMeans(logX) 8 | z.lr <- as.matrix(sweep(logX, 1, z.geo, "-")) 9 | lz.sr <- t(z.lr + mean(z.geo)) #corresponds to log(z.sr) in updateF function 10 | 11 | #use quality weights from limma: 12 | aw <- limma::arrayWeights(lz.sr, design) 13 | W <- t(sweep(matrix(1, nrow(lz.sr), ncol(lz.sr)), 2, aw, `*`)) #get the correct dimensions 14 | return(W) 15 | } 16 | 17 | # data 18 | keep <- iris$Species %in% c("setosa", "versicolor") 19 | counts <- iris[keep, 1:4] * 10 20 | group <- ifelse(iris[keep, "Species"] == "setosa", "A", "B") 21 | 22 | 23 | test_that("test that weights are properly incorporated to lrv", { 24 | 25 | # get weights 26 | design <- stats::model.matrix(~ . + 0, data = as.data.frame(group)) 27 | W <- fetch_weights(counts,design) 28 | 29 | # calculate lrv using propr 30 | counts <- as.matrix(counts) 31 | lrv_w <- propr:::lrv(counts, W, TRUE, NA, counts, W) 32 | 33 | # calculate expected lrv with weights manually 34 | lrv_e <- c() 35 | for (i in 2:ncol(counts)) { 36 | for (j in 1:(i-1)) { 37 | Wij <- 2 * W[, i] * W[, j] / (W[, i] + W[, j]) 38 | x <- log(counts[, i] / counts[, j]) 39 | xbar <- sum(x * Wij) / sum(Wij) 40 | lrv <- sum(Wij * (x - xbar)^2) / (sum(Wij) - sum(Wij^2) / sum(Wij)) 41 | lrv_e <- c(lrv_e, lrv) 42 | #lrv_e <- c(lrv_e, propr:::wtvRcpp(log(counts[, i] / counts[, j]), Wij)) # this is the same as above 43 | } 44 | } 45 | 46 | expect_equal(lrv_w, lrv_e) 47 | 48 | }) 49 | 50 | test_that("test that weights are properly incorporated to lrm", { 51 | # get weights 52 | design <- stats::model.matrix(~ . + 0, data = as.data.frame(group)) 53 | W <- fetch_weights(counts,design) 54 | 55 | # calculate lrm using propr 56 | counts <- as.matrix(counts) 57 | lrm_w <- propr:::lrm(counts, W, TRUE, NA, counts, W) 58 | 59 | # calculate expected lrm with weights manually 60 | lrm_e <- c() 61 | for (i in 2:ncol(counts)) { 62 | for (j in 1:(i-1)) { 63 | Wij <- 2 * W[, i] * W[, j] / (W[, i] + W[, j]) 64 | x <- log(counts[, i] / counts[, j]) 65 | xbar <- sum(x * Wij) / sum(Wij) 66 | lrm_e <- c(lrm_e, xbar) 67 | } 68 | } 69 | 70 | expect_equal(lrm_w, lrm_e) 71 | }) 72 | 73 | test_that("test that weights are properly incorporated to omega" ,{ 74 | # get weights 75 | design <- stats::model.matrix(~ . + 0, data = as.data.frame(group)) 76 | W <- fetch_weights(counts,design) 77 | 78 | # calculate omega using propr 79 | counts <- as.matrix(counts) 80 | omega_w <- propr:::omega(W) 81 | 82 | # calculate expected omega with weights manually 83 | omega_e <- c() 84 | for (i in 2:ncol(counts)) { 85 | for (j in 1:(i-1)) { 86 | Wij <- 2 * W[, i] * W[, j] / (W[, i] + W[, j]) 87 | omega_e <- c(omega_e, sum(Wij) - sum(Wij^2) / sum(Wij)) 88 | } 89 | } 90 | 91 | expect_equal(omega_w, omega_e) 92 | }) 93 | 94 | test_that("test that weights are properly incorporated to theta", { 95 | # get weights 96 | design <- stats::model.matrix(~ . + 0, data = as.data.frame(group)) 97 | W <- fetch_weights(counts,design) 98 | 99 | # calculate theta using propr 100 | counts <- as.matrix(counts) 101 | theta_w <- propr:::calculate_theta(counts, group, weighted=TRUE)$theta 102 | 103 | # calculate expected theta with weights manually 104 | theta_e <- c() 105 | groups <- lapply(unique(group), function(g) g == group) 106 | Wfull <- W 107 | W1 <- W[groups[[1]],] 108 | W2 <- W[groups[[2]],] 109 | counts1 <- counts[groups[[1]],] 110 | counts2 <- counts[groups[[2]],] 111 | for (i in 2:ncol(counts)) { 112 | for (j in 1:(i-1)) { 113 | # calculate lrv and omega for group 1 114 | Wij1 <- 2 * W1[, i] * W1[, j] / (W1[, i] + W1[, j]) 115 | lrv1 <- propr:::wtvRcpp(log(counts1[, i] / counts1[, j]), Wij1) 116 | omega1 <- sum(Wij1) - sum(Wij1^2) / sum(Wij1) 117 | 118 | # calculate lrv and omega for group 2 119 | Wij2 <- 2 * W2[, i] * W2[, j] / (W2[, i] + W2[, j]) 120 | lrv2 <- propr:::wtvRcpp(log(counts2[, i] / counts2[, j]), Wij2) 121 | omega2 <- sum(Wij2) - sum(Wij2^2) / sum(Wij2) 122 | 123 | # calculate lrv and omega between groups 124 | Wij <- 2 * Wfull[, i] * Wfull[, j] / (Wfull[, i] + Wfull[, j]) 125 | lrv <- propr:::wtvRcpp(log(counts[, i] / counts[, j]), Wij) 126 | omega <- sum(Wij) - sum(Wij^2) / sum(Wij) 127 | 128 | # calculate theta 129 | theta <- (omega1 * lrv1 + omega2 * lrv2) / (omega * lrv) 130 | theta_e <- c(theta_e, theta) 131 | } 132 | } 133 | 134 | expect_equal(theta_w, theta_e) 135 | }) 136 | -------------------------------------------------------------------------------- /man/propr.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/1-propr-OOP.R, R/1-propr-help.R, R/1-propr.R 3 | \docType{class} 4 | \name{propr-class} 5 | \alias{propr-class} 6 | \alias{show,propr-method} 7 | \alias{propr} 8 | \title{The propr Package} 9 | \usage{ 10 | \S4method{show}{propr}(object) 11 | 12 | propr( 13 | counts, 14 | metric = c("rho", "phi", "phs", "cor", "vlr", "ppcor", "pcor", "pcor.shrink", 15 | "pcor.bshrink"), 16 | ivar = "clr", 17 | select = NA, 18 | symmetrize = FALSE, 19 | alpha = NA, 20 | p = 0, 21 | permutation_option = c("feature-wise", "sample-wise") 22 | ) 23 | } 24 | \arguments{ 25 | \item{object}{A \code{propr} object.} 26 | 27 | \item{counts}{A data matrix representing counts. 28 | It is assumed that the matrix contains numerical values only.} 29 | 30 | \item{metric}{A character vector indicating the metric used for computing 31 | the association matrix. It can take the following values: 32 | - "rho": Propr matrix based on the rho coefficient. 33 | - "phi": Propr matrix based on the phi coefficient. 34 | - "phs": Propr matrix based on the symmetric phi coefficient. 35 | - "cor": Propr matrix based on the simple Pearson correlation coefficient. 36 | - "vlr": Propr matrix based on the variance of log-ratio (VLR). 37 | - "pcor": Propr matrix based on the partial correlation coefficient 38 | (using ppcor package). 39 | - "pcor.shrink": Propr matrix based on the shrinkage-estimated partial 40 | correlation coefficient (using corpcor package). 41 | - "pcor.bshrink": Propr matrix based on the partial correlation 42 | coefficient with basis shrinkage (ivar argument must be 'clr' or 'alr').} 43 | 44 | \item{ivar}{An indicator specifying the method for log-ratio transformation. 45 | It can take the following values: 46 | - "clr" (default): Centered log-ratio transformation. 47 | - "alr": Additive log-ratio transformation ("pcor.bshrink" metric only). 48 | - "iqlr": Inter-quartile log-ratio transformation from ALDEx2. 49 | - The explicit name(s) or index(es) of variable(s) to use as a reference. 50 | - Use NA to skip log-ratio transformation and any other pre-processing, like 51 | zero replacement. This is useful when the input data is already pre-processed.} 52 | 53 | \item{select}{A numeric vector representing the indices of features to be 54 | used for computing the Propr matrix. This argument is optional. If 55 | provided, it reduces the data size by using only the selected features.} 56 | 57 | \item{symmetrize}{A logical value indicating whether to force symmetry in 58 | the output Propr matrix when the metric is "phi". If `TRUE`, the function 59 | will symmetrize the matrix; otherwise, it will return the original matrix.} 60 | 61 | \item{alpha}{The alpha parameter used in the alpha log-ratio transformation.} 62 | 63 | \item{p}{The number of permutations to perform for calculating the false 64 | discovery rate (FDR). The default is 0.} 65 | 66 | \item{permutation_option}{A character string indicating if permute the data 67 | sample-wise or feature-wise. Default is "feature-wise"} 68 | } 69 | \value{ 70 | A propr object containing the Propr matrix, associated log-ratio 71 | transformation, and other calculated statistics. 72 | } 73 | \description{ 74 | Welcome to the \code{propr} package! 75 | 76 | To learn more about calculating proportionality, see 77 | Details. 78 | 79 | To learn more about differential proportionality, see 80 | \code{\link{propd}}. 81 | 82 | To learn more about compositional data analysis, see 83 | \code{citation("propr")}. 84 | } 85 | \details{ 86 | The function performs log-ratio transformation and computes a 87 | Propr matrix using different measures of association. 88 | } 89 | \section{Slots}{ 90 | 91 | \describe{ 92 | \item{\code{counts}}{A data.frame. Stores the original "count matrix" input.} 93 | 94 | \item{\code{alpha}}{A double. Stores the alpha value used for transformation.} 95 | 96 | \item{\code{metric}}{A character string. The metric used to calculate proportionality.} 97 | 98 | \item{\code{ivar}}{A vector. The reference used to calculate proportionality.} 99 | 100 | \item{\code{logratio}}{A data.frame. Stores the transformed "count matrix".} 101 | 102 | \item{\code{matrix}}{A matrix. Stores the proportionality matrix.} 103 | 104 | \item{\code{pairs}}{A vector. Indexes the proportional pairs of interest.} 105 | 106 | \item{\code{results}}{A data.frame. Stores the pairwise \code{propr} measurements.} 107 | 108 | \item{\code{permutes}}{A list. Stores the shuffled transformed "count matrix" 109 | instances, used to reproduce permutations of \code{propr}.} 110 | 111 | \item{\code{fdr}}{A data.frame. Stores the FDR cutoffs for \code{propr}.} 112 | }} 113 | 114 | \section{Methods (by generic)}{ 115 | 116 | \code{show:} Method to show \code{propr} object. 117 | } 118 | 119 | \examples{ 120 | # Sample input count data 121 | data <- matrix(c(10, 5, 15, 20, 30, 25), nrow = 2, byrow = TRUE) 122 | 123 | # Calculate Propr matrix using correlation coefficient 124 | result_cor <- propr(data, metric = "cor", ivar = "clr") 125 | 126 | # Calculate Propr matrix using variance of log-ratio (VLR) 127 | result_vlr <- propr(data, metric = "vlr", ivar = "clr") 128 | 129 | # Calculate Propr matrix using partial correlation coefficient 130 | result_pcor <- propr(data, metric = "pcor", ivar = "clr") 131 | 132 | } 133 | -------------------------------------------------------------------------------- /R/3-shared-getResults.R: -------------------------------------------------------------------------------- 1 | #' Get Results from Object 2 | #' 3 | #' This function provides a unified wrapper to retrieve results 4 | #' from a \code{propr} or \code{propd} object. 5 | #' 6 | #' @param object A \code{propr} or \code{propd} object. 7 | #' 8 | #' @return A \code{data.frame} of results. 9 | #' 10 | #' @export 11 | getResults <- 12 | function(object) { 13 | results <- object@results 14 | names <- colnames(object@counts) 15 | results$Partner <- names[results$Partner] 16 | results$Pair <- names[results$Pair] 17 | return(results) 18 | } 19 | 20 | #' Get Significant Results from Object based on the permutation tests. 21 | #' 22 | #' This function retrieves results from a \code{propr} or \code{propd} object keeping only the 23 | #' statistically significant pairs. The significance is determined by the cutoff value for which 24 | #' the false discovery rate (FDR) is less or equal than the given value 'fdr'. The significant 25 | #' pairs are those that have a value greater/less or equal than the cutoff, depending on the metric. 26 | #' 27 | #' @inheritParams getAdjacencyFDR 28 | #' @return A \code{data.frame} of results. 29 | #' 30 | #' @export 31 | getSignificantResultsFDR <- 32 | function(object, fdr = 0.05, window_size = 1) { 33 | 34 | if (inherits(object, "propr")) { 35 | results <- getSignificantResultsFDR.propr(object, fdr=fdr, window_size=window_size) 36 | 37 | } else if(inherits(object, "propd")) { 38 | results <- getSignificantResultsFDR.propd(object, fdr=fdr, window_size=window_size) 39 | 40 | } else { 41 | stop("Please provide a 'propr' or 'propd' object.") 42 | } 43 | 44 | return(results) 45 | } 46 | 47 | #' @rdname getSignificantResultsFDR 48 | #' @section Methods: 49 | #' \code{getSignificantResultsFDR.propr:} 50 | #' This function retrieves results from a \code{propr} object keeping 51 | #' only the statistically significant pairs. 52 | #' @export 53 | getSignificantResultsFDR.propr <- 54 | function(object, fdr = 0.05, window_size = 1) { 55 | 56 | # function to subset the results data frame based on the cutoff 57 | subsetBeyondCutoff <- function(data, cutoff, tails=c('right', 'both')) { 58 | tails <- match.arg(tails) 59 | if (!cutoff) return(data[0,]) # return empty data frame when no cutoff found 60 | 61 | # check only the positive values if tails is 'right' 62 | if (tails == 'right') { 63 | data <- data[which(data$propr > 0),] 64 | } 65 | 66 | # check both sides if tails is 'both' 67 | vals <- data$propr 68 | if (tails == 'both') { 69 | vals <- abs(vals) 70 | } 71 | 72 | # return the significant values based on the cutoff 73 | if (object@direct) { 74 | return(data[which(vals >= cutoff), ]) 75 | } else { 76 | return(data[which(vals <= cutoff), ]) 77 | } 78 | } 79 | 80 | # define results data frame 81 | results <- getResults(object) 82 | 83 | # get the significant positive values 84 | cutoff <- getCutoffFDR(object, fdr=fdr, window_size=window_size) 85 | results <- subsetBeyondCutoff(results, cutoff, tails=object@tails) 86 | 87 | return(results) 88 | } 89 | 90 | #' @rdname getSignificantResultsFDR 91 | #' @section Methods: 92 | #' \code{getSignificantResultsFDR.propd:} 93 | #' This function retrieves results from a \code{propd} object keeping 94 | #' only the statistically significant pairs. 95 | #' @export 96 | getSignificantResultsFDR.propd <- 97 | function(object, fdr = 0.05, window_size = 1) { 98 | 99 | results <- getResults(object) 100 | cutoff <- getCutoffFDR(object, fdr=fdr, window_size=window_size) 101 | if (cutoff) { 102 | return(results[which(results$theta <= cutoff), ]) 103 | } else { 104 | return(results[0,]) 105 | } 106 | } 107 | 108 | #' Get Significant Results based on the F-stats. 109 | #' 110 | #' This function provides a unified wrapper to retrieve results 111 | #' from a \code{propd} object keeping only the statistically 112 | #' significant pairs. Note that it can only be applied to theta_d, 113 | #' as updateF only works for theta_d. 114 | #' 115 | #' @inheritParams getAdjacencyFstat 116 | #' @return A \code{data.frame} of results. 117 | #' 118 | #' @export 119 | getSignificantResultsFstat <- 120 | function(object, pval = 0.05, fdr_adjusted = TRUE) { 121 | 122 | if (!"Fstat" %in% colnames(object@results)) { 123 | stop("Please run updateF() on propd object before.") 124 | } 125 | if (pval < 0 | pval > 1) { 126 | stop("Provide a p-value cutoff from [0, 1].") 127 | } 128 | 129 | # get results data frame 130 | results <- getResults(object) 131 | 132 | # get significant theta based on the FDR adjusted empirical p-values 133 | if (fdr_adjusted) { 134 | message("Alert: Returning the significant pairs based on the FDR adjusted p-values.") 135 | results <- results[which(results$FDR <= pval), ] 136 | 137 | # get siniginicant theta based on the F-statistic cutoff 138 | } else { 139 | message("Alert: Returning the significant pairs based on the F-statistic cutoff.") 140 | cutoff <- getCutoffFstat(object, pval = pval, fdr_adjusted = FALSE) 141 | if (cutoff) { 142 | results <- results[which(results$theta <= cutoff), ] 143 | } else { 144 | results <- results[0,] 145 | } 146 | } 147 | 148 | return(results) 149 | } 150 | -------------------------------------------------------------------------------- /man/propd.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/2-propd-OOP.R, R/2-propd-help.R, R/2-propd.R, 3 | % R/2b-propd-frontend.R 4 | \docType{class} 5 | \name{propd-class} 6 | \alias{propd-class} 7 | \alias{show,propd-method} 8 | \alias{propd} 9 | \alias{setDisjointed} 10 | \alias{setEmergent} 11 | \alias{setActive} 12 | \alias{updateF} 13 | \title{The propd Method} 14 | \usage{ 15 | \S4method{show}{propd}(object) 16 | 17 | propd(counts, group, alpha = NA, p = 0, weighted = FALSE, shrink = FALSE) 18 | 19 | setDisjointed(propd) 20 | 21 | setEmergent(propd) 22 | 23 | setActive(propd, what = "theta_d") 24 | 25 | updateF(propd, moderated = TRUE, ivar = "clr") 26 | } 27 | \arguments{ 28 | \item{object}{A \code{propd} object.} 29 | 30 | \item{counts}{A data matrix representing counts. 31 | It is assumed that the matrix contains numerical values only.} 32 | 33 | \item{group}{A character vector representing group labels indicating the 34 | assignment of each count to different groups.} 35 | 36 | \item{alpha}{The alpha parameter used in the alpha log-ratio transformation.} 37 | 38 | \item{p}{The number of permutations to perform for calculating the false 39 | discovery rate (FDR). The default is 0.} 40 | 41 | \item{weighted}{A logical value indicating whether weighted calculations 42 | should be performed.} 43 | 44 | \item{shrink}{A logical value indicating whether to apply shrinkage} 45 | 46 | \item{propd}{A \code{propd} object.} 47 | 48 | \item{what}{A character string. The theta type to set active.} 49 | 50 | \item{moderated}{For \code{updateF}, a boolean. Toggles 51 | whether to calculate a moderated F-statistic.} 52 | 53 | \item{ivar}{See \code{propr} method.} 54 | } 55 | \value{ 56 | A \code{propd} object containing the computed theta values, 57 | associated count matrix, group labels, and other calculated statistics. 58 | } 59 | \description{ 60 | Welcome to the \code{propd} method! 61 | 62 | Let \eqn{X} and \eqn{Y} be non-zero positive feature vectors 63 | measured across \eqn{N} samples belonging to one of two groups, 64 | sized \eqn{N1} and \eqn{N2}. We use VLR to denote the variance 65 | of the log of the ratio of the vectors \eqn{X} over \eqn{Y}. 66 | We define theta as the weighted sum of the within-group VLR 67 | divided by the weighted total VLR. 68 | 69 | The \code{propd} method calculates theta. This fails in 70 | the setting of zero counts. The \code{propd} method 71 | will use a Box-Cox transformation to approximate VLR based on 72 | the parameter \eqn{\alpha}, if provided. We refer the user to 73 | the vignette for more details. 74 | 75 | Note that Group 1 always refers to the first element of the 76 | \code{group} vector argument supplied to \code{propd}. 77 | } 78 | \details{ 79 | The \code{propd} function creates a \code{propd} object, which is 80 | used for differential analysis of regulatory relationships between features. 81 | It performs log-ratio transformation, calculates the variance of log-ratio 82 | (VLR), and computes the theta values using different formulas. The object 83 | stores the count matrix, group labels, alpha parameter, and other relevant 84 | information needed for further analysis and visualization. 85 | } 86 | \section{Slots}{ 87 | 88 | \describe{ 89 | \item{\code{counts}}{A data.frame. Stores the original "count matrix" input.} 90 | 91 | \item{\code{alpha}}{A double. Stores the alpha value used for transformation.} 92 | 93 | \item{\code{group}}{A character vector. Stores the original group labels.} 94 | 95 | \item{\code{weighted}}{A logical. Stores whether the theta is weighted.} 96 | 97 | \item{\code{weights}}{A matrix. If weighted, stores the limma-based weights.} 98 | 99 | \item{\code{active}}{A character. Stores the name of the active theta type.} 100 | 101 | \item{\code{Fivar}}{ANY. Stores the reference used to moderate theta.} 102 | 103 | \item{\code{dfz}}{A double. Stores the prior df used to moderate theta.} 104 | 105 | \item{\code{results}}{A data.frame. Stores the pairwise \code{propd} measurements.} 106 | 107 | \item{\code{permutes}}{A data.frame. Stores the shuffled group labels, 108 | used to reproduce permutations of \code{propd}.} 109 | 110 | \item{\code{fdr}}{A data.frame. Stores the FDR cutoffs for \code{propd}.} 111 | }} 112 | 113 | \section{Methods (by generic)}{ 114 | 115 | \code{show:} Method to show \code{propd} object. 116 | } 117 | 118 | \section{Functions}{ 119 | 120 | \code{setDisjointed:} 121 | A wrapper for \code{setActive(propd, what = "theta_d")}. 122 | 123 | 124 | \code{setEmergent:} 125 | A wrapper for \code{setActive(propd, what = "theta_e")}. 126 | 127 | 128 | \code{setActive:} 129 | Build analyses and figures using a specific theta type. For 130 | example, set \code{what = "theta_d"} to analyze disjointed 131 | proportionality and \code{what = "theta_e"} to analyze 132 | emergent proportionality. 133 | 134 | 135 | \code{updateF:} 136 | Use the \code{propd} object to calculate the F-statistic 137 | from theta as described in the Erb et al. 2017 manuscript 138 | on differential proportionality. Optionally calculates a 139 | moderated F-statistic using the limma-voom method. Supports 140 | weighted and alpha transformed theta values. 141 | } 142 | 143 | \examples{ 144 | # Sample input count data and group assignments 145 | data <- iris[1:100, 1:4] 146 | group <- iris[1:100, 5] 147 | 148 | # Create a propd object for differential analysis 149 | result <- propd(data, group, alpha = 0.5) 150 | 151 | } 152 | -------------------------------------------------------------------------------- /tests/testthat/test-SHARED-getAdjacency-propr.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(propr) 3 | 4 | # define data matrix 5 | set.seed(123) 6 | N <- 100 7 | a <- seq(from = 5, to = 15, length.out = N) 8 | b <- a * rnorm(N, mean = 1, sd = 0.1) 9 | c <- rnorm(N, mean = 10) 10 | d <- rnorm(N, mean = 10) 11 | e <- rep(10, N) 12 | X <- data.frame(a, b, c, d, e) 13 | 14 | 15 | test_that("getAdjacencyFDR returns the expected values for pcor.bshrink - clr", { 16 | 17 | # get propr object 18 | pr <- propr(X, metric = "pcor.bshrink", ivar='clr', p=10) 19 | pr <- updateCutoffs(pr, number_of_cutoffs=100) 20 | 21 | # get adjacency matrix 22 | adj <- getAdjacencyFDR(pr) 23 | 24 | # get expected adjacency matrix 25 | adj_expected <- matrix(0, nrow = ncol(X), ncol = ncol(X)) 26 | adj_expected[pr@matrix >= getCutoffFDR(pr)] <- 1 27 | adj_expected[diag(adj_expected)] <- 1 28 | rownames(adj_expected) <- colnames(X) 29 | colnames(adj_expected) <- colnames(X) 30 | 31 | # check that the values are correct 32 | expect_equal(adj, adj_expected) 33 | }) 34 | 35 | test_that("getAdjacencyFDR returns the expected values for pcor.bshrink - alr", { 36 | 37 | # get propr object 38 | pr <- propr(X, metric = "pcor.bshrink", ivar='alr', p=10) 39 | pr <- updateCutoffs(pr, number_of_cutoffs=100) 40 | 41 | # get adjacency matrix 42 | adj <- getAdjacencyFDR(pr) 43 | 44 | # get expected adjacency matrix 45 | adj_expected <- matrix(0, nrow = ncol(X), ncol = ncol(X)) 46 | adj_expected[pr@matrix >= getCutoffFDR(pr)] <- 1 47 | adj_expected[diag(adj_expected)] <- 1 48 | rownames(adj_expected) <- colnames(X) 49 | colnames(adj_expected) <- colnames(X) 50 | 51 | # check that the values are correct 52 | expect_equal(adj, adj_expected) 53 | }) 54 | 55 | test_that("getAdjacencyFDR returns the expected values for rho - clr", { 56 | 57 | # get propr object 58 | pr <- propr(X, metric = "rho", ivar='clr', p=10) 59 | pr <- updateCutoffs(pr, number_of_cutoffs=100) 60 | 61 | # get adjacency matrix 62 | adj <- getAdjacencyFDR(pr) 63 | 64 | # get expected adjacency matrix 65 | adj_expected <- matrix(0, nrow = ncol(X), ncol = ncol(X)) 66 | adj_expected[pr@matrix >= getCutoffFDR(pr)] <- 1 67 | adj_expected[diag(adj_expected)] <- 1 68 | rownames(adj_expected) <- colnames(X) 69 | colnames(adj_expected) <- colnames(X) 70 | 71 | # check that the values are correct 72 | expect_equal(adj, adj_expected) 73 | }) 74 | 75 | test_that("getAdjacencyFDR returns the expected values for rho - 5", { 76 | 77 | # get propr object 78 | pr <- propr(X, metric = "rho", ivar=5, p=10) 79 | pr <- updateCutoffs(pr, number_of_cutoffs=100) 80 | 81 | # get adjacency matrix 82 | adj <- getAdjacencyFDR(pr) 83 | 84 | # get expected adjacency matrix 85 | adj_expected <- matrix(0, nrow = ncol(X), ncol = ncol(X)) 86 | adj_expected[pr@matrix >= getCutoffFDR(pr)] <- 1 87 | adj_expected[diag(adj_expected)] <- 1 88 | rownames(adj_expected) <- colnames(X) 89 | colnames(adj_expected) <- colnames(X) 90 | 91 | # check that the values are correct 92 | expect_equal(adj, adj_expected) 93 | }) 94 | 95 | test_that("getAdjacencyFDR returns the expected values for phs - clr", { 96 | 97 | # get propr object 98 | pr <- propr(X, metric = "phs", ivar='clr', p=10) 99 | pr <- updateCutoffs(pr, number_of_cutoffs=100) 100 | 101 | # get adjacency matrix 102 | adj <- getAdjacencyFDR(pr) 103 | 104 | # get expected adjacency matrix 105 | adj_expected <- matrix(0, nrow = ncol(X), ncol = ncol(X)) 106 | adj_expected[pr@matrix <= getCutoffFDR(pr,)] <- 1 107 | adj_expected[diag(adj_expected)] <- 1 108 | rownames(adj_expected) <- colnames(X) 109 | colnames(adj_expected) <- colnames(X) 110 | 111 | # check that the values are correct 112 | expect_equal(adj, adj_expected) 113 | }) 114 | 115 | test_that("getAdjacencyFDR returns the expected values for phs - 5", { 116 | 117 | # get propr object 118 | pr <- propr(X, metric = "phs", ivar=5, p=10) 119 | pr <- updateCutoffs(pr, number_of_cutoffs=100) 120 | 121 | # get adjacency matrix 122 | adj <- getAdjacencyFDR(pr) 123 | 124 | # get expected adjacency matrix 125 | adj_expected <- matrix(0, nrow = ncol(X), ncol = ncol(X)) 126 | adj_expected[pr@matrix <= getCutoffFDR(pr)] <- 1 127 | adj_expected[diag(adj_expected)] <- 1 128 | rownames(adj_expected) <- colnames(X) 129 | colnames(adj_expected) <- colnames(X) 130 | 131 | # check that the values are correct 132 | expect_equal(adj, adj_expected) 133 | }) 134 | 135 | test_that("getAdjacencyFDR and getSignificantResultsFDR return coherent results", { 136 | 137 | for (metric in c('rho', 'phi', 'phs', 'pcor', 'pcor.bshrink')) { # pcor.shrink does not provide positive values for this dataset, and it gives error when tails = 'right' 138 | print(metric) 139 | 140 | # get propr object 141 | pr <- propr(X, metric=metric, p=10) 142 | 143 | # update FDR values 144 | pr <- updateCutoffs(pr, number_of_cutoffs=100) 145 | 146 | # get adjacency matrix 147 | adj <- getAdjacencyFDR(pr) 148 | 149 | # get significant results 150 | results <- getSignificantResultsFDR(pr) 151 | 152 | # check that the values are correct 153 | for (i in 1:nrow(results)){ 154 | expect_equal(adj[results[i,1], results[i,2]], 1) 155 | } 156 | } 157 | }) 158 | -------------------------------------------------------------------------------- /old_vignettes/d_advanced.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "A Brief Critique of Proportionality" 3 | author: "Thomas Quinn" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{3. A Brief Critique of Proportionality} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | 12 | ## Introduction 13 | 14 | We recognize that this package uses concepts that are not necessarily intuitive. As such, we offer a brief critique of proportionality analysis. Although the user may feel eager to start here, we strongly recommend first reading the companion vignette, "An Introduction to Proportionality". 15 | 16 | ## Sample data 17 | 18 | To facilitate discussion, we simulate count data for 5 features (e.g., genes) labeled "a", "b", "c", "d", and "e", as measured across 100 subjects. 19 | 20 | ```{r} 21 | library(propr) 22 | N <- 100 23 | a <- seq(from = 5, to = 15, length.out = N) 24 | b <- a * rnorm(N, mean = 1, sd = 0.1) 25 | c <- rnorm(N, mean = 10) 26 | d <- rnorm(N, mean = 10) 27 | e <- rep(10, N) 28 | X <- data.frame(a, b, c, d, e) 29 | ``` 30 | 31 | Let us assume that these data $X$ represent absolute abundance counts (i.e., not relative data). We can build a relative dataset, $Y$, by constraining and scaling $X$: 32 | 33 | ```{r} 34 | Y <- X / rowSums(X) * abs(rnorm(N)) 35 | ``` 36 | 37 | ## Spurious correlation 38 | 39 | Next, we compare pairwise scatterplots for the absolute count data and the corresponding relative count data. We see quickly how these relative data suggest a *spurious correlation*: although genes "c" and "d" do not correlate with one another absolutely, their relative quantities do. 40 | 41 | ```{r, dpi = 66, fig.width = 8, fig.height = 8, fig.show = "hold"} 42 | pairs(X) # absolute data 43 | ``` 44 | 45 | ```{r, dpi = 66, fig.width = 8, fig.height = 8, fig.show = "hold"} 46 | pairs(Y) # relative data 47 | ``` 48 | 49 | Spurious correlation is evident by the correlation coefficients too. 50 | 51 | ```{r, warning = FALSE} 52 | suppressWarnings(cor(X)) # absolute correlation 53 | cor(Y) # relative correlation 54 | ``` 55 | 56 | ## An in-depth look at VLR 57 | 58 | In contrast, the **variance of the log-ratios** (VLR), defined as the variance of the logarithm of the ratio of two feature vectors, offers a measure of dependence that (a) does not change with respect to the nature of the data (i.e., absolute or relative), and (b) does not change with respect to the number of features included in the computation. As such, the VLR, constituting the numerator portion of the $\phi$ metric, and a portion of the $\rho$ metric as well, is considered *sub-compositionally coherent*. Yet, while VLR yields valid results for compositional data, it lacks a meaningful scale. 59 | 60 | ```{r} 61 | propr:::proprVLR(Y[, 1:4]) # relative VLR 62 | propr:::proprVLR(X) # absolute VLR 63 | ``` 64 | 65 | ## An in-depth look at clr 66 | 67 | In proportionality, we adjust the arbitrarily large VLR by the variance of its individual constituents. To do this, we need to place samples on a comparable scale. Log-ratio transformation, such as the **centered log-ratio** (clr) transformation, shifts the data onto a "standardized" scale that allows us to compare differences in the VLR-matrix. 68 | 69 | In the next figures, we compare pairwise scatterplots for the clr-transformed absolute count data and the corresponding clr-transformed relative count data. While equivalent, we see a relationship between "c" and "d" that should not exist based on what we know from the non-transformed absolute count data. This demonstrates that, although the clr-transformation helps us compare values across samples, it does not rescue information lost by making absolute data relative. 70 | 71 | ```{r, dpi = 66, fig.width = 8, fig.height = 8, fig.show = "hold"} 72 | pairs(propr:::proprCLR(Y[, 1:4])) # relative clr-transformation 73 | ``` 74 | 75 | ```{r, dpi = 66, fig.width = 8, fig.height = 8, fig.show = "hold"} 76 | pairs(propr:::proprCLR(X)) # absolute clr-transformation 77 | ``` 78 | 79 | Proportionality is a compromise between the advantages of VLR and the disadvantages of clr to establish a measure of dependence that is robust yet interpretable. As such, spurious proportionality is possible when the clr does not adequately approximate an ideal reference. 80 | 81 | ```{r, message = FALSE} 82 | propr(Y[, 1:4])@matrix # relative proportionality with clr 83 | ``` 84 | 85 | ```{r, message = FALSE} 86 | propr(X)@matrix # absolute proportionality with clr 87 | ``` 88 | 89 | ## An in-depth look at alr 90 | 91 | The **additive log-ratio** (alr) adjusts each subject vector by the value of one its own components, chosen as a *reference*. If we select as a reference some feature $D$ with an *a priori* known fixed absolute count across all subjects, we can effectively "back-calculate" absolute data from relative data. When initially crafting the data $X$, we included "e" as this fixed value. 92 | 93 | The following figures compare pairwise scatterplots for alr-transformed relative count data (i.e., $\textrm{alr}(Y)$ with "e" as the reference) and the corresponding absolute count data. We see here how the alr-transformation can eliminate the *spurious correlation* between "c" and "d". 94 | 95 | ```{r, dpi = 66, fig.width = 8, fig.height = 8, fig.show = "hold"} 96 | pairs(propr:::proprALR(Y, ivar = 5)) # relative alr 97 | ``` 98 | 99 | ```{r, dpi = 66, fig.width = 8, fig.height = 8, fig.show = "hold"} 100 | pairs(X[, 1:4]) # absolute data 101 | ``` 102 | 103 | Again, this gets reflected in the results of `propr` when we select "e" as the reference. 104 | 105 | ```{r, message = FALSE} 106 | propr(Y, ivar = 5)@matrix # relative proportionality with alr 107 | ``` 108 | --------------------------------------------------------------------------------