3
$\begingroup$

How can I plot these kinds of figures,

with Mathematica?

The data is:

C1:{0.862076744436836,-0.0710018127126162}
C2:{0.180643829948566,-0.0755912807586123}
C3:{-0.0902639293512224,-0.101494749952635}
C4:{-0.02510200130903,0.414697606843563}
C5:{-0.0868408989788668,0.0360895100200192}
C6:{-0.00403033602621659,-0.00453504754499428}
C7:{-0.0200482239439571,0.00728005293229898}
C8:{-0.0280502818828574,0.0150931092712761}
C9:{-0.0291530751595138,-0.118717184195124}
C10:{-0.166021924674956,-0.452910499266306}
C11:{-0.0338820323215196,-0.0924307124136004}
C12:{0.349307747775784,-0.108411030616226}
C13:{-0.0147063225289707,0.0252518940945218}
C14:{-0.14240351120446,-0.135546568196238}
C15:{-0.00993959039911283,0.0174501321870128}
C16:{-0.0106671860191681,0.0938542340696139}
C17:{0.0740621629262059,-0.0309916803974033}
C18:{-0.0311146572435248,0.0382612613500809}
C19:{-0.146592168407794,-0.406223400984143}
C20:{-0.0233970156016837,-0.0151959116059057}
C21:{-0.0450897313645501,0.0139856262500525}
C22:{-0.0150375405433944,0.10002398156993}
C23:{-0.0602789617089736,0.599875560203239}

A1:{0.0560126266664577,-0.00580529824387133}
A2:{-0.00248292950568901,0.028469782782429}
A3:{-0.0162320058025636,-0.0246052854984663}
A4:{-0.0153031168095184,0.00585110492371706}
A5:{-0.0219945745486867,-0.00391030396380843}
DMG:{0.483471133048858,-0.251186944346878}

PS: * The mentioned data are brought here just for completeness. I think one or two points will be enough. * The dashed lines are perpendicular to the red line.

$\endgroup$
0

2 Answers 2

6
$\begingroup$

You can get very close to your figure with fine grained control over Graphics: If you post your data, I can update it if necessary, otherwise I've used random data below:

(* some fake data *)
SeedRandom[1];
cdata = RandomVariate[NormalDistribution[0, .1], {23, 2}];
adata = RandomVariate[NormalDistribution[0, .2], {5, 2}];

