Mapping a function over the parts of a deeply nested Array

Question

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.

Answer 1

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.

Answer 2

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 *)

Answer 3

1. Load Simon Woods's smartThread from: How can I make threading more flexible?

2. Write simply:

   smartThread[tensorR + tensorS, 1]
   

3. Be happy.

:-)