How can I mark each of several plots with a parameter that identifies it?

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. Commented Nov 5, 2012 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 Commented Nov 6, 2012 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? Commented Oct 30, 2012 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. Commented Oct 30, 2012 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. Commented Oct 30, 2012 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/… Commented Oct 31, 2012 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. Commented Oct 31, 2012 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@"https://i.sstatic.net/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! Commented Nov 6, 2012 at 14:45
• @PeeterJoot I like it too :) Commented Nov 6, 2012 at 15:30
• @ belisarius - May I ask how you compressed the code into a PNG? It's very neat. Commented Nov 7, 2012 at 22:36
• @ChrisDegnen Code here meta.mathematica.stackexchange.com/a/633/193 Commented Nov 7, 2012 at 23:44
• @ChrisDegnen A palette here meta.mathematica.stackexchange.com/questions/771/… Commented Nov 7, 2012 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? Commented Oct 31, 2012 at 13:14
• @Peeter, try Text[Row[{"R = ", r}], {#, i[r, #]}].
– kglr
Commented Oct 31, 2012 at 15:19
• .. or Text["r = " <> ToString[r], {#, i[r, #]}].
– kglr
Commented Oct 31, 2012 at 15:32
• StringForm[] would also be convenient to use here... Commented Nov 7, 2012 at 5:23

Using PlotLabels makes it straightforward:

f[r_] := 4 r/(1 - r)^2
i[r_, delta_] := 1/(1 + f[r] Sin[delta/2]^2)
place = {Scaled[r], After};
Show[Table[
Plot[i[r, delta], {delta, 0, 4 Pi}, PlotRange -> {0, 1},
Frame -> True,
PlotLabels -> Placed[{ToString[r]}, place]], {r, {0.1,
0.3, 0.6, 0.97}}]]


One can use different placements, i.e. different location specifications instead of place; I chose Scaled[r] because for this particular plot it works fine and After` because in my opinion it looks best.

• My question was old (Mathematica 8 days). This new better labelling option was mentioned in a comment referring to: mathematica.stackexchange.com/questions/4025/… Also note that Mathematica11 appears to have further refined its Labelling methods, but I haven't purchased the upgrade to try that out. Commented Sep 1, 2016 at 21:51
• I get it all, I just stumbled upon this question acidentally, so to speak, and thought it might be useful for future users to point them toward some update. Commented Sep 1, 2016 at 22:12