การลด NExpectation สำหรับการแจกจ่ายแบบกำหนดเองใน Mathematica

สิ่งนี้เกี่ยวข้องกับคำถามก่อนหน้านี้จากย้อนกลับไปในเดือนมิถุนายน:

การคำนวณความคาดหวังสำหรับการแจกแจงแบบกำหนดเองใน Mathematica

ฉันมีการกระจายแบบผสมที่กำหนดเองโดยใช้การแจกแจงแบบกำหนดเองที่สองตามด้วยบรรทัดที่กล่าวถึง@Sashaในคำตอบจำนวนหนึ่งในปีที่ผ่านมา

รหัสที่กำหนดการแจกแจงดังนี้:

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]];

ซึ่งจะช่วยให้ฉันเพื่อให้พอดีกับพารามิเตอร์การจัดจำหน่ายและสร้างไฟล์ PDFและCDF ของ ตัวอย่างของการแปลง:

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]

ตอนนี้ฉันได้นิยามการfunctionคำนวณค่าเฉลี่ยชีวิตที่เหลืออยู่ (ดูคำถามนี้สำหรับคำอธิบาย)

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

ครั้งแรกของสิ่งเหล่านี้ที่ไม่ได้ตั้งค่า จำกัด ในครั้งที่สองใช้เวลานานในการคำนวณ แต่พวกเขาทั้งสองทำงาน

ตอนนี้ฉันต้องการค้นหาขั้นต่ำของ MeanResidualLifeฟังก์ชันสำหรับการแจกแจงแบบเดียวกัน (หรือการเปลี่ยนแปลงของมัน) หรือย่อให้เล็กสุด

ฉันได้ลองมาหลายรูปแบบแล้ว:

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]

สิ่งเหล่านี้ดูเหมือนจะทำงานตลอดไปหรือพบกับ:

พลังงาน :: infy: พบนิพจน์ไม่สิ้นสุด 1/1 >>

MeanResidualLifeฟังก์ชั่นที่ใช้กับที่เรียบง่าย แต่มีรูปร่างคล้าย ๆ แสดงให้เห็นว่าการกระจายว่ามันมีขั้นต่ำเดียว:

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}}]

ทั้งสอง:

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

ให้ฉันตอบ (ถ้ามีพวงของข้อความเป็นครั้งแรก) LogNormalDistributionเมื่อใช้ร่วมกับ

มีความคิดเกี่ยวกับวิธีทำให้สิ่งนี้ทำงานให้กับการแจกจ่ายที่กำหนดเองที่อธิบายไว้ข้างต้นหรือไม่

ฉันจำเป็นต้องเพิ่มข้อ จำกัด หรือตัวเลือกหรือไม่?

ฉันต้องกำหนดอย่างอื่นในคำจำกัดความของการแจกแจงแบบกำหนดเองหรือไม่?

อาจจะFindMinimumหรือNMinimizeเพียงแค่ต้องทำงานอีกต่อไป (ฉันใช้พวกเขาเกือบชั่วโมงเพื่อประโยชน์) ถ้าเป็นเช่นนั้นฉันแค่ต้องการวิธีเร่งความเร็วในการหาฟังก์ชั่นขั้นต่ำ? ข้อเสนอแนะใด ๆ เกี่ยวกับอย่างไร

ไม่Mathematicaได้มีวิธีการทำเช่นนี้อีก?

เพิ่ม 9 ก.พ. 5:50 PM EST:

ทุกคนสามารถดาวน์โหลดOleksandr Pavlyk ของการนำเสนอเกี่ยวกับการสร้างการกระจายใน Mathematica จากปี 2011 การประชุมเชิงปฏิบัติการวุลแฟรมเทคโนโลยีการประชุม 'สร้างการกระจายตัวคุณเอง' ที่นี่ การดาวน์โหลดนั้นรวมถึงโน้ตบุ๊ก'ExampleOfParametricDistribution.nb'ที่ดูเหมือนจะวางชิ้นส่วนทั้งหมดที่จำเป็นในการสร้างการกระจายที่สามารถใช้เช่นการแจกแจงที่มาพร้อมกับ Mathematica

