(* :Title: Multiple List Plot *)

(* :Context: Graphics`MultipleListPlot`*)

(* :Author: John M. Novak, based on a package by
			Cameron Smith *)

(* :Summary:
This package contains a function for plotting multiple sets
of data in a graph and related utilities.
*)

(* :Copyright: Copyright 1989-1999, Wolfram Research, Inc. *)

(* :Package Version: 2.1 *)

(* :Mathematica Version: 3.0 *)

(* :History:
	V2.0 April 1993 by John M. Novak (unreleased)
	V2.1 March 1994 by John M. Novak. Adds many new features, such as
		error bars, labeled points, and legends.
*)

(* :Keywords:
	data plots, plot symbols
*)

(* :Sources:
	
*)

(* :Discussion:
	
*)

BeginPackage["Graphics`MultipleListPlot`",
		     "Utilities`FilterOptions`",
		     "Graphics`Legend`",
		     "Graphics`Common`GraphicsCommon`"]

MultipleListPlot::usage =
"MultipleListPlot[data, (opts)] plots the data, using symbols
determined by the options. MultipleListPlot[data1, data2,...]
plots multiple sets of data. Data are either a list of numbers
(whose x coordinates are implicitly the positions in the list),
or a list of {x, y} coordinate pairs. Each data point can be accompanied
by an error, indicated by an ErrorBar object giving the error
as positive and negative offsets (see ErrorBar for more information). ";

ErrorBarFunction::usage =
"ErrorBarFunction is an option for MultipleListPlot that allows the
user to specify the shape of an error bar. ErrorBarFunction -> Automatic
generates default error bars. ErrorBarFunction may also be set to a function
of two arguments, where the first is the point around which the error bars are
drawn, and the second is an ErrorBar object indicating the x and y error.
(See ErrorBar for more information).";

SymbolLabel::usage =
"SymbolLabel is an option for MultipleListPlot, specifying a textual label
for each dot in MultipleListPlot. SymbolLabel -> None implies that no
label is drawn. If SymbolLabel -> Automatic, each point is labelled
(n,m), where n is the data set and m is the point in the data set.
Otherwise, the label is wrapped in a Text primitive and drawn at the point.
A label can be specified for each point. Labels are cycled if not
specified for every point.";

SymbolShape::usage =
"SymbolShape is an option for MultipleListPlot that specifies a list
of functions that determine the shapes of the symbols representing
each of the sets of data given to MultipleListPlot. Each function should
accept one argument, the position of the symbol to be drawn.
As a special case, SymbolShape -> None indicates that no symbol should be
drawn, or SymbolShape -> Label indicates that the text label should be drawn
instead of the symbol.";

SymbolStyle::usage =
"SymbolStyle is an option for MultipleListPlot. It is a list of
styles for the symbols drawn for each data set. SymbolStyle -> Automatic
specifies that each symbol will be black with thin lines.";

Label::usage =
"Label is a value for the SymbolShape option for MultipleListPlot. It
specifies that a label given by the SymbolLabel option should be used
in place of a dot shape.";

ErrorBar::usage =
"ErrorBar[{negerror, poserror}] is used in a data argument for
MultipleListPlot to represent error in a data point. The syntax is
generally {pt, ErrorBar[err]}. The error is expressed as a change in
the value at the point. Error in both independent and dependent variable
can be given, as in ErrorBar[xerr, yerr], where xerr and yerr each is
expressed as {negerror, poserror}.";

PlotSymbol::usage =
"PlotSymbol[type] evaluates to a function that generates a graphic
symbol of the particular type for use as a plot symbol in MultipleListPlot.
Valid types include Star, Diamond, and Box. PlotSymbol[type, radius]
resizes the shape to approximately the given radius. PlotSymbol can
also take an option Filled -> False, which will only outline the
symbol in question.";

Filled::usage =
"Filled is an option for PlotSymbol indicating whether the symbol should
be drawn as a polygon (if True) or a line (if False).";

MakeSymbol::usage =
"MakeSymbol[gprims] takes the shape expressed by the graphic
primitives and turns it into a function that creates a shape
in Offset coordinates about a user specified point. This can be
used for generating plot symbols in MultipleListPlot.";

