I am trying to optimize an equation in R, but it seems like I can only minimize it. My question is: How do I maximize my equation?
p = 0.00379
W_0 = 0.3*10^6
L = 0.1489*10^6
u <- function(x,n){
if(n != 1){
(x^{1-n})/1-n
}
else{
log(x)
}
}
aslan <- function(a,n,l){
p*u(W_0-L+a*L-a*p*L*(1+l),n)+(1-p)*u(W_0-a*p*L*(1+l),n)
}
optimize(aslan,c(0,1),n=0.8,l=0.5)
Related
I am trying to run the following loop for calculating MLE as
l = matrix(0, tj, n)
For n or tj greater than 1000 this loop will be supper slow, is there anyway to improve this code in a more efficient way?
Thanks,
for (t in 1:tj) {
for (k in 1:n) {
if(S[t]==1) {
for(c in 1:C) {
l[t,k]=l[t,k]+(dt*(exp(alpha[c])*exp(-(X[k]-mx[c])^2/2/sx[c]^2))*mvnpdf(x=matrix(m[t,]),mean=mu[[c]],varcovM=sig[[c]], Log = FALSE))*exp(-LAN2[k]*dt)
}
} else {
l[t,k]=exp(-LAN2[k]*dt)
}
}
}
I am trying to make a Mandelbrot set code in R from scratch without using any predefined functions. But I am getting an error message saying-
In complex(real = rl, imaginary = hig) :
imaginary parts discarded in coercion
I think that means complex numbers can't be stored in vectors.
Please tell me whether I am right or wrong and also please help me to solve this error.
Below is my code.
listx=c()
z=0
inmbs=F
imgdispl=matrix(c(),441 ,441 )
for (hig in seq(-220,220,1)){
for (wid in seq(-220,220,1)){
listx=c()
z=0
for (k in 0:5){
inmbs=F
xx=z^2
rl=xx+wid
l = complex(real = rl, imaginary = hig)
if (l %in% listx){
inmbs=T
break
}
else{
append(listx,l)
z=l
}
}
if (inmbs==T){
imgdispl[hig+221,wid+221]=1
}
else{
imgdispl[hig+221,wid+221]=0
}
}
}
image(imgdispl)
updated code:
listx=c()
z=0
inmbs=F
imgdispl=matrix(c(0),441 ,441 )
for (hig in seq(-220,220,1)){
for (wid in seq(-220,220,1)){
listx=c()
z=0
for (k in 0:5){
inmbs=F
xx=z^2
coor = complex(real = wid/15, imaginary = hig/15)
l=xx+coor
if (l %in% listx){
inmbs=T
break
}
else{
append(listx,l)
z=l
}
}
if (inmbs==T){
imgdispl[hig+221,wid+221]=1
}
else{
imgdispl[hig+221,wid+221]=0
}
}
}
image(imgdispl)
If you debug your code you'll see that rl becomes complex.
The message tells you that only the real part is used in the call to:
l = complex(real = rl, imaginary = hig)
If you follow these instructions, you get:
z=0
N=10
inmbs=F
imgdispl=matrix(c(0),441 ,441 )
for (hig in seq(-220,220,1)){
for (wid in seq(-220,220,1)){
coor = complex(real = wid/220, imaginary = hig/220)
z=0
for (k in 0:N){
inmbs=F
if ((Re(z)^2+Im(z)^2)>4){
inmbs=T
break
}
z = z^2 + coor
}
if (inmbs==T){
imgdispl[hig+221,wid+221]=1
}
else{
imgdispl[hig+221,wid+221]=0
}
}
}
image(imgdispl)
I am building a simple ant colony optimization code in R, but I have a problem in compiling a function to obtain the optimum route for each ant using the "break" statement. There is always appear an error saying that "missing value where TRUE/FALSE needed" in my looping. Here is the code
rm(list = ls())
x = c(11.7057,17.4151,1.4992,14.9609,9.5711)
y = c(11.1929,10.7112,17.0964,12.2228,6.7928)
n = length(x)
m = 20
t = matrix(0.0001,ncol=n,nrow=n)
beta = 1
alpha = 5
miter = 100
d = matrix(c(rep(0,n*n)),ncol=n,byrow=FALSE)
for (i in 1:n){
for (j in 1:n){
d[i,j] = sqrt((x[i]-x[j])^2+(y[i]-y[j])^2)
}
}
d
h = matrix(c(rep(0,n*n)),ncol=n,byrow=FALSE)
for (i in 1:n){
for (j in 1:n){
if (d[i,j]==0){
h[i,j]=0
}
else{
h[i,j]=1/d[i,j]
}
}
}
h
antour <- function(a1,a2,a3,a4,a5,a6,a7){
for (i in 1:m){
mh = h
for (j in 1:n-1){
a = start_places[i,j]
mh[,c(a)]=0
temp = (t[c(a),]^alpha)*(mh[c(a),]^beta)
q = sum(temp)
p = (1/q)*temp
r = runif(1)
s = 0
for (k in 1:n){
s = s+p[k]
start_places[i,j+1] = k
if (r <= s){
break
}
print(start_places)
}
}
}
new_places = start_places
}
for (i in 1:miter){
start_places = matrix(c(rep(1,m)),ncol=1)
tour = antour(a1=start_places,a2=m,a3=n,a4=h,a5=t,a6=alpha,a7=beta)
}
I expect that in the looping process, the start_places[i,j+1]=k when the value of r <= s and obtain the optimum route for each ant, but the actual output is an error always appears as follows
output is Error in if (r <= s) { : missing value where TRUE/FALSE needed
I was asked to implement function that calculates n-dimensional matrix determinant using Laplace expansion. This involves recursion. I developed this:
minor<-function(A,i,j) {
return(A[c(1:(i-1),(i+1):dim(A)[1]),c(1:(j-1),(j+1):dim(A)[2])])
}
determinantRec<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1) return(X[1][1])
else {
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k][i]*(-1)^(k+i)*determinantRec(minor(X,k,i),k)
}
return(s)
}
}
where k in determinantRec(X,k) function indicates which row I want to use Laplace expansion along of.
My problem is when I run determinantRec(matrix(c(1,2,3,4),nrow = 2,ncol = 2),1) this error appears:
C stack usage 7970628 is too close to the limit
What is wrong with my code?
#julia, there is one simple type in your code. Just remove the '*' at the end of the definition of 's'. And don't indent the recursion.
determinantRek<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1)
return(X[1,1])
if (dim(X)[1] == 2 && dim(X)[2] == 2)
return(X[1,1]*X[2,2]-X[1,2]*X[2,1])
else
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k,i]*(-1)^(k+i)
determinantRek(X[-k,-i],k)
}
return(s)
}
I did this way and works just fine, although it is super slow, compared to the det function in base R
laplace_expansion <- function(mat){
det1 <- function(mat){
mat[1]*mat[4]-mat[2]*mat[3]
}
determinant <- 0
for(j in 1:ncol(mat)){
mat1 <- mat[-1,-j]
if(nrow(mat1) == 2){
determinant <- determinant+mat[1,j]*(-1)^(1+j)*det1(mat1)
}else{
val <- mat[1,j]*(-1)^(1+j)
if(val != 0){
determinant <- determinant+val*laplace_expansion(mat1)
}
}
}
return(determinant)
}
This is my approach, I think it's cleaner.
deter <- function(X) {
stopifnot(is.matrix(X))
stopifnot(identical(ncol(X), nrow(X)))
if (all(dim(X) == c(1, 1))) return(as.numeric(X))
i <- 1:nrow(X)
out <- purrr::map_dbl(i, function(i){
X[i, 1] * (-1)^(i + 1) * deter(X[-i, -1, drop = FALSE])
})
return(sum(out))
}
Thank you #ArtemSokolov and #MrFlick for pointing the problem cause, it was it. I also discovered that this code does not calculate properly the determinant of 2x2 matrix. After all it looks like that:
determinantRek<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1)
return(X[1,1])
if (dim(X)[1] == 2 && dim(X)[2] == 2)
return(X[1,1]*X[2,2]-X[1,2]*X[2,1])
else
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k,i]*(-1)^(k+i)*
determinantRek(X[-k,-i],k)
}
return(s)
}
Debuging with browser() was also helpful :)
Using:
mean (x, trim=0.05)
Removes 2.5% from each side of the distribution, which is fine for symmetrical two-tailed data. But if I have one tailed or highly asymmetric data I would like to be able to remove just one side of the distribution. Is there a function for this or do I have write myself a new one? If so, how?
Just create a modified mean.default. First look at mean.default:
mean.default
Then modify it to accept a new argument:
mean.default <-
function (x, trim = 0, na.rm = FALSE, ..., side="both")
{
if (!is.numeric(x) && !is.complex(x) && !is.logical(x)) {
warning("argument is not numeric or logical: returning NA")
return(NA_real_)
}
if (na.rm)
x <- x[!is.na(x)]
if (!is.numeric(trim) || length(trim) != 1L)
stop("'trim' must be numeric of length one")
n <- length(x)
if (trim > 0 && n) {
if (is.complex(x))
stop("trimmed means are not defined for complex data")
if (any(is.na(x)))
return(NA_real_)
if (trim >= 0.5)
return(stats::median(x, na.rm = FALSE))
lo <- if( side=="both" || side=="right" ){ floor(n * trim) + 1 }else{1}
hi <- if( side=="both" || side=="left" ){ n + 1 - (floor(n * trim) + 1 ) }else{ n}
x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
cat(c(length(x), lo , hi) )
}
.Internal(mean(x))
}
I don't know of a function. Something like the following would trim off the upper tail of the distribution before taking the mean.
upper.trim.mean <- function(x,trim) {
x <- sort(x)
mean(x[1:floor(length(x)*(1-trim))])
}
This should account for either side, or both sides for trimming.
trim.side.mean <- function(x, trim, type="both"){
if (type == "both") {
mean(x,trim)}
else if (type == "right") {
x <- sort(x)
mean(x[1:floor(length(x)*(1-trim))])}
else if (type == "left"){
x <- sort(x)
mean(x[max(1,floor(length(x)*trim)):length(x)])}}
one.sided.trim.mean <- function(x, trim, upper=T) {
if(upper) trim = 1-trim
data <- mean(x[x<quantile(x, trim)])
}
I found that all the answers posted do not match when checked manually. So I created one of my own. Its long but simple enough to understand
get_trim <- function(x,trim,type)
{
x <- sort(x)
ans<-0
if (type=="both")
{
for (i in (trim+1):(length(x)-trim))
{
ans=ans+x[i];
}
print(ans/(length(x)-(2*trim)))
}
else if(type=="left")
{
for (i in (trim+1):(length(x)))
{
ans=ans+x[i];
}
print(ans/(length(x)-trim))
}
else if (type=="right")
{
for (i in 1:(length(x)-trim))
{
ans=ans+x[i];
}
print(ans/(length(x)-trim))
}
}