# Given a Table of Plots with some parameter, how would I mark each of the plots with that parameter

I've got a two variable function that I'm plotting against one axis for a few different values of a parameter

Clear[f, r]
f[r_] := 4 r /(1 - r)^2
i[r_, delta_] := 1/(1 + f[r] Sin[delta/2]^2)
Show[
Table[ Plot[i[r, delta], {delta, 0, 4 Pi},
PlotRange -> {0, 1}], {r, {0.1, 0.3, 0.6, 0.97}}]
]


This looks like

but I'd like to label each of the curves with the value of the parameter (r = 0.1, r = 0.3, ...). I can do this manually inserting labels with the Graphics controls, but figured there's got to be a better way.

-
It would certainly be nice if there were some way to use Tooltip for this sort of thing. – murray Nov 5 '12 at 23:16
Looks like there's a ToolTip like LabelingFunction for Charts, but I don't see a way to use those with Plot – Peeter Joot Nov 6 '12 at 14:32

I'd invert Table and Plot :

Needs["PlotLegends"]

Plot[Evaluate@Table[i[r, delta], {r, {0.1, 0.3, 0.6, 0.97}}], {delta, 0, 4 Pi},
PlotRange -> {0, 1}, PlotLegend -> {0.1, 0.3, 0.6, 0.97}, LegendPosition -> {0.95, 0.05}]


-
Can you explain what you are doing with Evaluate@ here? – Peeter Joot Oct 30 '12 at 21:44
@Peeter, Evaluate[] forces the first argument of Plot[] to be an explicit list of functions, which are then plotted with different colors. Execute Plot[Table[x^k, {k, 0, 2}], {x, 0, 1}] and Plot[Evaluate @ Table[x^k, {k, 0, 2}], {x, 0, 1}] to see the difference. – J. M. Oct 30 '12 at 22:41
@PeeterJoot Without the Evaluate Plot only sees one function and thus will not get the coloring and the legend right. Just try and look at the result. Just as an aside, there is also an undocumented option Evaluated->True which does the same thing, but is preferable as it also results in correct scoping. – sebhofer Oct 30 '12 at 22:41
Thanks. I didn't realize there's a Hold attribute associated with Plot, and found an explaination of that here: mathematica.stackexchange.com/questions/6894/… – Peeter Joot Oct 31 '12 at 1:06
Instead of PlotLegends, consider using the code in this excellent answer: mathematica.stackexchange.com/a/4028/745. It gives much much nicer legends. – Ajasja Oct 31 '12 at 9:57

I made a function that could be used for labeling plots interactively, adding labeled Bezier arrows, preserve your labels from session to session, and a few more goodies.

Some snapshots follow:

Calling code:

Clear[f, r]
f[r_] := 4 r/(1 - r)^2
i[r_, delta_] := 1/(1 + f[r] Sin[delta/2]^2)
s = Plot[Evaluate@Table[i[r, d], {r, {.1, .3, .6, .97}}], {d, 0, 4 Pi}, PlotRange -> {0, 1}];
lblPlot[s, {FontFamily -> "xkcd", 16}]


Working area:

Result

Edit:

Per @Rojo's request, added an option to preload old exported lbls like this:

lblPlot[s, {FontFamily -> "xkcd", 16}, optLblsO -> oldExportedLabels]


As the code is too long for posting it here, you can download it by executing:

NotebookPut@ImportString[Uncompress@FromCharacterCode@Flatten@ImageData[
Import@"http://i.stack.imgur.com/3pcrS.png","Byte"],"NB"]


Edit

ClearAll[lblPlot];
Options[lblPlot] = {maxArrowedLbls -> 5, maxNonArrowedLbls -> 5, optLblsO -> {}};
lblPlot[s_Graphics, myStyle_List: {FontFamily -> "Times", 16}, OptionsPattern[]] :=

(* Thanks to @WReach, @jVincent and @chris @Rojo for their useful help and code *)
(* Errors, bugs and bad coding due to belisarius*)

