R/main_class.R

In campbio/musicatk: Mutational Signature Comprehensive Analysis Toolkit

#' @importFrom utils capture.output
NULL

# Count Tables object/methods -------------------------------

#' Object containing the count table matrices, their names and descriptions
#' that we generated by provided and by user functions. These are used to
#' discover and infer signatures and exposures.
#'
#' @slot name A name that describes the type of table (e.g. "SBS96")
#' @slot count_table An array of counts with samples as the columns and motifs
#' as the rows
#' @slot annotation A data.frame of annotations with three columns used for
#' plotting: motif, mutation, and context
#' @slot features Original features used to generate the count_table
#' @slot type The mutation type of each feature, in case we need to plot or
#' model they differently
#' @slot color_variable The variable used for plotting colors, selected from
#' the annotation slot
#' @slot color_mapping The mapping of the annotations chosen by color_variable
#' to color values for plotting
#' @slot description A summary table of the result objects in result_list
#' a list of lists. The nested lists created combined (rbind) tables, and the
#' tables at the first list level are modelled independantly. Combined tables
#' must be named.
#' list("tableA", comboTable = list("tableC", "tableD"))
#' @importFrom S4Vectors Rle
#' @export
setClass("count_table", slots = c(name = "character",
                                  count_table = "array",
                                  annotation = "data.frame",
                                  features = "data.frame",
                                  type = "Rle",
                                  color_variable = "character",
                                  color_mapping = "character",
                                  description = "character"))

setMethod("show", "count_table",
          function(object)    cat("Count_Table: ", object@name,
                                  c("\nMotifs:", dim(object@count_table)[1], 
                                    "\nSamples:", dim(object@count_table)[2], 
                                    "\n"),
                                    "\n**Annotations: \n",
                                    paste(capture.output(rbind(head(
                                      object@annotation), "...")), 
                                      collapse = "\n"),
                                    "\n\n**Features: \n",
                                    paste(capture.output(rbind(head(
                                      object@features), "...")), 
                                      collapse = "\n"),
                                    "\n\n**Types: \n",
                                    paste0(unique(object@type), "\n"),
                                    "\n**Color Variable: \n",
                                    paste0(object@color_variable, "\n"),
                                    "\n**Color Mapping: \n",
                                    paste0(object@color_mapping, "\n"),
                                    "\n**Descriptions: \n",
                                    paste0(object@description, "\n"))
          )

# Primary variant object/methods -------------------------------

#' The primary object that contains variants, count_tables,
#' and samples annotations
#'
#' @slot variants \code{data.table} of variants
#' @slot count_tables Summary table with per-sample unnormalized motif counts
#' @slot sample_annotations Sample-level annotations (e.g. age, sex, primary)
#' @export
#' @exportClass musica
setClass("musica", slots = c(variants = "data.table",
                                 count_tables = "list",
                                 sample_annotations = "data.frame"),
         prototype = list(variants = data.table::data.table(),
                   count_tables = list(),
                   sample_annotations = data.frame()))

# setMethod("show", "musica_variants",
#           function(object)cat(cat("musica object containing \n**Variants: \n"),
#                               if (!all(is.na(object@variants))) {
#                                 cat(methods::show(object@variants))
#                                 }else{
#                                   cat("Empty")
#                                     },
#                               cat("\n**Count_Tables Object containing: \n"),
#                               if (length(object@count_tables@table_name) > 0) {
#                                 cat("\n**Count Tables: \n",
#                                     apply(cbind(do.call("rbind", lapply(
#                                       object@count_tables@table_list, dim)),
#                                       "\n"), 1, paste),
#                                     "\n**Names: \n", paste(
#                                         unlist(object@count_tables@table_name),
#                                         "\n", sep = ""), "\n**Descriptions: \n",
#                                     paste(unlist(
#                                       object@count_tables@description), "\n",
#                                       sep = ""))
#                                 }else{
#                                   cat("Empty")
#                                   },
#                               cat("\n**Sample Level Annotations: \n"),
#                               if (!all(is.na(object@sample_annotations))) {
#                                 cat(methods::show(object@sample_annotations))
#                               }else{
#                                 cat("Empty")
#                               })
# )

# Variant-Level object/methods -------------------------------

#' Return sample from musica_variant object
#'
#' @param musica A \code{\linkS4class{musica}} object.
#' @param sample_name Sample name to subset by
#' @return Returns sample data.frame subset to a single sample
#' @examples
#' data(musica)
#' subset_variants_by_samples(musica, "TCGA-94-7557-01A-11D-2122-08")
#' @export
subset_variants_by_samples <- function(musica, sample_name) {
  return(variants(musica)[
    which(variants(musica)$sample == sample_name), ])
}

# Sample-Level object/methods -------------------------------

#' Creates a new musica subsetted to only samples with enough variants
#'
#' @param musica A \code{\linkS4class{musica}} object.
#' @param table_name Name of table used for subsetting
#' @param num_counts Minimum sum count value to drop samples
#' @return Returns a new musica object with sample annotations, count tables,
#' and variants subsetted to only contains samples with the specified minimum
#' number of counts (column sums) in the specified table
#' @examples
#' data(musica_sbs96)
#' subset_musica_by_counts(musica_sbs96, "SBS96", 20)
#' @export
subset_musica_by_counts <- function(musica, table_name, num_counts) {
  tab <- .extract_count_table(musica, table_name)
  min_samples <- colnames(tab)[which(colSums(tab) >= num_counts)]

  tables(musica) <- .subset_count_tables(musica, min_samples)

  #Subset variants
  variants(musica) <- variants(musica)[
    which(variants(musica)$sample %in% min_samples), ]

  #Subset sample annotations
  if (nrow(samp_annot(musica)) != 0) {
    .overwrite_samp_annot(musica = musica, 
                          new_annot = 
                            samp_annot(musica)[which(samp_annot(musica)$Samples 
                                                     %in% min_samples), , 
                                               drop = FALSE])
    #samp_annot(musica) <- samp_annot(musica)[which(
    #  samp_annot(musica)$Samples %in% min_samples), ]
  }
  return(musica)
}

