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
$\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$
  • $\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 '16 at 7:31
  • $\begingroup$ @ShutaoTANG yep, p.s. you can use MapAt instead of ReplacePart in your code too. $\endgroup$ – Kuba Jun 16 '16 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 '16 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$
  • $\begingroup$ THX. idx + Range@Length@idx is very important. :) $\endgroup$ – xyz Jun 16 '16 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 '16 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$
  • $\begingroup$ I like your doubleAt[] nomenclature. :) $\endgroup$ – xyz Jun 16 '16 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 '16 at 9:57

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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