plotnet

0th

Percentile

Plot a neural network model

Plot a neural interpretation diagram for a neural network object

Usage
plotnet(mod_in, ...)
"plotnet"(mod_in, x_names, y_names, struct = NULL, nid = TRUE, all_out = TRUE, all_in = TRUE, bias = TRUE, rel_rsc = c(1, 7), circle_cex = 5, node_labs = TRUE, var_labs = TRUE, line_stag = NULL, cex_val = 1, alpha_val = 1, circle_col = "lightblue", pos_col = "black", neg_col = "grey", bord_col = "lightblue", max_sp = FALSE, prune_col = NULL, prune_lty = "dashed", skip = NULL, ...)
"plotnet"(mod_in, x_names = NULL, y_names = NULL, skip = FALSE, ...)
"plotnet"(mod_in, struct, x_names = NULL, y_names = NULL, ...)
"plotnet"(mod_in, x_names = NULL, y_names = NULL, prune_col = NULL, prune_lty = "dashed", ...)
"plotnet"(mod_in, x_names = NULL, y_names = NULL, ...)
"plotnet"(mod_in, x_names = NULL, y_names = NULL, skip = FALSE, ...)
Arguments
mod_in
neural network object or numeric vector of weights
...
additional arguments passed to or from other methods
x_names
chr string indicating names for input variables, default from model object
y_names
chr string indicating names for output variables, default from model object
struct
numeric vector equal in length to the number of layers in the network. Each number indicates the number of nodes in each layer starting with the input and ending with the output. An arbitrary number of hidden layers can be included.
nid
logical value indicating if neural interpretation diagram is plotted, default TRUE
all_out
chr string indicating names of response variables for which connections are plotted, default all
all_in
chr string indicating names of input variables for which connections are plotted, default all
bias
logical value indicating if bias nodes and connections are plotted, default TRUE
rel_rsc
numeric indicating the scaling range for the width of connection weights
circle_cex
numeric value indicating size of nodes, default 5
node_labs
logical value indicating if labels are plotted directly on nodes, default TRUE
var_labs
logical value indicating if variable names are plotted next to nodes, default TRUE
line_stag
numeric value that specifies distance of connection weights from nodes
cex_val
numeric value indicating size of text labels, default 1
alpha_val
numeric value (0-1) indicating transparency of connections, default 1
circle_col
chr string indicating color of nodes, default 'lightblue', or two element list with first element indicating color of input nodes and second indicating color of remaining nodes
pos_col
chr string indicating color of positive connection weights, default 'black'
neg_col
chr string indicating color of negative connection weights, default 'grey'
bord_col
chr string indicating border color around nodes, default 'lightblue'
max_sp
logical value indicating if space between nodes in each layer is maximized, default FALSE
prune_col
chr string indicating color of pruned connections, otherwise not shown
prune_lty
line type for pruned connections, passed to segments
skip
logical if skip layer connections are plotted instead of the primary network
Details

This function plots a neural network as a neural interpretation diagram as in Ozesmi and Ozesmi (1999). Options to plot without color-coding or shading of weights are also provided. The default settings plot positive weights between layers as black lines and negative weights as grey lines. Line thickness is in proportion to relative magnitude of each weight. The first layer includes only input variables with nodes labelled arbitrarily as I1 through In for n input variables. One through many hidden layers are plotted with each node in each layer labelled as H1 through Hn. The output layer is plotted last with nodes labeled as O1 through On. Bias nodes connected to the hidden and output layers are also shown. Neural networks created using mlp do not show bias layers.

