Take a look at this link.
I am trying to understand the following source code meant for finding stationary distribution of a matrix:
# Stationary distribution of discrete-time Markov chain
# (uses eigenvectors)
stationary <- function(mat)
{
x = eigen(t(mat))$vectors[,1]
as.double(x/sum(x))
}
I tested the following source code myself:
> rm(list=ls())
>
> P <- matrix(c(0.66, 0.34,
+ 0.66, 0.34), nrow=2, ncol=2, byrow = TRUE)
>
> x <- eigen(t(P))
> x$values
[1] 1 0
$vectors
[,1] [,2]
[1,] 0.8889746 -0.7071068
[2,] 0.4579566 0.7071068
> y <- x$vectors[,1]
> y
[1] 0.8889746 0.4579566
>
looks like the command
y <- x$vectors[,1]
is selecting the 1st column of the matrix.
Why wasn't that simply written like the following?
# Stationary distribution of discrete-time Markov chain
# (uses eigenvectors)
stationary <- function(mat)
{
x = eigen(t(mat))
y = x[,1]
as.double(y/sum(y))
}
What was the reason for introduction of a dollar sign and vector keyword?
Let's test out your proposal:
> P <- matrix(c(0.66, 0.34, 0.66, 0.34), nrow=2, ncol=2, byrow = TRUE)
> x <- eigen(t(P))
> print(x)
eigen() decomposition
$values
[1] 1 0
$vectors
[,1] [,2]
[1,] 0.8889746 -0.7071068
[2,] 0.4579566 0.7071068
> y = x[,1]
This would produce the following error message:
Error in x[, 1] : incorrect number of dimensions
eigen returns a named list, with eigenvalues named values and eigenvectors named vectors. To access this component of the list. we use the dollar sign. Hence, that is why the code x$vectors which extract the matrix.
Related
I have been told to implement the Levenberg-Marquardt algorithm in R studio, considering lambda's initial value equals 10. The algorithm must stop when the gradient's norm is lower than the tolerance. I also need to print the values that x1, x2, λ, ∇f(x), d1 and d2 take for each iteration. Any ideas on how to do it? Many thanks in advance
This is what I have:
library(pracma)
library(matlib)
MetodeLM<-function(f,xi,t)
{
l=10
stop=FALSE
x<-xi
k=0
while (stop==FALSE){
dk<- inv(hessian(f,x)+l*diag(diag(hessian(f,x))))
x1<-x+dk
if (Norm(grad(f,x1))<t){
stop<-TRUE
}
else{
if (f(x1) < f(x)){
l<-l/10
k<-k+1
stop<-FALSE
}
else{
l<-l*10
stop<-FALSE
}
}
}
}
Correcting a few mistakes in your code, the following implementation of Levenberg Marquadt's algorithm should work (note that the update rule for the algorithm is shown in the following figure):
library(pracma)
# tolerance = t, λ = l
LM <- function(f, x0, t, l=10, r=10) {
x <- x0
k <- 0
while (TRUE) {
H <- hessian(f, x)
G <- grad(f, x)
dk <- inv(H + l * diag(nrow(H))) %*% G # dk <- solve(H + l * diag(nrow(H)), G)
x1 <- x - dk # update rule
print(k) # iteration
# print(l) # λ
print(x1) # x1, x2
print(G) # ∇f(x)
print(dk) # d1, d2
if (Norm(G) < t) break
l <- ifelse(f(x1) < f(x), l / r, l * r)
k <- k + 1
x <- x1 # update the old point
}
}
For example, with the following function, the non-linear optimization algorithm will quickly find a local minimum point (in the 10th iteration) as shown below
f <- function(x) {
return ((x[1]^2+x[2]-25)^2 + (x[1]+x[2]^2-25)^2)
}
x0 <- rep(0,2)
LM(f, x0, t=1e-3, l=400, r=2)
# [1] 0
# [,1]
# [1,] 0.165563
# [2,] 0.165563
# [1] -50 -50
# [,1]
# [1,] -0.165563
# [2,] -0.165563
# [1] 1
# [,1]
# [1,] 0.7986661
# [2,] 0.7986661
# [1] -66.04255 -66.04255
# [,1]
# [1,] -0.6331031
# [2,] -0.6331031
# ...
# [1] 10
# [,1]
# [1,] 4.524938
# [2,] 4.524938
# [1] 0.0001194898 0.0001194898
# [,1]
# [1,] 5.869924e-07
# [2,] 5.869924e-07
The following animation shows the convergence to the local minimum point for the function:
The following one is with LoG function
I'm trying to calculate the euclidean distance between two matrices. I have already achieved that using 2 for loops but trying to vectorize the calculation to speed up. I'm using pdist as a benchmark to valid if the distance is calculated correctly.
Thanks to this post, https://medium.com/#souravdey/l2-distance-matrix-vectorization-trick-26aa3247ac6c, I tried to achieve the same thing in r with this code:
dist <- sqrt(rowSums(xtest**2)+rowSums(xtrain**2)-2*xtrain %*% t(xtest))
But the result is different from what comes out of pdist. I am not sure what's wrong with this.
Here are some codes
Create some data
xtest=matrix(cbind(c(0,0),c(1,31)),2,2,byrow=TRUE)
xtrain=matrix(cbind(c(9,2),c(4,15),c(7,8),c(-22,-2)),4,2,byrow=TRUE)
Calculate using double loops
mydist <- function(xtest,xtrain) {
euc.dist <- function(x1, x2) sqrt(sum((x1 - x2) ^ 2))
dist <- matrix(,nrow=nrow(xtrain),ncol=nrow(xtest))
for (i in 1:nrow(xtrain)){
for (j in 1:nrow(xtest)){
dist[i,j] <- euc.dist(xtrain[i,], xtest[j,])
}
}
return (dist)
}
> mydist(xtest,xtrain)
[,1] [,2]
[1,] 9.219544 30.08322
[2,] 15.524175 16.27882
[3,] 10.630146 23.76973
[4,] 22.090722 40.22437
The result is same as using pdist
> libdists <- pdist(xtrain,xtest)
> as.matrix(libdists)
[,1] [,2]
[1,] 9.219544 30.08322
[2,] 15.524175 16.27882
[3,] 10.630146 23.76973
[4,] 22.090721 40.22437
But if I use matrix multiplication method it's wrong
> mydist2 <- function(xtest,xtrain) {
+ dist <- sqrt(rowSums(xtest**2)+rowSums(xtrain**2)-2*xtrain %*% t(xtest))
+ return (dist)
+ }
> mydist2(xtest,xtrain)
[,1] [,2]
[1,] 9.219544 NaN
[2,] 34.684290 16.27882
[3,] 10.630146 NaN
[4,] 38.078866 40.22437
I have also tried to use mapply function
> mydist3 <- function(xtest,xtrain) {
+ euc.dist <- function(x1, x2) sqrt(sum((x1 - x2) ^ 2))
+ dist <- mapply(euc.dist, xtest,xtrain)
+ return (dist)
+ }
> mydist3(xtest,xtrain)
[1] 9 3 7 53 2 14 8 33
I think it goes element wise rather than takes each row as a vector to calculate the distance between two vectors.
Any suggestions will be appreciated!
Use two apply instances with the second nested in the first:
d1 <- apply(xtest, 1, function(x) apply(xtrain, 1, function(y) sqrt(crossprod(x-y))))
Check against pdist:
library(pdist)
d2 <- as.matrix(pdist(xtrain, xtest))
all.equal(d1, d2, tolerance = 1e-7)
## [1] TRUE
I hope I can find answer for this question here. I have this piece of code that I am trying to analyze closely,
alphas <- matrix(runif(900), ncol=3, byrow=TRUE)
z <- t(apply(alphas, 1, cumsum))
for(i in 1:nrow(z)){
z[i, ] <- z[i, ] / (1:ncol(z))
}
I am trying to understand what does z[i,]<- z[i,]/(1:ncol(z)) code is doing for the matrix alphas. I know we are dividing each column by the sequence of columns in the input matrix. I also know when using apply with margin 2, we apply the function we are interested in, which is in this case "cumsum" over the rows of matrix alphas. Thats basically what I know, I have no clue why the next line and what does to my matrix alphas?
I would appreciate some insigts
Thank you very much
With your code I would say you are calculating row-wise cumulative means of your alphas.
With the line in your loop you're doing a vector division that yields the averages of cumulative sums of each column.
Look what ncol(z) yields
> ncol(z)
[1] 3
So basically what you're doing with z[i, ] / (1:ncol(z)) in your loop is a division of each row by a vector, or sequence respectively, with length of column numbers, i.e. c(1, 2, 3) or just 1:3.
Consider the first row of your alphas and your z.
set.seed(42) # for sake of reproducibility
alphas <- matrix(runif(900), ncol=3, byrow=TRUE)
z <- t(apply(alphas, 1, cumsum))
> alphas[1, ]
[1] 0.9148060 0.9370754 0.2861395
> z[1, ]
[1] 0.914806 1.851881 2.138021
> cbind(alphas[1, 1], mean(c(alphas[1, 1:2])), mean(c(alphas[1, 1:3])))
[,1] [,2] [,3]
[1,] 0.914806 0.9259407 0.7126737
The core of your loop yields
> z[1, ] / 1:ncol(z)
[1] 0.9148060 0.9259407 0.7126737
So each element of a row of z[1, ] will be divided by its corresponding divisor of the vector, yielding the means of the aggregated cells of
Your loop simply does this for your whole z matrix.
Apropos—faster and more convenient in R we do this in a vectorized way within a function. Since you understand apply() you will understand sapply(). Which we will use by first defining a function.
FUN1 <- function(i){
z[i, ] / 1:ncol(z)
}
M <- t(sapply(1:nrow(z), FUN1))
> head(M, 3)
[,1] [,2] [,3]
[1,] 0.9148060 0.9259407 0.7126737
[2,] 0.8304476 0.7360966 0.6637630
[3,] 0.7365883 0.4356275 0.5094157
This yields the same as your loop but in the R way.
In one step we can do this saying
z <- t(sapply(seq_len(nrow(alphas)),
function(i) cumsum(alphas[i, ]) / seq_along(alphas[i, ])))
> head(z, 3)
[,1] [,2] [,3]
[1,] 0.9148060 0.9259407 0.7126737
[2,] 0.8304476 0.7360966 0.6637630
[3,] 0.7365883 0.4356275 0.5094157
I am using nleqslv package in R to solve nonlinear system of equations. The R codes are given below;
require(nleqslv)
x <- c(6,12,18,24,30)
NMfun1 <- function(k,n) {
y <- rep(NA, length(k))
y[1] <- -(5/k[1])+sum(x^k[2]*exp(k[3]*x))+2*sum(k[4]*x^k[2]*exp(-k[1]*x^k[2]*exp(k[3]*x)+k[3]*x)/(1-k[4]*exp(-k[1]*x^k[2]*exp(k[3]*x))))
y[2] <- -sum(log(x))-sum(1/(k[2]+k[3]*x))+sum(k[1]*x^k[2]*exp(k[3]*x)*log(x))+2*sum(k[1]*k[4]*exp(-k[1]*x^k[2]*exp(k[3]*x)+k[3]*x)*log(x)/(1-k[4]*exp(-k[1]*x^k[2]*exp(k[3]*x))))
y[3] <- -sum(x/(k[2]+k[3]*x))+sum(k[1]*x^(k[2]+1)*exp(k[3]*x))-sum(x)+2*sum(k[4]*x^k[2]*exp(-k[1]*x^k[2]*exp(k[3]*x)+k[3]*x)/(1-k[4]*exp(-k[1]*x^k[2]*exp(k[3]*x))))
y[4] <- -(5/(1-k[4]))+2*sum(exp(-k[1]*x^k[2]*exp(k[3]*x))/(1-k[4]*exp(-k[1]*x^k[2]*exp(k[3]*x))))
return(y)
}
kstart <- c(0.05, 0, 0.35, 0.9)
NMfun1(kstart)
nleqslv(kstart, NMfun1, control=list(btol=.0001),method="Newton")
The estimated values for k obtained are; 0.04223362 -0.08360564 0.14216026 0.37854908
But the estimated values of k are to be
greater than zero.
Ok. So you want real larger than 0 solutions if they exist of course.
Make a new function which squares the input argument before passing it to NMfun1. And then use the searchZeros function in the package nleqslv to search for solutions. Like this
NMfun1.alt <- function(k0,n) NMfun1(k0^2,n)
3 use set.seed for reproducibility
set.seed(413)
# generate 100 random starting values
xstart <- matrix(runif(4*100,min=0,max=1), nrow=100,ncol=4)
z <- searchZeros(xstart,NMfun1.alt)
z
ksol <- z$x^2
ksol
# in this case there are two solutions
NMfun1(ksol[1,])
NMfun1(ksol[2,])
The output of the last 4 non comment lines of this code are
> ksol <- z$x^2
> ksol
[,1] [,2] [,3] [,4]
[1,] 0.002951051 1.669142 0.03589502 0.001167185
[2,] 0.002951051 1.669142 0.03589502 0.001167185
> NMfun1(ksol[1,])
[1] 3.231138e-11 3.602561e-13 -4.665268e-12 -1.119105e-13
> NMfun1(ksol[2,])
[1] 1.532663e-12 1.085046e-14 6.894485e-14 -2.664535e-15
You will see that the solution contained in object z has a negative element. And that is squared.
From this experiment it appears that your system has a single positive solution.
I am trying to multiply matrices. The values within the matrices represent probabilities that are different for each cycle. Therefore, I use loop for to update the values within the matrix. At the beginning it works fine, but then I get the feedback: subscript out of boundaries. The error message is showing my next values [4,] 210, 323, 467. Why are they not displayed at the bottom?
> initial_patient_distribtion <- c (1000,0,0)
> aaa <- c(1,0.7,0.6,0.5,0.4)
> bbb <- c(1, 0.2,0.3, 0.4, 0.5)
> ccc <- c(1, 0.1,0.1,0.1,0.1)
>
> cycle_patient_distribution_dasa_no2nd[1,] <-initial_patient_distribtion
> for (i in 2:length(aaa)){
+ trans_matrix_dasa_no2nd <- matrix (,nrow=3,ncol=3)
+ trans_matrix_dasa_no2nd[1,] <- c(aaa[i],bbb[i],ccc[i])
+ trans_matrix_dasa_no2nd[2,] <- c(0,0.5,0.5)
+ trans_matrix_dasa_no2nd[3,] <- c(0,0,1)
+
+ cycle_patient_distribution_dasa_no2nd[i,] <- cycle_patient_distribution_dasa_no2nd[i-1,]%*%(trans_matrix_dasa_no2nd)}
Error in `[<-`(`*tmp*`, i, , value = c(210, 323, 467)) :
subscript out of bounds
>
> cycle_patient_distribution_dasa_no2nd
[,1] [,2] [,3]
[1,] 1000 0 0
[2,] 700 200 100
[3,] 420 310 270
Your for loop goes to length(aaa) (5) and tries to access cycle_patient_distribution_dasa_no2nd[i,] when i==5. However, you'll see that cycle_patient_distribution_dasa_no2nd[5,] throws an error because the dimensions of that matrix are 3x3.
If your code does what you want otherwise, then you need to either change the ending index in your for loop to 3, or modify the dimensions of your matrix:
trans_matrix_dasa_no2nd <- matrix (,nrow=length(aaa),ncol=3)