มันอาจให้คำตอบบางอย่าง

เท่าที่ฉันเห็นปัญหาคือ (ตามที่คุณเขียนไปแล้ว) ซึ่งMeanResidualLifeใช้เวลานานในการคำนวณแม้จะเป็นการประเมินครั้งเดียว ตอนนี้FindMinimumหรือฟังก์ชันที่คล้ายกันพยายามค้นหาฟังก์ชันขั้นต่ำสุด การค้นหาขั้นต่ำจำเป็นต้องตั้งค่าอนุพันธ์อันดับแรกของฟังก์ชั่นศูนย์และแก้ปัญหาสำหรับการแก้ปัญหา เนื่องจากฟังก์ชั่นของคุณค่อนข้างซับซ้อน (และอาจไม่แตกต่างกัน) ความเป็นไปได้ที่สองคือการทำตัวเลขให้เล็กที่สุดซึ่งต้องการการประเมินฟังก์ชันของคุณมากมาย เออร์โกมันช้ามาก

ฉันขอแนะนำให้ลองโดยไม่ต้องใช้เวทมนตร์ Mathematica

ก่อนอื่นเรามาดูว่าMeanResidualLifeมันคืออะไรตามที่คุณนิยามไว้ NExpectationหรือExpectationคำนวณค่าที่คาดหวัง สำหรับค่าที่คาดหวังเราเพียงต้องการการPDFกระจายของคุณ ลองแยกจากนิยามข้างบนลงในฟังก์ชั่นง่ายๆ:

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;

ถ้าเราพล็อต pdf2 ดูเหมือนว่าพล็อตของคุณ

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

ตอนนี้ค่าที่คาดหวัง ถ้าผมเข้าใจอย่างถูกต้องเราจะต้องบูรณาการx * pdf[x]จาก-infไป+infสำหรับค่าคาดว่าปกติ

x * pdf[x] ดูเหมือนกับ

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

และค่าที่คาดหวังคือ

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

แต่เนื่องจากคุณต้องการค่าที่คาดหวังระหว่าง startและ+infเราจำเป็นต้องรวมในช่วงนี้และเนื่องจาก PDF นั้นไม่รวมเข้ากับ 1 ในช่วงเวลาที่เล็กลงอีกต่อไปฉันเดาว่าเราต้องทำให้ผลลัพธ์ถูกหารด้วยอินทิกรัลของ PDF ใน ช่วงนี้ ดังนั้นฉันเดาค่าคาดหวังซ้ายคือ

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]}]

และสำหรับการMeanResidualLifeลบคุณstartจากมันให้

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

ซึ่งแปลงเป็น

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

ดูน่าเชื่อถือ แต่ฉันไม่มีความเชี่ยวชาญ ในที่สุดเราก็ต้องการลดมันลงนั่นคือหาstartที่ฟังก์ชั่นนี้เป็นค่าต่ำสุดในท้องถิ่น ค่าต่ำสุดน่าจะอยู่ที่ประมาณ 0.05 แต่ลองหาค่าที่แน่นอนมากกว่าเริ่มจากการเดานั้น

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

และหลังจากข้อผิดพลาดบางอย่าง (ฟังก์ชั่นของคุณไม่ได้กำหนดไว้ต่ำกว่า 0 ดังนั้นฉันเดาว่า minimizer โผล่ออกมาเล็กน้อยในพื้นที่ต้องห้ามนั้น) เราได้รับ

{0.0418137, {start -> 0.0584312}}

ดังนั้นค่าที่เหมาะสมควรอยู่ที่start = 0.0584312ค่าเฉลี่ยอายุการใช้งานของ0.0418137มีชีวิตที่เหลือเฉลี่ยของ

ฉันไม่รู้ว่านี่ถูกต้องหรือไม่ แต่ดูเหมือนน่าเชื่อถือ