Related
I am trying to increase the size of matrix below through for loop but the code gives an error that I have not found a solution until this point. Here is my code,
m = 1;
n = 1;
mat2 = Table[0, {m}, {n}];
For[i = 1, i <= n + 1, i++,
For[j = 1, j <= m + 1, j++,
mat2[[i, j]] = j
];
];
mat2 // MatrixForm
How can I solve this problem?
In[1]:= m = 2; n = 2; mat2 = Table[i + j, {i, m}, {j, n}];
mat2 = ArrayPad[mat2, {0, 1}];
mat2 // MatrixForm
Out[3]//MatrixForm=
{{2, 3, 0},
{3, 4, 0},
{0, 0, 0}}
a neat little trick using SparseArray ..
mat = SparseArray[Table[1, {5}, {5}]]
mat = SparseArray[Prepend[ArrayRules[mat], {6, 8} -> 9]]
note this copies the entire array to a new larger array (as does ArrayPad ), so you really don't want to be doing this often for large arrays.
likewise an "assignment" into an existing position works, but you don't want to do this for performance reasons:
mat = SparseArray[Prepend[ArrayRules[mat], {2, 2} -> 3]]
rather than growing arrays you would be better off to define a sufficiently large SparseArray in the first place (there is little/no memory hit for making a huge empty SparseArray)
mat = SparseArray[Table[1, {5}, {5}], {1000, 1000}];
mat[[6, 8]] = 9;
mat[[2, 2]] = 3;
(just don't try to print this..)
when done save the non-empty part:
mat=SparseArray[ArrayRules[mat]]
I'm looking for a way to reduce the length of a huge list with the Total function and a threshold parameter. I would like to avoid the use of For and If (coming from old habits).
Example :
List that I want to "reduce" :{1,5,3,8,11,3,4} with a threshold of 5.
Output that I want : {6,11,11,7}
That means that I use the Total function on the first parts of the list and look if the result of this function is higher than my threshold. If so, I use the result of the Total function and go to the next part of the list.
Another example is {1,1,1,1,1} with a threshold of 5. Result should be {5}.
Thanks!
EDIT : it is working but it is pretty slow. Any ideas in order to be faster?
EDIT 2 : the loop stuff (quit simple and not smart)
For[i = 1, i < Length[mylist] + 1, i++,
sum = sum + mylist[[i]];
If[sum > Threshold ,
result = Append[result , sum]; sum = 0; ]; ];
EDIT 3 : I have now a new thing to do.
I have to work now with a 2D list like {{1,2}{4,9}{1,3}{0,5}{7,3}}
It is more or less the same idea but the 1st and 2nd part of the list have to be higher than the thresold stuff (both of them).
Example : If lst[[1]] and lst[[2]] > threshold do the summuation for each part of the 2D list. I tried to adapt the f2 function from Mr.Wizard for this case but I didn't succeed. If it is easier, I can provide 2 independant lists and work with this input f3[lst1_,lst2_,thres_]:=
Reap[Sow#Fold[If[Element of the lst1 > thr && Element of the lst2, Sow##; #2, # + #2] &, 0, lst1]][[2, 1]] for example.
EDIT 4 :
You are right, it is not really clear. But the use of the Min## > thr statement is working perfectly.
Old code (ugly and not smart at all):
sumP = 0;
resP = {};
sumU = 0;
resU = {};
For[i = 1, i < Length[list1 + 1, i++,
sumP = sumP + list1[[i]];
sumU = sumU + list2[[i]];
If[sumP > 5 && sumU > 5 ,
resP = Append[resP, sumP]; sumP = 0;
resU = Append[resU, sumU]; sumU = 0;
];
]
NEW fast by Mr.Wizard :
f6[lst_, thr_] :=
Reap[Sow#Fold[If[Min## > thr , Sow##1; #2, #1 + #2] &, 0, lst]][[2,
1]]
That ~40times faster. Thanks a lot.
Thread[{resP, resU}] == f6[Thread[{list1,list2}], 5] True
I recommend using Fold for this kind of operation, combined with either linked lists or Sow and Reap to accumulate results. Append is slow because lists in Mathematica are arrays and must be reallocated every time an element is appended.
Starting with:
lst = {2, 6, 4, 4, 1, 3, 1, 2, 4, 1, 2, 4, 0, 7, 4};
Here is the linked-list version:
Flatten # Fold[If[Last## > 5, {#, #2}, {First##, Last## + #2}] &, {{}, 0}, lst]
{8, 8, 7, 7, 11, 4}
This is what the output looks like before Flatten:
{{{{{{{}, 8}, 8}, 7}, 7}, 11}, 4}
Here is the method using Sow and Reap:
Reap[Sow # Fold[If[# > 5, Sow##; #2, # + #2] &, 0, lst]][[2, 1]]
{8, 8, 7, 7, 11, 4}
A similar method applied to other problems: (1) (2)
The Sow # on the outside of Fold effectively appends the last element of the sequence which would otherwise be dropped by the algorithm.
Here are the methods packaged as functions, along with george's for easy comparison:
f1[lst_, thr_] :=
Flatten # Fold[If[Last## > thr, {#, #2}, {First##, Last## + #2}] &, {{}, 0}, lst]
f2[lst_, thr_] :=
Reap[Sow#Fold[If[# > thr, Sow##; #2, # + #2] &, 0, lst]][[2, 1]]
george[t_, thresh_] := Module[{i = 0, s},
Reap[While[i < Length[t], s = 0;
While[++i <= Length[t] && (s += t[[i]]) < thresh]; Sow[s]]][[2, 1]]
]
Timings:
big = RandomInteger[9, 500000];
george[big, 5] // Timing // First
1.279
f1[big, 5] // Timing // First
f2[big, 5] // Timing // First
0.593
0.468
Here is the obvious approach which is oh 300x faster.. Pretty isn't always best.
t = Random[Integer, 10] & /# Range[2000];
threshold = 4;
Timing[
i = 0;
t0 = Reap[
While[i < Length[t], s = 0;
While[++i <= Length[t] && (s += t[[i]]) < threshold ];
Sow[s]]][[2, 1]]][[1]]
Total[t] == Total[t0]
Timing[ t1 =
t //. {a___, b_ /; b < threshold, c_, d___} -> {a, b + c, d} ][[1]]
t1 == t0
I interpret your requirement as:
if an element in the list is less than the threshold value, add it to the next element in the list;
repeat this process until the list no longer changes.
So, for the threshold 5 and the input list {1,5,3,8,11,3,4} you'ld get
{6,3,8,11,3,4}
{6,11,11,3,4}
{6,11,11,7}
EDIT
I've now tested this solution to your problem ...
Implement the operation by using a replacement rule:
myList = {1,5,3,8,11,3,4}
threshold = 5
mylist = mylist //. {a___, b_ /; b < threshold, c_, d___} :> {a, b+c, d}
Note the use of ReplaceRepeated (symbolification //.).
I would like to populate an n * n (n being odd) matrix in the following way:
_ _ _ 23 22 21 20
_ _ 24 10 9 8 37
_ 25 11 3 2 19 36
26 12 4 1 7 18 35
27 13 5 6 17 34 _
28 14 15 16 33 _ _
29 30 31 32 _ _ _
What is an easy way to do this using Mathematica?
With this helper function:
Clear[makeSteps];
makeSteps[0] = {};
makeSteps[m_Integer?Positive] :=
Most#Flatten[
Table[#, {m}] & /# {{-1, 0}, {-1, 1}, {0, 1}, {1, 0}, {1, -1}, {0, -1}}, 1];
We can construct the matrix as
constructMatrix[n_Integer?OddQ] :=
Module[{cycles, positions},
cycles = (n+1)/2;
positions =
Flatten[FoldList[Plus, cycles + {#, -#}, makeSteps[#]] & /#
Range[0, cycles - 1], 1];
SparseArray[Reverse[positions, {2}] -> Range[Length[positions]]]];
To get the matrix you described, use
constructMatrix[7] // MatrixForm
The idea behind this is to examine the pattern that the positions of consecutive numbers 1.. follow. You can see that these form the cycles. The zeroth cycle is trivial - contains a number 1 at position {0,0} (if we count positions from the center). The next cycle is formed by taking the first number (2) at position {1,-1} and adding to it one by one the following steps: {0, -1}, {-1, 0}, {-1, 1}, {0, 1}, {1, 0} (as we move around the center). The second cycle is similar, but we have to start with {2,-2}, repeat each of the previous steps twice, and add the sixth step (going up), repeated only once: {0, -1}. The third cycle is analogous: start with {3,-3}, repeat all the steps 3 times, except {0,-1} which is repeated only twice. The auxiliary function makeSteps automates the process. In the main function then, we have to collect all positions together, and then add to them {cycles, cycles} since they were counted from the center, which has a position {cycles,cycles}. Finally, we construct the SparseArray out of these positions.
I don't know the Mathematica syntax but I guess you could use an algorithm like this:
start in the middle of the matrix
enter a 1 into the middle
go up-right (y-1 / x+1)
set integer iter=1
set integer num=2
while cursor is in matrix repeat:
enter num in current field
increase num by 1
repeat iter times:
go left (x-1 / y)
enter num in current field
increase num by 1
repeat iter times:
go down-left (x-1 / y+1)
enter num in current field
increase num by 1
repeat iter times:
go down (x / y+1)
enter num in current field
increase num by 1
repeat iter times:
go right (x+1 / y)
enter num in current field
increase num by 1
repeat iter times:
go up-right (x+1 / y-1)
enter num in current field
increase num by 1
repeat iter-1 times:
go up (x / y-1)
enter num in current field
increase num by 1
go up-up-right (y-2 / x+1)
increase iter by 1
you can also pretty easily convert this algorithm into a functional version or into a tail-recursion.
Well, you will have to check in the while loop if you aren't out of bounds as well. If n is odd then you can just count num up while:
m = floor(n/2)
num <= n*n - (m+m*m)
I'm pretty sure that there's a simpler algorithm but that's the most intuitive one to me.
The magic numbers on the diagonal starting at 1 and going up right can be arrived at from
f[n_] := 2 Sum[2 m - 1, {m, 1, n}] + UnitStep[n - 3] Sum[2 m, {m, 1, n - 2}]
In := f#Range#5
Out := {2, 8, 20, 38, 62}
With this it should be easy to set up a SparseArray. I'll play around with it a bit and see how hard that is.
First version:
i = 10;
a = b = c = Array[0 &, {2 (2 i + 1), 2 (2 i + 1)}];
f[n_] := 3*n*(n + 1) + 1;
k = f[i - 2];
p[i_Integer] :=
ToRules#Reduce[
-x + y < i - 1 && -x + y > -i + 1 &&
(2 i + 1 - x)^2 + (2 i + 1 - y)^2 <= 2 i i - 2 &&
3 i - 1 > x > i + 1 &&
3 i - 1 > y > i + 1, {x, y}, Integers];
((a[[Sequence ## #]] = 1) & /# ({x, y} /. {p[i]}));
((a[[Sequence ## (# + {2, 2})]] = 0) & /# ({x, y} /. {p[i - 1]}));
(b[[Sequence ## #]] = k--)&/#((# + 2 i {1, 1}) &/# (SortBy[(# - 2 i {1, 1}) &/#
Position[a, 1],
N#(Mod[-10^-9 - Pi/4 + ArcTan[Sequence ## #], 2 Pi]) &]));
c = Table[b[[2 (2 i + 1) - j, k]], {j, 2 (2 i + 1) - 1},
{k, 2 (2 i + 1) - 1}];
MatrixPlot[c]
Edit
A better one:
genMat[m_] := Module[{f, k, k1, i, n, a = {{1}}},
f[n_] := 3*n*(n + 1) + 1;
For[n = 1, n <= m, n++,
a = ArrayPad[a, 1];
k1 = (f[n - 1] + (k = f[n]) + 2)/2 - 1;
For[i = 2, i <= n + 1, i++, a[[i, 2n + 1]] = k--; a[[2-i+2 n, 1]] = k1--];
For[i = n + 2, i <= 2 n + 1, i++, a[[i, 3n+2-i]] = k--; a[[-i,i-n]] = k1--];
For[i = n, i >= 1, i--, a[[2n+1, i]] = k--;a[[1, -i + 2 n + 2]] = k1--];
];
Return#MatrixForm[a];
]
genMat[5]
A partial solution, using image procssing:
Image /# (Differences#(ImageData /#
NestList[
Fold[ImageAdd,
p = #, (HitMissTransform[p, #, Padding -> 0] & /#
{{{1}, {-1}},
{{-1}, {-1}, {1}},
{{1, -1, -1}},
{{-1, -1, 1}},
{{-1, -1, -1, -1}, {-1, -1, -1, -1}, {1, 1, -1, -1}},
{{-1, -1, -1, 1}, {-1, -1, -1, -1}, {-1, -1, -1, -1}}})] &, img, 4]))
While looking at the belisarius's question about generation of non-singular integer matrices with uniform distribution of its elements, I was studying a paper by Dana Randal, "Efficient generation of random non-singular matrices". The algorithm proposed is recursive, and involves generating a matrix of lower dimension and assigning it to a given minor. I used combinations of Insert and Transpose to do it, but there are must be more efficient ways of doing it. How would you do it?
The following is the code:
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]
It does generate a non-singular matrix, and has uniform distribution of matrix elements, but requires p to be prime:
The code is also not every efficient, which is, I suspect due to my inefficient matrix constructors:
In[10]:= Timing[NonSingularRandomMatrix[101, 300];]
Out[10]= {0.421, Null}
EDIT So let me condense my question. The minor matrix of a given matrix m can be computed as follows:
MinorMatrix[m_?MatrixQ, {i_, j_}] :=
Drop[Transpose[Drop[Transpose[m], {j}]], {i}]
It is the original matrix with i-th row and j-th column deleted.
I now need to create a matrix of size n by n that will have the given minor matrix mm at position {i,j}. What I used in the algorithm was:
ExpandMinor[minmat_, {i_, j_}, v1_,
v2_] /; {Length[v1] - 1, Length[v2]} == Dimensions[minmat] :=
Insert[Transpose[Insert[Transpose[minmat], v2, j]], v1, i]
Example:
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}}
I am hoping this can be done more efficiently, which is what I am soliciting in the question.
Per blisarius's suggestion I looked into implementing ExpandMinor via 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}
It took me a while to get here, but since I spent a good part of my postdoc generating random matrices, I could not help it, so here goes. The main inefficiency in the code comes from the necessity to move matrices around (copy them). If we could reformulate the algorithm so that we only modify a single matrix in place, we could win big. For this, we must compute the positions where the inserted vectors/rows will end up, given that we will typically insert in the middle of smaller matrices and thus shift the elements. This is possible. Here is the code:
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];
Here is the timing for the large matrix:
In[1114]:= gen [101, 300]; // Timing
Out[1114]= {0.078, Null}
For the histogram, I get the identical plots, and the 10-fold efficiency boost:
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}
I expect that upon careful profiling of the above compiled code, one could further improve the performance. Also, I did not use runtime Listable attribute in Compile, while this should be possible. It may also be that the parts of the code which perform assignment to minors are generic enough so that the logic can be factored out of the main function - I did not investigate that yet.
For the first part of your question (which I hope I understand properly) can
MinorMatrix be written as follows?
MinorMatrixAlt[m_?MatrixQ, {i_, j_}] := Drop[mat, {i}, {j}]
I want to "modify" Mathematica's Interpolation[] function (in 1
dimension) by replacing extrapolation with constant values when the
input is out of range.
In other words, if the interpolation domain is [1,20] and f[1]==7 and
f[20]==12, I want:
f[x] = 7 for x<=1
f[x] = 12 for x>=20
f[x] = Interpolation[...]
However, this fails:
(* interpolation w cutoff *)
interpcut[r_] := Module[{s, minpair, maxpair},
(* sort array by x coord *)
s = Sort[r, #1[[1]] < #2[[1]] &];
(* find min x value and corresponding y value *)
minpair = s[[1]];
(* ditto for max x value *)
maxpair = s[[-1]];
(* return the pure function representing cutoff interpolation *)
Piecewise[{
{minpair[[2]] &, #1 < minpair[[1]] &},
{maxpair[[2]] &, #1 > maxpair[[1]] &},
{Interpolation[r], True}
}]]
test = Table[{x,Prime[x]},{x,1,10}]
InputForm[interpcut[test]]
Piecewise[{{minpair$59[[2]] & , #1 < minpair$59[[1]] & },
{maxpair$59[[2]] & , #1 > maxpair$59[[1]] & }},
InterpolatingFunction[{{1, 10}}, {3, 1, 0, {10}, {4}, 0, 0, 0, 0},
{{1, 2, 3, 4, 5, 6, 7, 8, 9, 10}}, {{2}, {3}, {5}, {7}, {11}, {13}, {17},
{19}, {23}, {29}}, {Automatic}]]
I'm sure I'm missing something basic. What?
Function definition
interpcut[r_, x_] :=
Module[{s},(*sort array by x coord*)
s = SortBy[r, First];
Piecewise[
{{First[s][[2]], x < First[s][[1]]},
{Last [s][[2]], x > Last [s][[1]]},
{Interpolation[r][x], True}}]];
Test
test = Table[{x, Prime[x]}, {x, 1, 10}];
f[x_] := interpcut[test, x]
Plot[f[x], {x, -10, 30}]
Edit
Answering your comment about pure functions.
I did it that way just for clarity, not for cheating. For using pure functions just "follow the recipe":
interpcut[r_] := Module[{s},
s = SortBy[r, First];
Function[Piecewise[
{{First[s][[2]], # < First[s][[1]]},
{Last [s][[2]], # > Last [s][[1]]},
{Interpolation[r][#], True}}]]
]
test = Table[{x, Prime[x]}, {x, 1, 10}];
f = interpcut[test] // InputForm
Plot[interpcut[test][x], {x, -10, 30}]
Let me add an update to this old thread. Since V9 you can use native (but still experimental) "ExtrapolationHandler" parameter
test = Table[{x, Prime[x]}, {x, 1, 10}];
g = Interpolation[test, "ExtrapolationHandler" ->
{If[# <= test[[1, 1]], test[[1, 2]], test[[-1, 2]]] &,
"WarningMessage" -> False}];
Plot[g[x], {x, -10, 30}]
Here's a possible alternative to belisarius's answer:
interpcut[r_] := Module[{s}, s = SortBy[r, First];
Composition[Interpolation[r], Clip[#, Map[First, Through[{First, Last}[s]]]] &]]