Mathematica 教學：World life data with mixed statistical graphics

World life data with mixed statistical graphics

data=Import["https://www.cia.gov/library/publications/the-world-factbook/fields/2102.html","Data"];

datatemp=Select[data[[5;;-3]],Length[Tally[StringPosition[#,"NA"]]]==1&];

yearsget[cdata_]:=Block[{cc=cdata,strpos},
strpos=StringPosition[cc,{"total population:","years male:","years female:"}];
StringTake[cc,{{strpos[[1,2]]+1,strpos[[2,1]]-1},{strpos[[2,2]]+1,
strpos[[3,1]]-1},{strpos[[3,2]]+1,strpos[[3,2]]+5}}]
]

lifedata=Map[Flatten@{StringTake[#[[1]],{1,-2}],
ToExpression@yearsget[#[[2]]]}&,datatemp]

Needs["ComputationalGeometry`"]

SortBy[lifedata,Last]//TableForm

leq[ptstemp_List]:=Block[{pts=ptstemp,slope,x,y},
If[Abs[pts[[2,1]]-pts[[1,1]]]<10^-9,x==pts[[1,1]], y==(pts[[2,2]]-pts[[1,2]])/(pts[[2,1]]-pts[[1,1]])*(x- pts[[1,1]])+pts[[1,2]]]]; bagscheme[{sourcetemp_List,ptstemp_List}]:= Block[{source=sourcetemp,pts=ptstemp,ch,temp,newlineeq, newpts,x,y,newch,newchpts}, ch=Quiet@ConvexHull@Flatten[{source,pts},1]; temp=source[[#]]&/@Select[ch,#<=Length@source&]; source= source[[#]]&/@ Complement[Range[Length@source], Select[ch,#<=Length@source&]];  newlineeq=Flatten[{{{#[[1]],#[[-2]]},{#[[-1]],#[[2]]}},{{#[[1]],#[[ 3]]},{#[[-1]],#[[2]]}}}&/@ Table[RotateLeft[temp,i],{i,0,Length@temp-1}],1]; newpts={x,y}/.Solve[leq[#]&/@#,{x,y}][[1]]&/@newlineeq; N@{source,newpts}];  mybag=NestWhileList[bagscheme,{lifedata[[All,{3,4}]],{}}, Length@#[[1]]>Length[lifedata[[All,{3,4}]]]/2&,1];
mybagcontour[i_]:=
Tally[Flatten[mybag[[-i]],1]][[All,1]][[#]]&/@(Quiet@
ConvexHull@Tally[Flatten[mybag[[-i]],1]][[All,1]]);

Grid[{{Graphics[{Opacity[0.8],Green,
Cases[BoxWhiskerChart[lifedata[[All,4]],"Notched"],
GraphicsGroupBox[box___]:>box,Infinity]/.
PolygonBox[a__]:>PolygonBox[Evaluate@(If[#[[1]]>
1,{#[[1]]+1,#[[2]]},{#[[1]]-1,#[[2]]}]&/@
a)]},PlotRange->{Automatic,{20,100}},ImageSize->{50,700}],
ListPlot[lifedata[[All,{3,4}]],AspectRatio->1.5,
ImageSize->{500,700},
Axes->False,Frame->True,
GridLines->{Range[20,100,2],Range[20,100,2]},
AxesOrigin->{20,20},
PlotRange->{{20,100},{20,100}},
PlotStyle->Black,
Epilog->{
ConvexHullpoint=Quiet@ConvexHull[lifedata[[All,{3,4}]]];
Opacity[0.75],EdgeForm[None],
Red,
Cases[Histogram[lifedata[[All,3]],{25,100,5}],
RectangleBox[a__,b__,c___]:>
Rectangle[
a+{0,20},{b[[1]],20+a[[2]]+(b[[2]]-a[[2]])/2}],
Infinity],
Green,
Cases[
Histogram[lifedata[[All,4]],{25,100,5},BarOrigin->Left],
RectangleBox[a__,b__,c___]:>
Rectangle[
a+{20,0},{(b[[1]]-a[[1]])/2+a[[1]]+20,b[[2]]}],
Infinity],
Opacity[1],
Green,Thickness[0.01],
Line[{#,
LinearModelFit[lifedata[[All,{3,4}]],x,x][#]}&/@{20,
100}],
Brown,Thickness[0.01],
Line[{LinearModelFit[lifedata[[All,{4,3}]],y,
y][#],#}&/@{20,100}],
Black,
{Text[lifedata[[#,1]],lifedata[[#,{3,4}]]],
Point[lifedata[[#,{3,4}]]]}&/@ConvexHullpoint,
Blue,Opacity[0.25],EdgeForm[Blue],
Polygon[lifedata[[#,{3,4}]]&/@ConvexHullpoint],
Red,Opacity[0.25],EdgeForm[Red],
Polygon[Insert[mybagcontour[1],mybagcontour[1][[1]],-1]],Red,
Opacity[1],PointSize[0.0125],
Point@Quiet@ConvexHullMedian@lifedata[[All,{3,4}]]
}
]},
{"",Graphics[{Opacity[0.75],Red,
Cases[BoxWhiskerChart[lifedata[[All,3]],"Notched",
BarOrigin->Left],GraphicsGroupBox[box___]:>box,
Infinity]/.
PolygonBox[a__]:>
PolygonBox[
Evaluate@(If[#[[2]]>
1,{#[[1]],#[[2]]+1},{#[[1]],#[[2]]-1}]&/@
a)]},PlotRange->{{20,100},Automatic},
ImageSize->{500,50}]}}]

Tags: Mathematica 教學

• 編輯文章
• 此文章網址
• 轉寄此文章
• 目前有0 意見