R/plot.R

######################################################################
#
# plot.R
#
# Written by Carter T. Butts <[email protected]>; portions contributed by
# David Hunter <[email protected]> and Mark S. Handcock
# <[email protected]>.
#
# Last Modified 02/26/13
# Licensed under the GNU General Public License version 2 (June, 1991)
#
# Part of the R/network package
#
# This file contains various routines related to network visualization.
#
# Contents:
#
#   network.arrow
#   network.loop
#   network.vertex
#   plot.network
#   plot.network.default
#
######################################################################


#Introduce a function to make coordinates for a single polygon
make.arrow.poly.coords<-function(x0,y0,x1,y1,ahangle,ahlen,swid,toff,hoff,ahead, curve,csteps){ 
  slen<-sqrt((x0-x1)^2+(y0-y1)^2)  #Find the total length
  if(curve==0){         #Straight edges
    if(ahead){    
      coord<-rbind(                    #Produce a "generic" version w/head
        c(-swid/2,toff),
        c(-swid/2,slen-0.5*ahlen-hoff),
        c(-ahlen*sin(ahangle),slen-ahlen*cos(ahangle)-hoff),
        c(0,slen-hoff),
        c(ahlen*sin(ahangle),slen-ahlen*cos(ahangle)-hoff),
        c(swid/2,slen-0.5*ahlen-hoff),
        c(swid/2,toff),
        c(NA,NA)
      )
    }else{
      coord<-rbind(                    #Produce a "generic" version w/out head
        c(-swid/2,toff),
        c(-swid/2,slen-hoff),
        c(swid/2,slen-hoff),
        c(swid/2,toff),
        c(NA,NA)
      )
    }
  }else{             #Curved edges
    if(ahead){    
      inc<-(0:csteps)/csteps
      coord<-rbind(
        cbind(-curve*(1-(2*(inc-0.5))^2)-swid/2-sqrt(2)/2*(toff+inc*(hoff-toff)), inc*(slen-sqrt(2)/2*(hoff+toff)-ahlen*0.5)+sqrt(2)/2*toff),
        c(ahlen*sin(-ahangle-pi/16)-sqrt(2)/2*hoff, slen-ahlen*cos(-ahangle-pi/16)-sqrt(2)/2*hoff),
        c(-sqrt(2)/2*hoff,slen-sqrt(2)/2*hoff),
        c(ahlen*sin(ahangle-pi/16)-sqrt(2)/2*hoff, slen-ahlen*cos(ahangle-pi/16)-sqrt(2)/2*hoff),
        cbind(-curve*(1-(2*(rev(inc)-0.5))^2)+swid/2-sqrt(2)/2*(toff+rev(inc)*(hoff-toff)), rev(inc)*(slen-sqrt(2)/2*(hoff+toff)-ahlen*0.5)+sqrt(2)/2*toff),
        c(NA,NA)
      )
    }else{
      inc<-(0:csteps)/csteps
      coord<-rbind(
        cbind(-curve*(1-(2*(inc-0.5))^2)-swid/2-sqrt(2)/2*(toff+inc*(hoff-toff)), inc*(slen-sqrt(2)/2*(hoff+toff))+sqrt(2)/2*toff),
        cbind(-curve*(1-(2*(rev(inc)-0.5))^2)+swid/2-sqrt(2)/2*(toff+rev(inc)*(hoff-toff)), rev(inc)*(slen-sqrt(2)/2*(hoff+toff))+sqrt(2)/2*toff),
        c(NA,NA)
      )
    }
  }
  theta<-atan2(y1-y0,x1-x0)-pi/2     #Rotate about origin
  rmat<-rbind(c(cos(theta),sin(theta)),c(-sin(theta),cos(theta)))
  coord<-coord%*%rmat
  coord[,1]<-coord[,1]+x0            #Translate to (x0,y0)
  coord[,2]<-coord[,2]+y0
  coord
}

#Custom arrow-drawing method for plot.network
network.arrow<-function(x0,y0,x1,y1,length=0.1,angle=20,width=0.01,col=1,border=1,lty=1,offset.head=0,offset.tail=0,arrowhead=TRUE,curve=0,edge.steps=50,...){
  if(length(x0)==0)   #Leave if there's nothing to do
    return;

  #"Stretch" the arguments
  n<-length(x0)
  angle<-rep(angle,length=n)/360*2*pi
  length<-rep(length,length=n)
  width<-rep(width,length=n)
  col<-rep(col,length=n)
  border<-rep(border,length=n)
  lty<-rep(lty,length=n)
  arrowhead<-rep(arrowhead,length=n)
  offset.head<-rep(offset.head,length=n)
  offset.tail<-rep(offset.tail,length=n)
  curve<-rep(curve,length=n)
  edge.steps<-rep(edge.steps,length=n)
  #Obtain coordinates
  coord<-vector()
  for(i in 1:n)  
    coord<-rbind(coord,make.arrow.poly.coords(x0[i],y0[i],x1[i],y1[i],angle[i],length[i], width[i],offset.tail[i],offset.head[i],arrowhead[i],curve[i],edge.steps[i]))
  coord<-coord[-NROW(coord),]
  #Draw polygons.  
  # the coord matrix has some NA rows, which will break it into multiple polygons
  polygon(coord,col=col,border=border,lty=lty,...)
}

