3
$\begingroup$

Consider the matrix 'm1' :

m1 = RandomReal[{0, 1}, {100, 100}];

Let's draw a rectangle in this matrix

dim = 100; (*matrix dimension*)
t1 = Table[{i, j}, {i, dim}, {j, dim}]; (*matrix coordinates*)
alpha = -Pi/3;
k = Tan[alpha]; (* 0<alpha<Pi/2 *)
t2 = RandomSample[Flatten[t1, 1],50]; (*randomly selected coordinates*)
X = t2[[1, 2]](**)
Y = t2[[1, 1]]  (**)
b1 = Solve[k X + n == Y, n][[1, 1, 2]];
b2 = Solve[-1/k X + n == Y, n][[1, 1, 2]];
w1 = 5; (*Half the length of the side of the rectangle *)
w2 = 10; (*Half the length of the side of the rectangle *)
e1 = k x + b1 + w1 Sqrt[1 + k^2];
e2 = k x + b1 - w1 Sqrt[1 + k^2];
e3 = -(1/k) x + b2 + w2 Sqrt[1 + k^2];
e4 = -(1/k) x + b2 - w2 Sqrt[1 + k^2];
Rotate[Show[(*ArrayPlot[t1,PlotTheme->"Detailed"],*) ListPlot[{Catenate@t1}, PlotStyle -> {Gray, Red}, AspectRatio -> 1, PlotMarkers -> {\[FilledSmallCircle], Small}],Plot[{k x + b1, e1, e2, e3, e4, -(1/k) x + b2}, {x, 1, 100},PlotRange -> {{1, 100}, {1, 100}}, PlotStyle -> {{Dashed, Black}, Blue, Blue, Green, Green, {Dashed, Black}}], ListPlot[{{X, Y}}, PlotStyle -> {PointSize -> 0.03, Red}],ImageSize -> 600], -Pi/2]

enter image description here

The question is: how to extract elements of matrix 'm1' from area bounded by straight lines (rectangle) and save it as a matrix the "bounding rectangle" (orange), keep the red elements, and set the grey elements to zero (fig. by @Domen): enter image description here

@Henrik Schumacher Thanks. But how to control the alpha angle of the rectangle?

$\endgroup$

2 Answers 2

6
$\begingroup$

Maybe something like this does what you want:

m = 100;
n = 100;
m1 = RandomReal[{0, 1}, {m, n}];

(*center of the rectangle*)
center = {RandomInteger[{1, m}], RandomInteger[{1, n}]};
(*direction of first side of the rectangle*)
e1 = RandomPoint[Circle[]];
(*direction of the second side of the rectangle*)
e2 = RotationTransform[Pi/2][e1];
(*half the length of the first side of the rectangle*)
halflength1 = RandomReal[{1, m/2}];
(*half the length of the second side of the rectangle*)
halflength2 = RandomReal[{1, n/2}];

pts = Tuples[{Range[m], Range[n]}];
(*The following vector has a 1 at positions that belong to the rectangle; other entries are 0.*)
picker = Times[
  UnitStep[halflength1 - Abs[pts.e1 - center.e1]], 
  UnitStep[halflength2 - Abs[pts.e2 - center.e2]]
];
(*Pick the coordinates of the points belonging to the rectangle.*)
pattern = Pick[pts, picker, 1];
(*Find axis-aligned bounding box (the orange rectangle)*)
{xspan, yspan} = Span @@@ (MinMax /@ Transpose[pattern]);

(*Use SparseArray to construct the actual matrix.*)
result = SparseArray[pattern -> Extract[m1, pattern], {m, n}][[xspan, yspan]]
$\endgroup$
4
  • $\begingroup$ Thanks. But how to control the alpha angle of the rectangle? $\endgroup$
    – ralph
    Feb 14, 2022 at 16:13
  • $\begingroup$ Just by setting e1 = {cos[\[Alpha]],Sin[\[Alpha]]}? $\endgroup$ Feb 14, 2022 at 18:18
  • $\begingroup$ Thanks. And now an equally important question. How to optimize it to make it faster? For example, for n = 1000 and m = 1000 it is very slow. $\endgroup$
    – ralph
    Feb 15, 2022 at 21:01
  • $\begingroup$ That was not part of the original post. $\endgroup$ Feb 16, 2022 at 16:06
