How to use Manipulate to place `Tooltip` for each data point on a ListPlot with a varying Linear Regression line
Mathematica Asked on December 13, 2020
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:
- How can I add a linear or nonlinear regression line on top of the 4-quadrant figure?
- How can I label each observation on the
ListPlotusingTooltipwithdataLabels?
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]}}
]
2 Answers
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]
Correct answer by Bob Hanlon on December 13, 2020
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:
Answered by Tugrul Temel on December 13, 2020
Add your own answers!
Ask a Question
Get help from others!
Recent Questions
- How can I transform graph image into a tikzpicture LaTeX code?
- How Do I Get The Ifruit App Off Of Gta 5 / Grand Theft Auto 5
- Iv’e designed a space elevator using a series of lasers. do you know anybody i could submit the designs too that could manufacture the concept and put it to use
- Need help finding a book. Female OP protagonist, magic
- Why is the WWF pending games (“Your turn”) area replaced w/ a column of “Bonus & Reward”gift boxes?
Recent Answers
- Peter Machado on Why fry rice before boiling?
- Lex on Does Google Analytics track 404 page responses as valid page views?
- Joshua Engel on Why fry rice before boiling?
- haakon.io on Why fry rice before boiling?
- Jon Church on Why fry rice before boiling?