redline = Line[{{0.483471, -0.25119}, {-0.48347, 0.251187}}];
clines = Line[{#, {0, 0}}] & /@ cdata;
rnfline = RegionNearest[redline];
alines = Line[{#, rnfline[#]}] & /@ adata;

cmarker[{px_, py_}, width_, label_] := {
  FaceForm[Green], 
  EdgeForm[Black], 
  Rectangle[{px, py} - width*{1/2, 1/2}, {px, py} + width*{1/2, 1/2}],
  Black, Text[label, {px + width*1.2, py + width*1.1}]}

amarker[{px_, py_}, width_, label_] := {
  FaceForm[Blue], 
  EdgeForm[Black],
  Disk[{px, py}, width/2], Black, 
  Text[label, {px + width*1.2, py + width*1.1}]}

cpts = MapIndexed[cmarker[#1, .01, "C" <> ToString[First@#2]] &, cdata];
apts = MapIndexed[amarker[#1, .02, "A" <> ToString[First@#2]] &, adata];

Graphics[{
  {Red, Thick, redline},
  {Gray, clines},
  {Gray, Dashed, alines},
  cpts, apts
}, Axes -> True, Ticks -> None]

enter image description here


With the updated data the points cluster very tightly around zero which clutters the plot a bit. The 'A' points don't look like your picture. In fact they're very close to the center. So I've provided a way to zoom into the center of the plot:

(* replace the data in the above code *) 
cdata = {{0.862076744436836, -0.0710018127126162},{0.180643829948566, -0.0755912807586123}, {-0.0902639293512224,-0.101494749952635}, {-0.02510200130903,0.414697606843563}, {-0.0868408989788668,0.0360895100200192}, {-0.00403033602621659,-0.00453504754499428}, {-0.0200482239439571,0.00728005293229898}, {-0.0280502818828574,0.0150931092712761}, {-0.0291530751595138, -0.118717184195124},{-0.166021924674956, -0.452910499266306}, {-0.0338820323215196,-0.0924307124136004}, {0.349307747775784, -0.108411030616226},{-0.0147063225289707,0.0252518940945218}, {-0.14240351120446, -0.135546568196238},{-0.00993959039911283, 0.0174501321870128}, {-0.0106671860191681,0.0938542340696139}, {0.0740621629262059, -0.0309916803974033},{-0.0311146572435248,0.0382612613500809}, {-0.146592168407794, -0.406223400984143},{-0.0233970156016837, -0.0151959116059057}, {-0.0450897313645501,0.0139856262500525}, {-0.0150375405433944,0.10002398156993}, {-0.0602789617089736, 0.599875560203239}};
adata = {{0.0560126266664577, -0.00580529824387133},{-0.00248292950568901,0.028469782782429}, {-0.0162320058025636, -0.0246052854984663},{-0.0153031168095184,0.00585110492371706}, {-0.0219945745486867,-0.00391030396380843}};

...

(* replace the Graphics in the above code with this: *)
Manipulate[
 cpts = MapIndexed[cmarker[#1, 0.03/z, "C" <> ToString[First@#2]] &, cdata];
 apts = MapIndexed[amarker[#1, 0.06/z, "A" <> ToString[First@#2]] &, adata];
 Graphics[{{Red, Thick, redline}, {Gray, clines}, {Gray, Dashed,  alines}, cpts, apts},
  Axes -> True, Ticks -> None, 
  PlotRange -> {{-2/z, 2/z}, {-1/z, 1/z}}, AspectRatio -> 1/2, 
  ImageSize -> Large]
 , {z, 1, 50}]

enter image description here

$\endgroup$
5
  • $\begingroup$ Dear friend it is exactly what I mean. By the way, how can I upload the Excel file here? Moreover, how to zoom the center part and bring it inside the main plot as another part? Thank you. $\endgroup$ Jul 29, 2020 at 16:43
  • 1
    $\begingroup$ You cannot upload the excel file, but you could copy and paste the data into the question. If you have another plot you want to superimpose this plot upon, then you could combine it with Show, e.g Show[Graphics[...], anotherplot]. $\endgroup$
    – flinty
    Jul 29, 2020 at 16:46
  • $\begingroup$ The figures (data) are updated now. $\endgroup$ Jul 29, 2020 at 17:07
  • $\begingroup$ If you just need a fixed plot, you can zoom it by specifying a PlotRange. $\endgroup$
    – flinty
    Jul 29, 2020 at 17:27
  • $\begingroup$ Actually, I need a hard copy so, a fixed plot will be OK. $\endgroup$ Jul 29, 2020 at 17:55
5
$\begingroup$
Clear["Global`*"]

Format[a[n_]] := "A" <> ToString[n]
Format[c[n_]] := "C" <> ToString[n]

SeedRandom[1234];
dataA = RandomReal[{-1, 1}, {4, 2}];
dataC = RandomReal[{-1, 1}, {5, 2}];
dataRed = {{0.48, -0.25}, {-0.48, 0.25}};

ListPlot[{
  Labeled[#[[2]], a[#[[1]]]] & /@
   Transpose[{Range[Length[dataA]], dataA}],
  Labeled[#[[2]], c[#[[1]]]] & /@
   Transpose[{Range[Length[dataC]], dataC}]},
 PlotRange -> All,
 PlotRangePadding -> Scaled[.075],
 PlotMarkers -> {●, ■},
 PlotStyle -> {Blue, Green},
 Ticks -> None,
 Prolog -> {
   Dashed,
   Line[{#, RegionNearest[
        InfiniteLine[dataRed], #]}] & /@ dataA,
   Gray, Dashing[{}], Line[{{0, 0}, #}] & /@ dataC,
   Red, InfiniteLine[dataRed]}]

enter image description here

$\endgroup$

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.