5
$\begingroup$

I have some data in a list that are non-numeric. I want to replace the bad data with a linear interpolation from the surrounding data. The non-numeric data can be easily identified. There may be more than "one section" (i.e. continuous sub-list) of bad data in the list. For example

(*if the list contained the following*)
testy =  {1.1, 2.4, 3.5, 2.5, "xx", "xx", "xx", 4.5, 8.5, "xx", "xx", "xx", 
  4.5, "xx", 8.5};
(*want to change it to*)
 {1.1, 2.4, 3.5, 2.5, 3.0, 3.5, 4.0, 4.5, 8.5, 7.5, 6.5, 5.5, 
  4.5, 6.5, 8.5};

I have a very basic working approach to address this (below) but there are probably better ways to do this. There are special cases that this doesn't handle, such as if the first point, the last point, or all of the data is bad -- that is not a priority for this question. Those can be handled separately.

In this approach, I couldn't find a "nice" way to find the first and last points of every "section" of bad data. So, at the moment my approach is to run this routine multiple times until all the bad data is removed.

addition to original post: The test examples has just a few entries. The application will have between 500 and 10000 elements per row and around 7000 rows.

(*test data*)
testy = {1.1, 2.4, 3.5, 2.5, "xx", "xx", "xx", 4.5, 8.5, "xx", "xx", 
   "xx", 4.5, "xx", 8.5};
testyBefore = testy;
npts = Length@testy;

(*postions of bad data*)
xxList = Flatten@Position[testy, "xx"];

