Mathematica plotting based on all previous equation results - graph

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]]]]

Related

Mathematica: integrate symbolic vector function

I wrote a program that defines two piecewise functions "gradino[x_]" and "gradino1[x_]", where x is a vector of m components.
I'm not able to write these functions explicitly using the x_i, I need to keep x as a vector.
I need to measure the distance between these two function doing:
Integrate[Abs[gradino[x]-gradino1[x]],{x[[1]],0,100},{x[[2],0,100},{x[[3]],0,100}...{x[[m]],0,100}]
but it's not working.
Any idea how to do this? Remembering that I can't simply express gradino[x1_,x2_ etc...].
re: "its not working" posting the actual error message is usually a good idea,
in this case "Part specification x[[1]] is longer than depth of object.".. tells you exactly what the problem is. If x is not already defined as a list you cannot use list elements as integration variables.
f[y_] := y[[1]] y[[2]];
Integrate[ f[x] , {x[[1]], 0, 1}, {x[[2]], 0, 1}]
(* error Part specification x[[1]] is longer than depth of object. *)
If you first define x as a list, then it works:
x = Array[z, 2];
Integrate[ f[x] , {x[[1]], 0, 1}, {x[[2]], 0, 1}]
(*1/4*)
Note you can not do this with nintegrate:
NIntegrate[ f[x] , {x[[1]], 0, 1}, {x[[2]], 0, 1}]
(*error Tag Part in x[[1]] is Protected *)
you need to use the explicit elements:
NIntegrate[ f[x] , {z[1], 0, 1}, {z[2], 0, 1}]
(* 0.25 *)
According to the model above, with
x = Array[z, 2];
why the following is ok:
f[y_] := NIntegrate[y[[1]] y[[2]] t, {t, 0, 1}];
NIntegrate[f[x], {z[1], 0, 1}, {z[2], 0, 1}]
but the following is not:
f[y_] := NIntegrate[y[[1]] y[[2]] Exp[t], {t, 0, 1}];
NIntegrate[f[x], {z[1], 0, 1}, {z[2], 0, 1}]
The only difference is changing t in the inner integration into Exp[t].

Mathematica: part assignment

I'm trying to implement an algorithm to build a decision tree from a dataset.
I wrote a function to calculate the information gain between a subset and a particular partition, then I try all the possible partition and want to choose the "best" partition, in the sense that it's got the lowest entropy.
This procedure must be recursive, hence, after the first iteration, it needs to work for every subset of the partition you got in the previous step.
These are the data:
X = {{1, 0, 1, 1}, {1, 1, 1, 1}, {0, 1, 1, 1}, {1, 1, 1, 0}, {1, 1, 0, 0}}
Xfin[0]=X
This is the function: for every subset of the partition, it tries all the possible partitions and calculate the IG. Then it selects the partition with IGMAX:
Partizioneottimale[X_, n_] :=
For[l = 1, l <= Length[Flatten[X[n], n - 1]], l++,
For[v = 1, v <= m, v++,
If[IG[X[n][[l]], Partizione[X[n][[l]], v]] == IGMAX[X[n][[l]]],
X[n + 1][[l]] := Partizione[X[n][[l]], v]]]]
then I call it:
Partizioneottimale[Xfin, 0]
and it works fine for the first one:
Xfin[1]
{{{1, 0, 1, 1}, {1, 1, 1, 1}, {0, 1, 1, 1}, {1, 1, 1, 0}}, {{1, 0, 0, 0}}}
That is the partition with lowest entropy.
But it doesn't work for the next ones:
Partizioneottimale[Xfin, 1]
Set delayed::steps : Xfin[1+1] in the part assignment is not a symbol
Has anybody any idea about how to solve this?
Thanks
without unraveling all your logic a simple fix is this:
Partizioneottimale[X_, n_] := (
xnp1 = Table[Null, {Length[Flatten[X[n], n - 1]]}] ;
For[l = 1, l <= Length[Flatten[X[n], n - 1]], l++,
For[v = 1, v <= m, v++,
If[IG[X[n][[l]], Partizione[X[n][[l]], v]] == IGMAX[X[n][[l]]],
xnp1[[l]] = Partizione[X[n][[l]], v]]]] ;
X[n+1] = xnp1 ; )

Searching matrices in Mathematica 8 - Trying to find other elements on the same row as X

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}

