R/igraphplot2.R

In jgockley62/igraphNetworkExpansion: Trace Subnetworks from an AD Necortical Network of Protein-Protein Interactions

i.parse.plot.params <- utils::getFromNamespace(
  "i.parse.plot.params",
  "igraph"
)
igraph.check.shapes <- utils::getFromNamespace(
  "igraph.check.shapes",
  "igraph"
)
i.get.arrow.mode <- utils::getFromNamespace(
  "i.get.arrow.mode",
  "igraph"
)
#' @importFrom graphics xspline
igraph.polygon <- utils::getFromNamespace(
  "igraph.polygon",
  "igraph"
)
.igraph.shapes <- utils::getFromNamespace(
  ".igraph.shapes",
  "igraph"
)

#' @importFrom graphics par xyinch segments xspline lines polygon
igraph.Arrows <- utils::getFromNamespace(
"igraph.Arrows",
"igraph"
)

#' Modified igraph plotting code to allow for changes in edge.arrow.width.
#'    Edge.arrow.size still not supported
#' Code provided from: jevansbio/igraphhack
#' Git User: jevansbio
#' @inheritParams igraph::plot.igraph
#' @export
plot.igraph2 <- function (
  x,
  axes = FALSE, add = FALSE,
  xlim = c(-1, 1), ylim = c(-1, 1), 
  mark.groups = list(), mark.shape = 1/2,
  mark.col = grDevices::rainbow(length(mark.groups), alpha = 0.3), 
  mark.border = grDevices::rainbow(length(mark.groups), 
  alpha = 1), mark.expand = 15, 
  ...) 
{
  graph <- x
  if (!igraph::is_igraph(graph)) {
    stop("Not a graph object")
  }
  params <- i.parse.plot.params(graph, list(...))
  vertex.size <- 1/200 * params("vertex", "size")
  label.family <- params("vertex", "label.family")
  label.font <- params("vertex", "label.font")
  label.cex <- params("vertex", "label.cex")
  label.degree <- params("vertex", "label.degree")
  label.color <- params("vertex", "label.color")
  label.dist <- params("vertex", "label.dist")
  labels <- params("vertex", "label")
  shape <- igraph.check.shapes(params("vertex", "shape"))
  edge.color <- params("edge", "color")
  edge.width <- params("edge", "width")
  edge.lty <- params("edge", "lty")
  arrow.mode <- params("edge", "arrow.mode")
  edge.labels <- params("edge", "label")
  loop.angle <- params("edge", "loop.angle")
  edge.label.font <- params("edge", "label.font")
  edge.label.family <- params("edge", "label.family")
  edge.label.cex <- params("edge", "label.cex")
  edge.label.color <- params("edge", "label.color")
  elab.x <- params("edge", "label.x")
  elab.y <- params("edge", "label.y")
  arrow.size <- params("edge", "arrow.size")
  arrow.width <- params("edge", "arrow.width")
  curved <- params("edge", "curved")
  if (is.function(curved)) {
    curved <- curved(graph)
  }
  layout <- params("plot", "layout")
  margin <- params("plot", "margin")
  margin <- rep(margin, length = 4)
  rescale <- params("plot", "rescale")
  asp <- params("plot", "asp")
  frame <- params("plot", "frame")
  main <- params("plot", "main")
  sub <- params("plot", "sub")
  xlab <- params("plot", "xlab")
  ylab <- params("plot", "ylab")
  palette <- params("plot", "palette")
  if (!is.null(palette)) {
    old_palette <- palette(palette)
    on.exit(palette(old_palette), add = TRUE)
  }
  arrow.mode <- i.get.arrow.mode(graph, arrow.mode)
  maxv <- max(vertex.size)
  if (rescale) {
    layout <- igraph::norm_coords(layout, -1, 1, -1, 1)
    xlim <- c(xlim[1] - margin[2] - maxv, xlim[2] + margin[4] + 
                maxv)
    ylim <- c(ylim[1] - margin[1] - maxv, ylim[2] + margin[3] + 
                maxv)
  }
  if (!add) {
    graphics::plot(0, 0, type = "n", xlab = xlab, ylab = ylab, xlim = xlim, 
         ylim = ylim, axes = axes, frame = frame, asp = asp, 
         main = main, sub = sub)
  }
  if (!is.list(mark.groups) && is.numeric(mark.groups)) {
    mark.groups <- list(mark.groups)
  }
  mark.shape <- rep(mark.shape, length = length(mark.groups))
  mark.border <- rep(mark.border, length = length(mark.groups))
  mark.col <- rep(mark.col, length = length(mark.groups))
  mark.expand <- rep(mark.expand, length = length(mark.groups))
  for (g in seq_along(mark.groups)) {
    v <- igraph::V(graph)[mark.groups[[g]]]
    if (length(vertex.size) == 1) {
      vs <- vertex.size
    }
    else {
      vs <- rep(vertex.size, length = igraph::vcount(graph))[v]
    }
    igraph.polygon(layout[v, , drop = FALSE], vertex.size = vs, 
                   expand.by = mark.expand[g]/200, shape = mark.shape[g], 
                   col = mark.col[g], border = mark.border[g])
  }
  el <- igraph::as_edgelist(graph, names = FALSE)
  loops.e <- which(el[, 1] == el[, 2])
  nonloops.e <- which(el[, 1] != el[, 2])
  loops.v <- el[, 1][loops.e]
  loop.labels <- edge.labels[loops.e]
  loop.labx <- if (is.null(elab.x)) {
    rep(NA, length(loops.e))
  }
  else {
    elab.x[loops.e]
  }
  loop.laby <- if (is.null(elab.y)) {
    rep(NA, length(loops.e))
  }
  else {
    elab.y[loops.e]
  }
  edge.labels <- edge.labels[nonloops.e]
  elab.x <- if (is.null(elab.x)) 
    NULL
  else elab.x[nonloops.e]
  elab.y <- if (is.null(elab.y)) 
    NULL
  else elab.y[nonloops.e]
  el <- el[nonloops.e, , drop = FALSE]
  edge.coords <- matrix(0, nrow = nrow(el), ncol = 4)
  edge.coords[, 1] <- layout[, 1][el[, 1]]
  edge.coords[, 2] <- layout[, 2][el[, 1]]
  edge.coords[, 3] <- layout[, 1][el[, 2]]
  edge.coords[, 4] <- layout[, 2][el[, 2]]
  if (length(unique(shape)) == 1) {
    ec <- .igraph.shapes[[shape[1]]]$clip(edge.coords, el, 
                                          params = params, end = "both")
  }
  else {
    shape <- rep(shape, length = igraph::vcount(graph))
    ec <- edge.coords
    ec[, 1:2] <- t(sapply(seq(
      length = nrow(el)), function(x) {
        .igraph.shapes[[shape[el[x, 1]]]]$clip(
          edge.coords[x, , drop = FALSE],
          el[x, , drop = FALSE],
          params = params, end = "from"
        )
      }
    ))
    ec[, 3:4] <- t(sapply(seq(
      length = nrow(el)), function(x) {
        .igraph.shapes[[shape[el[x, 2]]]]$clip(
          edge.coords[x, , drop = FALSE], 
          el[x, , drop = FALSE], 
          params = params,
          end = "to"
        )
      }
    ))
  }
  x0 <- ec[, 1]
  y0 <- ec[, 2]
  x1 <- ec[, 3]
  y1 <- ec[, 4]
  if (length(loops.e) > 0) {
    ec <- edge.color
    if (length(ec) > 1) {
      ec <- ec[loops.e]
    }
    point.on.cubic.bezier <- function(cp, t) {
      c <- 3 * (cp[2, ] - cp[1, ])
      b <- 3 * (cp[3, ] - cp[2, ]) - c
      a <- cp[4, ] - cp[1, ] - c - b
      t2 <- t * t
      t3 <- t * t * t
      a * t3 + b * t2 + c * t + cp[1, ]
    }
    compute.bezier <- function(cp, points) {
      dt <- seq(0, 1, by = 1/(points - 1))
      sapply(dt, function(t) point.on.cubic.bezier(cp, 
                                                   t))
    }
    plot.bezier <- function(cp, points, color, width, arr, 
                            lty, arrow.size, arr.w) {
      p <- compute.bezier(cp, points)
      graphics::polygon(p[1, ], p[2, ], border = color, lwd = width, 
              lty = lty)
      if (arr == 1 || arr == 3) {
        igraph.Arrows(
          p[1, ncol(p) - 1],
          p[2, ncol(p) - 1],
          p[1, ncol(p)],
          p[2, ncol(p)],
          sh.col = color,
          h.col = color,
          size = arrow.size,
          sh.lwd = width,
          h.lwd = width,
          open = FALSE,
          code = 2,
          width = arr.w
        )
      }
      if (arr == 2 || arr == 3) {
        igraph.Arrows(
          p[1, 2], p[2, 2], p[1, 1], p[2, 1], 
          sh.col = color, h.col = color,
          size = arrow.size, sh.lwd = width, 
          h.lwd = width, open = FALSE,
          code = 2, width = arr.w
        )
      }
    }
    loop <- function(
      x0, y0, cx = x0, cy = y0, color, angle = 0, label = NA, width = 1,
      arr = 2, lty = 1, arrow.size = arrow.size, arr.w = arr.w, lab.x, lab.y
    ) {
      rad <- angle
      center <- c(cx, cy)
      cp <- matrix(c(x0, y0, x0 + 0.4, y0 + 0.2, x0 + 0.4, 
                     y0 - 0.2, x0, y0), ncol = 2, byrow = TRUE)
      phi <- atan2(cp[, 2] - center[2], cp[, 1] - center[1])
      r <- sqrt((cp[, 1] - center[1])^2 + (cp[, 2] - center[2])^2)
      phi <- phi + rad
      cp[, 1] <- cx + r * cos(phi)
      cp[, 2] <- cy + r * sin(phi)
      plot.bezier(cp, 50, color, width, arr = arr, lty = lty, 
                  arrow.size = arrow.size, arr.w = arr.w)
      if (is.language(label) || !is.na(label)) {
        lx <- x0 + 0.3
        ly <- y0
        phi <- atan2(ly - center[2], lx - center[1])
        r <- sqrt((lx - center[1])^2 + (ly - center[2])^2)
        phi <- phi + rad
        lx <- cx + r * cos(phi)
        ly <- cy + r * sin(phi)
        if (!is.na(lab.x)) {
          lx <- lab.x
        }
        if (!is.na(lab.y)) {
          ly <- lab.y
        }
        graphics::text(lx, ly, label, col = edge.label.color, font = edge.label.font, 
             family = edge.label.family, cex = edge.label.cex)
      }
    }
    ec <- edge.color
    if (length(ec) > 1) {
      ec <- ec[loops.e]
    }
    vs <- vertex.size
    if (length(vertex.size) > 1) {
      vs <- vs[loops.v]
    }
    ew <- edge.width
    if (length(edge.width) > 1) {
      ew <- ew[loops.e]
    }
    la <- loop.angle
    if (length(loop.angle) > 1) {
      la <- la[loops.e]
    }
    lty <- edge.lty
    if (length(edge.lty) > 1) {
      lty <- lty[loops.e]
    }
    arr <- arrow.mode
    if (length(arrow.mode) > 1) {
      arr <- arrow.mode[loops.e]
    }
    asize <- arrow.size
    if (length(arrow.size) > 1) {
      asize <- arrow.size[loops.e]
    }
    xx0 <- layout[loops.v, 1] + cos(la) * vs
    yy0 <- layout[loops.v, 2] - sin(la) * vs
    mapply(loop, xx0, yy0, color = ec, angle = -la, label = loop.labels, 
           lty = lty, width = ew, arr = arr, arrow.size = asize, 
           arr.w = arrow.width, lab.x = loop.labx, lab.y = loop.laby)
  }
  if (length(x0) != 0) {
    if (length(edge.color) > 1) {
      edge.color <- edge.color[nonloops.e]
    }
    if (length(edge.width) > 1) {
      edge.width <- edge.width[nonloops.e]
    }
    if (length(edge.lty) > 1) {
      edge.lty <- edge.lty[nonloops.e]
    }
    if (length(arrow.mode) > 1) {
      arrow.mode <- arrow.mode[nonloops.e]
    }
    if (length(arrow.size) > 1) {
      arrow.size <- arrow.size[nonloops.e]
      # modify here for multple arrow sizes - 
      # will pad out vector inside arrow function
      arrow.size = arrow.size[!is.na(arrow.size)]
    }
    if (length(curved) > 1) {
      curved <- curved[nonloops.e]
    }
    if (length(unique(arrow.mode)) == 1) {
      lc <- igraph.Arrows2(
        x0, y0, x1, y1, h.col = edge.color, sh.col = edge.color, 
        sh.lwd = edge.width, h.lwd = 1, open = FALSE, 
        code = arrow.mode[1], sh.lty = edge.lty, h.lty = 1, 
        size = arrow.size, width = arrow.width, curved = curved
      )
      lc.x <- lc$lab.x
      lc.y <- lc$lab.y
    }
    else {
      curved <- rep(curved, length = igraph::ecount(graph))[nonloops.e]
      lc.x <- lc.y <- numeric(length(curved))
      for (code in 0:3) {
        valid <- arrow.mode == code
        if (!any(valid)) {
          next
        }
        ec <- edge.color
        if (length(ec) > 1) {
          ec <- ec[valid]
        }
        ew <- edge.width
        if (length(ew) > 1) {
          ew <- ew[valid]
        }
        el <- edge.lty
        if (length(el) > 1) {
          el <- el[valid]
        }
        lc <- igraph.Arrows(
          x0[valid], y0[valid], x1[valid], y1[valid], code = code, 
          sh.col = ec, h.col = ec, sh.lwd = ew, h.lwd = 1, h.lty = 1,
          sh.lty = el, open = FALSE, size = arrow.size, 
          width = arrow.width, curved = curved[valid]
        )
        lc.x[valid] <- lc$lab.x
        lc.y[valid] <- lc$lab.y
      }
    }
    if (!is.null(elab.x)) {
      lc.x <- ifelse(is.na(elab.x), lc.x, elab.x)
    }
    if (!is.null(elab.y)) {
      lc.y <- ifelse(is.na(elab.y), lc.y, elab.y)
    }
    graphics::text(lc.x, lc.y, labels = edge.labels, col = edge.label.color, 
         family = edge.label.family, font = edge.label.font, 
         cex = edge.label.cex)
  }
  rm(x0, y0, x1, y1)
  if (length(unique(shape)) == 1) {
    .igraph.shapes[[shape[1]]]$plot(layout, params = params)
  }
  else {
    sapply(seq(length = igraph::vcount(graph)), function(x) {
      .igraph.shapes[[shape[x]]]$plot(layout[x, , drop = FALSE], 
                                      v = x, params = params)
    })
  }
  graphics::par(xpd = TRUE)
  x <- layout[, 1] + label.dist * cos(-label.degree) * 
    (vertex.size +  6 * 8 * log10(2)) / 200
  y <- layout[, 2] + label.dist * sin(-label.degree) * 
    (vertex.size + 6 * 8 * log10(2)) / 200
  if (length(label.family) == 1) {
    graphics::text(x, y, labels = labels, col = label.color, family = label.family, 
         font = label.font, cex = label.cex)
  }
  else {
    if1 <- function(vect, idx) if (length(vect) == 1) 
      vect
    else vect[idx]
    sapply(seq_len(igraph::vcount(graph)), function(v) {
      graphics::text(
        x[v], y[v], labels = if1(labels, v), col = if1(label.color, v),
        family = if1(label.family, v), font = if1(label.font,  v), 
        cex = if1(label.cex, v)
      )
    })
  }
  rm(x, y)
  invisible(NULL)
}

