Added R-based tests.

SingleR-inc · Aug 25, 2024 · 790359c · 790359c
1 parent b0edb0f
commit 790359c
Show file tree

Hide file tree

Showing 6 changed files with 115 additions and 20 deletions.
diff --git a/tests/R/R/RcppExports.R b/tests/R/R/RcppExports.R
@@ -2,8 +2,8 @@
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
 #' @export
-classify_integrate <- function(test, results, refs, labels, markers, quantile = 0.8) {
-    .Call('_singlepp_tests_classify_integrate', PACKAGE = 'singlepp.tests', test, results, refs, labels, markers, quantile)
+classify_integrate <- function(test, results, refs, labels, markers, quantile = 0.8, fine_tune = TRUE, tune_thresh = 0.05) {
+    .Call('_singlepp_tests_classify_integrate', PACKAGE = 'singlepp.tests', test, results, refs, labels, markers, quantile, fine_tune, tune_thresh)
 }
 
 #' @useDynLib singlepp.tests
@@ -14,8 +14,8 @@ classify_single <- function(test, ref, labels, markers, quantile = 0.8, fine_tun
 }
 
 #' @export
-intersect_integrate <- function(test, test_ids, results, refs, ref_ids, labels, markers, quantile = 0.8) {
-    .Call('_singlepp_tests_intersect_integrate', PACKAGE = 'singlepp.tests', test, test_ids, results, refs, ref_ids, labels, markers, quantile)
+intersect_integrate <- function(test, test_ids, results, refs, ref_ids, labels, markers, quantile = 0.8, fine_tune = TRUE, tune_thresh = 0.05) {
+    .Call('_singlepp_tests_intersect_integrate', PACKAGE = 'singlepp.tests', test, test_ids, results, refs, ref_ids, labels, markers, quantile, fine_tune, tune_thresh)
 }
 
 #' @export

diff --git a/tests/R/R/integrate.R b/tests/R/R/integrate.R
@@ -1,5 +1,5 @@
 #' @export
-naive_integrate <- function(test, results, refs, labels, markers, quantile = 0.8) {
+naive_integrate <- function(test, results, refs, labels, markers, quantile = 0.8, fine.tune = TRUE, tune.thresh = 0.05) {
     scores <- matrix(0, ncol(test), length(results))
     best <- integer(ncol(test))
     delta <- numeric(ncol(test))
@@ -24,8 +24,41 @@ naive_integrate <- function(test, results, refs, labels, markers, quantile = 0.8
         }
 
         scores[i,] <- collected
-        best[i] <- which.max(collected)
-        delta[i] <- diff(sort(-collected)[1:2])
+
+        if (!fine.tune) {
+            best[i] <- which.max(collected)
+            delta[i] <- diff(sort(-collected)[1:2])
+        } else {
+            prediction <- which.max(collected)
+            tuned <- which(collected >= max(collected) - tune.thresh)
+
+            while (length(tuned) > 1 && length(tuned) < length(collected)) {
+                cur.markers <- vector("list", length(tuned))
+                for (r in tuned) {
+                    curbest <- results[[r]][i]
+                    cur.markers[[r]] <- sort(unique(unlist(markers[[r]][[curbest]])))
+                }
+
+                common <- sort(unique(unlist(cur.markers)))
+                curtest <- superslice(test, common, i, drop=TRUE)
+                collected <- numeric(length(tuned))
+
+                for (t in seq_along(tuned)) {
+                    r <- tuned[t]
+                    curbest <- results[[r]][i]
+                    keep <- labels[[r]] == curbest
+                    curref <- superslice(refs[[r]], common, keep, drop=FALSE)
+                    corrs <- missing.cor(curref, curtest)
+                    collected[t] <- stats::quantile(corrs, prob=quantile)
+                }
+
+                prediction <- tuned[which.max(collected)]
+                tuned <- tuned[which(collected >= max(collected) - tune.thresh)]
+            }
+
+            best[i] <- prediction
+            delta[i] <- diff(sort(-collected)[1:2])
+        }
     }
 
     list(scores = scores, best = best, delta = delta)

diff --git a/tests/R/src/RcppExports.cpp b/tests/R/src/RcppExports.cpp
@@ -11,8 +11,8 @@ Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
 #endif
 
 // classify_integrate
-Rcpp::List classify_integrate(Rcpp::NumericMatrix test, Rcpp::List results, Rcpp::List refs, Rcpp::List labels, Rcpp::List markers, double quantile);
-RcppExport SEXP _singlepp_tests_classify_integrate(SEXP testSEXP, SEXP resultsSEXP, SEXP refsSEXP, SEXP labelsSEXP, SEXP markersSEXP, SEXP quantileSEXP) {
+Rcpp::List classify_integrate(Rcpp::NumericMatrix test, Rcpp::List results, Rcpp::List refs, Rcpp::List labels, Rcpp::List markers, double quantile, bool fine_tune, double tune_thresh);
+RcppExport SEXP _singlepp_tests_classify_integrate(SEXP testSEXP, SEXP resultsSEXP, SEXP refsSEXP, SEXP labelsSEXP, SEXP markersSEXP, SEXP quantileSEXP, SEXP fine_tuneSEXP, SEXP tune_threshSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type test(testSEXP);
@@ -21,7 +21,9 @@ BEGIN_RCPP
     Rcpp::traits::input_parameter< Rcpp::List >::type labels(labelsSEXP);
     Rcpp::traits::input_parameter< Rcpp::List >::type markers(markersSEXP);
     Rcpp::traits::input_parameter< double >::type quantile(quantileSEXP);
-    rcpp_result_gen = Rcpp::wrap(classify_integrate(test, results, refs, labels, markers, quantile));
+    Rcpp::traits::input_parameter< bool >::type fine_tune(fine_tuneSEXP);
+    Rcpp::traits::input_parameter< double >::type tune_thresh(tune_threshSEXP);
+    rcpp_result_gen = Rcpp::wrap(classify_integrate(test, results, refs, labels, markers, quantile, fine_tune, tune_thresh));
     return rcpp_result_gen;
 END_RCPP
 }
@@ -43,8 +45,8 @@ BEGIN_RCPP
 END_RCPP
 }
 // intersect_integrate
-Rcpp::List intersect_integrate(Rcpp::NumericMatrix test, std::vector<std::string> test_ids, Rcpp::List results, Rcpp::List refs, Rcpp::List ref_ids, Rcpp::List labels, Rcpp::List markers, double quantile);
-RcppExport SEXP _singlepp_tests_intersect_integrate(SEXP testSEXP, SEXP test_idsSEXP, SEXP resultsSEXP, SEXP refsSEXP, SEXP ref_idsSEXP, SEXP labelsSEXP, SEXP markersSEXP, SEXP quantileSEXP) {
+Rcpp::List intersect_integrate(Rcpp::NumericMatrix test, std::vector<std::string> test_ids, Rcpp::List results, Rcpp::List refs, Rcpp::List ref_ids, Rcpp::List labels, Rcpp::List markers, double quantile, bool fine_tune, double tune_thresh);
+RcppExport SEXP _singlepp_tests_intersect_integrate(SEXP testSEXP, SEXP test_idsSEXP, SEXP resultsSEXP, SEXP refsSEXP, SEXP ref_idsSEXP, SEXP labelsSEXP, SEXP markersSEXP, SEXP quantileSEXP, SEXP fine_tuneSEXP, SEXP tune_threshSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type test(testSEXP);
@@ -55,7 +57,9 @@ BEGIN_RCPP
     Rcpp::traits::input_parameter< Rcpp::List >::type labels(labelsSEXP);
     Rcpp::traits::input_parameter< Rcpp::List >::type markers(markersSEXP);
     Rcpp::traits::input_parameter< double >::type quantile(quantileSEXP);
-    rcpp_result_gen = Rcpp::wrap(intersect_integrate(test, test_ids, results, refs, ref_ids, labels, markers, quantile));
+    Rcpp::traits::input_parameter< bool >::type fine_tune(fine_tuneSEXP);
+    Rcpp::traits::input_parameter< double >::type tune_thresh(tune_threshSEXP);
+    rcpp_result_gen = Rcpp::wrap(intersect_integrate(test, test_ids, results, refs, ref_ids, labels, markers, quantile, fine_tune, tune_thresh));
     return rcpp_result_gen;
 END_RCPP
 }
@@ -80,9 +84,9 @@ END_RCPP
 }
 
 static const R_CallMethodDef CallEntries[] = {
-    {"_singlepp_tests_classify_integrate", (DL_FUNC) &_singlepp_tests_classify_integrate, 6},
+    {"_singlepp_tests_classify_integrate", (DL_FUNC) &_singlepp_tests_classify_integrate, 8},
     {"_singlepp_tests_classify_single", (DL_FUNC) &_singlepp_tests_classify_single, 8},
-    {"_singlepp_tests_intersect_integrate", (DL_FUNC) &_singlepp_tests_intersect_integrate, 8},
+    {"_singlepp_tests_intersect_integrate", (DL_FUNC) &_singlepp_tests_intersect_integrate, 10},
     {"_singlepp_tests_intersect_single", (DL_FUNC) &_singlepp_tests_intersect_single, 10},
     {NULL, NULL, 0}
 };

diff --git a/tests/R/src/classify_integrate.cpp b/tests/R/src/classify_integrate.cpp
@@ -13,7 +13,9 @@ Rcpp::List classify_integrate(
     Rcpp::List refs, 
     Rcpp::List labels,
     Rcpp::List markers,
-    double quantile = 0.8)
+    double quantile = 0.8,
+    bool fine_tune = true, 
+    double tune_thresh = 0.05)
 {
     size_t nrefs = refs.size();
     if (nrefs != results.size()) {
@@ -70,6 +72,8 @@ Rcpp::List classify_integrate(
 
     singlepp::ClassifyIntegratedOptions<double> copt;
     copt.quantile = quantile;
+    copt.fine_tune = fine_tune;
+    copt.fine_tune_threshold = tune_thresh;
     singlepp::classify_integrated(parsed_test, resptrs, itrained, buffers, copt);
 
     for (auto& o : output_best) {

diff --git a/tests/R/src/intersect_integrate.cpp b/tests/R/src/intersect_integrate.cpp
@@ -15,7 +15,9 @@ Rcpp::List intersect_integrate(
     Rcpp::List ref_ids,
     Rcpp::List labels,
     Rcpp::List markers,
-    double quantile = 0.8)
+    double quantile = 0.8,
+    bool fine_tune = true, 
+    double tune_thresh = 0.05)
 {
     size_t nrefs = refs.size();
     if (nrefs != results.size()) {
@@ -79,6 +81,8 @@ Rcpp::List intersect_integrate(
 
     singlepp::ClassifyIntegratedOptions<double> copt;
     copt.quantile = quantile;
+    copt.fine_tune = fine_tune;
+    copt.fine_tune_threshold = tune_thresh;
     singlepp::classify_integrated(parsed_test, resptrs, itrained, buffers, copt);
 
     for (auto& o : output_best) {

diff --git a/tests/R/tests/testthat/test-integrate.R b/tests/R/tests/testthat/test-integrate.R
@@ -1,7 +1,7 @@
 # This runs the integration tests against the reference R implementation.
 # library(testthat); library(singlepp.tests); source("setup.R"); source("test-integrate.R")
 
-test_that("integrated references, basic", {
+test_that("integrated references, no fine tuning", {
     ngenes <- 5000
 
     # Setting up the data.
@@ -18,6 +18,31 @@ test_that("integrated references, basic", {
         results[[i]] <- sample(nlabels, ncol(mat), replace=TRUE)
     }
 
+    ref <- naive_integrate(mat, results, refs, labels, markers, fine.tune=FALSE)
+    obs <- classify_integrate(mat, results, refs, labels, markers, fine_tune=FALSE)
+
+    expect_identical(ref$best, obs$best)
+    expect_equal(ref$scores, obs$scores)
+    expect_equal(ref$delta, obs$delta)
+})
+
+test_that("integrated references, standard fine tuning", {
+    ngenes <- 5000
+
+    # Setting up the data.
+    set.seed(10001)
+    mat <- matrix(rnorm(ngenes * 100), nrow=ngenes)
+
+    refs <- labels <- markers <- results <- vector("list", 3)
+    for (i in seq_along(refs)) {
+        nlabels <- 5 + i
+        nprofiles <- 10 * i
+        refs[[i]] <- matrix(rnorm(ngenes * nprofiles), nrow=ngenes)
+        labels[[i]] <- mock.labels(nprofiles, nlabels)
+        markers[[i]] <- mock.markers(ngenes, nlabels, ntop = 20)
+        results[[i]] <- sample(nlabels, ncol(mat), replace=TRUE)
+    }
+
     ref <- naive_integrate(mat, results, refs, labels, markers)
     obs <- classify_integrate(mat, results, refs, labels, markers)
 
@@ -26,6 +51,31 @@ test_that("integrated references, basic", {
     expect_equal(ref$delta, obs$delta)
 })
 
+test_that("integrated references, tight fine tuning", {
+    ngenes <- 5000
+
+    # Setting up the data.
+    set.seed(10002)
+    mat <- matrix(rnorm(ngenes * 100), nrow=ngenes)
+
+    refs <- labels <- markers <- results <- vector("list", 3)
+    for (i in seq_along(refs)) {
+        nlabels <- 5 + i
+        nprofiles <- 10 * i
+        refs[[i]] <- matrix(rnorm(ngenes * nprofiles), nrow=ngenes)
+        labels[[i]] <- mock.labels(nprofiles, nlabels)
+        markers[[i]] <- mock.markers(ngenes, nlabels, ntop = 20)
+        results[[i]] <- sample(nlabels, ncol(mat), replace=TRUE)
+    }
+
+    ref <- naive_integrate(mat, results, refs, labels, markers, tune.thresh=0.01)
+    obs <- classify_integrate(mat, results, refs, labels, markers, tune_thresh=0.01)
+
+    expect_identical(ref$best, obs$best)
+    expect_equal(ref$scores, obs$scores)
+    expect_equal(ref$delta, obs$delta)
+})
+
 test_that("integrated references, different quantile", {
     ngenes <- 5000
 
@@ -77,8 +127,8 @@ test_that("integrated references, intersection", {
         results[[i]] <- sample(nlabels, ncol(mat), replace=TRUE)
     }
 
-    ref <- naive_integrate(mat, results, refs, labels, named.markers, quantile = 0.7)
-    obs <- intersect_integrate(mat, rownames(mat), results, refs, lapply(refs, rownames), labels, markers, quantile = 0.7)
+    ref <- naive_integrate(mat, results, refs, labels, named.markers)
+    obs <- intersect_integrate(mat, rownames(mat), results, refs, lapply(refs, rownames), labels, markers)
 
     expect_identical(ref$best, obs$best)
     expect_equal(ref$scores, obs$scores)