如何在Mathematica中有效地设置矩阵的次要？

Question

在观察belisarius关于生成具有均匀分布元素的非奇异整数矩阵的问题时,我正在研究Dana Randal 撰写的一篇论文," 高效生成随机非奇异矩阵 ".提出的算法是递归的,并且涉及生成较低维度的矩阵并将其分配给给定的次要.我使用Insert和组合Transpose,但必须有更有效的方法.你会怎么做？

以下是代码:

Clear[Gen];
Gen[p_, 1] := {{{1}}, RandomInteger[{1, p - 1}, {1, 1}]};
Gen[p_, n_] := Module[{v, r, aa, tt, afr, am, tm},
  While[True,
   v = RandomInteger[{0, p - 1}, n];
   r = LengthWhile[v, # == 0 &] + 1;
   If[r <= n, Break[]]
   ];
  afr = UnitVector[n, r];
  {am, tm} = Gen[p, n - 1];
  {Insert[
    Transpose[
     Insert[Transpose[am], RandomInteger[{0, p - 1}, n - 1], r]], afr,
     1], Insert[
    Transpose[Insert[Transpose[tm], ConstantArray[0, n - 1], r]], v, 
    r]}
  ]

NonSingularRandomMatrix[p_?PrimeQ, n_] := Mod[Dot @@ Gen[p, n], p]

它确实生成一个非奇异矩阵,并且矩阵元素的分布均匀,但需要p为素数:

代码也不是很有效,我怀疑由于我的低效矩阵构造函数:

In[10]:= Timing[NonSingularRandomMatrix[101, 300];]

Out[10]= {0.421, Null}

---

编辑所以让我来浓缩我的问题.给定矩阵的次矩阵m可以如下计算:

MinorMatrix[m_?MatrixQ, {i_, j_}] := 
 Drop[Transpose[Drop[Transpose[m], {j}]], {i}]

它是删除了i-th row和j-th列的原始矩阵.

我现在需要创建大小的矩阵n通过n将具有给定的子式矩阵mm的位置{i,j}.我在算法中使用的是:

ExpandMinor[minmat_, {i_, j_}, v1_, 
   v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[minmat] := 
 Insert[Transpose[Insert[Transpose[minmat], v2, j]], v1, i]

例:

In[31]:= ExpandMinor[
 IdentityMatrix[4], {2, 3}, {1, 2, 3, 4, 5}, {2, 3, 4, 4}]

Out[31]= {{1, 0, 2, 0, 0}, {1, 2, 3, 4, 5}, {0, 1, 3, 0, 0}, {0, 0, 4,
   1, 0}, {0, 0, 4, 0, 1}}

我希望这可以更有效地完成,这就是我在问题中征集的内容.

---

按照blisarius的建议,我研究了实施ExpandMinorvia ArrayFlatten.

Clear[ExpandMinorAlt];
ExpandMinorAlt[m_, {i_ /; i > 1, j_}, v1_, 
   v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[m] :=
 ArrayFlatten[{
   {Part[m, ;; i - 1, ;; j - 1], Transpose@{v2[[;; i - 1]]}, 
    Part[m, ;; i - 1, j ;;]},
   {{v1[[;; j - 1]]}, {{v1[[j]]}}, {v1[[j + 1 ;;]]}},
   {Part[m, i ;;, ;; j - 1], Transpose@{v2[[i ;;]]}, Part[m, i ;;, j ;;]}
   }]

ExpandMinorAlt[m_, {1, j_}, v1_, 
   v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[m] :=
 ArrayFlatten[{
   {{v1[[;; j - 1]]}, {{v1[[j]]}}, {v1[[j + 1 ;;]]}},
   {Part[m, All, ;; j - 1], Transpose@{v2}, Part[m, All, j ;;]}
   }]

In[192]:= dim = 5;
mm = RandomInteger[{-5, 5}, {dim, dim}];
v1 = RandomInteger[{-5, 5}, dim + 1];
v2 = RandomInteger[{-5, 5}, dim];

In[196]:= 
Table[ExpandMinor[mm, {i, j}, v1, v2] == 
    ExpandMinorAlt[mm, {i, j}, v1, v2], {i, dim}, {j, dim}] // 
  Flatten // DeleteDuplicates

Out[196]= {True}

Answer 1

我花了一段时间才到达这里,但由于我花了很多时间来生成随机矩阵,我无法帮助它,所以这里有.代码中的主要低效率来自于移动矩阵(复制它们)的必要性.如果我们可以重新构造算法,以便我们只修改单个矩阵,我们就可以赢得大奖.为此,我们必须计算插入的矢量/行最终的位置,因为我们通常会插入较小矩阵的中间,从而移动元素.这个有可能.这是代码:

gen = Compile[{{p, _Integer}, {n, _Integer}},
 Module[{vmat = Table[0, {n}, {n}],
    rs = Table[0, {n}],(* A vector of r-s*)
    amatr = Table[0, {n}, {n}],
    tmatr = Table[0, {n}, {n}],
    i = 1,
    v = Table[0, {n}],
    r = n + 1,
    rsc = Table[0, {n}], (* recomputed r-s *)
    matstarts = Table[0, {n}], (* Horizontal positions of submatrix starts at a given step *)    
    remainingShifts = Table[0, {n}] 
      (* 
      ** shifts that will be performed after a given row/vector insertion, 
      ** and can affect the real positions where the elements will end up
      *)
},
(* 
 ** Compute the r-s and vectors v all at once. Pad smaller 
 ** vectors v with zeros to fill a rectangular matrix
*)
For[i = 1, i <= n, i++,
 While[True,
  v = RandomInteger[{0, p - 1}, i];
  For[r = 1, r <= i && v[[r]] == 0, r++];
  If[r <= i,
   vmat[[i]] = PadRight[v, n];
   rs[[i]] = r;
   Break[]]
  ]];
 (* 
 ** We must recompute the actual r-s, since the elements will 
 ** move due to subsequent column insertions. 
 ** The code below repeatedly adds shifts to the 
 ** r-s on the left, resulting from insertions on the right. 
 ** For example, if vector of r-s 
 ** is {1,2,1,3}, it will become {1,2,1,3}->{2,3,1,3}->{2,4,1,3}, 
 ** and the end result shows where
 ** in the actual matrix the columns (and also rows for the case of 
 ** tmatr) will be inserted 
 *)
 rsc = rs;
 For[i = 2, i <= n, i++,
  remainingShifts = Take[rsc, i - 1];
  For[r = 1, r <= i - 1, r++,
   If[remainingShifts[[r]] == rsc[[i]],
     Break[]
   ]
  ];
  If[ r <= n,
    rsc[[;; i - 1]] += UnitStep[rsc[[;; i - 1]] - rsc[[i]]]
  ]
 ];
 (* 
  ** Compute the starting left positions of sub-
  ** matrices at each step (1x1,2x2,etc)
 *)
 matstarts = FoldList[Min, First@rsc, Rest@rsc];
 (* Initialize matrices - this replaces the recursion base *)
 amatr[[n, rsc[[1]]]] = 1;
 tmatr[[rsc[[1]], rsc[[1]]]] = RandomInteger[{1, p - 1}];
 (* Repeatedly perform insertions  - this replaces recursion *)
 For[i = 2, i <= n, i++,
  amatr[[n - i + 2 ;; n, rsc[[i]]]] = RandomInteger[{0, p - 1}, i - 1];
  amatr[[n - i + 1, rsc[[i]]]] = 1;
  tmatr[[n - i + 2 ;; n, rsc[[i]]]] = Table[0, {i - 1}];
  tmatr[[rsc[[i]], 
    Fold[# + 1 - Unitize[# - #2] &, 
       matstarts[[i]] + Range[0, i - 1], Sort[Drop[rsc, i]]]]] = 
            vmat[[i, 1 ;; i]];    
 ];
 {amatr, tmatr}
 ], 
 {{FoldList[__], _Integer, 1}}, CompilationTarget -> "C"];

NonSignularRanomMatrix[p_?PrimeQ, n_] := Mod[Dot @@ Gen[p, n],p];
NonSignularRanomMatrixAlt[p_?PrimeQ, n_] := Mod[Dot @@ gen[p, n],p];

这是大矩阵的时间:

In[1114]:= gen [101, 300]; // Timing

Out[1114]= {0.078, Null}

对于直方图,我得到了相同的图,并提高了10倍的效率:

In[1118]:= 
  Histogram[Table[NonSignularRanomMatrix[11, 5][[2, 3]], {10^4}]]; // Timing

Out[1118]= {7.75, Null} 

In[1119]:= 
 Histogram[Table[NonSignularRanomMatrixAlt[11, 5][[2, 3]], {10^4}]]; // Timing

Out[1119]= {0.687, Null}

我希望通过仔细分析上面编译的代码,可以进一步提高性能.另外,我没有在Compile中使用运行时Listable属性,而这应该是可能的.它也可能是代码的这对未成年人进行分配的部分是通用足以使逻辑可以分解出来的主要功能 - 我没有调查这呢.