#Introduce a function to make coordinates for a single polygon
make.loop.poly.coords<-function(x0,y0,xctr,yctr,ahangle,ahlen,swid,off,rad,ahead,edge.steps){
  #Determine the center of the plot
  xoff <- x0-xctr
  yoff <- y0-yctr
  roff <- sqrt(xoff^2+yoff^2)
  x0hat <- xoff/roff
  y0hat <- yoff/roff
  r0.vertex <- off
  r0.loop <- rad
  x0.loop <- x0hat*r0.loop
  y0.loop <- y0hat*r0.loop
  ang <- (((0:edge.steps)/edge.steps)*(1-(2*r0.vertex+0.5*ahlen*ahead)/ (2*pi*r0.loop))+r0.vertex/(2*pi*r0.loop))*2*pi+atan2(-yoff,-xoff)
  ang2 <- ((1-(2*r0.vertex)/(2*pi*r0.loop))+r0.vertex/(2*pi*r0.loop))*2*pi+ atan2(-yoff,-xoff)
  if(ahead){
    x0.arrow <- x0.loop+(r0.loop+swid/2)*cos(ang2)
    y0.arrow <- y0.loop+(r0.loop+swid/2)*sin(ang2)
    coord<-rbind(
      cbind(x0.loop+(r0.loop+swid/2)*cos(ang), 
            y0.loop+(r0.loop+swid/2)*sin(ang)),
      cbind(x0.arrow+ahlen*cos(ang2-pi/2),
            y0.arrow+ahlen*sin(ang2-pi/2)),
      cbind(x0.arrow,y0.arrow),
      cbind(x0.arrow+ahlen*cos(-2*ahangle+ang2-pi/2),
            y0.arrow+ahlen*sin(-2*ahangle+ang2-pi/2)),
      cbind(x0.loop+(r0.loop-swid/2)*cos(rev(ang)),
            y0.loop+(r0.loop-swid/2)*sin(rev(ang))),
      c(NA,NA)
    )
  }else{
    coord<-rbind(
      cbind(x0.loop+(r0.loop+swid/2)*cos(ang),
            y0.loop+(r0.loop+swid/2)*sin(ang)),
      cbind(x0.loop+(r0.loop-swid/2)*cos(rev(ang)),
            y0.loop+(r0.loop-swid/2)*sin(rev(ang))),
      c(NA,NA)
    )
  }
  coord[,1]<-coord[,1]+x0            #Translate to (x0,y0)
  coord[,2]<-coord[,2]+y0
  coord
}

#Custom loop-drawing method for plot.network
network.loop<-function(x0,y0,length=0.1,angle=10,width=0.01,col=1,border=1,lty=1,offset=0,edge.steps=10,radius=1,arrowhead=TRUE,xctr=0,yctr=0,...){
  if(length(x0)==0)   #Leave if there's nothing to do
    return;

  #"Stretch" the arguments
  n<-length(x0)
  angle<-rep(angle,length=n)/360*2*pi
  length<-rep(length,length=n)
  width<-rep(width,length=n)
  col<-rep(col,length=n)
  border<-rep(border,length=n)
  lty<-rep(lty,length=n)
  rad<-rep(radius,length=n)
  arrowhead<-rep(arrowhead,length=n)
  offset<-rep(offset,length=n)
  #Obtain coordinates
  coord<-vector()
  for(i in 1:n)  
    coord<-rbind(coord,make.loop.poly.coords(x0[i],y0[i],xctr,yctr,angle[i],length[i], width[i],offset[i],rad[i],arrowhead[i],edge.steps))
  coord<-coord[-NROW(coord),]
  #Draw polygons
  polygon(coord,col=col,border=border,lty=lty,...)
}

#Introduce a function to make coordinates for a single vertex polygon
# this version just uses the raw radius, so triangles appear half the size of circles
old.make.vertex.poly.coords<-function(x,y,r,s,rot){
  ang<-(1:s)/s*2*pi+rot*2*pi/360
  rbind(cbind(x+r*cos(ang),y+r*sin(ang)),c(NA,NA))  
}

#Introduce a function to make coordinates for a single vertex polygon
# all polygons produced will have equal area
make.vertex.poly.coords<-function(x,y,r,s,rot){
  # trap some edge cases
  if(is.na(s) || s<2){
    return(rbind(c(x,y),c(NA,NA))) # return a single point
  } else {
    #scale r (circumradius) to make area equal
    area<-pi*r^2  # target area based desired r as radius of circle
    # solve for new r as polygon radius that would match the area of the circle
    r<-sqrt(2*area / (s*sin(2*pi/s)))
    ang<-(1:s)/s*2*pi+rot*2*pi/360
    return(rbind(cbind(x+r*cos(ang),y+r*sin(ang)),c(NA,NA)))
  }
}

#Routine to plot vertices, using polygons
network.vertex<-function(x,y,radius=1,sides=4,border=1,col=2,lty=NULL,rot=0,lwd=1,...){
  
  #Prep the vars
  n<-length(x)
  radius<-rep(radius,length=n)
  sides<-rep(sides,length=n)
  border<-rep(border,length=n)
  col<-rep(col,length=n)
  lty<-rep(lty,length=n)
  rot<-rep(rot,length=n)
  lwd<-rep(lwd,length=n)
  #Obtain the coordinates
  coord<-vector()
  for(i in 1:length(x)) {
    coord<-make.vertex.poly.coords(x[i],y[i],radius[i],sides[i],rot[i])
    polygon(coord,border=border[i],col=col[i],lty=lty[i],lwd=lwd[i], ...)
  }
  #Plot the polygons
  
}

# draw a label for a network edge
network.edgelabel<-function(px0,py0,px1,py1,label,directed,loops=FALSE,cex,curve=0,...){
  curve<-rep(curve,length(label))
  posl<-rep(0,length(label))
  offsets<-rep(0.1,length(label))
    if (loops){  # loops version 
      # assume coordinates are the first pair
      # math is hard.  For now just draw label near the vertex
      lpx<-px0
      lpy<-py0
      # compute crude offset so that label doesn't land on vertex
      # todo, this doesn't work well on all edge orientations
      posl<-rep(0,length(label))
      posl[(px0>px1) & (py0>py1)]<-4
      posl[(px0<=px1) & (py0<=py1)]<-2
      posl[(px0>px1) & (py0<=py1)]<-1
      posl[(px0<=px1) & (py0>py1)]<-3
      offsets<-rep(0.5,length(label))
      
    } else {  # either curved or straight line
      if (all(curve==0)){  # straight line non-curved version
        if (directed){
          # draw labels off center of line so won't overlap
          lpx<-px0+((px1-px0)/3)
          lpy<-py0+((py1-py0)/3)
        } else {
          # draw labels on center of line
          lpx<-px0+((px1-px0)/2)
          lpy<-py0+((py1-py0)/2)
          # assumes that line is straight
        }
        
    } else { # curved edge case
      coords<-sapply(seq_len(length(label)),function(p){
        make.arrow.poly.coords(px0[p],py0[p],px1[p],py1[p],ahangle = 0,ahlen=0,swid = 0,toff = 0,hoff=0,ahead = 0,curve=curve[p],csteps=2)[2,] # pick a point returned from the middle of the curve
      })
      lpx<-coords[1,]
      lpy<-coords[2,]
      # this should 
    }
    # compute crude offset so that label doesn't land on line
    # todo, this doesn't work well on all edge orientations
    posl[(px0>px1) & (py0>py1)]<-1
    posl[(px0<=px1) & (py0<=py1)]<-3
    posl[(px0>px1) & (py0<=py1)]<-2
    posl[(px0<=px1) & (py0>py1)]<-4
    
  }
   # debug coord location
    text(lpx,lpy,labels=label,cex=cex,pos=posl,offset=offsets,...)
}


