R/sim_wider.R

Defines functions sim_wider

Documented in sim_wider

#' Widen a symmetric melted similarity matrix.
#'
#' \code{sim_widen} widens a symmetric melted matrix.
#'
#' @param sim_df data.frame with melted similarity matrix.
#' @param primary_key_column character string specifying the column in \code{sim_df}
#'                           to use to uniquely identify rows and columns
#' @param annotation_column character string specifying the column in \code{sim_df}
#'                           to use to annotate rows and columns
#'
#' @return data.frame of widened similarity matrix, with some attributes.
#'
#' @importFrom magrittr %>%
#' @importFrom magrittr %>%
#' @importFrom rlang !!
#' @importFrom dplyr across all_of everything
#'
#' @examples
#' suppressMessages(suppressWarnings(library(magrittr)))
#' population <- tibble::tibble(
#'   Metadata_group = sample(c("a", "b", "c", "d"), 100, replace = TRUE),
#'   x1 = rnorm(100),
#'   x2 = rnorm(100),
#'   x3 = rnorm(100),
#'   x4 = rnorm(100),
#'   x5 = rnorm(100)
#' )
#' population$Metadata_id <- seq(nrow(population))
#' metadata <- matric::get_annotation(population)
#' annotation_cols <- c("Metadata_group", "Metadata_id")
#' sim_df <- matric::sim_calculate(population, method = "pearson")
#' row_metadata <- attr(sim_df, "row_metadata")
#' sim_df <- matric::sim_annotate(sim_df, row_metadata, annotation_cols)
#' annotation_column <- "Metadata_group"
#' primary_key_column <- "Metadata_id"
#' res <- matric::sim_wider(sim_df, annotation_column, primary_key_column)
#' res
#' data.frame(id = rownames(res)) %>% dplyr::inner_join(attr(res, "map"))
#' @export
sim_wider <-
  function(sim_df,
           annotation_column,
           primary_key_column) {
    primary_key_column1 <- paste0(primary_key_column, "1")
    primary_key_column2 <- paste0(primary_key_column, "2")
    primary_key_columns <-
      c(primary_key_column1, primary_key_column2)

    sim_df <- as.data.frame(sim_df)

    annotation_column1 <- paste0(annotation_column, "1")
    annotation_column2 <- paste0(annotation_column, "2")

    annotation_column_unique1 <-
      paste(annotation_column1, "uniq", sep = "_")

    sim_df_wider <-
      sim_df %>%
      dplyr::select(all_of(c(primary_key_columns, "sim"))) %>%
      dplyr::arrange(across(all_of(primary_key_columns))) %>%
      tidyr::pivot_wider(
        names_from = all_of(primary_key_column2),
        values_from = "sim"
      ) %>%
      tibble::column_to_rownames(primary_key_column1)

    # assumes symmetric matrix
    sim_df_wider <- sim_df_wider %>%
      dplyr::select(all_of(row.names(sim_df_wider)))

    stopifnot(colnames(sim_df_wider) == row.names(sim_df_wider))

    map1 <-
      sim_df %>%
      dplyr::select(all_of(c(
        primary_key_column1, annotation_column1
      ))) %>%
      dplyr::distinct() %>%
      dplyr::arrange(across(all_of(
        c(primary_key_column1, annotation_column1)
      )))
    map2 <-
      sim_df %>%
      dplyr::select(all_of(c(
        primary_key_column2, annotation_column2
      ))) %>%
      dplyr::distinct() %>%
      dplyr::arrange(across(all_of(
        c(primary_key_column2, annotation_column2)
      )))

    stopifnot(all(map1 == map2))

    map1[[annotation_column_unique1]] <-
      paste(map1[[annotation_column1]],
        seq_along(map1[[annotation_column1]]),
        sep = ":"
      )

    map1[[primary_key_column1]] <-
      as.character(map1[[primary_key_column1]])

    key1 <- data.frame(x = as.character(row.names(sim_df_wider)))
    names(key1) <- primary_key_column1

    value_unique1 <-
      key1 %>%
      dplyr::inner_join(map1, by = primary_key_column1) %>%
      dplyr::pull(all_of(annotation_column_unique1))

    row.names(sim_df_wider) <- value_unique1
    colnames(sim_df_wider) <- row.names(sim_df_wider)

    map1 <- map1 %>% dplyr::select(
      id = all_of(annotation_column_unique1),
      annotation = all_of(annotation_column1),
      primary_key = all_of(primary_key_column1)
    )

    attr(sim_df_wider, "map") <- map1

    sim_df_wider
  }

Try the matric package in your browser

Any scripts or data that you put into this service are public.

matric documentation built on April 1, 2023, 12:19 a.m.