Infer Parameters of LogNormalDistribution

Question

I am trying to explore whether Mathematica can help me infer the parameters of a LogNormalDistribution from observing the values of some integrals. For example, I construct the integral values by using

a1 = 3.9; b1 = .9;
val1 = Integrate[PDF[LogNormalDistribution[a1, b1], x] x, {x, 0, 40}]
val2 = Integrate[PDF[LogNormalDistribution[a1, b1], x] x, {x, 40, Infinity}]
(*9.5
64.5*)

Then, I try to work backwards from these values to see whether one of the minimizing functions can guess the a1 and b1 parameters. Using the NormalDistribution (instead of the LogNormalDistribution) produces success with FindMinimum and trying to reduce sum of squared errors. When I do the same with the LogNormalDistribution, however, Mathematica goes into a deep think and nothing happens (actually, I lose patience and abort the calculation). Here is what I try:

FindMinimum[
 (val1 - (Integrate[PDF[LogNormalDistribution[al, be], x] x, {x, 0, 40}]))^2 +
 (val2 - (Integrate[PDF[LogNormalDistribution[al, be], x] x, {x, 40, Infinity}]))^2
 ,{{al, 3.75}, {be, .8}}]

Replacing Infinity with a large number helps the NormalDistribution equivalent task (in part by avoiding some imaginary values; they need to be PositiveReals) but does not seem to make a difference here. Many thanks for any ideas.

Answer 1

Using the approach provided by user293787 you can use ContourPlot to identify initial estimates for FindRoot

$Version

(* "13.2.0 for Mac OS X x86 (64-bit) (November 18, 2022)" *)

Clear["Global`*"]

f1[a_, b_] = 
  Integrate[PDF[LogNormalDistribution[a, b], x]*x, {x, 0, 40}, 
   Assumptions -> {b > 0}];

f2[a_, b_] = 
  Integrate[PDF[LogNormalDistribution[a, b], x]*x, {x, 40, Infinity}, 
   Assumptions -> {b > 0}];

val1 = f1[3.9, 0.9];
val2 = f2[3.9, 0.9];

cplt = ContourPlot[
  {val1 == f1[a, b], val2 == f2[a, b]},
  {a, 2, 4}, {b, 0, 2}]

ip = Graphics`Mesh`FindIntersections[cplt]

(* {{3.36488, 1.37043}, {3.90046, 0.899019}} *)

Use these points as the initial estimates for FindRoot

FindRoot[{val1 == f1[a, b], val2 == f2[a, b]},
   {{a, #[[1]]}, {b, #[[2]]}}] & /@ ip

(* {{a -> 3.3677, b -> 1.36916}, {a -> 3.9, b -> 0.9}} *)

Answer 2

Assuming a fresh kernel, define with = (not with :=):

f1[a_,b_]=Integrate[PDF[LogNormalDistribution[a,b],x]*x,{x,0,40},Assumptions->{b>0}]
(* 1/2 E^(a+b^2/2) Erfc[(a+b^2-Log[40])/(Sqrt[2] b)] *)

f2[a_,b_]=Integrate[PDF[LogNormalDistribution[a,b],x]*x,{x,40,Infinity},Assumptions->{b>0}]
(* 1/2 E^(a+b^2/2) (1+Erf[(a+b^2-Log[40])/(Sqrt[2] b)]) *)

Your values are

val1=f1[3.9,.9]
val2=f2[3.9,.9]

You can reconstruct the parameters using (you can also use FindMinimum):

FindRoot[{val1==f1[a,b],val2==f2[a,b]},{{a,3.75},{b,.8}}]
(* {a->3.3677,b->1.36916} *)

FindRoot[{val1==f1[a,b],val2==f2[a,b]},{{a,3.75},{b,1.0}}]
(* {a->3.9,b->0.9} *)

There seem to be (at least) two solutions actually.