Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

This might be easy, but can't find a way to use DeleteDuplicates to get also list of the actual duplicates.

Example:

lstA = {1, 2, 4, 4, 6, 7, 8, 8};
r = DeleteDuplicates[lstA]
(* {1, 2, 4, 6, 7, 8} *)

I also wanted to get list of the actual duplicates, which are {4,8} in this example. It would have been nice if DeleteDuplicates would also return those, but there is no option there for that. I do not know what many Mathematica functions do not return back more useful information when called. Many seem to return one piece of information only, and one has to call another function to get another piece of information.

For example, here DeleteDuplicates could had an API like this

{r,d}=DeleteDuplicates[lst]

and r will contain the list after duplicates are moved, but d would contain the actual list of duplicates. To make it even more useful, it can be

{r,d,p}=DeleteDuplicates[lst]

Where p will be the positions of the duplicates in the original list. Matlab seems to do it this way. Many functions there can return more than one piece of information at a time. This might be due to WL being functional programming language, and designed for cascading function calls, where each function only does one thing at a time. I am not sure now.

DeleteDuplicates.html

share|improve this question
    
You want to get list of the duplicates in general, or such list with DeleteDuplicates usage? –  Kuba Nov 28 '13 at 8:34
    
@Kuba actually I found couple of places where they talk about finding positions of duplicates in lists but did not yet understand the code. I was hoping that DeleteDuplicate can do it. But if you know of an easy way to get list of duplicates (without using DeleteDuplicates) that will work also. Thanks. –  Nasser Nov 28 '13 at 8:51
7  
What's with the wolfram-language tag? Is it necessary? In principle, this tag could be applied to every question... –  István Zachar Nov 28 '13 at 12:03
6  
Sorry if I sounded harsh, but I really don't share SW's zeal about all the "new" products. And as I gathered it, Wolfram Language is really not much more than (the core of) Mathematica, so I guess we don't want to go down the slope where we end up retagging all questions here and/or on SO, or even renaming Mathematica.SE to Wolfram.SE. Personally I find it bad style to name a product and a language after yourself. –  István Zachar Nov 29 '13 at 8:00
1  
@IstvánZachar I agree. This tag is now banned at the system level and can no longer be used. Please also be on the lookout for variations of "wolfram-language". –  rm -rf Dec 1 '13 at 16:28

11 Answers 11

up vote 19 down vote accepted

Perhaps one of the simplest ways is to use Tally:

p = {1, 2, 4, 4, 6, 7, 8, 8};

Cases[Tally @ p, {x_, n_ /; n > 1} :> x]
{4, 8}

A somewhat faster formulation:

