Cibersort check 0 counts

R/cibersort.R

@@ -30,9 +30,9 @@
 
 
 # Core algorithm of Cibersort
-#' 
+#'
 #' @keywords internal
-#' 
+#'
 #' @importFrom parallel mclapply
 #' @importFrom stats cor
 #'
@@ -65,8 +65,8 @@ CoreAlg <- function(X, y, cores = 3){
 
   #Execute In a parallel way the SVM
   if(cores>1){
-    if(Sys.info()['sysname'] == 'Windows') out <- parallel::mclapply(1:svn_itor, res, mc.cores=1) 
-    else out <-  parallel::mclapply(1:svn_itor, res, mc.cores=cores) 
+    if(Sys.info()['sysname'] == 'Windows') out <- parallel::mclapply(1:svn_itor, res, mc.cores=1)
+    else out <-  parallel::mclapply(1:svn_itor, res, mc.cores=cores)
   }
   else out <-  lapply(1:svn_itor, res)
 
@@ -139,7 +139,7 @@ CoreAlg <- function(X, y, cores = 3){
 }
 
 #' @importFrom stats sd
-#' 
+#'
 #' @keywords internal
 #'
 doPerm <- function(perm, X, Y, cores = 3){
@@ -173,9 +173,9 @@ doPerm <- function(perm, X, Y, cores = 3){
 }
 
 #' @importFrom stats sd
-#' 
+#'
 #' @keywords internal
-#' 
+#'
 my_CIBERSORT <- function(Y, X, perm=0, QN=TRUE, cores = 3){
 
 
@@ -215,6 +215,22 @@ my_CIBERSORT <- function(Y, X, perm=0, QN=TRUE, cores = 3){
   XintY <- Xgns %in% row.names(Y)
   X <- X[XintY,,drop=FALSE]
 
+  # Eliminate empty samples
+  if(length(which(colSums(Y)==0))>0)
+    warning(sprintf(
+      "tidybulk says: the samples %s were ignored for decovolution as they have 0 counts for the deconvolution signature genes",
+      colnames(Y)[colSums(Y)==0] %>% paste(collapse = ", ")
+    ))
+  Y=Y[,colSums(Y)>0]
+
+  # Eliminate sd == 0
+  if(length(which(colSds(Y)==0))>0)
+    warning(sprintf(
+      "tidybulk says: the samples %s were ignored for decovolution as they have standard deviation of 0 for the deconvolution signature genes",
+      colnames(Y)[colSds(Y)==0] %>% paste(collapse = ", ")
+    ))
+  Y = Y[,colSds(Y)>0]
+
   #standardize sig matrix
   X <- (X - mean(X)) / sd(as.vector(X))
 

R/dplyr_methods.R

@@ -33,25 +33,25 @@
 #' individual methods for extra arguments and differences in behaviour.
 #'
 #' The following methods are currently available in loaded packages:
-#' 
+#'
 #' @param .data A data frame, data frame extension (e.g. a tibble), or a
 #'   lazy data frame (e.g. from dbplyr or dtplyr). See *Methods*, below, for
 #'   more details.
 #' @param ... <[`tidy-eval`][dplyr_tidy_eval]> Variables, or functions or
 #'   variables. Use [desc()] to sort a variable in descending order.
 #' @param .by_group If TRUE, will sort first by grouping variable. Applies to grouped data frames only.
-#' 
+#'
 #' @return A tibble
 #' @family single table verbs
-#' 
+#'
 #' @rdname arrange-methods
 #' @name arrange
 #' @importFrom dplyr arrange
-#' 
+#'
 #' @examples
-#' `%>%` = magrittr::`%>%`
+#'
 #' arrange(mtcars, cyl, disp)
-#' 
+#'
 #' @export
 NULL
 
@@ -101,10 +101,10 @@ arrange.tidybulk <- function(.data, ..., .by_group = FALSE) {
 #'   used instead.
 #' @return `bind_rows()` and `bind_cols()` return the same type as
 #'   the first input, either a data frame, `tbl_df`, or `grouped_df`.
-#'   
-#'   
+#'
+#'
 #' @examples
-#' `%>%` = magrittr::`%>%`
+#'
 #' one <- mtcars[1:4, ]
 #' two <- mtcars[11:14, ]
 #'
@@ -116,9 +116,9 @@ arrange.tidybulk <- function(.data, ..., .by_group = FALSE) {
 NULL
 
 #' @rdname bind-methods
-#' 
+#'
 #' @inheritParams bind
-#' 
+#'
 #' @export
 #'
 bind_rows <- function(..., .id = NULL) {
@@ -134,9 +134,9 @@ bind_rows.default <-  function(..., .id = NULL)
 #' @importFrom rlang dots_values
 #' @importFrom rlang flatten_if
 #' @importFrom rlang is_spliced
-#' 
+#'
 #' @export
-#' 
+#'
 bind_rows.tidybulk <- function(..., .id = NULL)
 {
 
@@ -156,9 +156,9 @@ bind_rows.tidybulk <- function(..., .id = NULL)
 }
 
 #' @export
-#' 
+#'
 #' @inheritParams bind
-#' 
+#'
 #' @rdname bind-methods
 bind_cols <- function(..., .id = NULL) {
 	UseMethod("bind_cols")
@@ -173,9 +173,9 @@ bind_cols.default <-  function(..., .id = NULL)
 #' @importFrom rlang dots_values
 #' @importFrom rlang flatten_if
 #' @importFrom rlang is_spliced
-#' 
+#'
 #' @export
-#' 
+#'
 bind_cols.tidybulk <- function(..., .id = NULL)
 {
 
@@ -198,7 +198,7 @@ bind_cols.tidybulk <- function(..., .id = NULL)
 #' @rdname distinct-methods
 #' @name distinct
 #' @importFrom dplyr distinct
-#' 
+#'
 #' @examples
 #'
 #' tidybulk::se_mini %>% tidybulk() %>% distinct()
@@ -276,11 +276,11 @@ distinct.tidybulk <- function (.data, ..., .keep_all = FALSE)
 #'
 #' The following methods are currently available in loaded packages:
 #' @seealso [filter_all()], [filter_if()] and [filter_at()].
-#' 
+#'
 #' @rdname filter-methods
 #' @name filter
 #' @importFrom dplyr filter
-#' 
+#'
 #' @export
 #' @examples
 #'
@@ -365,10 +365,10 @@ group_by.tidybulk <- function (.data, ..., .add = FALSE, .drop = group_by_drop_d
 #' @rdname ungroup-methods
 #' @name ungroup
 #' @importFrom dplyr ungroup
-#' 
+#'
 #' @param x A [tbl()]
 #' @param ... See dplyr
-#' 
+#'
 #' @export
 ungroup.tidybulk <- function (x, ...)
 {
@@ -591,15 +591,15 @@ mutate.nested_tidybulk <- function(.data, ...)
 	.data %>%
 		drop_class(c("nested_tidybulk", "tt")) %>%
 		dplyr::mutate(...) %>%
-		
+
 		# Attach attributes
 		reattach_internals(.data) %>%
-		
+
 		# Add class
 		add_class("tt") %>%
 		add_class("nested_tidybulk")
-	
-	
+
+
 }
 
 #' Rename columns
@@ -632,7 +632,7 @@ mutate.nested_tidybulk <- function(.data, ...)
 #' `%>%` = magrittr::`%>%`
 #' iris <- as_tibble(iris) # so it prints a little nicer
 #' rename(iris, petal_length = Petal.Length)
-#' 
+#'
 #' @rdname rename-methods
 #' @name rename
 #' @importFrom dplyr rename
@@ -685,7 +685,7 @@ rename.tidybulk <- function(.data, ...)
 #' `%>%` = magrittr::`%>%`
 #' df <- expand.grid(x = 1:3, y = 3:1)
 #' df_done <- df %>% rowwise() %>% do(i = seq(.$x, .$y))
-#' 
+#'
 #' @rdname rowwise-methods
 #' @name rowwise
 #' @importFrom dplyr rowwise