# How to double elements of a list given by their positions

Given that I have a list $\{P_0,P_1,P_2,\cdots,P_7\}$, where, $P_i$ is a real number or a list like {x,y}/{x,y,z}. Now I would like to double some elements according to given index(i) and interval(p). For instance,

$i=1,p=2$, the elements that will be doubled is $\{i-p-1,i,i+p+1\}=\{-2,1,4\}$. Namely, $P_1,P_4$ (delete $-2$ since $P_{-2}$ is non-existent)

$i=3,p=2$, the elements that will be doubled is $\{i-p-1,i,i+p+1\}=\{0,3,6\}$. Namely, $P_0,P_3,P_6$

### My trial

Firstly, I find the positions of the elements that need to be doubled, then applying ReplacePart[]

elemAdjust1[elems_, deg_, i_] :=
Module[{idx, n = Length[elems] - 1, new},
idx = Select[{i - deg - 1, i, i + deg + 1}, 0 <= # <= n &] + 1;
new = {#, #} & /@ elems[[idx]];
ReplacePart[elems, Thread[idx -> new] /. {x_, x_} :> Sequence[x, x]]
]


Another method came form J.M., i.e., with the help of Partition[]

elemAdjust2[elems_, deg_, i_] :=
Module[{idx, n = Length[elems] - 1, left, mid, right},
idx = Select[{i - deg - 1, i, i + deg + 1}, 0 <= # <= n &] + 1;
left = Take[elems, {1, idx[[1]] - 1}];
right = Take[elems, {idx[[-1]] + 1, n + 1}];
mid = Take[elems, {idx[[1]], idx[[-1]]}];
mid = Flatten[Partition[mid, deg + 2, deg + 1, {-1, 1}, {}], 1];
Join[left, mid, right]
]


### Test

pts = {P0, P1, P2, P3, P4, P5, P6, P7};
elemAdjust1[pts, 2, 1]
elemAdjust2[pts, 2, 1]
(*==> {P0, P1, P1, P2, P3, P4, P4, P5, P6, P7}*)
elemAdjust1[pts, 2, 2]
elemAdjust2[pts, 2, 2]
(*==> {P0, P1, P2, P2, P3, P4, P5, P5, P6, P7}*)
elemAdjust1[pts, 2, 3]
elemAdjust2[pts, 2, 3]
(*==> {P0, P0, P1, P2, P3, P3, P4, P5, P6, P6, P7}*)


elemAdjust[{{0, 0}, {1, 1}, {2, -1}, {3, 0}, {4, -2}, {5, 1}}, 2, 2]
(*==> {{0, 0}, {1, 1}, {2, -1}, {2, -1}, {3, 0}, {4, -2}, {5, 1}, {5, 1}}*)


### Question

• Is there more better to deal with this problem?

doubleElements[lst, postions]

doubleElements[{a1,a2,a3,a4,a5,a6,a7,a8,a9}, {1,7,9}]

==>{a1,a1,a2,a3,a4,a5,a6,a7,a7,a8,a9,a9}

## 3 Answers

It seems that {i−p−1,i,i+p+1} isn't really important so let's start assuming it's already generated:

list = {a, b, c, d}
indices = {-2, 0, 7}

Part[
list,
Range@Length@list /. Map[# -> Sequence[#, #] &, indices + 1]
]

{a, a, b, c, d}


Probably not the best for bigger lists but shorter. Notice that Select part is dropped, as ReplaceAll takes care of that.

another inefficient alternative:

MapIndexed[
## & @@ If[MemberQ[indices + 1, First@#2], {#, #}, #] &,
list
]

• Thanks. I see:) In Range@Length@list /. Map[# -> Sequence[#, #] &, indices + 1], /. could avoid the invalid indices automatically, rather than using Select[] to achieve the valid indices.
– xyz
Jun 16, 2016 at 7:31
• @ShutaoTANG yep, p.s. you can use MapAt instead of ReplacePart in your code too.
– Kuba
Jun 16, 2016 at 7:32
• Your second method might be simplified slightly to MapIndexed[If[MemberQ[indices + 1, First@#2], ## &[#, #], #] &, list] Jun 16, 2016 at 7:51
eA[elems_, deg_, i_] :=
Module[{idx = Select[{i - deg - 1, i, i + deg + 1}, 0 <= # <= Length@elems -1 &] + 1},
Fold[Insert[#, #[[#2 - 1]], #2] &, elems, idx + Range@Length@idx]
];

• THX. idx + Range@Length@idx is very important. :)
– xyz
Jun 16, 2016 at 7:55
• @ShutaoTANG Be sure to look at this q&a and Mr. Wizard's refactoring of my answer - that shows a very fast way of inserting into multiple positions, of which your case here is a simpler form, but perhaps useful...
– ciao
Jun 16, 2016 at 7:59

Prompted by rasher/ciao's comment referencing Looking for a way to insert multiple elements into multiple positions simultaneously in a list I propose:

doubleAt[list_, pos_] :=
Length[list] /. n_ :>
list[[ Sort @ Join[Select[pos, 1 <= # <= n &], Range @ n] ]]

doubleAt[{a1,a2,a3,a4,a5,a6,a7,a8,a9}, {-3, 7, 1, 9, 22}]

{a1, a1, a2, a3, a4, a5, a6, a7, a7, a8, a9, a9}


This is less intuitive but far somewhat faster than Kuba's code:

(* Kuba's method as a function; Dispatch added for performance *)

kubaFn[list_, indices_] :=
list[[
Range @ Length @ list /.
Dispatch @ Map[# -> Sequence[#, #] &, indices + 1]
]]

list = "a" ~CharacterRange~ "z" ~RandomChoice~ 50000;
pos  = Range[-1000, 60000] ~RandomSample~ 4000;

kubaFn[list, pos - 1]       // Length // AbsoluteTiming
doubleAt[list, pos]         // Length // AbsoluteTiming

{0.0153409, 53294}

{0.00306862, 53294}


Note that agreement with Kuba's code requires an offset (+1, -1) for one of the functions:

kubaFn[list, pos - 1] === doubleAt[list, pos]    (* True *)

• I like your doubleAt[] nomenclature. :)
– xyz
Jun 16, 2016 at 9:40
• @ShutaoTANG Thanks. I updated my timings to include Dispatch in Kuba's code, giving a much more even performance. If pushing for maximum performance Select can be improved at the further expense of clarity. Jun 16, 2016 at 9:57