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]].
Related
I am trying to figure out how to use Mathematica's color schemes with discrete data. For example, I have a list of time series in the form
s={{{1946,1},{1947,2},{1948,3}},{{1946,-2},{1947,-1.8}}}
and so on; there are about 30 series of varying length. If I plot/join/overlay these series using ListPlot, is there a way to instruct Mathematica to select colors for each plot by taking evenly spaced colors from a ColorFunction returned by ColorData (e.g., "Rainbow")?
How would I combine this with a directive to make each plot Thick?
ListPlot[s,Joined->True,PlotStyle->{Thick,???}]
Imagine this is your data - a ragged list of 30 lists of varied length:
data = Table[.5 k + RandomReal[1, RandomInteger[{8, 14}]], {k, 30}];
Is it what you need?
ListPlot[data, Joined -> True,
PlotStyle -> Thread#{Thick, ColorData["Rainbow"] /# Range[0, 1, 1/29]}]
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.
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}]
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]
I am doing this:
ClearAll[matrix];
matrix[p_,q_,nu_:0]:=Module[{sigma},
sigma=p/q;
N#SparseArray[
{{m_,m_}\[Rule]2Cos[2\[Pi]*m*p/q+nu],{i_,j_}/;
Abs[i-j]\[Equal]1\[Rule]1},{q,q}]]
ClearAll[attachsigma]
attachsigma[sigma_,lst_]:={sigma,#}&/#lst
and then execute
fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates;
pq = {Numerator##, Denominator##} & /# fracs;
(ens = Eigenvalues[#] & /#
Normal /# (matrix[#[[1]], #[[2]]] & /# pq);) // Timing
pts = Flatten[#, 1] &#MapThread[attachsigma, {fracs, ens}];
and finally I plot the points as follows (here is the real point of the question):
plot = ListPlot[pts,
PlotMarkers \[Rule] Graphics[{PointSize[Tiny], Point[{0, 0}]}]]
Calculating all the points takes around around 2.6s on my machine, but the plot takes around 25s. If, on the other hand, I plot it like this
ListPlot[pts]
then it is almost instantaneous, as it should (it's just 5256 points). So, it seems PlotMarkers slows things down immensely.
Could anybody
a) explain why (this much I vaguely understand, in analogy with what happens to Sort if you give it custom ordering function) and, more importantly,
b) explain how to avoid this slowdown? I am trying to create plots with quite a bit more points than this so they're really slow; in addition, I am creating lots of them (a movie actually).
One solution would be to not plot all of them, but as I vary parameters it becomes nontrivial to find out which I should include and which not (this would of course work if I only needed this one frame). So, I'd like to speed up the plot creation without removing points.
EDIT: Answered after hints from Sjoerd:
ListPlot[pts] /. Point[List[x___]] \[RuleDelayed] {PointSize[Tiny], Point[List[x]]}
produces the right thing instantaneously. This simply replaces the Points inside the Graphics structure by smaller points by hand.
Now one can increase the upper limit in the table in fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates to 80 or so to get many more points (this thing is the Hofstadter butterfly, and it's a fractal):
PlotMarkers is meant for data plots that contain relatively few points. It is very useful in plots in which you use the markers to identify various conditions. Each individual marker is an Inset as follows:
Inset[Graphics[List[Hue[0.67`,0.6,0.6`],PointSize[Tiny],Point[List[0, 0]]]],10512].
You can imagine this takes up some time and memory.
I also found what seems to be a bug. The plot with PlotMarkers is structured as GraphicsComplex[pointlist,graphicsinstructions]. This point list seems to contain the points in the plot twice!
In[69]:= pts // Length
Out[69]= 5256
In[66]:= plot[[1, 1]] // Length
Out[66]= 10512
In[64]:= Union[plot[[1, 1]]] == Union[pts]
Out[64]= True
In[68]:= Tally[plot[[1, 1]]][[All, 2]] // Mean (*the average number each point occurs*)
Out[68]= 2
Personally, I prefer Graphics to ListPlot, especially when the number of points is large.
Graphics[{Hue[{2/3, 1, 1, .5}], AbsolutePointSize[1.5], Point#pts},
PlotRange -> {{0, 1}, {-4, 4}}, Axes -> False,
AspectRatio -> 1/GoldenRatio]
gives, for example:
Length#pts
102969
I believe the solution you appended to your question can be simplified:
ListPlot[pts] /. x_Point :> {PointSize[Tiny], x}
I voted for both prior answers, but I agree with TomD on the direct use of Graphics.