Intersection of two spheres (maximization ) in R - r

I want to find intersection of two spheres in R(which is a circle) and find max and min of coordinates on that circle.
The spheres are :
S1: x^2+y^2+z^2=16
S2: (x+1)^2+(y+1)^2+(z+1)^2=27
library(rgl)
s1 =spheres3d(x = 0, y = 0, z = 0, radius = 4)
s2 =spheres3d(x = -1, y = -1, z = -1, radius = sqrt(27))
I think the plane which the circle is on that will be: ( is there any way that R can find this from S1&S2?).
P1: x+y+z=4
So now I have a maximization problem (P1 subject to S1 and S2): So I did this code:
eval_f <- function( x ) {
return( list( "objective" = (x[1]+x[2]+x[3])-4,
"gradient" = c(1,1,1) ))}
# constraint functions
eval_g_eq <- function( x ) {
constr <- cbind(c( (x[1]+1)^2 + (x[2]+1)^2 + (x[3]+1)^2 - 27) , c(x[1]^2+x[2]^2+x[3]^2-16))
grad <- cbind ( c( 2.0*(x[1]+1),
2.0*(x[2]+1),
2.0*(x[3]+1)
),c(2*x[1],2*x[2],2*x[3]) )
return( list( "constraints"=constr, "jacobian"=grad ) )
}
# initial values
x0 <- c( 0, 0, 0 )
local_opts <- list( "algorithm" = "NLOPT_LD_MMA",
"xtol_rel" = 1.0e-7 )
opts <- list( "algorithm" = "NLOPT_LD_AUGLAG",
"xtol_rel" = 1.0e-7,
"maxeval" = 1000,
"local_opts" = local_opts )
res <- nloptr( x0=x0,
eval_f=eval_f,eval_g_eq=eval_g_eq,
opts=opts)
print( res )
Link to the manual - nloptr function.
But I think there is a mistake!

Related

Maximization problem with R package nloptr

Good morning to everyone,
I've a problem with a maximization with the R package nloptr. I've to maximize a correlation between a variable, call it "a", and a linear combination of other variables. Changing the weigths of the varibles in order to maximize the correlation. This is an example:
library(nloptr)
#create a dataset for the example
data=data.frame("a"=c(1:10), "b"=c(2,3,4,2,3,1,2,4,1,6), "c"=rep(c(10,15), 5))
#Objective Function
eval_f <- function(x,y)
{
return (cor(data$a,(xdata$b+ydata$c)))
}
eval_f(2,2)
#Equality constraints
eval_g_eq <- function(x,y)
{
return ( x+y-1 )
}
#Lower and upper bounds
lb <- c(0,0)
ub <- c(1,1)
#initial values
x0 <- c(0.5,0.5)
#Set optimization options.
local_opts <- list( "algorithm" = "NLOPT_LD_MMA", "xtol_rel" = 1.0e-15 )
opts <- list( "algorithm"= "NLOPT_GN_ISRES",
"xtol_rel"= 1.0e-15,
"maxeval"= 160000,
"local_opts" = local_opts,
"print_level" = 0 )
res <- nloptr ( x0 = x0,
eval_f = eval_f,
lb = lb,
ub = ub,
eval_g_eq = eval_g_eq,
opts = opts
)
This give me the error:
Error in .checkfunargs(eval_f, arglist, "eval_f") :
eval_f requires argument 'y' but this has not been passed to the 'nloptr' function.
Could someone help me?
Thanks.

Instead of using a function f(x, y) use a function f(x) where x is a vector with two components:
eval_f <- function(x) cor(data$a,(x[1]*data$b+x[2]*data$c))
eval_g_eq <- function(x) sum(x) -1
lb <- c(0,0)
ub <- c(1,1)
x0 <- c(0.5,0.5)
local_opts <- list( "algorithm" = "NLOPT_LD_MMA", "xtol_rel" = 1.0e-15 )
opts <- list(
"algorithm"= "NLOPT_GN_ISRES",
"xtol_rel"= 1.0e-15,
"maxeval"= 160000,
"local_opts" = local_opts,
"print_level" = 0
)
res <- nloptr (
x0 = x0,
eval_f = eval_f,
lb = lb,
ub = ub,
eval_g_eq = eval_g_eq,
opts = opts
)

How to rotate 3D Plotly continuous for R shiny App

