Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
    
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
add comment

3 Answers 3

up vote 5 down vote accepted

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

share|improve this answer
    
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
1  
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
show 1 more comment

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

share|improve this answer
    
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, #]}]. –  kguler Oct 31 '12 at 15:19
1  
.. or Text["r = " <> ToString[r], {#, i[r, #]}]. –  kguler Oct 31 '12 at 15:32
1  
StringForm[] would also be convenient to use here... –  J. M. Nov 7 '12 at 5:23
add comment

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@"http://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}]
share|improve this answer
1  
Wow, that works really nicely. Great work! –  Peeter Joot Nov 6 '12 at 14:45
    
@PeeterJoot I like it too :) –  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 –  belisarius Nov 7 '12 at 23:44
    
@ChrisDegnen A palette here meta.mathematica.stackexchange.com/questions/771/… –  belisarius Nov 7 '12 at 23:45
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.