0
$\begingroup$

"13.0.1 for Microsoft Windows (64-bit) (January 28, 2022)"

Alternatively, we can find four intersection points of lines and use CoordinateBoundingBox to find bounding rectangle.

  ClearAll["Global`*"]

SeedRandom@123;
m = 100;
m1 = RandomReal[{0, 1}, {m, m}];
t1 = Tuples[Range@m, {2}] ;  (*matrix coordinates*)
alpha = -Pi/3;
k = Tan[alpha];   (*0<alpha<Pi/2*)
t2 = RandomSample[t1, 50];    (*randomly selected coordinates*)
X = t2[[1, 2]];
Y = t2[[1, 1]] ; 
b1 = Solve[k X + n == Y, n][[1, 1, 2]];
b2 = Solve[-1/k X + n == Y, n][[1, 1, 2]];
w1 = 5;(*Half the length of the side of the rectangle*)
w2 = 10;(*Half the length of the side of the rectangle*)
e1 = k x + b1 + w1 Sqrt[1 + k^2];
e2 = k x + b1 - w1 Sqrt[1 + k^2];
e3 = -(1/k) x + b2 + w2 Sqrt[1 + k^2];
e4 = -(1/k) x + b2 - w2 Sqrt[1 + k^2];

pts = Flatten /@ {SolveValues[ {y == e1, y == e3}, {x, y}], 
     SolveValues[ {y == e1, y == e4}, {x, y}], 
     SolveValues[ {y == e2, y == e3}, {x, y}], 
     SolveValues[ {y == e2, y == e4}, {x, y}]} // Simplify;

{{x1, y1}, {x2, y2}} = CoordinateBoundingBox[pts]

mask = UnitStep[t1[[All, 1]] - x1, x2 - t1[[All, 1]], 
    t1[[All, 2]] - y1, y2 - t1[[All, 2]]]~Partition~m;

boundingRectangle = Transpose[m1 mask];

{Show[ArrayPlot[Transpose@m1, Frame -> True, FrameTicks -> All, 
   DataReversed -> True, ImageSize -> 300], 
  Graphics[{FaceForm[None], EdgeForm[{Red, Thick}], 
    Rectangle[{x1, y1}, {x2, y2}]}]], 
 Show[ArrayPlot[boundingRectangle, Frame -> True, FrameTicks -> All, 
   DataReversed -> True, ImageSize -> 300], 
  Graphics[{FaceForm[None], EdgeForm[{Red, Thick}], 
    Rectangle[{x1, y1}, {x2, y2}]}, GridLines -> {{x1, x2}, {y1, y2}},
    PlotRange -> {{1, 100}, {1, 100}}, ImageSize -> 300]]}

enter image description here

list2 = Join @@ DeleteCases[Pick[t1~Partition~m, mask, 1], {}];

orange = Graphics[{FaceForm[Orange], Opacity[0.5], 
    Rectangle[Sequence @@ CoordinateBoundingBox[pts]]}];

red = Graphics[{FaceForm[Red], Opacity[0.5], 
    Polygon[{pts[[1]], pts[[3]], pts[[4]], pts[[2]]}]}];

Show[ListPlot[t1, PlotStyle -> Gray, AspectRatio -> 1, 
  PlotMarkers -> {\[FilledSmallCircle], Small}, Frame -> True], 
 Plot[{k x + b1, e1, e2, e3, e4, -(1/k) x + b2}, {x, 1, m}, 
  PlotRange -> {{1, m}, {1, m}}, 
  PlotStyle -> {{Dashed, Black}, Blue, Blue, Green, 
    Green, {Dashed, Black}}, Frame -> True], orange, red, 
 ListPlot[list2, PlotStyle -> Orange], 
 ListPlot[{{{X, Y}}, pts}, PlotStyle -> Red]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.