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}}
Improve this question
$\endgroup$
5
  • $\begingroup$ Will there ever be lists where there are three adjacent pairs with the same first element? $\endgroup$ Commented Oct 1, 2015 at 20:40
  • $\begingroup$ And will the second elements of the list always be in order from largest to smallest? $\endgroup$ Commented Oct 1, 2015 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$ Commented Oct 1, 2015 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$ Commented Oct 1, 2015 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$ Commented Oct 1, 2015 at 22:11

3 Answers 3

Reset to default
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}}

Improve this answer
$\endgroup$
2
  • $\begingroup$ The FoldList two arguments syntax has been introduced silently with version 10. I added the traditional 3 arguments syntax for older versions. $\endgroup$ Commented Oct 2, 2015 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$ Commented Oct 19, 2015 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}} *)
Improve this answer
$\endgroup$
7
  • $\begingroup$ There is a problem! See @Edmund's comment on his question! $\endgroup$ Commented Oct 1, 2015 at 20:59
  • 2
    $\begingroup$ @march I try to disregard "and this case too" question-upgrading comments. $\endgroup$ Commented Oct 1, 2015 at 21:03
  • $\begingroup$ Yeah, that seems like a reasonable practice, actually. I mean, I've just made more work for myself. $\endgroup$ Commented Oct 1, 2015 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$ Commented Oct 1, 2015 at 21:41
  • 1
    $\begingroup$ Very nice. Sorry to make you work harder :) $\endgroup$ Commented Oct 1, 2015 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}}
Improve this answer
$\endgroup$
1
  • $\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$ Commented Oct 19, 2015 at 19:16

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.