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

Question

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

Plot of etalon interference

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 05 '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 06 '12 at 14:32

Dr. belisarius · Answer 1 · 2014-08-25T03:38:41.333

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:

Mathematica graphics

Result

Mathematica graphics

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.stack.imgur.com/3pcrS.png","Byte"],"NB"]

Edit

Code added:

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[{
        Button["Add Labeled Arrow", 
         If[Length@pts1 < 3 OptionValue[maxArrowedLbls], 
          AppendTo[lbl1, "Arrow"]; pts1 = pts1~Join~(u)]],
        Button["Add Label", 
         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*)
          {""}~Join~PadRight[Row[{#,
                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*)
          {""}~Join~PadRight[Row[{#,
                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}]

@ belisarius - May I ask how you compressed the code into a PNG? It's very neat. — Chris Degnen, Nov 07 '12 at 22:36
@ChrisDegnen Code here http://meta.mathematica.stackexchange.com/a/633/193 — Dr. belisarius, Nov 07 '12 at 23:44
@ChrisDegnen A palette here http://meta.mathematica.stackexchange.com/questions/771/for-sale-three-potentially-useful-palettes — Dr. belisarius, Nov 07 '12 at 23:45
@ Dr. belisarius - your answer is quite useful and helps also solving my problem posted here http://mathematica.stackexchange.com/questions/132268/annotating-plots-by-adding-labels-with-arrows-connecting-them-to-data-points/132327#132327But I do have other questions: 1) how do you export the plot with the arrows to a static format that can be included in other documents and shared? and 2) how can I define the size of the image? ImageSize seems not to work. thanks — Luigi, Nov 30 '16 at 21:49

score 15 · Answer 2 · answered Oct 31 '12 at 09:03

15

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]]

enter image description here

answered Oct 31 '12 at 09:03

kglr

394,356
18
477
896

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
1

.. or Text["r = " <> ToString[r], {#, i[r, #]}]. – kglr Oct 31 '12 at 15:32
1

StringForm[] would also be convenient to use here... – J. M.'s missing motivation Nov 07 '12 at 05:23

score 10 · Accepted Answer · edited Oct 30 '12 at 22:39

10

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}]

plot with legends

edited Oct 30 '12 at 22:39

J. M.'s missing motivation

124,525
11
401
574

answered Oct 30 '12 at 20:17

b.gates.you.know.what

20,103
2
43
84

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.'s missing motivation 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:
http://mathematica.stackexchange.com/questions/6894/why-do-i-have-to-put-evaluate-here
– Peeter Joot Oct 31 '12 at 01:06
1

Instead of PlotLegends, consider using the code in this excellent answer: http://mathematica.stackexchange.com/a/4028/745. It gives much much nicer legends. – Ajasja Oct 31 '12 at 09:57
@Ajasja Thanks, very nice indeed. – b.gates.you.know.what Oct 31 '12 at 10:05

score 1 · Answer 4 · answered Sep 01 '16 at 19:57

1

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.

answered Sep 01 '16 at 19:57

corey979

23,947
7
58
101

My question was old (Mathematica 8 days). This new better labelling option was mentioned in a comment referring to: http://mathematica.stackexchange.com/questions/4025/creating-legends-for-plots-with-multiple-lines/4028#4028
Also note that Mathematica11 appears to have further refined its Labelling methods, but I haven't purchased the upgrade to try that out.
– Peeter Joot Sep 01 '16 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. – corey979 Sep 01 '16 at 22:12

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

4 Answers4

Linked