Mathematica code and figures created for the paper "Understanding the Back Propagated Neural Network Using Mathematica Graphics"
Steve Hunka, University of Alberta; steve.hunka@ualberta.ca
Mike Carbonaro

Date Last Modified: Apr 15/97

Required Packages

<<Graphics`Graphics3D`
<<Graphics`MultipleListPlot`
<<Graphics`Arrow`

Code for Figure 1

Show[Graphics[{
   Table[
  {RGBColor[1,0,0],Disk[Scaled[{n,.2}],.1]},
  {n,.1,1.,0.4}], (*end Table *)
  Table[
  {RGBColor[0,1,0],Disk[Scaled[{n,.5}],.1]},
  {n,.25,1.,0.5}],(*end Table *)
   {RGBColor[0,0,1],Disk[Scaled[{.5,.75}],.1]}},
  (*now show the arrows*)
  Epilog->{{Arrow[{.08,.16},{.25,.5}]},
           {Arrow[{.08,.16},{.75,.5}]},
           {Arrow[{.5,.16},{.25,.5}]},
           {Arrow[{.5,.16},{.75,.5}]},
           {Arrow[{.9,.16},{.75,.5}]},
           {Arrow[{.9,.16},{.25,.5}]},
           {Arrow[{.25,.5},{.5,.75}]},
           {Arrow[{.75,.5},{.5,.75}]},
           {Arrow[{.08,.01},{.08,.1}]},
           {Arrow[{.5,.01},{.5,.1}]},
           {Arrow[{.9,.01},{.9,.1}]},
           {Arrow[{.5,.75},{.5,.95}]},
           {Text["Input",{.3,.16}]},
           {Text["Cells",{.7,.16}]},
           {Text["Hidden Cells",{.5,.5}]},
           {Text["Output Cell",{.8,.8}]}
           }
  
             ],  (*end Graphics *)
  AspectRatio->Automatic]; (*end Show*)

Figure 1: Neural Network Example Display

Figure 2: T and C character matrix

tcr={{.9,.1,.9,.9,.1,.9,.1,.1,.1},
     {.9,.9,.1,.1,.1,.1,.9,.9,.1},
     {.1,.1,.1,.9,.1,.9,.9,.1,.9},
     {.1,.9,.9,.1,.1,.1,.1,.9,.9},
     
     {.1,.1,.1,.1,.9,.9,.1,.1,.1},
     {.1,.9,.1,.1,.9,.1,.1,.1,.1},
     {.1,.1,.1,.9,.9,.1,.1,.1,.1},
     {.1,.1,.1,.1,.9,.1,.1,.9,.1}
     }

