Searching for certain triples in a list - wolfram-mathematica

Let’s assume we have a list of elements of the type {x,y,z} for x, y
and z integers. And, if needed x < y < z.
We also assume that the list contains at least 3 such triples.
Can Mathematica easily solve the following problem?
To detect at least one triple of the type {a,b,.}, {b,c,.} and {a,c,.}?
I am more intereseted in an elegant 1-liner than computational efficient solutions.

If I understood the problem, you want to detect triples not necessarily following one another, but generally present somewhere in the list. Here is one way to detect all such triples. First, some test list:
In[71]:= tst = RandomInteger[5,{10,3}]
Out[71]= {{1,1,0},{1,3,5},{3,3,4},{1,2,1},{2,0,3},{2,5,1},{4,2,2},
{4,3,4},{1,4,2},{4,4,3}}
Here is the code:
In[73]:=
Apply[Join,ReplaceList[tst,{___,#1,___,#2,___,#3,___}:>{fst,sec,th}]&###
Permutations[{fst:{a_,b_,_},sec:{b_,c_,_},th:{a_,c_,_}}]]
Out[73]= {{{1,4,2},{4,3,4},{1,3,5}},{{1,4,2},{4,2,2},{1,2,1}}}
This may perhaps satisfy your "one-liner" requirement, but is not very efficient. If you need only triples following one another, then, as an alternative to solution given by #Chris, you can do
ReplaceList[list,
{___, seq : PatternSequence[{a_, b_, _}, {b_, c_, _}, {a_,c_, _}], ___} :> {seq}]

I don't know if I interpreted your question correctly but suppose your list is something like
list = Sort /# RandomInteger[10, {20, 3}]
(*
{{3, 9, 9}, {0, 5, 6}, {3, 4, 8}, {4, 6, 10}, {3, 6, 9}, {1, 4, 8},
{0, 6, 10}, {2, 9, 10}, {3, 5, 9}, {6, 7, 9}, {0, 9, 10}, {1, 7, 10},
{4, 5, 10}, {0, 2, 5}, {0, 6, 7}, {1, 8, 10}, {1, 8, 10}}
*)
then you could do something like
ReplaceList[Sort[list],
{___, p:{a_, b_, _}, ___, q:{a_, c_, _}, ___, r:{b_, c_, _}, ___} :> {p, q, r}]
(* Output:
{{{0, 2, 5}, {0, 9, 10}, {2, 9, 10}}, {{3, 4, 8}, {3, 5, 9},
{4, 5, 10}}, {{3, 4, 8}, {3, 6, 9}, {4, 6, 10}}}
*)
Note that this works since it is given that for any element {x,y,z} in the original list we have x<=y. Therefore, for a triple {{a,b,_}, {a,c,_}, {b,c,_}} \[Subset] list we know that a<=b<=c. This means that the three elements {a,b,_}, {a,c,_}, and {b,c,_} will appear in that order in Sort[list].

To match triples "of the type {a,b,.}, {b,c,.} and {a,c,.}":
list = {{34, 37, 8}, {74, 32, 65}, {48, 77, 18}, {77, 100, 30},
{48, 100, 13}, {100, 94, 55}, {48, 94, 73}, {77, 28, 12},
{90, 91, 51}, {34, 5, 32}};
Cases[Partition[list, 3, 1], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}]

(Edited)
(Tuples was not the way to go)
Do you require something like:
list = RandomInteger[10, {50, 3}];
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}} /; a < b < c]
giving
{{{0, 1, 2}, {1, 5, 2}, {0, 5, 4}},
{{2, 3, 5},{3, 4, 10}, {2, 4, 5}},
{{6, 8, 10}, {8, 10, 10},{6, 10, 0}},
{{2, 4, 5}, {4, 8, 2}, {2, 8, 5}},
{{2, 4, 5}, {4, 7, 7}, {2, 7, 3}},
{{0, 2, 2}, {2, 7, 3}, {0, 7, 2}},
{{0, 2, 1}, {2, 7, 3}, {0, 7, 2}}}
or perhaps (as other have interpreted the question):
Cases[Permutations[
list, {3}], {{a_, b_, _}, {b_, c_, _}, {a_, c_, _}}];

