Skip to main content

How can I remove matching sublists from my list?


I want to use DeleteCases (or any appropriate function) to remove elements of a list, which in turn are lists of fixed size. The rule I wish to apply is that any element of the list which already appear elsewhere in the list, up to any number of -1 is to be removed. But I don't know how to do this kind of tricky pattern matching. For example, I have the following list:


myData = {{h -> 255.155, c -> 0, s -> -10000.},
{h -> -255.155, c -> 0, s -> 10000.},

{h -> 0, c -> 0, s -> 10000.},
{h -> 0, c -> 0, s -> -10000.},
{h -> 255.155, c -> 0, s -> 10000.},
{h -> -255.155, c -> 0, s -> -10000.},
{h -> -255.155, c -> 1870.83, s -> 3535.53},
{h -> 255.155, c -> -1870.83, s -> -3535.53},
{h -> 0, c -> 1870.83, s -> 3535.53},
{h -> 0, c -> -1870.83, s -> -3535.53},
{h -> 255.155, c -> 1870.83, s -> 3535.53},
{h -> -255.155, c -> -1870.83, s -> -3535.53},

{h -> 255.155, c -> -4000., s -> 0},
{h -> -255.155, c -> 4000., s -> 0},
{h -> 0, c -> 4000., s -> 0},
{h -> 0, c -> -4000., s -> 0},
{h -> 255.155, c -> 4000., s -> 0},
{h -> -255.155, c -> -4000., s -> 0},
{h -> 255.155, c -> 1870.83, s -> -3535.53},
{h -> -255.155, c -> -1870.83, s -> 3535.53},
{h -> 0, c -> 1870.83, s -> -3535.53},
{h -> 0, c -> -1870.83, s -> 3535.53},

{h -> 255.155, c -> -1870.83, s -> 3535.53},
{h -> -255.155, c -> 1870.83, s -> -3535.53},
{h -> 255.155, c -> 0, s -> 0},
{h -> -255.155, c -> 0, s -> 0},
{h -> 0, c -> 0, s -> 0}}

As can be seen the first element myData[[1]] (which is a list of three items) is a duplicate (up to the minus signs) myData[[2]] myData[[5]] myData[[6]]. But I don't know how to get Mathematica to remove these.


As an added bonus, it would be nice that, among the ones that are duplicates up to -1, the one with the least number of negatives is kept, and all others are removed. (In the example above, myData[[5]] would be among those that would be kept.)



Answer



The problem with both Union - based and DeleteDuplicates - based solutions is that both functions have quadratic complexity in the size of the list, for an explicit comparison function. Here is code which should be much faster for larger lists:



Reap[
Sow[#, Abs[{{h, c, s} /. #}]] & /@ myData,
_,
First@#2[[Ordering[UnitStep[-{h, c, s} /. #2]]]] &
][[2]]

(*
{{h->255.155,c->0,s->10000.},{h->0,c->0,s->10000.},
{h->255.155,c->1870.83,s->3535.53},{h->0,c->1870.83,s->3535.53},
{h->255.155,c->4000.,s->0},{h->0,c->4000.,s->0},

{h->255.155,c->0,s->0},{h->0,c->0,s->0}}
*)

It is based on tagging the list entries with some function of the entry that serves as an equivalence tag, and then postprocessing the resulting lists. It should have a near-linear complexity with respect to the length of the list.


Comments

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...