pobj={
MapThread[ListDensityPlot[#,
       FrameTicks->None,Frame->False,
       ColorFunction->(If[#<=0.1,
        GrayLevel[0.4],GrayLevel[1.0]]&),
       DisplayFunction->Identity]&,
       {MapThread[Partition[##,3]&,{tcr}]}
       ]};

Show[GraphicsArray[Partition[Flatten[pobj],4]],
    DisplayFunction->$DisplayFunction]

Functions required or referred to in the paper

kbin3[q_,p_] function to accept numeric input from keyboard posing question in q. If p is any integer then an integer is to be input; if p is any real value then a real value is to be input; if p={n} then a n element vector is expected; if p={r,c} then a matrix with r rows and c columns is expected. If the input is inappropriate the question is posed again.  If the input is appropriate it is returned.

kbin3[q_,p_]:=
 Module[{c,ans,vrp,vrp2},
  c=0;
  vrp=" Input Error. Type a vector with # elements=";
  vrp2=" Input Error. Type a matrix of order ";
  While[c==0,
   ans=Input[q];
    Which[
      Head[ans]===Symbol,(*check for character*)
       Print[ans," Input Error; Characters not allowed"];,
       (*integer or real required*)
      Head[p]===Integer || Head[p]===Real, 
      (*chk for vec when scalar wanted*)
      If[Head[p]=!=Head[ans],
       Print[ans," Input Error. Input must be ",Head[p]];,
       c=1];,
       
      Head[p]===List && Length[p]==1, (*vector rqd*)
       If[VectorQ[ans]==False, 
       Print[ans,StringJoin[vrp,ToString[p]]];,
         If[Length[ans]!=First[p],
       Print[ans," Error: Vector requires # of elements=",
             First[p]];,
       c=1]];,
       
      Head[p]===List && Length[p]==2, (*matrix rqd*)
      If[MatrixQ[ans]==False,
      Print[ans,StringJoin[vrp2,ToString[p]]];,
          If[Dimensions[ans]!=p,
      Print[ans," Error; Matrix dimensions must be ",p];,
       c=1]]; 
     ]; (*end Which *)    
   ]; (*end While *)
 Return[ans];
 ]; (* end Module*)

inpvec[r,n,ty] presents directive "Type n element vector of "ty"" and checks the vector elements being in the range {min,max}.
r is a vector of the acceptable range
n is the acceptable number of elements in the vector
ty is a string describing the nature of the indices to be input
If the range is exceed, the directive is presented again.
Calls: kbin3
Returns: an acceptable input vector
Mod. Date: March 24/97

inpvec[r_,n_,ty_]:=Module[{q,selv,rng},
q="Type  element vector of .";
q=StringInsert[StringInsert[q,ToString[n],6],ty,-2];
rng=False;
While[rng==False,
 selv=kbin3[q,{n}];
 If[Max[selv]>Max[r] || Min[selv]<Min[r],
 Print[selv,":Vector elements out of range"],
 rng=True];
 ]; (*end While rng==False*)
Return[selv];
]; (*end Module *)

kbinstrg[q,p] used to input a string in response to question in q. p contains acceptable answers in the form of a list,eg., p={{ans1},{ans2},....}. If the input is appropriate it is returned. If the input is inappropriate the question is posed again.

kbinstrg[q_,p_]:=
 Module[{c,ans},
  c=0;
  While[c==0,
   ans=InputString[q];
    Do[If[{ans}==p[[j]],
         c=1; Break[]];
      ,{j,1,Length[p]}]; (* end Do *)  
   If[c!=1,Print[ans," Input Error. Type Again"]];  
   ]; (*end While*)
 Return[ans];
 ]; (* end Module*)

getFdata:The user is asked to input the name of the file holding the file data; if the file is found a message is given; if the file is not found a message is given and the user is asked to give another name. If the user enters quit at the point of entering a file name, the function stops. If the file is available the user is asked whether "all" or only "part" of the data is to read. If the user enters all, all data is used; if part is entered, the user is asked to give the starting point in the file and the ending point for which the data is wanted.
Calls: kbin3, kbinstrg,timeDate
Returns: data from the file read, and extnt a 2 element vector of starting and
             ending position for the data read.

getFdata:=
 Module[{fname,ok,data,extnt,strt,end},
ok=0;
 While[ok==0,
  fname=InputString["Type name of file"];
  If[fname=="quit",Return[]];
  If[{fname}===FileNames[fname],
    Print[fname," was found"];ok=1;
   ,Print[fname," was not found"]];
 ]; (*end While *)
 Print["File created:"];
 timeDate[FileDate[fname]];
 extnt=kbinstrg["Use all or part of data file?",
 {{"all"},{"part"}}];
 Print["Data read from file=",extnt];
 If[extnt=="all",data=ReadList[fname];
   extnt={1,Part[Dimensions[data],1]}; (*else*)
 ,strt=kbin3["Type starting position",0];
  end=kbin3["Type ending position",0];
  OpenRead[fname];
  Skip[fname,Expression,strt];
  data=ReadList[fname,Expression,1+end-strt];
  Close[fname];
  Print["Data returned from file=",strt," to ",end];
  extnt=ToString[Join[{strt},{end}]];
 ]; (*end if extnt*)
 Print["Returned data dimension=",Dimensions[data]];
 Return[{data,extnt}];
 ]; (*end Module*)

timeDate[ts] prints month day,year at hour:minutes. ts is vector returned by Date or FileDate.

timeDate[ts_]:=
  Module[{month},
   month={{"Jan "},{"Feb "},{"Mar "},{"Apr "},
          {"May "},{"Jun "},{"Jul "},{"Aug "},
          {"Sep "},{"Oct "},{"Nov "},{"Dec "}};
   Print[Part[month,ts[[2]]][[1]],ts[[3]],",",ts[[1]],
         " at ",ts[[4]],":",ts[[5]]];
  ];

splt3d[d_,ttl_] 3D plot for weights or output of 3 cells defined by user. 
d is the cell output or weights from the neural network usually stored in a file;
ttl is a title for the plot.
The user input options are:
a) whether each plot should be marked with an id number at the start or end of
    the line or dots plotted.
b) whether lines or points are to be plotted; if points, the point size is
    requested.
c) whether single 3d plots should be made in addition to the combined plot
   ScatterPlot3D produces Graphics3D[{Point[{x,y,z}],.....},options]; it is
   changed to give Graphics3D[{PointSize[ps],Point[{x,y,z}],.....},options
    in each pobj[[j]]. Also the first or last point is changed to Text[j,{x,y,z}]
    depending upon option (a) above.
d) the cell data to use, e.g., {1,2,5} plots point as defined by cells 1, 2 and 5. 
e) whether more plots are wanted after the first, to allow user to select other
    cells.
 Note: 
 1)PlotRange->All has been set. If PlotRange->Automatic, then if in (a) "end" is selected an id number may not appear for a specific plot because the plot was truncated.
 2) d is of order (#epochs, #z,#hidden cells) where #z may be number of output cells, number of exemplars, or number of input cells depending on the calling function. 
Calls: kbinstrg, kbin3,inpvec
Rqrs: <<Graphics`Graphics3D` 
Mod. Date: Mar 24/97

splt3d[d_,ttl_]:=
 Module[{p,ans,ln,pobj,temp,ps,ept,ipt,hcv,dt,qplt},
 ept=Part[Dimensions[d],1];(*default mark end point*)
  p=Part[Dimensions[d],2];
 (*dt=Transpose[d,{3,1,2}];*)
 qplt="y";
 While["y"==qplt, 
  ans=kbinstrg["Mark start or end?",
     {{"start"},{"end"}}];
Print["Line id=",ans];
If[ans=="start",ept=1];
  ans=kbinstrg["Join plotted points? y/n",{{"y"},{"n"}}];
If[ans=="n",ln=False;
   ps=kbin3["Type point size",0.01];
   Print["Point size=",ps];
   ,ln=True;];
ipt=kbinstrg["Single plots? y/n",{{"y"},{"n"}}];
If[ipt=="y",ipt=$DisplayFunction,ipt=Identity];
hcv=inpvec[{1,Part[Dimensions[d],3]},3,"hidden cells"];
Print["Selected Cells=",hcv];
  pobj=List[];  
dt=Transpose[d,{2,3,1}][[hcv]];
dt=Transpose[dt,{3,2,1}];
 pobj=MapThread[
   ScatterPlot3D[#,
   PlotJoined->ln,Axes->True,
         AxesLabel->Map[ToString,hcv],
         PlotRange->All,
         DisplayFunction->ipt]&,
      {dt}];  
  If[ans=="n",
  Do[ (*incl ps in each graphic object*)
    temp=Append[{PointSize[ps]},pobj[[j]][[1]]];
    pobj=ReplacePart[pobj,temp,{j,1}];
    pobj=pobj /.
    pobj[[j,1,2,ept]]->
      Text[ToString[j],pobj[[j,1,2,ept,1]]];
  ,{j,1,p}];,
  (* do below if ans==y, ie lines *)
   Do[
   temp=Append[{Text[ToString[j],
       pobj[[j,1,1,ept]]]},pobj[[j,1]]];
   pobj[[j]]=ReplacePart[pobj[[j]],temp,1];
   ,{j,1,p}];
   ];
  Show[pobj,
  PlotLabel->ttl, 
  DisplayFunction->$DisplayFunction];
  qplt=kbinstrg["More plots? y/n",{{"y"},{"n"}}];
  ]; (*end While *)
  ]; (* end Module *)

hdwAray[d___]: used for making an array plot of the hidden cell weights by epoch for each input cell (attribute).
d  is optional; if d is present it contains the hidden weights of order (#epochs,#hidden cells,#input cells). d may be obtained from the appropriate  file created by the neural network program bpnn by using ReadList["filename"].  If d is absent, the user is requested to give the name of the file holding the hidden weights. 

Each plot contains one colored line for each hidden cell, and each plot represents a different attribute of the exemplars input. The plots are brought together in an array of plots for which the user may specify a common y-axis scaling (or default the scaling) and the plot arrangement. If the number of plots in each row exceeds the number of plots available an error message is given.
User Input: 
1) See getFdata if hdwmulist[] is used.
2) plot range (y/n); if y, {min,max} required; if no PlotRange->All
3) a vector specifying the number of plots in each row of the array plot. The sum of the elements in this vector should equal the number of input cells.
Calls: mplotLists, araydis, kbinstrg, kbin3,getFdata, timeDate
Required:<<Graphics`MultipleListPlot`
Mod. Date: Mar 28/97