I am trying to create a constant rotating 3D scatter plotly so that I can put it in my R shiny app. However, I can't seem to get it to constantly rotate (like this: https://codepen.io/etpinard/pen/mBVVyE).
I don't want to save it to an image/gif just directly use in my App. Can anyone provide any help to get it continuously rotating (I have little experience with Python)? I've tried this in the Viewer screen of R studio, but it doesn't rotate there.
library(plotly)
library(ggplot2)
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N,min= 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x,y,z)
for (i in seq(0,100, by=0.1)){
cam.zoom = 2
ver.angle = 0
graph <- plot_ly()%>%
add_trace(type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~x,
y = ~y,
z = ~z) %>%
layout(scene = list(
camera = list(
eye = list(
x = cos(i)*cam.zoom,
y = sin(i)*cam.zoom,
z = 0.3
),
center = list(
x = 0,
y = 0,
z = 0
)
)
)
)
graph
}
I am very new to plotly, so any help would be greatly appreciated.

We can reuse most of the JS code via htmlwidgets::onRender. You tagged the question shiny - wrapped it in an app accordingly:
library(shiny)
library(plotly)
library(htmlwidgets)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = 1.25,
y = 1.25,
z = 1.25
),
center = list(x = 0,
y = 0,
z = 0)
))) %>%
onRender("
function(el, x){
var id = el.getAttribute('id');
var gd = document.getElementById(id);
Plotly.update(id).then(attach);
function attach() {
var cnt = 0;
function run() {
rotate('scene', Math.PI / 180);
requestAnimationFrame(run);
}
run();
function rotate(id, angle) {
var eye0 = gd.layout[id].camera.eye
var rtz = xyz2rtz(eye0);
rtz.t += angle;
var eye1 = rtz2xyz(rtz);
Plotly.relayout(gd, id + '.camera.eye', eye1)
}
function xyz2rtz(xyz) {
return {
r: Math.sqrt(xyz.x * xyz.x + xyz.y * xyz.y),
t: Math.atan2(xyz.y, xyz.x),
z: xyz.z
};
}
function rtz2xyz(rtz) {
return {
x: rtz.r * Math.cos(rtz.t),
y: rtz.r * Math.sin(rtz.t),
z: rtz.z
};
}
};
}
")
})
}
shinyApp(ui, server)
The same can be done via plotlyProxy without additional JS - but it's not as smooth:
library(shiny)
library(plotly)
ui <- fluidPage(
plotlyOutput("graph")
)
server <- function(input, output, session) {
N <- 100
x <- rnorm(N, mean = 50, sd = 2.3)
y <- runif(N, min = 0, max = 100)
z <- runif(N, min = 4, max = 70)
luci.frame <- data.frame(x, y, z)
mySequence <- seq(0, 100, by = 0.1)
cam.zoom = 2
# ver.angle = 0
output$graph <- renderPlotly({
plot_ly(
type = "scatter3d",
mode = "markers",
data = luci.frame,
x = ~ x,
y = ~ y,
z = ~ z
) %>%
layout(scene = list(camera = list(
eye = list(
x = cos(mySequence[1]) * cam.zoom,
y = sin(mySequence[1]) * cam.zoom,
z = 0.3
),
center = list(x = 0,
y = 0,
z = 0)
)))
})
myPlotlyProxy <- plotlyProxy("graph")
count <- reactiveVal(1L)
observe({
invalidateLater(100)
plotlyProxyInvoke(myPlotlyProxy, "relayout", list(scene = list(camera = list(
eye = list(
x = cos(mySequence[isolate(count())]) * cam.zoom,
y = sin(mySequence[isolate(count())]) * cam.zoom,
z = 0.3
),
center = list(x = 0,
y = 0,
z = 0)
))))
isolate(count(count()+1))
if(count() > length(mySequence)){
count(1L)
}
})
}
shinyApp(ui, server)

Using NLOPT/Gurobi for solving mixed constraint optimization

