R/recolor.R

In ialmodovar/SynClustR: Syncytial Clustering Algorithms in R

oranges <- colorRampPalette(c("#FFF5EB","#FEE6CE","#FDD0A2","#FDAE6B",
                              "#FD8D3C","#F16913","#D94801","#A63603","#7F2704"))
purd <- colorRampPalette(c("#F7F4F9","#E7E1EF","#D4B9DA","#C994C7",
                           "#DF65B0","#E7298A","#CE1256","#980043","#67001F"))

paired <- c("#A6CEE3","#1F78B4","#B2DF8A","#33A02C","#FB9A99","#E31A1C",
            "#FDBF6F","#FF7F00","#CAB2D6","#6A3D9A","#FFFF99","#B15928")

ylgnbu <- colorRampPalette(c("#FFFFD9","#EDF8B1","#C7E9B4","#7FCDBB","#41B6C4",
                             "#1D91C0","#225EA8","#253494","#081D58"))

which.max.matrix <- function(mat) (which(x = mat == max(mat), arr.ind=T))

rematch <- function(tg.id, cl.id) {
  ##
  ## This function remaps the colors in the classification vector cl.id to the
  ## target class vector given by tg.id. It is the heart of the recolor function
  ## and is usually called from recolor. However, it can easily be used as a
  ## standalone function.
  ##
  ## written Ranjan Maitra, Ames, IA 50011-1210, 2015/10/26
  
  cl.id.tmp <- recode(cl.id) - min(cl.id) + 1
  tg.id.tmp <- recode(tg.id) - min(tg.id) + 1
  orig.cl.id <- sort(unique(cl.id))
  orig.tg.id <- sort(unique(tg.id)) 
  
  xtabs <- table(tg.id.tmp, cl.id.tmp)
  ncl <- max(cl.id.tmp)
  ntg <- max(tg.id.tmp)
  id.tg <- NULL
  id.cl <- NULL
  tg.idx <- 1:ntg 
  cl.idx <- 1:ncl 
  for (i in 1:min(c(ncl,ntg))) {
    xtab <- xtabs[tg.idx, cl.idx]
    if (!is.null(dim(xtab))) {
      ind <- which.max.matrix(xtab)[1,]
      id.tg <- c(id.tg, tg.idx[ind[1]])
      id.cl <- c(id.cl, cl.idx[ind[2]])
      tg.idx <- setdiff(tg.idx, tg.idx[ind[1]])
      cl.idx <- setdiff(cl.idx, cl.idx[ind[2]])
    }
    else {
      if (ncl == ntg) {
        id.cl <- c(id.cl, cl.idx)
        id.tg <- c(id.tg, tg.idx)
      }
      else {
        ind <- which.max(xtab)
        if (ncl > ntg) {
          id.cl <- c(id.cl,cl.idx[ind])
          id.tg <- c(id.tg,tg.idx)
          cl.idx <- setdiff(cl.idx, cl.idx[ind])
          id.cl <- c(id.cl, cl.idx)
        }
        else {
          id.cl <- c(id.cl,cl.idx)
          id.tg <- c(id.tg,tg.idx[ind])
          tg.idx <- setdiff(tg.idx, tg.idx[ind])
          id.tg <- c(id.tg, tg.idx)
        }
      }
    }
  }
  return(list(id.class = orig.cl.id[id.cl], id.target = orig.tg.id[id.tg]))
}

recode <- function(id) {
  ##
  ## This function reorders classes to eliminate group ids without any members.
  ## It is assumed that the group ids are integers
  ## Written Ranjan Maitra, Ames, IA 50011-1210, 2015/10/26
  ##

  cl.sort <- sort(unique(id))
  if (length(cl.sort) < 1 + diff(range(cl.sort))) {
    j <- min(id)
    for (i in 1:length(cl.sort)) {
      id[id==cl.sort[i]] <- j
      j <- j + 1
    }
  }
  return(id)
}

recolor <- function(id.target, id.class, scatter.class = NULL, scatter.target = NULL) {
  ##
  ## This function colors id.target in accordance with the most likely candidate
  ## in id.class. It returns a list as id.trcl (which is a factor version of 
  ## id.class) and id.prcl (which is a factored version of the colored id.target)
  ## Note that if scatter is present, then the class given by 0 is represented
  ## as scatter and it is assumed to be the same for both classifications.
  ##
  ## written Ranjan Maitra, Ames, IA 50011-1210, 2015/10/19
  ##

  ## first erase missing classes
  id.cl <- recode(id.class)
  id.tg <- recode(id.target)
  tg.id <- id.tg
  cl.id <- id.cl
  if (!is.null(scatter.target) | !is.null(scatter.class)) {
    tg.id <- id.tg[(id.tg != scatter.target) & (id.cl != scatter.class)]
    cl.id <- cl.id[(id.tg != scatter.target) & (id.cl != scatter.class)]
  }
  cls <- rematch(tg.id, cl.id)
  tg.ids <- cls$id.target
  cl.ids <- cls$id.class
  for (i in 1:min(c(length(tg.ids),length(cl.ids))))  {
    id.cl[id.cl == tg.ids[i]] <- -1
    id.cl[id.cl == cl.ids[i]] <- tg.ids[i]
    id.cl[id.cl == -1] <- cl.ids[i]
    j <- i+1
    while (j <= min(c(length(tg.ids),length(cl.ids)))) {
      if (cl.ids[j] == tg.ids[i]) {
        cl.ids[j] <- cl.ids[i]
        j <-  min(c(length(tg.ids),length(cl.ids)))
      }
      else
        j <- j + 1
    }
  }
  return(id.cl)
}