igraph.Arrows2 = function (
  x1, y1, x2, y2, code = 2, size = 1, width = 1.2/4/cin, open = TRUE,
  sh.adj = 0.1, sh.lwd = 1, sh.col = if (is.R()) graphics::par("fg") else 1, 
  sh.lty = 1, h.col = sh.col, h.col.bo = sh.col, h.lwd = sh.lwd, 
  h.lty = sh.lty, curved = FALSE
) {
  cin <- size * graphics::par("cin")[2]
  
  lx <- length(x1)
  
  uin <- if (is.R()) 
    1/graphics::xyinch()
  else graphics::par("uin")
  
  delta <- sqrt(h.lwd) * graphics::par("cin")[2] * 0.005
  
  #modify for multiple sizes here
  arrlist=lapply(1:length(size),function(w){
    x <- sqrt(seq(0, cin[w]^2, length = floor(35 * cin[w]) + 2))
    x.arr <- c(-rev(x), -x)
    return(list(x=x,x.arr=x.arr))
  })
  x=lapply(arrlist,function(w) w$x)
  x.arr=lapply(arrlist,function(w) w$x.arr)
  #pad size to same length as edges
  wx=lx/length(x)
  if(wx>1){
    x=rep(x,ceiling(wx))
    x.arr=rep(x.arr,ceiling(wx))
    cin=rep(cin,ceiling(wx))
  }
  wx=lx/length(width)
  if(wx>1){
    width=rep(width,ceiling(wx))
  }
  width <- width * (1.2/4/cin)
  
  #modify for multiple widths here
  arrlist=lapply(1:length(width),function(w){
    
    wx2<-width[w]*x[[w]]^2
    #repeat it backwards
    y.arr <- c(-rev(wx2 + delta), wx2 + delta)
    #atan2 of y array and x array
    deg.arr <- c(atan2(y.arr, x.arr[[w]]), NA)
    #square root of x array and y array
    r.arr <- c(sqrt(x.arr[[w]]^2 + y.arr^2), NA)
    return(list(deg.arr=deg.arr,r.arr=r.arr))
  })
  deg.arr=do.call(c,lapply(arrlist,function(w) w$deg.arr))
  r.arr=do.call(c,lapply(arrlist,function(w) w$r.arr))
  deg.arr2=lapply(arrlist,function(w) w$deg.arr)
  
  bx1 <- x1
  bx2 <- x2
  by1 <- y1
  by2 <- y2
  
  #modify for multiple arrow sizes
  
  if(length(cin)==1){
    r.seg <- rep(cin * sh.adj, lx)
    theta1 <- atan2((y1 - y2) * uin[2], (x1 - x2) * uin[1])
    th.seg1 <- theta1 + rep(atan2(0, -cin), lx)
    theta2 <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1])
    th.seg2 <- theta2 + rep(atan2(0, -cin), lx)
  }else{
    r.seg <- cin * sh.adj
    theta1 <- atan2((y1 - y2) * uin[2], (x1 - x2) * uin[1])
    th.seg1 <- theta1 + (atan2(0, -cin))
    theta2 <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1])
    th.seg2 <- theta2 + (atan2(0, -cin))		
  }
  
  
  x1d <- y1d <- x2d <- y2d <- 0
  if (code %in% c(1, 3)) {
    x2d <- r.seg * cos(th.seg2)/uin[1]
    y2d <- r.seg * sin(th.seg2)/uin[2]
  }
  if (code %in% c(2, 3)) {
    x1d <- r.seg * cos(th.seg1)/uin[1]
    y1d <- r.seg * sin(th.seg1)/uin[2]
  }
  if (is.logical(curved) && all(!curved) || is.numeric(curved) && 
      all(!curved)) {
    graphics::segments(x1 + x1d, y1 + y1d, x2 + x2d, y2 + y2d, lwd = sh.lwd, 
             col = sh.col, lty = sh.lty)
    phi <- atan2(y1 - y2, x1 - x2)
    r <- sqrt((x1 - x2)^2 + (y1 - y2)^2)
    lc.x <- x2 + 2/3 * r * cos(phi)
    lc.y <- y2 + 2/3 * r * sin(phi)
  }
  else {
    if (is.numeric(curved)) {
      lambda <- curved
    }
    else {
      lambda <- as.logical(curved) * 0.5
    }
    lambda <- rep(lambda, length.out = length(x1))
    c.x1 <- x1 + x1d
    c.y1 <- y1 + y1d
    c.x2 <- x2 + x2d
    c.y2 <- y2 + y2d
    midx <- (x1 + x2)/2
    midy <- (y1 + y2)/2
    spx <- midx - lambda * 1/2 * (c.y2 - c.y1)
    spy <- midy + lambda * 1/2 * (c.x2 - c.x1)
    sh.col <- rep(sh.col, length = length(c.x1))
    sh.lty <- rep(sh.lty, length = length(c.x1))
    sh.lwd <- rep(sh.lwd, length = length(c.x1))
    lc.x <- lc.y <- numeric(length(c.x1))
    for (i in seq_len(length(c.x1))) {
      if (lambda[i] == 0) {
        graphics::segments(c.x1[i], c.y1[i], c.x2[i], c.y2[i], 
                 lwd = sh.lwd[i], col = sh.col[i], lty = sh.lty[i])
        phi <- atan2(y1[i] - y2[i], x1[i] - x2[i])
        r <- sqrt((x1[i] - x2[i])^2 + (y1[i] - y2[i])^2)
        lc.x[i] <- x2[i] + 2/3 * r * cos(phi)
        lc.y[i] <- y2[i] + 2/3 * r * sin(phi)
      }
      else {
        spl <- graphics::xspline(x = c(c.x1[i], spx[i], c.x2[i]), 
                       y = c(c.y1[i], spy[i], c.y2[i]), shape = 1, 
                       draw = FALSE)
        graphics::lines(spl, lwd = sh.lwd[i], col = sh.col[i], 
              lty = sh.lty[i])
        if (code %in% c(2, 3)) {
          x1[i] <- spl$x[3 * length(spl$x)/4]
          y1[i] <- spl$y[3 * length(spl$y)/4]
        }
        if (code %in% c(1, 3)) {
          x2[i] <- spl$x[length(spl$x)/4]
          y2[i] <- spl$y[length(spl$y)/4]
        }
        lc.x[i] <- spl$x[2/3 * length(spl$x)]
        lc.y[i] <- spl$y[2/3 * length(spl$y)]
      }
    }
  }
  if (code %in% c(2, 3)) {
    theta <- atan2((by2 - y1) * uin[2], (bx2 - x1) * uin[1])
    
    #alter here for multiple arrow widths/size
    if(length(width)==1&length(size)==1){
      Rep <- rep(length(deg.arr), lx)
    } else {
      Rep <- sapply(deg.arr2,length)
    }
    p.x2 <- rep(bx2, Rep)
    p.y2 <- rep(by2, Rep)
    if(length(width)==1&length(size)==1){
      ttheta <- rep(theta, Rep) + rep(deg.arr, lx)
      r.arr <- rep(r.arr, lx) 
    } else {#repping not neccesary
      ttheta <- rep(theta, Rep) + deg.arr
    }
    if (open) 
      graphics::lines(
        (p.x2 + r.arr * cos(ttheta) / uin[1]),
        (p.y2 + r.arr * sin(ttheta) / uin[2]),
        lwd = h.lwd, col = h.col.bo, lty = h.lty
      )
    else graphics::polygon(
      p.x2 + r.arr * cos(ttheta)/uin[1],
      p.y2 + r.arr * sin(ttheta)/uin[2],
      col = h.col,
      lwd = h.lwd,
      border = h.col.bo, 
      lty = h.lty
    )
  }
  if (code %in% c(1, 3)) {
    x1 <- bx1
    y1 <- by1
    tmp <- x1
    x1 <- x2
    x2 <- tmp
    tmp <- y1
    y1 <- y2
    y2 <- tmp
    theta <- atan2((y2 - y1) * uin[2], (x2 - x1) * uin[1])
    lx <- length(x1)
    Rep <- rep(length(deg.arr), lx)
    p.x2 <- rep(x2, Rep)
    p.y2 <- rep(y2, Rep)
    ttheta <- rep(theta, Rep) + rep(deg.arr, lx)
    r.arr <- rep(r.arr, lx)
    if (open) 
      graphics::lines(
        (p.x2 + r.arr * cos(ttheta)/uin[1]),
        (p.y2 + r.arr * sin(ttheta)/uin[2]),
        lwd = h.lwd,
        col = h.col.bo,
        lty = h.lty
      )
    else graphics::polygon(
      p.x2 + r.arr * cos(ttheta)/uin[1], 
      p.y2 + r.arr * sin(ttheta)/uin[2],
      col = h.col,
      lwd = h.lwd,
      border = h.col.bo,
      lty = h.lty
    )
  }
  list(lab.x = lc.x, lab.y = lc.y)
}