The first cell integrates the Lorenz equation for 0 < t < tf, with the initial conditions on the line segment jointing the two nontrivial fixed points.
The parameter s, between -1 and 1, determines the position on the line segment.

sig = 10;
r = 28;
b = 8/3;
xf = Sqrt[(r-1.) b];
zf = r-1;
(* The fixed points are (0,0,0), (xf, xf, zf), and (-xf, -xf, zf) *)

s = .01; (* between -1 and 1 *)
tf =6;

fig[s_, tf_] := Module[{},
x0 = s* xf;  
y0 = s* xf;
z0 = r-1;
{soln,poincare}=Reap@NDSolve[{
x'[t]==sig(y[t]-x[t]),
y'[t]==r x[t]-y[t]- x[t] z[t], 
z'[t] == x[t] y[t] - b z[t],
x[0]== x0,y[0]==y0,z[0] == z0, 
WhenEvent[z[t] > 27, Sow[{x[t],y[t], t}] ]},
{x,y, z},{t,0,tf}];
soln = Part[soln, 1];
If[poincare ≠ {}, poincare = Part[poincare, 1] ];
points = Table[{poincare[[i, 1]], poincare[[i, 2]], r-1}, {i, Length[poincare]}];
yList = Table[poincare[[i, 2]], {i, Length[poincare]}];
signList = Sign[yList];
sum = 0.;
Do[sum = sum + Sign[poincare[[i, 1]] ] /2^(i), {i, 1, Length[poincare]}];
z27plane = Graphics3D[{Opacity[0.7],Polygon[{{-25, -25, r-1}, {-25, 25, r-1}, {25, 25, r-1}, {25, -25, r-1}}], PointSize[Medium], Black, Point[{xf, xf, r-1}], Point[{-xf, -xf, r-1}],Point[{x0, y0, z0}],Red, Point[points]}];
pTrajectory =ParametricPlot3D[{x[t], y[t], z[t]}/.soln, {t, 0, tf}, PlotLabel -> "IC = (s (Subscript[x, f]), s (Subscript[x, f]), 27), with s = "<>ToString[s]<>"\nsignList = "<>ToString[signList]<>"\nf(s) = "<>ToString[sum]];
Show[pTrajectory, z27plane]
]

fig[.2,4]

fig[.01,5.7]

poincare

