inst/Collections/Built-in/BE-mapper.R

In TKCat: Tailored Knowledge Catalog

function(
  x,
  y,
  orthologs = FALSE,
  restricted = FALSE,
  ...
) {
  if (!requireNamespace("BED")) {
    stop("The BED package is required")
  }
  if (!BED::checkBedConn()) {
    stop(
      "You need to connect to a BED database using",
      " the BED::connectToBed() function"
    )
  }

  if (!"organism" %in% colnames(x)) {
    d <- x
    scopes <- dplyr::distinct(d, be, source)
    nd <- c()
    for (i in 1:nrow(scopes)) {
      be <- scopes$be[i]
      source <- scopes$source[i]
      toadd <- d %>% dplyr::filter(be == be, source == source)
      organism <- BED::guessIdScope(
        toadd$identifier,
        be = be,
        source = source,
        tcLim = Inf
      ) %>%
        attr("details") %>%
        filter(be == !!be & source == !!source) %>%
        pull(organism) %>%
        unique()
      toadd <- merge(toadd, tibble(organism = organism))
      nd <- bind_rows(nd, toadd)
    }
    x <- nd %>% mutate(organism_type = "Scientific name")
  }
  if (!"organism" %in% colnames(y)) {
    d <- y
    scopes <- dplyr::distinct(d, be, source)
    nd <- c()
    for (i in 1:nrow(scopes)) {
      be <- scopes$be[i]
      source <- scopes$source[i]
      toadd <- d %>% dplyr::filter(be == be, source == source)
      organism <- BED::guessIdScope(
        toadd$identifier,
        be = be,
        source = source,
        tcLim = Inf
      ) %>%
        attr("details") %>%
        filter(be == !!be & source == !!source) %>%
        pull(organism) %>%
        unique()
      toadd <- merge(toadd, tibble(organism = organism))
      nd <- bind_rows(nd, toadd)
    }
    y <- nd %>% mutate(organism_type = "Scientific name")
  }

  xscopes <- dplyr::distinct(x, be, source, organism, organism_type)
  yscopes <- dplyr::distinct(y, be, source, organism, organism_type)

  toRet <- NULL
  for (i in 1:nrow(xscopes)) {
    xscope <- xscopes[i, ]
    if (any(apply(xscope, 2, is.na))) {
      next()
    }
    xi <- dplyr::right_join(
      x,
      xscope,
      by = c("be", "source", "organism", "organism_type")
    )
    xorg <- ifelse(
      xscope$organism_type == "NCBI taxon identifier",
      BED::getOrgNames(xscope$organism) %>%
        dplyr::filter(nameClass == "scientific name") %>%
        dplyr::pull(name),
      xscope$organism
    )
    for (j in 1:nrow(yscopes)) {
      yscope <- yscopes[j, ]
      if (any(apply(yscope, 2, is.na))) {
        next()
      }
      yi <- dplyr::right_join(
        y,
        yscope,
        by = c("be", "source", "organism", "organism_type")
      )
      yorg <- ifelse(
        yscope$organism_type == "NCBI taxon identifier",
        BED::getOrgNames(yscope$organism) %>%
          dplyr::filter(nameClass == "scientific name") %>%
          dplyr::pull(name),
        yscope$organism
      )
      if (xorg == yorg || orthologs) {
        xy <- BED::convBeIds(
          ids = xi$identifier,
          from = xscope$be,
          from.source = xscope$source,
          from.org = xorg,
          to = yscope$be,
          to.source = yscope$source,
          to.org = yorg,
          restricted = restricted
        ) %>%
          dplyr::as_tibble() %>%
          dplyr::select(from, to)
        if (restricted) {
          xy <- dplyr::bind_rows(
            xy,
            BED::convBeIds(
              ids = yi$identifier,
              from = yscope$be,
              from.source = yscope$source,
              from.org = yorg,
              to = xscope$be,
              to.source = xscope$source,
              to.org = xorg,
              restricted = restricted
            ) %>%
              dplyr::as_tibble() %>%
              dplyr::select(to = from, from = to)
          )
        }
        xy <- xy %>%
          dplyr::rename("identifier_x" = "from", "identifier_y" = "to") %>%
          dplyr::mutate(
            be_x = xscope$be,
            source_x = xscope$source,
            organism_x = xscope$organism,
            be_y = yscope$be,
            source_y = yscope$source,
            organism_y = yscope$organism
          )
        toRet <- dplyr::bind_rows(toRet, xy)
      }
    }
  }
  toRet <- dplyr::distinct(toRet)
  return(toRet)
}