Goal Seek, in Mathematica - wolfram-mathematica

For an experiment, we generated in Matlab some images made out of 8 Disks. We constrained, the minimum distance between the disks and between the disks and the frame as well as the location of the Disks Center Of Gravity (COG). Bellow an example of a composition with the COG on the upper lift "third"
FraXYs = {{4.32, 3.23}, {35.68, 26.75}}
stiDisks = {{{8, 11}, 1}, {{10, 17}, 1}, {{16, 24}, 1}, {{25, 22},1},
{{31, 22}, 1}, {{7, 21}, 2}, {{16, 12}, 2}, {{19, 22}, 2}}
Graphics[{White, EdgeForm[Thick],
Rectangle ## FraXYs,
Red, Disk[{14.77, 18.91}, 1],
Blue, Opacity[.6], EdgeForm[Black],
Blue, Thickness[0.003],
Opacity[1],
Black,
Disk[#[[1]], #[[2]]] & /# stiDisks}, ImageSize -> {400, 300}]
I would like to generate those stimuli in Mathematica. Below are the element (features and constraints) I am dealing with. The measures are in Cm. The Center Of Gravity (COG) of the shapes is defined as the area weihtgted location of the disks.
The Features :
Stimuli Frame : {{xMin,xMin},{xMax,yMax}}
FraXYs = {{4.32, 3.23}, {35.68, 26.75}}
5 Small Disks : with radius
rSmall=1
3 Large Disks : with radius
rLarge=2
The Constraints :
Minimum distance between the shapes edges :
minDistSha=1
Minimum distance between the shapes edges and the frame border :
minDistFra=1
Distance of shapes COG from the center :
minDistCogCenter=2
Potentially, I will need to constraint the COG of the disks to be on a certain angle from the center (theta coordinate in a polar system?). So I could select the disks coordinates constraining their COGs to be located every 22.5 degree in a polar coordinate
angleBin=22.5
Is there useful Functions in Mathematica to achieve the selection under constraints aside of Selct.
I would be curious to know if a closed formula to generate 1 composition with a particular COG location is possible.
Indicatively, I will need to get a pool of 1000 compositions. Using the "theta constraints"of 36 degrees, I should extract 10*100 composition with their COG located on the 10 different theta bars at a minimum or fixed distance from the center.
Please tell me if clarifications are needed. Thank You for your attention.

This might get you started. It is a simple rejection method to generate circles at random, throwing away ensembles that do not meet requirements.
Arguments are the box size, numbers and radii of small and large circles, and a minimum separation. That last is used both for distances to boundary and distances between circles. I double it for the center of gravity to center of frame constraint. Clearly this usage could be generalized by adding more arguments.
For purposes of assessing how likely this is to find viable ensembles, I print the number of times through the loop. Also I use a Catch/Throw mechanism that is not really necessary (artifact of some experimentation that I did not bother to remove).
--- edit ---
The code below has modest changes from what I originally posted. It separates the center of gravity circle as the red one.
To handle the constraint that it lie at some specified angle, one might generate as below, rotate to put into the correct angular position, and recheck distances from circles to frame boundary. Possibly there is something smarter that will be less likely to give a rejection, while still maintaining uniformity. Actually I'm not at all certain that what I coded gives a uniform distribution from the space of allowable configurations. If it does, the influence of rotating will very likely destroy that property.
--- end edit ---
randomConfiguration[{xlo_, ylo_}, {xhi_, yhi_}, nsmall_, nlarge_,
rsmall_, rlarge_, minsep_] := Catch[Module[
{found = False, xsmall, ysmall, xlarge, ylarge, smallsep, largesep,
smallcircs, largecircs, cog, cen, indx = 0},
smallsep = {rsmall + minsep, -rsmall - minsep};
largesep = {rlarge + minsep, -rlarge - minsep};
cen = {xhi - xlo, yhi - ylo};
While[! found,
found = True;
indx++;
xsmall = RandomReal[{xlo, xhi} + smallsep, nsmall];
ysmall = RandomReal[{ylo, yhi} + smallsep, nsmall];
xlarge = RandomReal[{xlo, xhi} + largesep, nlarge];
ylarge = RandomReal[{ylo, yhi} + largesep, nlarge];
smallcircs = Transpose[{xsmall, ysmall}];
Do[If[
Norm[smallcircs[[i]] - smallcircs[[j]]] <= 2*rsmall + minsep,
found = False; Break[]], {i, nsmall - 1}, {j, i + 1, nsmall}];
largecircs = Transpose[{xlarge, ylarge}];
Do[If[
Norm[largecircs[[i]] - largecircs[[j]]] <= 2*rlarge + minsep,
found = False; Break[]], {i, nlarge - 1}, {j, i + 1, nlarge}];
Do[If[
Norm[smallcircs[[i]] - largecircs[[j]]] <=
rsmall + rlarge + minsep, found = False; Break[]], {i,
nsmall}, {j, nlarge}];
cog = (rsmall^2*Total[smallcircs] +
rlarge^2*Total[largecircs])/(nsmall*rsmall^2 +
nlarge*rlarge^2);
If[Norm[cog - cen] <= 2*minsep, found = False;];
];
Print[indx];
Throw[{{cog, rsmall},Map[{#, rsmall} &, smallcircs],
Map[{#, rlarge} &, largecircs]}]
]]
Example:
{smallc, largec} =
randomConfiguration[{4.32, 3.23}, {35.68, 26.75}, 5, 3, 1, 2, 1];
13
FraXYs = {{4.32, 3.23}, {35.68, 26.75}};
{cog, smallc, largec} =
randomConfiguration[{4.32, 3.23}, {35.68, 26.75}, 5, 3, 1, 2, 1];
Graphics[{White, EdgeForm[Thick], Rectangle ## FraXYs, Red,
Apply[Disk, cog], Blue, Opacity[.6], EdgeForm[Black], Blue,
Thickness[0.003], Opacity[1], Black,
Disk[#[[1]], #[[2]]] & /# Join[smallc, largec]},
ImageSize -> {400, 300}]

Related

Find frequency for non-binned, weighted data

Here is a tricky problem (or at least so I think). I need to create a histogram, but instead of having the data and it's frequency, I have repeated data (i.e. not binned) and some weight for each data.
One example:
Angle | Weight
90 .... 3/10
93 .... 2/10
180 .... 2/10
180 .... 1/10
95 .... 2/10
I want to create a histogram with bin size 10. The y-values should be the sum of weighted frequencies for angles within a range. How can I do it? Preferably Mathematica or pseudocode...
In Mathematica 9, you can do it using the WeightedData function like this:
Histogram[WeightedData[{90, 93, 180, 180, 95}, {3/10, 2/10, 2/10, 1/10, 2/10}], {10}]
You should then get a graphic like this one:
Since the expected output is not forthcoming I shall adopt Verbeia's interpretation. You might use something like this:
dat = {{90, 3/10}, {93, 1/5}, {180, 1/5}, {180, 1/10}, {95, 1/5}};
bars =
Reap[
Sow[#2, Floor[#, 10]] & ### dat,
_,
{#, Tr##2} &
][[2]]
Graphics[
Rectangle[{#, 0}, {# + 10, #2}] & ### bars,
AspectRatio -> 1/GoldenRatio,
Axes -> True,
AxesOrigin -> {Min#bars[[All, 1]], 0}
]
I did something similar for a different kind of question recently (weighting by balance sheet size).
Assuming your data is in an N * 2 matrix list, I would do something like:
{numbers,weights} = {data[[All,1]], data[[All,2]]*10};
weightednumbers = Flatten# MapThread[
Table[#1, {#2}] &, {numbers, Ceiling[weights]}];
And then use Histogram to draw the histogram on this transformed data.
There might be other ways but this works.
An important point is to make sure the weights are integers, so the Table as the correct iterator. This might require defining weights as data[[All,2]]*Min[data[[All,2]].

Covariance Matrix of Disks Pixels in Mathematica

I would like to compute the Covariance Matrix of the image below. Pixel based. That is considering each Black Pixel of the Disks as vectors.
While the units below are in centimeter, there are 32 pixels per cm on the screen I am using.
Ahead of the Covariance Matrix computation itself, I can`t figure out the way to obtain all the pixels vector.
frmXY = {{6.59, 1.59}, {33.41, 28.41}};
stim = {{10.85, 21.91, 0.97}, {16.8, 5.26, 0.97}, {11.78, 7.11, 0.97},
{12.64, 14.13, 0.97`}, {20.24, 16.16, 0.97}, {29.51, 8.06,1.53},
{22.42, 5.78, 1.53}, {27.13, 16.47, 1.53}}
Graphics[{EdgeForm[Thick],White, Rectangle ## frmXY, Black,
Disk ### (stim /. {a_, b_, c_} :> {{a, b}, c})}, ImageSize -> 300]
It is not clear from your question as to what constitutes the random variable that describes your model/system and I don't understand what it is that you're trying to take the covariance matrix of.
However, here's a simple example showing how to obtain the covariance matrix and compute the eigenvalues and eigenvectors (basically, reproduce your first plot).
list = RandomReal[
MultinormalDistribution[{0, 0}, {{6, 3}, {3, 3}}], {5000}];
sampleCov = Covariance#list;
{eigValues, eigVectors} = Eigensystem#sampleCov;
Show[ListPlot#list,
Graphics[{Red, Arrowheads[0.03],
Arrow[{{0, 0}, #}] & /# (eigValues eigVectors)}]]

Parametrizing 3D geometry for shape optimization

I am trying to parametrize a 3D geometry for shape optimization. The structure looks like the following. Another real example is here.
Currently I am using BSplines to create the lower part and using symmetry to create the whole down part of the foil. Here is what I get.
Now I have many control points to take care in order to run a shape optimization. I also don't know how to join the upper part with the bottom hydrofoil part in a sensible way. I don't know how to design a good middle part of the foil (fat nose part of the foil) where the upper part is linked to. I also need to accompany a flap with in the geometry.
Please offer some suggestion for parametrization of such a surface so that we can manipulate the geometry from MMA. The less control points are there better the situation is for optimization. May be combination of some analytic function in 3D. But I doubt if that is possible.
BR
I think you have two choices: 1) create the second part of the geometry and then write a face-face intersection algorithm to merge them. 2) create the second part of the geometry and write two functions that return -1 if a query point is inside the geometry and +1 if it is out side (other values will do). Then use RegionPlot3D[ f1[x,y,z]<0 || f2[x,y,z]<0,....]. The idea is the to extract the GraphicsComplex and use that. The question is going to be how well you can approximate the corners with that. Here is an illustration of what I mean.
if1[x_, y_, z_] := If[x^2 + y^2 + z^2 <= 1, -1, 1]
if2[x_, y_, z_] := If[(x - 1)^2 + y^2 <= 1 && -1.5 <= z <= 1.5, -1, 1]
res = RegionPlot3D[
if1[x, y, z] < 0 || if2[x, y, z] < 0, {x, -2, 2}, {y, -2,
2}, {z, -2, 2}, PlotPoints -> 100, Boxed -> False, Axes -> False]
Then extract the coords and the polygons.
coords = res[[1, 1]];
poly = Cases[res[[1]], _Polygon, Infinity];
Graphics3D[GraphicsComplex[coords, poly], Boxed -> False]
Hope this helps.

Create matrix out of list with mathematica

I have a problem which I try to solve with mathematica.
I am having a list with x and y coordinates from a position measurement (and also with z values of the quantity which was measured at each point). So, my list starts with
list={{-762.369,109.998,0.915951},{-772.412,109.993,0.923894},{-777.39, 109.998, 0.918108},...} (x,y,z).
Out of some reasons, I have to fill all these x,y, and z-values into a matrix. That would be easy if I have for each y-coordinate the same amount of x-coordinates (lets say 80), then I could use Partition[list,80] which produces a matrix with 80 columns (and some rows whose number is given by the number of y-coordinates with the same value).
Unfortunately, it is not so easy, the number of x-coordinates for each y is not strictly constant, as can be seen from the attached ListPlot.
Can anybody give me some suggestions, how I could fill each point of this plot / each x-y-(and z-) coordinate of my list into a matrix?
To explain better what I want to have, I indicated in the attached picture a matrix. There one can see that almost every point of my plot would fall into a cell of a matrix, only some cells would stay empty.
I used in the plot the color red for the points whose x coordinates are ascending in my list and blue for the points whose x coordinate are descending in my list (the positions are measured along a meander line). Perhaps this kind of order can be useful to solve to problem...
Here a link to my coordinates, perhaps this helps.
Well, I hope I explained my question well enough. I would appreciate every help much!
The basic idea behind this solution is:
all points seem to lie on a lattice, but it's not precisely a square lattice (it's slanted)
so let's find the basis vectors of the lattice, then all (most?) points will be approximate integer linear combinations of the basis vectors
the integer "coordinates" of the points along the basis vectors will be the matrix indices for the OP's matrix
(The OP emailed me the datafile. It consists of {x,y} point coordinates.)
Read in the data:
data = Import["xy.txt", "Table"];
Find the nearest 4 points to each point, and notice that they lie about distance 5 away both horizontally and vertically:
nf = Nearest[data];
In:= # - data[[100]] & /# nf[data[[100]], 5]
Out= {{0., 0.}, {-4.995, 0.}, {5.003, 0.001}, {-0.021, 5.003}, {0.204, -4.999}}
ListPlot[nf[data[[100]], 5], PlotStyle -> Red,
PlotMarkers -> Automatic, AspectRatio -> Automatic]
Generate the difference vectors between close points and keep only those that are about length 5:
vv = Select[
Join ## Table[(# - data[[k]] & /# nf[data[[k]], 5]), {k, 1, Length[data]}],
4.9 < Norm[#] < 5.1 &
];
Average the vectors out by directions they can point to, and keep two "good" ones (pointing "up" or to the "right").
In:= Mean /# GatherBy[vv, Round[ArcTan ## #, 0.25] &]
Out= {{0.0701994, -4.99814}, {-5.00094, 0.000923234}, {5.00061, -4.51807*10^-6},
{-4.99907, -0.004153}, {-0.0667469, 4.9983}, {-0.29147, 4.98216}}
In:= {u1, u2} = %[[{3, 5}]]
Out= {{5.00061, -4.51807*10^-6}, {-0.0667469, 4.9983}}
Use one random point as the point of origin, so the coordinates along the basis vectors u1 and u2 will be integers:
translatedData = data[[100]] - # & /# data;
Let's find the integer coordinates and see how good they are (how far they are from actual integers):
In:= integerIndices = LinearSolve[Transpose[{u1, u2}], #] & /# translatedData ;
In:= Max[Abs[integerIndices - Round[integerIndices]]]
Out= 0.104237
In:= ListPlot[{integerIndices, Round[integerIndices]}, PlotStyle -> {Black, Red}]
All points lie close to the integer approximations.
Offset the integer coordinates so they're all positive and can be used as matrix indices, then gather the elements into a matrix. I put the coordinates in a point object in order not to confuse SparseArray:
offset = Min /# Transpose[Round[integerIndices]]
offset = {1, 1} - offset
result =
SparseArray[
Thread[(# + offset & /# Round[integerIndices]) -> point ### data]]
result = Normal[result] /. {point -> List, 0 -> Null}
And we finally have a matrix result where each element is a coordinate-pair! (I was sloppy doing 0 -> Null here to mark missing elements: it's important that data contained no exact 0s.)
MatrixForm[result[[1 ;; 10, 1 ;; 5]]]
EDIT
Just for fun, let's look at the deviations of points from the precise integer lattice sites:
lattice = #1 u1 + #2 u2 & ### Round[integerIndices];
delta = translatedData - lattice;
delta = # - Mean[delta] & /# delta;
ListVectorPlot[Transpose[{lattice, delta}, {2, 1, 3}], VectorPoints -> 30]

"Center of Mass" between a set of points on a Toroidally-Wrapped Map that minimizes average distance to all points

edit As someone has pointed out, what I'm looking for is actually the point minimizing total geodesic distance between all other points
My map is topographically similar to the ones in Pac Man and Asteroids. Going past the top will warp you to the bottom, and going past the left will warp you to the right.
Say I have two points (of the same mass) on the map and I wanted to find their center of mass. I could use the classical definition, which basically is the midpoint.
However, let's say the two points are on opposite ends of the mass. There is another center of mass, so to speak, formed by wrapping "around". Basically, it is the point equidistant to both other points, but linked by "wrapping around" the edge.
Example
b . O . . a . . O .
Two points O. Their "classical" midpoint/center of mass is the point marked a. However, another midpoint is also at b (b is equidistant to both points, by wrapping around).
In my situation, I want to pick the one that has lower average distance between the two points. In this case, a has an average distance between the two points of three steps. b has an average distance of two steps. So I would pick b.
One way to solve for the two-point situation is to simply test both the classical midpoint and the shortest wrapped-around midpoint, and use the one that has a shorter average distance.
However! This does not easily generalize to 3 points, or 4, or 5, or n points.
Is there a formula or algorithm that I could use to find this?
(Assume that all points will always be of equal mass. I only use "center of mass" because it is the only term I knew to loosely describe what I was trying to do)
If my explanation is unclear, I will try to explain it better.
The notion of center of mass is a notion relevant on affine spaces. The n-dimensional torus has no affine structure.
What you want is a point which minimizes (geodesic) distance to all the other points.
I suggest the following: let x_1...x_n be a collection of points on the d-dimensional torus (or any other metric space for that purpose).
Your problem:
find a point mu such that sum(dist(mu, x_k)^2) is minimal.
In the affine-euclidian case, you get the usual notion of center of mass back.
This is a problem you will be able to solve (for instance, there are probably better options) with the conjugate gradient algorithm, which performs well in this case. Beware that you need moderate n (say n < 10^3) since the algorithm needs n^2 in space and n^3 in time.
Perhaps better suited is the Levenberg-Marquardt algorithm, which is tailored for minimization of sum of squares.
Note that if you have a good initial guess (eg. the usual center of mass of the points seen as points in R^d instead of the torus) the method will converge faster.
Edit:
If (x1...xd) and (y1...yd) are points on the torus, the distance is given by
dist(x, y)^2 = alpha1^2 + ... + alphad^2
where alphai = min((xi - yi) mod 1, (yi - xi) mod 1)
I made a little program to check the goodness of the involved functions and found that you should be very carefull with the minimization process.
Below you can see two sets of plots showing the points distribution, the function to minimize in the euclidean case, and the one corresponding to the "toric metric".
As you may see, the euclidean distance is very well-behaved, while the toric present several local minima that difficult the finding of the global minima. Also, the global minimum in the toric case is not unique.
Just in case, the program in Mathematica is:
Clear["Global`*"];
(*Define non wrapping distance for dimension n*)
nwd[p1_, p2_, n_] := (p1[[n]] - p2[[n]])^2;
(*Define wrapping distance for dimension n *)
wd[p1_, p2_, max_,n_] := (max[[n]] - Max[p1[[n]], p2[[n]]] + Min[p1[[n]], p2[[n]]])^2;
(*Define minimal distance*)
dist[p1_, p2_, max_] :=
Min[nwd[p1, p2, 1], wd[p1, p2, max, 1]] +
Min[nwd[p1, p2, 2], wd[p1, p2, max, 2]];
(*Define Euclidean distance*)
euclDist[p1_, p2_, max_] := nwd[p1, p2, 1] + nwd[p1, p2, 2];
(*Set torus dimensions *)
MaxX = 20;
MaxY = 15;
(*Examples of Points sets *)
lCircle =
Table[{10 Cos[fi] + 10, 5 Sin[fi] + 10}, {fi, 0, 2 Pi - .0001, Pi/20}];
lRect = Join[
Table[{3, y}, {y, MaxY - 1}],
Table[{MaxX - 1, y}, {y, MaxY - 1}],
Table[{x, MaxY/2}, {x, MaxY - 1}],
Table[{x, MaxY - 1}, {x, MaxX - 1}],
Table[{x, 1}, {x, MaxX - 1}]];
(*Find Euclidean Center of mass *)
feucl = FindMinimum[{Total[
euclDist[#, {a, b}, {MaxX, MaxY}] & /# lRect], 0 <= a <= MaxX,
0 <= b <= MaxY}, {{a, 10}, {b, 10}}]
(*Find Toric Center of mass *)
ftoric = FindMinimum[{Total[dist[#, {a, b}, {MaxX, MaxY}] & /# lRect],
0 <= a <= MaxX, 0 <= b <= MaxY}, {{a, 10}, {b, 10}}]
In the 1 dimensional case, your problem would be analagous to finding a mean angle.
The mean of angles a and b can be computed by
mean = remainder( a + remainder( b-a, C)/2.0, C)
where C is the measure of a whole circle (ie 2*PI if you're using radians).
If you have n angles a[], the mean can be computed by
mean = a[0];
for i=1..n mean=remainder( mean + remainder( a[i]-mean, C)/(i+1), C)
So I reckon
meanX = X[0]; meanY = Y[0]
for i=1..n
meanX = remainder( meanX + remainder( X[i]-meanX, W)/(i+1), W)
meanY = remainder( meanY + remainder( Y[i]-meanY, H)/(i+1), H)
might do the job.
But note that this will result in -W/2<=meanX
IANATopologist, and I don't know how clear I'm making myself in this, but for what it's worth, these are some thoughts on the matter:
Using mass and gravity to calculate this sort of thing might indeed be elegant -- ISTR that there are a number of libraries and efficient algorithms to find the gravity vectors for any number of masses.
If you were using a spherical map, I'd suggest finding within the sphere the actual center of gravity for your N mass points. You then draw a line from the center outward through this inner center of gravity to find the point on the sphere's surface where your mass points wish to congregate.
However, a toroidal map makes this difficult.
My suggestion, then, is to flatten and copy your map to give you a 3 x 3 quilt of maps (using an infinite field of maps will give better results, but might be overkill). I'll assign coordinates (0, 0) to (2, 2) to them, with (1, 1) being your source map. Find the point(s) to which the mass points of your inner map (1, 1) are attracted -- if they all go towards the middle of your map, fine: you found your center of gravity. If not, if one of the points close to the edge is going towards some mass accumulation outside of your inner map, say into map (2, 1), then discard this mass point when calculating your center of gravity. Instead you use the mass point from the opposite map ((0, 1) in this case) that wants to wander over into your middle map.
Adding the acceleration vectors for these mass points gives you the center of gravity on your torus.
Done.

Resources