Plot Mathematica中自定义分布的最小化期望
这与6月份早些时候的一个问题有关: 我有一个定制的混合发行版,使用第二个定制发行版,按照Plot Mathematica中自定义分布的最小化期望,plot,wolfram-mathematica,probability,calculus,mathematica-8,Plot,Wolfram Mathematica,Probability,Calculus,Mathematica 8,这与6月份早些时候的一个问题有关: 我有一个定制的混合发行版,使用第二个定制发行版,按照@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
@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]];
现在我定义了一个函数
来计算平均剩余寿命(请参阅以获取解释)
这些可能会永远持续下去,也可能会遇到:
Power::infy:无限表达式1/0。遇到的问题。>>
应用于更简单但形状相似的分布的平均剩余寿命
函数表明,它有一个最小值:
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
一起使用时,给我答案(如果先有一堆消息)
关于如何让它在上述定制发行版中工作,您有什么想法吗
我是否需要添加约束或选项
我是否需要在自定义发行版的定义中定义其他内容
也许findminium
或nmimimimize
只需要运行更长的时间(我已经运行了将近一个小时,但没有效果)。如果是这样的话,我需要一些方法来加速寻找函数的最小值吗?有什么建议吗
Mathematica
是否有其他方法可以做到这一点
美国东部时间2月9日下午5:50添加:
任何人都可以从Wolfram Technology Conference 2011研讨会“创建您自己的发行版”下载Oleksandr Pavlyk关于在Mathematica中创建发行版的演示文稿。下载内容包括笔记本,“ExampleOfParametricDistribution.nb”
,它似乎列出了创建一个发行版所需的所有部分,人们可以像Mathematica附带的发行版一样使用该发行版
它可能提供了一些答案。据我所知,问题是(正如你已经写的那样),
平均剩余寿命
计算时间很长,即使是一次计算。现在,findminium
或类似函数试图找到函数的最小值。求一个最小值需要设置函数的一阶导数为零,然后求解一个解。由于函数非常复杂(可能不可微),第二种可能是进行数值最小化,这需要对函数进行多次求值。因此,它非常非常慢
我建议不用魔法也试试
首先,让我们看看您定义的平均剩余寿命是什么<代码>下一个预期
或预期
计算预测值。
对于预期值,我们只需要您的发行版的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
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]}]
但是,因为你想要一个start
和+inf
之间的期望值,我们需要在这个范围内积分,因为PDF在这个较小的间隔内不再积分为1,我想我们必须将结果标准化,除以这个范围内PDF的积分。所以我对左界期望值的猜测是
NIntegrate[pdf2[3.77, 1.34, -2.65, 0.40, x]*x, {x, 0, \[Infinity]}]
Out= 0.0596504
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]}]
对于平均剩余寿命
从中减去开始
,给出
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以下,所以我猜极小值在那个禁止区域中有点戳),我们得到
{0.0418137,{start->0.0584312}
因此,最佳值应为start=0.0584312
,平均剩余寿命0.0418137
我不知道这是否正确,但似乎有道理。我不是数学专家,但我在其他地方也遇到过类似的问题。当域从0开始时,您似乎遇到了问题。试着从0.1开始,然后再向上,看看会发生什么。@Makketronix--谢谢你。有趣的同步性,考虑到我在三年后开始重温这一点。我不确定我能帮到你,但你可以试着去问一下。祝你好运!你试过了吗:?在SearchforExpectations+1上有很多关于它的文章——我刚刚看到了这一点,所以我需要解决它,但我认为你将问题划分为可解决的步骤的方式很有意义。此外,您的MRL函数的绘图,当然看起来很准确。非常感谢,只要我有时间研究你的答案,我会尽快回到这里。
FindMinimum[MRL[start], {start, 0.05}]