igraphplot2.R

#modified igraph plotting code to allow for changes in edge.arrow.width. Edge.arrow.size still not supported

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 = rainbow(length(mark.groups), 
    alpha = 0.3), mark.border = rainbow(length(mark.groups), 
    alpha = 1), mark.expand = 15, ...) 
{
    graph <- x
    if (!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 <- 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) {
        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 <- V(graph)[mark.groups[[g]]]
        if (length(vertex.size) == 1) {
            vs <- vertex.size
        }
        else {
            vs <- rep(vertex.size, length = 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 <- 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 = 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)
            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
                }
                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 = 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)
        }
        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 = vcount(graph)), function(x) {
            .igraph.shapes[[shape[x]]]$plot(layout[x, , drop = FALSE], 
                v = x, params = params)
        })
    }
    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) {
        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(vcount(graph)), function(v) {
            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()) 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 * par("cin")[2]
	
	lx <- length(x1)
    
    uin <- if (is.R()) 
        1/xyinch()
    else par("uin")
    
    delta <- sqrt(h.lwd) * 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
    	y.arr <- c(-rev(wx2 + delta), wx2 + delta)#repeat it backwards
    	deg.arr <- c(atan2(y.arr, x.arr[[w]]), NA)#atan2 of y array and x array
    	r.arr <- c(sqrt(x.arr[[w]]^2 + y.arr^2), NA) #square root of x array and y array
    	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)) {
        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) {
                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 <- 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)
                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) 
            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 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) 
            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 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)
}