Mathematica'da özel dağıtım için NExecectation'ı en aza indirme

Bu, Haziran ayında daha önceki bir soruyla ilgilidir:

Mathematica'da özel dağıtım beklentisini hesaplama

@SashaGeçen yıl bir dizi cevapta tartışılan çizgileri takip eden ikinci bir özel dağıtım kullanılarak tanımlanan özel bir karma dağıtımım var .

Dağılımları tanımlayan kod aşağıdaki gibidir:

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

Bu, dağıtım parametrelerine uymamı ve PDF ve CDF'ler oluşturmamı sağlıyor . Arsalara bir örnek:

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]

Şimdi functionortalama kalıntı ömrünü hesaplamak için bir tanımladım ( açıklama için bu soruya bakın ).

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

Bunlardan ilki, ikincisinde olduğu gibi bir sınır koymaz, hesaplanması uzun sürer, ancak ikisi de çalışır.

Şimdi MeanResidualLifeaynı dağıtım (veya bazı varyasyonları) için fonksiyonun minimumunu bulmam veya en aza indirmem gerekiyor.

Bu konuda bir çok varyasyon denedim:

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]

Bunlar ya sonsuza dek koşuyor ya da şöyle görünüyor:

Power :: infy: Sonsuz ifade 1/0 ile karşılaştı. >>

Daha MeanResidualLifebasit ama benzer şekilli bir dağılıma uygulanan işlev, tek bir minimum değere sahip olduğunu gösterir:

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

Ayrıca her ikisi de:

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

ile kullandığınızda bana cevaplar verin (ilk önce bir grup mesajla) LogNormalDistribution .

Yukarıda açıklanan özel dağıtım için bunun nasıl çalışacağına dair düşünceleriniz var mı?

Kısıtlamalar veya seçenekler eklemem gerekir mi?

Özel dağıtımların tanımlarında başka bir şey tanımlamam gerekir mi?

Belki FindMinimumveyaNMinimize sadece daha uzun çalıştırmak gerekir (boşuna yaklaşık bir saat koştum). Eğer öyleyse, fonksiyonun minimumunu bulmayı hızlandırmanın bir yoluna ihtiyacım var mı? Nasıl olduğuna dair herhangi bir öneriniz var mı?

MathematicaBunu yapmanın başka bir yolu var mı ?

Eklendi 9 Şub 17:50 EST:

Herkes indirebilirsiniz Oleksandr Pavlyk en Wolfram Teknoloji Konferansı 2011 atölye 'Kendi Dağılımı oluşturma' dan Mathematica dağılımlarını oluşturma hakkında sunum burada . İndirmeler, 'ExampleOfParametricDistribution.nb'Mathematica ile birlikte gelen dağıtımlar gibi kullanabileceğiniz bir dağıtım oluşturmak için gereken tüm parçaları ortaya koyan not defterini içerir .

Cevabın bir kısmını sağlayabilir.

Gördüğüm kadarıyla, sorun (daha önce yazdığınız gibi), MeanResidualLifetek bir değerlendirme için bile, hesaplanması uzun zaman alıyor. Şimdi FindMinimumveya benzeri işlevler, işlev için bir minimum bulmaya çalışır. Bir minimum bulmak için ya fonksiyonun ilk türevini sıfırlamak ve bir çözüm bulmak gerekir. İşleviniz oldukça karmaşık olduğundan (ve muhtemelen ayırt edilemediğinden), ikinci olasılık, işlevinizin birçok değerlendirmesini gerektiren sayısal bir minimizasyon yapmaktır. Ergo, çok çok yavaş.

Mathematica büyüsü olmadan denemenizi öneririm.

Önce MeanResidualLifetanımladığınız gibi ne olduğunu görelim . NExpectationveya beklenen değeriExpectation hesaplayın . Beklenen değer için, sadece dağıtımınıza ihtiyacımız var . Yukarıdaki tanımınızdan basit işlevlere çıkaralım: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'yi çizersek, tam olarak sizin planınız gibi görünür

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

Şimdi beklenen değere. Ben doğru anlamak biz entegre etmek zorunda x * pdf[x]den -infüzere +infnormal beklenen değeri.

x * pdf[x] benziyor

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

ve beklenen değer

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

Ancak a arasında beklenen değeri istediğiniz için startve +infbu aralıkta entegre etmemiz gerekiyor ve PDF artık bu daha küçük aralıkta 1 ile entegre olmadığından, sonucu PDF'nin integraline bölerek normalleştirmek zorundayız. bu aralık. Sola doğru beklenen değer için tahminim

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

Ve MeanResidualLifesen startondan çıkarıyorsun ,

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

Hangi parseller

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

Mantıklı görünüyor, ama ben uzman değilim. Son olarak, bunu en aza indirmek istiyoruz, yani startbu işlevin yerel bir minimum olduğunu bulmak. Minimum değer 0,05 civarındadır, ancak bu tahminden başlayarak daha kesin bir değer bulalım

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

ve bazı hatalardan sonra (fonksiyonunuz 0'ın altında tanımlanmadı, bu yüzden minimizer bu yasak bölgede biraz pok yapıyor)

{0.0418137, {başlangıç ​​-> 0.0584312}}

Bu nedenle optimum, start = 0.0584312ortalama kalıntı ömrü ile olmalıdır 0.0418137.

Bunun doğru olup olmadığını bilmiyorum, ama mantıklı görünüyor.