3
$\begingroup$

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$

enter image description here

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[]

enter image description here

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}

$\endgroup$

3 Answers 3

3
$\begingroup$

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
]
$\endgroup$
3
  • $\begingroup$ 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. $\endgroup$
    – xyz
    Jun 16, 2016 at 7:31
  • $\begingroup$ @ShutaoTANG yep, p.s. you can use MapAt instead of ReplacePart in your code too. $\endgroup$
    – Kuba
    Jun 16, 2016 at 7:32
  • 1
    $\begingroup$ Your second method might be simplified slightly to MapIndexed[If[MemberQ[indices + 1, First@#2], ## &[#, #], #] &, list] $\endgroup$
    – Mr.Wizard
    Jun 16, 2016 at 7:51
3
$\begingroup$
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]
 ];
$\endgroup$
2
  • $\begingroup$ THX. idx + Range@Length@idx is very important. :) $\endgroup$
    – xyz
    Jun 16, 2016 at 7:55
  • 2
    $\begingroup$ @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... $\endgroup$
    – ciao
    Jun 16, 2016 at 7:59
2
$\begingroup$

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 *)
$\endgroup$
2
  • $\begingroup$ I like your doubleAt[] nomenclature. :) $\endgroup$
    – xyz
    Jun 16, 2016 at 9:40
  • $\begingroup$ @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. $\endgroup$
    – Mr.Wizard
    Jun 16, 2016 at 9:57

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.