Star::usage =
"Star is a kind of PlotSymbol for use with MultipleListPlot. It
represents a five-pointed star.";

Diamond::usage =
"Diamond is a kind of PlotSymbol for use with MultipleListPlot. It
represents a narrow upright diamond shape.";

Box::usage =
"Box is a kind of PlotSymbol for use with MultipleListPlot. It
represents a square box shape.";

Triangle::usage =
"Triangle is a kind of PlotSymbol for use with MultipleListPlot. It
represents an equilateral triangle shape.";

If[Head[Dashing::usage] === String,
   Dashing::usage = Dashing::usage <>
      " Dashing[{shape1, shape2, ...}] represents a dashing pattern
      of dots and dashes. Valid shapes include Dot, Dash, and LongDash.
      The shapes are automatically spaced."
];

If[Head[AbsoluteDashing::usage] === String,
   AbsoluteDashing::usage = AbsoluteDashing::usage <>
      " AbsoluteDashing[{shape1, shape2, ...}] represents a dashing pattern
      of dots and dashes. Valid shapes include Dot, Dash, and LongDash.
      The shapes are automatically spaced."
];

If[Head[Dot::usage] === String,
   Dot::usage = Dot::usage <>
       " Dot can also be used as a tag for a dot in a Dashing or
       AbsoluteDashing specification."
];

Dash::usage =
"Dash is a tag for a dash in a Dashing or AbsoluteDashing specification.";

LongDash::usage =
"LongDash is a tag for a long dash in a Dashing or AbsoluteDashing
specification.";

(* This version of RegularPolygon is by Cameron Smith *)

RegularPolygon::usage=
"RegularPolygon[n, rad, ctr, tilt, skip] creates a regular polygon of n sides
and radius rad, centered at the point ctr (represented as a list of
two real numbers), tilted counterclockwise from vertical by angle
theta, and with every skip-th vertex connected.  Defaults are
rad=1, ctr={0,0}, tilt=0, skip=1."

(* Offset compatibility *)

If[ $VersionNumber < 3.0,
    Offset::usage = "Offset is an absolute scaled position introduced
in Mathematica Version 3.0. For compatibility, it is defined here as
Offset[a,b] --> Scaled[a/100, b]."
];

(* Backwards compatibility *)

DotShapes::usage =
"DotShapes is obsolete. Use SymbolShape instead.";

LineStyles::usage =
"LineStyles is obsolete. Use PlotStyle instead.";

$DotShapes::usage =
"$DotShapes is obsolete. Use
SetOptions[MultipleListPlot, SymbolShape -> shapes] instead."

$LineStyles::usage =
"$LineStyles is obsolete. Use
SetOptions[MultipleListPlot, PlotStyle -> styles] instead."

Begin["`Private`"]

(* offset compatibility completed *)
If[ $VersionNumber < 3.0,
    Offset[ a_, b_] := Scaled[ a/100, b]
]

(* internal globals -- a default style *)
$$defaultstyle = {GrayLevel[0], Dashing[{}],
                Thickness[.0001], PointSize[.01]};

$$defaultshapes :=
   {PlotSymbol[Diamond], PlotSymbol[Star], PlotSymbol[Box],
    PlotSymbol[Triangle], Point};

$$defaultlinestyles :=
   {GrayLevel[0], AbsoluteDashing[Dot], AbsoluteDashing[Dot, Dash],
    AbsoluteDashing[Dash], AbsoluteDashing[Dot, Dash, Dot]};

(* another NumberQ -- should eventually migrate to NumericQ *)

numberQ[n_] := NumberQ[N[n]]

(* The following is a useful internal utility function to be
used when you have a list of values that need to be cycled to
some length (as PlotStyle works in assigning styles to lines
in a plot).  The list is the list of values to be cycled, the
integer is the number of elements you want in the final list. *)

cycleValues[{},_] := {}

cycleValues[list_List, n_Integer] :=
	Module[{hold = list},
		While[Length[hold] < n,hold = Join[hold,hold]];
		Take[hold,n]
	]

cycleValues[item_,n_] := cycleValues[{item},n]

