Merge pull request #60 from bodkan/qpadm-one-source

Fix broken handling of single-source qpAdm runs (fixes #51)
bodkan · Jun 14, 2020 · 6e7ba8b · 6e7ba8b
2 parents 9dc0f46 + e96b6e3
commit 6e7ba8b
Show file tree

Hide file tree

Showing 3 changed files with 49 additions and 27 deletions.
diff --git a/R/output_parsers.R b/R/output_parsers.R
@@ -227,26 +227,31 @@ read_qpAdm <- function(log_lines) {
     dplyr::mutate_at(dplyr::vars(-target), as.numeric)
 
   # parse the population combination patterns into a data.frame
-  pat_start <- stringr::str_detect(log_lines, "fixed pat") %>% which
-  pat_end <- stringr::str_detect(log_lines, "best pat") %>% which
-  patterns <- log_lines[pat_start : (pat_end[1] - 1)] %>%
-    stringr::str_replace(" fixed", "") %>%
-    stringr::str_replace(" prob", "") %>%
-    stringr::str_replace(" pattern", "") %>%
-    stringr::str_replace_all(" +", " ") %>%
-    stringr::str_replace_all("^ | $", "")
-  pat_header <- c(strsplit(patterns[1], " ")[[1]], source) %>%
-    stringr::str_replace("pat", "pattern")
-  if (any(stringr::str_detect(patterns, "infeasible"))) {
-    pat_header <- c(pat_header, "comment")
-    patterns[-1] <- sapply(patterns[-1], USE.NAMES = FALSE, function(l)
-      if (stringr::str_detect(l, "infeasible")) l else paste0(l, " -"))
+  # (but only if there are multiple sources!)
+  if (any(stringr::str_detect(log_lines, "single source. terminating"))) {
+    pat_df <- NULL
+  } else {
+    pat_start <- stringr::str_detect(log_lines, "fixed pat") %>% which
+    pat_end <- stringr::str_detect(log_lines, "best pat") %>% which
+    patterns <- log_lines[pat_start : (pat_end[1] - 1)] %>%
+      stringr::str_replace(" fixed", "") %>%
+      stringr::str_replace(" prob", "") %>%
+      stringr::str_replace(" pattern", "") %>%
+      stringr::str_replace_all(" +", " ") %>%
+      stringr::str_replace_all("^ | $", "")
+    pat_header <- c(strsplit(patterns[1], " ")[[1]], source) %>%
+      stringr::str_replace("pat", "pattern")
+    if (any(stringr::str_detect(patterns, "infeasible"))) {
+      pat_header <- c(pat_header, "comment")
+      patterns[-1] <- sapply(patterns[-1], USE.NAMES = FALSE, function(l)
+        if (stringr::str_detect(l, "infeasible")) l else paste0(l, " -"))
+    }
+    pat_df <- patterns[-1] %>%
+      paste0(collapse = "\n") %>%
+      readr::read_delim(delim = " ", col_names = FALSE) %>%
+      stats::setNames(pat_header)
   }
-  pat_df <- patterns[-1] %>%
-    paste0(collapse = "\n") %>%
-    readr::read_delim(delim = " ", col_names = FALSE) %>%
-    stats::setNames(pat_header)
-
+
   # parse the rank test results
   ranks <- read_qpWave(log_lines)
 

diff --git a/R/wrappers.R b/R/wrappers.R
@@ -125,17 +125,22 @@ qpAdm <- function(data, target, sources, outgroups, outdir = NULL, params = NULL
   ranks <- lapply(seq_along(target), function(i) { results[[i]]$ranks %>% dplyr::mutate(target = target[i]) }) %>%
     dplyr::bind_rows() %>%
     dplyr::select(target, dplyr::everything())
-  subsets <- lapply(seq_along(target), function(i) {
-      results[[i]]$subsets %>% dplyr::mutate(target = target[i])
-    }) %>%
-    dplyr::bind_rows() %>%
-    dplyr::select(target, dplyr::everything())
-
+
   res <- list(
     proportions = proportions,
-    ranks = ranks,
-    subsets = subsets
+    ranks = ranks
   )
+
+  if (!is.null(results[[1]]$subsets)) {
+    subsets <- lapply(seq_along(target), function(i) {
+        results[[i]]$subsets %>% dplyr::mutate(target = target[i])
+      }) %>%
+      dplyr::bind_rows() %>%
+      dplyr::select(target, dplyr::everything())
+    res$subsets <- subsets
+  } else {
+    res$subsets <- NULL
+  }
 
   attr(res, "command") <- "qpAdm"
   attr(res, "log_output") <- lapply(results, function(i) attr(i, "log_output"))

diff --git a/tests/testthat/test-wrappers.R b/tests/testthat/test-wrappers.R
@@ -78,6 +78,18 @@ test_that("qpAdm wrapper produces correct results", {
 })
 
 
+test_that("qpAdm with a single source produces NULL subsets dataframe", {
+  skip_on_cran()
+
+  data <- eigenstrat(file.path(data_dir, "qpdata"))
+  left <- scan(file.path(examples_dir, "left1"), what = "character", quiet = TRUE)[1:2]
+  right <- scan(file.path(examples_dir, "right1"), what = "character", quiet = TRUE) %>%
+    stringr::str_subset("^[^#]")
+  result <- qpAdm(target = left[1], sources = left[-1], outgroups = right, data = data)
+  expect_true(is.null(result$subsets))
+})
+
+
 # qpWave ------------------------------------------------------------------
 
 test_that("qpWave wrapper produces correct results", {