Pattern to match list of identical elements - wolfram-mathematica

I am looking for a pattern that matches a (possibly empty) list consisting of identical (in the sense of Equal[]) atomic objects, but I can't figure it out. Any help would be greatly appreciated.

All of the responses so far seem to have missed the requirement that the objects being matched need to be atomic. The following does this:
Cases[testList, {a___?AtomQ} /; Equal[a]]
If you don't define identical in the sense of Equal you could have used:
Cases[testList, {(a_?AtomQ) ...}]
With a slightly modified test list you'll see other methods fail the requirement
testList = {{1, 1.0, 1.0}, {a, b, c}, {Exp[Pi] + 1, Exp[Pi] + 1, Exp[Pi] + 1}, {}, {3}};
they all incorrectly match the 3rd element too.

Does this work for you?
testList = {
{1, 1.0, 1.},
{a, b, c},
{0, Exp[Pi*I] + 1.0, Sin[Pi]}
}
Cases[testList, _List?(Equal ## # &)]

Using Condition, instead of PatternTest:
In[31]:= testList = {{1, 1.0, 1.}, {a, b, c}, {0, Exp[Pi*I] + 1.0,
Sin[Pi]}, {}, {3}};
Cases[testList, {a___} /; Equal[a]]
Out[32]= {{1, 1., 1.}, {0, 0., 0}, {}, {3}}
(and expanding on Mark's list of test cases to cover empty and singleton lists.)

Related

Dynamic Manipulate function in Wolfram?

I am writing a demonstration for a digital GUI for analog filter design. Since demonstrations only allows for one Manipulate function, is there any way to dynamically update my Manipulate controls?
E.x. I have 4 different filter types (Lowpass, Highpass, Bandpass, Bandstop), the former two only require two frequency inputs while the latter two require four frequency inputs. Is there a way to switch between two Manipulate sliders and four based on which mode was selected without nesting Manipulates? Alternatively can I have all four and grey out two when they are not needed?
Here is an example of dynamically changing Manipulate controls that should be easy to modify to achieve what you want. I did not write it, and I do not remember where I saw it.
Manipulate[
{x, yyy},
{{x, a}, {a, b, c, d}, None},
{{yyy, 0.5}, 0, 1, None},
{{type, 1}, Range#3, None},
PaneSelector[{
1 -> Column[{
Control#{x, {a, b, c, d}, RadioButtonBar},
Control#{{yyy, 0.5}, 0, 1},
Control#{type, Range#3}
}],
2 -> Column[{
Control#{x, {a, b, c, d}, SetterBar},
Control#{yyy},
Control#{type, Range#3}
}],
3 -> Column[{
Control#{x, {a, b, c, d}, PopupMenu},
Control#{{yyy, 0.5}, 0, 1},
Control#{type, Range#3}
}]
}, Dynamic#type]
]

How to delete duplicate based on a portion of list item only in Mathematica

I have the following data set (showing just the snapshot)
data = {{0.1, 0.2, 5}, {0.1, 0.3, 7}, {0.2, 0.2, 1}, {0.1, 0.2, 9}}
In other words, the data is in the format of {A, B, C}.
I want to delete duplicate based on A & B only.
I would like the output to be (effectively removing the last item as in the example)
{{0.1, 0.2, 5}, {0.1, 0.3, 7}, {0.2, 0.2, 1}}
DeleteDuplicates[data] doesn't work for me as it uses all A, B and C in the duplicate detection and removal.
This is more or less explained in the documentation for DeleteDuplicates.
DeleteDuplicates[data, Take[#1, 2] == Take[#2, 2] &]
should do what you want : it defines an equality function of any two first-level elements of data (#1 and #2) as equality of the first two sub-elements (that's what Take[ ..., 2] does) .

Evaluation of Expressions inside Manipulate Statements

I have problems getting Manipulate to work with code assigned to variables that should be evaluated inside the Manipulate statement. Here is how it goes ...
test1={a,b,c};
Manipulate[test1,{a,0,10,.1},{b,0,10,.1},{c,0,10,.1}]
So {a, b, c} are not updated. Ok, whatever, let's enforce the evaluation of test1
Manipulate[Evaluate[test1],{a,0,10,.1},{b,0,10,.1},{c,0,10,.1}]
Now it works. But if I want to plot the list of manipulated elements, like this
Manipulate[ListPlot[Evaluate[test1]],{a,0,10,.1},{b,0,10,.1},{c,0,10,.1}]
Manipulate[Evaluate[ListPlot[test1]],{a,0,10,.1},{b,0,10,.1},{c,0,10,.1}]
I end up with
in both chases.
I am aware of 'Evaluate Expressions inside Dynamic or Manipulate' in Mathematica's documentation, but I am pretty sure that it does not provide a solution to my problem.
So the problem is that test1 is defined in terms of global variable Global`a,
but the a defined in the manipulate is created by a DynamicModule and is thus local. This is what acl showed with his Hold[a] example.
Maybe the easiest way to fix this is to use With to insert test1 into the manipulate:
Clear[a, b, c]
test1 = {a, b, c};
With[{test1 = test1},
Manipulate[test1, {a, 0, 10, .1}, {b, 0, 10, .1}, {c, 0, 10, .1}]]
This way the Manipulate never actually sees test1, all it sees is {a,b,c} which it then goes on to correctly localize. Although, this will run into problems if a,b,c have been given a value before the Manipulate is run - thus the Clear[a,b,c] command.
I think that the best practice is to make all local variables completely explicit in the manipulate. So you should do something like
Clear[a, b, c, test1]
test1[a_, b_, c_] := {a, b, c};
Manipulate[test1[a, b, c], {a, 0, 10, .1}, {b, 0, 10, .1}, {c, 0, 10, .1}]
This avoids problems with the global vs local variables that you were having. It also makes it easier for you when you have to come back and read your own code again.
Edit to answer the question in the comments "I really would like to understand why Evaluate does not work with the somewhat nested ListPlot?". IANLS (I am not Leonid Shifrin) and so I don't have a perfect Mathematica (non)standard evaluation sequence running in my brain, but I'll try to explain what's going on.
Ok, so unlike Plot, ListPlot does not need to localize any variables, so it does not have the Attribute HoldAll.
Let's define something similar to your example:
ClearAll[a, test]
test = {a, a + 1};
The final example you gave is like
Manipulate[Evaluate[ListPlot[test]], {a, 0, 1}]
By looking at the Trace, you see that this first evaluates the first argument which is ListPlot[test] ~> ListPlot[{a,a+1}]
and since a is not yet localized, it produces an empty list plot. To see this, simply run
ListPlot[{a, a + 1}]//InputForm
to get the empty graphics object
Graphics[{}, {AspectRatio -> GoldenRatio^(-1), Axes -> True, AxesOrigin -> {0, 0}, PlotRange -> {{0., 0.}, {0., 0.}}, PlotRangeClipping -> True, PlotRangePadding -> {Scaled[0.02], Scaled[0.02]}}]
As the symbolic values a have been thrown out, they can not get localized by the Manipulate and so not much else happens.
This could be fixed by still evaluating the first argument, but not calling ListPlot until after Manipulate has localized the variables. For example, both of the following work
Manipulate[Evaluate[listPlot[test]], {a, 0, 1}] /. listPlot -> ListPlot
Manipulate[Evaluate[Hold[ListPlot][test]], {a, 0, 1}] // ReleaseHold
The fact that ListPlot throws away non-numeric values without even the slightest complaint, is probably a feature, but can lead to some annoyingly hard to track bugs (like the one this question pertains to). Maybe a more consistent (but less useful?) behaviour would be to return an unevaluated ListPlot if the plot values are non-numeric... Or to at least issue a warning that some non-numeric points have been discarded.
The penultimate example you gave is (more?) interesting, it looks like
Manipulate[ListPlot[Evaluate[test]], {a, 0, 1}]
Now since Manipulate has the attribute HoldAll, the first thing it does is wrap the arguments in Hold, so if you look at the Trace, you'll see Hold[ListPlot[Evaluate[test]]] being carried around. The Evaluate is not seen, since as described in the Possible Issues section, "Evaluate works only on the first level, directly inside a held function". This means that test is not evaluated until after the variables have been localized and so they are taken to be the global a and not the local (DynamicModule) a.
It's worth thinking about how the following variations work
ClearAll[a, test, f, g]
SetAttributes[g, HoldAll];
test = {a, a + 1};
Grid[{
{Manipulate[test, {a, 0, 1}], Manipulate[Evaluate[test], {a, 0, 1}]},
{Manipulate[f[test], {a, 0, 1}],
Manipulate[f[Evaluate[test]], {a, 0, 1}]},
{Manipulate[g[test], {a, 0, 1}],
Manipulate[g[Evaluate[test]], {a, 0, 1}]}
}]
Here is why it doesn't work:
Manipulate[
{
Hold[a]
},
{a, 0, 10, .1},
{b, 0, 10, .1},
{c, 0, 10, .1}
]
One may fix this in various ways. One is to simply define test1 with the localized variables, like so:
ClearAll[test1, a, b, c];
Manipulate[
test1 = {a, b, c};
{
test1
},
{a, 0, 10, .1},
{b, 0, 10, .1},
{c, 0, 10, .1}
]
and then eg
ClearAll[test1, a, b, c];
Manipulate[
test1 = {a, b, c};
ListPlot#test1,
{a, 0, 10, .1},
{b, 0, 10, .1},
{c, 0, 10, .1}
]
works.
If you prefer to define test1 globally, this
ClearAll[test1, a, b, c];
test1 = {a, b, c};
Manipulate[
test1,
{a, 0, 10, .1},
{b, 0, 10, .1},
{c, 0, 10, .1},
LocalizeVariables -> False,
TrackedSymbols -> test1
]
works.

Question about the RotationTransform function in Mathematica

Background:
a = 0; b = 0; c = 0;
Manipulate[Graphics3D[
GeometricTransformation[
{Cuboid[{0, 0, 0}, {1, 1, 1}]},
{RotationTransform[x, {1, 1, 0}, {a, b, c}]}],
ViewPoint -> Left], {x, 0, 2 \[Pi]}]
My question concerns RotationTransform with the following signature:
RotationTransform[x, {1, 1, 0}, {a, b, c}]
The documentation says: "gives a 3D rotation around the axis w anchored at the point p", in the example above w={1,1,0} and p={a,b,c}.
To my surprise the rotation acts the same no matter what values I assign to (a,b,c). I assume that I don't understand the docs, made an error somewhere. I would have expected at least a different rotation for different values of a,b,c. Changing the vector w behaves as expected.
Please explain the purpose of p.
Consider the following example from the help:
gr={Cuboid[],AbsolutePointSize[10],Opacity[1],{Magenta,Point[{0,0,0}]},
{Green,Point[{1,1,1}]}};
p = {1,1,1};
Graphics3D[{{Opacity[.35], Blue, gr},
GeometricTransformation[{Opacity[.85], Red, gr},
RotationTransform[Pi/6, {0, 0, 1}, p]]}, Boxed -> False]
And now with :
p={1,0,0};
May be this will make it clear. It does have an effect. I show the anchor point, and the axis.
Manipulate[
Module[{w={1,0,0},p={-2,2}},
Graphics3D[
{
{Opacity->.4,GeometricTransformation[
{Cuboid[{0,0,0}]},RotationTransform[angle,w,{a,b,c}]]
},
{Blue,PointSize[0.05],Point[{a,b,c}]},
{Red,Thick,Line[{{a,b,c},{a,b,c}+w}]}
},
ImageSize->300,
ImagePadding->2,AxesOrigin->{0,0,0},
ImageMargins->2,ViewAngle->All,
Axes->True,
Ticks->None,
PlotRange->{p,p,p}
]
],
{angle,0,2 \[Pi],ImageSize->Tiny},
{{a,0,"a"},0,1,.1,Appearance->"Labeled",ImageSize->Tiny},
{{b,0,"b"},0,1,.1,Appearance->"Labeled",ImageSize->Tiny},
{{c,0,"c"},0,1,.1,Appearance->"Labeled",ImageSize->Tiny},
ControlPlacement->Left
]

In Mathematica, how do I compile the function Outer[] for an arbitrary number of arguments?

If I want to find all possible sums from two lists list1 and list2, I use the Outer[] function with the specification of Plus as the combining operator:
In[1]= list1 = {a, b}; list2 = {c, d}; Outer[Plus, list1, list2]
Out[1]= {{a + c, a + d}, {b + c, b + d}}
If I want to be able to handle an arbitrary number of lists, say a list of lists,
In[2]= listOfLists={list1, list2};
then the only way I know how to find all possible sums is to use the Apply[] function (which has the short hand ##) along with Join:
In[3]= argumentsToPass=Join[{Plus},listOfLists]
Out[3]= {Plus, {a, b}, {c, d}}
In[4]= Outer ## argumentsToPass
Out[4]= {{a + c, a + d}, {b + c, b + d}}
or simply
In[5]= Outer ## Join[{Plus},listOfLists]
Out[5]= {{a + c, a + d}, {b + c, b + d}}
The problem comes when I try to compile:
In[6]= Compile[ ..... Outer ## Join[{Plus},listOfLists] .... ]
Compile::cpapot: "Compilation of Outer##Join[{Plus},listOfLists]] is not supported for the function argument Outer. The only function arguments supported are Times, Plus, or List. Evaluation will use the uncompiled function. "
The thing is, I am using a supported function, namely Plus. The problem seems to be solely with the Apply[] function. Because if I give it a fixed number of lists to outer-plus together, it works fine
In[7]= Compile[{{bob, _Integer, 1}, {joe, _Integer, 1}}, Outer[Plus, bob, joe]]
Out[7]= CompiledFunction[{bob, joe}, Outer[Plus, bob, joe],-CompiledCode-]
but as soon as I use Apply, it breaks
In[8]= Compile[{{bob, _Integer, 1}, {joe, _Integer, 1}}, Outer ## Join[{Plus}, {bob, joe}]]
Out[8]= Compile::cpapot: "Compilation of Outer##Join[{Plus},{bob,joe}] is not supported for the function argument Outer. The only function arguments supported are Times, Plus, or List. Evaluation will use the uncompiled function."
So my questions is: Is there a way to circumvent this error or, alternatively, a way to compute all possible sums of elements pulled from an arbitrary number of lists in a compiled function?
(Also, I'm not sure if "compilation" is an appropriate tag. Please advise.)
Thanks so much.
One way it to use With, to create a compiled function programmatically:
Clear[makeCompiled];
makeCompiled[lnum_Integer] :=
With[{listNames = Table[Unique["list"], {lnum}]},
With[{compileArgs = {#, _Integer, 1} & /# listNames},
Compile ## Join[Hold[compileArgs],
Replace[Hold[Outer[Plus, listNames]],
Hold[Outer[Plus, {x__}]] :> Hold[Outer[Plus, x]], {0}]]]];
It can probably be done prettier, but it works. For example:
In[22]:= p2 = makeCompiled[2]
Out[22]= CompiledFunction[{list13,list14},Outer[Plus,list13,list14],-CompiledCode-]
In[23]:= p2[{1,2,3},{4,5}]
Out[23]= {{5,6},{6,7},{7,8}}
In[24]:= p3 = makeCompiled[3]
Out[24]= CompiledFunction[{list15,list16,list17},Outer[Plus,list15,list16,list17],-CompiledCode-]
In[25]:= p3[{1,2},{3,4},{5,6}]
Out[25]= {{{9,10},{10,11}},{{10,11},{11,12}}}
HTH
Edit:
You can hide the compiled function behind another one, so that it is created at run-time and you don't actually see it:
In[33]:=
Clear[computeSums]
computeSums[lists : {__?NumberQ} ..] := makeCompiled[Length[{lists}]][lists];
In[35]:= computeSums[{1, 2, 3}, {4, 5}]
Out[35]= {{5, 6}, {6, 7}, {7, 8}}
You face an overhead of compiling in this case, since you create then a compiled function afresh every time. You can fight this overhead rather elegantly with memoization, using Module variables for persistence, to localize your memoized definitions:
In[44]:=
Clear[computeSumsMemoized];
Module[{compiled},
compiled[n_] := compiled[n] = makeCompiled[n];
computeSumsMemoized[lists : {__?NumberQ} ..] := compiled[Length[{lists}]][lists]];
In[46]:= computeSumsMemoized[{1, 2, 3}, {4, 5}]
Out[46]= {{5, 6}, {6, 7}, {7, 8}}
This is my first post. I hope I get this right.
If your inputs are lists of integers, I am skeptical of the value of compiling this function, at least in Mathematica 7.
For example:
f = Compile[{{a, _Integer, 1}, {b, _Integer, 1}, {c, _Integer, 1}, {d, _Integer, 1}, {e, _Integer, 1}},
Outer[Plus, a, b, c, d, e]
];
a = RandomInteger[{1, 99}, #] & /# {12, 32, 19, 17, 43};
Do[f ## a, {50}] // Timing
Do[Outer[Plus, ##] & ## a, {50}] // Timing
The two Timings are not significantly different for me, but of course this is only one sample. The point is merely that Outer is already fairly fast compared to the compiled version.
If you have reasons other than speed for compilation, you may find some use in Tuples instead of Outer, but you still have the constraint of compiled functions requiring tensor input.
f2 = Compile[{{array, _Integer, 2}},
Plus ### Tuples#array
];
f2[{{1, 3, 7}, {13, 25, 41}}]
If your inputs are large, then a different approach may be in order. Given a list of lists of integers, this function will return the possible sums and the number of ways to get each sum:
f3 = CoefficientRules#Product[Sum[x^i, {i, p}], {p, #}] &;
f3[{{1, 3, 7}, {13, 25, 41}}]
This should prove to be far more memory efficient in many cases.
a2 = RandomInteger[{1, 999}, #] & /# {50, 74, 55, 55, 90, 57, 47, 79, 87, 36};
f3[a2]; // Timing
MaxMemoryUsed[]
This took 3 seconds and minimal memory, but attempting the application of Outer to a2 terminated the kernel with "No more memory available."

Resources