A primary network and a skip layer network can be plotted for nnet models with a skip layer connection. The default is to plot the primary network, whereas the skip layer network can be viewed with skip = TRUE. If nid = TRUE, the line widths for both the primary and skip layer plots are relative to all weights. Viewing both plots is recommended to see which network has larger relative weights. Plotting a network with only a skip layer (i.e., no hidden layer, size = 0) will include bias connections to the output layer, whereas these are not included in the plot of the skip layer if size is greater than zero. The numeric method for plotting requires the input weights to be in a specific order given the structure of the network. An additional argument struct (from neuralweights is also required that lists the number of nodes in the input, hidden, and output layers. The example below for the numeric input shows the correct weight vector for a simple neural network model with two input variables, one output variable, and one hidden layer with two nodes. Bias nodes are also connected to the hidden and output layer. Using the plot syntax of I, H, O, and B for input, hidden, output, and bias to indicate weighted connections between layers, the correct weight order for the mod_in vector is B1-H1, I1-H1, I2-H1, B1-H2, I1-H2, I2-H2, B2-O1, H1-O1, H2-O1. For a generic network (three layers) with n input nodes, j hidden nodes, and k output nodes, the weights are ordered as the connections from B1, I1,...,In to H1,...,Hj, then B2, H1,..,Hj to O1,...,Ok.

Value

A graphics object unless wts_only = TRUE, then neural network weights from neuralweights.

References

Ozesmi, S.L., Ozesmi, U. 1999. An artificial neural network approach to spatial habitat modeling with interspecific interaction. Ecological Modelling. 116:15-31.

Aliases
  • plotnet
  • plotnet.default
  • plotnet.mlp
  • plotnet.nn
  • plotnet.nnet
  • plotnet.numeric
  • plotnet.train
Examples
## using numeric input

# B1-H1, I1-H1, I2-H1, B1-H2, I1-H2, I2-H2, B2-O1, H1-O1, H2-O1.
wts_in <- c(13.12, 1.49, 0.16, -0.11, -0.19, -0.16, 0.56, -0.52, 0.81)
struct <- c(2, 2, 1) #two inputs, two hidden, one output 

plotnet(wts_in, struct = struct)

# numeric input, two hidden layers

# B1-H11, I1-H11, I2-H11, B1-H12, I1-H12, I2-H12, B2-H21, H11-H21, H12-H21, 
# B2-H22, H11-H22, H12-H22, B3-O1, H21-O1, H22-O1 
wts_in <- c(1.12, 1.49, 0.16, -0.11, -0.19, -0.16, 0.5, 0.2, -0.12, -0.1, 
 0.89, 0.9, 0.56, -0.52, 0.81)
struct <- c(2, 2, 2, 1) # two inputs, two (two nodes each), one output 

plotnet(wts_in, struct = struct)

## using nnet

library(nnet)

data(neuraldat) 
set.seed(123)

mod <- nnet(Y1 ~ X1 + X2 + X3, data = neuraldat, size = 5)
 
plotnet(mod)  

## plot the skip layer from nnet model

mod <- nnet(Y1 ~ X1 + X2 + X3, data = neuraldat, size = 5, skip = TRUE)

plotnet(mod, skip = TRUE)  

## Not run: 
# ## using RSNNS, no bias layers
# 
# library(RSNNS)
# 
# x <- neuraldat[, c('X1', 'X2', 'X3')]
# y <- neuraldat[, 'Y1']
# mod <- mlp(x, y, size = 5)
# 
# plotnet(mod)
# 
# # pruned model using code from RSSNS pruning demo
# pruneFuncParams <- list(max_pr_error_increase = 10.0, pr_accepted_error = 1.0, 
#  no_of_pr_retrain_cycles = 1000, min_error_to_stop = 0.01, init_matrix_value = 1e-6, 
#  input_pruning = TRUE, hidden_pruning = TRUE)
# mod <- mlp(x, y, size = 5, pruneFunc = "OptimalBrainSurgeon", 
#  pruneFuncParams = pruneFuncParams)
# 
# plotnet(mod)
# plotnet(mod, prune_col = 'lightblue')
# 
# ## using neuralnet
# 
# library(neuralnet)
# 
# mod <- neuralnet(Y1 ~ X1 + X2 + X3, data = neuraldat, hidden = 5)
# 
# plotnet(mod)
# 
# ## using caret
# 
# library(caret)
# 
# mod <- train(Y1 ~ X1 + X2 + X3, method = 'nnet', data = neuraldat, linout = TRUE)
# 
# plotnet(mod)
# 
# ## a more complicated network with categorical response
# AND <- c(rep(0, 7), 1)
# OR <- c(0, rep(1, 7))
#  
# binary_data <- data.frame(expand.grid(c(0, 1), c(0, 1), c(0, 1)), AND, OR)
#  
# mod <- neuralnet(AND + OR ~ Var1 + Var2 + Var3, binary_data, 
#  hidden = c(6, 12, 8), rep = 10, err.fct = 'ce', linear.output = FALSE)
#  
# plotnet(mod)
# 
# ## recreate the previous example with numeric inputs
# 
# # get the weights and structure in the right format
# wts <- neuralweights(mod)
# struct <- wts$struct
# wts <- unlist(wts$wts)
# 
# # plot
# plotnet(wts, struct = struct)
# 
# ## color input nodes by relative importance
# mod <- nnet(Y1 ~ X1 + X2 + X3, data = neuraldat, size = 5)
#  
# rel_imp <- garson(mod, bar_plot = FALSE)$rel_imp
# cols <- colorRampPalette(c('lightgreen', 'darkgreen'))(3)[rank(rel_imp)]
#  
# plotnet(mod, circle_col = list(cols, 'lightblue'))
# ## End(Not run)
Documentation reproduced from package NeuralNetTools, version 1.5.0, License: CC0

Community examples

markvandijl@hotmail.com at Oct 29, 2018 NeuralNetTools v1.5.0

plotnet <- function(mod.in,nid=T,all.out=T,all.in=T,bias=T,wts.only=F,rel.rsc=5,circle.cex=5, node.labs=T,var.labs=T,x.lab=NULL,y.lab=NULL,line.stag=NULL,struct=NULL,cex.val=1, alpha.val=1,circle.col='lightblue',pos.col='black',neg.col='grey', max.sp = F, ...){ require(scales) #sanity checks if('mlp' %in% class(mod.in)) warning('Bias layer not applicable for rsnns object') if('numeric' %in% class(mod.in)){ if(is.null(struct)) stop('Three-element vector required for struct') if(length(mod.in) != ((struct[1]*struct[2]+struct[2]*struct[3])+(struct[3]+struct[2]))) stop('Incorrect length of weight matrix for given network structure') } if('train' %in% class(mod.in)){ if('nnet' %in% class(mod.in$finalModel)){ mod.in<-mod.in$finalModel warning('Using best nnet model from train output') } else stop('Only nnet method can be used with train object') } #gets weights for neural network, output is list #if rescaled argument is true, weights are returned but rescaled based on abs value nnet.vals<-function(mod.in,nid,rel.rsc,struct.out=struct){ require(scales) require(reshape) if('numeric' %in% class(mod.in)){ struct.out<-struct wts<-mod.in } #neuralnet package if('nn' %in% class(mod.in)){ struct.out<-unlist(lapply(mod.in$weights[[1]],ncol)) struct.out<-struct.out[-length(struct.out)] struct.out<-c( length(mod.in$model.list$variables), struct.out, length(mod.in$model.list$response) ) wts<-unlist(mod.in$weights[[1]]) } #nnet package if('nnet' %in% class(mod.in)){ struct.out<-mod.in$n wts<-mod.in$wts } #RSNNS package if('mlp' %in% class(mod.in)){ struct.out<-c(mod.in$nInputs,mod.in$archParams$size,mod.in$nOutputs) hid.num<-length(struct.out)-2 wts<-mod.in$snnsObject$getCompleteWeightMatrix() #get all input-hidden and hidden-hidden wts inps<-wts[grep('Input',row.names(wts)),grep('Hidden_2',colnames(wts)),drop=F] inps<-melt(rbind(rep(NA,ncol(inps)),inps))$value uni.hids<-paste0('Hidden_',1+seq(1,hid.num)) for(i in 1:length(uni.hids)){ if(is.na(uni.hids[i+1])) break tmp<-wts[grep(uni.hids[i],rownames(wts)),grep(uni.hids[i+1],colnames(wts)),drop=F] inps<-c(inps,melt(rbind(rep(NA,ncol(tmp)),tmp))$value) } #get connections from last hidden to output layers outs<-wts[grep(paste0('Hidden_',hid.num+1),row.names(wts)),grep('Output',colnames(wts)),drop=F] outs<-rbind(rep(NA,ncol(outs)),outs) #weight vector for all wts<-c(inps,melt(outs)$value) assign('bias',F,envir=environment(nnet.vals)) } if(nid) wts<-rescale(abs(wts),c(1,rel.rsc)) #convert wts to list with appropriate names hid.struct<-struct.out[-c(length(struct.out))] row.nms<-NULL for(i in 1:length(hid.struct)){ if(is.na(hid.struct[i+1])) break row.nms<-c(row.nms,rep(paste('hidden',i,seq(1:hid.struct[i+1])),each=1+hid.struct[i])) } row.nms<-c( row.nms, rep(paste('out',seq(1:struct.out[length(struct.out)])),each=1+struct.out[length(struct.out)-1]) ) out.ls<-data.frame(wts,row.nms) out.ls$row.nms<-factor(row.nms,levels=unique(row.nms),labels=unique(row.nms)) out.ls<-split(out.ls$wts,f=out.ls$row.nms) assign('struct',struct.out,envir=environment(nnet.vals)) out.ls } wts<-nnet.vals(mod.in,nid=F) if(wts.only) return(wts) #circle colors for input, if desired, must be two-vector list, first vector is for input layer if(is.list(circle.col)){ circle.col.inp<-circle.col[[1]] circle.col<-circle.col[[2]] } else circle.col.inp<-circle.col #initiate plotting x.range<-c(0,100) y.range<-c(0,100) #these are all proportions from 0-1 if(is.null(line.stag)) line.stag<-0.011*circle.cex/2 layer.x<-seq(0.17,0.9,length=length(struct)) bias.x<-layer.x[-length(layer.x)]+diff(layer.x)/2 bias.y<-0.95 circle.cex<-circle.cex #get variable names from mod.in object #change to user input if supplied if('numeric' %in% class(mod.in)){ x.names<-paste0(rep('X',struct[1]),seq(1:struct[1])) y.names<-paste0(rep('Y',struct[3]),seq(1:struct[3])) } if('mlp' %in% class(mod.in)){ all.names<-mod.in$snnsObject$getUnitDefinitions() x.names<-all.names[grep('Input',all.names$unitName),'unitName'] y.names<-all.names[grep('Output',all.names$unitName),'unitName'] } if('nn' %in% class(mod.in)){ x.names<-mod.in$model.list$variables y.names<-mod.in$model.list$respons } if('xNames' %in% names(mod.in)){ x.names<-mod.in$xNames y.names<-attr(terms(mod.in),'factor') y.names<-row.names(y.names)[!row.names(y.names) %in% x.names] } if(!'xNames' %in% names(mod.in) & 'nnet' %in% class(mod.in)){ if(is.null(mod.in$call$formula)){ x.names<-colnames(eval(mod.in$call$x)) y.names<-colnames(eval(mod.in$call$y)) } else{ forms<-eval(mod.in$call$formula) x.names<-mod.in$coefnames facts<-attr(terms(mod.in),'factors') y.check<-mod.in$fitted if(ncol(y.check)>1) y.names<-colnames(y.check) else y.names<-as.character(forms)[2] } } #change variables names to user sub if(!is.null(x.lab)){ if(length(x.names) != length(x.lab)) stop('x.lab length not equal to number of input variables') else x.names<-x.lab } if(!is.null(y.lab)){ if(length(y.names) != length(y.lab)) stop('y.lab length not equal to number of output variables') else y.names<-y.lab } #initiate plot plot(x.range,y.range,type='n',axes=F,ylab='',xlab='',...) #function for getting y locations for input, hidden, output layers #input is integer value from 'struct' get.ys<-function(lyr, max_space = max.sp){ if(max_space){ spacing <- diff(c(0*diff(y.range),0.9*diff(y.range)))/lyr } else { spacing<-diff(c(0*diff(y.range),0.9*diff(y.range)))/max(struct) } seq(0.5*(diff(y.range)+spacing*(lyr-1)),0.5*(diff(y.range)-spacing*(lyr-1)), length=lyr) } #function for plotting nodes #'layer' specifies which layer, integer from 'struct' #'x.loc' indicates x location for layer, integer from 'layer.x' #'layer.name' is string indicating text to put in node layer.points<-function(layer,x.loc,layer.name,cex=cex.val){ x<-rep(x.loc*diff(x.range),layer) y<-get.ys(layer) points(x,y,pch=21,cex=circle.cex,col=in.col,bg=bord.col) if(node.labs) text(x,y,paste(layer.name,1:layer,sep=''),cex=cex.val) if(layer.name=='I' & var.labs) text(x-line.stag*diff(x.range),y,x.names,pos=2,cex=cex.val) if(layer.name=='O' & var.labs) text(x+line.stag*diff(x.range),y,y.names,pos=4,cex=cex.val) } #function for plotting bias points #'bias.x' is vector of values for x locations #'bias.y' is vector for y location #'layer.name' is string indicating text to put in node bias.points<-function(bias.x,bias.y,layer.name,cex,...){ for(val in 1:length(bias.x)){ points( diff(x.range)*bias.x[val], bias.y*diff(y.range), pch=21,col=in.col,bg=bord.col,cex=circle.cex ) if(node.labs) text( diff(x.range)*bias.x[val], bias.y*diff(y.range), paste(layer.name,val,sep=''), cex=cex.val ) } } #function creates lines colored by direction and width as proportion of magnitude #use 'all.in' argument if you want to plot connection lines for only a single input node layer.lines<-function(mod.in,h.layer,layer1=1,layer2=2,out.layer=F,nid,rel.rsc,all.in,pos.col, neg.col,...){ x0<-rep(layer.x[layer1]*diff(x.range)+line.stag*diff(x.range),struct[layer1]) x1<-rep(layer.x[layer2]*diff(x.range)-line.stag*diff(x.range),struct[layer1]) if(out.layer==T){ y0<-get.ys(struct[layer1]) y1<-rep(get.ys(struct[layer2])[h.layer],struct[layer1]) src.str<-paste('out',h.layer) wts<-nnet.vals(mod.in,nid=F,rel.rsc) wts<-wts[grep(src.str,names(wts))][[1]][-1] wts.rs<-nnet.vals(mod.in,nid=T,rel.rsc) wts.rs<-wts.rs[grep(src.str,names(wts.rs))][[1]][-1] cols<-rep(pos.col,struct[layer1]) cols[wts<0]<-neg.col if(nid) segments(x0,y0,x1,y1,col=cols,lwd=wts.rs) else segments(x0,y0,x1,y1) } else{ if(is.logical(all.in)) all.in<-h.layer else all.in<-which(x.names==all.in) y0<-rep(get.ys(struct[layer1])[all.in],struct[2]) y1<-get.ys(struct[layer2]) src.str<-paste('hidden',layer1) wts<-nnet.vals(mod.in,nid=F,rel.rsc) wts<-unlist(lapply(wts[grep(src.str,names(wts))],function(x) x[all.in+1])) wts.rs<-nnet.vals(mod.in,nid=T,rel.rsc) wts.rs<-unlist(lapply(wts.rs[grep(src.str,names(wts.rs))],function(x) x[all.in+1])) cols<-rep(pos.col,struct[layer2]) cols[wts<0]<-neg.col if(nid) segments(x0,y0,x1,y1,col=cols,lwd=wts.rs) else segments(x0,y0,x1,y1) } } bias.lines<-function(bias.x,mod.in,nid,rel.rsc,all.out,pos.col,neg.col,...){ if(is.logical(all.out)) all.out<-1:struct[length(struct)] else all.out<-which(y.names==all.out) for(val in 1:length(bias.x)){ wts<-nnet.vals(mod.in,nid=F,rel.rsc) wts.rs<-nnet.vals(mod.in,nid=T,rel.rsc) if(val != length(bias.x)){ wts<-wts[grep('out',names(wts),invert=T)] wts.rs<-wts.rs[grep('out',names(wts.rs),invert=T)] sel.val<-grep(val,substr(names(wts.rs),8,8)) wts<-wts[sel.val] wts.rs<-wts.rs[sel.val] } else{ wts<-wts[grep('out',names(wts))] wts.rs<-wts.rs[grep('out',names(wts.rs))] } cols<-rep(pos.col,length(wts)) cols[unlist(lapply(wts,function(x) x[1]))<0]<-neg.col wts.rs<-unlist(lapply(wts.rs,function(x) x[1])) if(nid==F){ wts.rs<-rep(1,struct[val+1]) cols<-rep('black',struct[val+1]) } if(val != length(bias.x)){ segments( rep(diff(x.range)*bias.x[val]+diff(x.range)*line.stag,struct[val+1]), rep(bias.y*diff(y.range),struct[val+1]), rep(diff(x.range)*layer.x[val+1]-diff(x.range)*line.stag,struct[val+1]), get.ys(struct[val+1]), lwd=wts.rs, col=cols ) } else{ segments( rep(diff(x.range)*bias.x[val]+diff(x.range)*line.stag,struct[val+1]), rep(bias.y*diff(y.range),struct[val+1]), rep(diff(x.range)*layer.x[val+1]-diff(x.range)*line.stag,struct[val+1]), get.ys(struct[val+1])[all.out], lwd=wts.rs[all.out], col=cols[all.out] ) } } } #use functions to plot connections between layers #bias lines if(bias) bias.lines(bias.x,mod.in,nid=nid,rel.rsc=rel.rsc,all.out=all.out,pos.col=alpha(pos.col,alpha.val), neg.col=alpha(neg.col,alpha.val)) #layer lines, makes use of arguments to plot all or for individual layers #starts with input-hidden #uses 'all.in' argument to plot connection lines for all input nodes or a single node if(is.logical(all.in)){ mapply( function(x) layer.lines(mod.in,x,layer1=1,layer2=2,nid=nid,rel.rsc=rel.rsc, all.in=all.in,pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)), 1:struct[1] ) } else{ node.in<-which(x.names==all.in) layer.lines(mod.in,node.in,layer1=1,layer2=2,nid=nid,rel.rsc=rel.rsc,all.in=all.in, pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)) } #connections between hidden layers lays<-split(c(1,rep(2:(length(struct)-1),each=2),length(struct)), f=rep(1:(length(struct)-1),each=2)) lays<-lays[-c(1,(length(struct)-1))] for(lay in lays){ for(node in 1:struct[lay[1]]){ layer.lines(mod.in,node,layer1=lay[1],layer2=lay[2],nid=nid,rel.rsc=rel.rsc,all.in=T, pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)) } } #lines for hidden-output #uses 'all.out' argument to plot connection lines for all output nodes or a single node if(is.logical(all.out)) mapply( function(x) layer.lines(mod.in,x,layer1=length(struct)-1,layer2=length(struct),out.layer=T,nid=nid,rel.rsc=rel.rsc, all.in=all.in,pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)), 1:struct[length(struct)] ) else{ node.in<-which(y.names==all.out) layer.lines(mod.in,node.in,layer1=length(struct)-1,layer2=length(struct),out.layer=T,nid=nid,rel.rsc=rel.rsc, pos.col=pos.col,neg.col=neg.col,all.out=all.out) } #use functions to plot nodes for(i in 1:length(struct)){ in.col<-bord.col<-circle.col layer.name<-'H' if(i==1) { layer.name<-'I'; in.col<-bord.col<-circle.col.inp} if(i==length(struct)) layer.name<-'O' layer.points(struct[i],layer.x[i],layer.name) } if(bias) bias.points(bias.x,bias.y,'B') }

markvandijl@hotmail.com at Oct 29, 2018 NeuralNetTools v1.5.0

plotnet <- function(mod.in,nid=T,all.out=T,all.in=T,bias=T,wts.only=F,rel.rsc=5,circle.cex=5, node.labs=T,var.labs=T,x.lab=NULL,y.lab=NULL,line.stag=NULL,struct=NULL,cex.val=1, alpha.val=1,circle.col='lightblue',pos.col='black',neg.col='grey', max.sp = F, ...){ require(scales) #sanity checks if('mlp' %in% class(mod.in)) warning('Bias layer not applicable for rsnns object') if('numeric' %in% class(mod.in)){ if(is.null(struct)) stop('Three-element vector required for struct') if(length(mod.in) != ((struct[1]*struct[2]+struct[2]*struct[3])+(struct[3]+struct[2]))) stop('Incorrect length of weight matrix for given network structure') } if('train' %in% class(mod.in)){ if('nnet' %in% class(mod.in$finalModel)){ mod.in<-mod.in$finalModel warning('Using best nnet model from train output') } else stop('Only nnet method can be used with train object') } #gets weights for neural network, output is list #if rescaled argument is true, weights are returned but rescaled based on abs value nnet.vals<-function(mod.in,nid,rel.rsc,struct.out=struct){ require(scales) require(reshape) if('numeric' %in% class(mod.in)){ struct.out<-struct wts<-mod.in } #neuralnet package if('nn' %in% class(mod.in)){ struct.out<-unlist(lapply(mod.in$weights[[1]],ncol)) struct.out<-struct.out[-length(struct.out)] struct.out<-c( length(mod.in$model.list$variables), struct.out, length(mod.in$model.list$response) ) wts<-unlist(mod.in$weights[[1]]) } #nnet package if('nnet' %in% class(mod.in)){ struct.out<-mod.in$n wts<-mod.in$wts } #RSNNS package if('mlp' %in% class(mod.in)){ struct.out<-c(mod.in$nInputs,mod.in$archParams$size,mod.in$nOutputs) hid.num<-length(struct.out)-2 wts<-mod.in$snnsObject$getCompleteWeightMatrix() #get all input-hidden and hidden-hidden wts inps<-wts[grep('Input',row.names(wts)),grep('Hidden_2',colnames(wts)),drop=F] inps<-melt(rbind(rep(NA,ncol(inps)),inps))$value uni.hids<-paste0('Hidden_',1+seq(1,hid.num)) for(i in 1:length(uni.hids)){ if(is.na(uni.hids[i+1])) break tmp<-wts[grep(uni.hids[i],rownames(wts)),grep(uni.hids[i+1],colnames(wts)),drop=F] inps<-c(inps,melt(rbind(rep(NA,ncol(tmp)),tmp))$value) } #get connections from last hidden to output layers outs<-wts[grep(paste0('Hidden_',hid.num+1),row.names(wts)),grep('Output',colnames(wts)),drop=F] outs<-rbind(rep(NA,ncol(outs)),outs) #weight vector for all wts<-c(inps,melt(outs)$value) assign('bias',F,envir=environment(nnet.vals)) } if(nid) wts<-rescale(abs(wts),c(1,rel.rsc)) #convert wts to list with appropriate names hid.struct<-struct.out[-c(length(struct.out))] row.nms<-NULL for(i in 1:length(hid.struct)){ if(is.na(hid.struct[i+1])) break row.nms<-c(row.nms,rep(paste('hidden',i,seq(1:hid.struct[i+1])),each=1+hid.struct[i])) } row.nms<-c( row.nms, rep(paste('out',seq(1:struct.out[length(struct.out)])),each=1+struct.out[length(struct.out)-1]) ) out.ls<-data.frame(wts,row.nms) out.ls$row.nms<-factor(row.nms,levels=unique(row.nms),labels=unique(row.nms)) out.ls<-split(out.ls$wts,f=out.ls$row.nms) assign('struct',struct.out,envir=environment(nnet.vals)) out.ls } wts<-nnet.vals(mod.in,nid=F) if(wts.only) return(wts) #circle colors for input, if desired, must be two-vector list, first vector is for input layer if(is.list(circle.col)){ circle.col.inp<-circle.col[[1]] circle.col<-circle.col[[2]] } else circle.col.inp<-circle.col #initiate plotting x.range<-c(0,100) y.range<-c(0,100) #these are all proportions from 0-1 if(is.null(line.stag)) line.stag<-0.011*circle.cex/2 layer.x<-seq(0.17,0.9,length=length(struct)) bias.x<-layer.x[-length(layer.x)]+diff(layer.x)/2 bias.y<-0.95 circle.cex<-circle.cex #get variable names from mod.in object #change to user input if supplied if('numeric' %in% class(mod.in)){ x.names<-paste0(rep('X',struct[1]),seq(1:struct[1])) y.names<-paste0(rep('Y',struct[3]),seq(1:struct[3])) } if('mlp' %in% class(mod.in)){ all.names<-mod.in$snnsObject$getUnitDefinitions() x.names<-all.names[grep('Input',all.names$unitName),'unitName'] y.names<-all.names[grep('Output',all.names$unitName),'unitName'] } if('nn' %in% class(mod.in)){ x.names<-mod.in$model.list$variables y.names<-mod.in$model.list$respons } if('xNames' %in% names(mod.in)){ x.names<-mod.in$xNames y.names<-attr(terms(mod.in),'factor') y.names<-row.names(y.names)[!row.names(y.names) %in% x.names] } if(!'xNames' %in% names(mod.in) & 'nnet' %in% class(mod.in)){ if(is.null(mod.in$call$formula)){ x.names<-colnames(eval(mod.in$call$x)) y.names<-colnames(eval(mod.in$call$y)) } else{ forms<-eval(mod.in$call$formula) x.names<-mod.in$coefnames facts<-attr(terms(mod.in),'factors') y.check<-mod.in$fitted if(ncol(y.check)>1) y.names<-colnames(y.check) else y.names<-as.character(forms)[2] } } #change variables names to user sub if(!is.null(x.lab)){ if(length(x.names) != length(x.lab)) stop('x.lab length not equal to number of input variables') else x.names<-x.lab } if(!is.null(y.lab)){ if(length(y.names) != length(y.lab)) stop('y.lab length not equal to number of output variables') else y.names<-y.lab } #initiate plot plot(x.range,y.range,type='n',axes=F,ylab='',xlab='',...) #function for getting y locations for input, hidden, output layers #input is integer value from 'struct' get.ys<-function(lyr, max_space = max.sp){ if(max_space){ spacing <- diff(c(0*diff(y.range),0.9*diff(y.range)))/lyr } else { spacing<-diff(c(0*diff(y.range),0.9*diff(y.range)))/max(struct) } seq(0.5*(diff(y.range)+spacing*(lyr-1)),0.5*(diff(y.range)-spacing*(lyr-1)), length=lyr) } #function for plotting nodes #'layer' specifies which layer, integer from 'struct' #'x.loc' indicates x location for layer, integer from 'layer.x' #'layer.name' is string indicating text to put in node layer.points<-function(layer,x.loc,layer.name,cex=cex.val){ x<-rep(x.loc*diff(x.range),layer) y<-get.ys(layer) points(x,y,pch=21,cex=circle.cex,col=in.col,bg=bord.col) if(node.labs) text(x,y,paste(layer.name,1:layer,sep=''),cex=cex.val) if(layer.name=='I' & var.labs) text(x-line.stag*diff(x.range),y,x.names,pos=2,cex=cex.val) if(layer.name=='O' & var.labs) text(x+line.stag*diff(x.range),y,y.names,pos=4,cex=cex.val) } #function for plotting bias points #'bias.x' is vector of values for x locations #'bias.y' is vector for y location #'layer.name' is string indicating text to put in node bias.points<-function(bias.x,bias.y,layer.name,cex,...){ for(val in 1:length(bias.x)){ points( diff(x.range)*bias.x[val], bias.y*diff(y.range), pch=21,col=in.col,bg=bord.col,cex=circle.cex ) if(node.labs) text( diff(x.range)*bias.x[val], bias.y*diff(y.range), paste(layer.name,val,sep=''), cex=cex.val ) } } #function creates lines colored by direction and width as proportion of magnitude #use 'all.in' argument if you want to plot connection lines for only a single input node layer.lines<-function(mod.in,h.layer,layer1=1,layer2=2,out.layer=F,nid,rel.rsc,all.in,pos.col, neg.col,...){ x0<-rep(layer.x[layer1]*diff(x.range)+line.stag*diff(x.range),struct[layer1]) x1<-rep(layer.x[layer2]*diff(x.range)-line.stag*diff(x.range),struct[layer1]) if(out.layer==T){ y0<-get.ys(struct[layer1]) y1<-rep(get.ys(struct[layer2])[h.layer],struct[layer1]) src.str<-paste('out',h.layer) wts<-nnet.vals(mod.in,nid=F,rel.rsc) wts<-wts[grep(src.str,names(wts))][[1]][-1] wts.rs<-nnet.vals(mod.in,nid=T,rel.rsc) wts.rs<-wts.rs[grep(src.str,names(wts.rs))][[1]][-1] cols<-rep(pos.col,struct[layer1]) cols[wts<0]<-neg.col if(nid) segments(x0,y0,x1,y1,col=cols,lwd=wts.rs) else segments(x0,y0,x1,y1) } else{ if(is.logical(all.in)) all.in<-h.layer else all.in<-which(x.names==all.in) y0<-rep(get.ys(struct[layer1])[all.in],struct[2]) y1<-get.ys(struct[layer2]) src.str<-paste('hidden',layer1) wts<-nnet.vals(mod.in,nid=F,rel.rsc) wts<-unlist(lapply(wts[grep(src.str,names(wts))],function(x) x[all.in+1])) wts.rs<-nnet.vals(mod.in,nid=T,rel.rsc) wts.rs<-unlist(lapply(wts.rs[grep(src.str,names(wts.rs))],function(x) x[all.in+1])) cols<-rep(pos.col,struct[layer2]) cols[wts<0]<-neg.col if(nid) segments(x0,y0,x1,y1,col=cols,lwd=wts.rs) else segments(x0,y0,x1,y1) } } bias.lines<-function(bias.x,mod.in,nid,rel.rsc,all.out,pos.col,neg.col,...){ if(is.logical(all.out)) all.out<-1:struct[length(struct)] else all.out<-which(y.names==all.out) for(val in 1:length(bias.x)){ wts<-nnet.vals(mod.in,nid=F,rel.rsc) wts.rs<-nnet.vals(mod.in,nid=T,rel.rsc) if(val != length(bias.x)){ wts<-wts[grep('out',names(wts),invert=T)] wts.rs<-wts.rs[grep('out',names(wts.rs),invert=T)] sel.val<-grep(val,substr(names(wts.rs),8,8)) wts<-wts[sel.val] wts.rs<-wts.rs[sel.val] } else{ wts<-wts[grep('out',names(wts))] wts.rs<-wts.rs[grep('out',names(wts.rs))] } cols<-rep(pos.col,length(wts)) cols[unlist(lapply(wts,function(x) x[1]))<0]<-neg.col wts.rs<-unlist(lapply(wts.rs,function(x) x[1])) if(nid==F){ wts.rs<-rep(1,struct[val+1]) cols<-rep('black',struct[val+1]) } if(val != length(bias.x)){ segments( rep(diff(x.range)*bias.x[val]+diff(x.range)*line.stag,struct[val+1]), rep(bias.y*diff(y.range),struct[val+1]), rep(diff(x.range)*layer.x[val+1]-diff(x.range)*line.stag,struct[val+1]), get.ys(struct[val+1]), lwd=wts.rs, col=cols ) } else{ segments( rep(diff(x.range)*bias.x[val]+diff(x.range)*line.stag,struct[val+1]), rep(bias.y*diff(y.range),struct[val+1]), rep(diff(x.range)*layer.x[val+1]-diff(x.range)*line.stag,struct[val+1]), get.ys(struct[val+1])[all.out], lwd=wts.rs[all.out], col=cols[all.out] ) } } } #use functions to plot connections between layers #bias lines if(bias) bias.lines(bias.x,mod.in,nid=nid,rel.rsc=rel.rsc,all.out=all.out,pos.col=alpha(pos.col,alpha.val), neg.col=alpha(neg.col,alpha.val)) #layer lines, makes use of arguments to plot all or for individual layers #starts with input-hidden #uses 'all.in' argument to plot connection lines for all input nodes or a single node if(is.logical(all.in)){ mapply( function(x) layer.lines(mod.in,x,layer1=1,layer2=2,nid=nid,rel.rsc=rel.rsc, all.in=all.in,pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)), 1:struct[1] ) } else{ node.in<-which(x.names==all.in) layer.lines(mod.in,node.in,layer1=1,layer2=2,nid=nid,rel.rsc=rel.rsc,all.in=all.in, pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)) } #connections between hidden layers lays<-split(c(1,rep(2:(length(struct)-1),each=2),length(struct)), f=rep(1:(length(struct)-1),each=2)) lays<-lays[-c(1,(length(struct)-1))] for(lay in lays){ for(node in 1:struct[lay[1]]){ layer.lines(mod.in,node,layer1=lay[1],layer2=lay[2],nid=nid,rel.rsc=rel.rsc,all.in=T, pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)) } } #lines for hidden-output #uses 'all.out' argument to plot connection lines for all output nodes or a single node if(is.logical(all.out)) mapply( function(x) layer.lines(mod.in,x,layer1=length(struct)-1,layer2=length(struct),out.layer=T,nid=nid,rel.rsc=rel.rsc, all.in=all.in,pos.col=alpha(pos.col,alpha.val),neg.col=alpha(neg.col,alpha.val)), 1:struct[length(struct)] ) else{ node.in<-which(y.names==all.out) layer.lines(mod.in,node.in,layer1=length(struct)-1,layer2=length(struct),out.layer=T,nid=nid,rel.rsc=rel.rsc, pos.col=pos.col,neg.col=neg.col,all.out=all.out) } #use functions to plot nodes for(i in 1:length(struct)){ in.col<-bord.col<-circle.col layer.name<-'H' if(i==1) { layer.name<-'I'; in.col<-bord.col<-circle.col.inp} if(i==length(struct)) layer.name<-'O' layer.points(struct[i],layer.x[i],layer.name) } if(bias) bias.points(bias.x,bias.y,'B') }