hdwAray[d___]:=
 Module[{data,extnt,nhc,nic,p,prng,ans,lim,apat,ok},
 Print["Hidden Weights,Plots=inc[j]"];
 Print["Yaxis=wt; Xaxis=epoch; Line=hc[j]"];
 Print["Point=wt at each epoch"];
 If[Length[{d}]==0,
 {data,extnt}=getFdata;,data=d];
 nhc=Part[Dimensions[data],2];
 nic=Part[Dimensions[data],3];
 Print["Number Hidden cells=",nhc];
 Print["Number of input cells=",nic];
 Print["Minimum weight=",Min[data]];
 Print["Maximim weight=",Max[data]];
 p=List[];
 ans=kbinstrg["Set plot range? y/n",{{"y"},{"n"}}];
 If[ans=="y",
   prng=kbin3["Type {min,max} plot range",{2}];,
   prng=All];
 Do[ (* over number of input cells *)
 AppendTo[p,mplotLists[Transpose[
       Transpose[data,{3,2,1}][[i]]],prng]];           
 ,{i,1,nic}]; (*end Do *)
 
  ok=0;
  While[ok==0,
   apat=Input["Type vector of # plots in each row of array"];
   If[Apply[Plus,apat]>Length[p],
     Print["Error: too many plots in vector"];,
     ok=1]; (*end if *)
  ]; (*end while *)
 (*now display plots according to pattern in apat*)
 Show[GraphicsArray[
 araydis[Flatten[p],apat]],
      DisplayFunction->$DisplayFunction];                   
 ]; (*end Module *)