f[s_, tf_] := Module[{},
If[s == -1, Return[-1] ];
If[s == 0, Return[0] ];
If[s == 1, Return[1]];
x0 = y0 =s xf;
z0 = r-1;
{soln,poincare}=Reap@NDSolve[{
x'[t]==sig(y[t]-x[t]),
y'[t]==r x[t]-y[t]- x[t] z[t], 
z'[t] == x[t] y[t] - b z[t],x[0]== x0,y[0]==y0,z[0] == z0, WhenEvent[z[t] > 27, Sow[{x[t],y[t], t}] ]},{x,y, z},{t,tf}];
soln = Part[soln, 1];
poincare = Part[poincare, 1];
signList = Sign[Transpose[poincare ][[1]] ];
sum = 0.;
Do[sum = sum + signList[[i]] /2^(i), {i, 1, Length[poincare]}];
sum
]

f[.1, 10]
signList

poincare

pts = {};
Do[AppendTo[pts, {s, f[s, 10]}], {s, -1, 1, .02}]
ListPlot[pts]

I can use this to (hopefully) find orbits with any sequence I want.  I can just use root-finding.  Choose a sequence like LRLLR LRLLR LRLLR ... and get the number for that, and Use FindRoot with an interval initial guess.

(*
FindRoot[f[s, 10] == 1/3, {s, 0.01, .3}]
*)

I’m not sure why that didn’t work.  Do my own secant method;
{+,-,+,- ...} has f =

s1 = 0.1;
s2 = .3;
tf = 15;
maxIts = 10;
tol = 0.0001;
target = 1/3;
f1 = f[s1, tf] - target
Print[signList]
f2 = f[s2, tf]-target 
Print[signList];
its = 0;
While[Abs[f2 -f1] > tol && its < maxIts,
snew = s1 - f1*(s2-s1)/(f2-f1);
fnew = f[snew, tf] - target;
Print[fnew];
Print[signList];
s2 = s1;
f2 = f1;
s1 = snew;
f1 = fnew;
its++
]

poincare

{x0, y0, t1} = poincare[[1]];
z0 = r-1;
per = 2;
t2 = poincare[[1 + per, 3]];
soln = NDSolve[{x'[t]==sig(y[t]-x[t]),y'[t]==r x[t]-y[t]- x[t] z[t], z'[t] == x[t] y[t] - b z[t],x[0]== x0,y[0]==y0,z[0] == z0},{x,y, z},{t,t2-t1}];

 ParametricPlot3D[{x[t], y[t], z[t]}/.soln, {t, 0, t2-t1}]

nPoints = 30;
rlList = Table[{x[t], y[t], z[t]}/.soln[[1]], {t, 0, t2-t1, (t2-t1)/nPoints}];
rlList = Drop[rlList, 1];
Graphics3D@Tube@BSplineCurve[rlList, .5, SplineClosed -> True]
nPoints = 150;
rlList = Table[{x[t], y[t], z[t]}/.soln[[1]], {t, 0, t2-t1, (t2-t1)/nPoints}];
plr =Graphics3D[{Green,Tube[rlList, .5]}]

s1 = 0.5;
s2 = .7;
tf = 25;
maxIts = 20;
tol = 0.000000001;
targetSeq = {1,1, 1, 1, 1,1,1,1,1,-1};
per = Length[targetSeq];

target = Sum[targetSeq[[i]]/2^i,{i, 1,per}]/(1-1/2^(per))
f1 = f[s1, tf] - target
Print[signList]
f2 = f[s2, tf]-target 
Print[signList];
its = 0;
While[Abs[f2 -f1] > tol && its < maxIts,
snew = s1 - f1*(s2-s1)/(f2-f1);
fnew = f[snew, tf] - target;
Print[signList];
s2 = s1;
f2 = f1;
s1 = snew;
f1 = fnew;
its++
]
{x0, y0, t1} = poincare[[1]];
z0 = r-1;
t2 = poincare[[1 + per, 3]];
soln = NDSolve[{x'[t]==sig(y[t]-x[t]),y'[t]==r x[t]-y[t]- x[t] z[t], z'[t] == x[t] y[t] - b z[t],x[0]== x0,y[0]==y0,z[0] == z0},{x,y, z},{t,t2-t1}];

 ParametricPlot3D[{x[t], y[t], z[t]}/.soln, {t, 0, t2-t1}]

default ViewPoint is {1.3, -2.4, 2}

nPoints = 950;
rad = 0.65;
rrrlList = Table[{x[t], y[t], z[t]}/.soln[[1]], {t, 0, t2-t1, (t2-t1)/nPoints}];
lllrList = Table[{-x[t], -y[t], z[t]}/.soln[[1]], {t, 0, t2-t1, (t2-t1)/nPoints}];
lllrPlot =Graphics3D[{Cyan, Tube[lllrList, rad]}];
rrrlPlot =Graphics3D@Tube[rrrlList, rad];
fixedPts = Graphics3D[{Sphere[{-xf,-xf,27}, .75],Sphere[{xf,xf,27},.75], Sphere[{0,0,0}, .75]}];
bannerFig = Show[rrrlPlot, lllrPlot,fixedPts, ViewPoint -> {2.2, -1.3, .7}, ImagePadding -> 10]

Export["/Users/jimswift/Dropbox/math art/LorenzAttractor4.png", bannerFig, ImageSize ->{720, 350}]
Export["/Users/jimswift/Dropbox/math art/LorenzAttractor4.pdf", bannerFig]

this is a trial of plotting the two periodic orbits on top of the attractor.  I gave it up as being too busy.