1
$\begingroup$

I want to build on an already developed Code given in:

https://mathematica.stackexchange.com/a/183401/60365

For easy implementation, I applied it to a sample of 10 observations. Given:

data = {{525.48, 37.02}, {525.2, 36.86}, {528.44, 36.995}, 
        {533.27, 36.795}, {534.31, 36.59}, {536.26, 36.53}, 
        {535.66, 36.52}, {534.24, 36.515}, {534.71, 36.5}, 
        {535.41, 36}};

dataLabels = {"aa", "bb", "cc", "dd", "ee", "gg", "hh", "kk", "nn", "mm"};

Implement:

f[p1_, p2_] := Module[{x0, y0, q, q1, q2, q3, q4, xLeft, xRight, yLower, yUpper}, (*Determine the point that will give those two proportions*)
x0 = Quantile[data[[All, 1]], p1 + p2];
y0 = Quantile[Select[data, #[[1]] <= x0 &][[All, 2]], p1/(p1 + p2)];

(*Assign the points to each quadrant*)
q1 = Select[data, #[[1]] <= x0 && #[[2]] <= y0 &];
q2 = Select[data, #[[1]] <= x0 && #[[2]] > y0 &];
q3 = Select[data, #[[1]] > x0 && #[[2]] <= y0 &];
q4 = Select[data, #[[1]] > x0 && #[[2]] > y0 &];

(*Find proportions in each quadrant*)
proportions = N[Length[#] & /@ {q1, q2, q3, q4}/Length[data]];

(*Determine locations on the plot for placing the proportions*)
xLeft = (Max[Join[q1[[All, 1]], q2[[All, 1]]]] + 
  Min[Join[q1[[All, 1]], q2[[All, 1]]]])/2;
xRight = (Max[Join[q3[[All, 1]], q4[[All, 1]]]] + 
  Min[Join[q3[[All, 1]], q4[[All, 1]]]])/2;
yLower = (Max[Join[q1[[All, 2]], q3[[All, 2]]]] + 
  Min[Join[q1[[All, 2]], q3[[All, 2]]]])/2;
yUpper = (Max[Join[q2[[All, 2]], q4[[All, 2]]]] + 
  Min[Join[q2[[All, 2]], q4[[All, 2]]]])/2;

(*Show results*)
q = Select[{q1, q2, q3, q4}, # != {} &];
Show[ListPlot[q, ImageSize -> Large, 
Epilog -> {Inset[
   Style[ToString[NumberForm[proportions[[1]], {10, 3}]], Bold, 
    36], {xLeft, yLower}], 
  Inset[Style[ToString[NumberForm[proportions[[2]], {10, 3}]], 
    Bold, 36], {xLeft, yUpper}], 
  Inset[Style[ToString[NumberForm[proportions[[3]], {10, 3}]], 
    Bold, 36], {xRight, yLower}], 
  Inset[Style[ToString[NumberForm[proportions[[4]], {10, 3}]], 
    Bold, 36], {xRight, yUpper}]}], 
 ListPlot[{{{x0, Min[data[[All, 2]]]}, {x0, 
   Max[data[[All, 2]]]}}, {{Min[data[[All, 1]]], 
   y0}, {Max[data[[All, 1]]], y0}}}, Joined -> True, 
 PlotRange -> All, PlotStyle -> Black]]]

The above Code works as expected. I wanted to add two more features to the existing Code:

  1. How can I add a linear or nonlinear regression line on top of the 4-quadrant figure?
  2. How can I label each observation on the ListPlot using Tooltip with dataLabels?

Thank you.

CODE REVISED

ClearAll[typeTFP, measureTFP, proportions, poly, dataLabels];
typeTFP = {data, datagr1, datagr};
measureTFP = {"TFP Distance", "TFP Growth   Rate Distance", "TFP Growth Rate Distance DWA"};

Manipulate[
  Module[
   {x0, y0, q, q1, q2, q3, q4, xLeft, xRight, yLower, yUpper},

(*Determine the point that will give selected two proportions*)
 x0 = Quantile[typeTFP[[type]][factor, initYear][[All, 1]], 
 p1 + p2];   (*p1 denotes the proportion for Q1, and p2, the proportion for Q2*)
 y0 = Quantile[
  Select[typeTFP[[type]][factor, initYear], #[[1]] <= x0 &][[All,2]], p1/(p1 + p2)];

(*Assign the points to each quadrant*)
 q1 = Select[
   typeTFP[[type]][factor, initYear], #[[1]] <= x0 && #[[2]] <= y0 &];
 q2 = Select[
   typeTFP[[type]][factor, initYear], #[[1]] <= x0 && #[[2]] > y0 &];
 q3 = Select[typeTFP[[type]][factor, initYear], #[[1]] > x0 && #[[2]] <= y0 &];
 q4 = Select[
   typeTFP[[type]][factor, initYear], #[[1]] > x0 && #[[2]] > y0 &];

 (*Find proportions in each quadrant*)
 proportions = 
   N[Length[#] & /@ {q1, q2, q3, q4}/
 Length[typeTFP[[type]][factor, initYear]]];

 (*Determine locations on the plot for placing the proportions*)
 xLeft = (Max[Join[q1[[All, 1]], q2[[All, 1]]]] + Min[Join[q1[[All, 1]], q2[[All, 1]]]])/2;  (* Exo.factor left of the vertical line on X-axis *)
 xRight = (Max[Join[q3[[All, 1]], q4[[All, 1]]]] + Min[Join[q3[[All, 1]], q4[[All, 1]]]])/2;   (* Exo. factor right of the vertical line on X-axis *)
 yLower = (Max[Join[q1[[All, 2]], q3[[All, 2]]]] + Min[Join[q1[[All, 2]], q3[[All, 2]]]])/2;  (*TFPdist below the horizontal line on Y-axis *)
 yUpper = (Max[Join[q2[[All, 2]], q4[[All, 2]]]] + Min[Join[q2[[All, 2]], q4[[All, 2]]]])/2;  (*TFPdist above the horizontal line on Y-axis *)

 (*Show results*)
 q = Select[{q1, q2, q3, q4}, # != {} &];

 poly[x] := 
   With[{n = 2}, NonlinearModelFit[typeTFP[[type]][factor, initYear], Total@Table[a[k] x^k, {k, 0, n}], a /@ Range[0, n], x] //Normal];
 dataLabels[factor, initYear] = 
  StringTake[dataCountry[factor,initYear]   // Flatten, 3];

 Show[ListPlot[q /. {x_?NumericQ, y_?NumericQ} :>Callout[{x, y}, Style[dataLabels[factor, initYear][[Position[typeTFP[[type]][factor, initYear], {x, y}][[1,1]]]], 10]],
 ImageSize -> Large, Frame -> {{True, False}, {True, False}}, FrameLabel -> (Style[#, 12, Bold] & /@ {vars[[factor]], measureTFP[[type]]}), Prolog -> {(*Move lines and text to Prolog so they are not on top of the data*) 
Black, Text[Style[ToString[NumberForm[proportions[[1]], {10, 2}]], 
Bold, 18], {xLeft, yLower}],     Text[Style[ToString[NumberForm[proportions[[2]], {10, 2}]], 
Bold,16], {xLeft, yUpper}],    Text[Style[ToString[NumberForm[proportions[[3]], {10, 2}]], 
Bold, 16], {xRight, yLower}],     Text[Style[ToString[NumberForm[proportions[[4]], {10, 2}]], 
Bold, 16], {xRight, yUpper}],      Line[{{x0, Min[typeTFP[[type]][factor, initYear][[All, 2]]]}, {x0, Max[typeTFP[[type]][factor, initYear][[All, 2]]]}}], 
Line[{{Min[typeTFP[[type]][factor, initYear][[All, 1]]], y0}, {Max[typeTFP[[type]][factor, initYear][[All, 1]]], y0}}]}], 
Plot[poly[xp], {xp,       Min[typeTFP[[type]][factor, initYear][[All, 1]]], Max[typeTFP[[type]][factor, initYear][[All, 1]]]}]]],

Spacer[40],
Delimiter, Style["Parameters for TFP Distance Network", Bold, Medium],
{{initYear, 1, "Choose an initial period for TFP: "},   Thread[Range[Length[years] - 1] ->Take[years, 10]], ControlType -> PopupMenu}, 
{{type, 1, "Choose the type of TFP measure: "}, Thread[Range[Length[measureTFP]] -> measureTFP], ControlType -> PopupMenu},
{{factor, 14, "Choose an exogenous factor:"},  Thread[Range[Length[vars]] -> vars], ControlType -> PopupMenu}, 
{{p1, 0.20, "Choose a proportion for TFP_Lower: "}, 0, 1, .01, Appearance -> "Labeled"},
{{p2, 0.35, "Choose a proportion for TFP_Upper: "}, 0, 1, .01, Appearance -> "Labeled"},
 FrameLabel -> {{"", ""}, {"", Style["Four Quadrants: TFP Measure versus Exogenous Factor", Larger, Bold, Black]}}

]

$\endgroup$

2 Answers 2

1
$\begingroup$
Clear["Global`*"]

data = {{525.48, 37.02}, {525.2, 36.86}, {528.44, 36.995}, {533.27, 
    36.795}, {534.31, 36.59}, {536.26, 36.53}, {535.66, 36.52}, {534.24, 
    36.515}, {534.71, 36.5}, {535.41, 36}};

For a quadratic fit

poly[x_] = With[{n = 2}, NonlinearModelFit[data,
    Total@Table[a[k] x^k, {k, 0, n}],
    a /@ Range[0, n], x] // Normal]

(* -2233.98 + 8.61496 x - 0.00817032 x^2 *)

dataLabels = {"aa", "bb", "cc", "dd", "ee", "gg", "hh", "kk", "nn", "mm"};

Modified Module

f[p1_, p2_] := 
 Module[{x0, y0, q, q1, q2, q3, q4, xLeft, xRight, yLower, yUpper},
  (*Determine the point that will give those two proportions*)
  x0 = Quantile[data[[All, 1]], p1 + p2];
  y0 = Quantile[Select[data, #[[1]] <= x0 &][[All, 2]], p1/(p1 + p2)];
  (*Assign the points to each quadrant*)
  q1 = Select[data, #[[1]] <= x0 && #[[2]] <= y0 &];
  q2 = Select[data, #[[1]] <= x0 && #[[2]] > y0 &];
  q3 = Select[data, #[[1]] > x0 && #[[2]] <= y0 &];
  q4 = Select[data, #[[1]] > x0 && #[[2]] > y0 &];
  (*Find proportions in each quadrant*)
  proportions =
   N[Length[#] & /@ {q1, q2, q3, q4}/Length[data]];
  (*Determine locations on the plot for placing the proportions*)
  xLeft = (Max[Join[q1[[All, 1]], q2[[All, 1]]]] +
      Min[Join[q1[[All, 1]], q2[[All, 1]]]])/2;
  xRight = (Max[Join[q3[[All, 1]], q4[[All, 1]]]] +
      Min[Join[q3[[All, 1]], q4[[All, 1]]]])/2;
  yLower = (Max[Join[q1[[All, 2]], q3[[All, 2]]]] +
      Min[Join[q1[[All, 2]], q3[[All, 2]]]])/2;
  yUpper = (Max[Join[q2[[All, 2]], q4[[All, 2]]]] +
      Min[Join[q2[[All, 2]], q4[[All, 2]]]])/2;
  (*Show results*)
  q = Select[{q1, q2, q3, q4}, # != {} &];
  Show[
   ListPlot[q /. {x_?NumericQ, y_?NumericQ} :>
      Tooltip[{x, y}, Style[dataLabels[[Position[data, {x, y}][[1, 1]]]], 24]],
    ImageSize -> Large,
    Prolog -> {
      (* Move lines and text to Prolog so they are not on top of the data *)
           Gray,
      Text[
       Style[ToString[NumberForm[proportions[[1]], {10, 3}]], Bold, 36],
       {xLeft, yLower}],
      Text[
       Style[ToString[NumberForm[proportions[[2]], {10, 3}]], Bold, 36],
       {xLeft, yUpper}],
      Text[
       Style[ToString[NumberForm[proportions[[3]], {10, 3}]], Bold, 36],
       {xRight, yLower}],
      Text[
       Style[ToString[NumberForm[proportions[[4]], {10, 3}]], Bold, 36],
       {xRight, yUpper}],
      Line[{{x0, Min[data[[All, 2]]]},
        {x0, Max[data[[All, 2]]]}}],
      Line[{{Min[data[[All, 1]]], y0},
        {Max[data[[All, 1]]], y0}}]}],
   Plot[poly[xp], {xp, Min[data[[All, 1]]], Max[data[[All, 1]]]}]]]

Plots

f[0.2, 0.3]

enter image description here

$\endgroup$
9
  • $\begingroup$ It is very nice. Is it possible to use Tooltip to give a label for each observation? Currently, when I move the cursor on top of the observation point, I see the label attached to it. I would like to see the labels permanently written next to the plots. Thanks. $\endgroup$ Commented Sep 19, 2020 at 17:17
  • 1
    $\begingroup$ Then you don't want a Tooltip. Change Tooltip to Callout. $\endgroup$
    – Bob Hanlon
    Commented Sep 19, 2020 at 17:46
  • $\begingroup$ Yes. Sorry for my mistake in naming. Thanks for the code. It works as I wanted. $\endgroup$ Commented Sep 19, 2020 at 18:03
  • $\begingroup$ In plotting nonlinear regression line, I face a problem. In the example I gave above, data is given outside of Module but in my real case, data is generated within Module using Manipulate. Even if I give numeric max and min values for xp in Plot[poly[xp]...] I cannot see the regression line. The only difference between my example case and the actual case is the location of data. Do you think that it is the reason for not being able to see the regression line? $\endgroup$ Commented Sep 19, 2020 at 20:42
  • $\begingroup$ Did you move the definition of poly inside the Module? Without seeing your code I can only guess. Suggest that you post a new question with the minimum amount of data and code necessary to demonstrate the problem. $\endgroup$
    – Bob Hanlon
    Commented Sep 20, 2020 at 0:17
0
$\begingroup$

This is just a revision of @Bob Hanlon's code above with two adjustments: the use of Callout instead of Tooltip and the use of Manipulate instead of Module. One can then play with different polynomial degrees denoted by n as a control.

Clear["Global`*"];
SeedRandom[11];
data = RandomReal[{0, 300}, {40, 2}];
Manipulate[

(*Determine the point that will give those two proportions*)
x0 = Quantile[data[[All, 1]], p1 + p2];
y0 = Quantile[Select[data, #[[1]] <= x0 &][[All, 2]], p1/(p1 + p2)];

(*Assign the points to each quadrant*)
q1 = Select[data, #[[1]] <= x0 && #[[2]] <= y0 &];
q2 = Select[data, #[[1]] <= x0 && #[[2]] > y0 &];
q3 = Select[data, #[[1]] > x0 && #[[2]] <= y0 &];
q4 = Select[data, #[[1]] > x0 && #[[2]] > y0 &];

(*Find proportions in each quadrant*)
proportions = N[Length[#] & /@ {q1, q2, q3,q4}/Length[data]];

(*Determine locations on the plot for placing the proportions*)
xLeft = (Max[Join[q1[[All, 1]], q2[[All, 1]]]] +     
   Min[Join[q1[[All, 1]], q2[[All, 1]]]])/2;
xRight = (Max[Join[q3[[All, 1]], q4[[All, 1]]]] + 
   Min[Join[q3[[All, 1]], q4[[All, 1]]]])/2;
yLower = (Max[Join[q1[[All, 2]], q3[[All, 2]]]] + 
   Min[Join[q1[[All, 2]], q3[[All, 2]]]])/2;
yUpper = (Max[Join[q2[[All, 2]], q4[[All, 2]]]] + 
   Min[Join[q2[[All, 2]], q4[[All, 2]]]])/2;

(*Show results*)
q = Select[{q1, q2, q3, q4}, # != {} &];

poly[x_] = 
NonlinearModelFit[data, Total@Table[a[k] x^k, {k, 0, n}], a /@ Range[0, n], x] // Normal; 
dataLabels = {"aa", "bb", "cc", "dd", "ee", "gg", "hh", "kk", "nn", "mm", "aa1", "bb1", "cc1", "dd1", "ee1", "gg1", "hh1", "kk1", "nn1", "mm1", "aa2", bb2", "cc2", "dd2", "ee2", "gg2", "hh2", "kk2", "nn2", mm2", "aa3", "bb3", "cc3", "dd3", "ee3", "gg3", "hh3", "kk3", "nn3", "mm3"};

 Show[
  ListPlot[
   q /. {x_?NumericQ, y_?NumericQ} :>Callout[{x, y}, Style[dataLabels[[Position[data, {x, y}][[1, 1]]]], 12]], ImageSize -> Large, Frame -> {{True, False}, {True, False}}, FrameLabel -> (Style[#, 12, Bold] & /@ {"Fertility", "TFP measure"}), Prolog -> {(*Move lines and text to Prolog so they are not on top of the data*)
Black, 
 Text[Style[ToString[NumberForm[proportions[[1]], {10, 3}]], Bold,16], {xLeft, yLower}],
 Text[Style[ToString[NumberForm[proportions[[2]], {10, 3}]], Bold, 16], {xLeft, yUpper}],
 Text[Style[ToString[NumberForm[proportions[[3]], {10, 3}]], Bold,16], {xRight, yLower}],
 Text[Style[ToString[NumberForm[proportions[[4]], {10, 3}]], Bold,16], {xRight, yUpper}],
 Line[{{x0, Min[data[[All, 2]]]}, {x0, Max[data[[All, 2]]]}}], 
 Line[{{Min[data[[All, 1]]], y0}, {Max[data[[All, 1]]], y0}}]}], Plot[poly[xp], {xp, Min[data[[All, 1]]], Max[data[[All, 1]]]}]],
{{n, 2, "Choose a polynomial degree: "}, 1, 10, 1, 
  Appearance -> "Labeled"},
{{p1, 0.20, "Choose a Low-Low proportion: "}, 0, 
  1, .01, Appearance -> "Labeled"},
{{p2, 0.35, "Choose a Low-Up proportion: "}, 0, 1, 
  .01, Appearance -> "Labeled"},
 FrameLabel -> {{"", ""}, {"",Style["Four Quadrants: TFP Measure versus Fertility", Larger,Bold, Black]}}]

Here is the final output: 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.