# Identify flipped data

## Edit

I'll try to reformulate my problem to make it more clear.

Consider association with elements of the form {x,y} -> {f(x,y),g(x,y),...}, where keys are points on the plane. It can be assumed that keys can be always treated as being on an integer grid {x_i,y_j} = {dx*i,dy*j}, but current solution doesn't use this fact.

Now, some values are flipped and the task is to recover original form assuming values close to {0,0} are correct. For example, given <|{0,0} -> {1,100},{0,1} -> {0.9,150},{1,1} -> {110,1.1}|>, key {0,0} is correct by definition and {0,1} has correct ordering and {1,1} is flipped and should be reordered.

Here is a test example:

(* generate correct test data *)
step = 0.025 ;
data = Table[
{x,y} -> {Sin[(x+y)/2]^2,10.0+Cos[(x+y)/2]^2,-10.+0.5*Sin[(x+y)^2/4]^2},
{x,-Pi,Pi,step*Pi},
{y,-Pi,Pi,step*Pi}
] ;
data = Flatten[data,1] ;
data = Association[data] ;

(* corrupted data with flips *)
flipped = KeyValueMap[
Block[
{x,y,a,b,c},
{{x,y},{a,b,c}} = {##} ;
{{x,y},{a,b,c}} = {{x,y},{a,b,c}} /. {{x_,y_},{a_,b_,c_}} /; -2.0 <= x <= +2.0 && +1.0 <= y <= +2.0 :> {{x,y},{b,a,c}} ;
{{x,y},{a,b,c}} = {{x,y},{a,b,c}} /. {{x_,y_},{a_,b_,c_}} /; +0.5 <= x <= +1.0 && -1.5 <= y <= -0.5 :> {{x,y},{a,c,b}} ;
{{x,y},{a,b,c}} = {{x,y},{a,b,c}} /. {{x_,y_},{a_,b_,c_}} /; +1.5 <= x <= +2.0 && +1.5 <= y <= +2.5 :> {{x,y},{c,b,a}} ;
{x,y} -> {a,b,c}
]&,
data
] ;
flipped = Association[flipped] ;

(* recover original data *)
result = backflip[flipped]  ; // AbsoluteTiming

ClearAll[plot] ;
plot = ListPointPlot3D[
{
KeyValueMap[Composition[Flatten,List],Part[#,All,1]],
KeyValueMap[Composition[Flatten,List],Part[#,All,2]],
KeyValueMap[Composition[Flatten,List],Part[#,All,3]]
},
PlotStyle -> {
Directive[{Opacity[0.5],PointSize[Small],Red}],
Directive[{Opacity[0.5],PointSize[Small],Blue}],
Directive[{Opacity[0.5],PointSize[Small],Green}]
},
PlotRange -> {{-Pi,Pi},{-Pi,Pi},{-15.0,15.0}},
ImageSize -> 300,
BoxRatios -> {1/3,1/3,1}
] & ;
Grid[{{"original","corrupted","recovered"},Map[plot,{data,flipped,result}]},Spacings->0]


My current solution seems to work, but it is very slow. I want to optimize it or to use a better approach. Here is a modified version of backflip function.

limit = 100 ;
neighbors = 4 ;
ClearAll[backflip] ;
backflip[
data_
] := Block[
{local,result},
(* sort *)
local = KeySortBy[data,Norm] ;
(* set 1st point *)
result = Take[local,1] ;
(* check point-by-point *)
KeyValueMap[
Block[
{key,value,cut,select,mean,index},
{key,value} = List[##] ;
(* select close points with smaller radius *)
cut = Take[result,-Min[{limit,Length[result]}]] ;
(* find nearest points in selected *)
select = Nearest[Keys[cut],key,neighbors,Method->"Scan",DistanceFunction->EuclideanDistance] ;
(* get corresponding mean of their values *)
mean = Map[cut,select] ;
mean = Map[Mean,Transpose[mean]] ;
(* ordering *)
index = Flatten[Map[Ordering[Abs[(value-#)],1]&,mean]] ;
value = value[[index]] ;
(* add point to the result *)
result = Join[result,Association[Rule[key,value]]] ;
] &,
local
] ;
result
]  ;


## Original post

I have data of the form:

(* {...,{x_i,y_i,{a_i,b_i}}},... } *)
step = 0.025 ;
data = Table[
{x,y,{0.0,If[-2.0 <= x <= 2.0 && 1.0 <= y <= 2.0,2.0,0.0]}+Sin[x*y/2]^2},
{x,-Pi,Pi,step*Pi},
{y,-Pi,Pi,step*Pi}
] ;
data = Flatten[data,1] ;


Next, given data where only some a_i and b_i values are flipped.

(* flipped data *)
flipped = RandomSample[data,Length[data]] /. {x_,y_,{a_,b_}} /; -2.0 <= x <= 2.0 && 1.0 <= y <= 2.0 :> {x,y,{b,a}} ;
ListPointPlot3D[
Transpose[{flipped[[;;,1]],flipped[[;;,2]],flipped[[;;,3,1]]}],
PlotStyle -> Directive[{Opacity[0.5],PointSize[Small],Red}],
PlotRange -> {{-Pi,Pi},{-Pi,Pi},{-5.0,5.0}},
ImageSize -> 250
]


How can these data points be flipped back?

Usually, flipped region has a form of a localized patch and doesn't contain the origin, i.e. data near the origin is assumed to be correct. Patch points can be assumed to be well separated and correct data should be somewhat smooth.

My current solution is very slow (here test data size is 6.5k, and real data is 1m points). What can be optimized here? Or is there a better approach?

Rectangular grid can be assumed for x_i and y_i with constant steps, but for real data this is not always the case.

association = (flipped[[;;,{1,2}]] -> flipped[[;;,-1]]) // Thread // Association ;
result = backflip[association] ; // AbsoluteTiming
result = Map[Flatten,Transpose[{Keys[result],Values[result]}]] ;
ListPointPlot3D[
result,
PlotStyle -> Directive[{Opacity[0.5],PointSize[Small],Red}],
PlotRange -> {{-Pi,Pi},{-Pi,Pi},{-5.0,5.0}},
ImageSize -> 250
]


limit = 100 ;
neighbors = 2 ;
ClearAll[backflip] ;
backflip[
data_
] := Block[
{local,result},
(* sort *)
local = KeySortBy[data,Norm] ;
(* set 1st point *)
result = Map[First,Take[local,1]] ;
(* check point-by-point *)
KeyValueMap[
Block[
{key,value,cut,select,mean},
{key,value} = List[##] ;
(* select close points with smaller radius *)
cut = Take[result,-Min[{limit,Length[result]}]] ;
(* find nearest points in selected *)
select = Nearest[Keys[cut] -> "Distance",key,neighbors,Method -> "Scan", DistanceFunction -> ManhattanDistance] ;
(* get corresponding mean of their values *)
mean = Mean[Map[cut,select]] ;
(* select closest to the mean *)
value = First[SortBy[value,Abs[#-mean]&]] ;
(* add point to the result *)
result = Join[result,Association[Rule[key,value]]] ;
] &,
local
] ;
(* return *)
result
] ;


ClearAll[backFlip]
backFlip =
Module[{cc = ConnectedComponents@NearestNeighborGraph[#, 4], dif},
dif = {0, 0, Mean[cc[[1, All, -1]]] - Mean[cc[[2, All, -1]]]};
cc[[2]] = dif + # & /@ cc[[2]]; Join @@ cc] &;

d1 = Transpose[{flipped[[;; , 1]], flipped[[;; , 2]], flipped[[;; , 3, 1]]}];

Row[ListPointPlot3D[#,
PlotStyle -> Directive[{Opacity[0.5], PointSize[Small], Red}],
PlotRange -> {{-Pi, Pi}, {-Pi, Pi}, {-5.0, 5.0}},
ImageSize -> 400] & /@ {d1, backFlip@d1}]


• thanks for your answer. Sorry, my initial data example is misleading, a_i and b_i are not related in general, only some good separation can be assumed and some smoothness of a_i data starting from zero. Your code will not give desired output for initial data like data = Table[{x,y,{Sin[x*y/2]^2,2.0+Cos[x*y/2]^2}},{x,-Pi,Pi,step*Pi},{y,-Pi,Pi,step*Pi}];. Is it possible to build a graph for data {x_i,y_i,maybe_a_i,maybe_b_i} and then traverse it starting from zero {x_i,y_i} = {0,0} assuming maybe_a_i are correct a_i near zero and then use smoothness of a_i's to check other points?
– I.M.
Jun 1, 2020 at 3:45
• e.g. data = {{0,0,{1,100}},{1,1,{110,1.1}}} should be transformed to {{0,0,{1,100}},{1,1,{1.1,110}}} because at zero data is correct by definition and 1.1 is closer to 1.0 then 111
– I.M.
Jun 1, 2020 at 3:49
• @I.M. i will post an update if I come up with something that works for the general case.
– kglr
Jun 1, 2020 at 13:15