2
$\begingroup$

I'm trying to plot the intersection of a Sum function with a horizontal line and automatically highlight the intersection points. The code below shows my knowledge of Mathematica and for different values of "d" I am calculating with Solve the intersection points (ex p1,p2 and p3) and manually typing the value in the Epilog option. I tried Point[{p1,1}] but it doesn't work. I also tried it with MeshFunctions -> {g[#] - f[#] &}, Mesh -> {{0}}, MeshStyle -> PointSize[Large] but I get an error "functions must be pure functions". I would also like to be able to define the ranges of "d" and "pc" as {d, {min,max,incr}} instead of a list. Thanks in advance.

np = 2
f[pc_] := 1
q[d_, pc_] := (pc/(100*0.48)) * 
  Sum[((Pi/4)*(d - (2*n*0.48))^2), {n, 1, np}]
p[d_] := Sum[Pi*(d - (2*n - 1)*0.48), {n, 1, np}]
p1 = Solve[q[20, pc]/p[20] == f[pc], pc]
p2 = Solve[q[10, pc]/p[10] == f[pc], pc]
p3 = Solve[q[8, pc]/p[8] == f[pc], pc]
g[d_, pc_] := q[d, pc]/p[d]
Plot[{Evaluate[Table[g[d, pc], {d, {8, 10, 20}}]], f[pc]}, {pc, 0, 
  50}, PlotRange -> All, AxesLabel -> {"%", "li/lp"}, 
 FrameLabel -> {Style["pc", 12, Bold], Style["li/lp", 12, Bold]}, 
 PlotLabels -> {"d=8", "d=10", "d=20"}, PlotTheme -> "Scientific", 
 GridLines -> Automatic, PlotLabel -> "Razão comprimentos",
 Epilog -> {PointSize[0.02], Point[{10.6053, 1}], Point[{23.6134, 1}],
    Point[{31.2426, 1}]}]
$\endgroup$
3
$\begingroup$
np = 2;
f[pc_] = 1;

dmin = 8;
dmax = 24;
dincr = 4;

q[d_, pc_] = (pc/(100*12/25))*
    Sum[((Pi/4)*(d - (2*n*12/25))^2), {n, 1, np}] //
   Simplify;

p[d_] = Sum[Pi*(d - (2*n - 1)*12/25), {n, 1, np}] //
   Simplify;

g[d_, pc_] := q[d, pc]/p[d];

pt[d_] = {pc, f[pc]} /. Solve[g[d, pc] == f[pc], pc][[1]];

Plotting

Plot[{
  Evaluate[Table[g[d, pc], {d, dmin, dmax, dincr}]],
  f[pc]}, {pc, 0, 50},
 PlotRange -> All,
 FrameLabel ->
  (Style[#, 12, Bold] & /@ {"pc", "li/lp"}), 
 PlotLabels -> (StringForm["d=``", #] & /@
    Range[dmin, dmax, dincr]),
 PlotTheme -> "Scientific",
 GridLines -> Automatic,
 PlotLabel -> "Razão comprimentos",
 Epilog -> {PointSize[0.02],
   Tooltip[Point[#], N[#[[1]]]] & /@
    (pt /@ Range[dmin, dmax, dincr])}]

enter image description here

EDIT: To vary the level of the line

Manipulate[
 pt[d_] = {pc, fpc} /. Solve[g[d, pc] == fpc, pc][[1]];
 Plot[{
   Evaluate[Table[g[d, pc], {d, dmin, dmax, dincr}]],
   fpc}, {pc, 0, 50},
  PlotRange -> All, 
  FrameLabel -> (Style[#, 12, Bold] & /@
     {"pc", "li/lp"}),
  PlotLabels -> (StringForm["d=``", #] & /@
     Range[dmin, dmax, dincr]),
  PlotTheme -> "Scientific",
  GridLines -> Automatic,
  PlotLabel -> "Razão comprimentos",
  Epilog -> {PointSize[0.02],
    Tooltip[Point[#], N[#[[1]]]] & /@
     Select[(pt /@ Range[dmin, dmax, dincr]), #[[1]] <= 50 &]}],
 {{fpc, 1}, 0.5, 5.5, 0.1, Appearance -> "Labeled"},
 SynchronousUpdating -> False]

enter image description here

$\endgroup$
5
  • $\begingroup$ Hi! Is there a way to specify the pc variation in terms of pcmin,pcmax and pcincr? $\endgroup$ Jul 25 at 1:28
  • $\begingroup$ It is not clear what you mean by the "pc variation". pc is the x-axis and is a continuum. Are you instead trying to vary the definition of f[pc]? $\endgroup$
    – Bob Hanlon
    Jul 25 at 1:43
  • $\begingroup$ You're right. There is no reason to vary pc. Thanks. $\endgroup$ Jul 25 at 1:52
  • $\begingroup$ Your solution is great but unfortunately, my knowledge of Mathematica does not allow me to understand the meaning of the syntax of the line pt[d_] = and the meaning of the symbology "d=``", #, /@ & , N[#[[1]]]] & /@ (& /@ Range etc. Are there any book or Wolfram documentation on this? $\endgroup$ Jul 25 at 2:01
  • $\begingroup$ Highlight the unknown symbol in the notebook and press F1 on your keyboard for help. Or use the Help menu. Wolfram has online resources, e.g., An Elementary Introduction to the Wolfram Language $\endgroup$
    – Bob Hanlon
    Jul 25 at 2:15
3
$\begingroup$

Method 1

Here we plot the intersection of three functions g[8,pc], g[10,pc], g[20,pc] respect tof[pc].

For example,if we want to find the intersetion of g[8,pc] and y=f[x] when we plot g[8,pc], we can set the MeshFunction of g[8,pc] to y-f[x],that is MeshFunctions -> {#2 - f[#1] &}, Mesh -> {{0}}

np = 2;
f[pc_] := 1;
q[d_, pc_] := (pc/(100*0.48))*
   Sum[((Pi/4)*(d - (2*n*0.48))^2), {n, 1, np}];
p[d_] := Sum[Pi*(d - (2*n - 1)*0.48), {n, 1, np}];
g[d_, pc_] := q[d, pc]/p[d];
plot = Plot[Evaluate[Table[g[d, pc], {d, {8, 10, 20}}]], {pc, 0, 50}, 
  MeshFunctions -> {#2 - f[#1] &}, Mesh -> {{0}}, 
  MeshStyle -> {PointSize[Large], Automatic}, PlotRange -> All, 
  AxesLabel -> {"%", "li/lp"}, 
  FrameLabel -> {Style["pc", 12, Bold], Style["li/lp", 12, Bold]}, 
  PlotLabels -> {"d=8", "d=10", "d=20"}, PlotTheme -> "Scientific", 
  GridLines -> Automatic, PlotLabel -> "Razão comprimentos"]

Show[plot, Plot[f[pc], {pc, 0, 50}]]

enter image description here

Method 2

On the other hand, we can also set three pure functions Table[Function[pc, g[d, pc] - f[pc] // Evaluate], {d, {8, 10, 20}}]

when we plot f[pc] to get the three intersections.

np = 2;
f[pc_] := 1;
q[d_, pc_] := (pc/(100*0.48))*
   Sum[((Pi/4)*(d - (2*n*0.48))^2), {n, 1, np}];
p[d_] := Sum[Pi*(d - (2*n - 1)*0.48), {n, 1, np}];
g[d_, pc_] := q[d, pc]/p[d];

Plot[f[pc], {pc, 0, 50}, 
 MeshFunctions -> 
  Table[Function[pc, g[d, pc] - f[pc] // Evaluate], {d, {8, 10, 20}}],
  Mesh -> {{0}}, MeshStyle -> Directive[PointSize[Large], Red]]

enter image description here

Animation

Clear[np, f, q, p, g, plot];
np = 2;
f[pc_] := 1;
q[d_, pc_] := (pc/(100*0.48))*
   Sum[((Pi/4)*(d - (2*n*0.48))^2), {n, 1, np}];
p[d_] := Sum[Pi*(d - (2*n - 1)*0.48), {n, 1, np}];
g[d_, pc_] := q[d, pc]/p[d];
plot[c_] := 
  Plot[Evaluate[Table[g[d, pc], {d, {8, 10, 20}}]], {pc, 0, 50}, 
   MeshFunctions -> {#2 - f[#1] &}, Mesh -> {{c}}, 
   MeshStyle -> {PointSize[Large], Automatic}, PlotRange -> All, 
   AxesLabel -> {"%", "li/lp"}, 
   FrameLabel -> {Style["pc", 12, Bold], Style["li/lp", 12, Bold]}, 
   PlotLabels -> {"d=8", "d=10", "d=20"}, PlotTheme -> "Scientific", 
   GridLines -> Automatic, PlotLabel -> "Razão comprimentos"];
Manipulate[Show[plot[c], Plot[f[pc] + c, {pc, 0, 50}]], {c, -1, 2}, 
 ControlPlacement -> Bottom]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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