Related

n'th biggest number in a multi-dimensional list in Mathematica

Imagine I have a 2D list of numbers in Mathematica :
myList = Table[{i,i*j},{i,1,10},{j,1,10}];
and I want to retrieve the 5th highest values in an efficient way. Using RankedMax gives an error. For example,
Max[myList]
gives 100 but:
RankedMax[myList,1]
gives :
RankedMax::vec : "Input {{{1, 1}, {1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}, \
{1, 7}, {1, 8}, {1, 9}, {1, 10}}, {{2, 2}, {2, 4}, {2, 6}, {2, 8}, {2, 10}, \
{2, 12}, {2, 14}, {2, 16}, {2, 18}, {2, 20}}, 6, {{9, 9}, {9, 18}, {9, 27}, \
{9, 36}, {9, 45}, {9, 54}, {9, 63}, {9, 72}, {9, 81}, {9, 90}}, {{10, 10}, \
{10, 20}, {10, 30}, {10, 40}, {10, 50}, {10, 60}, {10, 70}, {10, 80}, {10, \
90}, {10, 100}}} is not a vector
How do I use RankedMax on my data or is there any other way around ?
Use Flatten
RankedMax[Flatten#myList,1]
This is fine if he's just looking for the fifth biggest of all the numbers in the table. If, as I suspect, he's looking for the fifth biggest of the calculated terms -- the second element in each pair -- we should slightly amend the previous solution to read:
RankedMax[Flatten#Map[Rest, myList, {2}], 5]

Mathematica: flatten a nested list with repetitions

I have a following list:
lis={{1, {2}}, {3, {4, 5, 6}}, {7, {8, 9}}, {10, {11}}};
I'd like to obtain this:
lis2={{1, 2}, {3, 4}, {3, 5}, {3, 6}, {7, 8}, {7, 9}, {10, 11}};
I can achieve that using nested tables and calculating the length of the second nested list:
Flatten[Table[Table[{lis[[kk, 1]], lis[[kk, 2, ii]]}, {ii, 1, Length[lis[[kk, 2]]]}], {kk, 1, Length[lis]}], 1]
It works, but is there a more straightforward way? Perhaps a combination of Map/Thread/Apply?
One way:
ArrayFlatten[Distribute[#, List] & /# lis, 1]
=> {{1, 2}, {3, 4}, {3, 5}, {3, 6}, {7, 8}, {7, 9}, {10, 11}}
Edit
Or
ArrayFlatten[Thread /# lis, 1]
Edit 2
Or, slightly simpler, as Mr Wizard points out in a comment:
Flatten[Thread /# lis, 1]

Overlapping strips

Suppose I have a series of strips of paper placed along an infinite ruler, with start and end points specified by pairs of numbers. I would like to create a list representing the number of layers of paper at points along the ruler.
For example:
strips =
{{-27, 20},
{ -2, -1},
{-47, -28},
{-41, 32},
{ 22, 31},
{ 2, 37},
{-28, 30},
{ -7, 39}}
Should output:
-47 -41 -27 -7 -2 -1 2 20 22 30 31 32 37 39
1 2 3 4 5 4 5 4 5 4 3 2 1 0
What is the most efficient, clean, or terse way to do this, accommodating Real and Rational strip positions?
Here's one approach:
Clear[hasPaper,nStrips]
hasPaper[y_, z_] := Piecewise[{{1, x <= z && x >= y}}, 0];
nStrips[y_, strip___] := Total#(hasPaper ### strip) /. x -> y
You can get the number of strips at any value.
Table[nStrips[i, strips], {i, Sort#Flatten#strips}]
{1, 2, 3, 3, 3, 4, 5, 5, 5, 5, 5, 5, 4, 3, 2, 1}
Also, plot it
Plot[nStrips[x, strips], {x, Min#Flatten#strips, Max#Flatten#strips}]
Here is one solution:
In[305]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[313]:= int = Interval /# strips;
In[317]:= Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}]
Out[317]= {{-47, 1}, {-41, 2}, {-28, 2}, {-27, 3}, {-7, 4}, {-2,
5}, {-1, 4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32,
2}, {37, 1}, {39, 0}}
EDIT Using SplitBy and postprocessing the following code gets the shortest list:
In[329]:=
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
In[330]:= int = Interval /# strips;
In[339]:=
SplitBy[Thread[{Union[Flatten[strips]],
Join[Count[int, x_ /; IntervalMemberQ[x, #]] & /# (Mean /#
Partition[Union[Flatten[strips]], 2, 1]), {0}]}],
Last] /. {b : {{_, co_} ..} :> First[b]}
Out[339]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1,
4}, {2, 5}, {20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37,
1}, {39, 0}}
You may regard this as a silly approach, but I'll offer it anyway:
f[x_]:=Sum[UnitStep[x-strips[[k,1]]]-UnitStep[x-strips[[k,2]]],{k,Length[strips]}]
f/#Union[Flatten[strips]]
f[u_, s_] := Total[Piecewise#{{1, #1 <= x < #2}} & ### s /. x -> u]
Usage
f[#, strips] & /# {-47, -41, -27, -7, -2, -1, 2, 20, 22, 30, 31, 32, 37, 39}
->
{1, 2, 3, 4, 5, 4, 5, 4, 5, 4, 3, 2, 1, 0}
For Open/Closed ends, just use <= or <
Here's my approach, similar to belisarius':
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31}, {2,
37}, {-28, 30}, {-7, 39}};
pw = PiecewiseExpand[Total[Boole[# <= x < #2] & ### strips]]
Grid[Transpose[
SplitBy[SortBy[Table[{x, pw}, {x, Flatten[strips]}], First],
Last][[All, 1]]], Alignment -> "."]
Here's my attempt - it works on integers, rationals and reals, but makes no claim to being terribly efficient. (I made the same mistake as Sasha, my original version did not return the shortest list. So I stole the SplitBy fix!)
layers[strips_?MatrixQ] := Module[{equals, points},
points = Union#Flatten#strips;
equals = Function[x, Evaluate[(#1 <= x < #2) & ### strips]];
points = {points, Total /# Boole /# equals /# points}\[Transpose];
SplitBy[points, Last] /. {b:{{_, co_}..} :> First[b]}]
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}, {22, 31},
{2, 37}, {-28, 30}, {-7, 39}};
In[3]:= layers[strips]
Out[3]= {{-47, 1}, {-41, 2}, {-27, 3}, {-7, 4}, {-2, 5}, {-1, 4}, {2, 5},
{20, 4}, {22, 5}, {30, 4}, {31, 3}, {32, 2}, {37, 1}, {39, 0}}
In[4]:= layers[strips/2]
Out[4]:= {{-(47/2), 1}, {-(41/2), 2}, {-(27/2), 3}, {-(7/2), 4},
{-1, 5}, {-(1/2), 4}, {1, 5}, {10, 4}, {11, 5}, {15, 4}, {31/2, 3},
{16, 2}, {37/2, 1}, {39/2, 0}}
In[5]:= layers[strips/3.]
Out[5]= {{-15.6667, 1}, {-13.6667, 2}, {-9., 3}, {-2.33333, 4}, {-0.666667, 5},
{-0.333333, 4}, {0.666667, 5}, {6.66667, 4}, {7.33333, 5}, {10.,4},
{10.3333, 3}, {10.6667, 2}, {12.3333, 1}, {13., 0}}
Splice together abutting strips, determine key points where number of layers
changes, and calculate how many strips each key point inhabits:
splice[s_, {}] := s
splice[s_, vals_] := Module[{h = First[vals]},
splice[(s /. {{x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j},
w, z}, {x___, {k_, h}, w___, {h, j_}, z___} :> {x, {k, j}, w,
z}}), Rest[vals]]]
splicedStrips = splice[strips, Union#Flatten#strips];
keyPoints = Union#Flatten#splicedStrips;
({#, Total#(splicedStrips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
// Transpose // TableForm
EDIT
After some struggling I was able to remove splice and more directly eliminate points that did not need checking (-28, in the strips data we've been using) :
keyPoints = Complement[pts = Union#Flatten#strips,
Cases[pts, x_ /; MemberQ[strips, {x, _}] && MemberQ[strips, {_, x}]]];
({#, Total#(strips /. {a_, b_} :> Boole[a <= # < b])} & /# keyPoints)
One approach of solving this is converting the strips
strips = {{-27, 20}, {-2, -1}, {-47, -28}, {-41, 32}
,{ 22, 31}, { 2, 37}, {-28, 30}, {-7, 39}}
to a list of Delimiters, marking the beginning or end of a strip and sort them by position
StripToLimiters[{start_, end_}] := Sequence[BeginStrip[start], EndStrip[end]]
limiterlist = SortBy[StripToLimiters /# strips, First]
Now we can map the sorted limiters to increments/decrements
LimiterToDiff[BeginStrip[_]] := 1
LimiterToDiff[EndStrip[_]] := -1
and use Accumulate to get the intermediate totals of intersected strips:
In[6]:= Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[limiterlist]
Out[6]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
Or without the intermediate limiterlist:
In[7]:= StripListToCountList[strips_]:=
Transpose[{First/##,Accumulate[LimiterToDiff/##]}]&[
SortBy[StripToLimiters/#strips,First]
]
StripListToCountList[strips]
Out[8]= {{-47,1},{-41,2},{-28,3},{-28,2},{-27,3},{-7,4},{-2,5},{-1,4}
,{2,5},{20,4},{22,5},{30,4},{31,3},{32,2},{37,1},{39,0}}
The following solution assumes that the layer count function will be called a large number of times. It uses layer precomputation and Nearest in order to greatly reduce the amount of time required to compute the layer count at any given point:
layers[strips:{__}] :=
Module[{pred, changes, count}
, changes = Union # Flatten # strips /. {c_, r___} :> {c-1, c, r}
; Evaluate[pred /# changes] = {changes[[1]]} ~Join~ Drop[changes, -1]
; Do[count[x] = Total[(Boole[#[[1]] <= x < #[[2]]]) & /# strips], {x, changes}]
; With[{n = Nearest[changes]}
, (n[#] /. {m_, ___} :> count[If[m > #, pred[m], m]])&
]
]
The following example uses layers to define a new function f that will compute the layer count for the provided sample strips:
$strips={{-27,20},{-2,-1},{-47,-28},{-41,32},{22,31},{2,37},{-28,30},{-7,39}};
f = layers[$strips];
f can now be used to compute the number of layers at a point:
Union # Flatten # $strips /. s_ :> {s, f /# s} // TableForm
Plot[f[x], {x, -50, 50}, PlotPoints -> 1000]
For 1,000 layers and 10,000 points, the precomputation stage can take quite a bit of time, but individual point computation is relatively quick:

how to simulate the following scenario in mathematica

Suppose I have n=6 distinct monomers each of which has two distinct and reactive ends. During each round of reaction, one random end unites with another random end, either elongates the monomer to a dimer or self-associates into a loop. This reaction process stops whenever no free ends are present in the system. I want to use Mma to simulate the reaction process.
I am thinking to represent the monomers as a list of strings, {'1-2', '3-4', '5-6', '7-8', '9-10', '11-12'}, then to do one round of reacion by updating the content of the list, for example either {'1-2-1', '3-4', '5-6', '7-8', '9-10', '11-12'} or {'1-2-3-4', '5-6', '7-8', '9-10', '11-12'}. But I am not able to go very far due to my programming limitation in Mma. Could anyone please help? Thanks a lot.
Here is the set-up:
Clear[freeVertices];
freeVertices[edgeList_List] := Select[Tally[Flatten[edgeList]], #[[2]] < 2 &][[All, 1]];
ClearAll[setNew, componentsBFLS];
setNew[x_, x_] := Null;
setNew[lhs_, rhs_] := lhs := Function[Null, (#1 := #0[##]); #2, HoldFirst][lhs, rhs];
componentsBFLS[lst_List] :=
Module[{f}, setNew ### Map[f, lst, {2}]; GatherBy[Tally[Flatten#lst][[All, 1]], f]];
Here is the start:
In[13]:= start = Partition[Range[12], 2]
Out[13]= {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}
Here are the steps:
In[51]:= steps =
NestWhileList[Append[#, RandomSample[freeVertices[#], 2]] &,
start, freeVertices[#] =!= {} &]
Out[51]= {{{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}, {{1,
2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}}, {{1,
2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}, {3,
4}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5,
1}, {3, 4}, {7, 11}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9,
10}, {11, 12}, {5, 1}, {3, 4}, {7, 11}, {8, 2}}, {{1, 2}, {3,
4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}, {5, 1}, {3, 4}, {7, 11}, {8,
2}, {6, 10}}, {{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11,
12}, {5, 1}, {3, 4}, {7, 11}, {8, 2}, {6, 10}, {9, 12}}}
Here are the connected components (cycles etc), which you can study:
In[52]:= componentsBFLS /# steps
Out[52]= {{{1, 2}, {3, 4}, {5, 6}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2,
5, 6}, {3, 4}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2, 5, 6}, {3,
4}, {7, 8}, {9, 10}, {11, 12}}, {{1, 2, 5, 6}, {3, 4}, {7, 8, 11,
12}, {9, 10}}, {{1, 2, 5, 6, 7, 8, 11, 12}, {3, 4}, {9, 10}}, {{1,
2, 5, 6, 7, 8, 9, 10, 11, 12}, {3, 4}}, {{1, 2, 5, 6, 7, 8, 9, 10,
11, 12}, {3, 4}}}
What happens is that we treat all pairs as edges in one big graph, and add an edge randomly if both vertices have at most one connection to some other edge at the moment. At some point, the process stops. Then, we map the componentsBFLS function onto resulting graphs (representing the steps of the simulation), to get the connected components of the graphs (steps). You could use other metrics as well, of course, and write more functions which will analyze the steps for loops etc. Hope this will get you started.
It seems like it would be more natural to represent your molecules as lists rather than strings. So start with {{1,2},{3,4},{5,6}} and so on. Then open chains are just longer lists {1,2,3,4} or whatever, and have some special convention for loops such as starting with the symbol "loop". {{loop,1,2},{3,4,5,6},{7,8}} or whatever.
How detailed does your simulation actually need to be? For instance, do you actually care which monomers end up next to which, or do you only care about the statistics of the lengths of chains? In the latter case, you could greatly simplify the state of your simulation: it could, for instance, consist of a list of loop lengths (which would start empty) and a list of open chain lengths (which would start as a bunch of 1s). Then one simulation step is: pick an open chain at random; with appropriate probabilities, either turn that into a loop or combine it with another open chain.
Mathematica things you might want to look up: RandomInteger, RandomChoice; Prepend, Append, Insert, Delete, ReplacePart, Join; While (though actually some sort of "functional iteration" with, e.g., NestWhile might make for prettier code).
Here's a simple approach. Following the examples given in the question, I've assumed that the monomers have a prefered binding, so that only {1,2} + {3,4} -> {1,2,3,4} OR {1,2,1} + {3,4,3} is possible, but {1,2} + {3,4} -> {1,2,4,3} is not possible. The following code should be packaged up as a nice function/module once you are happy with it. If you're after statistics, then it can also probably be compiled to add some speed.
Initialize:
In[1]:= monomers=Partition[Range[12],2]
loops={}
Out[1]= {{1,2},{3,4},{5,6},{7,8},{9,10},{11,12}}
Out[2]= {}
The loop:
In[3]:= While[monomers!={},
choice=RandomInteger[{1,Length[monomers]},2];
If[Equal##choice,
AppendTo[loops, monomers[[choice[[1]]]]];
monomers=Delete[monomers,choice[[1]]],
monomers=Prepend[Delete[monomers,Transpose[{choice}]],
Join##Extract[monomers,Transpose[{choice}]]]];
Print[monomers,"\t",loops]
]
During evaluation of In[3]:= {{7,8,1,2},{3,4},{5,6},{9,10},{11,12}} {}
During evaluation of In[3]:= {{5,6,7,8,1,2},{3,4},{9,10},{11,12}} {}
During evaluation of In[3]:= {{5,6,7,8,1,2},{3,4},{9,10}} {{11,12}}
During evaluation of In[3]:= {{3,4,5,6,7,8,1,2},{9,10}} {{11,12}}
During evaluation of In[3]:= {{9,10}} {{11,12},{3,4,5,6,7,8,1,2}}
During evaluation of In[3]:= {} {{11,12},{3,4,5,6,7,8,1,2},{9,10}}
Edit:
If the monomers can bind at both ends, you just add a option to flip on of the monomers that you join, e.g.
Do[
choice=RandomInteger[{1,Length[monomers]},2];
reverse=RandomChoice[{Reverse,Identity}];
If[Equal##choice,
AppendTo[loops,monomers[[choice[[1]]]]];
monomers=Delete[monomers,choice[[1]]],
monomers=Prepend[Delete[monomers,Transpose[{choice}]],
Join[monomers[[choice[[1]]]],reverse#monomers[[choice[[2]]]]]]];
Print[monomers,"\t",loops],{Length[monomers]}]
{{7,8,10,9},{1,2},{3,4},{5,6},{11,12}} {}
{{3,4,5,6},{7,8,10,9},{1,2},{11,12}} {}
{{3,4,5,6},{7,8,10,9},{11,12}} {{1,2}}
{{7,8,10,9},{11,12}} {{1,2},{3,4,5,6}}
{{7,8,10,9,11,12}} {{1,2},{3,4,5,6}}
{} {{1,2},{3,4,5,6},{7,8,10,9,11,12}}
I see my implementation mimics Simon's closely. Reminder to self: never go to bed before posting solution...
simulatePolimerization[originalStuff_] :=
Module[{openStuff = originalStuff, closedStuff = {}, picks},
While[Length[openStuff] > 0,
picks = RandomInteger[{1, Length[openStuff]}, 2];
openStuff = If[RandomInteger[1] == 1, Reverse[#], #] & /# openStuff;
If[Equal ## picks,
(* closing *)
AppendTo[closedStuff,Append[openStuff[[picks[[1]]]], openStuff[[picks[[1]], 1]]]];
openStuff = Delete[openStuff, picks[[1]]],
(* merging *)
AppendTo[openStuff,Join[openStuff[[picks[[1]]]], openStuff[[picks[[2]]]]]];
openStuff = Delete[openStuff, List /# picks]
]
];
Return[closedStuff]
]
Some results:

Sort all levels of expression

What's a good way to Sort all levels of an expression? The following does what I want when expression has rectangular structure, but I'd like it to work for non-rectangular expressions as well
Map[Sort, {expr}, Depth[expr] - 1]
For instance, the following should print True
sorted = deepSort[{{{1, 3, 8}, {3, 7, 6}, {10, 4, 9}, {3, 8, 10,
6}, {8, 2, 5, 10}, {8, 5, 10,
9}}, {{{1, 3, 8}, {3, 8, 10, 6}}, {{3, 7, 6}, {3, 8, 10,
6}}, {{10, 4, 9}, {8, 5, 10, 9}}, {{3, 8, 10, 6}, {8, 2, 5,
10}}, {{8, 2, 5, 10}, {8, 5, 10, 9}}}}];
checkSortedLevel[k_] := Map[OrderedQ, sorted, {k}];
And ## Flatten[checkSortedLevel /# Range[0, 2]]
deepSort[expr_] := Map[Sort, expr, {0, -2}]
Note that this will work even if your expr contains heads other than List.
Should you have an expression that contains heads other than List, and you do not want to sort those, this may be useful.
expr /. List :> Composition[Sort, List]

Resources