Work with patterns using Cases to filter data?

Questions
,
1

I have this list of (x,y,z) data points and I would like to program symbolically Cases to:

(a) remove points that have x,y,z indexes greater than 1

(b) add 1 to x,y,z indexes that have a negative value

How can be this done in with patterns in Cases?
JGuy

Here is the list:

{{0.416668, 0.295182, 0.044696}, {0.416668, 1.29518, 
  0.044696}, {1.41667, 1.29518, 0.044696}, {0.295182, 0.044696, 
  0.416668}, {0.295182, 1.0447, 0.416668}, {1.29518, 1.0447, 
  0.416668}, {0.044696, 0.416668, 0.295182}, {0.044696, 1.41667, 
  0.295182}, {1.0447, 1.41667, 
  0.295182}, {-0.416668, -0.295182, -0.044696}, {-0.416668, 
  0.704818, -0.044696}, {0.583332, 
  0.704818, -0.044696}, {-0.295182, -0.044696, -0.416668}, {-0.295182,
   0.955304, -0.416668}, {0.704818, 
  0.955304, -0.416668}, {-0.044696, -0.416668, -0.295182}, {-0.044696,
   0.583332, -0.295182}, {0.955304, 0.583332, -0.295182}}
2

One of the possible approaches:

In[1]:= Cases[{{0.416668, 0.295182, 0.044696}, {0.416668, 1.29518, 
    0.044696}, {1.41667, 1.29518, 0.044696}, {0.295182, 0.044696, 
    0.416668}, {0.295182, 1.0447, 0.416668}, {1.29518, 1.0447, 
    0.416668}, {0.044696, 0.416668, 0.295182}, {0.044696, 1.41667, 
    0.295182}, {1.0447, 1.41667, 
    0.295182}, {-0.416668, -0.295182, -0.044696}, {-0.416668, 
    0.704818, -0.044696}, {0.583332, 
    0.704818, -0.044696}, {-0.295182, -0.044696, -0.416668}, \
{-0.295182, 0.955304, -0.416668}, {0.704818, 
    0.955304, -0.416668}, {-0.044696, -0.416668, -0.295182}, \
{-0.044696, 0.583332, -0.295182}, {0.955304, 
    0.583332, -0.295182}}, {x_ /; x <= 1, y_ /; y <= 1, 
   z_ /; z <= 1}] /. {x_ /; x < 0 -> x + 1, y_ /; y < 0 -> y + 1, 
  z_ /; z < 0 -> z + 1}

Out[1]= {{0.416668, 0.295182, 0.044696}, {0.295182, 0.044696, 
  0.416668}, {0.044696, 0.416668, 0.295182}, {0.583332, 0.704818, 
  0.955304}, {0.583332, 0.704818, 0.955304}, {0.583332, 0.704818, 
  0.955304}, {0.704818, 0.955304, 0.583332}, {0.704818, 0.955304, 
  0.583332}, {0.704818, 0.955304, 0.583332}, {0.955304, 0.583332, 
  0.704818}, {0.955304, 0.583332, 0.704818}, {0.955304, 0.583332, 
  0.704818}}
3

Thank you for your quick reply! So there is no way to write all this inside the Cases[] statement. Nice use of the ReplaceAll[] though. Patterns are a mystery to me. Is there a link on the web where Patterns examples are listed? I want learn this subject but examples are few.

JGuy

4

Sure, it can be written:

In[1]:= Cases[{{0.416668, 0.295182, 0.044696}, {0.416668, 1.29518, 
    0.044696}, {1.41667, 1.29518, 0.044696}, {0.295182, 0.044696, 
    0.416668}, {0.295182, 1.0447, 0.416668}, {1.29518, 1.0447, 
    0.416668}, {0.044696, 0.416668, 0.295182}, {0.044696, 1.41667, 
    0.295182}, {1.0447, 1.41667, 
    0.295182}, {-0.416668, -0.295182, -0.044696}, {-0.416668, 
    0.704818, -0.044696}, {0.583332, 
    0.704818, -0.044696}, {-0.295182, -0.044696, -0.416668}, \
{-0.295182, 0.955304, -0.416668}, {0.704818, 
    0.955304, -0.416668}, {-0.044696, -0.416668, -0.295182}, \
{-0.044696, 0.583332, -0.295182}, {0.955304, 
    0.583332, -0.295182}} /. {x_ /; x < 0 -> x + 1, 
   y_ /; y < 0 -> y + 1, z_ /; z < 0 -> z + 1}, {x_ /; x <= 1, 
  y_ /; y <= 1, z_ /; z <= 1}]