Module[{myLabel, copyToNewNB, exportLbls, printLbls, u, plotRsrv,
safeGuard = {"FeboAsoma"}, optLbls},

myLabel[{str_, {p1_, p2_, p3_}}] := {Thick, Arrow@BezierCurve[{p3, p2, p1}],
Inset[Style[str, myStyle], p3, Background -> White]};

myLabel[{str_, p1 : {_, _}}] := {Thick, Inset[Style[str, myStyle], p1, Background -> White]};

copyToNewNB[plot_, list_] := Module[{nb},  nb = NotebookCreate[];
NotebookWrite[nb, Cell[BoxData@ToBoxes@plot, "Output"]];
printLbls[nb, list]; ];

exportLbls[list_] := Module[{nb},  nb = NotebookCreate[]; printLbls[nb, list];];

printLbls[nb_, list_] := (NotebookWrite[nb,
Cell["Reserve the following expression in your Notebook to \
restore your Labels and Arrows the next time you need to include them \
in the Plot", "Subsection", CellMargins -> {{50, 50}, Inherited}]];
NotebookWrite[nb, Cell[BoxData@ToBoxes@Join[safeGuard, list, safeGuard], "Output"]];);

u = Array[(PlotRange /. Options[s, PlotRange])[[All, 1]] +
Flatten[Differences /@ (PlotRange /. Options[s, PlotRange])/4] # &, 3];

optLbls = OptionValue[optLblsO];

Panel@DynamicModule[{pts1 = {}, pts2 = {}, lbl1 = {}, lbl2 = {}, varRsrv = "Label Import Area"},

If[Head[optLbls] == List && Length@optLbls == 6 &&
optLbls[[1]] == optLbls[[-1]] == safeGuard[[1]],
{pts1 = optLbls[[2]], pts2 = optLbls[[3]], lbl1 = optLbls[[4]], lbl2 = optLbls[[5]]}];

Column[{Dynamic@ Show[
plotRsrv = Show[s, Epilog -> myLabel /@ Join @@
{MapIndexed[{lbl1[[#2[[1]]]], #1} &, Partition[pts1, 3]],
MapIndexed[{lbl2[[#2[[1]]]], #1} &, pts2]}, ImageSize -> 500],
Graphics[{
Dynamic@MapIndexed[ With[{i = #2[[1]]}, Locator[Dynamic[pts1[[i]]]]] &, pts1],
Dynamic@MapIndexed[ With[{i = #2[[1]]}, Locator[Dynamic[pts2[[i]]]]] &, pts2]},
PlotRange -> {{0, 1}, {0, 1}}]],

InputField[Dynamic@varRsrv, FieldSize -> 55, FieldHint -> "Label Import Area"],

Row[{
If[Length@pts1 < 3 OptionValue[maxArrowedLbls],
AppendTo[lbl1, "Arrow"]; pts1 = pts1~Join~(u)]],
If[Length@pts2 <
OptionValue[maxNonArrowedLbls], (AppendTo[lbl2, "Label"];
AppendTo[pts2, u[[2]]])]],
Button["Copy to new .nb", copyToNewNB[plotRsrv, {pts1, pts2, lbl1, lbl2}]],
Button["Export Labels", exportLbls[{pts1, pts2, lbl1, lbl2}]],
Button["Import Labels",
(*validate the labels set, then import *)
If[
Head[varRsrv] == List && Length@varRsrv == 6 &&
varRsrv[[1]] == varRsrv[[-1]] == safeGuard[[1]],
{pts1 = varRsrv[[2]], pts2 = varRsrv[[3]],
lbl1 = varRsrv[[4]], lbl2 = varRsrv[[5]]},
MessageDialog["You're trying to Import a label set not created by \"Export Labels\""],
MessageDialog[{Head[varRsrv], varRsrv[[1]] == varRsrv[[-1]] == safeGuard}]]
;]}],

Dynamic@Grid[Transpose[{
(*arrows*)
InputField[Dynamic[lbl1[[#]]], String],
Button["Delete" <> ToString@#,
(lbl1 = Drop[lbl1, {#, #}];
pts1 = Drop[pts1, {3 # - 2, 3 #}])]}] & /@
Range@(Length@pts1/3), Max[Length@lbl1, Length@lbl2], ""],
(*non- arrows*)
InputField[Dynamic[lbl2[[#]]], String],
Button["Delete" <> ToString@#,
(lbl2 = Drop[lbl2, {#, #}];
pts2 = Drop[pts2, {#}])]}] & /@ Range@(Length@pts2),
Max[Length@lbl1, Length@lbl2], ""]
}], ItemSize -> 30]}]]
]

Clear[f, r]
f[r_] := 4 r/(1 - r)^2
i[r_, delta_] := 1/(1 + f[r] Sin[delta/2]^2)
s = Plot[Evaluate@
Table[i[r, delta], {r, {0.1, 0.3, 0.6, 0.97}}], {delta, 0, 4 Pi},  PlotRange -> {0, 1}];
lblPlot[s, {FontFamily -> "xkcd", 16}]

-
Wow, that works really nicely. Great work! – Peeter Joot Nov 6 '12 at 14:45
@PeeterJoot I like it too :) – Dr. belisarius Nov 6 '12 at 15:30
@ belisarius - May I ask how you compressed the code into a PNG? It's very neat. – Chris Degnen Nov 7 '12 at 22:36
@ChrisDegnen Code here meta.mathematica.stackexchange.com/a/633/193 – Dr. belisarius Nov 7 '12 at 23:44
@ChrisDegnen A palette here meta.mathematica.stackexchange.com/questions/771/… – Dr. belisarius Nov 7 '12 at 23:45

You can also use Epilog to place the labels on the lines.

Example:

Row[Plot[Evaluate@
Table[i[r, delta], {r, {0.1, 0.3, 0.6, 0.97}}], {delta, 0, 4 Pi},
PlotRange -> {Automatic, {0, 1}},
PlotStyle -> (Directive[Thick, #] & /@ {Red, Green, Blue, Orange}),
PlotRangePadding -> .05, Frame -> True, ImageSize -> 400,
Epilog -> {Table[(Style[Text[r, {#, i[r, #]}], 12,
Background -> White] &) /@ (#),
{r, {0.1, 0.3, 0.6, 0.97}}]}] & /@
{{Pi}, {3 Pi}, {Pi/2, 3 Pi/2, 5 Pi/2, 7 Pi/2}}, Spacer[5]]


-
Excellent. That's much more like what I was thinking. If I try modifying the text to Text[ "R = " r, ... then strangely it displays as "0.1 R =", "0.3 R =", ... ? Is there a way to concatonate multiple text objects at the location specified by one? – Peeter Joot Oct 31 '12 at 13:14
@Peeter, try Text[Row[{"R = ", r}], {#, i[r, #]}]. – kglr Oct 31 '12 at 15:19
.. or Text["r = " <> ToString[r], {#, i[r, #]}]. – kglr Oct 31 '12 at 15:32
StringForm[]` would also be convenient to use here... – J. M. Nov 7 '12 at 5:23