Related
I want to generate a set in r which contains all of its subsets but not the set itself.
For example, say I have the set
{1, 2, 3}
I want to generate the following list in r
{{}, {1}, {2}, {3}, {1, 2}, {1, 3}, {2, 3}}
However, the commands I am trying in r (powerset and set_power) are giving
{{}, {1}, {2}, {3}, {1, 2}, {1, 3}, {2, 3}, {1, 2, 3}}
I want to create a set which contains all of it's subsets.
Any help would be appreciated!
You can use the sets package.
First, create set A:
library(sets)
A <- set(1,2,3)
A
{1, 2, 3}
Find the power set:
PS <- 2^A
PS
{{}, {1}, {2}, {3}, {1, 2}, {1, 3}, {2, 3}, {1, 2, 3}}
And substract A from the power set:
B <- set_symdiff(PS,set(A))
B
{{}, {1}, {2}, {3}, {1, 2}, {1, 3}, {2, 3}}
I have managed to do it by
s <- c(1,2,3)
powerSet(s)[-length(powerSet(s))]
Thanks!
I have a plot
Plot[40500*x^(-0.1), {x, 1, 100}, PlotRange -> {0, 50000}]
I'm trying to plot the cumulative of these y values. I'll try to explain with an example:
I'm trying to get
for x=1: 40500*1^(-0.1)
for x=2: 40500*(2^(-0.1)+1^(-0.1))
for x=3: 40500*(3^(-0.1)+2^(-0.1)+1^(-0.1))
and so on up to x=100.
Is there a way to do that?
Running some examples for x = 3
for x=3: 40500*(3^(-0.1)+2^(-0.1)+1^(-0.1))
114574.
This can be found using Sum:
Sum[40500*i^(-0.1), {i, 3}]
or using Fold
Fold[#1 + 40500*#2^(-0.1) &, 0, {1, 2, 3}]
114574.
FoldList outputs the intermediate steps.
FoldList[#1 + 40500*#2^(-0.1) &, 0, {1, 2, 3}]
{0, 40500., 78287.8, 114574.}
Accumulating to 100 and discarding the initial zero value:
ListLinePlot[Rest[FoldList[#1 + 40500*#2^(-0.1) &, 0, Range[100]]]]
The text in italics describes my general goal, if anyone is interested. Question is underneath.
I am trying to graph the energy levels of simple molecules using Mathematica 8. My method is crude, and goes as this:
Find eigenvalues of simple Hückel matrix.
Delete duplicates and determine size of list.
Evaluate the number of degeneracies by comparing duplicate list with no-duplicate list.
Create a n x 2 zero matrix where n is the number of unique energy levels.
5. Fill first column with unique energy levels, second column with degeneracies.
The matrix generated in step 5 can look like this:
(1 2)
(3 1) == M
(-1 1)
I wish to evaluate the maximum of column 2, and then find the value of the element in the same row, but in column 1. In this case, the answer I am looking for is 1.
These commands both evaluate to -1:
Extract[M[[All, 1]], M[[Max[M[[All, 2]]], 1]]]
M[[Max[M[[All, 1]]], 1]]
which is not the answer I want.
Any tips?
EDIT: This
Part[Part[Position[M, Max[M[[All, 2]]]], 1], 1]
works, but I don't understand why I have to use Part[] twice.
m = {{1, 2}, {3, 1}, {-1, 1}}
max = Max[m[[All, 2]]]
So find the position of the max and replace the second column with the first:
pos=Position[m, max] /. {x_,_}:>{x,1}
{{1,1}}
Then take the first element from pos, i.e. {1,1} and sub use it in Part
m[[Sequence ## First[pos]]]
1
But having said that I prefer something like this:
Cases[m, {x_, max} :> x]
{1}
The result is a list. You could either use First#Cases[...] or you might want to keep a list of results to cover cases where the maximum value occurs more than once in a column.
The inner Part gives you the first occurance of the maximum. Position returns a list of positions, even if there is only one element that has the maximum value, like this:
M = {{2, 2}, {2, 3}, {2, 2}, {1, 1}}
{{2, 2}, {2, 3}, {2, 2}, {1, 1}}
Position[M, Max[M[[All, 2]]]]
{{2, 2}}
So you want the first element in the first element of this output. You could condense your code like this:
Position[M, Max[M[[All, 2]]]][[1, 1]]
However, one thing that I think your code needs to handle better is this case:
M = {{3, 2}, {2, 3}, {2, 2}, {1, 1}}
3, 2}, {2, 3}, {2, 2}, {1, 1}}
Position[M, Max[M[[All, 2]]]]
{{1, 1}, {2, 2}}
You will get the wrong answer with your code in this case.
Better would be:
M[[All, 1]][[Position[M[[All, 2]], Max[M[[All, 2]]]][[1, 1]] ]]
Or alternatively
M[[Position[M[[All, 2]], Max[M[[All, 2]]]][[1, 1]], 1]]
If you only want a single column one value in the case of duplicate maximum values in column two I suggest that you make use of Ordering:
m = {{1, 3}, {1, 8}, {5, 7}, {2, 2}, {1, 9}, {4, 9}, {5, 6}};
m[[ Ordering[m[[All, 2]], -1], 1 ]]
{4}
I have mathematica code to check whether a collection of sets satisfies the definition of a topology, I would now like to programmatically generate diagrams like these:
How can this be done?
I'm not familiar with your problem but to create diagrams from primitives, that look kind of like the ones you have pasted, you can do this:
start with the "base" case --
base = {Circle[{-0.4, 0.4}, 0.1], Disk[{0, .125}, 0.05],
Text[Style["1", 24], {0, -0.1}],
Disk[{0.5, .125}, 0.05], Text[Style["2", 24], {0.5, -0.1}],
Disk[{1., .125}, 0.05], Text[Style["3", 24], {1., -0.1}],
Circle[{.5, 0}, {.9, .5}]};
Graphics[{base}, ImageSize -> 220]
From here just add elipses to the base case:
Graphics[{base, Circle[{0, 0}, {.15, .3}]}, ImageSize -> 220]
Graphics[{base, Circle[{0, 0}, {.15, .3}],
Circle[{0.5, 0}, {.15, .3}], Circle[{0.25, 0}, {.58, .38}]},
ImageSize -> 220]
Graphics[{base, Circle[{0.5, 0}, {.15, .3}],
Circle[{0.25, 0}, {.58, .38}], Circle[{0.75, 0}, {.58, .38}]},
ImageSize -> 220]
Graphics[{base, Circle[{0.5, 0}, {.15, .3}],
Circle[{1, 0}, {.15, .3}], Red, AbsoluteThickness[6],
Line[{{-0.4, -0.5}, {1.4, 0.55}}],
Line[{{-0.4, 0.55}, {1.4, -0.5}}]}, ImageSize -> 220]
Graphics[{base, Circle[{0.25, 0}, {.58, .38}],
Circle[{0.75, 0}, {.58, .38}], Red, AbsoluteThickness[6],
Line[{{-0.4, -0.5}, {1.4, 0.55}}],
Line[{{-0.4, 0.55}, {1.4, -0.5}}]}, ImageSize -> 220]
Note that I set Frame->True while tweaking these so I could see the coordinates.
To complement Mike's cool diagrams, here is a way to check if an arbitrary finite list of lists is a topology, that is, (1) if it contains the empty set, (2) the base set, (3) closed under finite intersections, and (3) closed under union:
topologyQ[x_List] :=
Intersection[x, #] === # & [
Union[
{Union ## x},
Intersection ### Rest##,
Union ### #
] & # Subsets # x
]
Applied to the six examples
list1 = {{}, {1, 2, 3}};
list2 = {{}, {1}, {1, 2, 3}};
list3 = {{}, {1}, {2}, {1, 2}, {1, 2, 3}};
list4 = {{}, {2}, {1, 2}, {2, 3}, {1, 2, 3}};
list5 = {{}, {2}, {3}, {1, 2, 3}};
list6 = {{}, {1, 2}, {2, 3}, {1, 2, 3}};
like
topologyQ /# {list1, list2, list3, list4, list5, list6}
gives
{True, True, True, True, False, False}
EDIT 1: For a further refinement of the formulation, note that the operator
topoCover := (Union ## {Union ### #, Intersection ### Rest##} &)#Subsets## &
gives the collection obtained by taking all unions and intersections of the elements of a collection of sets. A collection of sets list is a topology if it is a fixed point of the operator topoCover. So one can define an alternative function to check if list is topology:
topologyQ2 := (topoCover## === #) &
If list is not a topology, topoCover gives the smalles superset of list which is a topology. So
Complement[topoCover##,#]&
gives the elements to be added to list to make it a topology.
One can also consider largest subset(s) of list which is a topology and the element(s) to be deleted from list to topologize it. This is done by using
maxTopoSubset := (If[{} == #, None, Last##] &)#(GatherBy[
Select[Subsets##, topologyQ], Length[#] &]) &
Applied, for example, to list6 as
maxTopoSubset#list6
we get the two topologies
{{}, {1, 2}, {1, 2, 3}}, {{}, {2, 3}, {1, 2, 3}}}
To get the elements to be removed to get a topology from list, one can use
removeToTopologize := Table[Complement[#, Part[maxTopoSubset##, i]], {i,
Length#maxTopoSubset##}] &
Using with list6 as
removeToTopologize#list6
we get
{{{2, 3}}, {{1, 2}}}
that is, removing {2,3} or {1,2} from list6 gives a topology.
I wont be able to give a mathematica specific solution however i might share some insight considering finding all the topologies on a given finite set.
The naive algorithm (the one that checks topological space axioms) runtime would be around $2^2^n$. We will reduce the search space considerably. Key point to realize is that for every preorder on a finite set there is a topology and vice versa. Given a topology one can create a relation where $x \leq y$ iff $y$ is element of all the open sets which $x$ belongs to. I believe this is called specialization preorder. From a given preorder one can recover the topology by finding the upper sets.
So if we can find all the preorders on a given set, we can recover all the topologies. Finding preorders is considerably easier. A preorder is a binary relation which is transitive and reflexive. So the search space is $2^n^2$.
There are also cool algorithms (Floyd-Warshall ) to find the transitive closure of any given relation. Finding the reflexive closure is also easy (just add the identity matrix to the adjacency matrix represantation)
Considering the following list :
dalist = {{1, a, 1}, {2, s, 0}, {1, d, 0}, {2, f, 0}, {1, g, 1}}
I would like to count the number of times a certain value in the first column takes a certain value in column 3.
So in this example my desired output would be:
{{1,1,2},
{1,0,1},
{2,1,0},
{2,0,2}}
or :
Where the latest sublist {2,0,2} being read as: When the value is 2 in the first column, a corresponding value (same row in matrices world) in column 3 of 0 is present twice.
I hope this is not to confusing. I added the second Column to convey the fact that the columns are distant to each other.
If possible, no reordering should happen.
EDIT :
{1,2,3,4,5}
{1,0}
are the exact values taken by the columns I am actually dealing with in my data.
I know I am missing the correct description. Please edit if you can and know it. Thank you
From what I understood, this should do it:
In[11]:= dalist = {{1, a, 1}, {2, s, 0}, {1, d, 0}, {2, f, 0}, {1, g, 1}}
Out[11]= {{1, a, 1}, {2, s, 0}, {1, d, 0}, {2, f, 0}, {1, g, 1}}
In[12]:= Map[Flatten, Tally[dalist[[All, {1, 3}]]]]
Out[12]= {{1, 1, 2}, {2, 0, 2}, {1, 0, 1}}
In your sample, you don't actually have the combination {2,1}, but you have the combination {2,0} twice, not once - thus the output is different from what you anticipated. That is, if I understood the question correctly.
I tried to come up with something brand new using Sasha's assumptions about the required output, but it got more similar to his code than I thought it would be. Still the differences are interesting enough to post.
{#1, #2, Count[dalist[[All, {1, 3}]], {##}]} & ###
Tuples[
{DeleteDuplicates#dalist[[All, 1]],
DeleteDuplicates#dalist[[All, 3]]}
]
Edit
With your clarification about the input the code can be simplified and actually improved to:
{#1, #2, Count[dalist[[All, {1, 3}]], {##}]}& ###Tuples[{Range[5],{0,1}}]
The first version is correct only if at least one example of each possible outcome is actually present in each column.
You can use a combination of Outer and Count:
In[39]:= Flatten[Outer[
{#1, #2, Count[dalist, {#1, _, #2}]} &,
DeleteDuplicates#dalist[[All, 1]],
DeleteDuplicates#dalist[[All, -1]] ], 1]
Out[39]= {{1, 1, 2}, {1, 0, 1}, {2, 1, 0}, {2, 0, 2}}
Here is a variation of Sjoerd's second method, that may or may not be easier to read and adapt.
Join ## Table[{i, j, dalist[[All, {1,3}]] ~Count~ {i, j}}, {i,5}, {j,0,1}]
One may use Array in the same manner:
Join ## Array[{##, dalist[[All, {1,3}]] ~Count~ {##}} &, {5,2}, {1,0}]
If your table is large, it will be worthwhile to do the extraction only once:
With[{x = dalist[[All, {1,3}]]},
Join ## Array[{##, x~Count~{##}} &, {5,2}, {1,0}]
]