Out[1]= {{0.416668, 0.295182, 0.044696}, {0.295182, 0.044696, 
  0.416668}, {0.044696, 0.416668, 0.295182}, {0.583332, 0.704818, 
  0.955304}, {0.583332, 0.704818, 0.955304}, {0.583332, 0.704818, 
  0.955304}, {0.704818, 0.955304, 0.583332}, {0.704818, 0.955304, 
  0.583332}, {0.704818, 0.955304, 0.583332}, {0.955304, 0.583332, 
  0.704818}, {0.955304, 0.583332, 0.704818}, {0.955304, 0.583332, 
  0.704818}}

But, this code is less efficient for a long list.

I suppose, community will highlight other ways to solve your problem.

All the best!

5

Thank You Valeriu! It does the job very well! One thing more. I did result=Union@result and I could not remove the duplicates in the result. These points are the result of calculations. I guess the Machine Precision makes the points non-identical. Any way to further filter the result to remove duplicates up to a given precision?

Thanks!

JGuy

6

It works fine:

In[1]:= Union@
 Cases[{{0.416668, 0.295182, 0.044696}, {0.416668, 1.29518, 
     0.044696}, {1.41667, 1.29518, 0.044696}, {0.295182, 0.044696, 
     0.416668}, {0.295182, 1.0447, 0.416668}, {1.29518, 1.0447, 
     0.416668}, {0.044696, 0.416668, 0.295182}, {0.044696, 1.41667, 
     0.295182}, {1.0447, 1.41667, 
     0.295182}, {-0.416668, -0.295182, -0.044696}, {-0.416668, 
     0.704818, -0.044696}, {0.583332, 
     0.704818, -0.044696}, {-0.295182, -0.044696, -0.416668}, \
{-0.295182, 0.955304, -0.416668}, {0.704818, 
     0.955304, -0.416668}, {-0.044696, -0.416668, -0.295182}, \
{-0.044696, 0.583332, -0.295182}, {0.955304, 
     0.583332, -0.295182}} /. {x_ /; x < 0 -> x + 1, 
    y_ /; y < 0 -> y + 1, z_ /; z < 0 -> z + 1}, {x_ /; x <= 1, 
   y_ /; y <= 1, z_ /; z <= 1}]

Out[1]= {{0.044696, 0.416668, 0.295182}, {0.295182, 0.044696, 
  0.416668}, {0.416668, 0.295182, 0.044696}, {0.583332, 0.704818, 
  0.955304}, {0.704818, 0.955304, 0.583332}, {0.955304, 0.583332, 
  0.704818}}
7

Nice approach, Valeriu. (first version)

JGuy, If you want “Approximately equal” do to rounding of exact numbers you can do This instead of Union:

