Minimiser NExpectation pour une distribution personnalisée dans Mathematica

238

Cela se rapporte à 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 discutées par @Sashadans 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'adapter les paramètres de distribution et de générer des PDF et 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]

entrez la description de l'image ici

Maintenant, j'ai défini un functionpour 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 MeanResidualLifefonction pour la même distribution (ou une certaine 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 MeanResidualLifefonction 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}}]

entrez la description de l'image ici

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 réflexions 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 FindMinimumou NMinimizejuste besoin de fonctionner plus longtemps (je les ai exécutés près d'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?

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

Ajouté le 9 févr.17: 50 PM EST:

Tout le monde peut télécharger de Oleksandr Pavlyk présentation sur la création des distributions à Mathematica de l'atelier Technology Conference 2011 Wolfram « 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.

plot wolfram-mathematica probability calculus mathematica-8 Jagra
la source
9
Pas expert en Mathematica, mais j'ai rencontré des problèmes similaires ailleurs. Il semble que vous rencontriez des problèmes lorsque votre domaine commence à 0. Essayez de commencer à 0,1 et plus et voyez ce qui se passe.
Makketronix
7
@Makketronix - Merci pour cela. Synchronicité amusante, étant donné que j'ai commencé à revoir cela après 3 ans.
Jagra
8
Je ne suis pas sûr de pouvoir vous aider, mais vous pouvez essayer de demander à partir du stackoverflow spécifique à Mathematica . Bonne chance!
Olivia Stork
4
Avez-vous essayé: reference.wolfram.com/language/ref/Expectation.html ?
Cplusplusplus
1
Il y a beaucoup d'articles à ce sujet sur zbmath.org Recherche d'attentes
Ivan V

Réponses:

11

Pour autant que je vois, le problème est (comme vous l'avez déjà écrit), cela MeanResidualLifeprend beaucoup de temps à calculer, même pour une seule évaluation. Maintenant, la FindMinimumou des fonctions similaires essaient de trouver un minimum pour la fonction. Trouver un minimum nécessite soit de définir la dérivée première de la fonction zéro et de 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érerais de l'essayer sans magie Mathematica.

Voyons d'abord ce que MeanResidualLifec'est, comme vous l'avez défini. NExpectationou Expectationcalculer la valeur attendue . Pour la valeur attendue, nous n'avons besoin que PDFde 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}]

Tracé de PDF

Maintenant à la valeur attendue. Si je comprends bien, nous devons intégrer x * pdf[x]de -infà +infpour 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]

Tracé de 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 comme vous voulez la valeur attendue entre a startet +infnous devons l'intégrer dans cette plage, et puisque le PDF ne s'intègre plus à 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 gamme. 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 MeanResidualLifevous en soustraire start, donnant

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

Quelles parcelles comme

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

Tracé de la durée de vie résiduelle moyenne

Semble plausible, mais je ne suis pas un expert. Donc finalement nous voulons le minimiser, c'est-à-dire trouver le startpour 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}}

L'optimum devrait donc être à start = 0.0584312une durée de vie résiduelle moyenne de 0.0418137.

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

azt
la source
+1 - Je viens de voir cela, donc je vais devoir y travailler, mais je pense que la façon dont vous avez divisé le problème en étapes résolubles a beaucoup de sens. En outre, l'intrigue de votre fonction MRL semble certainement parfaite. Merci beaucoup, j'y reviendrai dès que je pourrai prendre le temps d'étudier votre réponse.
Jagra