NoFillHistogram Package
- To: mathgroup at yoda.physics.unc.edu
- Subject: NoFillHistogram Package
- From: wasfy at nic.gac.edu (Michael Wasfy Nicolas Ibrahim)
- Date: Mon, 14 Sep 92 12:26:30 CDT
Hello,
I couldn't find any way to produce this type of
histogram in Mathematica so I put together this
package. Enough people used it to make me think
it might be worth cleaning up (it's still a mess)
and distributing. I added a few options and put
*a lot* of documentation in...so here it is. I
realize that a few things are screwy so comments
are welcome. I hope someone finds this useful.
Michael Ibrahim
P.S.: If anyone knows if there is an "official name" for
this type of plot (it may be obvious that I made the name
up) fell free to let me know.
===================cut here======================
(* 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 at nic.gac.edu
and is distributed under the terms of the GNU General Public
License, which is too long to include here. If you are unfamiliar
with the GNU License contact the author to receive more
information.
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.0 *)
(* 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 ****)
EmptyHistogram::usage = "Histogram is a package that defines the
NoFillHistogram function and its options."
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[]