Visualization for Fun and Profit

Bringing New Life to Everyday Facts

Brett Champion
Yu-Sung Chang

Wolfram Research, Inc.

From Data to Dynamic Graphics

Gathering Data with No Problem

Import real world data: Hundreds of scientific and industrial formats, ready to be served.

Directly from curated data: Scientific, financial and cultural data with few keystrokes.

Synthetic data: From formulas, random distribution, etc...

Processing Data with Minimum Effort

Understand and filter the data.

Find relations within/among the data.

Apply appropriate processes.

Visualizing Data for Maximum Effect (and Profit...)

Choose an effective format: To maximize the understanding, to reveal the relations.

Visualize the ideas: Usage of clever graphics, animations, colors, and effects.

???

Profit!

Visualization of 3D Scanned Data

Import the Geometry File (from NextEngine 3D Desktop Scanner)

vraw=Import[ToFileName[{NotebookDirectory[],"Data"},"yusung_quick.ply"],{"PLY","VertexData"}];

craw=Import[ToFileName[{NotebookDirectory[],"Data"},"yusung_quick.ply"],{"PLY","VertexColors"}];

Simple Visualization of the Data

ListPointPlot3D[vraw,PlotStyle->Directive[PointSize[Tiny],Opacity[.5]],BoxRatios->Automatic,PlotRange->All]

ListPlot3D[vraw[[;;;;5]],Mesh->None,PlotRange->Automatic,PlotStyle->Directive[Orange,Specularity[White,50]],BoxRatios->Automatic]

Have Some Fun with the Data

Vertex colors

ListPlot3D[vraw[[;;;;5]],Mesh->None,PlotRange->Automatic,BoxRatios->Automatic,VertexColors->{craw[[;;;;5]]},Lighting->"Neutral"]

Do some wicked things...

ListPlot3D[vraw[[;;;;5]],Mesh->None,PlotRange->Automatic,BoxRatios->Automatic,ColorFunction->"Rainbow"]

