1
$\begingroup$

I found this illustration here,I would like if someone could recreate it using Manipulate to control the rotation of the line.

enter image description here

$\endgroup$
5
  • $\begingroup$ It is far beyond my skills to attack such a problem ^^..but i will try to help if a good approach is provided. $\endgroup$
    – Youphyso
    Aug 7 '17 at 19:04
  • $\begingroup$ @Youphyso Did you notice the availability of the Matlab code? $\endgroup$
    – Alan
    Aug 7 '17 at 19:21
  • $\begingroup$ This site is not to be used for questions of the sort: "Here's something really cool. I haven't done anything on it, but would someone else please do all the programming for me?" $\endgroup$ Aug 7 '17 at 19:29
  • $\begingroup$ @Alan yes I noticed the availability of the matlab code,one extra reason for seeking a mathematica one ^^. $\endgroup$
    – Youphyso
    Sep 7 '17 at 0:12
  • $\begingroup$ @ David G. Stork Hi,I am a beginner,I found this cool illustration on the net,I said this forum is the home for this kind of problems.If i were capable of doing it,I've shared it with you without hesitation.I have no personal interest in doing this,so this is not for me,I thought this will be beneficial in many ways:First,It is a programming challenge;actually a good one.Second,a good mathematical illustration to understand the notion of regression visually.Finally,This will enrich this amazing forum with versatile bunch of tricks and problems. $\endgroup$
    – Youphyso
    Sep 7 '17 at 15:00
6
$\begingroup$

The red dots are projections of the blue dots on the rotated line. RegionNearest is a function in Mathematica that computes this projection. Here I'll show how it can be used to recreate the animation (using Manipulate, as specified in the question.)

Let's start with the blue points, which I take to be random deviations from a straight line:

n = 40;
pts = With[
   {r = RandomReal[{1, 4}, n]},
   Transpose[{r, r + RandomReal[{-1, 1}, n]}]
   ];
Plot[
 x, {x, 0, 5},
 PlotStyle -> Red,
 Epilog -> {Blue, PointSize[Medium], Point[pts]}
 ]

Mathematica graphics

I take the rotating line segment to have its center at $(2.5, 2.5)$. The endpoints of the segment are given by $(2.5, 2.5) \pm \sqrt{1.5^2+1.5^2}(\cos(\theta),\sin(\theta))$. The square root is just Pythagoras theorem applied to the length of half the line segment.

Doing this, we get

bg[th_] := With[{c = {2.5, 2.5}, len = Sqrt[1.5^2 + 1.5^2]},
  Show[
   Plot[x, {x, 0, 1}, PlotStyle -> Red],
   Plot[x, {x, 4, 5}, PlotStyle -> Red],
   Graphics[{
     Black,
     Line[{{c + len {Cos[th], Sin[th]}, c - len {Cos[th], Sin[th]}}}]
     }],
   PlotRange -> {{0, 5}, {0, 5}},
   AspectRatio -> 1
   ]
  ]

Manipulate[bg[th], {th, 0, 2 Pi}]

Rotating line

I now use RegionNearest on each point and plot the line between the point and its RegionNearest projection.

rnf[th_] := With[{c = {2.5, 2.5}, len = Sqrt[1.5^2 + 1.5^2]},
  RegionNearest[
   Line[{{c + len {Cos[th], Sin[th]}, c - len {Cos[th], Sin[th]}}}]
   ]]

lines[th_] := Module[{f = rnf[th], proj},
  proj = f /@ pts;
  Graphics[{
    Red, PointSize[Medium],
    Line /@ Transpose[{pts, proj}],
    Point[proj]
    }]]

bg[th_] := With[{c = {2.5, 2.5}, len = Sqrt[1.5^2 + 1.5^2]},
  Show[
   Plot[x, {x, 0, 1}, PlotStyle -> Red],
   Plot[x, {x, 4, 5}, PlotStyle -> Red],
   Graphics[{
     Black,
     Line[{{c + len {Cos[th], Sin[th]}, 
        c - len {Cos[th], Sin[th]}}}],
     Blue, PointSize[Medium], Point[pts]
     }],
   lines[th],
   PlotRange -> {{0, 5}, {0, 5}},
   AspectRatio -> 1
   ]
  ]

Manipulate[bg[th], {th, 0, 2 Pi}]

Rotating line with projections.

$\endgroup$
1
  • $\begingroup$ @ C.E. Thank you very much for this huge effort,I will try to study your code in detail. $\endgroup$
    – Youphyso
    Sep 7 '17 at 15:02

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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