Conditional Counting in Mathematica

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}]
]

Visualizing a geometric puzzle with mathematica

I am trying to figure out a way to move two points, X and Y, independently of one another along the edges of an equilateral triangle with vertices A, B, and C. There are also some collision rules that need to be taken into account:
(1) If X is at a vertex, say vertex A, then Y cannot be on A or on the edges adjacent to it. i.e., Y can only be on vertices B or C or the edge BC.
(2) If X is on an edge, say AB, then Y cannot be on A, nor B, nor any of the edges adjacent to A and B. i.e., Y must be on vertex C
I have figured out how to move the two points along the triangle using a pair of sliders, but I can't figure out how to implement the collision rules. I tried using the Exclusions option for Slider but the results are not what I expect. I would prefer to drag the points along the triangle rather than using sliders, so if someone knows how to do that instead it would be helpful. Ideally, I would be able to
move the two points from a vertex to either one of the edges instead of coming to a stop at one of them. Here is my code so far.
MyTriangle[t_] :=
Piecewise[{{{-1, 0} + (t/100) {1, Sqrt[3]},
100 > t >= 0}, {{0, Sqrt[3]} + (t/100 - 1) {1, -Sqrt[3]},
200 > t >= 100},
{{1, 0} + (t/100 - 2) {-2, 0}, 300 >= t >= 0}}]
excluded[x_] := \[Piecewise] {
{Range[0, 99]~Join~Range[201, 299], x == 0},
{Range[0, 199], x == 100},
{Range[101, 299], x == 200},
{Range[0, 199]~Join~Range[201, 299], 0 < x < 100},
{Range[1, 299], 100 < x < 200},
{Range[0, 99]~Join~Range[101, 299], 200 < x < 300}
}
{Dynamic[t], Dynamic[x]}
{Slider[Dynamic[t], {0, 299, 1}, Exclusions -> Dynamic[excluded[x]]], Dynamic[t]}
{Slider[Dynamic[x], {0, 299, 1}, Exclusions -> Dynamic[excluded[t]]], Dynamic[x]}
Dynamic[Graphics[{PointSize[Large], Point[MyTriangle[t]],
Point[MyTriangle[x]],
Line[{{-1, 0}, {1, 0}, {0, Sqrt[3]}, {-1, 0}}]},
PlotRange -> {{-1.2, 4.2}, {-.2, 2}}]]
How about something like:
MyTriangle[t_]:=Piecewise[{
{{-1,0}+t {1,Sqrt[3]},1>t>=0},
{{0,Sqrt[3]}+(t-1) {1,-Sqrt[3]},2>t>=1},
{{1,0}+(t-2) {-2,0},3>=t>=0},{0,True}}]
and
Column[{
{Slider[Dynamic[x], {0, 3, .01}], Dynamic[x]},
{Slider[Dynamic[y], {0, 3, .01}], Dynamic[y]},
Dynamic[x = Mod[x, 3]; Which[
x==0.,Which[0.<=y<1.,y=1.,2.<y<=3.,y=2.],0.<x<1.,y=2.,
x==1.,Which[1.<=y<2.,y=2.,0.<y<=1.,y=0.],1.<x<2.,y=0.,
x==2.,Which[2.<=y<3.,y=0.,1.<y<=2.,y=1.],2.<x<3.,y=1.];
Graphics[{PointSize[Large], Point[MyTriangle /# {x, y}],
Line[{{-1, 0}, {1, 0}, {0, Sqrt[3]}, {-1, 0}}]}]]}]

Resources