5
$\begingroup$

I have a list of integers from 1 - 400. I choose n random numbers with replacement from the list.

Here is an example:

list = 
  {5, 14, 15, 29, 38, 100, 112, 139, 156, 165, 195, 217, 
   228, 237, 249, 286, 320, 323, 325, 329, 335, 349}

If I have this list, the routine should find all the sublists with all the elements within 60 of each other

{{5, 14, 15, 29, 38}, {14, 15, 29, 38}, {15, 29, 38}, {29, 38}, 
 {100, 112, 139, 156}, {112, 139, 156, 165}, {139, 156, 165, 195}, 
 {156, 165, 195}, {165, 195, 217}, {195, 217, 228, 237, 249}, 
 {217, 228, 237, 249}, {228, 237, 249, 286}, {237, 249, 286}, {249, 286},
 {286, 320, 323, 325, 329, 335}, {320, 323, 325, 329, 335, 349}, 
 {323, 325, 329, 335, 349}, {325, 329, 335, 349}, {329, 335, 349}, {335, 349}}

list, in this case is sorted but that will generally not be true. I have a small program working now but it is less general and very slow. Can something be done here?

Here is my code:

between[l_] := Module[{}, 
    h = TakeWhile[l, # <= l[[1]] + 60 &];
    s = Drop[s, 1];
    h
]


s = Sort[RandomChoice[Range[400], 22]];
Table[between[s], {Length[s] - 7 + 1}]
Improve this question
$\endgroup$
4
  • 4
    $\begingroup$ You might need to explain a bit more clearly. For example, what's wrong with {5, 14} as one of your sublists? Posting your existing code always helps too. Split and Gather are useful functions for this type of problem. $\endgroup$
    – wxffles
    Jul 17, 2013 at 2:59
  • 1
    $\begingroup$ Hi wxffles; Basically between takes the first element of the list and finds the longest sequence it can. Then the front element is dropped from the global variable s. While it does not get all of them it hopefully gets the longest one which is what I was originally after. $\endgroup$
    – bobbym
    Jul 17, 2013 at 4:20
  • 1
    $\begingroup$ It's generally a good idea to wait a while before accepting an answer. There may be more than one way to skin a cat $\endgroup$
    – DavidC
    Jul 17, 2013 at 7:50
  • $\begingroup$ @David: Hi; I accepted because he exactly explained the command I had been fumbling with. However, Michael E2's routine is smoking on my machine. Fast! $\endgroup$
    – bobbym
    Jul 17, 2013 at 12:44

4 Answers 4

Reset to default
3
$\begingroup$

Nearest with a suitable DistanceFunction, followed by a filtering using Gather can be used to pick the elements:

list = 
  {5, 14, 15, 29, 38, 100, 112, 139, 156, 165, 195, 217, 
   228, 237, 249, 286, 320, 323, 325, 329, 335, 349};

With[{
       nf = Nearest[list, DistanceFunction -> (If[ManhattanDistance[#, #2] <= 60, 0, 1] &)],
       filt = 
         Flatten[Gather[#, ManhattanDistance[#, #2] > 60 &] /. x : {__Integer} :> First@x] &
      },
  Composition[filt, nf] /@ list // DeleteDuplicates
]

(* {{5, 14, 15, 29, 38}, {100, 112, 139, 156}, {112, 139, 156, 165}, 
    {139, 156, 165, 195}, {165, 195, 217}, {195, 217, 228, 237, 249}, {228, 237, 249, 286}, 
    {286, 320, 323, 325, 329, 335}, {320, 323, 325, 329, 335, 349}}*)

If you want all the subsets, you can just call Subsets on each of the sublists above. However, as wxffles notes, your question is underspecified in this regard, because you seem to only consider subsets by dropping the first element successively and that too, only for certain lists.

Improve this answer
$\endgroup$
3
  • $\begingroup$ Hi; Thanks, I was having trouble with an approach like that. Couldn't get it to work. $\endgroup$
    – bobbym
    Jul 17, 2013 at 4:22
  • $\begingroup$ @bobbym Does your comment mean that this answer is what you wanted? Then you should accept it. Otherwise you should explain what is missing. $\endgroup$
    – Jens
    Jul 17, 2013 at 4:53
  • $\begingroup$ How do I accept it? $\endgroup$
    – bobbym
    Jul 17, 2013 at 5:36
4
$\begingroup$

Here's another way to get the output you desire, assuming you are looking for lists that are of length 2 or greater:

list = {5, 14, 15, 29, 38, 100, 112, 139, 156, 165, 195, 217, 228, 
   237, 249, 286, 320, 323, 325, 329, 335, 349};

DeleteCases[
 Pick[#, UnitStep[60 - (# - First@#)] & /@ #, 1] &@ NestList[Rest, list, Length@list - 2],
 _?(Length[#] < 2 &)]

(* {{5, 14, 15, 29, 38}, {14, 15, 29, 38}, {15, 29, 38}, {29, 38},
    {100, 112, 139, 156}, {112, 139, 156, 165}, {139, 156, 165, 195},
    {156, 165, 195}, {165, 195, 217}, {195, 217, 228, 237, 249},
    {217, 228, 237, 249}, {228, 237, 249, 286}, {237, 249, 286},
    {249, 286}, {286, 320, 323, 325, 329, 335}, {320, 323, 325, 329, 335, 349},
    {323, 325, 329, 335, 349}, {325, 329, 335, 349}, {329, 335, 349}, {335, 349}} *)

Alternatively, especially if the list is not sorted, then here's a slightly different way.

SeedRandom[1];
list2 = RandomInteger[{1, 400}, 22]
(* {258, 385, 135, 32, 337, 229, 96, 125, 138, 301, 324, 20, 76, 170,
    397, 10, 193, 318, 341, 175, 48, 115} *)

DeleteCases[
 Pick[list2, UnitBox[Rescale[list2, {#, # + 60}, {-0.5, 0.5}]], 1] & /@ list2,
 _?(Length[#] < 2 &)]

(* {{258, 301, 318}, {385, 397}, {135, 138, 170, 193, 175}, {32, 76, 48},
    {385, 337, 397, 341}, {258, 229}, {135, 96, 125, 138, 115},
    {135, 125, 138, 170, 175}, {138, 170, 193, 175}, {337, 301, 324, 318, 341},
    {337, 324, 341}, {32, 20, 76, 48}, {135, 96, 125, 76, 115},
    {229, 170, 193, 175}, {32, 20, 10, 48}, {229, 193}, {337, 324, 318, 341},
    {385, 397, 341}, {229, 193, 175}, {96, 76, 48}, {135, 125, 138, 170, 175, 115}} *)
Improve this answer
$\endgroup$
2
  • $\begingroup$ Hi; Also very nice solutions that are working, thanks. $\endgroup$
    – bobbym
    Jul 17, 2013 at 5:42
  • $\begingroup$ That is quite fast. +1 $\endgroup$
    – Mr.Wizard
    Jul 17, 2013 at 7:18
4
$\begingroup$

Maybe I am a bit late, but here's another approach to the problem. To be honest, I do not have any idea how fast my approach is compared to the other ones presented, but I always wanted to use Longest in a "real-life" problem, so here we go:

Using your list (it must be sorted):

list = 
      {5, 14, 15, 29, 38, 100, 112, 139, 156, 165, 195, 217, 
       228, 237, 249, 286, 320, 323, 325, 329, 335, 349};

We apply a pattern and ReplaceAll:

list /. 
  {{___, #, Longest[y___], z_, ___} /; z <= # + 60 :> {#, y, z}, _ :> (## &[])} & /@ list

and get:

{{5, 14, 15, 29, 38}, {14, 15, 29, 38}, {15, 29, 38}, {29, 38}, {100, 112, 139, 156}, {112, 139, 156, 165}, {139, 156, 165, 195}, {156, 165, 195}, {165, 195, 217}, {195, 217, 228, 237, 249}, {217, 228, 237, 249}, {228, 237, 249, 286}, {237, 249, 286}, {249, 286}, {286, 320, 323, 325, 329, 335}, {320, 323, 325, 329, 335, 349}, {323, 325, 329, 335, 349}, {325, 329, 335, 349}, {329, 335, 349}, {335, 349}}

I am not sure how much explanation you need to understand that. Maybe I highlight the central pattern:

 {{___, #, Longest[y___], z_, ___} /; z <= # + 60 :> {#, y, z}

This matches any sequence starting with some numbers or none, then the number # (this is a slot that will be filled with the elements of list, see the Map at the end of the code), then a sequence of numbers (called y___, where y can be "empty"), and finally z, followed by more numbers (or none). We condition z to be <= # + 60, as you desire. This pattern will be replaced by {#, y, z}, which is what you want, I hope. The second pattern is to get rid of the ones that do not match the first one, e.g. when we call 38 (it will be replaced by ##&[], a.k.a. Unevaluated[Sequence[]].

I hope this helps!

Improve this answer
$\endgroup$
3
$\begingroup$

Here is a rather literal method:

near[a_, n_] :=
  DeleteCases[Pick[a, IntervalMemberQ[Interval[{#, # + n}], a]] & /@ a, {_}]

near[list, 60]

{{5, 14, 15, 29, 38}, {14, 15, 29, 38}, {15, 29, 38}, {29, 38}, {100, 112, 139, 156},
 {112, 139, 156, 165}, {139, 156, 165, 195}, {156, 165, 195}, {165, 195, 217},
 {195, 217, 228, 237, 249}, {217, 228, 237, 249}, {228, 237, 249, 286}, {237, 249, 286},
 {249, 286}, {286, 320, 323, 325, 329, 335}, {320, 323, 325, 329, 335, 349},
 {323, 325, 329, 335, 349}, {325, 329, 335, 349}, {329, 335, 349}, {335, 349}}

This is appropriate for short lists which may be your application if "a list of integers from 1 - 400" is not merely an example, but very long lists will be slower. Michael's method should be fast, but in version 7 I need this SparseArray trick for best performance:

near2[a_, n_] := 
 DeleteCases[#[[SparseArray[UnitStep[n + First@# - #]]@"AdjacencyLists"]] & /@ 
   NestList[Rest, a, Length@a - 2], {_}]
Improve this answer
$\endgroup$
1
  • $\begingroup$ +1. I'll have to remember DeleteCases[.., {_}] -- I was stuck thinking in terms of Length, which I knew would slow things down a little. $\endgroup$
    – Michael E2
    Jul 17, 2013 at 12:54

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.