Giảm thiểu NExpectation cho phân phối tùy chỉnh trong Mathicala

Điều này liên quan đến một câu hỏi trước đó từ hồi tháng 6:

Tính toán kỳ vọng cho một phân phối tùy chỉnh trong Mathematica

Tôi có một phân phối hỗn hợp tùy chỉnh được xác định bằng cách sử dụng phân phối tùy chỉnh thứ hai theo sau các dòng được thảo luận @Sashatrong một số câu trả lời trong năm qua.

Mã xác định các phân phối sau:

nDist /: CharacteristicFunction[nDist[a_, b_, m_, s_], 
   t_] := (a b E^(I m t - (s^2 t^2)/2))/((I a + t) (-I b + t));
nDist /: PDF[nDist[a_, b_, m_, s_], x_] := (1/(2*(a + b)))*a* 
   b*(E^(a*(m + (a*s^2)/2 - x))* Erfc[(m + a*s^2 - x)/(Sqrt[2]*s)] + 
     E^(b*(-m + (b*s^2)/2 + x))* 
      Erfc[(-m + b*s^2 + x)/(Sqrt[2]*s)]); 
nDist /: CDF[nDist[a_, b_, m_, s_], 
   x_] := ((1/(2*(a + b)))*((a + b)*E^(a*x)* 
        Erfc[(m - x)/(Sqrt[2]*s)] - 
       b*E^(a*m + (a^2*s^2)/2)*Erfc[(m + a*s^2 - x)/(Sqrt[2]*s)] + 
       a*E^((-b)*m + (b^2*s^2)/2 + a*x + b*x)*
        Erfc[(-m + b*s^2 + x)/(Sqrt[2]*s)]))/ E^(a*x);         