Pick[#, Unitize[#2 - 1], 1] & @@ Transpose[Tally @ p]

Taking the optimization to a rather excessive degree:

#[[SparseArray[#2, Automatic, 1]["AdjacencyLists"]]] & @@ Transpose[Tally @ p]

Though not as fast as the SparseArray optimized form of Tally, an alternative is to use Split after sorting. This is reasonably clean and fast:

Flatten[Split @ Sort @ p, {2}][[2]]
{4, 8}

For Integer data this method is twice as fast as any other listed here:

With[{s = Sort @ p},
 DeleteDuplicates @ 
   s[[ SparseArray[Unitize @ Differences @ s, Automatic, 1]["AdjacencyLists"] ]]
]

Timings

p = RandomInteger[1*^8, 1*^6];

Cases[Tally @ p, {x_, n_ /; n > 1} :> x] // Timing // First

Pick[#, Unitize[#2 - 1], 1] & @@ Transpose[Tally @ p] // Timing // First

#[[SparseArray[#2, Automatic, 1]["AdjacencyLists"]]] & @@ Transpose[Tally @ p] //
  Timing // First

Flatten[Split @ Sort @ p, {2}][[2]] // Timing // First

With[{s = Sort @ p},
 DeleteDuplicates @ 
   s[[ SparseArray[Unitize @ Differences @ s, Automatic, 1]["AdjacencyLists"] ]]
] // Timing // First
0.827

0.343

0.265

0.343

0.11
share|improve this answer
1  
@Nasser & Mr.Wizard I like this answer but it is not the final answer to the question. You havn't asked about list of duplicates but about that and standard result from DD at once. I don't mean that something terrible is going on here but it is strange that the accepted answer do not fit the question, isn't it? :) –  Kuba Nov 29 '13 at 7:44
1  
I agree with @Kuba, as if one omits the request for the advanced API the question becomes quite trivial, perhaps even would have been closed down due to the fact that the answer is easy to find in the documentation. Nevertheless, I (and others no doubt) find the Q inspiring, as it forced me to explore Reap in more depths. –  István Zachar Nov 29 '13 at 7:51
    
Kuba and @István I didn't see the point in packaging this into a function that returns "{r, d, p}". Methods for the positions of duplicates can be found here. If you are focusing on the "API" I believe that has been asked before, perhaps by rm -rf. I'll try to find it. –  Mr.Wizard Nov 29 '13 at 12:26
1  
1  
The difference is that the result in form {r, d, p} is more challenging in terms of efficiency. For example in my myClone positions are gathered with additional scanning, where one could get them earlier if knows how. –  Kuba Nov 29 '13 at 12:58

If you have to use DeleteDuplicates you can use Sow/Reap:

{#, Pick @@ Transpose[GatherBy[#2[[1]]][[;; , 1]]]} & @@ Reap[
   DeleteDuplicates[lstA, (Sow[{#1, SameQ[##]}]; SameQ[##]) &]]
{{1, 2, 4, 6, 7, 8}, {4, 8}}

Here's more general and faster approach:

myClone[list_, test_: Identity] := Composition[
       {#[[1]], #[[2]], Position[list, #] & /@ #[[2]]} &,
       {#[[;; , 1]], DeleteCases[#, {_}][[;; , 1]]} &,
       GatherBy[#, test] &
       ][list]

lstA = RandomInteger[10, 10]
myClone[lstA]
{5, 6, 3, 5, 10, 10, 8, 7, 0, 10}

{{5, 6, 3, 10, 8, 7, 0}, {5, 10}, {{{1}, {4}}, {{5}, {6}, {10}}}}
share|improve this answer
    
Nice. Now would it not be good if Mathematica DeleteDuplicate returned both of these lists as well? (if user wanted) –  Nasser Nov 28 '13 at 8:53
    
@Nasser I don't know, I think it might be the case where there is no "most useful output" so they left it in quite raw form :) –  Kuba Nov 28 '13 at 9:00

I am posting a second answer because this is a different method unrelated to the first.
I wondered how I might approach this if Tally did not exist. I came up with using Ordering on a reverse-sorted list as a way to look for duplicates. It seems to work, and I think it's fairly interesting. By nature it sorts the list of duplicates rather than giving them in order of appearance as Tally does.

duplicates[p_] := 
 With[{sp = Sort@p}, 
   sp[[SparseArray[Unitize[1 - Differences@Ordering@Reverse@Sort@sp], Automatic, 1][
     "AdjacencyLists"]]]] // DeleteDuplicates

duplicates[{1, 2, 4, 4, 6, 7, 8, 8}]
{4, 8}

It is competitively fast compared to my first answer:

p = RandomInteger[8*^6, 2*^6];

Cases[Tally@p, {x_, n_ /; n > 1} :> x] // Length // Timing

Pick[#, Unitize[#2 - 1], 1] & @@ Transpose[Tally@p] // Length // Timing

#[[SparseArray[#2, Automatic, 1]["AdjacencyLists"]]] & @@ Transpose[Tally@p] // 
  Length // Timing

duplicates[p] // Length // Timing
{1.607, 212376}

{0.686, 212376}

{0.562, 212376}

{0.452, 212376}

On lists with extreme duplication it is a bit slower:

p = RandomInteger[1*^6, 5*^6];

(* same timing code as before *)
{1.482, 959893}

{1.014, 959893}

{0.936, 959893}

{1.342, 959893}
share|improve this answer

Important: Union with one argument does exactly what I describe below. I don't know how I missed that for so long. Anyway I suppose it is still nice to be able to return a list of the positions of the duplicates. And there may be other cases where you know a result is sorted I guess.

Original answer

I have long been a bit frustrated about the fact that there is neither an option for Sort that deletes duplicates, nor an option for DeleteDuplicates that makes it assume its input is sorted. DeleteDuplicates probably first sorts its argument, but still even determining that a list is sorted is unnecessary overhead. I saw that in your question the numbers were sorted, so I have focussed on this case.

In my opinion, your questions and my own made for a good case to make a library with LibraryLink. Here is the code. It is a bit long, especially because similar code is used over and over.

#include "WolframLibrary.h"

static MTensor positions;
// static MTensor frequencies;

/* Return the version of Library Link */
DLLEXPORT mint WolframLibrary_getVersion( ) {
    return WolframLibraryVersion;
}

/* Initialize Library */
DLLEXPORT int WolframLibrary_initialize( WolframLibraryData libData) {
    return LIBRARY_NO_ERROR;
}

/* Uninitialize Library */
DLLEXPORT void WolframLibrary_uninitialize( WolframLibraryData libData) {
    return;
}

//DD is for delete duplicates
DLLEXPORT int sortedDD_T_T(WolframLibraryData libData, mint Argc, MArgument *Args, MArgument Res) {
    MTensor input; //not redundant as we access this two times, once for data and once for dimension
    MTensor result;

    int err = LIBRARY_NO_ERROR;

    mint *inputDataPtr;
    mint *resultDataPtr;

    mint inputDataLen;

    input = MArgument_getMTensor(Args[0]);

    inputDataPtr = libData->MTensor_getIntegerData(input);

    inputDataLen = * libData->MTensor_getDimensions(input);

    mint array[inputDataLen];
    mint *arrayPtr;
    arrayPtr = array;

//below is basically the first (0th) iteration
    mint max = *inputDataPtr;
    inputDataPtr++;
    *arrayPtr = max;
    arrayPtr++;

    mint val;
    mint resultDataLenCounter = 1;
    mint iiii;

    for(iiii = 1; iiii < inputDataLen; iiii++)
    {
        val = *inputDataPtr;
        inputDataPtr++;
        if( val != max)
        {
            *arrayPtr = val;
            arrayPtr++;
            resultDataLenCounter++;
            max = val;
        }
    }

    err = libData->MTensor_new(MType_Integer, 1, &resultDataLenCounter, &result);
    if(err) goto error_label;

    resultDataPtr = libData->MTensor_getIntegerData(result);

    arrayPtr = array;

    for(iiii = 0; iiii < resultDataLenCounter; iiii++){
        *(resultDataPtr++) = * (arrayPtr++);
    }

    libData->MTensor_disown(input);

    MArgument_setMTensor(Res, result);
    return err;

    error_label:
    libData->MTensor_disown(input);

    if(!err) err = 1;
    return err; 

}


//WP is for with positions

DLLEXPORT int sortedDDWP_T_T(WolframLibraryData libData, mint Argc, MArgument *Args, MArgument Res) {
    MTensor input; //not redundant as we access this two times, once for data and once for dimension
    MTensor result;

    int err = LIBRARY_NO_ERROR;

    mint *inputDataPtr;
    mint *resultDataPtr;
    mint *posDataPtr;

    mint inputDataLen;

    input = MArgument_getMTensor(Args[0]);

    inputDataPtr = libData->MTensor_getIntegerData(input);

    inputDataLen = * libData->MTensor_getDimensions(input);

    mint uqArray[inputDataLen];
    mint *uqArrayPtr;
    uqArrayPtr = uqArray;

    mint posArray[inputDataLen];
    mint *posArrayPtr;
    posArrayPtr = posArray;

    mint posLen;


//below is basically the first (0th) iteration
    mint max = *inputDataPtr;
    inputDataPtr++;
    *uqArrayPtr = max;
    uqArrayPtr++;

    mint val;
    mint resultDataLenCounter = 1;
    mint iiii;

    for(iiii = 1; iiii < inputDataLen; iiii++)
    {
        val = *inputDataPtr;
        inputDataPtr++;
        if( val != max)
        {
            *uqArrayPtr = val;
            uqArrayPtr++;
            resultDataLenCounter++;
            max = val;
        } 
        else 
        {
            *posArrayPtr = iiii;
            posArrayPtr++;
        }
    }

    posLen = inputDataLen - resultDataLenCounter;

    err = libData->MTensor_new(MType_Integer, 1, &resultDataLenCounter, &result);
    if(err) goto error_label;

    err = libData->MTensor_new(MType_Integer, 1, &posLen, &positions);
    if(err) goto error_label;

    resultDataPtr = libData->MTensor_getIntegerData(result);
    posDataPtr = libData->MTensor_getIntegerData(positions);

    uqArrayPtr = uqArray;
    posArrayPtr = posArray;

    for(iiii = 0; iiii < resultDataLenCounter; iiii++){
        *(resultDataPtr++) = * (uqArrayPtr++);
    }

    for(iiii = 0; iiii < posLen; iiii++){
        *(posDataPtr++) = *(posArrayPtr++);
    }

    libData->MTensor_disown(input);

    MArgument_setMTensor(Res, result);
    return err;

    error_label:
    libData->MTensor_disown(input);

    if(!err) err = 1;
    return err; 

}

DLLEXPORT int getPositions(WolframLibraryData libData, mint Argc, MArgument *Args, MArgument Res) {

    MArgument_setMTensor(Res, positions);
    // libData->MTensor_disown(positions);
    return 0;
}

for the steps ("instructions") for compiling and linking the code, please see my answer here.

(* libraryName = "libraryName"; *) (*this is the last line from the "instructions"*)

The following code loads the functions.

SortedDD is the function that simply deletes duplicates from a sorted list.

sortedDD = 
 LibraryFunctionLoad[libraryName, 
  "sortedDD_T_T", {{Integer, 1, "Shared"}}, {Integer, 1}]

sortedDDWP is the function that makes a list with duplicates deleted, as well of a list of positions of the duplicates.

sortedDDWP = 
 LibraryFunctionLoad[libraryName, 
  "sortedDDWP_T_T", {{Integer, 1, "Shared"}}, {Integer, 1}]

As we can only return one argument in LibraryLink, we have to work around this and get the positions with another function call. This is what getPos does.

getPos = LibraryFunctionLoad[libraryName, 
  "getPositions", {}, {Integer, 1}]

Performance

WARNING: One big problem with my code is that it crashes the kernel for large input. This is because of a stackoverflow that I intend to fix.

Now let's create some random numbers. I chose to generate a BinomialProcess, i.e., a process that increases by with probably 1/2 and otherwise stays the same. So a sequence could be normal = {0,1,1,1,2,2} and we expect about 50% duplicates.

nnnn = 1002000;
randomize :=
 Block[{rands},
  rands = RandomInteger[1, nnnn];
  normal = Accumulate[rands]
  ];

now let's compare with DeleteDuplicates

sortedDD@normal // Timing // First
DeleteDuplicates@normal // Timing // First

0.008401
0.018445

That is quite nice :). Now let's see what happens if we also generate the positions list

kkkk = 522000;
(
   mOut =
     {
      sortedDDWP[normal[[;; kkkk]]],
      getPos[]
      };
   ) // Timing // First

0.006506

and we have

mOut[[1]] == Delete[normal[[;; kkkk]], List /@ mOut[[2]]]

True

Notes about the C Code

If you read the C Code, you will that I make an array, only to copy the contents of that array into another array. Unfortunately I think there is no good way around this.

share|improve this answer
    
Oh by the way to get the actual duplicates just do Part[normal[[;;kkkk]], mOut[[2]]] –  Jacob Akkerboom Dec 2 '13 at 0:25
1  
I don't think DeleteDuplicates sorts its argument first: DeleteDuplicates[{5, 4, 3, 4, 1}, (Print[{##}]; SameQ[##]) &] clearly reports otherwise. –  István Zachar Dec 2 '13 at 9:49
    
@IstvánZachar it's possible that the behavior is different for a user specified test. I could not find a claim of this for DeleteDuplicates, but here Leonid claims the behavior for Union changes. –  Jacob Akkerboom Dec 2 '13 at 11:55
    
You are right Jacob, similar tests for DeleteDuplicates indicate similar increase in time when SameQ[##]& is used instead of SameQ. Thanks for pointing it out! –  István Zachar Dec 2 '13 at 13:47
    
@IstvánZachar :) no problem! Good that you tested it out. However do not underestimate the impact on timing of that SameQ[##]& requires the tests to be evaluated by Mathematica, whereas otherwise everything can be done "in C". I wish my code worked on larger data so we could do more comparisons. The most convincing thing for me is that calling DeleteDuplicates on increasingly large lists seems to give a (quasi-)linear increase in timing. –  Jacob Akkerboom Dec 2 '13 at 14:02

Another way to get the dupe-free list and the list of duplicates:

With[{grouped = Gather[lstA, SameQ], pattern = {x_, __} :> x},
    {Flatten@Replace[grouped, pattern, 1], Cases[grouped, pattern]}
]
(* {{1, 2, 4, 6, 7, 8}, {4, 8}} *)
share|improve this answer

This uses a function which redefines itself, and MapIndexed to get the position data:

deldup[z_] := Module[{f},
  f[x_, _] := (f[x, q_] := (Sow[q, x]; Unevaluated@Sequence[]); x);
  Reap[MapIndexed[f, z], _, Rule]]

deldup[{1, 2, 3, 4, 2, 3, 2}]
(* {{1, 2, 3, 4}, {2 -> {{5}, {7}}, 3 -> {{6}}}} *)
share|improve this answer

Some variants with Reap/Sow or Tally:

fun1[u_] := {#[[1]], Pick[#[[1]], (# > 1) & /@ #[[2]]]} &@
  Transpose[Reap[Sow[1, #] & /@ u, _, {#1, Total@#2} &][[2]]]

or

fun2[u_] := {#[[1]], Pick[#[[1]], (# > 1) & /@ #[[2]]]} &@
  Transpose@Tally[u]
share|improve this answer
    
I am giving a +1 for using Transpose@Tally[u] but see my answer for a faster method to do the second part. –  Mr.Wizard Nov 28 '13 at 11:12
    
@Mr.Wizard thank you for instruction...am always glad to improve...Unitize very nice –  ubpdqn Nov 29 '13 at 6:30

Similar to Kuba's solution, but more compact, using Reap's third argument to remove duplicates from the duplicates:

x = {1, 2, 3, 4, 5, 4, 4, 4, 5, 1};

Reap[DeleteDuplicates[x, If[SameQ[##], Sow@#1; True, False] &], _, Union@#2 &]
 {{1, 2, 3, 4, 5}, {{1, 4, 5}}}
share|improve this answer
CustomDeleteDuplicates[lst_List] := 
 Module[{lstA = lst}, {lstA //. {s___, a_, a_, g___} -> {s, a, g}, 
   Complement[lstA, lstA //. {s___, a_, a_, g___} -> {s, 0, g}]}]

{{1, 2, 4, 6, 7, 8}, {4, 8}}

EDIT: As pointed out I have updated code that is working with all use cases. I have used patterns to find out duplicates to filter out as many repetitions as can be made. It will filter out all even pairs and last remaining in case of odd count will be dealt with next function acting on it.

CustomDeleteDuplicates[li_List] := 
 Block[{l = li}, {Flatten[l] //. {s___, a_, k___, a_, g___} -> {s, a, k, g}, 
   Complement[l,Pick[(l //. {s___, a_, k___, a_, g___} -> {s, k, g}), 
     Count[l, #] & /@ (l //. {s___, a_, k___, a_, g___} -> {s, k, g}),  1]]}]

{13, 12, 2, 15, 2, 6, 7, 2, 4, 7, 12, 15, 6, 15, 12, 14, 15, 10, 14, 1}

Gather[l]

{{13}, {12, 12, 12}, {2, 2, 2}, {15, 15, 15, 15}, {6, 6}, {7, 7}, {4}, {14, 14}, {10}, {1}}

CustomDeleteCases[l]

{{13, 12, 2, 15, 6, 7, 4, 14, 10, 1}, {2, 6, 7, 12, 14, 15}}

And an even simpler solution with ReplaceRepeated:

list = {13, 12, 2, 15, 2, 6, 7, 2, 4, 7, 12, 15, 6, 15, 12, 14, 15, 10, 14, 1};
{list, {}} //. {{a___, b_, c___, b_, d___}, {du___}} :> {{a, b, c, d}, Union@{du, b}}
 {{13, 12, 2, 15, 6, 7, 4, 14, 10, 1}, {2, 6, 7, 12, 14, 15}}
share|improve this answer
    
This only works if the duplicates are next to each other, and there are no more than 2 of each. You should also use RuleDelayed (:>) instead of Rule (->) if using named patterns to avoid interference with any predifined s, a or g. –  István Zachar Nov 29 '13 at 10:07
    
@IstvánZachar : Actually I knew my mistake, I have updated it now, I think its working fine now. I always had some doubt about -> vs ':>`, now I think am more clear on reading your comment. Thanks :) –  Rorschach Nov 30 '13 at 16:43
    
I still find it pretty convoluted :) You scan through the lists so many times! Also, the Block is unnecessary, you could work on li` directly; Complement and Pick can be replaced by Union; you do the //. three times, though one would be enough. I could not resist and edited in a simpler solution, because I find your ReplaceRepeated approach quite interesting! Please feel free to revert my edit if you think so! –  István Zachar Nov 30 '13 at 18:25
    
@IstvánZachar I am always open to anyone editing my answer to make it better so, thanks :) . I tend to use 'Block' to prevent any outside variable intervention, nothing else. –  Rorschach Nov 30 '13 at 20:14
    
I see your intention, though li in f[li_]:=(...) is as much local and protected from the outside as l in f[li_]:=Block[{l=li}, (...)]. Block however does not make by itself s, k, g locals. –  István Zachar Dec 1 '13 at 10:10

delinit[v_List] := Module[{f}, f[x_] := (f[x] = x; Unevaluated[]); f/@v] deletes the initial instance of every term in v. All instances after the first are kept, in the order in which they come. This is the logical complement of DeleteDuplicates.

EDIT - deli does the same thing, but faster.

deli[v_List] := Delete[v,Transpose@List@Part[Range[Length@v][[#]],
     Most@FoldList[Plus,1,Length/@Split@v[[#]]]]]& @ Ordering@v
share|improve this answer
    
Nice! I do not know how it works, but it does :) btw, the FE on V 9.01 does not like Unevaluated[] it puts little red marker between the [] but it still worked. –  Nasser Nov 29 '13 at 7:50
    
If you know that v contains no sublists then you could change Unevaluated[] to {} and do Flatten[f/@v]. Or change Unevaluated[] to Hold@Sequence[] and do ReleaseHold[f/@v], which should work no matter what is in v. –  Ray Koopman Nov 29 '13 at 8:01
    
@Nasser - Sorry, I forgot about what's probably the easiest fix -- just change Unevaluated[] to Mr.Wizard's "vanishing function", ##&[]. –  Ray Koopman Nov 30 '13 at 3:00
    
@Nasser you can change the SyntaxInformation of Unevaluated if you like to use the zero or multiple argument form; AFAICT it is perfectly usable that way. Ray, thanks for the mention regarding ##&[] -- it is my favorite method. –  Mr.Wizard Nov 30 '13 at 5:48

Probably not working in every case:

Select[Partition[Sort[lstA], 2, 1, 1], #[[1]] == #[[2]] &][[All, 1]]

(* {4, 8} *)
share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.