(* default error bar function *)
ebarfun[pt:{x_, y_},
        ErrorBar[{xmin_, xmax_}, {ymin_, ymax_}]
       ] :=
 Module[{xline, yline},
 	If[xmin === 0 && xmax === 0, xline = {},
 		xline = {Line[{{x + xmax, y}, {x + xmin, y}}],
				Line[{Offset[{0,1.5}, {x + xmax, y}],
					Offset[{0,-1.5}, {x + xmax, y}]}],
				Line[{Offset[{0,1.5}, {x + xmin, y}],
					Offset[{0,-1.5}, {x + xmin, y}]}]}
	];
	If[ymin === 0 && ymax === 0, yline = {},
		yline = {Line[{{x, y + ymax}, {x, y + ymin}}],
				Line[{Offset[{1.5,0}, {x, y + ymax}],
					Offset[{-1.5,0}, {x, y + ymax}]}],
				Line[{Offset[{1.5,0}, {x, y + ymin}],
					Offset[{-1.5,0}, {x, y + ymin}]}]}
	];
	Join[xline, yline]
 ]


(* data enters in normalized format: data in list of
	x-y pairs *)

handleset[data_, iebfun_, shape_, symsty_, join_, style_, labels_] :=
	Module[{len = Length[data], ebf, pts = First[Transpose[data]],
	        barprims, symbolprims, lineprims},
	  (* set up error bar function and error bars *)
		If[iebfun === Automatic,
			ebf = ebarfun,
			ebf = iebfun
	    ];
	    If[ebf === None,
	        barprims = {},
	        barprims = Apply[ebf, data, {1}]
	    ];
	  (* build line and shapes, combine with bars in proper order *)
        {doline[join, style, pts], barprims,
		      doshape[symsty, shape, labels, pts]}
	]

(* build the line based on data and options *)
doline[True, Automatic, data_] := doline[True, {}, data]

doline[True, sty_, data_] := Flatten[{sty, Line[data]}]

doline[___] := {}

(* build the shapes based on data and options *)
doshape[_, None, _, _] := {}

doshape[Automatic | None, shp_, lbl_, dat_] :=
     doshape[{}, shp, lbl, dat]

doshape[sty_, shp_, None, dat_] :=
    Join[Flatten[{$$defaultstyle, sty}], Map[shp, dat]]

