R中约束优化的非单调输出 问题

constOptim函数是R，它给了我一组参数估计。这些参数估计值是一年中12个不同点的支出值，应该是单调递减的

我需要它们是单调的，并且每个参数之间的间隙适合我心目中的应用程序。为此，支出价值的模式很重要，而不是绝对价值。我猜在优化术语中，这意味着与参数估计的差异相比，我需要较小的公差

最小工作示例（具有简单实用功能）

我试图修复它 我试过：

• 增加公差（这在带有

  outer.eps=1e-10

  的代码中高于此值）
• 增加迭代次数（这在代码中高于

  outer.iterations=100

  ）
• 提高初始参数值的质量。我用我的实际案例做了这件事（相同，但使用了更复杂的效用函数），但没有解决问题
• 通过增加预算或将效用函数乘以标量来扩展问题

关于constOptim的其他问题 其他SO问题侧重于编写constOptim约束的困难，例如：

---

我没有发现任何检查公差或对输出不满意的地方

这并不是一个确切的答案，但它比一条评论要长，应该会有所帮助

我认为你的问题有一个解析解——如果你在测试一个优化算法，知道这个很好

这里是预算固定为1.0时的情况

analytical.solution <- function(rho=0.9, T=10) {
    sapply(seq_len(T) - 1, function(t) (rho ^ (2*t)) * (1 - rho^2) / (1 - rho^(2*T)))
}
sum(analytical.solution())  # Should be 1.0, i.e. the budget

---

analytic.solution您是否尝试在函数上强制使用梯度（并指定不同的
optim
方法）？我没有使用过
constrOptim
，但这似乎是一件值得尝试的事情。或者改变你的contstraint矩阵和向量（ui，ci），这样每两个月之间就有一个关系。嗨@CarlWitthoft，我基本上没有梯度，因为我对优化理论不太了解，也没有信心指定梯度。我还认为应该有一种方法可以在没有梯度的情况下解决这个问题（尽管可能需要更长的时间）。至于其他optim包，我通常使用OptimX，但在本例中不能使用，因为这会导致每个参数都是无限的。我需要在优化中指定x1+x2+…+是的，就像我猜的那样，将ci和ui扩展到矩阵和向量是其中的一个重要部分。谢谢Adrian。据我所知，这个问题是通过@CarlWitthoft所提到的梯度表达式来解决的。如果有一种方法不需要梯度，那就太好了，但我想没有。我不认为ui和ci扮演了很大的角色，因为附加的非负性约束永远不会绑定。在没有梯度函数的情况下施加这些附加约束并不能解决问题，而梯度函数可以解决问题（要看到这一点，需要ρ=0.996）。不过，为了完整性，最好有这些约束条件。非常感谢您的帮助。@Stuart渐变不是必需的——请参阅上面我的后续编辑。@Adrian我同意rho=0.9的情况。运行代码时，round（abs（…）语句给出的错误非常小，当您绘制它时，您会得到一个单调的模式。但是，在代码中仅将rho更改为0.996会导致更高的错误和非单调模式“plot（1:10，result4$par）”。我仍然认为梯度是解决方案。在rho很低的情况下，梯度并不重要。@Stuart，我明白了，我得到的结果和你得到的结果一样，rho=0.996。然而，constrOptim调优参数会影响输出——我将在回复的底部添加一个示例。
plot( Time_Array , Optimal_Spending)

analytical.solution <- function(rho=0.9, T=10) {
    sapply(seq_len(T) - 1, function(t) (rho ^ (2*t)) * (1 - rho^2) / (1 - rho^(2*T)))
}
sum(analytical.solution())  # Should be 1.0, i.e. the budget

analytical.solution <- function(rho=0.9, T=10) {
    sapply(seq_len(T) - 1, function(t) (rho ^ (2*t)) * (1 - rho^2) / (1 - rho^(2*T)))
}
candidate.solution <- analytical.solution()
sum(candidate.solution)  # Should be 1.0, i.e. the budget

objfn <- function(x, rho=0.9, T=10) {
    stopifnot(length(x) == T)
    sum(sqrt(x) * rho ^ (seq_len(T) - 1))
}
objfn.grad <- function(x, rho=0.9, T=10) {
    rho ^ (seq_len(T) - 1) * 0.5 * (1/sqrt(x))
}

## Sanity check the gradient
library(numDeriv)
all.equal(grad(objfn, candidate.solution), objfn.grad(candidate.solution))  # True

ui <- rbind(matrix(data=-1, nrow=1, ncol=10), diag(10))  # First row: budget constraint; other rows: x >= 0
ci <- c(-1, rep(10^-8, 10))
all(ui %*% candidate.solution - ci >= 0)  # True, the candidate solution is admissible
result1 <- constrOptim(theta=rep(0.01, 10), f=objfn, ui=ui, ci=ci, grad=objfn.grad, control=list(fnscale=-1))
round(abs(result1$par - candidate.solution), 4)  # Essentially zero
result2 <- constrOptim(theta=candidate.solution, f=objfn, ui=ui, ci=ci, grad=objfn.grad, control=list(fnscale=-1))
round(abs(result2$par - candidate.solution), 4)  # Essentially zero

result3 <- constrOptim(theta=rep(0.01, 10), f=objfn, ui=ui, ci=ci, grad=NULL, control=list(fnscale=-1))
round(abs(result3$par - candidate.solution), 4)  # Still very close to zero
result4 <- constrOptim(theta=c(10^-6, 1-10*10^-6, rep(10^-6, 8)), f=objfn, ui=ui, ci=ci, grad=NULL, control=list(fnscale=-1))
round(abs(result4$par - candidate.solution), 4)  # Still very close to zero

candidate.solution <- analytical.solution(rho=0.996)
candidate.solution  # Should be close to rep(1/10, 10) as discount factor is close to 1.0

result5 <- constrOptim(theta=c(10^-6, 1-10*10^-6, rep(10^-6, 8)), f=objfn,
                       ui=ui, ci=ci, grad=objfn.grad, control=list(fnscale=-1), rho=0.996)
round(abs(result5$par - candidate.solution), 4)
plot(result5$par)  # Looks nice when we used objfn.grad, as you pointed out

play.with.tuning.parameter <- function(mu) {
    result <- constrOptim(theta=c(10^-6, 1-10*10^-6, rep(10^-6, 8)), f=objfn,
                          mu=mu, outer.iterations=200, outer.eps = 1e-08,
                          ui=ui, ci=ci, grad=NULL, control=list(fnscale=-1), rho=0.996)
    return(mean(diff(result$par) < 0))
}

candidate.mus <- seq(0.01, 1, 0.01)
fraction.decreasing <- sapply(candidate.mus, play.with.tuning.parameter)
candidate.mus[fraction.decreasing == max(fraction.decreasing)]  # A few little clusters at 1.0
plot(candidate.mus, fraction.decreasing)  # ...but very noisy

result6 <- constrOptim(theta=c(10^-6, 1-10*10^-6, rep(10^-6, 8)), f=objfn,
                          mu=candidate.mus[which.max(fraction.decreasing)], outer.iterations=200, outer.eps = 1e-08,
                          ui=ui, ci=ci, grad=NULL, control=list(fnscale=-1), rho=0.996)
plot(result6$par)
round(abs(result6$par - candidate.solution), 4)