I have the coordinates of the cloud of points stored in a matrix. Few of the points are isolated from the others. Does anybody know how I can delete them? The points are shown in the picture. I would appreciate if you could help me because I am not a mathematics guy :(
Since I am a new user I could not upload the picture however the points at the bottom show the data set with 4 scattered points that I want to delete.
.......
........
.........
......... .
.......... ..
...... .
.....
...
Here's some code hope will help for you:
data = Table[{Random[], Random[]}, {100}];
DynamicModule[{p = {0.5, 0.5}, linePts = {}, p1 = {0., 0.},
pts = data},
Manipulate[
Graphics[{Dynamic[Point[pts]], Locator[Dynamic[p]],
Line[Dynamic[If[p != p1, AppendTo[linePts, p]; p1 = p];
linePts]]}],
Row[{Button["updata",
pts = Select[pts, ! Graphics`Mesh`InPolygonQ[linePts, #] &]],
Button["copy points", Print[Flatten[Position[data, #] & /# pts]]],
Button["Reset", linePts = {}; pts = data;]}]]]
You can draw a region in the plot and then delete them in the plot. "update" button will show the remain points, "copy points" will copy the remain points position, "reset" will reset to the original plot.
Related
I have an unstructured dataset "nm", excel file in the link below.
https://www.dropbox.com/s/k7sdblxg4txjvj8/nm.xls?dl=0
it looks like that in a Mathematica list plot 1.
Could You please help me extracting upper bound envelope of this dataset, similar to the red line marked in picture 2? By extracting an envelope I mean to make another list "nm2" that for a given n produces a maximum m? I need another list "nm2" because then i need to work with it in excel.
Best Regards,
BG
Using a technique found here : obtain all boundary points on a convex hull
data = Import["nm.xls"];
chr = ConvexHullRegion[data];
sr = SignedRegionDistance[chr];
dist = sr /# data;
points = Extract[data, Position[dist, 0.]];
{maxx, maxy} = Max /# Transpose[data];
minx = First[FirstCase[points, {_, maxy}]];
miny = Last[FirstCase[points, {maxx, _}]];
arc = Select[points, First[#] >= minx && Last[#] >= miny &];
f = Interpolation[arc];
Show[ListPlot[data], Plot[f[x], {x, minx, maxx},
PlotStyle -> {Thick, Red}]]
This question might seem a little strange but for my purposes is not that crazy.
Its easy but I need you to follow me.
The aim
My aim is plotting a tridimensional graph.
The problem
The problem is the material I have in my hands to start building this graph. Actually I have a collection of points in the 2D space (thus tuples of two real ordered values). Consider a moment to have these collection of points stored into an array and now consider to plot them on a 2D diagram. You will just have a nice sparse view of these points.
Well, the second step is this: consider the surface with these points and create a third axis orthogonal to the plane where those points are drawn. The aim is assigning to every point a numerical scalar value (using a function that accepts the couple and returns a numerical value). So the graph should show bars starting from every point and having a specific value according to the assignment function.
How can I achieve this in Mathematica?
A little note
Basically my points in the 2d space are also connected by a graph. Is it possible to connect the top of the bars to the top of other bars whose base point are connected together in the 2d graph?
Some other notes
My graph doesn`t have to be a surface but just a collection of bars placed on a plane in the exact place where the correspondent point they refer to is located. But if you have a good hint how to draw a surface other than bars, it will be gladly accepted.
I hope I was clear. I would like to point that I have Mathematica 8 so all functionalities are available. Thank you.
This can be done using Graphics3D primitives. Lets start with some data
(* a list of 2D coordinates *)
points2D = RandomReal[{0, Pi}, {50, 2}];
(* some edges as a list of pairs of vertex indices *)
edges = Union[Flatten[MapIndexed[Sort /# Thread[{#2[[1]],
Nearest[points2D -> Automatic, #, 4]}] &, points2D], 1]];
(* constructing list of 3D coordinates *)
f[{x_, y_}] := 2 + Sin[x y]
points3D = {##, f[{##}]} & ### points2D;
The actual plot can then be constructed as follows (width is half the width of the bars)
With[{width = .02},
Graphics3D[{{LightBlue, EdgeForm[None],
Cuboid[{#1, #2, 0} - width {1, 1, 0}, {##} + width {1, 1, 0}] & ### points3D},
{Orange,
GraphicsComplex[points3D, Line[edges]]}},
Lighting -> "Neutral",
BoxRatios -> {1, 1, .6}]]
Encouraged by this question, I dare to ask something similar.
I am trying to plot with mathematica a cone which is intersected by a line. The start point of the line is on the lateral surface of the cone and its endpoint inside of the cone.
As long as the endpoint of the line is far away from the tip of the cone, everything looks quite nice (use e.g. endpointOfLine = 0.007 in my example). But if the endpoint approaches the tip (endpointOfLine < 0.007 in my example), it seems that a big part of the line would be on the surface of the cone.
Sure, for endpoint values which are very close to the cone tip, the line is almost parallel to the surface so that this effect has probably to appear. But the effect appears also if the endpoint is not so close to cone tip.
Here the example:
totalLength = 10^-2;(*length of the cone*)
theta = 17*10^-3;(*half opening angle of the cone*)
radius[theta_, l_] := Tan[theta]*l;(*radius of the cone as function of its length*)
endpointOfLine = 0.0015;(*endpoint of the test line, to be varied*)
testLine = Line[{{radius[theta, totalLength], 0, totalLength},{0, 0, endpointOfLine}},
VertexColors -> {Orange, Orange}
];
Graphics3D[
{
{
RevolutionPlot3D[{radius[theta, l], 0, l}, {l, 0, totalLength},
Mesh -> None,
PlotStyle -> Directive[Opacity[0.5], Gray],
PlotPoints -> 60][[1]]
},
{testLine}
},
Boxed -> True,BoxRatios -> {1, 1, 3},
Lighting -> None(*ugly, but makes the problem well visible*)
]
Is there any way to reduce this effect? Increasing the PlotPoints to 60 has reduced the effect a bit, but I would be happy if I could reduce it more. Any ideas?
Try to place the endpoint at the base of the cone close but not on the radius like:
testLine =
Line[{{0.97 radius[theta, totalLength], 0, totalLength}, {0, 0, endpointOfLine}},
VertexColors -> {Orange, Orange}
];
I feel this is not a problem fundamentally different from the one you were referring to.
Continuing with the project I previously described I am currently building an animation showing movement between a list of cities. My current code renders a list of cities and makes a set of great circle arcs connecting the cities. The list of cities are part of a timeline so after visiting one city the animation will transition to be centered upon the next.
To my mind this means the ViewVector should be adjusted to show points between a starting city and an ending city. The resulting would probably look like an in-flight map for a long-haul flight sped up considerably. A single frame might look like the following manually produced still:
I now understand how to position the ViewVector above the most recent city but I am quite unsure about how to move the camera smoothly between two spherical coordinate points. My current code is below:
SC[{lat_, lon_}] := {Cos[lon \[Degree]] Cos[lat \[Degree]],
Sin[lon \[Degree]] Cos[lat \[Degree]], Sin[lat \[Degree]]};
GreatCircleArc[{lat1_, lon1_}, {lat2_, lon2_}] :=
Module[{u = SC[{lat1, lon1}], v = SC[{lat2, lon2}], a},
a = VectorAngle[u, v];
Table[Evaluate[RotationTransform[\[Theta], {u, v}][u]], {\[Theta],
0, a, a/Ceiling[10 a]}]]
CityGraphic[name_] := {Opacity[0.85], Black, PointSize[Medium], White,
PointSize[0.045], Point[1.01 SC[CityData[name, "Coordinates"]]]}
CityGraph[places_, age_] :=
Graphics3D[{
Opacity[0.75],
Sphere[{0, 0, 0}, 0.99 ],
Map[Line[
Map[SC,
CountryData[#, "SchematicCoordinates"], {-2}]] &,
CountryData["Countries"]],
Map[CityGraphic, places],
Text[Style[age, FontFamily -> "Helvetica"],
1.02 SC[CityData[First[places], "Coordinates"]]],
White, Line
[Apply[GreatCircleArc,
Partition[Map[CityData[#, "Coordinates"] &, places], 2, 1], {1}]]
},
ViewVector -> {
4 SC[CityData[First[places], "Coordinates"]], {0, 0, 0}},
Boxed -> False,
SphericalRegion -> True,
ImageSize -> {640, 480}
];
CityGraph[{"Tokyo", "Dublin", "Cape Town", "Seattle", "Denver"}, "04"]
In computer graphics people often use Quaternions to smoothly interpolate between various camera viewing directions. Mathematica has a Quaternion package which you could use for basic Quaternion arithmetic. A conversion between Quaternions and Euler angles is described here.
The interpolation process is described here.
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]