#Generic plot.network method. 
plot.network <- function(x, ...){
  plot.network.default(x, ...)
}


#Two-dimensional network visualization; this was originally a direct port of the gplot
#routine from sna (Carter T. Butts <[email protected]>)
plot.network.default<-function(x,
attrname=NULL,
label=network.vertex.names(x),
coord=NULL,
jitter=TRUE,
thresh=0,
usearrows=TRUE,
mode="fruchtermanreingold",
displayisolates=TRUE,
interactive=FALSE,
xlab=NULL,
ylab=NULL,
xlim=NULL,
ylim=NULL,
pad=0.2,
label.pad=0.5,
displaylabels=!missing(label),
boxed.labels=FALSE,
label.pos=0,
label.bg="white",
vertex.sides=50,
vertex.rot=0,
vertex.lwd=1,
arrowhead.cex=1,
label.cex=1,
loop.cex=1,
vertex.cex=1,
edge.col=1,
label.col=1,
vertex.col=2,
label.border=1,
vertex.border=1,
edge.lty=1,
label.lty=NULL,
vertex.lty=1,
edge.lwd=0,
edge.label=NULL,
edge.label.cex=1,
edge.label.col=1,                               
label.lwd=par("lwd"),
edge.len=0.5,
edge.curve=0.1,
edge.steps=50,
loop.steps=20,
object.scale=0.01,
uselen=FALSE,
usecurve=FALSE,
suppress.axes=TRUE,
vertices.last=TRUE,
new=TRUE,
layout.par=NULL,
...){
   #Check to see that things make sense
   if(!is.network(x))
     stop("plot.network requires a network object.")
   if(network.size(x)==0)
     stop("plot.network called on a network of order zero - nothing to plot.")
   #Turn the annoying locator bell off, and remove recursion limit
   bellstate<-options()$locatorBell
   expstate<-options()$expression
   on.exit(options(locatorBell=bellstate,expression=expstate))
   options(locatorBell=FALSE,expression=Inf)
   #Create a useful interval inclusion operator
   "%iin%"<-function(x,int) (x>=int[1])&(x<=int[2])
   #Extract the network to be displayed
   if(is.hyper(x)){    #Is this a hypergraph?  If so, use two-mode form.
     #Create a new graph to store the two-mode structure
     xh<-network.initialize(network.size(x)+sum(!sapply(x$mel, is.null)), 
       directed=is.directed(x))
     #Port attributes, in case we need them
     for(i in list.vertex.attributes(x)){
       set.vertex.attribute(xh,attrname=i,
       value=get.vertex.attribute(x,attrname=i,null.na=FALSE,unlist=FALSE),
       v=1:network.size(x))
     }
     for(i in list.network.attributes(x)){
       if(!(i%in%c("bipartite","directed","hyper","loops","mnext","multiple",
          "n")))
         set.network.attribute(xh,attrname=i,
           value=get.network.attribute(x,attrname=i,unlist=FALSE))
     }
     #Now, import the edges
     cnt<-1
     for(i in 1:length(x$mel)){  #Not a safe way to do this, long-term
       if(!is.null(x$mel[[i]])){
         for(j in x$mel[[i]]$outl){
           if(!is.adjacent(xh,j,network.size(x)+cnt))
             add.edge(xh,j,network.size(x)+cnt,names.eval=names(x$mel[[i]]$atl),
               vals.eval=x$mel[[i]]$atl)
         }
         for(j in x$mel[[i]]$inl){
           if(!is.adjacent(xh,network.size(x)+cnt,j)){
             add.edge(xh,network.size(x)+cnt,j,names.eval=names(x$mel[[i]]$atl),
               vals.eval=x$mel[[i]]$atl)
           }
         }
         cnt<-cnt+1                    #Increment the edge counter
       }
     }
     cnt<-cnt-1
     if(length(label)==network.size(x))  #Fix labels, if needed
       label<-c(label,paste("e",1:cnt,sep=""))
     xh%v%"vertex.names"<-c(x%v%"vertex.names",paste("e",1:cnt,sep=""))
     x<-xh
     n<-network.size(x)
     d<-as.matrix.network(x,matrix.type="edgelist",attrname=attrname)
     if(!is.directed(x))
       usearrows<-FALSE
   }else if(is.bipartite(x)){
     n<-network.size(x)
     d<-as.matrix.network(x,matrix.type="edgelist",attrname=attrname)
     usearrows<-FALSE
   }else{
     n<-network.size(x)
     d<-as.matrix.network(x,matrix.type="edgelist",attrname=attrname)
     if(!is.directed(x))
       usearrows<-FALSE
   }
   #Make sure that edge values are in place, matrix has right shape, etc.
   if(NCOL(d)==2){
     if(NROW(d)==0)
       d<-matrix(nrow=0,ncol=3)
     else
       d<-cbind(d,rep(1,NROW(d)))
   }
   diag<-has.loops(x)         #Check for existence of loops
   #Replace NAs with 0s
   d[is.na(d)]<-0
   #Determine which edges should be used when plotting
   edgetouse<-d[,3]>thresh
   d<-d[edgetouse,,drop=FALSE]
   #Save original matrix, which we may use below
   d.raw<-d
   #Determine coordinate placement
   if(!is.null(coord)){      #If the user has specified coords, override all other considerations
     cx<-coord[,1]
     cy<-coord[,2]
   }else{   #Otherwise, use the specified layout function
     layout.fun<-try(match.fun(paste("network.layout.",mode,sep="")), silent=TRUE)
     if(class(layout.fun)=="try-error")
       stop("Error in plot.network.default: no layout function for mode ",mode)
     temp<-layout.fun(x,layout.par)
     cx<-temp[,1]
     cy<-temp[,2]
   }
   #Jitter the coordinates if need be
   if(jitter){
      cx<-jitter(cx)
      cy<-jitter(cy)
   }
   #Which nodes should we use?
   use<-displayisolates|(((sapply(x$iel,length)+sapply(x$oel,length))>0))   
   #Deal with axis labels
   if(is.null(xlab))
     xlab=""
   if(is.null(ylab))
     ylab=""
   #Set limits for plotting region
   if(is.null(xlim))
     xlim<-c(min(cx[use])-pad,max(cx[use])+pad)  #Save x, y limits
   if(is.null(ylim))
     ylim<-c(min(cy[use])-pad,max(cy[use])+pad)
   xrng<-diff(xlim)          #Force scale to be symmetric
   yrng<-diff(ylim)
   xctr<-(xlim[2]+xlim[1])/2 #Get center of plotting region
   yctr<-(ylim[2]+ylim[1])/2
   if(xrng<yrng)
     xlim<-c(xctr-yrng/2,xctr+yrng/2)
   else
     ylim<-c(yctr-xrng/2,yctr+xrng/2)
   baserad<-min(diff(xlim),diff(ylim))*object.scale  #Extract "base radius"
   #Create the base plot, if needed
   if(new){  #If new==FALSE, we add to the existing plot; else create a new one
     plot(0,0,xlim=xlim,ylim=ylim,type="n",xlab=xlab,ylab=ylab,asp=1, axes=!suppress.axes,...)
   }
   # force lazy evaluation of display labels arg before we change value of labels
   displaylabels<-displaylabels
   #Fill out vertex vectors; assume we're using attributes if chars used
   # this is done with the plotArgs.network so we can standarize it
   label <-plotArgs.network(x,'label',label)
   vertex.cex <- plotArgs.network(x,'vertex.cex',vertex.cex)
   vertex.radius <-rep(baserad*vertex.cex,length=n)   #Create vertex radii
   vertex.sides <- plotArgs.network(x,'vertex.sides',vertex.sides)
   vertex.border <- plotArgs.network(x,'vertex.border',vertex.border)
   vertex.col <- plotArgs.network(x,'vertex.col',vertex.col)
   vertex.lty <- plotArgs.network(x,'vertex.lty',vertex.lty)
   vertex.rot <- plotArgs.network(x,'vertex.rot',vertex.rot)
   vertex.lwd <- plotArgs.network(x,'vertex.lwd',vertex.lwd)
   loop.cex <- plotArgs.network(x,'loop.cex',loop.cex)
   label.col <- plotArgs.network(x,'label.col',label.col)
   label.border<-plotArgs.network(x,'label.border',label.border)
   label.bg <- plotArgs.network(x,'label.bg',label.bg)
   #Plot vertices now, if desired
   if(!vertices.last)
     network.vertex(cx[use],cy[use],radius=vertex.radius[use], sides=vertex.sides[use],col=vertex.col[use],border=vertex.border[use],lty=vertex.lty[use],rot=vertex.rot[use], lwd=vertex.lwd[use])
   #Generate the edges and their attributes
   # TODO: initialize to full length, or sapply code below
   # don't append in loop, no wonder is slow. 
   nDrawEdges<-NROW(d)
   px0<-numeric(nDrawEdges)   #Create position vectors (tail, head)
   py0<-numeric(nDrawEdges)
   px1<-numeric(nDrawEdges)
   py1<-numeric(nDrawEdges)
   e.lwd<-numeric(nDrawEdges) #Create edge attribute vectors
   e.curv<-numeric(nDrawEdges)
   e.type<-numeric(nDrawEdges)
   e.col<-character(nDrawEdges)
   e.hoff<-numeric(nDrawEdges) #Offset radii for heads
   e.toff<-numeric(nDrawEdges) #Offset radii for tails
   e.diag<-logical(nDrawEdges) #Indicator for self-ties
   e.rad<-numeric(nDrawEdges)  #Edge radius (only used for loops)
   if(NROW(d)>0){
     #Edge color
     edge.col<-plotArgs.network(x,'edge.col',edge.col,d=d)
     #Edge line type
     edge.lty<-plotArgs.network(x,'edge.lty',edge.lty,d=d)
     #Edge line width
     edge.lwd<-plotArgs.network(x,'edge.lwd',edge.lwd,d=d)
     #Edge curve
     # TODO: can't move this into prepare plot args becaue it also sets the e.curve.as.mult
     #       but I think it could be refactored to use the d[] array as the other edge functions do
     if(!is.null(edge.curve)){
       if(length(dim(edge.curve))==2){
         edge.curve<-edge.curve[d[,1:2]]
         e.curv.as.mult<-FALSE
       }else{ 
         if(length(edge.curve)==1)
           e.curv.as.mult<-TRUE
         else
           e.curv.as.mult<-FALSE
         edge.curve<-rep(edge.curve,length=NROW(d))
       }
     }else if(is.character(edge.curve)&&(length(edge.curve)==1)){
       temp<-edge.curve
       edge.curve<-(x%e%edge.curve)[edgetouse]
       if(all(is.na(edge.curve)))
         stop("Attribute '",temp,"' had illegal missing values for edge.curve or was not present in plot.network.default.")
       e.curv.as.mult<-FALSE
     }else{
       edge.curve<-rep(0,length=NROW(d))
       e.curv.as.mult<-FALSE
     }
     # only evaluate edge label stuff if we will draw label
     if(!is.null(edge.label)){
       #Edge label
        edge.label<-plotArgs.network(x,'edge.label',edge.label,d=d)
       
       #Edge label color
       edge.label.col<-plotArgs.network(x,'edge.label.col',edge.label.col,d=d)
       #Edge label cex
       edge.label.cex<-plotArgs.network(x,'edge.label.cex',edge.label.cex,d=d)
     } # end edge label setup block
     
     #Proceed with edge setup
     dist<-((cx[d[,1]]-cx[d[,2]])^2+(cy[d[,1]]-cy[d[,2]])^2)^0.5  #Get the inter-point distances for curves
     tl<-d.raw*dist   #Get rescaled edge lengths
     tl.max<-max(tl)  #Get maximum edge length
     for(i in 1:NROW(d)){
       if(use[d[i,1]]&&use[d[i,2]]){  #Plot edges for displayed vertices (wait,doesn't 'use' track isolates, which don't have edges anyway?)
         px0[i]<-as.double(cx[d[i,1]])  #Store endpoint coordinates
         py0[i]<-as.double(cy[d[i,1]])
         px1[i]<-as.double(cx[d[i,2]])
         py1[i]<-as.double(cy[d[i,2]])
         e.toff[i]<-vertex.radius[d[i,1]] #Store endpoint offsets
         e.hoff[i]<-vertex.radius[d[i,2]]
         e.col[i]<-edge.col[i]   #Store other edge attributes
         e.type[i]<-edge.lty[i]
         e.lwd[i]<-edge.lwd[i]
         e.diag[i]<-d[i,1]==d[i,2]  #Is this a loop?
         e.rad[i]<-vertex.radius[d[i,1]]*loop.cex[d[i,1]]
         if(uselen){   #Should we base curvature on interpoint distances?
           if(tl[i]>0){ 
             e.len<-dist[i]*tl.max/tl[i]
             e.curv[i]<-edge.len*sqrt((e.len/2)^2-(dist[i]/2)^2)
           }else{
             e.curv[i]<-0
           }
         }else{        #Otherwise, use prespecified edge.curve
           if(e.curv.as.mult)    #If it's a scalar, multiply by edge str
             e.curv[i]<-edge.curve[i]*d.raw[i]
           else
             e.curv[i]<-edge.curve[i]
         }
       }
     } 
   }# end edges block
   #Plot loops for the diagonals, if diag==TRUE, rotating wrt center of mass
   if(diag&&(length(px0)>0)&&sum(e.diag>0)){  #Are there any loops present?
     network.loop(as.vector(px0)[e.diag],as.vector(py0)[e.diag], length=1.5*baserad*arrowhead.cex,angle=25,width=e.lwd[e.diag]*baserad/10,col=e.col[e.diag],border=e.col[e.diag],lty=e.type[e.diag],offset=e.hoff[e.diag],edge.steps=loop.steps,radius=e.rad[e.diag],arrowhead=usearrows,xctr=mean(cx[use]),yctr=mean(cy[use]))
     if(!is.null(edge.label)){
       network.edgelabel(px0,py0,0,0,edge.label[e.diag],directed=is.directed(x),cex=edge.label.cex[e.diag],col=edge.label.col[e.diag],loops=TRUE)
     }
     
   }
   #Plot standard (i.e., non-loop) edges
   if(length(px0)>0){  #If edges are present, remove loops from consideration
     px0<-px0[!e.diag] 
     py0<-py0[!e.diag]
     px1<-px1[!e.diag]
     py1<-py1[!e.diag]
     e.curv<-e.curv[!e.diag]
     e.lwd<-e.lwd[!e.diag]
     e.type<-e.type[!e.diag]
     e.col<-e.col[!e.diag]
     e.hoff<-e.hoff[!e.diag]
     e.toff<-e.toff[!e.diag]
     e.rad<-e.rad[!e.diag]
   }
   if(!usecurve&!uselen){   #Straight-line edge case
     if(length(px0)>0){
       network.arrow(as.vector(px0),as.vector(py0),as.vector(px1), as.vector(py1),length=2*baserad*arrowhead.cex,angle=20,col=e.col,border=e.col,lty=e.type,width=e.lwd*baserad/10,offset.head=e.hoff,offset.tail=e.toff,arrowhead=usearrows)
       if(!is.null(edge.label)){
         network.edgelabel(px0,py0,px1,py1,edge.label[!e.diag],directed=is.directed(x),cex=edge.label.cex[!e.diag],col=edge.label.col[!e.diag])
       }
     }
   }else{   #Curved edge case
     if(length(px0)>0){
       network.arrow(as.vector(px0),as.vector(py0),as.vector(px1), as.vector(py1),length=2*baserad*arrowhead.cex,angle=20,col=e.col,border=e.col,lty=e.type,width=e.lwd*baserad/10,offset.head=e.hoff,offset.tail=e.toff,arrowhead=usearrows,curve=e.curv,edge.steps=edge.steps)
       if(!is.null(edge.label)){
         network.edgelabel(px0,py0,px1,py1,edge.label[!e.diag],directed=is.directed(x),cex=edge.label.cex[!e.diag],col=edge.label.col[!e.diag],curve=e.curv)
       }
     }
   }
   
   #Plot vertices now, if we haven't already done so
   if(vertices.last)
     network.vertex(cx[use],cy[use],radius=vertex.radius[use], sides=vertex.sides[use],col=vertex.col[use],border=vertex.border[use],lty=vertex.lty[use],rot=vertex.rot[use], lwd=vertex.lwd[use])
   #Plot vertex labels, if needed
   if(displaylabels&(!all(label==""))&(!all(use==FALSE))){
     if (label.pos==0){
       xhat <- yhat <- rhat <- rep(0,n) 
       #Set up xoff yoff and roff when we get odd vertices
       xoff <- cx[use]-mean(cx[use])
       yoff <- cy[use]-mean(cy[use])
       roff <- sqrt(xoff^2+yoff^2)
       #Loop through vertices
       for (i in (1:n)[use]){
         #Find all in and out ties that aren't loops
         ij <- unique(c(d[d[,2]==i&d[,1]!=i,1],d[d[,1]==i&d[,2]!=i,2]))
         ij.n <- length(ij)
         if (ij.n>0) {
           #Loop through all ties and add each vector to label direction
           for (j in ij){
             dx <- cx[i]-cx[j]
             dy <- cy[i]-cy[j]
             dr <- sqrt(dx^2+dy^2)
             xhat[i] <- xhat[i]+dx/dr
             yhat[i] <- yhat[i]+dy/dr
           }
           
           #Take the average of all the ties
           xhat[i] <- xhat[i]/ij.n
           yhat[i] <- yhat[i]/ij.n
           rhat[i] <- sqrt(xhat[i]^2+yhat[i]^2)
           if (!is.nan(rhat[i]) && rhat[i]!=0) { # watch out for NaN when vertices have same position
             # normalize direction vector
             xhat[i] <- xhat[i]/rhat[i]
             yhat[i] <- yhat[i]/rhat[i]
           } else { #if no direction, make xhat and yhat away from center
             xhat[i] <- xoff[i]/roff[i]
             yhat[i] <- yoff[i]/roff[i]
           }
         } else { #if no ties, make xhat and yhat away from center
           xhat[i] <- xoff[i]/roff[i]
           yhat[i] <- yoff[i]/roff[i]
         }
         if ( is.nan(xhat[i]) || xhat[i]==0 ) xhat[i] <- .01 #jitter to avoid labels on points
         if (is.nan(yhat[i]) || yhat[i]==0 ) yhat[i] <- .01
       }
       xhat <- xhat[use]
       yhat <- yhat[use]
     } else if (label.pos<5) {
       xhat <- switch(label.pos,0,-1,0,1)
       yhat <- switch(label.pos,-1,0,1,0)
     } else if (label.pos==6) {
       xoff <- cx[use]-mean(cx[use])
       yoff <- cy[use]-mean(cy[use])
       roff <- sqrt(xoff^2+yoff^2)
       xhat <- xoff/roff
       yhat <- yoff/roff
     } else {
       xhat <- 0
       yhat <- 0
     }
     os<-par()$cxy*mean(label.cex,na.rm = TRUE) # don't think this is actually used?
     lw<-strwidth(label[use],cex=label.cex)/2
     lh<-strheight(label[use],cex=label.cex)/2
     if(boxed.labels){
       rect(cx[use]+xhat*vertex.radius[use]-(lh*label.pad+lw)*((xhat<0)*2+ (xhat==0)*1),
         cy[use]+yhat*vertex.radius[use]-(lh*label.pad+lh)*((yhat<0)*2+ (yhat==0)*1),
         cx[use]+xhat*vertex.radius[use]+(lh*label.pad+lw)*((xhat>0)*2+ (xhat==0)*1),
         cy[use]+yhat*vertex.radius[use]+(lh*label.pad+lh)*((yhat>0)*2+ (yhat==0)*1),
         col=label.bg,border=label.border,lty=label.lty,lwd=label.lwd)
     }
     text(cx[use]+xhat*vertex.radius[use]+(lh*label.pad+lw)*((xhat>0)-(xhat<0)),
          cy[use]+yhat*vertex.radius[use]+(lh*label.pad+lh)*((yhat>0)-(yhat<0)),
          label[use],cex=label.cex,col=label.col,offset=0)         
   }
   #If interactive, allow the user to mess with things
   if(interactive&&((length(cx)>0)&&(!all(use==FALSE)))){
     #Set up the text offset increment
     os<-c(0.2,0.4)*par()$cxy
     #Get the location for text messages, and write to the screen
     textloc<-c(min(cx[use])-pad,max(cy[use])+pad)
     tm<-"Select a vertex to move, or click \"Finished\" to end."
     tmh<-strheight(tm)
     tmw<-strwidth(tm)
     text(textloc[1],textloc[2],tm,adj=c(0,0.5)) #Print the initial instruction
     fm<-"Finished"
     finx<-c(textloc[1],textloc[1]+strwidth(fm))
     finy<-c(textloc[2]-3*tmh-strheight(fm)/2,textloc[2]-3*tmh+strheight(fm)/2)
     finbx<-finx+c(-os[1],os[1])
     finby<-finy+c(-os[2],os[2])
     rect(finbx[1],finby[1],finbx[2],finby[2],col="white")
     text(finx[1],mean(finy),fm,adj=c(0,0.5))
     #Get the click location
     clickpos<-unlist(locator(1))
     #If the click is in the "finished" box, end our little game.  Otherwise,
     #relocate a vertex and redraw.
     if((clickpos[1]%iin%finbx)&&(clickpos[2]%iin%finby)){
       cl<-match.call()                #Get the args of the current function
       cl$interactive<-FALSE           #Turn off interactivity
       cl$coord<-cbind(cx,cy)          #Set the coordinates
       cl$x<-x                         #"Fix" the data array
       return(eval.parent(cl))     #Execute the function and return
     }else{
       #Figure out which vertex was selected
       clickdis<-sqrt((clickpos[1]-cx[use])^2+(clickpos[2]-cy[use])^2)
       selvert<-match(min(clickdis),clickdis)
       #Create usable labels, if the current ones aren't
       if(all(label==""))
         label<-1:n
       #Clear out the old message, and write a new one
       rect(textloc[1],textloc[2]-tmh/2,textloc[1]+tmw,textloc[2]+tmh/2, border="white",col="white")
       tm<-"Where should I move this vertex?"
       tmh<-strheight(tm)
       tmw<-strwidth(tm)
       text(textloc[1],textloc[2],tm,adj=c(0,0.5))
       fm<-paste("Vertex",label[use][selvert],"selected")
       finx<-c(textloc[1],textloc[1]+strwidth(fm))
       finy<-c(textloc[2]-3*tmh-strheight(fm)/2,textloc[2]-3*tmh+ strheight(fm)/2)
       finbx<-finx+c(-os[1],os[1])
       finby<-finy+c(-os[2],os[2])
       rect(finbx[1],finby[1],finbx[2],finby[2],col="white")
       text(finx[1],mean(finy),fm,adj=c(0,0.5))
       #Get the destination for the new vertex
       clickpos<-unlist(locator(1))
       #Set the coordinates accordingly
       cx[use][selvert]<-clickpos[1]
       cy[use][selvert]<-clickpos[2]
       #Iterate (leaving interactivity on)
       cl<-match.call()                #Get the args of the current function
       cl$coord<-cbind(cx,cy)          #Set the coordinates
       cl$x<-x                         #"Fix" the data array
       return(eval.parent(cl))     #Execute the function and return
     }
   }
   #Return the vertex positions, should they be needed
   invisible(cbind(cx,cy))
}

