I have a very large array of numbers in the form of a third order tensor.I want to find the highest of all the values in that tensor. How can I do it in mathematica? The context is that a reaction is carried out by varying temperature pressure and vessel volume. I want to find the optimum combination of the three to maximize the product. Each element of the tensor represents a value of the product produced corresponding to a specific combination of temperature pressure and volume.
Given some matrix, tensor, or basically any list-of-lists of real numbers, you can simply use the Max function to determine the maximum value and then Position to say where it is. Assuming your data isn't enormous (requiring some conservative/careful approach to save time/memory), this should be fine.
For example, here is a random list of lists of of lists of reals:
data = Table[RandomReal[],
{i, 1, RandomInteger[{4, 8}]},
{j, 1, RandomInteger[{4, 8}]},
{k, 1, RandomInteger[{4, 8}]}
];
You can just do:
m = Max[data]
Position[data, m]
This will tell you the position of the maximum value. If you did random integers instead, you could have ties, in which case you might have repeats:
data = Table[RandomInteger[{1, 10}],
{i, 1, RandomInteger[{4, 8}]},
{j, 1, RandomInteger[{4, 8}]},
{k, 1, RandomInteger[{4, 8}]}
];
m = Max[data]
Position[data, m]
Table[RandomInteger[100, 3], 3]
Prepend[Ordering[%[[First[Ordering[Reverse#*Sort /# %, -1]]]], -1],
First[Ordering[Reverse#*Sort /# %, -1]]]
% stands for the tensor to sort, in this case it's a random tensor generated from Table[RandomInteger[100, 3], 3]
This gives the position and value in one shot.
(m = RandomReal[{-1, 1}, {4, 3, 2}]) // MatrixForm
First#MaximalBy[
Flatten[MapIndexed[ {##} &, #, {-1}], ArrayDepth[#] - 1],
First] &#m
{0.903213, {3, 2, 2}}
Here is an alternate that will work with ragged lists:
Module[{h},
First#MaximalBy[List ### Flatten[MapIndexed[h### &, #, {-1}]],
First]] &#{{1, 2, 3}, {4, 5, {2, 3}}}
{5, {2, 2}}
I'm looking for a fast implementation for the following, I'll call it Position2D for lack of a better term:
Position2D[ matrix, sub_matrix ]
which finds the locations of sub_matrix inside matrix and returns the upper left and lower right row/column of a match.
For example, this:
Position2D[{
{0, 1, 2, 3},
{1, 2, 3, 4},
{2, 3, 4, 5},
{3, 4, 5, 6}
}, {
{2, 3},
{3, 4}
}]
should return this:
{
{{1, 3}, {2, 4}},
{{2, 2}, {3, 3}},
{{3, 1}, {4, 2}}
}
It should be fast enough to work quickly on 3000x2000 matrices with 100x100 sub-matrices. For simplicity, it is enough to only consider integer matrices.
Algorithm
The following code is based on an efficient custom position function to find positions of (possibly overlapping) integer sequences in a large integer list. The main idea is that we can first try to eficiently find the positions where the first row of the sub-matrix is in the Flatten-ed large matrix, and then filter those, extracting full sub-matrices and comparing to the sub-matrix of interest. This will be efficient for most cases except very pathological ones (those, for which this procedure would generate a huge number of potential position candidates, while the true number of entries of the sub-matrix would be much smaller. But such cases seem rather unlikely generally, and then, further improvements to this simple scheme can be made).
For large matrices, the proposed solution will be about 15-25 times faster than the solution of #Szabolcs when a compiled version of sequence positions function is used, and 3-5 times faster for the top-level implementation of sequence positions - finding function. The actual speedup depends on matrix sizes, it is more for larger matrices. The code and benchmarks are below.
Code
A generally efficient function for finding positions of a sub-list (sequence)
These helper functions are due to Norbert Pozar and taken from this Mathgroup thread. They are used to efficiently find starting positions of an integer sequence in a larger list (see the mentioned post for details).
Clear[seqPos];
fdz[v_] := Rest#DeleteDuplicates#Prepend[v, 0];
seqPos[list_List, seq_List] :=
Fold[
fdz[#1 (1 - Unitize[list[[#1]] - #2])] + 1 &,
fdz[Range[Length[list] - Length[seq] + 1] *
(1 - Unitize[list[[;; -Length[seq]]] - seq[[1]]])] + 1,
Rest#seq
] - Length[seq];
Example of use:
In[71]:= seqPos[{1,2,3,2,3,2,3,4},{2,3,2}]
Out[71]= {2,4}
A faster position-finding function for integers
However fast seqPos might be, it is still the major bottleneck in my solution. Here is a compiled-to-C version of this, which gives another 5x performance boost to my code:
seqposC =
Compile[{{list, _Integer, 1}, {seq, _Integer, 1}},
Module[{i = 1, j = 1, res = Table[0, {Length[list]}], ctr = 0},
For[i = 1, i <= Length[list], i++,
If[list[[i]] == seq[[1]],
While[j < Length[seq] && i + j <= Length[list] &&
list[[i + j]] == seq[[j + 1]],
j++
];
If[j == Length[seq], res[[++ctr]] = i];
j = 1;
]
];
Take[res, ctr]
], CompilationTarget -> "C", RuntimeOptions -> "Speed"]
Example of use:
In[72]:= seqposC[{1, 2, 3, 2, 3, 2, 3, 4}, {2, 3, 2}]
Out[72]= {2, 4}
The benchmarks below have been redone with this function (also the code for main function is slightly modified )
Main function
This is the main function. It finds positions of the first row in a matrix, and then filters them, extracting the sub-matrices at these positions and testing against the full sub-matrix of interest:
Clear[Position2D];
Position2D[m_, what_,seqposF_:Automatic] :=
Module[{posFlat, pos2D,sp = If[seqposF === Automatic,seqposC,seqposF]},
With[{dm = Dimensions[m], dwr = Reverse#Dimensions[what]},
posFlat = sp[Flatten#m, First#what];
pos2D =
Pick[Transpose[#], Total[Clip[Reverse#dm - # - dwr + 2, {0, 1}]],2] &#
{Mod[posFlat, #, 1], IntegerPart[posFlat/#] + 1} &#Last[dm];
Transpose[{#, Transpose[Transpose[#] + dwr - 1]}] &#
Select[pos2D,
m[[Last## ;; Last## + Last#dwr - 1,
First## ;; First## + First#dwr - 1]] == what &
]
]
];
For integer lists, the faster compiled subsequence position-finding function seqposC can be used (this is a default). For generic lists, one can supply e.g. seqPos, as a third argument.
How it works
We will use a simple example to dissect the code and explain its inner workings. This defines our test matrix and sub-matrix:
m = {{0, 1, 2, 3}, {1, 2, 3, 4}, {2, 3, 4, 5}};
what = {{2, 3}, {3, 4}};
This computes the dimensions of the above (it is more convenient to work with reversed dimensions for a sub-matrix):
In[78]:=
dm=Dimensions[m]
dwr=Reverse#Dimensions[what]
Out[78]= {3,4}
Out[79]= {2,2}
This finds a list of starting positions of the first row ({2,3} here) in the Flattened main matrix. These positions are at the same time "flat" candidate positions of the top left corner of the sub-matrix:
In[77]:= posFlat = seqPos[Flatten#m, First#what]
Out[77]= {3, 6, 9}
This will reconstruct the 2D "candidate" positions of the top left corner of a sub-matrix in a full matrix, using the dimensions of the main matrix:
In[83]:= posInterm = Transpose#{Mod[posFlat,#,1],IntegerPart[posFlat/#]+1}&#Last[dm]
Out[83]= {{3,1},{2,2},{1,3}}
We can then try using Select to filter them out, extracting the full sub-matrix and comparing to what, but we'll run into a problem here:
In[84]:=
Select[posInterm,
m[[Last##;;Last##+Last#dwr-1,First##;;First##+First#dwr-1]]==what&]
During evaluation of In[84]:= Part::take: Cannot take positions 3 through 4
in {{0,1,2,3},{1,2,3,4},{2,3,4,5}}. >>
Out[84]= {{3,1},{2,2}}
Apart from the error message, the result is correct. The error message itself is due to the fact that for the last position ({1,3}) in the list, the bottom right corner of the sub-matrix will be outside the main matrix. We could of course use Quiet to simply ignore the error messages, but that's a bad style. So, we will first filter those cases out, and this is what the line Pick[Transpose[#], Total[Clip[Reverse#dm - # - dwr + 2, {0, 1}]], 2] &# is for. Specifically, consider
In[90]:=
Reverse#dm - # - dwr + 2 &#{Mod[posFlat, #, 1],IntegerPart[posFlat/#] + 1} &#Last[dm]
Out[90]= {{1,2,3},{2,1,0}}
The coordinates of the top left corners should stay within a difference of dimensions of matrix and a sub-matrix. The above sub-lists were made of x and y coordiantes of top - left corners. I added 2 to make all valid results strictly positive. We have to pick only coordiantes at those positions in Transpose#{Mod[posFlat, #, 1], IntegerPart[posFlat/#] + 1} &#Last[dm] ( which is posInterm), at which both sub-lists above have strictly positive numbers. I used Total[Clip[...,{0,1}]] to recast it into picking only at those positions at which this second list has 2 (Clip converts all positive integers to 1, and Total sums numbers in 2 sublists. The only way to get 2 is when numbers in both sublists are positive).
So, we have:
In[92]:=
pos2D=Pick[Transpose[#],Total[Clip[Reverse#dm-#-dwr+2,{0,1}]],2]&#
{Mod[posFlat,#,1],IntegerPart[posFlat/#]+1}&#Last[dm]
Out[92]= {{3,1},{2,2}}
After the list of 2D positions has been filtered, so that no structurally invalid positions are present, we can use Select to extract the full sub-matrices and test against the sub-matrix of interest:
In[93]:=
finalPos =
Select[pos2D,m[[Last##;;Last##+Last#dwr-1,First##;;First##+First#dwr-1]]==what&]
Out[93]= {{3,1},{2,2}}
In this case, both positions are genuine. The final thing to do is to reconstruct the positions of the bottom - right corners of the submatrix and add them to the top-left corner positions. This is done by this line:
In[94]:= Transpose[{#,Transpose[Transpose[#]+dwr-1]}]&#finalPos
Out[94]= {{{3,1},{4,2}},{{2,2},{3,3}}}
I could have used Map, but for a large list of positions, the above code would be more efficient.
Example and benchmarks
The original example:
In[216]:= Position2D[{{0,1,2,3},{1,2,3,4},{2,3,4,5},{3,4,5,6}},{{2,3},{3,4}}]
Out[216]= {{{3,1},{4,2}},{{2,2},{3,3}},{{1,3},{2,4}}}
Note that my index conventions are reversed w.r.t. #Szabolcs' solution.
Benchmarks for large matrices and sub-matrices
Here is a power test:
nmat = 1000;
(* generate a large random matrix and a sub-matrix *)
largeTestMat = RandomInteger[100, {2000, 3000}];
what = RandomInteger[10, {100, 100}];
(* generate upper left random positions where to insert the submatrix *)
rposx = RandomInteger[{1,Last#Dimensions[largeTestMat] - Last#Dimensions[what] + 1}, nmat];
rposy = RandomInteger[{1,First#Dimensions[largeTestMat] - First#Dimensions[what] + 1},nmat];
(* insert the submatrix nmat times *)
With[{dwr = Reverse#Dimensions[what]},
Do[largeTestMat[[Last#p ;; Last#p + Last#dwr - 1,
First#p ;; First#p + First#dwr - 1]] = what,
{p,Transpose[{rposx, rposy}]}]]
Now, we test:
In[358]:= (ps1 = position2D[largeTestMat,what])//Short//Timing
Out[358]= {1.39,{{{1,2461},{100,2560}},<<151>>,{{1900,42},{1999,141}}}}
In[359]:= (ps2 = Position2D[largeTestMat,what])//Short//Timing
Out[359]= {0.062,{{{2461,1},{2560,100}},<<151>>,{{42,1900},{141,1999}}}}
(the actual number of sub-matrices is smaller than the number we try to generate, since many of them overlap and "destroy" the previously inserted ones - this is so because the sub-matrix size is a sizable fraction of the matrix size in our benchmark).
To compare, we should reverse the x-y indices in one of the solutions (level 3), and sort both lists, since positions may have been obtained in different order:
In[360]:= Sort#ps1===Sort[Reverse[ps2,{3}]]
Out[360]= True
I do not exclude a possibility that further optimizations are possible.
This is my implementation:
position2D[m_, k_] :=
Module[{di, dj, extractSubmatrix, pos},
{di, dj} = Dimensions[k] - 1;
extractSubmatrix[{i_, j_}] := m[[i ;; i + di, j ;; j + dj]];
pos = Position[ListCorrelate[k, m], ListCorrelate[k, k][[1, 1]]];
pos = Select[pos, extractSubmatrix[#] == k &];
{#, # + {di, dj}} & /# pos
]
It uses ListCorrelate to get a list of potential positions, then filters those that actually match. It's probably faster on packed real matrices.
As per Leonid's suggestion here's my solution. I know it isn't very efficient (it's about 600 times slower than Leonid's when I timed it) but it's very short, rememberable, and a nice illustration of a rarely used function, PartitionMap. It's from the Developer package, so it needs a Needs["Developer`"] call first.
Given that, Position2D can be defined as:
Position2D[m_, k_] := Position[PartitionMap[k == # &, m, Dimensions[k], {1, 1}], True]
This only gives the upper-left coordinates. I feel the lower-right coordinates are really redundant, since the dimensions of the sub-matrix are known, but if the need arises one can add those to the output by prepending {#, Dimensions[k] + # - {1, 1}} & /# to the above definition.
How about something like
Position2D[bigMat_?MatrixQ, smallMat_?MatrixQ] :=
Module[{pos, sdim = Dimensions[smallMat] - 1},
pos = Position[bigMat, smallMat[[1, 1]]];
Quiet[Select[pos, (MatchQ[
bigMat[[Sequence##Thread[Span[#, # + sdim]]]], smallMat] &)],
Part::take]]
which will return the top left-hand positions of the submatrices.
Example:
Position2D[{{0, 1, 2, 3}, {1, 2, 3, 4}, {2, 3, 4, 5}, {3, 5, 5, 6}},
{{2, 3}, {3, _}}]
(* Returns: {{1, 3}, {2, 2}, {3, 1}} *)
And to search a 1000x1000 matrix, it takes about 2 seconds on my old machine
SeedRandom[1]
big = RandomInteger[{0, 10}, {1000, 1000}];
Position2D[big, {{1, 1, _}, {1, 1, 1}}] // Timing
(* {1.88012, {{155, 91}, {295, 709}, {685, 661},
{818, 568}, {924, 45}, {981, 613}}} *)
Example:
list:={ Plus[1,1], Times[2,3] }
When looking at list, I get
{2,6}
I want to keep them unevaluated (as above) so that list returns
{ Plus[1,1], Times[2,3] }
Later I want to evaluate the functions in list sequence to get
{2,6}
The number of unevaluated functions in list is not known beforehand. Besides Plus, user defined functions like f[x_] may be stored in list
I hope the example is clear.
What is the best way to do this?
The best way is to store them in Hold, not List, like so:
In[255]:= f[x_] := x^2;
lh = Hold[Plus[1, 1], Times[2, 3], f[2]]
Out[256]= Hold[1 + 1, 2 3, f[2]]
In this way, you have full control over them. At some point, you may call ReleaseHold to evaluate them:
In[258]:= ReleaseHold#lh
Out[258]= Sequence[2, 6, 4]
If you want the results in a list rather than Sequence, you may use just List##lh instead. If you need to evaluate a specific one, simply use Part to extract it:
In[261]:= lh[[2]]
Out[261]= 6
If you insist on your construction, here is a way:
In[263]:= l:={Plus[1,1],Times[2,3],f[2]};
Hold[l]/.OwnValues[l]
Out[264]= Hold[{1+1,2 3,f[2]}]
EDIT
In case you have some functions/symbols with UpValues which can evaluate even inside Hold, you may want to use HoldComplete in place of Hold.
EDIT2
As pointed by #Mr.Wizard in another answer, sometimes you may find it more convenient to have Hold wrapped around individual items in your sequence. My comment here is that the usefulness of both forms is amplified once we realize that it is very easy to transform one into another and back. The following function will split the sequence inside Hold into a list of held items:
splitHeldSequence[Hold[seq___], f_: Hold] := List ## Map[f, Hold[seq]]
for example,
In[274]:= splitHeldSequence[Hold[1 + 1, 2 + 2]]
Out[274]= {Hold[1 + 1], Hold[2 + 2]}
grouping them back into a single Hold is even easier - just Apply Join:
In[275]:= Join ## {Hold[1 + 1], Hold[2 + 2]}
Out[275]= Hold[1 + 1, 2 + 2]
The two different forms are useful in diferrent circumstances. You can easily use things such as Union, Select, Cases on a list of held items without thinking much about evaluation. Once finished, you can combine them back into a single Hold, for example, to feed as unevaluated sequence of arguments to some function.
EDIT 3
Per request of #ndroock1, here is a specific example. The setup:
l = {1, 1, 1, 2, 4, 8, 3, 9, 27}
S[n_] := Module[{}, l[[n]] = l[[n]] + 1; l]
Z[n_] := Module[{}, l[[n]] = 0; l]
placing functions in Hold:
In[43]:= held = Hold[Z[1], S[1]]
Out[43]= Hold[Z[1], S[1]]
Here is how the exec function may look:
exec[n_] := MapAt[Evaluate, held, n]
Now,
In[46]:= {exec[1], exec[2]}
Out[46]= {Hold[{0, 1, 1, 2, 4, 8, 3, 9, 27}, S[1]], Hold[Z[1], {1, 1, 1, 2, 4, 8, 3, 9, 27}]}
Note that the original variable held remains unchanged, since we operate on the copy. Note also that the original setup contains mutable state (l), which is not very idiomatic in Mathematica. In particular, the order of evaluations matter:
In[61]:= Reverse[{exec[2], exec[1]}]
Out[61]= {Hold[{0, 1, 1, 2, 4, 8, 3, 9, 27}, S[1]], Hold[Z[1], {2, 1, 1, 2, 4, 8, 3, 9, 27}]}
Whether or not this is desired depends on the specific needs, I just wanted to point this out. Also, while the exec above is implemented according to the requested spec, it implicitly depends on a global variable l, which I consider a bad practice.
An alternative way to store functions suggested by #Mr.Wizard can be achieved e.g. like
In[63]:= listOfHeld = splitHeldSequence[held]
Out[63]= {Hold[Z1], Hold[S1]}
and here
In[64]:= execAlt[n_] := MapAt[ReleaseHold, listOfHeld, n]
In[70]:= l = {1, 1, 1, 2, 4, 8, 3, 9, 27} ;
{execAlt[1], execAlt[2]}
Out[71]= {{{0, 1, 1, 2, 4, 8, 3, 9, 27}, Hold[S[1]]}, {Hold[Z[1]], {1, 1, 1, 2, 4, 8, 3, 9, 27}}}
The same comments about mutability and dependence on a global variable go here as well. This last form is also more suited to query the function type:
getType[n_, lh_] := lh[[n]] /. {Hold[_Z] :> zType, Hold[_S] :> sType, _ :> unknownType}
for example:
In[172]:= getType[#, listOfHeld] & /# {1, 2}
Out[172]= {zType, sType}
The first thing that spings to mind is to not use List but rather use something like this:
SetAttributes[lst, HoldAll];
heldL=lst[Plus[1, 1], Times[2, 3]]
There will surely be lots of more erudite suggestions though!
You can also use Hold on every element that you want held:
a = {Hold[2 + 2], Hold[2*3]}
You can use HoldForm on either the elements or the list, if you want the appearance of the list without Hold visible:
b = {HoldForm[2 + 2], HoldForm[2*3]}
c = HoldForm#{2 + 2, 2*3}
{2 + 2, 2 * 3}
And you can recover the evaluated form with ReleaseHold:
a // ReleaseHold
b // ReleaseHold
c // ReleaseHold
Out[8]= {4, 6}
Out[9]= {4, 6}
Out[10]= {4, 6}
The form Hold[2+2, 2*3] or that of a and b above are good because you can easily add terms with e.g. Append. For b type is it logically:
Append[b, HoldForm[8/4]]
For Hold[2+2, 2*3]:
Hold[2+2, 2*3] ~Join~ Hold[8/4]
Another way:
lh = Function[u, Hold#u, {HoldAll, Listable}];
k = lh#{2 + 2, Sin[Pi]}
(*
->{Hold[2 + 2], Hold[Sin[\[Pi]]]}
*)
ReleaseHold#First#k
(*
-> 4
*)
When manipulating matrices it is often convenient to change their shape. For instance, to turn an N x M sized matrix into a vector of length N X M. In MATLAB a reshape function exists:
RESHAPE(X,M,N) returns the M-by-N matrix whose elements are taken columnwise from X. An error results if X does not have M*N elements.
In the case of converting between a matrix and vector I can use the Mathematica function Flatten which takes advantage of Mathematica's nested list representation for matrices. As a quick example, suppose I have a matrix X:
With Flatten[X] I can get the vector {1,2,3,...,16}. But what would be far more useful is something akin to applying Matlab's reshape(X,2,8) which would result in the following Matrix:
This would allow creation of arbitrary matrices as long as the dimensions equal N*M. As far as I can tell, there isn't anything built in which makes me wonder if someone hasn't coded up a Reshape function of their own.
Reshape[mtx_, _, n_] := Partition[Flatten[mtx], n]
ArrayReshape does exactly that.
Reshape[list_, dimensions_] :=
First[Fold[Partition[#1, #2] &, Flatten[list], Reverse[dimensions]]]
Example Usage:
In: Reshape[{1,2,3,4,5,6},{2,3}]
Out: {{1,2,3},{4,5,6}}
This works with arrays of arbitrary depth.
I know this is an old thread but for the sake of the archives and google searches I've got a more general way that allows a length m*n*... list to be turned into an m*n*... array:
Reshape[list_, shape__] := Module[{i = 1},
NestWhile[Partition[#, shape[[i]]] &, list, ++i <= Length[shape] &]
]
Eg:
In:= Reshape[Range[8], {2, 2, 2}]
Out:= {{{1, 2}, {3, 4}}, {{5, 6}, {7, 8}}}
There is now also a new function ArrayReshape[].
Example:
{{1, 2, 3}, {4, 5, 6}} // MatrixForm
ArrayReshape[{{1, 2, 3}, {4, 5, 6}}, {3, 2}] // MatrixForm