doshape[sty_, shp_, lbl_, dat_] :=
    Join[Flatten[{$$defaultstyle, sty}],
         MapThread[dopoint[#1, shp, #2]&, {dat, lbl}]
    ]

(* build individual points when labels are specified per point *)
dopoint[pt_, Label, None] := {}

dopoint[pt_, Label, label_] :=
	Text[label, pt]

dopoint[pt_, fun_, None] :=
	fun[pt]

dopoint[pt_, fun_, label_] :=
	{fun[pt], Text[label, pt, {-1.5,-1.7}]}

(* normalize the labels *)

normalizelabels[None, _, _] := None

normalizelabels[Automatic, num_, tot_] :=
	Map[ToString[#[[1]]]<>"-"<>ToString[#[[2]]] &,
		Map[{num, #}&, Range[tot]]
	]

normalizelabels[labs:(_List | _String), _, tot_] :=
	cycleValues[labs, tot]

normalizelabels[fun_, num_, tot_] :=
    Apply[fun, Map[{num, #}&, Range[tot]], {1}]

(* validErrorQ - test that the error bar is valid *)
validErrorQ[
        ErrorBar[{ymin_?numberQ, ymax_?numberQ}/;ymin <= 0 <= ymax]
   ] := True

validErrorQ[
        ErrorBar[{xmin_?numberQ, xmax_?numberQ}/;xmin <= 0 <= xmax,
                 {ymin_?numberQ, ymax_?numberQ}/;ymin <= 0 <= ymax]
     ] := True

validErrorQ[_] := False

(* fixpoints - put all the points into a canonical form *)

MultipleListPlot::badpt =
"`1` is not a valid specification for a point in MultipleListPlot. It
should be a number, a pair of numbers, or the same with an error
specification given as an Interval around zero.";

fixpoints[n_?numberQ, pos_] :=
    { {pos, n}, ErrorBar[{0,0}, {0,0}] }

fixpoints[{n_?numberQ, err_ErrorBar}, pos_] :=
    fixpoints[{{pos, n}, err}]

fixpoints[pt:{_?numberQ, _?numberQ}, _] :=
    {pt, ErrorBar[{0,0}, {0,0}] }

fixpoints[{pt:{_?numberQ, _?numberQ}}, _] :=
    {pt, ErrorBar[{0,0}, {0,0}] }

fixpoints[{pt:{_?numberQ, _?numberQ},
           err_ErrorBar}, pos_] :=
    fixpoints[{pt, err}]

fixpoints[ErrorBar[{ymin_?numberQ, ymax_?numberQ}/;ymin <= ymax],
          pos_] :=
    Block[{middle = (ymax - ymin)/2},
        { {pos, ymin + middle}, ErrorBar[{0,0}, {-middle, middle}] }
    ]

fixpoints[ErrorBar[{xmin_?numberQ, xmax_?numberQ}/;xmin <= xmax,
                   {ymin_?numberQ, ymax_?numberQ}/;ymin <= ymax],
          _] :=
    Block[{xmid = (xmax - xmin)/2, ymid = (ymax - ymin)/2},
        { {xmin + xmid, ymin + ymid},
          ErrorBar[{-xmid, xmid}, {-ymid, ymid}] }
     ]

fixpoints[{ept_ErrorBar, _}, pos_] :=
    fixpoints[ept, pos]

fixpoints[{pt_, ErrorBar[yerr_]?validErrorQ}] :=
    {pt, ErrorBar[{0,0}, yerr]}

fixpoints[{pt_, err:ErrorBar[_, _]?validErrorQ}] :=
    {pt, err}

fixpoints[pt_, _] := Message[MultipleListPlot::badpt, pt]

fixpoints[pt_] := Message[MultipleListPlot::badpt, pt]

(* ErrorBar single value expansion - a cheesy way to deal with the
   possibility of the user entering a single value instead of a range
   for an error bar. *)

ErrorBar[yerr_?numberQ] := ErrorBar[{-yerr, yerr}]

ErrorBar[xerr_?numberQ, yerr_] := ErrorBar[{-xerr, xerr}, yerr]

ErrorBar[xerr_, yerr_?numberQ] := ErrorBar[xerr, {-yerr, yerr}]

(* MultipleListPlot: main routine *)

MultipleListPlot::badargs =
"MultipleListPlot has been given bad arguments. Input should be data sets
consisting of points or points with ErrorBar specifications.";

Options[MultipleListPlot] :=
	Join[Options[ListPlot],
	{ErrorBarFunction -> Automatic,
	 SymbolLabel -> None,
	 SymbolShape -> Automatic,
	 SymbolStyle -> Automatic,
	 PlotLegend -> Automatic},
	 Options[Legend]
	 ];

SetOptions[MultipleListPlot,
    LegendShadow -> {0,0}, LegendPosition -> Automatic];

MultipleListPlot[{data__List?(Length[#] > 3 &)}, opts___?OptionQ] :=
   MultipleListPlot[data, opts]

MultipleListPlot[idata__List, opts___?OptionQ] :=
	Module[{data, ebfuns, labels, shapes, symstys, joins, style,
			numsets = Length[{idata}], pl, lsize, lpos, dispfun,
			lorient, scalefact},
	  (* get the option values *)
		{ebfuns, labels, shapes, symstys, joins, style, pl, lsize, lpos,
		        lorient, dispfun} =
			{ErrorBarFunction, SymbolLabel, SymbolShape, SymbolStyle,
			PlotJoined, PlotStyle, PlotLegend, LegendSize, LegendPosition,
			LegendOrientation, DisplayFunction}/.
			Flatten[{opts}]/.Options[MultipleListPlot];
	  (* normalize the form of the data.The normalizing function
	        returns Null for bad points, so pull the Nulls. *)
		data = MapIndexed[fixpoints[#1, Last[#2]]&, {idata}, {2}];
		data = Map[Select[#, # =!= Null &]&, data];
	  (* grab some defaults *)
	    If[shapes === Automatic, shapes = $$defaultshapes];
	    If[style === Automatic, style = $$defaultlinestyles];
	  (* options that are one per data set need to be normalized
	         to the right number *)
		{ebfuns, shapes, symstys, joins, style, labels} =
		    Map[cycleValues[#, numsets]&,
		        {ebfuns, shapes, symstys, joins, style, labels}];
      (* when labels are not None, they can be one per data point;
              set them as such *)
		labels = MapThread[normalizelabels, {labels,
							Range[numsets],
							Map[Length, data]}
				];
	  (* the graphic *)
	    gr = Graphics[{Thickness[.001],
			    MapThread[handleset,
				    {data, ebfuns, shapes, symstys, joins, style, labels}
			    ]
			  },
			  FilterOptions[Graphics, ##]& @@
			      Flatten[{opts, Options[MultipleListPlot]}]
	    ];
	  (* set up for legends *)
	    If[Head[pl] =!= List,
	       Show[gr],
	      (* else *)
	        (* first determine size of legend; default of .8 matches
	           V2.2 behavior *)
	       If[!MatchQ[lsize, {_?numberQ, _?numberQ} | _?numberQ],
	           lsize = .8];
	       If[Head[lsize] === List, 
	          If[lorient === Horizontal,
	              lsize = Last[lsize],
	              lsize = First[lsize]
	          ]
	        ];
	         (* determine the scaling factor for scaled coordinates
	            in a legend box; this is a magic number *)
	       scalefact = (numsets/lsize) * 1.87;
	         (* generate the legend and display with the graphic *)
	       ShowLegend[gr,
	           {Transpose[{
	               MapThread[legendbox[scalefact, ##]&,
	                    {symstys, shapes, labels, joins, style}],
	               cycleValues[pl, numsets]
	            }], FilterOptions[Legend, ##] & @@
	                 Flatten[{
	                   If[lpos === Automatic,
	                      LegendPosition ->
	                          If[lorient === Horizontal,
	                              {-lsize/2, -1.0},
	                              {1.1, -lsize/2}
	                           ],
	                      LegendPosition -> lpos
	                   ],
	                   opts,
	                   Options[MultipleListPlot]}]},
	           DisplayFunction -> dispfun
	       ]
	   ]
	]

MultipleListPlot[___] :=
  badinput/;Message[MultipleListPlot::badargs]

legendbox[scalefact_, symsty_, shape_, label_, join_, sty_] :=
    Graphics[{Thickness[.001],doline[join, sty, {{-1, 0}, {1, 0}}],
     doshape[symsty, shape,
         If[Head[label] === List,
             {First[label]},
             label
         ], {{0,0}}]},
    PlotRange -> {{-1,1},{-1,1}}, AspectRatio -> 1]/.
       {Thickness[x_] :> Thickness[scalefact x],
        PointSize[x_] :> PointSize[scalefact x],
        Dashing[x_] :> Dashing[scalefact x],
        Scaled[off_, pt_] :> Scaled[scalefact off, pt]}

(* Plot Symbols *)
PlotSymbol::unknown =
"`` is an unknown type for PlotSymbol."

Options[PlotSymbol] = {Filled -> True};

PlotSymbol[type_Symbol, size:(_Integer | _Real):2.5, opts___?OptionQ] :=
    If[TrueQ[Filled/.Flatten[{opts}]/.Options[PlotSymbol]],
        MakeSymbol[symb[type, size]/.Line -> Polygon],
        MakeSymbol[symb[type, size]]
    ]

symb[Diamond, size_] :=
    Line[size {{-.75, 0}, {0,1}, {.75, 0}, {0,-1}, {-.75, 0}}]

symb[Box, size_] :=
    Line[size {{-1, 1}, {1, 1}, {1, -1}, {-1, -1}, {-1, 1}}]

symb[Star, size_] :=
    Line[size {{0, 1.}, {-0.226071, 0.31116},
       {-0.951057, 0.309017}, {-0.365791, -0.118853},
       {-0.587785, -0.809017}, {0, -0.384615}, 
       {0.587785, -0.809017}, {0.365791, -0.118853},
       {0.951057, 0.309017}, {0.226071, 0.31116}, {0, 1.}}]

symb[Triangle, size_] :=
    Line[size {{0, 1}, {-.866, -.5}, {.866, -.5}, {0,1}}]

symb[type_, _] :=
   (Message[PlotSymbol::unknown, type]; {})

(* MakeSymbol *)
Attributes[MakeSymbol] = {HoldAll};

MakeSymbol[expr_] :=
   With[{fexpr = tofun[expr]},
       Function[fexpr]/.{fixpt[p_List] :> Offset[p, #],
           fixpt[Offset[o_, p_]] :> Offset[o, p + #],
           fixpt[Scaled[s_, p_]] :> Scaled[s, p + #]}
   ]

tofun[e_List] := Map[tofun, e]

tofun[Line[e_List]] := Line[Map[fixpt, e]]

tofun[Polygon[e_List]] := Polygon[Map[fixpt, e]]

tofun[Text[t_, pt_, rest___]] := Text[t, fixpt[pt], rest]

tofun[Circle[pt_, rest___]] := Circle[fixpt[pt], rest]

tofun[Disk[pt_, rest___]] := Disk[fixpt[pt], rest]

tofun[Point[pt_]] := Point[fixpt[pt]]

tofun[Rectangle[minpt_, maxpt_]] := Rectangle[fixpt[minpt], fixpt[maxpt]]

tofun[e_] := e

(* brief form for Dashing specification *)

Unprotect[Dashing, AbsoluteDashing];

Dashing[seq:((Dot | Dash | LongDash)..)] :=
    Dashing[{seq}]

Dashing[dashlist:{(Dot | Dash | LongDash)..}] :=
    Dashing[filloutdashes[dashlist, 0.015, 0.02, 0.03]/.
        {Dot -> 0.003, Dash -> 0.04, LongDash -> 0.09}
    ]

AbsoluteDashing[seq:((Dot | Dash | LongDash)..)] :=
    AbsoluteDashing[{seq}]

AbsoluteDashing[dashlist:{(Dot | Dash | LongDash)..}] :=
    AbsoluteDashing[filloutdashes[dashlist, 2, 3, 4]/.
        {Dot -> 0.5, Dash -> 5, LongDash -> 10}
    ]

Protect[Dashing, AbsoluteDashing];

filloutdashes[l_List, sspace_, mspace_, lspace_] :=
    l//.{{a___, Dot,Dot, b___} :> {a, Dot, mspace, Dot, b},
         {a___, Dot, d:(Dash | LongDash), b___} :>
                                 {a, Dot, lspace, d, b},
         {a___, d:(Dash | LongDash), Dot, b___} :>
                                 {a, d, lspace, Dot, b},
         {a___, d1:(Dash | LongDash), d2:(Dash | LongDash), b___} :>
                                 {a, d1, sspace, d2, b},
         {Dot, a___, Dot} :> {Dot, a, Dot, mspace},
         {d:(Dash | LongDash), a___, Dot} :> {d, a, Dot, lspace},
         {Dot, a___, d:(Dash | LongDash)} :> {Dot, a, d, lspace},
         {d1:(Dash | LongDash), a___, d2:(Dash | LongDash)} :>
                                     {d1, a, d2, sspace},
         {Dot} -> {Dot, mspace},
         {d:(Dash | LongDash)} :> {d, sspace}}

(* RegularPolygon - drawn directly from the V2.2 package.
   Attributed to Cameron Smith. *)

RegularPolygon[n_Integer?((#>1)&), rad_:1, ctr_:{0,0}, tilt_:0, skip_:1] :=
     Line[
           Block[
                  { w = 2Pi/n,
                    w1 = I N[ rad (Cos[tilt] + I Sin[tilt]) ],
                    y = {}
                  },
                  w = N[ Cos[w] + I Sin[w] ]^skip;
                  Do[
                      y = Append[ y, ctr + {Re[w1],Im[w1]} ];
                      w1 = w1 w,
                      {n}
                    ];
                  Append[ y, y[[1]] ]
                ]
         ]

(* Backwards compatibility code *)
LineStyles = PlotStyle;
DotStyles = SymbolShape;

$LineStyles/: Set[$LineStyles, setto_] :=
   (SetOptions[MultipleListPlot, PlotStyle -> setto]; setto)

$DotStyles/: Set[$DotStyles, setto_] :=
   (SetOptions[MultipleListPlot, SymbolShape -> setto]; setto)
   
End[]

EndPackage[]
