R/labelPoints.R

In milescsmith/WGCNA: Weighted Correlation Network Analysis

# =================================================================================================
#
# labelPoints: label points in a scatterplot while trying to avoid labels overlapping with one another
# and with points.
#
# =================================================================================================

labelPoints <- function(x, y, labels, cex = 0.7, offs = 0.01, xpd = TRUE, jiggle = 0,
                        protectEdges = TRUE,
                        doPlot = TRUE, ...) {
  nPts <- length(labels)
  box <- par("usr")
  dims <- par("pin")
  scaleX <- dims[1] / (box[2] - box[1])
  scaleY <- dims[2] / (box[4] - box[3])

  # ish = charmatch(shape, .shapes);
  # if (is.na(ish))
  #  stop(paste("Unrecognized 'shape'. Recognized values are", paste(.shapes, collapse = ", ")));

  if (par("xlog")) {
    xx <- log10(x)
  } else {
    xx <- x
  }

  if (par("ylog")) {
    yy <- log10(y)
  } else {
    yy <- y
  }

  xx <- xx * scaleX
  yy <- yy * scaleY

  if (jiggle > 0) {
    rangeX <- max(xx, na.rm = TRUE) - min(xx, na.rm = TRUE)
    jx <- xx + jiggle * rangeX * (runif(nPts) - 0.5)
    rangeY <- max(yy, na.rm = TRUE) - min(yy, na.rm = TRUE)
    jy <- yy + jiggle * rangeY * (runif(nPts) - 0.5)
  } else {
    jx <- xx
    jy <- yy
  }
  dx <- offs
  dy <- offs
  labWidth <- strwidth(labels, cex = cex) * scaleX
  labHeight <- strheight(labels, cex = cex) * scaleY
  if (nPts == 0) {
    return(0)
  }

  if (nPts == 1) {
    if (protectEdges) {
      shift <- ifelse(x - labWidth / 2 / scaleX < box[1], box[1] - x + labWidth / 2 / scaleX,
        ifelse(x + labWidth / 2 / scaleX > box[2], box[2] - x - labWidth / 2 / scaleX, 0)
      )
      x <- x + shift
      # Also check the top and bottom edges
      yShift <- if (y + labHeight / scaleY + offs / scaleY > box[4]) -(labHeight + 2 * offs) / scaleY else 0
      y <- y + yShift
    }
    text(x, y + labHeight / 2 / scaleY + offs / scaleY, labels, cex = cex, xpd = xpd, adj = c(0.5, 0.5), ...)
    return(0)
  }

  xMat <- cbind(xx, yy)
  jxMat <- cbind(jx, jy)
  distX <- as.matrix(dist(jx))
  distY <- as.matrix(dist(jy))

  dir <- matrix(0, nPts, 2)

  d0SqX <- (labWidth + 2 * offs)^2
  d0SqY <- (labHeight + 2 * offs)^2
  for (p in 1:nPts)
  {
    difs <- matrix(jxMat[p, ], nPts, 2, byrow = TRUE) - jxMat
    difSc <- difs / sqrt(matrix(apply(difs^2, 1, sum, na.rm = TRUE), nPts, 2))
    difSx <- rbind(difSc, c(0, 1))
    difSx[p, ] <- 0
    w <- c(exp(-distX[, p]^4 / d0SqX[p]^2 - distY[, p]^4 / d0SqY^2))
    w[distX[, p] == 0 & distY[, p] == 0] <- 0
    w <- c(w, 0.01)
    dir[p, ] <- apply(difSx * matrix(w, (nPts + 1), 2), 2, sum, na.rm = TRUE) / sum(w, na.rm = TRUE)

    if (sum(abs(dir[p, ])) == 0) dir[p, ] <- runif(2)
  }

  scDir <- dir / sqrt(matrix(apply(dir^2, 1, sum, na.rm = TRUE), nPts, 2))
  offsMat <- cbind(labWidth / 2 + offs, labHeight / 2 + offs)
  Rmat <- abs(scDir / offsMat)
  ind <- Rmat[, 1] > Rmat[, 2] # This is an indicator of whether the labels touch the vertical (TRUE ) or
  # horizontal (FALSE) edge of the square around the point

  # These are preliminary text coordinates relative to their points.
  dx <- offsMat[, 1] * sign(scDir[, 1])
  dx[!ind] <- scDir[!ind, 1] * offsMat[!ind, 2] / abs(scDir[!ind, 2])
  dy <- offsMat[, 2] * sign(scDir[, 2])
  dy[ind] <- scDir[ind, 2] * offsMat[ind, 1] / abs(scDir[ind, 1])

  # Absolute coordinates
  xt <- (xx + dx) / scaleX
  yt <- (yy + dy) / scaleY


  # Check if any of the points overlap with a label (of a different point)

  pointMaxx <- matrix(xx + offs, nPts, nPts)
  pointMinx <- matrix(xx - offs, nPts, nPts)
  pointMiny <- matrix(yy - offs, nPts, nPts)
  pointMaxy <- matrix(yy + offs, nPts, nPts)

  labelMinx <- matrix(xt - labWidth / 2, nPts, nPts, byrow = TRUE)
  labelMaxx <- matrix(xt + labWidth / 2, nPts, nPts, byrow = TRUE)
  labelMiny <- matrix(yt - labHeight / 2, nPts, nPts, byrow = TRUE)
  labelMaxy <- matrix(yt + labHeight / 2, nPts, nPts, byrow = TRUE)

  overlapF <- function(x1min, x1max, x2min, x2max) {
    overlap <- matrix(0, nPts, nPts)
    overlap[x1max > x2min & x1max < x2max & x1min < x2min] <- 1
    overlap[x1max > x2min & x1max < x2max & x1min > x2min] <- 2
    overlap[x1max > x2max & x1min > x2min] <- 3
    overlap
  }

  overlapX <- overlapF(pointMinx, pointMaxx, labelMinx, labelMaxx)
  overlapY <- overlapF(pointMiny, pointMaxy, labelMiny, labelMaxy)

  indOvr <- overlapX > 0 & overlapY > 0
  overlap <- matrix(0, nPts, nPts)
  overlap[indOvr] <- (overlapY[indOvr] - 1) * 3 + overlapX[indOvr]

  # For now try to fix cases of a single overlap.

  nOvrPerLabel <- apply(overlap > 0, 1, sum)

  # for (p in 1:nPts) if (nOverPerLabel[p]==1)
  # {

  # Check if any of the labels extend past the left or right edge of the plot
  if (protectEdges) {
    shift <- ifelse(xt - labWidth / 2 / scaleX < box[1], box[1] - xt + labWidth / 2 / scaleX,
      ifelse(xt + labWidth / 2 / scaleX > box[2], box[2] - xt - labWidth / 2 / scaleX, 0)
    )
    xt <- xt + shift

    # Also check the top and bottom edges
    # Do labels overlap with points along the x coordinate?
    xOverlap <- abs(xt - x) < (labWidth / 2 + offs) / scaleX

    yShift <- ifelse(yt - labHeight / 2 / scaleY < box[3],
      ifelse(xOverlap, (labHeight + 2 * offs) / scaleY, box[3] - yt + labHeight / 2 / scaleY),
      ifelse(yt + labHeight / 2 / scaleY > box[4], -(labHeight + 2 * offs) / scaleY, 0)
    )
    yt <- yt + yShift
  }

  if (par("xlog")) xt <- 10^xt
  if (par("ylog")) yt <- 10^yt

  if (doPlot) {
    text(xt, yt, labels, cex = cex, xpd = xpd, adj = c(0.5, 0.5), ...)
  }

  invisible(data.frame(x = xt, y = yt, label = labels))
}