Is there an alternative way instead of increasing the number of plotpoints in RegionPlot to get a better result?

Question

I have this function and I use RegionPlot to see in which part of the domain, the function is negative:

f := 1/4 x^2 Sinh[(2 \[Pi] x)/
     3]^2 Sinh[\[Pi] x]^2 (-512 Sinh[(\[Pi] x)/3] + 
      128 x^2 Sinh[(\[Pi] x)/3] + 64 Sinh[\[Pi] x] + 
      32 x^2 Sinh[\[Pi] x] + 4 x^4 Sinh[\[Pi] x] - 
      128 Sinh[(5 \[Pi] x)/3] - 64 x^2 Sinh[(5 \[Pi] x)/3] - 
      8 x^4 Sinh[(5 \[Pi] x)/3] + 576 Sinh[(7 \[Pi] x)/3] - 
      96 x^2 Sinh[(7 \[Pi] x)/3] + 4 x^4 Sinh[(7 \[Pi] x)/3])^2 - 
   4 (256 Cosh[(2 \[Pi] x)/3]^2 - 128 x^2 Cosh[(2 \[Pi] x)/3]^2 + 
      16 x^4 Cosh[(2 \[Pi] x)/3]^2 + 
      256 x^2 Sinh[(2 \[Pi] x)/
        3]^2) Sinh[\[Pi] x]^2 (64 Sinh[(\[Pi] x)/3]^2 - 
      32 x^2 Sinh[(\[Pi] x)/3]^2 + 4 x^4 Sinh[(\[Pi] x)/3]^2 - 
      16 Sinh[(\[Pi] x)/3] Sinh[\[Pi] x] - 
      4 x^2 Sinh[(\[Pi] x)/3] Sinh[\[Pi] x] + 
      x^4 Sinh[(\[Pi] x)/3] Sinh[\[Pi] x] + 
      1/4 x^6 Sinh[(\[Pi] x)/3] Sinh[\[Pi] x] + Sinh[\[Pi] x]^2 + 
      x^2 Sinh[\[Pi] x]^2 + 3/8 x^4 Sinh[\[Pi] x]^2 + 
      1/16 x^6 Sinh[\[Pi] x]^2 + 1/256 x^8 Sinh[\[Pi] x]^2 - 
      256 Cosh[(2 \[Pi] x)/3]^2 Sinh[\[Pi] x]^2 + 
      128 x^2 Cosh[(2 \[Pi] x)/3]^2 Sinh[\[Pi] x]^2 - 
      16 x^4 Cosh[(2 \[Pi] x)/3]^2 Sinh[\[Pi] x]^2 + 
      32 Sinh[(\[Pi] x)/3] Sinh[(5 \[Pi] x)/3] + 
      8 x^2 Sinh[(\[Pi] x)/3] Sinh[(5 \[Pi] x)/3] - 
      2 x^4 Sinh[(\[Pi] x)/3] Sinh[(5 \[Pi] x)/3] - 
      1/2 x^6 Sinh[(\[Pi] x)/3] Sinh[(5 \[Pi] x)/3] - 
      4 Sinh[\[Pi] x] Sinh[(5 \[Pi] x)/3] - 
      4 x^2 Sinh[\[Pi] x] Sinh[(5 \[Pi] x)/3] - 
      3/2 x^4 Sinh[\[Pi] x] Sinh[(5 \[Pi] x)/3] - 
      1/4 x^6 Sinh[\[Pi] x] Sinh[(5 \[Pi] x)/3] - 
      1/64 x^8 Sinh[\[Pi] x] Sinh[(5 \[Pi] x)/3] + 
      4 Sinh[(5 \[Pi] x)/3]^2 + 4 x^2 Sinh[(5 \[Pi] x)/3]^2 + 
      3/2 x^4 Sinh[(5 \[Pi] x)/3]^2 + 1/4 x^6 Sinh[(5 \[Pi] x)/3]^2 + 
      1/64 x^8 Sinh[(5 \[Pi] x)/3]^2 - 
      144 Sinh[(\[Pi] x)/3] Sinh[(7 \[Pi] x)/3] + 
      60 x^2 Sinh[(\[Pi] x)/3] Sinh[(7 \[Pi] x)/3] - 
      7 x^4 Sinh[(\[Pi] x)/3] Sinh[(7 \[Pi] x)/3] + 
      1/4 x^6 Sinh[(\[Pi] x)/3] Sinh[(7 \[Pi] x)/3] + 
      18 Sinh[\[Pi] x] Sinh[(7 \[Pi] x)/3] + 
      6 x^2 Sinh[\[Pi] x] Sinh[(7 \[Pi] x)/3] - 
      1/4 x^4 Sinh[\[Pi] x] Sinh[(7 \[Pi] x)/3] - 
      1/8 x^6 Sinh[\[Pi] x] Sinh[(7 \[Pi] x)/3] + 
      1/128 x^8 Sinh[\[Pi] x] Sinh[(7 \[Pi] x)/3] - 
      36 Sinh[(5 \[Pi] x)/3] Sinh[(7 \[Pi] x)/3] - 
      12 x^2 Sinh[(5 \[Pi] x)/3] Sinh[(7 \[Pi] x)/3] + 
      1/2 x^4 Sinh[(5 \[Pi] x)/3] Sinh[(7 \[Pi] x)/3] + 
      1/4 x^6 Sinh[(5 \[Pi] x)/3] Sinh[(7 \[Pi] x)/3] - 
      1/64 x^8 Sinh[(5 \[Pi] x)/3] Sinh[(7 \[Pi] x)/3] + 
      81 Sinh[(7 \[Pi] x)/3]^2 - 27 x^2 Sinh[(7 \[Pi] x)/3]^2 + 
      27/8 x^4 Sinh[(7 \[Pi] x)/3]^2 - 
      3/16 x^6 Sinh[(7 \[Pi] x)/3]^2 + 
      1/256 x^8 Sinh[(7 \[Pi] x)/3]^2);
