Mapping a function over the parts of a deeply nested Array

I have two tensors:

    tensorS = Array[Subscript[s, #1, #2, #3, #4] &, {2, 16, 16, 19}];
tensorR = Array[Subscript[r, #1, #2, #3] &, {2, 16, 19}];


Here is a Part of the solution that I want to obtain:

    Map[Plus[tensorR[[1, 1]], #] &, tensorS[[1, 1]], {1}];


which is the same as:

    Thread[Plus[Transpose[tensorS[[1, 1]]], tensorR[[1, 1]]], List];


or:

    Inner[Plus, tensorS[[1, 1]], tensorR[[1, 1]], List];


The resulting tensor should have Dimensions {2,16,16,19}.

It can be seen from the part of a solution, that I want to add every element of a tensorR (defined by it's indices i1,i2,i3) to the corresponding elements of a tensorS i1,i2,i3,i4, for all indices i3 of a tensorS. First i1, second i2, and third index i3 of tensorR correspond to first i1, second i2 and fourth i4 index of tensorS, respectively.

This is the solution I want to get, but without using Table:

    Table[Map[Plus[tensorR[[i, j]], #] &, tensorS[[i, j]], {1}], {i, 1, 2}, {j, 1, 16}];


$Q$: How to use the combination od Thread, Map, MapThread, Transpose and Inner functions to obtain the above result? I want to avoid using Part and Table.

I'm sure that there's elegant solution that can be written in one line, but I'm not that good with deeply nested lists, so I decided to ask for your help. I've searched the forum and couldn't find the solution. I apologize if my question is a duplicate.

Here is a way to use MapThread:

MapThread[Function[{r, s}, r + # & /@ s], {tensorR, tensorS}, 2]


For numeric tensors, it can be compiled to squeeze out a little more performance:

Compile[{{tensorR, _Real, 3}, {tensorS, _Real, 4}}
, MapThread[Function[{r, s}, r + # & /@ s], {tensorR, tensorS}, 2]
]


Performance Measurements

@kguler's solution has notational appeal. Not only that, but on my machine (V10.0.0, Win7, 64-bit, 4 cpus) @kguler's method runs faster than the Table solution for symbolic tensors. And, with a slight modification, it runs faster than both Table and MapThread for numeric tensors.

Here are the combinations I tried, using larger symbolic tensors and much larger numeric tensors:

Symbolic Tensors

\$HistoryLength = 0;

symbolsS = Array[Subscript[s, #1, #2, #3, #4] &, {20, 16, 16, 190}];
symbolsR = Array[Subscript[r, #1, #2, #3] &, {20, 16, 190}];

(* bst *)
Table[symbolsR[[i, j]] + # & /@ symbolsS[[i, j]], {i, 1, 20}, {j, 1, 16}] ; // Timing
(* {6.021639, Null} *)

(* kguler *)
Transpose[Transpose[symbolsS, {1, 2, 4, 3}] + symbolsR, {1, 2, 4, 3}]; // Timing
(* {1.591210, Null} *)

(* kguler, modified *)
With[{t = Transpose[#, {1, 2, 4, 3}]&}, t[t @ symbolsS + symbolsR]]; // Timing
(* {1.045207, Null} *)

(* wreach *)
MapThread[Function[{r, s}, r + #& /@ s], {symbolsR, symbolsS}, 2]; // Timing
(* {0.967206, Null} *)

(* mr.wizard / simon woods *)
smartThread[symbolsS + symbolsR, 1]; // Timing
(* {1.528810, Null} *)


Numeric Tensors

SeedRandom[1234];
realsS = RandomReal[1, {20, 160, 160, 190}];
realsR = RandomReal[1, {20, 160, 190}];

(* bst *)
Table[realsR[[i, j]] + # & /@ realsS[[i, j]], {i, 1, 20}, {j, 1, 160}] ; // Timing
(* {4.290027, Null} *)

(* kguler *)
Transpose[Transpose[realsS, {1,2,4,3}] + realsR,{1,2,4,3}]; // Timing
(* {2.839218, Null} *)

(* kguler, modified *)
With[{t = Transpose[#, {1, 2, 4, 3}]&}, t[t @ realsS + realsR]]; // Timing
(* {1.731611, Null} *)

(* wreach *)
MapThread[Function[{r, s}, r + #& /@ s], {realsR, realsS}, 2]; // Timing
(* {2.433616, Null} *)

(* wreach, compiled *)
Compile[{{tensorR, _Real, 3}, {tensorS, _Real, 4}}
, MapThread[Function[{r, s}, r + # & /@ s], {tensorR, tensorS}, 2]
][realsR, realsS]; // Timing
(* {1.903212, Null} *)

(* mr.wizard / simon woods *)
smartThread[realsS + realsR, 1]; // Timing
(* {2.745618, Null} *)


I did not notice significant differences in performance when pinning the kernel to a single CPU. Neither was there a noticeable difference when calling ClearSystemCache[] before each run.

Here is a summary table of performance, with V10, V9, V8 and V7 numbers for comparison:

Test                        V10  V9   V8   V7
symbolic bst                6.02 4.82 5.21 1.01
symbolic kguler             1.59 1.39 1.58 1.23
symbolic mr.W / simon woods 1.53 1.44 2.15 1.64
symbolic kguler, modified   1.05 1.22 1.30 1.03
symbolic wreach             0.97 0.78 0.87 0.95

numeric  bst                4.29 4.70 4.21 2.61
numeric  kguler             2.83 3.26 2.62 2.62
numeric  mr.W / simon woods 2.75 2.59 2.26 2.15
numeric  wreach             2.43 2.63 2.53 2.25
numeric  wreach, compiled   1.90 1.70 1.40 fail
numeric  kguler, modified   1.73 1.79 1.58 1.62


NOTE: The compiled MapThread version failed to execute properly due to a compilation error on V7.

• You need another t wrapping t@x +y in the modified kguler. (+1 of course) – kglr Sep 6 '14 at 8:02
• @kguler Yes, it was a transcription error. My results stand. – WReach Sep 6 '14 at 12:33
• @kguler I don't normally like to get drawn into microbenchmarking discussions, but I felt it important to note that your solution was running very quickly in my environment despite reports to the contrary. My tests were aimed primarily at trying to determine whether this was a fluke result, or consistent. It seems consistent, under these conditions at least. – WReach Sep 6 '14 at 13:36
• @WReach Thanks a lot. This was the answer that I was looking for. Before accepting your solution, I needed some time to build my calculation model and test the solution within, which fits in perfectly. – bst Sep 26 '14 at 16:01

Use the second argument of Transpose: transpose the last two levels of tensorS, add tensorR, transpose the last two levels again:

tensorS = Array[Subscript[s, #1, #2, #3, #4] &, {2, 16, 16, 19}];
tensorR = Array[Subscript[r, #1, #2, #3] &, {2, 16, 19}];
opres = Table[Map[Plus[tensorR[[i, j]], #]&, tensorS[[i, j]], {1}], {i, 1, 2}, {j, 1, 16}];

res1 = Transpose[(Transpose[tensorS, {1, 2, 4, 3}] + tensorR), {1, 2, 4, 3}];
Dimensions[res1]
(* {2,16,16,19 *)
opres == res1
(* True *)

• Certainly +1 for elegance. Your solution is about 30% slower than the OP's Table- approach (if this matters at all) – eldo Sep 5 '14 at 17:53
• Thanks @eldo. Yes, Table is much faster - by over 50% on my machine. – kglr Sep 5 '14 at 18:02
• Performance matters a lot, since I need a solution that will work fast on higher-rank tensors. – bst Sep 5 '14 at 18:24
• On my machine, this method runs faster than the Table approach, and With[{t = Transpose[#, {1, 2, 4, 3}]&}, t @ symbolsS + symbolsR] is even faster still (see the testing details in my response). – WReach Sep 6 '14 at 6:54
• I transcribed that incorrectly, I meant With[{t = Transpose[#, {1, 2, 4, 3}]&}, t[t @ symbolsS + symbolsR]]. It is slightly faster. – WReach Sep 6 '14 at 12:34
1. Load Simon Woods's smartThread from: How can I make threading more flexible?

2. Write simply:

smartThread[tensorR + tensorS, 1]

3. Be happy.

:-)

• Thanks for pointing out. I accepted WReach's answer just because it works great for me, and I didn't have that much time to test smartThread's behavior within my calculation model. – bst Sep 26 '14 at 16:10