Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
1992
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 1992

[Date Index] [Thread Index] [Author Index]

Search the Archive

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[] 







  • Prev by Date: NetPlot3D[]
  • Next by Date: Re: Using ListPlot3D with real x,y.z coordinates
  • Previous by thread: NetPlot3D[]
  • Next by thread: Re: MMA sounds and snd