MathematicaでのStepwise変数選択（変数減少法のみ）

MathematicaでStepwise変数選択（変数減少法のみ）のプログラム作成してみました。

改良などご助言ありましたらご連絡いただけると嬉しいです。

AICやBICなどによる選択法のプログラムも作ったのですが、また次回にでも。

(* テスト用のデータ作成 *)

tmp = {RandomReal[{0, 20}, 40], RandomReal[{0, 20}, 40] , RandomReal[{0, 20}, 40],
   Table[0.5*x + RandomVariate[NormalDistribution[0, 1]], {x, 1, 40, 1}],  Table[1*x + RandomVariate[NormalDistribution[0, 1]], {x, 1, 40, 1}]};
data = {"x1", "x2", "x3", "x4", "y"};
data = Join[{data}, Transpose[tmp]];
data // TableForm

(* dataの最後のリストを従属変数として、他の変数を独立変数として重回帰し、結果をreslistに保存。推定されたパラメタに対するt検定のp値が全てcritを下回ったら終了（誤差項は除いています）。そうでなければ最大のp値が返されたパラメタを持つ独立変数を除き再度重回帰。独立変数の数が0になったら変数選択を終了。*)

crit = 0.2;
label = data[[1]];
df = Transpose[Drop[data, {1}]];
xlist = Table[Subscript[x, i] , {i, 1, Length[df] - 1}];
reslist = {}; tmplist = {};
While[Length[df] > 1,
 {
  data = Transpose[df];
  lm = LinearModelFit[data, xlist, xlist];
  AppendTo[reslist, lm];
  tmp = Drop[lm["ParameterTable"][[1]][[1]][[All, 5]], 2];
  AppendTo[tmplist, tmp];
  Print[label];
  If[Length[Select[tmp, # > crit &]] == 0, Break[]];
  remove = 1; maxP = -1;
  For[i = 1, i <= Length[tmp], i++,
   If[tmp[[i]] > maxP, {remove = i, maxP = tmp[[i]]}]];
  df = Delete[df, {remove}];
  label = Delete[label, {remove}];
  xlist = Delete[xlist, {remove}];
  }
 ]

(* ベストモデルの抽出 *)

Normal[Last[reslist]]
Last[reslist]["ParameterTable"]