5
$\begingroup$

I have two lists of the same length n.

For the case of n=5, these would be:

a = {a1, a2, a3, a4, a5};
b = {b1, b2, b3, b4, b5};

I want to Transpose these lists but with an offset of 1 creating a resulting list with one additional element. Such as:

wantResult = {{a1},{a2,b1},{a3,b2},...,{b5}}

I can sort of do this by prepending {} to a, and appending {} to b resulting in the following two lists:

az = Append[a,{}] = {a1,a2,a3,a4,a5,{}}
bz = Prepend[b,{}] = {{},b1,b2,b3,b4,b5}

Then Transpose[{az,bz}], but I get:

{ {a1,{}},{a2,b1},{a3,b2},...,{{},b5} }

where the empty braces/lists are the problem :(..

Any ideas would be very helpful.

$\endgroup$
2
  • $\begingroup$ Map[Flatten]@Transpose[{az,bz}]? $\endgroup$
    – kglr
    Feb 6 at 9:49
  • $\begingroup$ Thank you! Many great answers below. I am working through them and dread having to pick a single one to mark as answered. This is a great collection of variations and is growing my mind already. $\endgroup$ Feb 6 at 15:16

9 Answers 9

3
$\begingroup$
{#[[{1}]], ##2, #[[{-1}]]} & @@ Transpose[{a, RotateRight @ b}]
{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}

Also

Inner[ List, a, RotateRight @ b, {#[[{1}]], ##2, #[[{-1}]]} &]
{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}

For fun:

☺ = {#[[{1}]], ##2, #[[{-1}]]} & @@ ({#, {##2, #} & @@ #2}\[Transpose]) &;

☺[a, b]
{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}
$\endgroup$
2
  • $\begingroup$ it was fun! .. thanks for the great answers :) $\endgroup$ Feb 6 at 15:13
  • $\begingroup$ I accepted this answer as it profiles fastest. All the answers work, and make a great collection of alternatives to demonstrate the many ways to achieve this task. $\endgroup$ Feb 6 at 17:28
7
$\begingroup$

Using Partition and Riffle:

If both lists have the same length, then:

a = {a1, a2, a3, a4, a5};
b = {b1, b2, b3, b4, b5};


g[a_List, b_List] := {{First@a}}~Join~
  Partition[Riffle[Rest@a, Most@b], UpTo[2]]~Join~{{Last@b}}

g[a, b]

Using TakeList:

h[a_List, b_List] := 
 Module[{chunks = {1, Sequence @@ ConstantArray[2, Length@a - 1], 1}},
  Riffle[a, b] // TakeList[#, chunks] & // Map[Reverse]
  ]

h[a, b]

Using Transpose:

Transpose[{Append[a, x], Prepend[b, x]}] /. x -> Nothing

Result(s):

{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}

$\endgroup$
6
$\begingroup$
f[x_, y_] := Module[{r = Thread[{Most@x, Rest@y}]},
  Join[{{x[[1]]}}, r, {{y[[-1]]}}]]

Testing

am = Array[a, 10];
bm = Array[b, 10];
f[am, bm]

yields: {{a[1]}, {a[1], b[2]}, {a[2], b[3]}, {a[3], b[4]}, {a[4], b[5]}, {a[5], b[6]}, {a[6], b[7]}, {a[7], b[8]}, {a[8], b[9]}, {a[9], b[10]}, {b[10]}}

$\endgroup$
5
$\begingroup$

Alternative ways to combine Partition and Riffle:

Partition[Riffle[a, b], 2, 2, {-1, 1}, {}, Reverse @* List]
{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}
Partition[Riffle[Append[Last @ b] @ a, b, {3, -2, 2}], 2, 2, {-1, 1}, {}]
{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}
$\endgroup$
4
$\begingroup$
a = {a1, a2, a3, a4, a5};
b = {b1, b2, b3, b4, b5};

MapAt[Nothing, {1, 2}] @ Append[{Last @ b}] @
 Thread[{a, RotateRight @ b}]

{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}

Append[{Last @ b}] @ Prepend[{First @ a}] @ 
 Thread[{a[[2 ;;]], b[[;; -2]]}]

{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}

$\endgroup$
4
$\begingroup$

Using Flatten to transpose a 'ragged' array (see here):

Flatten[{Rest@a,b},{{2}}]//Prepend[{First@a}]

(* {{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}} *)
$\endgroup$
3
$\begingroup$
a = {a1, a2, a3, a4, a5};
b = {b1, b2, b3, b4, b5};

Another way using Insert and Thread:

l1 = Thread[{a, b}];
l2 = Thread[{a[[2 ;;]], b[[;; -2]]}];

Insert[List /@ Diagonal@#[[{1, -1}]] &@l1, Splice@l2, 2]

{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}
$\endgroup$
2
$\begingroup$

I did a quick profile of all the answers so far. They all work and thank you. I will mark the fastest one as the answer as that's a key goal of mine.

a = {a1, a2, a3, a4, a5};
b = {b1, b2, b3, b4, b5};


f[x_, y_] := 
  Module[{r = Thread[{Most@x, Rest@y}]}, 
   Join[{{x[[1]]}}, r, {{y[[-1]]}}]];
f[a, b];

g[a_List, b_List] := {{First@a}}~Join~
   Partition[Riffle[Rest@a, Most@b], UpTo[2]]~Join~{{Last@b}};
g[a, b];

h[a_List, b_List] := 
  Module[{chunks = {1, Sequence @@ ConstantArray[2, Length@a - 1], 
      1}}, Riffle[a, b] // TakeList[#, chunks] & // Map[Reverse]];
h[a, b];

(*Transpose[{Append[a,x],Prepend[b,x]}]/. x->Nothing*)
i[x_, y_] := 
  Transpose[{Append[x, u], Prepend[y, u]}] /. u -> Nothing;
i[a, b];

(*{#[[{1}]],##2,#[[{-1}]]}&@@Transpose[{a,RotateRight@b}]*)
j[x_, y_] := {#[[{1}]], ##2, #[[{-1}]]} & @@ 
   Transpose[{x, RotateRight@y}];
j[a, b];

(*Inner[List,a,RotateRight@b,{#[[{1}]],##2,#[[{-1}]]}&]*)
k[x_, y_] := 
  Inner[List, x, RotateRight@y, {#[[{1}]], ##2, #[[{-1}]]} &];
k[a, b];

(*\[HappySmiley]={#[[{1}]],##2,#[[{-1}]]}&@@({#,{##2,#}&@@#2}\
\[Transpose])&;*)
\[HappySmiley] = {#[[{1}]], ##2, #[[{-1}]]} & @@ ({#, {##2, #} & @@ \
#2}\[Transpose]) &;
\[HappySmiley][a, b];

(*MapAt[Nothing,{1,2}]@Append[{Last@b}]@Thread[{a,RotateRight@b}]*)
l[x_, y_] := 
  MapAt[Nothing, {1, 2}]@Append[{Last@y}]@Thread[{x, RotateRight@y}];
l[a, b];

(*Append[{Last@b}]@Prepend[{First@a}]@Thread[{a[[2;;]],b[[;;-2]]}]*)
m[x_, y_] := 
  Append[{Last@x}]@
   Prepend[{First@y}]@Thread[{x[[2 ;;]], y[[;; -2]]}];
m[a, b];

(*Partition[Riffle[a,b],2,2,{-1,1},{},Reverse@*List]*)
n[x_, y_] := Partition[Riffle[x, y], 2, 2, {-1, 1}, {}, Reverse@*List];
n[a, b];

(*Partition[Riffle[Append[Last@b]@a,b,{3,-2,2}],2,2,{-1,1},{}]*)
o[x_, y_] := 
  Partition[Riffle[Append[Last@y]@a, y, {3, -2, 2}], 2, 
   2, {-1, 1}, {}];
o[a, b];

Print["f[a,b]", RepeatedTiming[f[a, b], 1]]
Print["g[a,b]", RepeatedTiming[g[a, b], 1]]
Print["h[a,b]", RepeatedTiming[h[a, b], 1]]
Print["i[a,b]", RepeatedTiming[i[a, b], 1]]
Print["j[a,b]", RepeatedTiming[j[a, b], 1]]
Print["k[a,b]", RepeatedTiming[k[a, b], 1]]
Print["\[HappySmiley][a,b]", RepeatedTiming[\[HappySmiley][a, b], 1]]
Print["l[a,b]", RepeatedTiming[l[a, b], 1]]
Print["m[a,b]", RepeatedTiming[m[a, b], 1]]
Print["n[a,b]", RepeatedTiming[n[a, b], 1]]
Print["o[a,b]", RepeatedTiming[o[a, b], 1]]


f[a,b]{4.612*10^-6,{{a1},{a1,b2},{a2,b3},{a3,b4},{a4,b5},{b5}}}

g[a,b]{5.08331*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}

h[a,b]{7.72621*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}

i[a,b]{6.75102*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}

j[a,b]{4.82434*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}

k[a,b]{2.8945*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}

\[HappySmiley][a,b]{4.89292*10^-6,{{a1},{a2,b3},{a3,b4},{a4,b5},{a5,b1},{b2}}}

l[a,b]{3.28372*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}

m[a,b]{3.12413*10^-6,{{b1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{a5}}}

n[a,b]{4.9749*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}

o[a,b]{3.91459*10^-6,{{a1},{a2,b1},{a3,b2},{a4,b3},{a5,b4},{b5}}}
```
$\endgroup$
1
$\begingroup$
a = {a1, a2, a3, a4, a5};

b = {b1, b2, b3, b4, b5};

Using Splice (new in 12.1)

{{First @ a}, Splice @ Transpose[{Rest @ a, Most @ b}], {Last @ b}}

{{a1}, {a2, b1}, {a3, b2}, {a4, b3}, {a5, b4}, {b5}}

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.