Eliminate element of every list within a nested list - wolfram-mathematica

I would like to eliminate the third element of every list within a nested list.
E.g.,
lst = { {1, 0, 0}, {1, 1, 1}, {1, 1, 4} }
So it would become
{ {1, 0}, {1, 1}, {1, 1} }
How should I do that?

yet another:
lst = #[[1;;2]] & /# lst
or if you want to drop only the third element from possibly longer sublists:
lst = Drop[#,{3}]& /# lst

Lots of way to do that, e.g.
lst = {{1, 0, 0}, {1, 1, 1}, {1, 1, 4}};
lst = lst[[All, {1, 2}]]
{{1, 0}, {1, 1}, {1, 1}}
Or
lst = Transpose[Most[Transpose[lst]]]
Or, without transposing
lst = MapThread[Delete, {lst, Table[3, {Length[lst]}]}]

Related

Efficiently generating "subtraction chains"

I posted another question earlier if you want some context. It appears that I was on the wrong path with that approach.
Addition chains can be used to minimize the number of multiplications needed to exponentiate a number. For example, a7 requires four multiplications. Two to compute a2=a×a and a4=a2×a2, and another two to compute a7=a4×a2×a.
Similarly, I'm trying to generate all of the possible "subtraction chains" for a set of numbers. For example, given the set of numbers {1, 2, 3}, I'm trying to generate the following permutations.
{1, 2, 3}
{1, 2, 3}, {1, 2}
{1, 2, 3}, {1, 2}, {1}
{1, 2, 3}, {1, 2}, {2}
{1, 2, 3}, {1, 2}, {1}, {2}
{1, 2, 3}, {1, 3}
{1, 2, 3}, {1, 3}, {1}
{1, 2, 3}, {1, 3}, {3}
{1, 2, 3}, {1, 3}, {1}, {3}
{1, 2, 3}, {2, 3}
{1, 2, 3}, {2, 3}, {2}
{1, 2, 3}, {2, 3}, {3}
{1, 2, 3}, {2, 3}, {2}, {3}
{1, 2, 3}, {1, 2}, {1, 3}
{1, 2, 3}, {1, 2}, {1, 3}, {1}
{1, 2, 3}, {1, 2}, {1, 3}, {2}
{1, 2, 3}, {1, 2}, {1, 3}, {3}
{1, 2, 3}, {1, 2}, {1, 3}, {1}, {2}
{1, 2, 3}, {1, 2}, {1, 3}, {1}, {3}
{1, 2, 3}, {1, 2}, {1, 3}, {2}, {3}
{1, 2, 3}, {1, 2}, {1, 3}, {1}, {2}, {3}
# and so on...
Where each element in the permutation (besides {1, 2, 3}) can be found by removing a single element from another set in the permutation.
For example, the permutation {1, 2, 3}, {1} is invalid because {1} can not be constructed by removing a single element from {1, 2, 3}.
Is there a known algorithm to find this subset of the power set of a power set? My implementation will be in Python, but the question is language agnostic. Also, I don't actually want the permutations which contain a set with a single element (e.g. {1, 2, 3}, {1, 2}, {1}) because they corresponds to a "dictator" case which is not of interest.
An algorithm to generate all those lists as you describe it could work as follows: For each set in the current list, create a copy, remove one element, add it to the list, and call the algorithm recursively. You also have to make sure not to generate duplicates, which could by done by ensuring that the new list is "smaller" (by length or pairwise comparison of the (sorted) elements) than the previous one.
Here's an implementation in Python, as a generator function, without much optimization. This seems to work pretty well now, generating all the subsets without any duplicates.
def generate_sets(sets, min_num=2):
yield sets
added = set() # new sets we already generated in this iteration
for set_ in sets:
# only if the current set has the right length
if min_num < len(set_) <= len(sets[-1]) + 1:
for x in set_:
# remove each element in turn (frozenset so we can put in into added)
new = set_.difference({x})
# prevent same subset being reachable form multiple sets
frozen = frozenset(new)
if frozen not in added:
added.add(frozen)
# recurse only if current element is "smaller" than last
if (len(new), sorted(new)) < (len(sets[-1]), sorted(sets[-1])):
for result in generate_sets(sets + [new], min_num):
yield result
For generate_sets([{1,2,3}], min_num=2) this generates the following lists:
[{1, 2, 3}]
[{1, 2, 3}, {2, 3}]
[{1, 2, 3}, {2, 3}, {1, 3}]
[{1, 2, 3}, {2, 3}, {1, 3}, {1, 2}]
[{1, 2, 3}, {2, 3}, {1, 2}]
[{1, 2, 3}, {1, 3}]
[{1, 2, 3}, {1, 3}, {1, 2}]
[{1, 2, 3}, {1, 2}]
For generate_sets([{1,2,3}], 1), a total of 45 lists of sets are generated.
However, I fail to see the connection to your previous question: Shouldn't {1, 2, 3}, {1, 2}, {1, 2, 3}, {1, 3}, and {1, 2, 3}, {2, 3} all be considered equivalent?

two questions on string manipulation in Mathematica

Given a character or a string s, generate a result string with n (an integer) repeats of s
Given a list of characters or strings, and a list of the frequencies of their appearance (in correspondence), generate a result string with each string in the list repeated with the desired times as specified in the second list and StringJoin them together. For example, given {"a", "b", "c"} and {1,0,3}, I want to have "accc".
I of course want to have the most efficient way of doing these. Otherwise, my own way is too ugly and slow.
Thank you for your help!
rep[s_String, n_] := StringJoin[ConstantArray[s, n]]
then
rep["f", 3]
(*fff*)
next
chars = {"a", "b", "c"};
freqs = {1, 0, 3};
StringJoin[MapThread[rep, {chars, freqs}]]
gives "accc"
For 1, Table will do what you need.
s = "samplestring";
StringJoin[Table[s, {3}]]
"samplestringsamplestringsamplestring"
But acl's answer using ContantArray is faster, if you care about the last 1/100th second.
Do[StringJoin[Table[s, {30}]];, {10000}] // Timing
{0.05805, Null}
Do[StringJoin[ConstantArray[s, 30]];, {10000}] // Timing
{0.033306, Null}
Do[StringJoin[Table[s, {300}]];, {10000}] // Timing
{0.39411, Null}
Do[StringJoin[ConstantArray[s, 300]];, {10000}] // Timing
{0.163103, Null}
For 2, MapThread will handle cases where the second list is known to be non-negative integers.
StringJoin #
MapThread[Table[#1, {#2}] &, {{"a", "b", "c"} , {1, 0, 3}}]
"accc"
If the second list contains negative integers, these are treated as zeros.
Non-integer elements in the second list are treated as if they are the integer part. I am not sure if this is what you want.
StringJoin #
MapThread[Table[#1, {#2}] &, {{"a", "b", "c"} , {1, 0, 3.7}}]
"accc"
Knowing your application I propose using Inner:
sets = {{0, 0, 0, 4}, {0, 0, 1, 3}, {0, 1, 0, 3}, {0, 1, 1, 2}, {0, 2, 0, 2},
{0, 2, 1, 1}, {1, 0, 0, 3}, {1, 0, 1, 2}, {1, 1, 0, 2}, {1, 1, 1, 1},
{1, 2, 0, 1}, {1, 2, 1, 0}, {2, 0, 0, 2}, {2, 0, 1, 1}, {2, 1, 0, 1},
{2, 1, 1, 0}, {2, 2, 0, 0}};
chars = {"a", "b", "c", "d"};
Inner[ConstantArray[#2, #] &, sets, chars, StringJoin]
{"dddd", "cddd", "bddd", "bcdd", "bbdd", "bbcd", "addd", "acdd",
"abdd", "abcd", "abbd", "abbc", "aadd", "aacd", "aabd", "aabc", "aabb"}

Using Mathematica Gather/Collect properly

How do I use Mathematica's Gather/Collect/Transpose functions to convert:
{ { {1, foo1}, {2, foo2}, {3, foo3} }, { {1, bar1}, {2, bar2}, {3, bar3} } }
to
{ {1, foo1, bar1}, {2, foo2, bar2}, {3, foo3, bar3} }
EDIT: Thanks! I was hoping there was a simple way, but I guess not!
Here is your list:
tst = {{{1, foo1}, {2, foo2}, {3, foo3}}, {{1, bar1}, {2, bar2}, {3, bar3}}}
Here is one way:
In[84]:=
Flatten/#Transpose[{#[[All,1,1]],#[[All,All,2]]}]&#
GatherBy[Flatten[tst,1],First]
Out[84]= {{1,foo1,bar1},{2,foo2,bar2},{3,foo3,bar3}}
EDIT
Here is a completely different version, just for fun:
In[106]:=
With[{flat = Flatten[tst,1]},
With[{rules = Dispatch[Rule###flat]},
Map[{#}~Join~ReplaceList[#,rules]&,DeleteDuplicates[flat[[All,1]]]]]]
Out[106]= {{1,foo1,bar1},{2,foo2,bar2},{3,foo3,bar3}}
EDIT 2
And here is yet another way, using linked lists and inner function to accumulate the results:
In[113]:=
Module[{f},f[x_]:={x};
Apply[(f[#1] = {f[#1],#2})&,tst,{2}];
Flatten/#Most[DownValues[f]][[All,2]]]
Out[113]= {{1,foo1,bar1},{2,foo2,bar2},{3,foo3,bar3}}
EDIT 3
Ok, for those who consider all of the above too complicated, here is a really simple rule - based solution:
In[149]:=
GatherBy[Flatten[tst, 1], First] /. els : {{n_, _} ..} :> {n}~Join~els[[All, 2]]
Out[149]= {{1, foo1, bar1}, {2, foo2, bar2}, {3, foo3, bar3}}
Perhaps easier:
tst = {{{1, foo1}, {2, foo2}, {3, foo3}}, {{1, bar1}, {2, bar2}, {3, bar3}}};
GatherBy[Flatten[tst, 1], First] /. {{k_, n_}, {k_, m_}} -> {k, n, m}
(*
-> {{1, foo1, bar1}, {2, foo2, bar2}, {3, foo3, bar3}}
*)
MapThread
If the "foo" and "bar" sublists are guaranteed to be aligned with one another (as they are in the example) and if you will consider using functions other than Gather/Collect/Transpose, then MapThread will suffice:
data={{{1,foo1},{2,foo2},{3,foo3}},{{1,bar1},{2,bar2},{3,bar3}}};
MapThread[{#1[[1]], #1[[2]], #2[[2]]}&, data]
result:
{{1, foo1, bar1}, {2, foo2, bar2}, {3, foo3, bar3}}
Pattern Matching
If the lists are not aligned, you could also use straight pattern matching and replacement (although I wouldn't recommend this approach for large lists):
data //.
{{h1___, {x_, foo__}, t1___}, {h2___, {x_, bar_}, t2___}} :>
{{h1, {x, foo, bar}, t1}, {h2, t2}} // First
Sow/Reap
A more efficient approach for unaligned lists uses Sow and Reap:
Reap[Cases[data, {x_, y_} :> Sow[y, x], {2}], _, Prepend[#2, #1] &][[2]]
Also just for fun ...
DeleteDuplicates /# Flatten /# GatherBy[Flatten[list, 1], First]
where
list = {{{1, foo1}, {2, foo2}, {3, foo3}}, {{1, bar1}, {2, bar2}, {3,
bar3}}}
Edit.
Some more fun ...
Gather[#][[All, 1]] & /# Flatten /# GatherBy[#, First] & #
Flatten[list, 1]
Here is how I would do it using the version of SelectEquivalents I posted in What is in your Mathematica tool bag?
l = {{{1, foo1}, {2, foo2}, {3, foo3}}, {{1, bar1}, {2, bar2}, {3, bar3}}};
SelectEquivalents[
l
,
MapLevel->2
,
TagElement->(#[[1]]&)
,
TransformElement->(#[[2]]&)
,
TransformResults->(Join[{#1},#2]&)
]
This method is quite generic. I used to use functions such as GatherBy before for treating huge lists I generate in Monte-Carlo simulations. Now with SelectEquivalents implementations for such operations are much more intuitive. Plus it is based on the combination Reap and Sow which is very fast in Mathematica.
Until the question is updated to be more clear and specific, I will assume what I want to, and suggest this:
UnsortedUnion ### #~Flatten~{2} &
See: UnsortedUnion
Maybe a bit overcomplicated, but:
lst = {{{1, foo1}, {2, foo2}, {3, foo3}}, {{1, bar1}, {2, bar2}, {3, bar3}}}
Map[
Flatten,
{Scan[Sow[#[[1]]] &,
Flatten[lst, 1]] // Reap // Last // Last // DeleteDuplicates,
Scan[Sow[#[[2]], #[[1]]] &,
Flatten[lst, 1]] // Reap // Last} // Transpose
]
(*
{{1, foo1, bar1}, {2, foo2, bar2}, {3, foo3, bar3}}
*)
Here's how this works:
Scan[Sow[#[[1]]] &,
Flatten[lst, 1]] // Reap // Last // Last // DeleteDuplicates
returns the unique first elements of each of your list items, in the order they were sown (since DeleteDuplicates never reorders elements). Then,
Scan[Sow[#[[2]], #[[1]]] &,
Flatten[lst, 1]] // Reap // Last
exploits the fact that Reap returns expressions sown with difference tags in different lists. So then put them together, and transpose.
This has the disadvantage that we scan twice.
EDIT:
This
Map[
Flatten,
{DeleteDuplicates##[[1]],
Rest[#]} &#Last#Reap[
Scan[(Sow[#[[1]]]; Sow[#[[2]], #[[1]]];) &,
Flatten[lst, 1]]] // Transpose
]
is (very) slightly faster, but is even less readable...

Changing values in nested lists according to elements in the list

I have a list of pairs of values in mathematica, for example List= {{3,1},{5,4}}.
How do I change the first element (3 & 5) if the second element does not reach a threshold. For example, if the second parts are below 2 then i wish the first parts to go to zero. so that list then = {{0,1},{5,4}}. Some of these lists are extremely long so manually doing it is not an option, unfortunately.
Conceptually, the general way is to use Map. In your case, the code would be
In[13]:= lst = {{3, 1}, {5, 4}}
Out[13]= {{3, 1}, {5, 4}}
In[14]:= thr = 2
Out[14]= 2
In[15]:= Map[{If[#[[2]] < thr, 0, #[[1]]], #[[2]]} &, lst]
Out[15]= {{0, 1}, {5, 4}}
The # symbol here stands for the function argument. You can read more on pure functions here. Double square brackets stand for the Part extraction. You can make it a bit more concise by using Apply on level 1, which is abbreviated by ###:
In[27]:= {If[#2 < thr, 0, #], #2} & ### lst
Out[27]= {{0, 1}, {5, 4}}
Note however that the first method is several times faster for large numerical lists. An even faster, but somewhat more obscure method is this:
In[29]:= Transpose[{#[[All, 1]]*UnitStep[#[[All, 2]] - thr], #[[All, 2]]}] &[lst]
Out[29]= {{0, 1}, {5, 4}}
It is faster because it uses very optimized vectorized operations which apply to all sub-lists at once. Finally, if you want the ultimate performance, this procedural compiled to C version will be another factor of 2 faster:
fn = Compile[{{lst, _Integer, 2}, {threshold, _Real}},
Module[{copy = lst, i = 1},
For[i = 1, i <= Length[lst], i++,
If[copy[[i, 2]] < threshold, copy[[i, 1]] = 0]];
copy], CompilationTarget -> "C", RuntimeOptions -> "Speed"]
You use it as
In[32]:= fn[lst, 2]
Out[32]= {{0, 1}, {5, 4}}
For this last one, you need a C compiler installed on your machine.
Another alternative: Apply (###, Apply at level 1) and Boole (turns logical values in 1's and 0's):
lst = {{3, 1}, {5, 4}};
{#1 Boole[#2 >= 2], #2} & ### lst
An alternative approach might be to use substitution rules, and attach a condition (/;)
lst = {{3, 1}, {5, 4}};
lst /. {x_, y_ /; y < 2} -> {0, y}
output:
{{0, 1}, {5, 4}}
Assuming that your matrix is 2x2 and by second elemnt you mean the second row:
This should work:
If[A[[2, 1]] < 2 || A[[2, 2]] < 2, A[[2,1]] = 0 ]; A
You may have to change the variables, since your questions is kind of confusing. But that's the idea ;-)

Filter out sublist in Mathematica

I am a newbie user in mathematica. Here is my problem:
For example, I have a nested list:
lst = {{1, 0, 0}, {0, 1, 1}, {2, 0, 1}, {1}, {0,3}}
I want to only output those sublist whose elements are 0 or 1. The above list's output should be:
{{1, 0, 0}, {0, 1, 1}, {1}}
I can get the list that satisfies my conditions with this:
lst /. x:{(1 | 0) ..} :> x
But how can I get the converse of the pattern? like this:
lst /. x:NOT{(1 | 0) ..} :> Sequence[]
So that i can get the result in one stroke.
thanks!
Starting with:
lst = {{1, 0, 0}, {0, 1, 1}, {2, 0, 1}, {1}, {0, 3}};
You can filter with this:
Cases[lst, {(1 | 0) ..}]
Or get the complement with either:
Cases[lst, Except # {(1 | 0) ..} ]
or:
DeleteCases[lst, {(1 | 0) ..}]
This is a nice application for some/every:
some[f_, l_List] := (* whether f applied to some *)
Scan[If[f[#], Return[True]]&, l] === True (* element of list is True. *)
every[f_, l_List] := (* similarly, And ## f/#l *)
Scan[If[!f[#], Return[False]]&, l]===Null (* (but with lazy evaluation). *)
So first make a function that checks a sublist for all zeroes/ones:
chk[lst_] := every[#==0||#==1&, lst]
Then filter your list-of-lists for sublists that pass the test:
Select[lst, chk]
Or, as a one-liner:
Select[lst, every[#==0||#==1&, #]&]

Resources