#' Creates a new musica object subsetted to only one value of a sample annotation
#'
#' @param musica A \code{\linkS4class{musica}} object.
#' @param annot_col Annotation class to use for subsetting
#' @param annot_names Annotational value to subset to
#' @return Returns a new musica object with sample annotations, count tables,
#' and variants subsetted to only contains samples of the specified annotation
#' type
#' @examples
#' data(musica_sbs96)
#' annot <- read.table(system.file("extdata", "sample_annotations.txt", 
#' package = "musicatk"), sep = "\t", header=TRUE)
#'
#' samp_annot(musica_sbs96, "Tumor_Subtypes") <- annot$Tumor_Subtypes
#'
#' musica_sbs96 <- subset_musica_by_annotation(musica_sbs96, "Tumor_Subtypes", 
#' "Lung")
#' @export
subset_musica_by_annotation <- function(musica, annot_col, annot_names) {
  if (!all(annot_col %in% colnames(samp_annot(musica)))) {
    stop(paste(annot_col, " not found in annotation columns, please review.",
               sep = ""))
  }
  annotation_index <- which(samp_annot(musica)[[which(colnames(
    samp_annot(musica)) %in% annot_col)]] %in% annot_names)
  if (length(annotation_index) == 0) {
    stop(paste(annot_names, " not present in ", annot_col,
               " column, please review.", sep = "", collapse = TRUE))
  }
  .overwrite_samp_annot(musica, samp_annot(musica)[annotation_index, ])
  annotation_samples <- samp_annot(musica)$"Samples"
  tables(musica) <- .subset_count_tables(musica, samples = annotation_samples)
  variants(musica) <- variants(musica)[
    which(variants(musica)$sample %in% annotation_samples), ]
  return(musica)
}

.overwrite_samp_annot <- function(musica, new_annot) {
  eval.parent(substitute(musica@sample_annotations <- new_annot))
}

drop_na_variants <- function(variants, annot_col) {
  if (!annot_col %in% colnames(variants)) {
    stop(paste(annot_col, " not found in annotation columns, please review.",
               sep = ""))
  }
  if (length(which(is.na(variants[[annot_col]]))) == 0) {
    return(variants)
  } else {
    return(variants[-which(is.na(variants[[annot_col]])), ])
  }
}

# Result object/methods -------------------------------

#' Object containing deconvolved/predicted signatures, sample weights, and
#' the musica object the result was generated from
#'
#' @slot signatures A matrix of signatures by mutational motifs
#' @slot exposures A matrix of samples by signature weights
#' @slot table_name A character vector of table names used to make the result
#' @slot algorithm Describes how the signatures/weights were generated
#' @slot musica The musica object the results were generated from
#' @slot umap List of umap data.frames for plotting and analysis
#' @export
#' @exportClass musica_result
setClass("musica_result", representation(signatures = "matrix", 
                                         exposures = "matrix", 
                                         table_name = "character", 
                                         algorithm = "character", 
                                         musica = "musica", 
                                         umap = "matrix"))

#' Return sample from musica object
#'
#' @param result Result object containing signatures and weights
#' @param name_vector Vector of user-defined signature names
#' @return Result object with user-defined signatures names
#' @examples
#' data(res)
#' name_signatures(res, c("smoking", "apobec", "unknown"))
#' @export
name_signatures <- function(result, name_vector) {
  num_sigs <- length(colnames(signatures(result)))
  if (length(name_vector) != num_sigs) {
    stop("Please provide a full list of signatures names (length = ",
               num_sigs, ").")
  }
  eval.parent(substitute(colnames(signatures(result)) <- name_vector))
  eval.parent(substitute(rownames(exposures(result)) <- name_vector))
}

get_result_alg <- function(musica_result) {
  return(musica_result@algorithm)
}

# Result Grid object/methods -------------------------------

#' Object containing the result objects generated from the combination of
#' annotations and a range of k values
#'
#' @slot grid_params The parameters the result grid was created using
#' @slot result_list A list of result objects with different parameters
#' @slot grid_table A summary table of the result objects in result_list
#' @export
setClass("musica_result_grid", representation(grid_params = "data.table",
                                       result_list = "list",
                                       grid_table = "data.table"))

get_grid_params <- function(result_grid) {
  return(result_grid@grid_params)
}

get_grid_list <- function(result_grid) {
  return(result_grid@result_list)
}

get_grid_table <- function(result_grid) {
  return(result_grid@grid_table)
}

set_grid_params <- function(result_grid, params) {
  eval.parent(substitute(result_grid@grid_params <- params))
}

set_grid_list <- function(result_grid, list) {
  eval.parent(substitute(result_grid@result_list <- list))
}

set_grid_table <- function(result_grid, table) {
  eval.parent(substitute(result_grid@grid_table <- table))
}

get_tab_name <- function(count_table) {
  return(count_table@name)
}

get_count_table <- function(count_table) {
  return(count_table@count_table)
}

get_annot_tab <- function(count_table) {
  return(count_table@annotation)
}

get_count_features <- function(count_table) {
  return(count_table@features)
}

get_count_type <- function(count_table) {
  return(count_table@type)
}

get_color_mapping <- function(count_table) {
  return(count_table@color_mapping)
}