9
$\begingroup$

I would like to make only one pass of a list of 2D items and replace adjacent items that have matching $x$ or $y$ coordinates with a series of linearly interpolated points between the two points. My attempt to construct this rule for matching $x$ coordinates is being met by a syntax error.

Minimal example:

{{4, 5}, {1, 2}, {1, 5}, {3, 5}} /. ({x_, j_}, {x_, k_}) -> 
  Table[{x, j + n (k - j)/3}, {n, 0, 3}]
Syntax::sntxf: "(" cannot be followed by "{x_,j_},{x_,k_})".

I am expecting

{{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {3, 5}}
$\endgroup$
  • $\begingroup$ Will there ever be lists where there are three adjacent pairs with the same first element? $\endgroup$ – march Oct 1 '15 at 20:40
  • $\begingroup$ And will the second elements of the list always be in order from largest to smallest? $\endgroup$ – march Oct 1 '15 at 20:46
  • $\begingroup$ @march Yes, there is no limit to how many adjacent elements there are. I thought the rule would pick these up due to the way rules work. Largest to smallest does not matter as the formula will still work. It will subtract instead of add in this case. $\endgroup$ – Edmund Oct 1 '15 at 20:55
  • $\begingroup$ In that case, I think it will be very difficult to do this in precisely "one pass". I think I have a solution in "three" passes, but I'm still working on it. Oh and one more question: You always want to fill in exactly two more points between the adjacent ones, or does it depend on the difference between the second elements of the adjacent pairs? $\endgroup$ – march Oct 1 '15 at 20:59
  • $\begingroup$ @march The number of interpolated points will be variable. I just picked 2 and integers for the example to keep it simple. $\endgroup$ – Edmund Oct 1 '15 at 22:11
7
$\begingroup$

You might find useful this other approach which is not using ReplaceAll:

foo[___, {x_, j_}, {x_, k_}] := 
 Sequence @@ Rest@Table[{x, j + n (k - j)/3}, {n, 0, 3}]

foo[__, s_] := s

then for any number of adjacent items with matching x, for example

testlist = {{4, 5}, {1, 2}, {1, 5}, {1, 7}, {3, 7}}

just run

FoldList[foo,testlist]
(* FoldList[foo, First@testlist, Rest@testlist] for versions < 10 *)
{{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 17/3}, {1, 19/3}, {1, 7}, {3, 7}}

If you need also, as I understand, the same interpolation when adjacent y are the same, just add the definition:

foo[___, {j_, y_}, {k_, y_}] := 
 Sequence @@ Rest@Table[{j + n (k - j)/3, y}, {n, 0, 3}]

then with the same FoldList command than above you get now

{{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 17/3}, {1, 19/3}, {1, 7}, {5/3, 7},

{7/3, 7}, {3, 7}}

$\endgroup$
  • $\begingroup$ The FoldList two arguments syntax has been introduced silently with version 10. I added the traditional 3 arguments syntax for older versions. $\endgroup$ – SquareOne Oct 2 '15 at 11:27
  • $\begingroup$ I was not originally looking for FoldList but this answer will be the easiest to follow when I (or more importantly, someone else) comes across it again so I have selected it. $\endgroup$ – Edmund Oct 19 '15 at 19:18
10
$\begingroup$
{{4, 5}, {1, 2}, {1, 5}, {3, 5}} /. 
          {a : ___,  b : PatternSequence[{x_, j_}, {x_, k_}], c : ___} :> 
             {a, Sequence @@ Table[{x, j + n (k - j)/3}, {n, 0, 3}], c}

(* {{4, 5}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {3, 5}} *)

Edit

For supporting multiple adjacent values you may do the much more convoluted:

g[x_] := Module[{s = 3 Length@x - 2},
             {x[[1, 1]], Interpolation[x[[All, 2]], InterpolationOrder -> 1][#]} & /@ 
                         Rescale[Range@s, {1, s}, {1, Length@x}]]
g[x : {{__}}] := x
f[l_] := Flatten[g /@ SplitBy[l, First], 1]

l = {{4, 5}, {1, 2}, {1, 5}, {1, 8}, {3, 5}, {3, 7}};
f@l

(*
{{4, 5}, 
  {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, {1, 7}, {1, 8}, 
  {3, 5}, {3, 17/3}, {3, 19/3}, {3, 7}}
*)
$\endgroup$
  • $\begingroup$ There is a problem! See @Edmund's comment on his question! $\endgroup$ – march Oct 1 '15 at 20:59
  • 2
    $\begingroup$ @march I try to disregard "and this case too" question-upgrading comments. $\endgroup$ – Dr. belisarius Oct 1 '15 at 21:03
  • $\begingroup$ Yeah, that seems like a reasonable practice, actually. I mean, I've just made more work for myself. $\endgroup$ – march Oct 1 '15 at 21:06
  • 1
    $\begingroup$ @march The full solution to a problem always include corner cases the OP should try to work out on his own.[{3,4},{1,2},{1,2},{8,7}} ..... $\endgroup$ – Dr. belisarius Oct 1 '15 at 21:41
  • 1
    $\begingroup$ Very nice. Sorry to make you work harder :) $\endgroup$ – march Oct 1 '15 at 22:45
4
$\begingroup$

Here is my extension of the belisarius' first solution for the case of arbitrary number of elements in the sequence with matching $x$ coordinate (the sequence is still allowed to be only one):

{{4, 5}, {1, 2}, {1, 8}, {1, 7}, {3, 5}} /. 
   {a : ___, b : Longest@Repeated[{x_, _}, {2, Infinity}], c : ___} :> 
   {a, 
    Sequence @@ 
     Transpose[PadLeft[{Append[
      Flatten[MovingMap[Most[Subdivide[#[[1]], #[[2]], 3]] &, {b}[[;; , 2]], 1]], 
      {b}[[-1, 2]]]}, {2, Automatic}, x]], 
    c}
{{4, 5}, {1, 2}, {1, 4}, {1, 6}, {1, 8}, {1, 23/3}, {1, 22/3}, {1, 7}, {3, 5}}

If the number of sequences with matching $x$ coordinate is arbitrary, there probably is no way to avoid Split:

l = {{4, 5}, {1, 2}, {1, 8}, {1, 7}, {3, 5}, {3, 7}, {3, 4}};

subd[s : {{_, _}}] := s;
subd[s : {{x_, _} ..}] := 
  Transpose[PadLeft[{Append[
      Flatten[BlockMap[Most[Subdivide[#[[1]], #[[2]], 3]] &, s[[;; , 2]], 2, 1]], 
      s[[-1, 2]]]}, {2, Automatic}, x]];

Flatten[subd /@ SplitBy[l, First], 1]
{{4, 5}, {1, 2}, {1, 4}, {1, 6}, {1, 8}, {1, 23/3}, {1, 22/3}, {1, 7}, {3, 5}, 
 {3, 17/3}, {3, 19/3}, {3, 7}, {3, 6}, {3, 5}, {3, 4}}
$\endgroup$
  • $\begingroup$ Many thanks for assisting with this but the FoldList (although I did ask for ReplaceAll answer seems like it will be easier to follow so easier to support. $\endgroup$ – Edmund Oct 19 '15 at 19:16

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.