RegionPlot[a f < 0, {x, 3.46572, 3.46574}, {a, 0, 1}, 
 PlotPoints -> 60]

This is the result:

I am sure that the blue part should be a continuous domain. How can I get a better result? Is there an alternative way instead of increasing the number of plotpoints? Since it is not easy for my system and it takes much time.

Answer 1

f can be simplified (and I would use = rather than :=):

f = FullSimplify[f]
(*  -2 (-4 + x^2)^2 (1 + Cosh[(2 π x)/3] + 
   Cosh[(4 π x)/3])^2 (155392 - 153856 x^2 + 8608 x^4 - 144 x^6 - 
   x^8 - 256 (-6 + x) (6 + x) (32 - 28 x^2 + x^4) Cosh[(2 π x)/3] - 
   64 (-3776 + 2768 x^2 - 212 x^4 + 3 x^6) Cosh[(4 π x)/3] - 
   64 (-12 + x^2) (208 - 96 x^2 + 3 x^4) Cosh[2 π x] - 
   128 (-12 + x^2)^2 (-4 + x^2) Cosh[(8 π x)/3] +
   (-12 + x^2)^4 Cosh[(10 π x)/3]) Sinh[(π x)/3]^6 *)

Then a plot of f over an appropriate range shows where f is negative:

Plot[f, {x, Rationalize[3.46572838, 0], Rationalize[3.46572842, 0]}, WorkingPrecision -> 30]

Now the RegionPlot:

RegionPlot[a f < 0, {x, Rationalize[3.46572838, 0], Rationalize[3.46572842, 0]}, {a, 0, 1},
  PlotPoints -> 60, WorkingPrecision -> 30]

So you end up with a rectangle. Am I missing something? (Yes, the display of the horizontal axis tick mark labels needs work.)

If it is a ContourPlot that you want, then the following might work:

ContourPlot[a f, {x, Rationalize[3.46572838, 0], Rationalize[3.46572842, 0]}, {a, 0, 1},
 Contours -> 10^22 Range[-10, 0], PlotPoints -> 60, 
 WorkingPrecision -> 50, FrameLabel -> {"x", "a"},
 PlotLegends -> Automatic]