DeleteDuplicates[data, SameQ[Round[#1, 10^-4], Round[#2, 10^-4]] &]

Where data holds the results from your list of triples. This will round to four places after the decimal (you can obviously tailor this to your accuracy needs)

Regards

8

Dear @Jean Guy Lussier, Welcome to Wolfram Community! Please make sure you know the rules:

https://wolfr.am/READ-1ST

While our members kindly helped, we usually expect user effort in the form of Wolfram Language code shown first. Please consult Documentation and existing resources before you ask for help:

For example these pages would show you many relevant examples:

9

I would strongly advice you to have a look at Select. Cases can be very nice for pattern-based methods, but once the patterns involve criteria with functions and conditions they quickly become unreadable. A Select-solution is more legible I would say:

ClearAll[IncrementNegative]
IncrementNegative[x_] := If[x < 0, x + 1, x]
SetAttributes[IncrementNegative, Listable]

Select[IncrementNegative[tmp], AllTrue[# < 1 &]]

One auxiliary function and one Select statement that is not so ‘unwieldy’.

10

I am just amazed! I have been discovering the beauty of Mathematica since July 2016 only and this post shows the great versatility of the language. Big Thank You to Valeriu, Neil and Sander who have contributed to this post! I am a procedural programmer and I come up with code like the following (just to add 1 to negative atomic positions in the list): (and it is not nice!!!)

For[i = 1, i <= Length[Pdsites], i++,
 If[Pdsites[[i, 1]] < 0, 
  Pdsites = 
   ReplacePart[Pdsites, {i, 1} -> Pdsites[[i, 1]] + 1]];
 If[Pdsites[[i, 2]] < 0, 
  Pdsites = 
   ReplacePart[Pdsites, {i, 2} -> Pdsites[[i, 2]] + 1]];
 If[Pdsites[[i, 3]] < 0, 
  Pdsites = 
   ReplacePart[Pdsites, {i, 3} -> Pdsites[[i, 3]] + 1]];]
11

I still have problems with the Union statement and it may not always remove duplicates on Lists. So, I combined the last 2 methods and it gives me the very readable code (by the way, this is an application to crystallography when we fold the atomic positions into one unit cell):

data = {{0.416668, 0.295182, 0.044696}, {0.416668, 1.29518, 
   0.044696}, {1.41667, 1.29518, 0.044696}, {0.295182, 0.044696, 
   0.416668}, {0.295182, 1.0447, 0.416668}, {1.29518, 1.0447, 
   0.416668}, {0.044696, 0.416668, 0.295182}, {0.044696, 1.41667, 
   0.295182}, {1.0447, 1.41667, 
   0.295182}, {-0.416668, -0.295182, -0.044696}, {-0.416668, 
   0.704818, -0.044696}, {0.583332, 
   0.704818, -0.044696}, {-0.295182, -0.044696, -0.416668}, \
{-0.295182, 0.955304, -0.416668}, {0.704818, 
   0.955304, -0.416668}, {-0.044696, -0.416668, -0.295182}, \
{-0.044696, 0.583332, -0.295182}, {0.955304, 0.583332, -0.295182}}
ClearAll[FoldNegative, FoldPositive]
FoldNegative[x_] := If[x < 0, x + 1, x]
FoldPositive[x_] := If[x >= 1, x - 1, x]
SetAttributes[FoldNegative, Listable]
SetAttributes[FoldPositive, Listable]
Print["Corrected Data"]
data3 = FoldPositive[FoldNegative[data]]
Print["Final Data"]
DeleteDuplicates[data3, SameQ[Round[#1, 10^-4], Round[#2, 10^-4]] &]

The Output is

{{0.416668, 0.295182, 0.044696}, {0.416668, 1.29518, 
  0.044696}, {1.41667, 1.29518, 0.044696}, {0.295182, 0.044696, 
  0.416668}, {0.295182, 1.0447, 0.416668}, {1.29518, 1.0447, 
  0.416668}, {0.044696, 0.416668, 0.295182}, {0.044696, 1.41667, 
  0.295182}, {1.0447, 1.41667, 
  0.295182}, {-0.416668, -0.295182, -0.044696}, {-0.416668, 
  0.704818, -0.044696}, {0.583332, 
  0.704818, -0.044696}, {-0.295182, -0.044696, -0.416668}, {-0.295182,
   0.955304, -0.416668}, {0.704818, 
  0.955304, -0.416668}, {-0.044696, -0.416668, -0.295182}, {-0.044696,
   0.583332, -0.295182}, {0.955304, 0.583332, -0.295182}}

Corrected Data

{{0.416668, 0.295182, 0.044696}, {0.416668, 0.29518, 
  0.044696}, {0.41667, 0.29518, 0.044696}, {0.295182, 0.044696, 
  0.416668}, {0.295182, 0.0447, 0.416668}, {0.29518, 0.0447, 
  0.416668}, {0.044696, 0.416668, 0.295182}, {0.044696, 0.41667, 
  0.295182}, {0.0447, 0.41667, 0.295182}, {0.583332, 0.704818, 
  0.955304}, {0.583332, 0.704818, 0.955304}, {0.583332, 0.704818, 
  0.955304}, {0.704818, 0.955304, 0.583332}, {0.704818, 0.955304, 
  0.583332}, {0.704818, 0.955304, 0.583332}, {0.955304, 0.583332, 
  0.704818}, {0.955304, 0.583332, 0.704818}, {0.955304, 0.583332, 
  0.704818}}

Final Data

{{0.416668, 0.295182, 0.044696}, {0.295182, 0.044696, 
  0.416668}, {0.044696, 0.416668, 0.295182}, {0.583332, 0.704818, 
  0.955304}, {0.704818, 0.955304, 0.583332}, {0.955304, 0.583332, 
  0.704818}}
12

Since the comparison is symmetric you could (should!) use DeleteDuplicatesBy:

DeleteDuplicatesBy[data3, Round[#, 10^-4]&]

That is faster as less comparisons are needed, and it is easier to read.

13

Yes, DeleteDuplicatesBy will be significantly faster. Nice suggestion, Sander.