(* This Package produces unfilled histograms, with a few options that
work much like those of built in functions such as Plot. It also
allows a convenient interface to the Legends package. *)
(* Author: Michael Ibrahim *)
(* All of the original code (there's not much of it!) in
this package is
Copyright September 1992
Michael Ibrahim
104 12th Ave. W.
Virginia, MN 55792
wasfy@gac.edu
and is free software; you can redistribute it and/or modify it under the
terms of the GNU General Public License as published by the Free
Software Foundation; either version 2, or (at your option) any later
version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRENTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to
Free Software Foundation, Inc.
675 Mass Ave
Cambridge, MA 02139
USA.
All code that does not belong to the author is commented with
references to the source. Please refer to the cited reference
for copyright information. *)
(* Version 1.01 *)
(* Revision History:
1.01: Clarification of Copyright and License Agreement *)
(* Warning: Uses the Packages: Graphics`Legend` and Utilities`FilterOptions`
*)
(* Simple Examples:
NoFillHistogram[Table[Random[],{10}]]
NoFillHistogram[Table[Evaluate[Table[Random[],{35}]+i],{i,6}],
HistoStyle->{Automatic,
GrayLevel[1/3],
{Dashing[{.01}],GrayLevel[2/3]}},
Align->{Automatic,5},
HistoLegend->{A,B,C,D,E,F}]
NoFillHistogram[{{1,3},{2,5},{4,7},{5,12}},
Presorted->True]
NoFillHistogram[Table[{{1,3},{2,6},{5,9},{4,7},{7,3}},{2}],
HistoStyle->{Automatic,Dashing[{.01}]},
Align->{0,8},
NoEntry->{Automatic,.3}]
NoFillHistogram[{{2,3},{4,5},{1,3}},Presorted->True,
PlotLabel->"Wrong! Don't do this."]
*)
(* Bugs and Potential Improvements:
The default calculation of the AxesOrigin is rather braindead.
It is easy enough to change for a particular graph but it would
be nice if it could make intelligent decisions by itself. If
the current default is truly obnoxious for your purposes try
replacing the line:
AxesOrigin->
{Min[Transpose[Flatten[newlist,1]][[1]]]-Max[widths],0}]]
with:
AxesOrigin->{Automatic,0}]]
Unless the above change is made an improper Interval
specification results in an Axes::axes error in addition to the
Histo::badopt message.
If using y only version an improper Interval specification
results in two Histo::badopt errors.
Allowing multiple lists of only y-elements can be slightly
ambiguous.
I have yet to develop a consistent naming and indenting
convention for Mathematica programming. I hope I haven't made
the code indecipherable. *)
BeginPackage["EmptyHistogram`","Utilities`FilterOptions`","Graphics`Legend`"]
(**** USAGE MESSAGES ****)
NoFillHistogram::usage = "NoFillHistogram[{{x1,y1},{x2,y2}...},opts] produces
an unfilled histogram.
NoFillHistogram[{CoordinateList1,CoordinateList2...},opts] produces multiple
histograms. NoFillHistogram[{y1,y2,y3...},opts] and
NoFillHistogram[{yList1,yList2...},opts] does the same assuming increasing x's
in steps given by the interval setting."
HistoStyle::usage = "HistoStyle is an option for NoFillHistogram that
specifies the style of the histogram lines. Lists are treated cyclically for
multiple histograms. This should work exactly like the PlotStyle option of
the Plot command."
Presorted::usage = "Presorted is an option for NoFillHistogram which specifies
whether the lists of x,y pairs have been sorted already. If Presorted->False
(the default) NoFillHistogram sorts all of the data before it uses it. If the
data is presorted (arranged by increasing x values) setting this option to
true will cause NoFillHistogram to not check the data. This can be a
considerable time saver when dealing with many data points. Note if the data
isn't presorted but this option is set to true you are guaranteed incorrect
results. Lists are treated cyclically for multiple histograms."
Interval::usage = "Interval is an option for NoFillHistogram that specifies
the width of a bar. It also specifies the step size for x coordinates when
they are not stated explicitly. If NoEntry is specified as Automatic this
option does virtually nothing. Lists are treated cyclically for multiple
histograms."
NoEntry::usage = "NoEntry is an option for NoFillHistogram that specifies the
action to occur when two consecutive x coordinates are seperated by an amount
greater than that given by the Interval option. A number specifies the y
value to assume for any coordinates that are not present (the default is 0).
Automatic causes the y coordinate of any missing entry to be the same as the y
coordinate of the previous coordinate entry. Lists are treated cyclically for
multiple histograms."
Align::usage = "Align is an option for NoFillHistogram that specifies the
position of the bar relative to the x coordinate. Automatic (the default)
implies that the bar is centered on the x location. A 0 aligns the left edge
with the x location, positive numbers displace it to the right, negative to
the left. Lists are treated cyclically for multiple histograms."
HistoLegend::usage = "HistoLegend is an option for NoFillHistogram. It should
perform exactly as the analogous PlotLegend."
Options[NoFillHistogram] =
{HistoStyle -> Automatic,
Presorted -> False,
Interval -> 1,
Align -> Automatic,
NoEntry -> 0}
Begin["`Private`"]
(**** AUXILIARY FUNCTIONS ****)
drawLines[movefunc_,list:{{_,_}..}, width_, skipfnc_]:=
Line[movefunc /@
Join[ { {list[[1,1]],0} }, (*First Point *)
Flatten[ Table[ skipfnc[list[[i]],list[[i+1]],width],(*MiddlePoints*)
{i,Length[list]-1}],
1],
With[{ last=Last[list]}, (*Last Points *)
{ last,
{ last[[1]]+width, last[[2]]},
{ last[[1]]+width, 0}}]]]
cycl[list_,index_] := RotateLeft[list, index-1][[1]]
pairsort[list:{{_,_}..}] := Sort[list,Less[Part[#1,1],Part[#2,1]]&]
listify[x_] := If[ Head[x] =!= List,{x}, x ]
makeNumNoEntry[num_] :=
With[{diff = #2[[1]]-#1[[1]]},
Which[diff < #3, (Message[Histo::badsep, #1, #2, #3];
{ #1,
{ #2[[1]], #1[[2]]}}),
diff == #3, { #1,
{ #2[[1]], #1[[2]]}},
True, (If[Mod[diff,#3] != 0, Message[Histo::badsep,#1,#2,#3]];
{ #1,
{ #1[[1]]+#3, #1[[2]]},
{ #1[[1]]+#3, num},
{ #2[[1]], num}})]]&
autoNoEntry[current_,next_,width_] :=
With[{diff = next[[1]]-current[[1]]},
If[Mod[diff,width] != 0, Message[Histo::badsep, current, next, width]];
{ current,
{ next[[1]], current[[2]]}}]
posChk[position_, width_] :=
Switch[position,
Automatic, width/2,
_?NumberQ, -position,
_,(Message[Histo::badopt, position, Align];width/2)]
srtChk[sortQ_, list_] :=
Switch[sortQ,
True, list,
False, pairsort[list],
_,(Message[Histo::badopt, sortQ, Presorted]; pairsort[list])]
ivlChk[width_] :=
Switch[width,
_?NumberQ,width,
_,(Message[Histo::badopt, width, Interval]; 1)]
noeChk[noentry_] :=
Switch[noentry,
Automatic, autoNoEntry,
_?NumberQ, makeNumNoEntry[noentry],
_,(Message[Histo::badopt, noentry, NoEntry]; makeNumNoEntry[0])]
(**** ERROR MESSAGES ****)
Histo::badopt = "`1` is an unknown specification for option `2`... continuing
with default."
Histo::badsep = "Warning: Either x seperation between coordinates `1` and `2`
is not an integer multiple of `3` as specified by the Interval option or
coordinates are out of order."
(**** EXPORTED FUNCTIONS ****)
NoFillHistogram[list:_?VectorQ, opts___Rule] :=
NoFillHistogram[{list},opts]
NoFillHistogram[lists:{_?VectorQ..},opts___Rule]:=
Module[{ i,
inter = ivlChk /@
listify[ Interval /. {opts} /. Options[NoFillHistogram] ]},
NoFillHistogram[
Transpose /@ Table[
With[{ lst = lists[[i]],
di = cycl[inter,i]},
{ Range[1,
di*Length[lst], (* max *)
di], (* step *)
lists[[i]]}],
{i,Length[lists]}],
Presorted->True,opts]] /; Or @@ (Length[#]=!=2& /@ lists)
(*
** The following two functions were taken almost verbatim from
** the standard Mathematica package "Graphics Legends" by
** John M. Novak. The code was slightly altered in order to allow
** for it to be used with the no fill histogram. (I think I fixed a
** bug that gave an unecessary graphics::gprim message sometimes too :^)
*)
NoFillHistogram[fn_List,o1___Rule, HistoLegend->None,o2___Rule] :=
NoFillHistogram[fn,o1,o2]
NoFillHistogram[fn_List,o1___Rule,HistoLegend->lg_,o2___Rule] :=
Module[{txt = lg,sopts,gopts,lopts,ps,disp,ln,gr,tb},
gopts = FilterOptions[NoFillHistogram,o1,o2];
myopts = FilterOptions[Graphics,o1,o2];
sopts = FilterOptions[ShadowBox,o1,o2];
lopts = FilterOptions[Legend,o1,o2];
{ps,disp} = {HistoStyle,DisplayFunction}/.{gopts}/.
Options[NoFillHistogram]/.Options[Graphics];
ln = If[Depth[fn] === 4, Length[fn],1];
If[Head[txt] =!= List, txt = {txt},
If[Length[txt] == 0, txt = {""}]];
While[Length[txt] < ln,txt = Join[txt,txt]];
txt = Take[txt,ln];
ps = ps /. Automatic -> {};
If[Head[ps] =!= List, ps = {ps},
If[Length[ps] == 0, ps = {{}}]];
While[Length[ps] < ln,ps = Join[ps,ps]];
ps = Take[ps,ln];
ps = ps/.Dashing[x_] -> Dashing[2/.3 x]; (* scale dashes *)
tb = Table[{Graphics[Flatten[{ps[[n]],
Line[{{0,0},{1,0}}]}]],txt[[n]]},{n,ln}];
gr = Insert[
NoFillHistogram[fn,
DisplayFunction->Identity,
Evaluate[gopts],
Evaluate[myopts]],
DisplayFunction->disp,2];
ShowLegend[gr,{tb,sopts,lopts}]]
(* end borrowed functions *)
NoFillHistogram[listolists:{{{_,_}..}..} | {{_,_}..}, opts___Rule]:=
Module[{styles, sorted, widths, moves, newlist, noentry, i},
styles = listify[ HistoStyle /. {opts} /.
Options[NoFillHistogram] /. Automatic->{} ];
sorted = listify[ Presorted /. {opts} /. Options[NoFillHistogram] ];
widths = listify[ Interval /. {opts} /. Options[NoFillHistogram] ];
moves = listify[ Align /. {opts} /. Options[NoFillHistogram] ];
noentry = listify[ NoEntry /. {opts} /. Options[NoFillHistogram] ];
newlist = If[ Depth[listolists] == 4,
listolists, (* then *)
{listolists}];(* else *)
If[Length[styles] == 0,styles = {styles}]; (* Improve *)
Show[
Table[
Graphics[
Flatten[
With[{ list = srtChk[ cycl[sorted,i], newlist[[i]] ],
width = ivlChk[ cycl[widths,i] ],
skipfnc = noeChk[ cycl[noentry,i] ],
style = cycl[styles,i],(* Graphics::gprim already checks *)
move = cycl[moves,i]},(* check implemented below *)
Flatten[{ style,
drawLines[{#[[1]]-posChk[move,width],#[[2]]}&,
list,
width,
skipfnc]},
1]],
1]],
{i,Length[newlist]}],
FilterOptions[Graphics,opts],
Axes->Automatic,
AxesOrigin->{Min[Transpose[Flatten[newlist,1]][[1]]]-Max[widths],0}]]
End[]
Protect[ NoFillHistogram ]
EndPackage[]