I am currently working on a project, and I want to use R and NLOPT package (or Gurobi) to solve the following optimization problem:
Find min ||y-y_h||_L^2 such that x = Ay_h, y >= 0, where x, y are given vector of size 16*1, A = 16*24 matrix is also given.
My attempt:
R code
nrow=16;
ncol = 24;
lambda = matrix(sample.int(100, size = ncol*nrow, replace = T),nrow,ncol);
lambda = lambda - diag(lambda)*diag(x=1, nrow, ncol);
y = rpois(ncol,lambda) + rtruncnorm(ncol,0,1,mean = 0, sd = 1);
x = matrix (0, nrow, 1);
x_A1 = y[1]+y[2]+y[3];
x_A2 = y[4]+y[7]+y[3];
x_B1 = y[4]+y[5]+y[6];
x_B2 = y[11]+y[1];
x_C1 = y[7]+y[8]+y[9];
x_C2 = y[2]+y[5]+y[12];
x_D1 = y[10]+y[11]+y[12];
x_D2 = y[3]+y[6]+y[9];
x_E1 = y[13]+y[14]+y[15];
x_E2 = y[18]+y[19]+y[23];
x_F1 = y[20]+y[21]+y[19];
x_F2 = y[22]+y[16]+y[13];
x_G1 = y[23]+y[22]+y[24];
x_G2 = y[14]+y[17]+y[20];
x_H1 = y[16]+y[17]+y[18];
x_H2 = y[15]+y[21]+y[24];
d <- c(x_A1, x_A2,x_B1, x_B2,x_C1, x_C2,x_D1, x_D2,x_E1,
x_E2,x_F1, x_F2,x_G1, x_G2,x_H1, x_H2)
x <- matrix(d, nrow, byrow=TRUE)
A = matrix(c(1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, #x_A^1
0,0,0,1,0,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0, #x_A^2
0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, #x_B^1
1,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0, #x_B^2
0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, #x_C^1
0,1,0,0,1,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0, #x_C^2
0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0, #x_D^1
0,0,1,0,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, #x_D^2
0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0, #x_E^1
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,1,0, #x_E^2
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0, #x_F^1
0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,1,0,0,0,0,0,1,0,0, #x_F^2
0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,1,0,0,1,0,0,0,0, #x_G^2
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1, #x_G^1
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0, #x_H^1
0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,1,0,0,1), #x_H^2
nrow, ncol, byrow= TRUE)
Tried two codes to solve the problem: min ||y - y_h||_L^2 where x= Ay_h, y>=0 where x,y,A are all given above.
# f(x) = ||yhat-y||_L2
eval_f <- function( yhat ) {
return( list( "objective" = norm((mean(yhat-y))^2, type = "2")))
}
# inequality constraint
eval_g_ineq <- function( yhat ) {
constr <- c(0 - yhat)
return( list( "constraints"=constr ))
}
# equalities constraint
eval_g_eq <- function( yhat ) {
constr <- c( x-A%*%yhat )
return( list( "constraints"=constr ))
}
x0 <- y
#lower bound of control variable
lb <- c(matrix (0, ncol, 1))
local_opts <- list( "algorithm" = "NLOPT_LD_MMA",
"xtol_rel" = 1.0e-7 )
opts <- list( "algorithm" = "NLOPT_LD_AUGLAG",
"xtol_rel" = 1.0e-7,
"maxeval" = 1000,
"local_opts" = local_opts )
res <- nloptr( x0=x0,
eval_f=eval_f,
eval_grad_f = NULL,
lb=lb,
eval_g_ineq = eval_g_ineq,
eval_g_eq=eval_g_eq,
opts=opts)
print(res)
Gurobi code:
**#model <- list()
#model$B <- A
#model$obj <- norm((y-yhat)^2, type = "2")
#model$modelsense <- "min"
#model$rhs <- c(x,0)
#model$sense <- c('=', '>=')
#model$vtype <- 'C'
#result <- gurobi(model, params)
#print('Solution:')
#print(result$objval)
#print(result$yhat)**
My question: First, when I ran the R code above, it kept giving me this message:
Error in is.nloptr(ret) :
wrong number of elements in gradient of objective
In addition: Warning message:
In is.na(f0$gradient) :
is.na() applied to non-(list or vector) of type 'NULL'
I tried to avoid computing gradient, as I do not have any information on the density function of y. Could anyone please help me fix the error above?
For the Gurobi code, I got this message: Error: is(model$A, "matrix") || is(model$A, "sparseMatrix") || is(model$A, .... is not TRUE
But my matrix A is correctly inputted, so what does this error mean?

I start to use nloptr only several days ago. This question is already an old one but I will still answer it. when you are using 'nloptr' with 'NLOPT_LD_AUGLAG' algorithm, the 'LD' stands for local and using gradient... So you need to choose something else with 'LN' in the middle. For ex., 'NLOPT_LN_COBYLA' should work fine without gradient.
Actually you can just look up the nloptr package manual.

Minimization with R nloptr package - multiple equality constraints

Is it possible to specify more than one equality constraint in nloptr function in R? The code that I am trying to run is the following:
eval_f <- function( x ) {
return( list( "objective" = x[3]^2+x[4]^2,
"gradient" = c( 0,
0,
2*x[3],
2*x[4] ) ) )
}
# constraint functions
# equalities
eval_g_eq <- function( x ) {
constr <- c( x[1] + x[2] + x[3] - 4,
x[1]^2 + x[2]^2 + x[4] - 15
)
grad <- c( c(1, 1, 1, 0),
c(2*x[1], 2*x[2], 0, 1)
)
return( list( "constraints"=constr, "jacobian"=grad ) )
}
# initial values
x0 <- c( 1, 5, 5, 1 )
local_opts <- list( "algorithm" = "NLOPT_LD_MMA",
"xtol_rel" = 1.0e-7 )
opts <- list( "algorithm" = "NLOPT_LD_AUGLAG",
"xtol_rel" = 1.0e-7,
"maxeval" = 1000,
"local_opts" = local_opts )
res <- nloptr( x0=x0,
eval_f=eval_f,
eval_g_eq=eval_g_eq,
opts=opts)
print( res )
The result it produce is the following:
Current value of controls: -1.035323 3.093593 2.409501 0.2708714
However these values do not hold equality constraints, i.e.
-1.035323 + 3.093593 + 2.409501 = 4.467771
(-1.035323)^2 + 3.093593^2 + 0.2708714 = 10.91308
I guess that either it is impossible to specify multiple equality constraints in nloptr function or I passed them in the wrong way.
I did not find any example having more than one equality constraint in package documentation.
UPDATE
Ok, I solved it. The case was that specifying constr and grad in eval_g_eq, one should use rbind() instead of c().

I answered this in a different post recently for inequality constraints, but you should be able to return multiple equality constraints in a vector as well using c()
"multiple inequality constraints" - Minimization with R nloptr package

MC algorithm for a non-conjugate model

The model is Poisson likelihood and Gaussian prior. I worked out the posterior for the model and I think that I have it coded correctly but I'm having a lot of trouble trying to implement the algorithm. I know that it's just a simple matter of not defining my variables properly but I'm not seeing where the problems lie. The code that I have so far is:
# Poisson model
#
#
# Log of the unnormalized posterior density:
log.post.dens = function( theta, n, sum.y, mu0, sig0 )
{
alpha = (log.dpois(x, lamda=exp(theta)))*dnorm(x, mu0, sig0)
}
#++++++++++++++++++++++++++++++++++++++++++++++++++++++++
rw.sim = function( M, mu0, sig0, n, sum.y, sd.pd, theta.start )
{
# create theta array and initialize theta[1]
#
theta = rep( 0, M )
theta[1] = theta.start
acc.cnt = 0
for( ii in 2:M ) {
# Normal proposal distribution is centered at the current theta
#
theta.new = rnorm( 1, theta[ii-1], sd.pd )
log.alpha = log.post.dens( theta.new, n, sum.y, mu0, sig0 ) -
log.post.dens( theta[ii-1], n, sum.y, mu0, sig0 )
if( log.alpha > 0 || exp( log.alpha ) > runif( 1, 0, 1 ) )
{
theta[ii] = theta.new
acc.cnt = acc.cnt + 1
}
else
theta[ii] = theta[ii-1]
}
list( ac = acc.cnt, theta = theta )
}
#++++++++++++++++++++++++++++++++++++++++++++++++++++++++
n = 200
mu0 = log(10)
sig0 = 3
yy = rpois( n, exp( mu0 ))
sd.pd = 1
theta.start = mu0
M = 100000
print( paste("M =", M, " mu0 =", mu0, " sig0 =", sig0, "sd.pd =", sd.pd,
"start", theta.start ))
res = rw.sim( M, mu0, sig0, length(yy), sum( yy ), sd.pd, theta.start )
theta = res$theta
acc.rate = res$ac / M
corr = cor( theta[1:(M-1)], theta[2:M])
print( paste("acceptance rate =", acc.rate ))
print( paste("correlation =", corr ))
3
m = 1
if( m )
{
theta0 = theta
thin.const = 40
theta = theta[ seq( .1*length(theta), length(theta), thin.const )]
}
par( mfrow=c(2,2))
hist( theta, prob=T, breaks=32 )
x = seq( min( theta ), max( theta ), len=200 )
lines( x, dnorm( x, mu0, sig0 ), col = 2)
plot( theta, type=’l’ )
acf( theta )
##pacf( theta )
#++++++++++++++++++++++++++++
#
# Posterior predictive density for data on a grid
#
hist( yy, prob=T)
lim1 = max(yy) + 2
xx = 0:lim1
ppd = rep( 0, lim1+1 )
for( ii in 1:(lim1+1) )
{
ppd[ii] = (1/M)*sum(yy)*((log.dpois(x, lamda=exp(theta)))*dnorm(x, mu0, sig0))
}
points( xx+.5, ppd, col=2 )
lines( xx+.5, ppd, col=2 )
As I said it's my defining of parameters that's off but I'm not sure how to fix it.

Resources