Logo Questions Linux Laravel Mysql Ubuntu Git Menu
 

Plotting linear inequalities in Mathematica

I have linear systems of inequalities in 3 variables and I'd like to plot these regions. Ideally, I'd like something that looks like objects in PolyhedronData. I tried RegionPlot3D, but the results are visually poor and too polygon-heavy to rotate in real time

Here's what I mean, the code below generates 10 sets of linear constraints and plots them

randomCons := Module[{},
   hadamard = KroneckerProduct @@ Table[{{1, 1}, {1, -1}}, {3}];
   invHad = Inverse[hadamard];
   vs = Range[8];
   m = mm /@ vs;
   sectionAnchors = Subsets[vs, {1, 7}];
   randomSection := 
    Mean[hadamard[[#]] & /@ #] & /@ 
     Prepend[RandomChoice[sectionAnchors, 3], vs]; {p0, p1, p2, p3} = 
    randomSection;
   section = 
    Thread[m -> 
      p0 + {x, y, z}.Orthogonalize[{p1 - p0, p2 - p0, p3 - p0}]];
   And @@ Thread[invHad.m >= 0 /. section]
   ];
Table[RegionPlot3D @@ {randomCons, {x, -3, 3}, {y, -3, 3}, {z, -3, 
    3}}, {10}]

Any suggestions?

Update: Incorporating suggestions below, here's the version I ended up using to plot feasible region of a system of linear inequalities

(* Plots feasible region of a linear program in 3 variables, \
specified as cons[[1]]>=0,cons[[2]]>=0,...
Each element of cons must \
be an expression of variables x,y,z only *)

plotFeasible3D[cons_] := 
 Module[{maxVerts = 20, vcons, vertCons, polyCons},
  (* find intersections of all triples of planes and get rid of \
intersections that aren't points *)

  vcons = Thread[# == 0] & /@ Subsets[cons, {3}];
  vcons = Select[vcons, Length[Reduce[#]] == 3 &];
  (* Combine vertex constraints with inequality constraints and find \
up to maxVerts feasible points *)
  vertCons = Or @@ (And @@@ vcons);
  polyCons = And @@ Thread[cons >= 0];
  verts = {x, y, z} /. 
    FindInstance[polyCons && vertCons, {x, y, z}, maxVerts];
  ComputationalGeometry`Methods`ConvexHull3D[verts, 
   Graphics`Mesh`FlatFaces -> False]
  ]

Code for testing

randomCons := Module[{},
   hadamard = KroneckerProduct @@ Table[{{1, 1}, {1, -1}}, {3}];
   invHad = Inverse[hadamard];
   vs = Range[8];
   m = mm /@ vs;
   sectionAnchors = Subsets[vs, {1, 7}];
   randomSection := 
    Mean[hadamard[[#]] & /@ #] & /@ 
     Prepend[RandomChoice[sectionAnchors, 3], vs]; {p0, p1, p2, p3} = 
    randomSection;
   section = 
    Thread[m -> 
      p0 + {x, y, z}.Orthogonalize[{p1 - p0, p2 - p0, p3 - p0}]];
   And @@ Thread[invHad.m >= 0 /. section]
   ];
Table[plotFeasible3D[List @@ randomCons[[All, 1]]], {50}];
like image 981
Yaroslav Bulatov Avatar asked Feb 26 '23 03:02

Yaroslav Bulatov


2 Answers

Here is a small program that seems to do what you want:

rstatic = randomCons;                    (* Call your function *)
randeq = rstatic /. x_ >= y_ -> x == y;  (* make a set of plane equations 
                                            replacing the inequalities by == *)

eqset = Subsets[randeq, {3}];            (* Make all possible subsets of 3 planes *)

                                         (* Now find the vertex candidates
                                            Solving the sets of three equations *)
vertexcandidates =      
    Flatten[Table[Solve[eqset[[i]]], {i, Length[eqset]}], 1];

                                         (* Now select those candidates 
                                            satisfying all the original equations *)          
vertex = Union[Select[vertexcandidates, rstatic /. # &]];

                                         (* Now use an UNDOCUMENTED Mathematica
                                            function to plot the surface *)

gr1 = ComputationalGeometry`Methods`ConvexHull3D[{x, y, z} /. vertex];
                                         (* Your plot follows *)
gr2 = RegionPlot3D[rstatic,
        {x, -3, 3}, {y, -3, 3}, {z, -3, 3},
         PerformanceGoal -> "Quality", PlotPoints -> 50]

Show[gr1,gr2]   (*Show both Graphs superposed *)

The result is:

alt text

Downside: the undocumented function is not perfect. When the face is not a triangle, it will show a triangulation:

alt text

Edit

There is an option to get rid of the foul triangulation

 ComputationalGeometry`Methods`ConvexHull3D[{x, y, z} /. vertex,
                                Graphics`Mesh`FlatFaces -> False]

does the magic. Sample:

alt text

Edit 2

As I mentioned in a comment, here are two sets of degenerate vertex generated by your randomCons

 {{x -> Sqrt[3/5]}, 
  {x -> -Sqrt[(5/3)] + Sqrt[2/3] y}, 
  {x -> -Sqrt[(5/3)], y -> 0}, 
  {y -> -Sqrt[(2/5)], x -> Sqrt[3/5]}, 
  {y -> 4 Sqrt[2/5],  x -> Sqrt[3/5]}
 }

and

{{x -> -Sqrt[(5/3)] + (2 z)/Sqrt[11]}, 
 {x -> Sqrt[3/5], z -> 0}, 
 {x -> -Sqrt[(5/3)], z -> 0}, 
 {x -> -(13/Sqrt[15]), z -> -4 Sqrt[11/15]}, 
 {x -> -(1/Sqrt[15]),  z -> 2 Sqrt[11/15]}, 
 {x -> 17/(3 Sqrt[15]), z -> -((4 Sqrt[11/15])/3)}
}

Still trying to see how to cope gently with those ...

Edit 3

This code is not general enough for the full problem, but eliminates the cylinder degenerancy problem for your sample data generator. I used the fact that the pathogenic cases are always cylinders with their axis paralell to one of the coordinate axis, and then used RegionPlot3D to plot them. I'm not sure if this will be useful for your general case :(.

For[i = 1, i <= 160, i++,
 rstatic = randomCons;
 r[i] = rstatic;
 s1 = Reduce[r[i], {x, y, z}] /. {x -> var1, y -> var2, z -> var3};
 s2 = Union[StringCases[ToString[FullForm[s1]], "var" ~~ DigitCharacter]];

 If [Dimensions@s2 == {3},

  (randeq = rstatic /. x_ >= y_ -> x == y;
   eqset = Subsets[randeq, {3}];
   vertexcandidates = Flatten[Table[Solve[eqset[[i]]], {i, Length[eqset]}], 1];
   vertex = Union[Select[vertexcandidates, rstatic /. # &]];
   a[i] = ComputationalGeometry`Methods`ConvexHull3D[{x, y, z} /. vertex, 
            Graphics`Mesh`FlatFaces -> False, Axes -> False, PlotLabel -> i])
  ,

   a[i] = RegionPlot3D[s1, {var1, -2, 2}, {var2, -2, 2}, {var3, -2, 2},
             Axes -> False, PerformanceGoal -> "Quality", PlotPoints -> 50, 
             PlotLabel -> i, PlotStyle -> Directive[Yellow, Opacity[0.5]], 
             Mesh -> None]
  ];
 ]

GraphicsGrid[Table[{a[i], a[i + 1], a[i + 2]}, {i, 1, 160, 4}]]

Here you can find an image of the generated output, the degenerated cases (all cylinders) are in transparent yellow

HTH!

like image 183
Dr. belisarius Avatar answered Mar 08 '23 00:03

Dr. belisarius


A triplet chosen from your set of inequalities will generally determine a point obtained by solving the corresponding triplet of equations. I believe that you want the convex hull of this set of points. You can generate this like so.

cons = randomCons;  (* Your function *)
eqs = Apply[Equal, List @@@ Subsets[cons, {3}], {2}];
sols = Flatten[{x, y, z} /. Table[Solve[eq, {x, y, z}], {eq, eqs}], 1];
pts = Select[sols, And @@ (NumericQ /@ #) &];
ComputationalGeometry`Methods`ConvexHull3D[pts]

Of course, some triplets might actually be underdetermined and lead to lines or evan a whole plane. Thus the code will issue a complaint in those cases.

This appeared to work in the few random cases that I tried but, as Yaro points out, it doesn't work in all. The following picture will illustrate exactly why:

{p0, p1, p2, 
   p3} = {{1, 0, 0, 0, 0, 0, 0, 0}, {1, 1/2, -(1/2), 0, -(1/2), 0, 
    0, -(1/2)}, {1, 0, 1/2, 1/2, 0, 0, -(1/2), 1/2}, {1, -(1/2), 1/2, 
    0, -(1/2), 0, 0, -(1/2)}};
hadamard = KroneckerProduct @@ Table[{{1, 1}, {1, -1}}, {3}];
invHad = Inverse[hadamard];
vs = Range[8];
m = mm /@ vs;
section = 
  Thread[m -> 
    p0 + {x, y, z}.Orthogonalize[{p1 - p0, p2 - p0, p3 - p0}]];
cons = And @@ Thread[invHad.m >= 0 /. section];
eqs = Apply[Equal, List @@@ Subsets[cons, {3}], {2}];
sols = Flatten[{x, y, z} /. Table[Solve[eq, {x, y, z}], {eq, eqs}], 
    1]; // Quiet
pts = Select[sols, And @@ (NumericQ /@ #) &];
ptPic = Graphics3D[{PointSize[Large], Point[pts]}];
regionPic = 
  RegionPlot3D[cons, {x, -2, 2}, {y, -2, 2}, {z, -2, 2}, 
   PlotPoints -> 40];
Show[{regionPic, ptPic}]

Thus, there are points that are ultimately cut off by the plane defined by some other constraint. Here's one (I'm sure terribly inefficient) way to find the ones you want.

regionPts = regionPic[[1, 1]];
nf = Nearest[regionPts];
trimmedPts = Select[pts, Norm[# - nf[#][[1]]] < 0.2 &];
trimmedPtPic = Graphics3D[{PointSize[Large], Point[trimmedPts]}];
Show[{regionPic, trimmedPtPic}]

Thus, you could use the convex hull of trimmedPts. This ultimately depends on the result of RegionPlot and you might need to ramp of the value of PlotPoints to make it more reliable.

Googling about a bit reveals the concept of a feasibility region in linear programming. This seems to be exactly what you're after.

Mark

like image 45
Mark McClure Avatar answered Mar 08 '23 01:03

Mark McClure