(*first and last position of a continuous run of bad data *)
k = 1 + LengthWhile[  Range[npts - 1], 
    xxList[[# + 1]] == 1 + xxList[[#]] & ];
iStart = First@xxList;
iEnd = xxList[[k]];
nBad = 1 + (iEnd - iStart );
{iStart, iEnd, nBad};

(*linear interpolation along line*)
y0 = testy[[iStart - 1]];
yN = testy[[iEnd + 1]];
yStep = (yN - y0) /(1 + nBad) ;

(*update data*)
iList = Range[iStart, iEnd];
yiList = (y0 + # yStep) & /@ Range[nBad];
(testy[[iList[[#]] ]] = yiList[[#]]) &  /@ Range[nBad];
testyAfter = testy;

(*summary*)
Grid[{ Prepend[ testyBefore, "Before"], Prepend[testyAfter, "After"] }, Frame -> All]

The result of this is to replace only the first section of bad data. The process could then be repeated.

Result of above implementation

Thanks for your recommendations.

$\endgroup$
9
$\begingroup$

TemporalData/TimeSeries + MissingDataMethod

You can replace non-numeric values with Missing[] in testy and use TemporalData (or TimeSeries) with the option MissingDataMethod:

testy2 = Replace[testy, {x_?NumericQ :> x, _ :> Missing[]}, {1}];

td = TemporalData[testy2, {1}, 
  MissingDataMethod -> {"Interpolation", InterpolationOrder -> 1}];

td["Values"]
{1.1, 2.4, 3.5, 2.5, 3., 3.5, 4., 4.5, 8.5, 7.5, 6.5, 5.5, 4.5, 6.5, 8.5} 
MapAt[Highlighted, %, Position[testy, "xx"]]

enter image description here

Row[{ListLinePlot[testy, PlotLabel -> Style["testy", 16], 
   PlotMarkers -> {Graphics[{FaceForm[Blue], EdgeForm[], Disk[]}, ImageSize -> 12]}, 
   ImageSize -> 300] ,
  ListLinePlot[td, PlotLabel -> Style["td", 16], 
   PlotMarkers -> {Graphics[{FaceForm[Red], EdgeForm[], Disk[]}, ImageSize -> 12]}, 
   ImageSize -> 300]}, Spacer[10]]

enter image description here

Further examples:

methods = {{"Interpolation", InterpolationOrder -> 1}, 
   {"Interpolation", InterpolationOrder -> 2}, 
   {"Interpolation", InterpolationOrder -> 0}, 
   {"Interpolation", "HoldFrom" -> Left}, 
   {"Interpolation", "HoldFrom" -> Right},
   {"Constant", 7}};

Multicolumn[Labeled[ListLinePlot[{testy, 
       TemporalData[testy2, {1}, MissingDataMethod -> #]}, 
     PlotStyle -> {Directive[AbsoluteThickness[5], Blue], 
       Directive[AbsoluteThickness[2], Red]}, 
     PlotMarkers -> {Graphics[{FaceForm[Blue], EdgeForm[], Disk[]}, ImageSize -> 14], 
       Graphics[{FaceForm[{Opacity[1], Red}], EdgeForm[], Disk[]},  ImageSize -> 10]}, 
         ImageSize -> 300], 
    Style[Column[{"MissingDataMethod -> ", #}, Alignment -> Center], 16], 
   Top] & /@ methods,
  2,  Appearance -> "Horizontal"]

enter image description here

TimeSeriesResample + ResamplingMethod

tss = TimeSeriesResample@
   TemporalData[Cases[_Real]@testy, {Flatten@Position[testy, _Real]}, 
    ResamplingMethod -> {"Interpolation", InterpolationOrder -> 1}];

tss["Values"] // MapAt[Highlighted, #, Position[testy, "xx"]] &

enter image description here

ReplaceRepeated

rule = {l___, a_Real, x : "xx" .., b_Real, r___} :> 
   Flatten[{l, Subdivide[a, b, 1 + Length@{x}], r}];

testy //. rule // MapAt[Highlighted, #, Position[testy, "xx"]] &

enter image description here

Interpolation

For large inputs, Interpolation is faster than alternative methods. The following is a slightly faster version of Jean-Pierre's approach:

intF = Interpolation[Transpose[{Flatten@Position[#, _Real], Cases[_Real]@#}], 
     InterpolationOrder -> 1] /@ Range[Length @#] &;

intF @ testy // MapAt[Highlighted, #, Position[testy, "xx"]] &

enter image description here

Update: Timings

SeedRandom[1]
n = 1000;
tstx = RandomReal[100, n];
tstx = MapAt["xx" &, tstx, List /@ RandomSample[Range[2, n - 1], n/2]];

Timings for the six methods posted so far:

resa = Interpolation[Transpose[{Flatten@Position[tstx, _Real], 
    Cases[_Real]@tstx}], InterpolationOrder -> 1] /@ Range[Length[tstx]]; // 
  RepeatedTiming // First
 0.0031
(p = Partition[Flatten@MapIndexed[{#2, #1} &, tstx], 2];
   cp = Cases[p, {_Integer, _Real}];
   ff = Interpolation[cp, InterpolationOrder -> 1];
   resb = Map[ff[#[[1]]] &, p];) // 
     RepeatedTiming // First (* method from Jean-Pierre's answer *)
 0.0046
resc = TemporalData[Replace[tstx, {x_?NumericQ :> x, _ :> Missing[]}, {1}], {1}, 
      MissingDataMethod -> {"Interpolation", 
        InterpolationOrder -> 1}]["Values"]; // RepeatedTiming // First
 0.0094
resd = TimeSeriesResample[TemporalData[Cases[_Real]@tstx, 
    {Flatten@Position[tstx, _Real]}, ResamplingMethod -> {"Interpolation", 
     InterpolationOrder -> 1}]]["Values"]; // 
     RepeatedTiming // First 
 0.0092
lerp[x_, y_, n_] := Interpolation[{{0, x}, {n + 1, y}}, 
   InterpolationOrder -> 1][Range[1, n]]

rese = FixedPoint[SequenceReplace[{x_Real, xs : "xx" .., y_Real} :> 
  With[{n = Length@{xs}}, 
    Sequence @@ Flatten[{x, lerp[x, y, n], y}]]], tstx]; // 
  RepeatedTiming // First (* method from Pillsy's answer *)
 8.2
rule = {l___, a_Real, x : "xx" .., b_Real, r___} :> 
   Flatten[{l, Subdivide[a, b, 1 + Length@{x}], r}];

resf = tstx //. rule; // RepeatedTiming // First
 330.
resa == resb == resc == resd == rese == resf
 True
$\endgroup$
1
  • $\begingroup$ thanks! this is becoming clearer now. $\endgroup$ – user6546 Jan 31 at 19:17
4
$\begingroup$
testy = {1.1, 2.4, 3.5, 2.5, "xx", "xx", "xx", 4.5, 8.5, "xx", "xx", 
   "xx", 4.5, "xx", 8.5};
p = Partition[Flatten@MapIndexed[{#2, #1} &, testy], 2];
cp = Cases[p, {_Integer, _Real}];
ff = Interpolation[cp, InterpolationOrder -> 1];
Map[ff[#[[1]]] &, p]
$\endgroup$
1
  • $\begingroup$ Thanks! Nice idea. Could you offer some suggestions about how this might be modified if the data set were large? In this case, each row of the data set would be between 500 and 10000 points. And there would be about 7000 rows. Am sure the Interpolation function could handle that, but are there changes you would recommend any changes for larger data sets? (apologies for not putting this into the original post) $\endgroup$ – user6546 Jan 31 at 3:21
4
$\begingroup$

We almost want SequenceReplace, but it doesn't quite work because of the way it handles overlapping patters. However, at the potential cost of some inefficiency, we can combine it with FixedPoint to get the result we want.

First, a utility function to do the interpolation:

lerp[x_, y_, n_] :=
 Interpolation[{{0, x}, {n + 1, y}}, InterpolationOrder -> 1][
  Range[1, n]]

With that, it gives the result you want:

FixedPoint[
 SequenceReplace[{x_Real, xs : "xx" .., y_Real} :>
   With[{n = Length@{xs}}, 
    Sequence @@ Flatten[{x, lerp[x, y, n], y}]]],
 testy]
(* {1.1, 2.4, 3.5, 2.5, 3., 3.5, 4., 4.5, 8.5, 7.5, 6.5, 5.5, 4.5, 6.5, \
8.5} *) 

EDIT

Unfortunately, with large data sets this is slow as all get-out. If you want speed, just use Interpolation directly, as suggested by Jean-Pierre and klgr. However, you can speed this up even more by using the third argument of Pick, instead of Cases.

With[{n = 1000},
  SeedRandom[1];
  testx = 
   MapAt["xx" &, RandomReal[100, n], 
    List /@ RandomSample[Range[2, n - 1], n/2]]];

Interpolation[Transpose[{Flatten@Position[#, _Real], Cases[_Real]@#}],
       InterpolationOrder -> 1] /@ Range[Length@#] &[
   testx]; // RepeatedTiming
(* {0.00331371, Null} *)

Interpolation[
   Pick[
    Transpose@{Range@Length@testz, testx},
    testz,
    _Real],
   InterpolationOrder -> 1]; // RepeatedTiming
(* {0.000958979, Null} *)

Given the size of the data set in question, a factor of 3 speed up is nothing to sneeze at.

$\endgroup$
1
  • $\begingroup$ thanks. Will study this. Do you expect it to be efficient for largish data sets (500 to 1000 elements per row and about 7000 rows) $\endgroup$ – user6546 Jan 31 at 3:26

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.