How do I maximize the following?

Question

I want to maximize

$${T(\epsilon)=\max\left\{\log_{(1/y)}\left(|\sqrt{2}-x/y|\right):x,y\in\mathbb{N}, |\sqrt{2}-x/y|<\epsilon\right\}}$$

Edit: I changed the inequality, it was supposed to be greater than

Edit 2: Perhaps it should be less than

When I used my code I tried (for $\epsilon=.0001$)

NMaximize[{x, y} \[Element] Integers && Log[1/y, Sqrt[2] - x/y] && 
  RealAbs[Sqrt[2] - x/y]<= .0001, {x, y}]

But instead I get:

NMaximize::nnum: The function value -False is not a number at {x,y} = {0.918621,0.716689}.

NMaximize::nnum: The function value -False is not a number at {x,y} = {0.918621,0.716689}.

NMaximize::nnum: The function value -False is not a number at {x,y} = {0.918621,0.716689}.

How do we fix this and create $T(\epsilon)$ in my code.

Answer 1

The syntax of NMaximize that you intended to try should be NMaximize[{f, constraints}, {x, y}]. But unfortunately

NMaximize[{
  Log[1 / y, Abs[Sqrt[2] - x / y]],
  Element[{x, y}, Integers] && x >= 1 && y >= 2 && Abs[Sqrt[2] - x / y] < 0.0001
}, {x, y}]

gives a warning like

NMaximize::incst: NMaximize was unable to generate any initial points satisfying the inequality constraints ...

and you would get an answer that does not satisfy the given constraints.

As an alternative option: my guess is that $y$ should be small as possible to maximize your expression (I hope this is correct or at least works as an approximation). For this purpose, you can use Rationalize. The following function returns a triplet $\{T(\epsilon),x,y\}$ for a given $\epsilon$.

t[eps_] := Module[{r, x, y},
  r = Rationalize[Sqrt[2], eps];
  x = Numerator[r];
  y = Denominator[r];
  {Log[1/y, Abs[Sqrt[2] - x/y]], {x, y}}
];

Example:

Table[{10^-n, t[10^-n]}, {n, 1, 10}] // N

Answer 2

Since the feasible discrete set RealAbs[Sqrt[2] - x / y] < 0.0001 is infinite, this is a hard task for NMaximize. It can be done as follows. First, we find the maximum for x >= 1000 && y >= 1000 by

NMaximize[{Log[1/y, RealAbs[Sqrt[2] - x/y]], 
Element[{x, y}, Integers] && x >= 1000 && y >= 1000 && 
RealAbs[Sqrt[2] - x/y] < 0.0001}, {x, y},Method->{"DifferentialEvolution", "ScalingFactor" ->3}]

which produces {1.51158, {x -> 1649, y -> 1166}} and a warning

NMaximize::incst: NMaximize was unable to generate any initial points satisfying the inequality constraints {-0.0001+RealAbs[Sqrt[2]-Round[x]/Round[<<1>>]]<=0}. The initial region specified may not contain any feasible points. Changing the initial region or specifying explicit initial points may provide a better solution.

The above result is a feasible solution in view of

N[RealAbs[Sqrt[2] - x/y] /. { x -> 1649, y -> 1166}]

0.0000231443

Second, in order to be sure, we apply the known lower estimate for RealAbs[Sqrt[2] - x/y] (see the "Liouville numbers and transcendence" section in that Wiki article for info) $$\exists A>0\, \forall\{x,y\}\in\mathbb{N} \left| \sqrt{2}-\frac{x}{y}\right|> \frac A {y^2} $$. According to Lemma from this section, we may take $A=\frac 1 {5}$ ($M=5$). This inequality implies the inequality ForAll[{x,y},{x,y} \[Element] PositiveIntegers && y>1, Log[1/y, RealAbs[Sqrt[2] - x/y]] < Log[1/y, 1/5] + 2]. It is clear the maximum of Log[1/y, 1/5] + 2] for all integers y >=1000 is attained at y==1000 and is equal to N[Log[1/1000, 1/5]]==0.23299.

Third, now we apply counting for x>=1&&x<=999&&y>=2&&y<=999

Do[If[RealAbs[Sqrt[2] - x/y] < 0.0001, Print[{x, y, N[Log[1/y, RealAbs[Sqrt[2] - x/y]]]}]],
 {x, 1, 999}, {y, 2, 999}]

{99,70,2.24473} {140,99,2.07542}... {997, 705, 1.59229}

Summarizing the above, we draw the conclusion that the maximum under consideration is equal to 2.224473 at {x==99,y==70}.

Edit. 1000 in the above instead of 100 and constant $A= \frac 1 5$ instead of $A=\frac 1 3$.

Answer 3

This is just an extended comment. Many times constructing a figure helps one focus on a solution. Below the gray dots are the values of Log[1/y, Abs[Sqrt[2] - x/y]], the green dots are the values where Abs[Sqrt[2] - x/y] <= 0.0001, and the red dot is where the maximum for x>=1&&x<=300&&y>=2&&y<=300 occurs.

ϵ = 1/10000;
t = Flatten[Table[{x, y, Log[1/y, Abs[Sqrt[2] - x/y]]}, {x, 1, 300}, {y, 2,  300}], 1];

t0 = Select[t, Abs[Sqrt[2] - #[[1]]/#[[2]]] < ϵ &];
(* {{99, 70, -(Log[99/70 - Sqrt[2]]/Log[70])}, 
    {140, 99, -(Log[-(140/99) + Sqrt[2]]/Log[99])}, 
    {198, 140, -(Log[99/70 - Sqrt[2]]/Log[140])},
    {239, 169, -(Log[-(239/169) + Sqrt[2]]/Log[169])},
    {280, 198, -(Log[-(140/99) + Sqrt[2]]/Log[198])},
    {297, 210, -(Log[99/70 - Sqrt[2]]/Log[210])}} *)

tmax = Select[t0, #[[3]] == Max[t0[[All, 3]]] &]
(* {99, 70, -(Log[99/70 - Sqrt[2]]/Log[70])} *)

ListPointPlot3D[{t, t0, tmax}, SphericalRegion -> True, BoxRatios -> {1, 1, 1},
  RotationAction -> "Clip", ImageSize -> Large, PlotRange -> All, 
  PlotStyle -> {{Gray, PointSize[0.001]}, {Green, PointSize[0.01]}, {Red, PointSize[0.015]}}]