Mathematica 教學 Path Analysis 路徑分析

『懶』，是一種美德。
這個程式指定內生變數集外生變數後即可產生路徑圖以及路徑分析各項效果分解表，不需要在SPSS中作多次回歸或是在Amos中畫圖。

data=Import["http://www.pws.stu.edu.tw/cydye/Employee.csv"];

emp=data[[All,{2,4,5,6,7,8,9,10}]][[2;;-1]];

TableForm[emp[[1;;10]],
TableHeadings->{Range[Length@emp],
data[[1,{2,4,5,6,7,8,9,10}]]}]
path={{"educ","prevexp"},{"educ","salbegin"},{"educ",
"salary"},{"prevexp","salbegin"},{"prevexp",
"salary"},{"salbegin","salary"},{"jobtime",
"salary"},{"gender","prevexp"},{"gender",
"salbegin"},{"gender","salary"},{"minority",
"salary"},{"minority","salbegin"}};

exvars={"educ","gender","minority","jobtime"};
envars={"prevexp","salbegin","salary"};
vars=ToExpression@data[[1,{2,4,5,6,7,8,9,10}]];
MapThread[
Set,{vars,emp[[All,#]]&/@Range[Dimensions[emp][[-1]]]}];
pathtonode[targetnode_]:=Block[{node=targetnode,m,k},
NestWhile[DeleteCases[Flatten[Table[k=i;
m=Cases[path,{__,k[[1,1]]}];
Insert[k,#,1]&/@If[m=={},{{,}},m]
,{i,#}],1],{Null,Null},Infinity]&,{{{node,node}}},
Unequal,All][[All,1;;-2]]
]

pathtonode["salary"]

submodel[targetnode_]:=
Block[{node=targetnode,sourcenode,nodelist,varlist,pathcoeff},
sourcenode=
DeleteDuplicates[
Cases[pathtonode[ToString@node],{__,ToString@node},Infinity]];
nodelist=DeleteDuplicates[sourcenode][[All,1]];
nodelist=Insert[nodelist,node,-1];
varlist=
ToExpression@CharacterRange["a","z"][[1;;Length@nodelist-1]];
pathcoeff=
LinearModelFit[
Transpose[N@Standardize[#]&/@ToExpression@nodelist],
varlist,varlist]["ParameterTableEntries"][[All,{1,-1}]][[
2;;-1]];
MapThread[{Rule@@#1,
If[#2[[2]]<0.05, Style[NumberForm[#2[[1]],3, NumberFormat->(Row[{#1,
"\!\(\*SuperscriptBox[\(\),\(*\)]\)"}]&)],Bold,
FontSize->14],
Style[NumberForm[#2[[1]],3],Bold,FontSize->14]]}&,
{sourcenode,pathcoeff}]
]

pathgraph=
Flatten[DeleteCases[
If[pathtonode[#]!={{}},submodel[#]]&/@
DeleteDuplicates[Flatten[path]],Null],1];
Show[LayeredGraphPlot[pathgraph,Left,DirectedEdges->False],
LayeredGraphPlot[pathgraph,Left,VertexLabeling->True,
EdgeRenderingFunction->({Red,Arrow[#1,0.15]}&),
VertexRenderingFunction->({White,EdgeForm[Black],Black,
Text[Framed[Style[#2,FontSize->15],
Background->RGBColor[1,1,0.8]],#1]}&)],
ImageSize->350]


allpathrule=
Cases[pathgraph,{a_->b_,
Style[NumberForm[c_,3,___],Bold,FontSize->14]}:>{a,b}->
c,Infinity];

submodeleffect[sourcenode_,targetnode_]:=
Block[{tnode=targetnode,snode=sourcenode,tpathtonode,exeffect},
tpathtonode[ssourcenode_,ttargetnode_]:=
If[Length@Cases[envars,snode]==0,
Select[pathtonode[ttargetnode],#[[1,1]]==ssourcenode&],
DeleteDuplicates[
Flatten[{Cases[
pathtonode[ttargetnode],{___,{ssourcenode,__},___,{___,
ttargetnode},___},Infinity][[All,2;;-1]],
Cases[pathtonode[
ttargetnode],{___,{ssourcenode,ttargetnode},___},
Infinity][[All,-1]]},1]]];
exeffect=SortBy[tpathtonode[snode,tnode]/.allpathrule,Length@#&];
Which[Length@exeffect==0,Flatten@{0,0,0},
Length@exeffect==1,Flatten@{exeffect[[1]],0,exeffect[[1]]},
Length@exeffect>=2,Flatten@{exeffect[[1]],
Total[Times@@@exeffect[[2;;-1]]],
exeffect[[1]]+Total[Times@@@exeffect[[2;;-1]]]}]
]

Text@Grid[
Prepend[MapThread[
Insert[#1,#2,1]&,{Transpose[
Insert[Flatten[#]&/@
Partition[
Cases[Table[
submodeleffect[i,j],{j,envars},{i,
Flatten@{exvars,envars[[1;;-2]]}}],{x_,y_,
z_}:>{If[x>=0,""<>ToString@NumberForm[x,{4,3}],
NumberForm[x,{4,3}]],
If[y>=0,""<>ToString@NumberForm[y,{4,3}],
NumberForm[y,{4,3}]],
If[z>=0,""<>ToString@NumberForm[z,{4,3}],
NumberForm[z,{4,3}]]},Infinity],
Length@envars+Length@exvars-1],
Flatten[{"直接效果","間接效果","總效果"}&/@
Range[Length@envars+Length@exvars-1]],1]],
Flatten[{#,"",""}&/@Flatten[{exvars,envars[[1;;-2]]}]]}],
Flatten@{"","",envars}],
Background->{None,{Lighter[Yellow,0],{Lighter[Green,0.8],
Lighter[Blend[{Blue,Green}],.7],Lighter[Gray,0.5]}}},
Dividers->{{Darker[Gray,.6],{Lighter[Gray,.5]},
Darker[Gray,.6]},{Darker[Gray,.6],Darker[Gray,.6],{False},
Darker[Gray,.6]}},
Alignment->{Center},ItemSize->{{5,7,5,5,5}},
Frame->Darker[Gray,.6],ItemStyle->14,
Spacings->{Automatic,1}]

Tags: Mathematica, Teaching

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