web-dev-qa-db-fra.com

Minimiser NExpectation pour une distribution personnalisée dans Mathematica

Cela concerne une question antérieure de juin:

Calcul des attentes pour une distribution personnalisée dans Mathematica

J'ai une distribution mixte personnalisée définie à l'aide d'une deuxième distribution personnalisée suivant les lignes décrites par @Sasha dans un certain nombre de réponses au cours de la dernière année.

Le code définissant les distributions suit:

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

Cela me permet d'ajuster les paramètres de distribution et de générer des PDF et des CDF . Un exemple des parcelles:

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]

enter image description here

Maintenant, j'ai défini un function pour calculer la durée de vie résiduelle moyenne (voir cette question pour une explication).

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

Le premier d'entre eux qui ne fixe pas de limite comme dans le second prend beaucoup de temps à calculer, mais ils fonctionnent tous les deux.

Maintenant, je dois trouver le minimum de la fonction MeanResidualLife pour la même distribution (ou une variation de celle-ci) ou la minimiser.

J'ai essayé un certain nombre de variantes à ce sujet:

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]

Ceux-ci semblent fonctionner pour toujours ou se heurter à:

Power :: infy: Expression infinie 1/0. rencontrée. >>

La fonction MeanResidualLife appliquée à une distribution plus simple mais de forme similaire montre qu'elle a un minimum unique:

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

enter image description here

Aussi les deux:

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

donnez-moi des réponses (si avec un tas de messages d'abord) lorsqu'il est utilisé avec le LogNormalDistribution.

Avez-vous des idées sur la façon de faire fonctionner cela pour la distribution personnalisée décrite ci-dessus?

Dois-je ajouter des contraintes ou des options?

Dois-je définir autre chose dans les définitions des distributions personnalisées?

Peut-être que le FindMinimum ou NMinimize a juste besoin de fonctionner plus longtemps (je les ai exécutés presque une heure en vain). Si oui, ai-je juste besoin d'un moyen d'accélérer la recherche du minimum de la fonction? Des suggestions sur la façon dont?

Mathematica a-t-il une autre façon de procéder?

Ajouté le 9 février 17h50 EST:

Tout le monde peut télécharger la présentation d'Oleksandr Pavlyk sur la création de distributions dans Mathematica à partir de l'atelier Wolfram Technology Conference 2011 'Créer votre propre distribution' ici . Les téléchargements incluent le cahier, 'ExampleOfParametricDistribution.nb' qui semble disposer de toutes les pièces nécessaires pour créer une distribution que l'on peut utiliser comme les distributions fournies avec Mathematica.

Il peut fournir une partie de la réponse.

plotwolfram-mathematicaprobabilitycalculusmathematica-8
238
Jagra

Pour autant que je vois, le problème est (comme vous l'avez déjà écrit), que MeanResidualLife prend beaucoup de temps à calculer, même pour une seule évaluation. Maintenant, les fonctions FindMinimum ou similaires essaient de trouver un minimum pour la fonction. Pour trouver un minimum, il faut soit définir la dérivée première de la fonction zéro et résoudre une solution. Puisque votre fonction est assez compliquée (et probablement pas différentiable), la deuxième possibilité est de faire une minimisation numérique, ce qui nécessite de nombreuses évaluations de votre fonction. Ergo, c'est très très lent.

Je suggère de l'essayer sans magie Mathematica.

Voyons d'abord ce qu'est le MeanResidualLife, tel que vous l'avez défini. NExpectation ou Expectation calcule le valeur attendue . Pour la valeur attendue, nous avons seulement besoin du PDF de votre distribution. Extrayons-le de votre définition ci-dessus dans des fonctions simples:

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;

Si nous traçons le pdf2, il ressemble exactement à votre tracé

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

Plot of PDF

Maintenant à la valeur attendue. Si je comprends bien, nous devons intégrer x * pdf[x] de -inf à +inf pour une valeur normale attendue.

x * pdf[x] ressemble à

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

Plot of x * PDF

et la valeur attendue est

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

Mais puisque vous voulez la valeur attendue entre un start et +inf nous devons intégrer dans cette plage, et puisque le PDF ne s'intègre plus alors à 1 dans cet intervalle plus petit, je suppose que nous devons normaliser le résultat en divisant par l'intégrale du = PDF dans cette plage. Donc, je suppose que la valeur attendue à gauche est

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

Et pour le MeanResidualLife vous en soustrayez start, donnant

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

Quelles parcelles comme

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

Plot of Mean Residual Life

Semble plausible, mais je ne suis pas un expert. Donc finalement nous voulons le minimiser, c'est-à-dire trouver le start pour lequel cette fonction est un minimum local. Le minimum semble être d'environ 0,05, mais trouvons une valeur plus exacte à partir de cette supposition

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

et après quelques erreurs (votre fonction n'est pas définie en dessous de 0, donc je suppose que le minimiseur pique un peu dans cette région interdite) nous obtenons

{0,0418137, {start -> 0,0584312}}

Donc, l'optimum devrait être à start = 0.0584312 avec une durée de vie résiduelle moyenne de 0.0418137.

Je ne sais pas si c'est correct, mais cela semble plausible.

11
azt