# moving all of the plot argument checking and expansion into a single function
# so that it will be acessible from other plot-related tools (like ndtv)
# argName = character named of argument to be checked/expaneded
# argValue = value passed in by user, to be processed/expanded
# d is an edgelist matrix of edge values optionally used by some edge attribute functions
# edgetouse the set of edge ids to be used (in case some edges are not being shown)

plotArgs.network<-function(x,argName, argValue,d=NULL,edgetouse=NULL){
  n<-network.size(x)
  # count the number of edges 
  # not sure if nrow d is every differnt, than network edgecount, but just being safe
  if(!is.null(d)){
    nE<-NROW(d)
  } else {
    nE<-network.edgecount(x)
  }
  if(is.null(edgetouse)){
    edgetouse<-seq_len(nE) # use all the edges
  }
  # if d exists, it may need to be subset to the number of edges
  if (!is.null(d)){
    d<-d[edgetouse,,drop=FALSE]
  }
  
  # assign the value to a local variable with the appropriate name
  assign(argName,argValue)
  #Fill out vertex vectors; assume we're using attributes if chars used
  # TODO: only one of the code blocks below should execute, set up as a switch?
  switch(argName,
      # ----- vertex labels ---------------------------
      label=if(is.character(label)&(length(label)==1)){
        temp<-label
        if(temp%in%list.vertex.attributes(x)){
          label <- rep(get.vertex.attribute(x,temp),length=n)
          if(all(is.na(label))){
            stop("Attribute '",temp,"' had illegal missing values for label or was not present in plot.network.default.")
          }
        } else { # didn't match with a vertex attribute, assume we are supposed to replicate it
          label <- rep(label,length=n)
        }
      }else{
        label <- rep(as.character(label),length=n)
      }
      ,
      # ------ vertex sizes (vertex.cex) --------------------
      vertex.cex=if(is.character(vertex.cex)&(length(vertex.cex)==1)){
        temp<-vertex.cex
        vertex.cex <- rep(get.vertex.attribute(x,vertex.cex),length=n)
        if(all(is.na(vertex.cex)))
          stop("Attribute '",temp,"' had illegal missing values for vertex.cex or was not present in plot.network.default.")
      }else
        vertex.cex <- rep(vertex.cex,length=n)
      ,
      # ------ vertex sides (number of sides for polygon) ---------
      vertex.sides=if(is.character(vertex.sides)&&(length(vertex.sides==1))){
        temp<-vertex.sides
        vertex.sides <- rep(get.vertex.attribute(x,vertex.sides),length=n)
        if(all(is.na(vertex.sides)))
          stop("Attribute '",temp,"' had illegal missing values for vertex.sides or was not present in plot.network.default.")
      }else
        vertex.sides <- rep(vertex.sides,length=n)
      ,
      # --------- vertex border  --------------------
      vertex.border=if(is.character(vertex.border)&&(length(vertex.border)==1)){
        temp<-vertex.border
        vertex.border <- rep(get.vertex.attribute(x,vertex.border),length=n)
        if(all(is.na(vertex.border)))
          vertex.border <- rep(temp,length=n) #Assume it was a color word
        else{
          if(!all(is.color(vertex.border),na.rm=TRUE))
            vertex.border<-as.color(vertex.border)
        }
      }else
        vertex.border <- rep(vertex.border,length=n)
      ,
      # -------- vertex color ------------------------
      vertex.col=if(is.character(vertex.col)&&(length(vertex.col)==1)){
        temp<-vertex.col
        vertex.col <- rep(get.vertex.attribute(x,vertex.col),length=n)
        if(all(is.na(vertex.col)))
          vertex.col <- rep(temp,length=n) #Assume it was a color word
        else{
          if(!all(is.color(vertex.col),na.rm=TRUE))
            vertex.col<-as.color(vertex.col)
        }
      }else
        vertex.col <- rep(vertex.col,length=n)
      ,
      # ------- vertex line type (vertex.lty) --------------------
      vertex.lty=if(is.character(vertex.lty)&&(length(vertex.lty)==1)){
        temp<-vertex.lty
        vertex.lty <- rep(get.vertex.attribute(x,vertex.lty),length=n)
        if(all(is.na(vertex.lty)))
          stop("Attribute '",temp,"' had illegal missing values for vertex.col or was not present in plot.network.default.")
      }else
        vertex.lty <- rep(vertex.lty,length=n)
      ,
      # ------- vertex rotation --------------------------------------
      vertex.rot=if(is.character(vertex.rot)&&(length(vertex.rot)==1)){
        temp<-vertex.rot
        vertex.rot <- rep(get.vertex.attribute(x,vertex.rot),length=n)
        if(all(is.na(vertex.rot)))
          stop("Attribute '",temp,"' had illegal missing values for vertex.rot or was not present in plot.network.default.")
      }else
        vertex.rot <- rep(vertex.rot,length=n)
      ,
      # -------- vertex line width --------------------------
      vertex.lwd=if(is.character(vertex.lwd)&&(length(vertex.lwd)==1)){
        temp<-vertex.lwd
        vertex.lwd <- rep(get.vertex.attribute(x,vertex.lwd),length=n)
        if(all(is.na(vertex.lwd)))
          stop("Attribute '",temp,"' had illegal missing values for vertex.lwd or was not present in plot.network.default.")
      }else
        vertex.lwd <- rep(vertex.lwd,length=n)
      ,
      # -------- vertex self-loop size -----------------------
      loop.cex=if(is.character(loop.cex)&&(length(loop.cex)==1)){
        temp<-loop.cex
        loop.cex <- rep(get.vertex.attribute(x,loop.cex),length=n)
        if(all(is.na(loop.cex)))
          stop("Attribute ",temp," had illegal missing values for loop.cex or was not present in plot.network.default.")
      }else
        loop.cex <- rep(loop.cex,length=n)
      ,
      # ---------  vertex label color -----------------------------
      label.col=if(is.character(label.col)&&(length(label.col)==1)){
        temp<-label.col
        label.col <- rep(get.vertex.attribute(x,label.col),length=n)
        if(all(is.na(label.col)))
          label.col <- rep(temp,length=n) #Assume it was a color word
        else{
          if(!all(is.color(label.col),na.rm=TRUE))
            label.col<-as.color(label.col)
        }
      }else
        label.col <- rep(label.col,length=n)
      ,
      # -------- vertex label border ------------------------------
      label.border=if(is.character(label.border)&&(length(label.border)==1)){
        temp<-label.border
        label.border <- rep(get.vertex.attribute(x,label.border),length=n)
        if(all(is.na(label.border)))
          label.border <- rep(temp,length=n) #Assume it was a color word
        else{
          if(!all(is.color(label.border),na.rm=TRUE))
            label.border<-as.color(label.border)
        }
      }else{
        label.border <- rep(label.border,length=n)
      }
      ,
      # ------- vertex label border background color ----------------
      label.bg=if(is.character(label.bg)&&(length(label.bg)==1)){
        temp<-label.bg
        label.bg <- rep(get.vertex.attribute(x,label.bg),length=n)
        if(all(is.na(label.bg)))
          label.bg <- rep(temp,length=n) #Assume it was a color word
        else{
          if(!all(is.color(label.bg),na.rm=TRUE))
            label.bg<-as.color(label.bg)
        }
      }else{
        label.bg <- rep(label.bg,length=n)
      }
      ,
      # ------ Edge color---------
      edge.col=if(length(dim(edge.col))==2)   #Coerce edge.col/edge.lty to vector form
        edge.col<-edge.col[d[,1:2]]
      else if(is.character(edge.col)&&(length(edge.col)==1)){
        temp<-edge.col
        edge.col<-x%e%edge.col
        if(!is.null(edge.col)){
          edge.col<-edge.col[edgetouse]
          if(!all(is.color(edge.col),na.rm=TRUE))
            edge.col<-as.color(edge.col)
        }else{
          edge.col<-rep(temp,length=nE)  #Assume it was a color word
        }
      }else{
        edge.col<-rep(edge.col,length=nE)
      }
      ,
      # ----------- Edge line type ------------------
      edge.lty=if(length(dim(edge.lty))==2){
        edge.lty<-edge.lty[d[,1:2]]
      }else if(is.character(edge.lty)&&(length(edge.lty)==1)){
        temp<-edge.lty
        edge.lty<-(x%e%edge.lty)[edgetouse]
        if(all(is.na(edge.lty)))
          stop("Attribute '",temp,"' had illegal missing values for edge.lty or was not present in plot.network.default.")
      }else{
        edge.lty<-rep(edge.lty,length=nE)
      }
      , 
      # ----------- Edge line width ------
      edge.lwd=if(length(dim(edge.lwd))==2){
        edge.lwd<-edge.lwd[d[,1:2]]  # what is going on here? aren't these the incident vertices? # for later matrix lookup?
      }else if(is.character(edge.lwd)&&(length(edge.lwd)==1)){
        temp<-edge.lwd
        edge.lwd<-(x%e%edge.lwd)[edgetouse]
        if(all(is.na(edge.lwd))){
          stop("Attribute '",temp,"' had illegal missing values for edge.lwd or was not present in plot.network.default.")
        }
      }else{ 
        if(length(edge.lwd)==1){ # if lwd has only one element..
          if(edge.lwd>0){  # ... and that element > 0 ,use it as a scale factor for the edge values in d
                           # .. unless d is missing
            if (!is.null(d)){
              edge.lwd<-edge.lwd*d[,3]
            } else {
              edge.lwd<-rep(edge.lwd,length=nE)
            } 
          }else{  # edge is zero or less, so set it to 1
            edge.lwd<-rep(1,length=nE)
          }
        } else { # just replacte for the number of edges
          edge.lwd<-rep(edge.lwd,length=nE)
        }
      }
      ,
      
      # ----------- Edge curve---------------
      edge.curve=if(!is.null(edge.curve)){
        if(length(dim(edge.curve))==2){
          edge.curve<-edge.curve[d[,1:2]]
          e.curv.as.mult<-FALSE
        }else{ 
          if(length(edge.curve)==1){
            e.curv.as.mult<-TRUE
          }else{
            e.curv.as.mult<-FALSE
          }
          edge.curve<-rep(edge.curve,length=nE)
        }
      }else if(is.character(edge.curve)&&(length(edge.curve)==1)){
        temp<-edge.curve
        edge.curve<-(x%e%edge.curve)[edgetouse]
        if(all(is.na(edge.curve))){
          stop("Attribute '",temp,"' had illegal missing values for edge.curve or was not present in plot.network.default.")
        }
        e.curv.as.mult<-FALSE
      }else{
        edge.curve<-rep(0,length=nE)
        e.curv.as.mult<-FALSE
      }
      ,
      # -------- edge label  ----------------------
      edge.label=if(length(dim(edge.label))==2){   #Coerce edge.label to vector form
        edge.label<-edge.label[d[,1:2]]
      }else if(is.character(edge.label)&&(length(edge.label)==1)){
        temp<-edge.label
        edge.label<-x%e%edge.label
        if(!is.null(edge.label)){
          edge.label<-edge.label[edgetouse]
        }else
          edge.label<-rep(temp,length=nE)  #Assume it was a value to replicate
      }else if(is.logical(edge.label)&&(length(edge.label)==1)) {
        if (edge.label){
          # default to edge ids.
          edge.label<-valid.eids(x)[edgetouse]
        } else {
          # don't draw edge labels if set to FALSE
          edge.label<-NULL
        }
      }else{   
        # do nothing and hope for the best!
        edge.label<-rep(edge.label,length=nE)
      }
      ,
      # ------ edge label color --------------------
      #Edge  label color
      edge.label.col=if(length(dim(edge.label.col))==2){   #Coerce edge.label.col
        edge.label.col<-edge.label.col[d[,1:2]]
      } else if(is.character(edge.label.col)&&(length(edge.label.col)==1)){
        temp<-edge.label.col
        edge.label.col<-x%e%edge.label.col
        if(!is.null(edge.label.col)){
          edge.label.col<-edge.label.col[edgetouse]
          if(!all(is.color(edge.label.col),na.rm=TRUE))
            edge.label.col<-as.color(edge.label.col)
        }else
          edge.label.col<-rep(temp,length=nE)  #Assume it was a color word
      }else{
        edge.label.col<-rep(edge.label.col,length=nE)
      }
      ,
      # ------- edge.label.cex  --------------------
      #Edge label cex
      edge.label.cex=if(length(dim(edge.label.cex))==2)
        edge.label.cex<-edge.label.cex[d[,1:2]]
      else if(is.character(edge.label.cex)&&(length(edge.label.cex)==1)){
        temp<-edge.label.cex
        edge.label.cex<-(x%e%edge.label.cex)[edgetouse]
        if(all(is.na(edge.label.cex)))
          stop("Attribute '",temp,"' had illegal missing values for edge.label.cex or was not present in plot.network.default.")
      }else{
        edge.label.cex<-rep(edge.label.cex,length=nE)
      }
      # case in which none of the argument names match up
      # stop('argument "',argName,'"" does not match with any of the plot.network arguments')
      # can't error out, because this function will be called with non-network args, so just
      # return the value passed in
      
  ) # end switch block
  # now return the checked / expanded value
  return(get(argName))
}

Try the network package in your browser

Any scripts or data that you put into this service are public.

network documentation built on May 2, 2019, 5:16 p.m.