ListPlot3D[vraw[[;;;;5]],MeshFunctions->{#3&},PlotRange->Automatic,BoxRatios->Automatic,ColorFunction->"Rainbow"]

ListPlot3D[vraw[[;;;;20]],Mesh->None,PlotRange->Automatic,BoxRatios->Automatic,ColorFunction->"Rainbow",InterpolationOrder->0,Method->{"UnboundedPolygons"->False}]

ListPlot3D[vraw[[;;;;5]],MeshFunctions->

Clear[vraw,craw]

Visualization of GIS Data

ArrayPlot vs. ReliefPlot

helens=Import[ToFileName[{NotebookDirectory[],"Data"},"helens.txt"],"Table"][[50;;-50,50;;-50]];

ArrayPlot[helens,DataReversed->True]

ReliefPlot[helens]

Import USGS DEM Data

gce=Import[ToFileName[{NotebookDirectory[],"Data"},"grand_canyon-e"],"Data"];

gcw=Import[ToFileName[{NotebookDirectory[],"Data"},"grand_canyon-w"],"Data"];

gc=Developer`ToPackedArray@MapThread[Join[#1,#2]&,{gcw,gce}];

ReliefPlot[gc,MaxPlotPoints->800,ImageSize->800,ColorFunction->"SiennaTones"]

Different Ways for Visualization

Show[
ReliefPlot[helens,ColorFunction->"SunsetColors",DataRange->{{0,80},{0,120}}],ListContourPlot[helens[[;;;;5,;;;;5]],ContourShading->None,ContourStyle->LightBlue]
]

ListPlot3D[helens[[;;;;5,;;;;5]],MaxPlotPoints->Infinity,Mesh->None,ColorFunction->"SunsetColors",BoxRatios->{2,3,1}]

NotebookOpen[ToFileName[NotebookDirectory[],"ReliefShadedElevationMap.nb"]]

A Big World Relief Map (GTOPO30)

Show[Import[ToFileName[{NotebookDirectory[],"Data"},"globe.png"]],ImageSize->800]

Visualization of Financial Data

Simple Elegance

DateListPlot[FinancialData["GOOG",{2007}]]

A Bit of Spice

Code

StockPlot[sl_List,{period__},args___]:=DateListPlot[FinancialData[#,{period}]&/@sl,Joined->True,PlotMarkers->Automatic,PlotRange->{All,{0,All}},Epilog->Inset[Panel[Grid[MapIndexed[{Style[{●,■,◆}[[First@#2]],ColorData[1,First@#2]],FinancialData[#1,"Name"]}&,sl]]],Offset[{-2,2},Scaled[{1,.3}]],{Right,Bottom}],args];

Example

StockPlot[{"F","GM","HMC"},{2007,9}]

Interactive Plot

Code

npack[x_]:=Developer`ToPackedArray@N@x;
toAbs[pos_]:={AbsoluteTime[First@pos],Last@pos};
toDate[pos_]:=DateString[First@pos,{"Year","/","Month","/","Day"}];
financeColor[n_Integer]:=Hue[First@ToColor[ColorData[1,n],Hue],.9,.9];
close[symbol_,period_]:=toAbs/@FinancialData[symbol,"Close",period];
low[symbol_,period_]:=toAbs/@FinancialData[symbol,"Low",period];
high[symbol_,period_]:=toAbs/@FinancialData[symbol,"High",period];
frac[symbol_,period_]:=toAbs/@FinancialData[symbol,"FractionalChange",period];
rangeminmax=Compile[{{lst,_Real,3},{s,_Real},{e,_Real}},Module[{min=900000.,max=-1000.},
Do[If[(lst[[i,j,1]]≥s)&&(lst[[i,j,1]]≤e),
If[lst[[i,j,2]]>max,max=lst[[i,j,2]],
If[lst[[i,j,2]]<min,min=lst[[i,j,2]]]]],
{i,Length[lst]},{j,Length[lst[[i]]]}];
{min,max}]];

dateRangeSlider[range_,{sd_,ed_},label_,background_]:=
Deploy@DynamicModule[{s=AbsoluteTime[sd],e=AbsoluteTime[ed],p1,p2,pos,pflag=True},
Show[
background,
Graphics[{
FaceForm[Opacity[.5,LightGray]],EdgeForm[None],
Rectangle[{s,0},Scaled[{0,1},p1]],
Rectangle[{e,0},Scaled[{0,1},p2]],
FaceForm[Opacity[0,White]],EdgeForm[Opacity[.3,Black]],
Rectangle[Scaled[{0,0},p1],Scaled[{0,1},p2]],
Locator[Dynamic[pos,(With[{d=.5(p2-p1)},pos={Max[Min[First@#,e-d],s+d],0};p1=pos-d;p2=pos+d];range=First/@{p1,p2})&],ImageSize->Small],
Tooltip[Locator[Dynamic[p1,(p1={Min[Clip[First@#,{s,e}],First@p2-604800],0};range=First/@{p1,p2};pos={.5Plus@@range,0})&],ImageSize->Small],Dynamic@toDate[p1]],
Tooltip[Locator[Dynamic[p2,(p2={Max[Clip[First@#,{s,e}],First@p1+604800],0};range=First/@{p1,p2};pos={.5Plus@@range,0})&],ImageSize->Small],Dynamic@toDate[p2]]
}],
PlotRange->{{s,e},All},PlotRangeClipping->False,PlotRangePadding->{Scaled[.02],None}],

Initialization:>(p1={First@range,0};p2={Last@range,0};pos={.5Plus@@range,0})
];
SetAttributes[dateRangeSlider,HoldFirst];

dateFrameTicks[{sd_,ed_}]:={
{Automatic,None},
{With[{d=Abs[DateDifference[sd,ed]]},
Join[
Table[{AbsoluteTime[{i,1,1}],ToString@i,{.01,0}},{i,First@DateList[sd],First@DateList[ed]}],
Flatten[Table[{AbsoluteTime[{i,j,1}],
If[((d<547)&&(Mod[j,3]==1))||(d<365),
DateString[{i,j},"MonthNameShort"],""],{.005,0}},
{i,First@DateList[sd],First@DateList[ed]},{j,2,12}],1] ]
],
None}
};

dateGridLines[{sd_,ed_}]:=
{With[{d=Abs[DateDifference[sd,ed]]},
Join[
Table[{AbsoluteTime[{i,1,1}],Opacity[.5]},{i,First@DateList[sd],First@DateList[ed]}],
Flatten[Table[{AbsoluteTime[{i,j,1}],Directive[AbsoluteDashing[{.4,.4}],Opacity[.4]]},{i,First@DateList[sd],First@DateList[ed]},{j,If[d<365,2,4],12,If[d<365,1,3]}],1]]
],
Automatic};

FinancialDataExplorer[symbols_,startd_,endd_,opts___]:=
Deploy@Module[{names,cl,l,h,nf,lines,bgplot,range,is=600},

Manipulate[

Column[{
Graphics[lines,
Frame->True,FrameTicks->Dynamic@dateFrameTicks[range],
GridLines->Dynamic@dateGridLines[range],GridLinesStyle->Opacity[.3],
PlotRange->Dynamic@{range,rangeminmax[cl,N@First@range,N@Last@range]},
PlotRangeClipping->True,PlotRangePadding->Scaled[.02],
AspectRatio->1/GoldenRatio,ImageSize->is,ImagePadding->{{40,20},{20,1}}],

dateRangeSlider[range,{startd,endd},"Time Line",bgplot]
},Alignment->Center],

Style["Finance Data Explorer",Medium],

Initialization:>(
With[{p={startd,endd}},
names=FinancialData[#,"Name"]&/@symbols;
cl=npack[close[#,p]&/@symbols];
l=npack[low[#,p]&/@symbols];
h=npack[high[#,p]&/@symbols];
];

nf=Table[Nearest[cl[[i,All]]],{i,Length[symbols]}];

lines=MapThread[
{financeColor[#6],AbsolutePointSize[2],
Line[#1],
Mouseover[
Point[#1],
{Point[#1],
Opacity[.3],Polygon[Join[#2,Reverse@#3]],
Dynamic@With[{mp=First@#4[MousePosition["Graphics"]]},{
Opacity[1],PointSize[Medium],
Point[mp],
Inset[Panel@Column[{
#5,
Dynamic@toDate[mp],
Row[{"Close: ",Dynamic[First@Cases[#1,{First@mp,x_}:>x]]}],
Row[{"Low: ",Dynamic[First@Cases[#2,{First@mp,x_}:>x]]}],
Row[{"High: ",Dynamic[First@Cases[#3,{First@mp,x_}:>x]]}]
}],Scaled[{.98,.98}],Scaled[{1,1}]],
AbsoluteThickness[1],Dashed,
Line[{mp,{First@mp,0}}],
Line[{mp,{0,Last@mp}}]
}]
}]
}&,{cl,l,h,nf,names,Range[Length[symbols]]}];

bgplot=DateListPlot[cl,
AspectRatio->.1,ImageSize->600,Joined->True,
FrameTicks->{{None,None},{Automatic,None}},ImagePadding->{{40,20},{20,1}}];

range={Max[AbsoluteTime@startd,AbsoluteTime@endd-15768000],AbsoluteTime@endd};
),
SynchronousInitialization->False,
TrackedSymbols->{}
]
]

Example

FinancialDataExplorer[{"CSCO","MSFT","NOK"},{2005,1},{2007,10}]

Visualization of Country Data

Simple Examples

Gathering the data

data=Cases[CountryData[#,"Population"]&/@CountryData[],Except[Missing[_]]];

Quite chaotic...

ListLogPlot[data]

A bit better...

ListLogPlot[Sort[data],Joined->True]

Graphics[{EdgeForm[{Black,Opacity[.5]}],With[{p=CountryData[#,"Population"]},
{If[NumberQ[p],ColorData["SolarColors"][1.-p 10^-9],White],
Tooltip[CountryData[#,{"SchematicPolygon","Robinson"}],
Column[{#,Row[{"Population:",p}]}]]}]&
/@CountryData[]},PlotRange->Automatic,ImageSize->600]

Reveal Relations

data=Cases[Tooltip[CountryData[#,"Population"],{#,CountryData[#,"Population"]}]&/@CountryData[],Except[Tooltip[Missing[_],_]]];

ListLogPlot[SortBy[data,First],Joined->True]

Graphics[{{
With[{pt={CountryData[#,"LifeExpectancy"],Log[10,CountryData[#,"GDPPerCapita"]]},
r=Rescale[Log[10,CountryData[#,"Population"]],{1.65,9.11}]},
If[MatchQ[pt,{_?NumberQ,_?NumberQ}],
{ColorData["Rainbow"][r],PointSize[r/40],Tooltip[Point[pt],#]},
{}]]}&/@CountryData[]},
AspectRatio->1/GoldenRatio,Frame->True,FrameLabel->{"Life Expectancy","GDP per Capita ((10^x))"},LabelStyle->(FontSize->14),ImageSize->600]

Interactive Tool

Some Demonstrations

NotebookOpen[ToFileName[NotebookDirectory[],"CountryRankingMaps.nb"]]

NotebookOpen[ToFileName[NotebookDirectory[],"WorldChart3D.nb"]]

CountryData Explorer

CreateDocument[
DynamicModule[
{p1={0,0},p2={0,0},d=False,ppr,pr=All,prstack={},
fr=True,gl=None,
c={"Africa"},csel=First@CountryData["Africa"],cgr,clgr,clgrf=True,ccgr,ccgrf=True,
poly="Polygon",props=Cases[CountryData["Properties"],Except["SchematicCoordinates"|"Coordinates"|"FullCoordinates"|"SchematicPolygon"|"Polygon"|"FullPolygon"]],propsels,propseln=5,ticker=1},

propsels=props[[1;;10]];

cgr=Dynamic@{
EdgeForm[{Black,Opacity[.5]}],ColorData["HTML"]["LightSteelBlue"],Opacity[.3],(EventHandler[CountryData[#,poly],{"MouseClicked":>If[!CurrentValue["ShiftKey"],(csel=#)]}])&/@CountryData@@c};

clgr=Dynamic@{Blue,Opacity[1],(With[{pt=Reverse@CountryData[#,"CapitalLocation"]},If[MatchQ[pt,Missing[_]],{},Tooltip[Point[pt],Grid[{{Style[#,12],SpanFromLeft},{Spacer[1],SpanFromLeft},{"Capital",CountryData[#,"CapitalCity"]},{"Location",CountryData[#,"CapitalLocation"]}}]]]])&/@CountryData@@c};
ccgr=Dynamic@{Red,Opacity[1],(With[{pt=Reverse@CountryData[#,"CenterCoordinates"]},If[MatchQ[pt,Missing[_]],{},Tooltip[Point[pt],Grid[{{Style[#,12],SpanFromLeft},{Spacer[1],SpanFromLeft},{"Center",CountryData[#,"CenterCoordinates"]}}]]]])&/@CountryData@@c};

Style[
Column[{
Panel[
Column[{
Pane[
Row[{
Grid[{{
PopupMenu[Dynamic[c,(pr=All;prstack={};c=#;csel=First[CountryData@@#])&],{{"Africa"}->"Africa",{"NorthAmerica"}->"NorthAmerica",{"SouthAmerica"}->"SouthAmerica",{"Asia"}->"Asia",{"Europe"}->"Europe",{"Oceania"}->"Oceania",{}->"World"}],
PopupMenu[Dynamic[poly],{"SchematicPolygon","Polygon","FullPolygon"}]},
{Button["Zoom out",If[prstack=!={},pr=Last@prstack;prstack=Most@prstack],ImageSize->{100,18}],SpanFromLeft},
{Button["View all",pr=All,ImageSize->{100,18}],SpanFromLeft}},Alignment->{Left,Center}],
Spacer[20],
Grid[{
{"FrameTicks ",RadioButtonBar[Dynamic[fr],{False,True}]},
{"GridLines ",RadioButtonBar[Dynamic[gl],{None,{Table[{i,If[Mod[i,10]==5,Directive[Dashed,LightGray],Directive[Dashing[{}],LightGray]]},{i,-165,165,15}],Table[{i,If[Mod[i,10]==5,Directive[Dashed,LightGray],Directive[Dashing[{}],LightGray]]},{i,-75,75,15}]}->"Every 15°",
{Table[{i,If[Mod[i,10]==5,Directive[Dashed,LightGray],Directive[Dashing[{}],LightGray]]},{i,-175,175,5}],Table[{i,If[Mod[i,10]==5,Directive[Dashed,LightGray],Directive[Dashing[{}],LightGray]]},{i,-85,85,5}]}->"Every 5°"}]},
{Spacer[1],SpanFromLeft},
{Row[{Style["Capital locations ",Blue],Checkbox[Dynamic[clgrf]],Spacer[20],Style["Center coordinates ",Red],Checkbox[Dynamic[ccgrf]]}],SpanFromLeft}
},Alignment->{Left,Center},BaseStyle->10,Dividers->{None,3->LightGray}]
}],{600,All}],

Spacer[{1,20}],

EventHandler[
Graphics[{
Dynamic@cgr,
Dynamic@{Yellow,Opacity[.4],CountryData[csel,poly]},
Dynamic@If[clgrf,clgr,{}],
Dynamic@If[ccgrf,ccgr,{}],
Text[Style["Click and drag for zoom-in. Shift-click and drag for pan.","Label",9,Gray],Scaled[{1,0}],{Right,Bottom}],
Dynamic@If[d,
{EdgeForm[Orange],FaceForm[{LightGray,Opacity[.5]}],Rectangle[p1,p2]},
{}]},
Frame->True,FrameTicks->Dynamic[fr],FrameStyle->Directive[Lighter[Gray],FontColor->Black],
GridLines->Dynamic@gl,
PlotRange->Dynamic@pr,
ImageSize->{{600},{400}}
],
{{"MouseDown",1}:>(p1=MousePosition["Graphics"];p2=p1;),

{"MouseDragged",1}:>(p1=MousePosition["Graphics"];
If[CurrentValue["ShiftKey"],
If[pr=!=All,pr=pr+(p2-p1)],
If[4Abs[p1-p2][[1]]>6Abs[p1-p2][[2]],p1[[2]]=4/6Sign[(p1-p2)[[2]]]Abs[p1-p2][[1]]+p2[[2]],p1[[1]]=6/4Sign[(p1-p2)[[1]]]Abs[p1-p2][[2]]+p2[[1]]];
d=True]),
{"MouseUp",1}:>(
If[(Min@Abs[p1-p2]>.5)&&!CurrentValue["ShiftKey"],
ppr=pr;pr=Sort/@Transpose[{p1,p2}];d=False;AppendTo[prstack,ppr],
d=False])
}](* EventHandler *)
},Alignment->{Center,Center}],
ImageSize->{650,All},Alignment->{Center,Center},ImageMargins->{{5,5},{0,5}}],

Panel[
OpenerView[{Dynamic@Row[{"Properties of ",PopupMenu[Dynamic[csel],CountryData@@c]}],
Column[{
Row[{"Number of properties to display",Spacer[10],Slider[Dynamic[propseln],{1,10,1},ImageSize->{200,15}],Spacer[10],Dynamic[propseln]}],
Dynamic@Grid[{PopupMenu[Dynamic[propsels[[#]]],props,BaseStyle->10],Row[{Replace[CountryData[csel,propsels[[#]]],Graphics[x___]:>Pane[Graphics[x],75,ImageSizeAction->"ShrinkToFit"]],Spacer[5],With[{u=Quiet@CountryData[csel,propsels[[#]],"Units"]},If[u=!=None&&Head[u]=!=CountryData,"("<>ToString[u]<>")",Null]]}]}&/@Range[propseln],Alignment->{{Right,Left},Center},Background->{None,{{LightGray,None}}},Frame->True,Spacings->{{1.5,{1},1.5},{1.5,{1},1.5}},ItemSize->{{All,48},Automatic}],
Button["Refresh property lists",props=CountryData["Properties"],ImageSize->{150,18},BaseStyle->10]
},BaseStyle->10]
}],
ImageSize->{650,All},ImageMargins->{{5,5},{5,0}}]
}],

CacheGraphics->False](* Style *)
],
WindowSize->All,Saveable->False,WindowFrame->"Palette",WindowElements->None,WindowFrameElements->{"CloseBox"},Editable->False,WindowTitle->"CountryData Explorer",ClosingAutoSave->False,WindowStatusArea->None,ShowCellBracket->False,Selectable->False]

Around the World... in an Optimized Way!

Gathering the data

cities=SortBy[Cases[N@{CityData[#,"Latitude"],CityData[#,"Longitude"],CityData[#,"Population"]}&/@CityData[],{_?NumericQ,_?NumericQ,_?NumericQ}],Last]

capitals=Cases[{CountryData[#,"CapitalCity"],CountryData[#,"CapitalLocation"]}&/@CountryData[],Except[{_,Missing[_]}]]

A bit of magic...

Get[ToFileName[{NotebookDirectory[],"Data"},"globe.mx"]]

Show[globe,ImageSize->800]

Computing the shortest path

spherical[{y_,x_}]:={Cos[x °]Cos[y °],Sin[x °]Cos[y °],Sin[y °]}
distfun[{y1_,x1_},{y2_,x2_}]:=VectorAngle[spherical[{y1,x1}],spherical[{y2,x2}]];
{dist,route}=FindShortestTour[capitals[[All,2]],distfun]

Show[Import[ToFileName[{NotebookDirectory[],"Data"},"globe_shortestpath.png"]],ImageSize->800]

Visualization of Data from Internet

The Whole Documentation Links

Code

$ZoomAspect=1/GoldenRatio;
$ZoomMinDrag=0.5;
$PanMod:=CurrentValue["ShiftKey"];

ZoomAndPan[graphic_]:=DynamicModule[{p1={0,0},p2={0,0},d=False,ppr,pr=All,prstack={}},Column[{EventHandler[Show[If[FreeQ[graphic,PlotRange->_],Append[graphic,PlotRange->Dynamic@pr],graphic/.(PlotRange->_):>(PlotRange->Dynamic@pr)],Graphics[{Dynamic@If[d,{EdgeForm[Orange],FaceForm[{LightGray,Opacity[.5]}],Rectangle[p1,p2]},{}],Text[Style["Click and drag for zoom-in. Shift-click and drag for pan.","Label",9,Gray],Scaled[{1,0}],{Right,Bottom}]}]],{{"MouseDown",1}:>(p1=MousePosition["Graphics"];
p2=p1;),{"MouseDragged",1}:>(p1=MousePosition["Graphics"];
If[$PanMod,If[pr=!=All,pr=pr+(p2-p1)],If[$ZoomAspect*Abs[p1-p2][[1]]>Abs[p1-p2][[2]],p1[[2]]=$ZoomAspect*Sign[(p1-p2)[[2]]] Abs[p1-p2][[1]]+p2[[2]],p1[[1]]=(1/$ZoomAspect)*Sign[(p1-p2)[[1]]] Abs[p1-p2][[2]]+p2[[1]]];
d=True]),{"MouseUp",1}:>(If[(Min@Abs[p1-p2]>$ZoomMinDrag)&&!$PanMod,ppr=pr;pr=Sort/@Transpose[{p1,p2}];d=False;
AppendTo[prstack,ppr],d=False])}],Row[{Button["Zoom out",pr=Last@prstack;prstack=Most@prstack,ImageSize->{100,18},Enabled->Dynamic[Length[prstack]>0]],Button["View all",pr=All;prstack={},ImageSize->{100,18},Enabled->Dynamic[pr=!=All]]}]},Alignment->Center]];

Explorer

Get[ToFileName[{NotebookDirectory[],"Data"},"weblinks.mx"]];

Panel[Style[ZoomAndPan[GraphPlot[g,VertexRenderingFunction->(Tooltip[Mouseover[{Blue,PointSize[Small],Point[#1]},{Red,PointSize[Large],Point[#1]}],#2]&),ImageSize->600,AspectRatio->1/GoldenRatio,PlotStyle->Opacity[.5],Frame->True,FrameTicks->None,FrameStyle->LightGray]],
CacheGraphics->False]
]

Future

Data Specific Plots

Field Specific Plots

Dynamic Plots

Easier Ways to Change Options