nDist /: Quantile[nDist[a_, b_, m_, s_], p_] :=  
 Module[{x}, 
   x /. FindRoot[CDF[nDist[a, b, m, s], x] == #, {x, m}] & /@ p] /; 
  VectorQ[p, 0 < # < 1 &]
nDist /: Quantile[nDist[a_, b_, m_, s_], p_] := 
 Module[{x}, x /. FindRoot[CDF[nDist[a, b, m, s], x] == p, {x, m}]] /;
   0 < p < 1
nDist /: Quantile[nDist[a_, b_, m_, s_], p_] := -Infinity /; p == 0
nDist /: Quantile[nDist[a_, b_, m_, s_], p_] := Infinity /; p == 1
nDist /: Mean[nDist[a_, b_, m_, s_]] := 1/a - 1/b + m;
nDist /: Variance[nDist[a_, b_, m_, s_]] := 1/a^2 + 1/b^2 + s^2;
nDist /: StandardDeviation[ nDist[a_, b_, m_, s_]] := 
  Sqrt[ 1/a^2 + 1/b^2 + s^2];
nDist /: DistributionDomain[nDist[a_, b_, m_, s_]] := 
 Interval[{0, Infinity}]
nDist /: DistributionParameterQ[nDist[a_, b_, m_, s_]] := ! 
  TrueQ[Not[Element[{a, b, s, m}, Reals] && a > 0 && b > 0 && s > 0]]
nDist /: DistributionParameterAssumptions[nDist[a_, b_, m_, s_]] := 
 Element[{a, b, s, m}, Reals] && a > 0 && b > 0 && s > 0
nDist /: Random`DistributionVector[nDist[a_, b_, m_, s_], n_, prec_] :=

    RandomVariate[ExponentialDistribution[a], n, 
    WorkingPrecision -> prec] - 
   RandomVariate[ExponentialDistribution[b], n, 
    WorkingPrecision -> prec] + 
   RandomVariate[NormalDistribution[m, s], n, 
    WorkingPrecision -> prec];

(* Fitting: This uses Mean, central moments 2 and 3 and 4th cumulant \
but it often does not provide a solution *)

nDistParam[data_] := Module[{mn, vv, m3, k4, al, be, m, si},
      mn = Mean[data];
      vv = CentralMoment[data, 2];
      m3 = CentralMoment[data, 3];
      k4 = Cumulant[data, 4];
      al = 
    ConditionalExpression[
     Root[864 - 864 m3 #1^3 - 216 k4 #1^4 + 648 m3^2 #1^6 + 
        36 k4^2 #1^8 - 216 m3^3 #1^9 + (-2 k4^3 + 27 m3^4) #1^12 &, 
      2], k4 > Root[-27 m3^4 + 4 #1^3 &, 1]];
      be = ConditionalExpression[

     Root[2 Root[
           864 - 864 m3 #1^3 - 216 k4 #1^4 + 648 m3^2 #1^6 + 
             36 k4^2 #1^8 - 
             216 m3^3 #1^9 + (-2 k4^3 + 27 m3^4) #1^12 &, 
           2]^3 + (-2 + 
           m3 Root[
              864 - 864 m3 #1^3 - 216 k4 #1^4 + 648 m3^2 #1^6 + 
                36 k4^2 #1^8 - 
                216 m3^3 #1^9 + (-2 k4^3 + 27 m3^4) #1^12 &, 
              2]^3) #1^3 &, 1], k4 > Root[-27 m3^4 + 4 #1^3 &, 1]];
      m = mn - 1/al + 1/be;
      si = 
    Sqrt[Abs[-al^-2 - be^-2 + vv ]];(*Ensure positive*)
      {al, 
    be, m, si}];

nDistLL = 
  Compile[{a, b, m, s, {x, _Real, 1}}, 
   Total[Log[
     1/(2 (a + 
           b)) a b (E^(a (m + (a s^2)/2 - x)) Erfc[(m + a s^2 - 
             x)/(Sqrt[2] s)] + 
        E^(b (-m + (b s^2)/2 + x)) Erfc[(-m + b s^2 + 
             x)/(Sqrt[2] s)])]](*, CompilationTarget->"C", 
   RuntimeAttributes->{Listable}, Parallelization->True*)];

nlloglike[data_, a_?NumericQ, b_?NumericQ, m_?NumericQ, s_?NumericQ] := 
  nDistLL[a, b, m, s, data];

nFit[data_] := Module[{a, b, m, s, a0, b0, m0, s0, res},

      (* So far have not found a good way to quickly estimate a and \
b.  Starting assumption is that they both = 2,then m0 ~= 
   Mean and s0 ~= 
   StandardDeviation it seems to work better if a and b are not the \
same at start. *)

   {a0, b0, m0, s0} = nDistParam[data];(*may give Undefined values*)

     If[! (VectorQ[{a0, b0, m0, s0}, NumericQ] && 
       VectorQ[{a0, b0, s0}, # > 0 &]),
            m0 = Mean[data];
            s0 = StandardDeviation[data];
            a0 = 1;
            b0 = 2;];
   res = {a, b, m, s} /. 
     FindMaximum[
       nlloglike[data, Abs[a], Abs[b], m,  
        Abs[s]], {{a, a0}, {b, b0}, {m, m0}, {s, s0}},
               Method -> "PrincipalAxis"][[2]];
      {Abs[res[[1]]], Abs[res[[2]]], res[[3]], Abs[res[[4]]]}];

nFit[data_, {a0_, b0_, m0_, s0_}] := Module[{a, b, m, s, res},
      res = {a, b, m, s} /. 
     FindMaximum[
       nlloglike[data, Abs[a], Abs[b], m, 
        Abs[s]], {{a, a0}, {b, b0}, {m, m0}, {s, s0}},
               Method -> "PrincipalAxis"][[2]];
      {Abs[res[[1]]], Abs[res[[2]]], res[[3]], Abs[res[[4]]]}];

dDist /: PDF[dDist[a_, b_, m_, s_], x_] := 
  PDF[nDist[a, b, m, s], Log[x]]/x;
dDist /: CDF[dDist[a_, b_, m_, s_], x_] := 
  CDF[nDist[a, b, m, s], Log[x]];
dDist /: EstimatedDistribution[data_, dDist[a_, b_, m_, s_]] := 
  dDist[Sequence @@ nFit[Log[data]]];
dDist /: EstimatedDistribution[data_, 
   dDist[a_, b_, m_, 
    s_], {{a_, a0_}, {b_, b0_}, {m_, m0_}, {s_, s0_}}] := 
  dDist[Sequence @@ nFit[Log[data], {a0, b0, m0, s0}]];
dDist /: Quantile[dDist[a_, b_, m_, s_], p_] := 
 Module[{x}, x /. FindRoot[CDF[dDist[a, b, m, s], x] == p, {x, s}]] /;
   0 < p < 1
dDist /: Quantile[dDist[a_, b_, m_, s_], p_] :=  
 Module[{x}, 
   x /. FindRoot[ CDF[dDist[a, b, m, s], x] == #, {x, s}] & /@ p] /; 
  VectorQ[p, 0 < # < 1 &]
dDist /: Quantile[dDist[a_, b_, m_, s_], p_] := -Infinity /; p == 0
dDist /: Quantile[dDist[a_, b_, m_, s_], p_] := Infinity /; p == 1
dDist /: DistributionDomain[dDist[a_, b_, m_, s_]] := 
 Interval[{0, Infinity}]
dDist /: DistributionParameterQ[dDist[a_, b_, m_, s_]] := ! 
  TrueQ[Not[Element[{a, b, s, m}, Reals] && a > 0 && b > 0 && s > 0]]
dDist /: DistributionParameterAssumptions[dDist[a_, b_, m_, s_]] := 
 Element[{a, b, s, m}, Reals] && a > 0 && b > 0 && s > 0
dDist /: Random`DistributionVector[dDist[a_, b_, m_, s_], n_, prec_] :=
   Exp[RandomVariate[ExponentialDistribution[a], n, 
     WorkingPrecision -> prec] - 
       RandomVariate[ExponentialDistribution[b], n, 
     WorkingPrecision -> prec] + 
    RandomVariate[NormalDistribution[m, s], n, 
     WorkingPrecision -> prec]];

Điều này cho phép tôi điều chỉnh các tham số phân phối và tạo các tệp PDF và CDF . Một ví dụ về các ô:

Plot[PDF[dDist[3.77, 1.34, -2.65, 0.40], x], {x, 0, .3}, 
 PlotRange -> All]
Plot[CDF[dDist[3.77, 1.34, -2.65, 0.40], x], {x, 0, .3}, 
 PlotRange -> All]

Bây giờ tôi đã xác định a functionđể tính tuổi thọ trung bình (xem câu hỏi này để được giải thích).

MeanResidualLife[start_, dist_] := 
 NExpectation[X \[Conditioned] X > start, X \[Distributed] dist] - 
  start
MeanResidualLife[start_, limit_, dist_] := 
 NExpectation[X \[Conditioned] start <= X <= limit, 
   X \[Distributed] dist] - start

Cái đầu tiên không đặt giới hạn như trong cái thứ hai mất nhiều thời gian để tính toán, nhưng cả hai đều hoạt động.

Bây giờ tôi cần tìm tối thiểu của MeanResidualLifehàm cho cùng một phân phối (hoặc một số biến thể của hàm) hoặc giảm thiểu nó.

Tôi đã thử một số biến thể về điều này:

FindMinimum[MeanResidualLife[x, dDist[3.77, 1.34, -2.65, 0.40]], x]
FindMinimum[MeanResidualLife[x, 1, dDist[3.77, 1.34, -2.65, 0.40]], x]

NMinimize[{MeanResidualLife[x, dDist[3.77, 1.34, -2.65, 0.40]], 
  0 <= x <= 1}, x]
NMinimize[{MeanResidualLife[x, 1, dDist[3.77, 1.34, -2.65, 0.40]], 0 <= x <= 1}, x]

Chúng dường như chạy mãi mãi hoặc chạy vào:

Power :: infy: Biểu thức vô hạn 1 / 0. gặp phải. >>

Các MeanResidualLifechức năng áp dụng cho một đơn giản nhưng có hình dạng tương tự như chương trình phân phối mà nó có một tối thiểu duy nhất:

Plot[PDF[LogNormalDistribution[1.75, 0.65], x], {x, 0, 30}, 
 PlotRange -> All]
Plot[MeanResidualLife[x, LogNormalDistribution[1.75, 0.65]], {x, 0, 
  30},
 PlotRange -> {{0, 30}, {4.5, 8}}]

Cả hai:

FindMinimum[MeanResidualLife[x, LogNormalDistribution[1.75, 0.65]], x]
FindMinimum[MeanResidualLife[x, 30, LogNormalDistribution[1.75, 0.65]], x]

cho tôi câu trả lời (nếu có một loạt tin nhắn trước) khi được sử dụng với LogNormalDistribution.

Bất kỳ suy nghĩ về làm thế nào để làm điều này để làm việc cho phân phối tùy chỉnh được mô tả ở trên?

Tôi có cần thêm các ràng buộc hoặc tùy chọn không?

Tôi có cần xác định một cái gì đó khác trong định nghĩa của các bản phân phối tùy chỉnh không?

Có lẽ FindMinimumhoặc NMinimizechỉ cần chạy lâu hơn (Tôi đã chạy chúng gần một giờ mà không có kết quả). Nếu vậy tôi chỉ cần một số cách để tăng tốc độ tìm tối thiểu của hàm? Bất cứ đề nghị về làm thế nào?

Có Mathematicacách nào khác để làm điều này?

Đã thêm 9 tháng 2 5:50 PM EST:

Bất cứ ai cũng có thể tải xuống bài thuyết trình của Oleksandr Pavlyk về việc tạo các bản phân phối trong Mathematica từ hội thảo Công nghệ Wolfram 2011 'Tạo phân phối của riêng bạn' tại đây . Các bản tải xuống bao gồm sổ ghi chép, 'ExampleOfParametricDistribution.nb'dường như đưa ra tất cả các phần cần thiết để tạo một bản phân phối mà người ta có thể sử dụng như các bản phân phối đi kèm với Mathicala.

Nó có thể cung cấp một số câu trả lời.

Theo như tôi thấy, vấn đề là (như bạn đã viết), MeanResidualLifephải mất một thời gian dài để tính toán, ngay cả đối với một đánh giá duy nhất. Bây giờ, các FindMinimumhàm tương tự hoặc cố gắng tìm tối thiểu cho hàm. Tìm một mức tối thiểu đòi hỏi hoặc phải đặt đạo hàm đầu tiên của hàm 0 và giải một giải pháp. Vì chức năng của bạn khá phức tạp (và có thể không khác biệt), nên khả năng thứ hai là thực hiện tối thiểu hóa số, đòi hỏi nhiều đánh giá về chức năng của bạn. Ergo, nó rất rất chậm.

Tôi khuyên bạn nên thử nó mà không có phép thuật Mathicala.

Trước tiên hãy xem nó là gì MeanResidualLife, như bạn đã định nghĩa nó. NExpectationhoặc Expectationtính giá trị mong đợi . Đối với giá trị mong đợi, chúng tôi chỉ cần PDFphân phối của bạn. Hãy trích xuất nó từ định nghĩa của bạn ở trên thành các hàm đơn giản:

pdf[a_, b_, m_, s_, x_] := (1/(2*(a + b)))*a*b*
    (E^(a*(m + (a*s^2)/2 - x))*Erfc[(m + a*s^2 - x)/(Sqrt[2]*s)] + 
    E^(b*(-m + (b*s^2)/2 + x))*Erfc[(-m + b*s^2 + x)/(Sqrt[2]*s)])
pdf2[a_, b_, m_, s_, x_] := pdf[a, b, m, s, Log[x]]/x;

Nếu chúng tôi vẽ pdf2, nó trông giống hệt như Lô của bạn

Plot[pdf2[3.77, 1.34, -2.65, 0.40, x], {x, 0, .3}]

Bây giờ đến giá trị mong đợi. Nếu tôi hiểu chính xác, chúng ta phải tích hợp x * pdf[x]từ -infđến +infmột giá trị mong đợi bình thường.

x * pdf[x] giống như

Plot[pdf2[3.77, 1.34, -2.65, 0.40, x]*x, {x, 0, .3}, PlotRange -> All]

và giá trị mong đợi là

NIntegrate[pdf2[3.77, 1.34, -2.65, 0.40, x]*x, {x, 0, \[Infinity]}]
Out= 0.0596504

Nhưng vì bạn muốn giá trị mong đợi giữa a startvà +infchúng ta cần tích hợp trong phạm vi này và vì PDF sau đó không còn tích hợp thành 1 trong khoảng nhỏ hơn này, tôi đoán rằng chúng ta phải bình thường hóa kết quả được chia cho tích phân của PDF trong phạm vi này. Vì vậy, dự đoán của tôi cho giá trị kỳ vọng ràng buộc trái là

expVal[start_] := 
    NIntegrate[pdf2[3.77, 1.34, -2.65, 0.40, x]*x, {x, start, \[Infinity]}]/
    NIntegrate[pdf2[3.77, 1.34, -2.65, 0.40, x], {x, start, \[Infinity]}]

Và đối với MeanResidualLifebạn trừ startnó, cho

MRL[start_] := expVal[start] - start

Lô đất nào

Plot[MRL[start], {start, 0, 0.3}, PlotRange -> {0, All}]

Có vẻ hợp lý, nhưng tôi không phải là chuyên gia. Vì vậy, cuối cùng chúng tôi muốn giảm thiểu nó, tức là tìm startchức năng này là tối thiểu cục bộ. Mức tối thiểu dường như là khoảng 0,05, nhưng hãy tìm một giá trị chính xác hơn bắt đầu từ dự đoán đó

FindMinimum[MRL[start], {start, 0.05}]

và sau một số lỗi (chức năng của bạn không được xác định dưới 0, vì vậy tôi đoán trình thu nhỏ chọc vào một chút trong vùng cấm đó) chúng tôi nhận được

{0,0418137, {bắt đầu -> 0,0584312}}

Vì vậy, tối ưu nên có start = 0.0584312với một cuộc sống còn lại trung bình là 0.0418137.

Tôi không biết điều này có đúng không, nhưng có vẻ hợp lý.