/R/signature_obj_operation.R

https://github.com/ShixiangWang/sigminer · R · 137 lines · 69 code · 17 blank · 51 comment · 17 complexity · 8c267ffdfcd9582b6eea7803b43dd7a6 MD5 · raw file

  1. #' Obtain or Modify Signature Information
  2. #'
  3. #' @param sig a `Signature` object obtained either from [sig_extract] or [sig_auto_extract].
  4. #' @name sig_operation
  5. #' @return a `Signature` object or data.
  6. #' @export
  7. #'
  8. #' @examples
  9. #' ## Operate signature names
  10. #' load(system.file("extdata", "toy_mutational_signature.RData",
  11. #' package = "sigminer", mustWork = TRUE
  12. #' ))
  13. #' sig_names(sig2)
  14. #' cc <- sig_modify_names(sig2, new_names = c("Sig2", "Sig1", "Sig3"))
  15. #' sig_names(cc)
  16. #'
  17. #' # The older names are stored in tags.
  18. #' print(attr(cc, "tag"))
  19. #' @testexamples
  20. #' expect_is(cc, "Signature")
  21. sig_names <- function(sig) {
  22. stopifnot(inherits(sig, "Signature"))
  23. colnames(sig$Signature)
  24. }
  25. #' @param new_names new signature names.
  26. #' @rdname sig_operation
  27. #' @export
  28. sig_modify_names <- function(sig, new_names) {
  29. ns <- sig_names(sig)
  30. if (length(new_names) != length(ns)) {
  31. stop("The new names should have same length as old names!")
  32. }
  33. colnames(sig$Signature) <- colnames(sig$Signature.norm) <- colnames(sig$Raw$W) <- rownames(sig$Exposure) <- rownames(sig$Exposure.norm) <- rownames(sig$Raw$H) <- new_names
  34. attr(sig, "tag") <- paste0("Older names:", paste(ns, collapse = ","), ";")
  35. sig
  36. }
  37. #' @rdname sig_operation
  38. #' @export
  39. #' @examples
  40. #' ## Get signature number
  41. #' sig_number(sig2)
  42. sig_number <- function(sig) {
  43. stopifnot(inherits(sig, "Signature"))
  44. sig$K
  45. }
  46. #' @rdname sig_operation
  47. #' @export
  48. #' @examples
  49. #' ## Get signature attributes
  50. #' sig_number(sig2)
  51. sig_attrs <- function(sig) {
  52. stopifnot(inherits(sig, "Signature"))
  53. attributes(sig)[!names(attributes(sig)) %in% c("names", "class")]
  54. }
  55. #' @param normalize one of 'row', 'column', 'raw' and "feature", for row normalization (signature),
  56. #' column normalization (component), raw data, row normalization by feature, respectively.
  57. #' @rdname sig_operation
  58. #' @export
  59. #' @examples
  60. #' ## Get signature matrix
  61. #' z <- sig_signature(sig2)
  62. #' z <- sig_signature(sig2, normalize = "raw")
  63. sig_signature <- function(sig, normalize = c("row", "column", "raw", "feature")) {
  64. stopifnot(inherits(sig, "Signature"))
  65. normalize <- match.arg(normalize)
  66. sig <- sig$Signature
  67. if (normalize == "row") {
  68. sig <- apply(sig, 2, function(x) x / sum(x))
  69. } else if (normalize == "column") {
  70. sig <- t(apply(sig, 1, function(x) x / sum(x)))
  71. } else if (normalize == "feature") {
  72. has_cn <- grepl("^CN[^C]", rownames(sig)) | startsWith(rownames(sig), "copynumber")
  73. if (!any(has_cn)) {
  74. stop("normalize method 'feature' is only suitable for copy number signature!")
  75. }
  76. mat <- as.data.frame(sig)
  77. mat$context <- rownames(mat)
  78. if (any(grepl("^CN[^C]", rownames(sig)))) {
  79. mat$base <- sub("\\[.*\\]$", "", mat$context)
  80. } else {
  81. mat$base <- sub("\\d+$", "", mat$context)
  82. }
  83. mat <- tidyr::gather(mat, class, signature, -c("context", "base"))
  84. mat <- mat %>%
  85. dplyr::group_by(.data$base, .data$class) %>%
  86. tidyr::nest() %>%
  87. dplyr::mutate(
  88. context = purrr::map(.data$data, ~ .$context),
  89. signature = purrr::map(.data$data, ~ .$signature / sum(.$signature))
  90. ) %>%
  91. dplyr::select(-"data") %>%
  92. tidyr::unnest(cols = c("context", "signature")) %>%
  93. dplyr::ungroup()
  94. mat <- tidyr::pivot_wider(mat, names_from = "class", values_from = "signature") %>%
  95. dplyr::select(-"base") %>%
  96. tibble::column_to_rownames("context") %>%
  97. as.matrix()
  98. # Keep row order same
  99. sig <- mat[rownames(sig), ]
  100. }
  101. return(sig)
  102. }
  103. #' @param type one of 'absolute' and 'relative'.
  104. #' @rdname sig_operation
  105. #' @export
  106. #' @examples
  107. #' ## Get exposure matrix
  108. #' ## Of note, this is different from get_sig_exposure()
  109. #' ## it returns a matrix instead of data table.
  110. #' z <- sig_exposure(sig2) # it is same as sig$Exposure
  111. #' z <- sig_exposure(sig2, type = "relative") # it is same as sig2$Exposure.norm
  112. sig_exposure <- function(sig, type = c("absolute", "relative")) {
  113. stopifnot(inherits(sig, "Signature"))
  114. type <- match.arg(type)
  115. if (type == "absolute") {
  116. return(sig$Exposure)
  117. } else {
  118. return(sig$Exposure.norm)
  119. }
  120. }