Plot all real and imaginary roots of FindRoot vrs `k`

Question

I'm looking to plot all real and imaginary roots of this cubic equation

eq[x_,k_]:=x^3-5x^2+x-k

as a function of a real parameter k.

Step 1: to get an idea, I first compare solutions by the two functions NSolve and FindRoot with a given range, for that I use

root1[k_]:= Solve[eq[x,k] == 0,x,Cubics->True]    

(* For k=2, root1[2] gives : {{{x -> 4.879057633484047},{x -> 0.06047118325797629 + 0.6373840752906359 I},
{x -> 0.06047118325797629 - 0.6373840752906359 I}}} *)

root2[k_]:= FindRoot[eq[x,k] == 0,{x,#}]&/@{-5,-2,0,2,5,10}

(* For k=2, root2[2] gives : {{{x -> 0.1031932441958189}, {x -> 0.1031957295973283}, {x -> 
0.1031928872111299}, {x -> 0.1031958817666505}, {x -> 
4.879057633484048}, {x -> 4.879057633484049}}}  *)

The problem at this level is that for the same value of k=2 I can't find the same complex roots by FindRoot, why?

Step 2: Then I try to plot all real parts Re[root2[k]] vrs k and all imaginary parts Im[root2[k]] vrs k of solutions, I form a table {k,root1[k]} for k∈[-5,5] but then I don't know how to do it

data=Table[{k,root1[k]},{k,-5,5,1}]//N

(* {{-5., {{x -> 
 4.536629621205803 + 0. I}, {x -> -0.8434044873336737 + 
  2.220446049250313*10^-16 I}, {x -> 
 1.306774866127871 - 2.220446049250313*10^-16 I}}}, {-4., {{x -> 
 4.592614742039923 + 
  1.480297366166875*10^-16 I}, {x -> -0.7515320715475298 + 
  2.220446049250313*10^-16 I}, {x -> 
 1.158917329507606 - 2.220446049250313*10^-16 I}}}, {-3., {{x -> 
 1.}, {x -> -0.6457513110645907}, {x -> 
 4.645751311064591}}}, {-2., {{x -> 
 4.696392779347097 + 
  7.401486830834377*10^-17 I}, {x -> -0.518198699326341 + 
  4.440892098500626*10^-16 I}, {x -> 
 0.8218059199792439 - 4.440892098500626*10^-16 I}}}, {-1., {{x -> 
 4.744826077681923 + 
  3.700743415417188*10^-17 I}, {x -> -0.3488942175007166 + 
  4.440892098500626*10^-16 I}, {x -> 
 0.6040681398187938 - 4.440892098500626*10^-16 I}}}, {0., {{x -> 
 0.}, {x -> 0.2087121525220801}, {x -> 
 4.79128784747792}}}, {1., {{x -> 
 0.08201204045934052 + 0.4472778999095655 I}, {x -> 
 0.08201204045934052 - 0.4472778999095655 I}, {x -> 
 4.835975919081319}}}, {2., {{x -> 4.879057633484047}, {x -> 
 0.06047118325797629 + 0.6373840752906359 I}, {x -> 
 0.06047118325797629 - 0.6373840752906359 I}}}, {3., {{x -> 
 4.920676006565271}, {x -> 
 0.03966199671736437 + 0.7798071907703745 I}, {x -> 
 0.03966199671736437 - 0.7798071907703745 I}}}, {4., {{x -> 
 4.960954381704582}, {x -> 
 0.0195228091477091 + 0.8977278700998234 I}, {x -> 
 0.0195228091477091 - 0.8977278700998234 I}}}, {5., {{x -> 
 0. - 1. I}, {x -> 0. + 1. I}, {x -> 5.}}}} *)

How to do it please?

Thanks guys for your help.

Answer 1

Clear["Global`*"]

eq[x_, k_] := x^3 - 5 x^2 + x - k

root1[k_] = SolveValues[eq[x, k] == 0, x] // Simplify;

sol1 = root1[2] // N

(* {4.87906, 0.0604712 + 0.637384 I, 0.0604712 - 0.637384 I} *)

From the documentation, "If all equations and starting values are real, then FindRoot will search only for real roots . If any are complex, it will also search for complex roots ."

root2[k_] := 
 Flatten[Values /@ (FindRoot[eq[x, k] == 0, {x, #}] & /@ {5, 0.1 + 0.7 I, 
      0.1 - 0.7 I})]

sol2 = root2[2]

(* {4.87906, 0.0604712 + 0.637384 I, 0.0604712 - 0.637384 I} *)

sol1 - sol2

(* {-8.88178*10^-16, 6.245*10^-17 - 3.33067*10^-16 I, 
 6.245*10^-17 + 3.33067*10^-16 I} *)

reim[k_] = ComplexExpand[ReIm[root1[k]]] // Simplify;

Show[
 ParametricPlot[Evaluate@reim[k], {k, -5, 5},
  PlotLegends -> Automatic,
  AspectRatio -> 1,
  PlotPoints -> 100,
  MaxRecursion -> 5,
  WorkingPrecision -> 15],
 Graphics[{
   Red, AbsolutePointSize[4],
   Point[ReIm[sol1]]}],
 AxesLabel -> {Re, Im}]

EDIT: Plotting Re and Im separately,

Column[
 Plot[
    Evaluate@#@root1@k, {k, -5, 5},
    PlotStyle -> {Blue, Red, Dashed},
    PlotLabel -> #,
    PlotLegends -> Automatic,
    PlotPoints -> 75,
    MaxRecursion -> 5,
    WorkingPrecision -> 15] & /@ {Re, Im}]

Clear[root2];
root2[k_, init : _List :
   {5, (1 + 7 I)/10, (1 - 7 I)/10}] :=
 Flatten[Values /@ (
    FindRoot[eq[x, k] == 0, {x, #}] & /@
     init)]

Column[
 ListLinePlot[
    #@Transpose@Table[root2[k,
        Piecewise[{{{9/2, 1/2, -1/2}, k <= 0},
          {{9/2, I/2, -I/2}, k > 0}}]],
       {k, -5, 5, 1/20}],
    DataRange -> {-5, 5},
    PlotStyle -> {Blue, Red, Dashed},
    PlotLabel -> #,
    PlotLegends -> Automatic] & /@
  {Re, Im}]

Clear["Global`*"]

EDIT 2: Re the comment

FindRootrequires tailored starting values. You cannot blindly reuse a previous solution.

Clear["Global`*"]

eq[x_, k_] = 1 - k^2/x^2 - 1/(x(x - 20));

root1[k_] = SolveValues[
  {eq[x, k] == 0, -5 <= k <= 5}, x] // Simplify;

Column[
 Plot[
    Evaluate@#@root1@k, {k, -5, 5},
    PlotRange -> All,
    PlotStyle ->
     {Green, {Blue, Dashed}, {Red, Dotted}},
    PlotLabel -> #,
    PlotLegends -> Automatic,
    PlotPoints -> 75,
    MaxRecursion -> 5,
    WorkingPrecision -> 15] & /@ {Re, Im}]

Since one of the roots is essentially constant, avoid taking its derivative. From the documentation, "FindRoot[lhs == rhs, {x, x0, x1}] searches for a solution using x0 and x1 as the first two values of x, avoiding the use of derivatives."

root2[k_] := Flatten[
  Values /@ (
    FindRoot[eq[x, k] == 0, {x, # - 10^-3, # + 10^-3}] & /@
     Piecewise[{{{20, k, -k}, k <= 0},
       {{20, -k, k}, k > 0}}])]

Column[
  ListLinePlot[
     #@Transpose@
       Table[root2[k], {k, -5, 5, 1/20}],
     DataRange -> {-5, 5},
     PlotStyle ->
      {Green, {Blue, Dashed}, {Red, Dotted}},
     PlotLabel -> #,
     PlotLegends -> Automatic] & /@
   {Re, Im}] // Quiet