mplotLists[m]; plots the values in the columns of a 2 dimensional matrix m using MultipleListPlot, but the plotting symbols are removed; up to 12 different colors are used to plot the lines after which the color cycle repeats.
$LineStyles is changed. The colors are rotated through the following color sequence:(1) black, (2) blue (3) green, (4) cyan, (5) red, (6) magenta,
(7) yellow, (8) dark blue, (9) dark green (10) turquoise, (11)brown, and (12)
purple. (Colors numbered 8 to 12 may vary with different monitors.) lim is a 2 element vector of min and max plot range or All to default the plot range of y. 
Requires: <<Graphics`MultipleListPlot`

mplotLists[m_,lim_]:=
Module[{pobj,mtr,indx,nr,lstyl,colr},
 pobj=List[]; 
  mtr=Transpose[m];
  nr=Part[Dimensions[mtr],1];
 lstyl=Table[{Thickness[0.005],RGBColor[0,1,0]},{nr}];
 colr={0.,0.,0.,0.,0.,1.,0.,1.,0.,0.,1.,1.,
       1.,0.,0.,1.,0.,1.,1.,1.,0.,
       .0,.0,.5,.0,.5,.0,.0,.5,.5,.5,.0,.0,.5,.0,.5};
 Do[ (*replace RGB color parameters *)
lstyl[[j]]=ReplacePart[lstyl[[j]],RGBColor[
  colr[[1]],colr[[2]],colr[[3]]],{2}];
colr=RotateLeft[colr,3];
,{j,1,nr}];
$LineStyles=lstyl; (*Now set line styles*)

(*Now get multiplelistplot graphics object*)
pobj=Apply[MultipleListPlot[##,
     AxesLabel->{"x","y"},
     PlotJoined->True,
     PlotRange->lim,
     DisplayFunction->Identity]&,mtr];
(*delete plot symbols for each plot according to indx*)   
indx=Transpose[{Table[1,{nr}],Range[nr],Table[1,{nr}]}];
pobj=Map[Delete[#,indx]&,{pobj}];        
(*Show[pobj,DisplayFunction->$DisplayFunction];*)
Return[pobj];
]; (*end module*)

plotnLists[m,tl,xu,ps,pm,pn] plots a colored line for each column of m.  The values in the column are y coordinates and the x coordinates are taken to be from 1 to the number of rows of the matrix.
tl is a title for the plot, 
xu is the label for the x-axis
ps  set to 1 for individual plots for each col; 0 for no individual plots
pm set to 1 for one plot holding multiple lines; 0 for no plot
pn  (Optional) set to 1 for line numbers at end of lines when pm=1; else 0 
For single plots (ps=1), the title is appended to a plot sequence number.
 The colors are rotated through the following color sequence:(1) black, (2) blue (3) green, (4) cyan, (5) red, (6) magenta, (7) yellow, (8) dark blue, (9) dark green (10) turquoise, (11)brown, and (12) purple. (Colors numbered 8 to 12 may vary with different monitors.) To get a simple example of the colors used, do plotnLists[Table[Range[0,11],{2}],"Legend","units",0,1,1].
Mod. Date: Mar 20/97

plotnLists[m_,tl_,xu_,ps_,pm_,pn_:0]:=
Module[{pobj,colr,ipt,cntr=0},
If[ps==0 && pm==0,
   Print["Parameter error;no plot"];Return[]];
 pobj=List[];    
 colr={.5,.0,.5,0.,0.,0.,0.,0.,1.,0.,1.,0.,0.,1.,1.,
       1.,0.,0.,1.,0.,1.,1.,1.,0.,.0,.0,.5,.0,.5,.0,
       .0,.5,.5,.5,.0,.0};
 If[ps==1,ipt=$DisplayFunction,ipt=Identity];    
  pobj=MapThread[ListPlot[#,AxesLabel->{xu,"y"},
    PlotJoined->True,PlotRange->All,
    PlotLabel->StringInsert[tl,ToString[cntr=cntr+1],1],
    PlotStyle->{RGBColor[Part[colr=RotateLeft[colr,3],1],
    Part[colr,2],Part[colr,3]]},
    DisplayFunction->ipt]&,{Transpose[m]}]; 
 If[pn==1, (*replace last point with number*)
 MapThread[AppendTo[pobj[[#,1]],
      Text[#,Last[pobj[[#,1,2,1]]]]]&,
      {Range[Length[Transpose[m]]]}];
   ]; (*end if*)
 If[pm==1,Show[pobj,PlotLabel->tl,
     DisplayFunction->$DisplayFunction]];    
      ]; (*end module*)

araydis[m,in]; arranges the plots in m for GraphicsArray according to the arrangement specified by in. For example if m had 9 plots, and in={2,3,4} then the 1st row will contain 2 plots, the next 3 plots, and the last row 4 plots as displayed by Graphics Array.

araydis[m_,in_]:=
 Module[{pa,ma,nt},
  pa=List[];nt=Length[in];
  ma=m;
  Do[AppendTo[pa,Take[ma,in[[i]]]];
     ma=Drop[ma,in[[i]]];
     ,{i,1,nt}];
Return[pa];
];

errAnlz: plots the error squared at each output cell as a single plot. The squared error data are read from a file written by the neural network simulation program bpnn, and is of order (#iterations,#outcells)
User Input: See function getFdata and plotnLists
Calls: getFdata,timeDate,kbin3,kbinstrng,plotnLists
Note: If there is wide variability in the values of error-squared for more than one output cell and a large number of iterations, a single plot of the error curves is likely to produce curves which appear to have solid colors throughout the range of the x-axis. In such cases, the RMS error output from the neural simulation function bpnn provides a better representation of the nature of the convergence towards minimum sqd error. 
Mod. Date: Apr 17/97

errAnlz:= Module[{ttl,data,extnt,xunits},
Print["Plot of Sqd-error at Output Cells"];
{data,extnt}=getFdata;
If[0==extnt,Print["No data read"];Return[]];
ttl=" Sqd-error for Iterations=";
ttl=StringInsert[ttl,ToString[extnt],-1]; 
plotnLists[data,ttl,"iterations",1,0,0];
]; (*end Module *)

Plot of squared error

errAnlz

hdrAnlz1: plots migration of hidden cell response for each exemplar. Plot is 3D of (hc1,hc2,hc3) at each epoch for each exemplar. Each dot is an epoch; each line is an exemplar; axes are hidden cell response values. The data is taken from the hidden response file written by bpnn, and is of order (epochs, #exemplars, #hidden cells).
User Input: 
a) See getFile; splt3d user input is:
b) whether lines to be identified at start or end
c) whether plotted points are joined; if no, point size requested
d) whether single plots for each line to be displayed
e) indices of 3 hidden cells as a vector
f) option to plot using new vector of 3 hidden cells.
Calls: getFdata,timeDate, kbin3,kbinstrng,splt3d
Rqd Packages: <<Graphics`Graphics3D`
Mod. Date: Mar 22/97

hdrAnlz1:=
 Module[{data,extnt},
 Print["Response of 3 hidden cells to exemplars"];
 Print["Xaxis=hc[i];Yaxis=hc[j];Zaxis=hc[k]"];
 Print["User specifies 3 hidden cells as vector"];
 Print["Line[j]=exemplar[j]"];
 {data,extnt}=getFdata;
 If[0==extnt,Print["No data read"];Return[]];
 Print["Number of exemplars=",Part[Dimensions[data],2]];
 Print["Number of hidden cells=",Part[Dimensions[data],3]];
 splt3d[data,"Hidden Cell Response"];
 ]; (*end Module *)

hdrAnlz1 (*Plot of hidden cell response*)

Figure 4

hdwAnlz: 3D plot of migration of hidden cell weight (hc[i],hc[j],hc[k]) for each input cell at each epoch. Each dot is an epoch; each line is input cell; each axis is a hidden cell. The data input is from the hidden weight file written by bpnn and is of order (#epochs, #hidden cells, #input cells).
User Input:
a) See getFile; splt3d user input is:
b) whether lines to be identified at start or end
c) whether plotted points are joined; if no, point size requested
d) whether single plots for each line to be displayed
e) indices of 3 hidden cells as a vector
f) option to plot again with different hidden cells
Calls: getFdata, kbin3, kbinstrng, splt3d
Rqd Packages: <<Graphics`Graphics3d`
Mod. Date: Mar 24/97

hdwAnlz:=
 Module[{data,extnt,title},
 Print["Three Hidden Cell Weights for each Input cell"];
 Print["Xaxis=hc[i] wt; Yaxis=hc[j] wt; Zaxis=hc[k] wt"];
 Print["User specifies 3 hidden cells indices as vector"];
 Print["Line[n]=inputcell[n]"];
 {data,extnt}=getFdata;
 If[0==extnt,Print["No data read"];Return[]];
 Print["Number of hidden cells=",Part[Dimensions[data],2]];
 Print["Number of input cells=",Part[Dimensions[data],3]];
 title="Hidden Cell Weight";
 splt3d[Transpose[data,{1,3,2}],title];
 ]; (*end Module *)

hdwAnlz (*Plot of hidden cell weights*)

Figure 5

hdwAray[] (*array plot of hidden cell responses*)