I am new to R and was trying to find a function which calculates JS divergence in R.
I can see that R has KLdiv for calculating KL divergence, but is there anything available for JS divergence?
I was looking for a simple implementation of the JS divergence rather than an R library. Since I did not see one in any of the responses, I came up with the one below.
Assuming we have the following input distributions:
# p & q are distributions so their elements should sum up to 1
p <- c(0.00029421, 0.42837957, 0.1371827, 0.00029419, 0.00029419,
0.40526004, 0.02741252, 0.00029422, 0.00029417, 0.00029418)
q <- c(0.00476199, 0.004762, 0.004762, 0.00476202, 0.95714168,
0.00476213, 0.00476212, 0.00476202, 0.00476202, 0.00476202)
The Jensen-Shannon divergence would be:
n <- 0.5 * (p + q)
JS <- 0.5 * (sum(p * log(p / n)) + sum(q * log(q / n)))
> JS
[1] 0.6457538
For more than 2 distributions (which has already been discussed here) we need a function to compute the Entropy:
H <- function(v) {
v <- v[v > 0]
return(sum(-v * log(v)))
}
Then the JS divergence would be:
JSD <- function(w, m) {
return(H(m %*% w) - apply(m, 2, H) %*% w)
}
> JSD(w = c(1/3, 1/3, 1/3), m = cbind(p, q, n))
[,1]
[1,] 0.4305025
Where w is a vector of weights which should sum up to 1 and m is a matrix with the input distributions as columns.
In case anyone is still searching for an answer (I was), there is a function to calculate this in the R package phyloseq: http://www.plosone.org/article/info%3Adoi%2F10.1371%2Fjournal.pone.0061217
I also found this tutorial useful: http://enterotype.embl.de/enterotypes.html
According to wikipedia Jensen-Shannon divergence is a transformation of the KL divergence. Applying the formula from the definition should give you the JS divergence then...
See: http://en.wikipedia.org/wiki/Jensen%E2%80%93Shannon_divergence
Related
I am both new to maximum likelihood and writing loop functions in R. I am playing around with the function in Matlab and I'm wondering if its correctly transcribed in R? There is not easy way for me to check it since I'm not familiar with MATLAB. The code uses equations (1) and (3) from the paper.
#Matlab Code. The matlab code imposes two conditions under which lnpq takes different values depending on q.
p=N/K;
if q == 0
lnqp = log(p);
else
lnqp =((p^q)-1)/q;
end
Y = ((aa *((p*K/Ka)-1))-1)*lnqp;
#R code. In the R code function, I'm trying to impose similar conditions on lnpq. Here is my attempt. However, I don't know how to compare if the values obtained from Matlab are similar to R. I am not sure how to verify across platforms
p <- c(1:00)
skewfun <- function(aa, K, Ka, q){
Y <- ifelse(q = 0, ((aa *((p*K/Ka)-1))-1)*log(p),((aa *((p*K/Ka)-1))-1)*((p^q)-1)/q)
}
The inputs can be either numeric scalars or vectors. If you don't have Matlab you could install Octave which is free and compatible with Matlab and try the original Matlab code there and then compare the outputs for a test case to the result of running the following on the same test case to ensure that it gives the same result.
f <- function(aa, N, K, Ka, q) {
p <- N / K
lnqp <- ifelse(q == 0, log(p), (p^q - 1) / q)
Y <- (aa * (p * K / Ka - 1) - 1) * lnqp
Y
}
aa <- 1; N <- 1; K <- 1; Ka <- 1; q <- 1 # test data: change to use your data
f(aa, N, K, Ka, q)
## [1] 0
You can use matconv package to facilitate automatic code conversion:
matconv::mat2r(inMat = "Y = ((aa *((p*K/Ka)-1))-1)*lnqp;")
will return:
$matCode
[1] "Y = ((aa *((p*K/Ka)-1))-1)*lnqp;"
$rCode
[1] "Y <- ((aa *((p*K/Ka)-1))-1)*lnqp"
R mailing list has also useful bash script that you may use for that purpose.
I am currently trying to implement a bigger simulation exercise but i'm stuck with this bit.
The aim is to find the vector p* (2x1) that maximizes this function (p* = argmax of h):
Equation
Also Y and q are given and all other quantities in the function are defined using them.
P_priority_i <- function(unknown, arg1, arg2, i){
mu = 2
delta = 0.00001
c <- c(pbar[i,] + rep(delta,m))
e <- rep(0,2)
s <- rep(0,2)
for (j in 1:m){
e[j] <- x[i,j] + sum(A[[j]][i,]*min(pbar[i,j],arg1[i,j]))
}
if(y[i,'countries'] != 'IT'){
s[1] <- min(pbar[i,1],(max(0,sum(arg2*e)))/arg2[1])
s[2] <- min(pbar[i,2],(max(0,sum(arg2*e)-arg2[1]*s[1]))/arg2[2])
value <- -0.5*t(c-unknown)%*%diag(arg2/(c-s))%*%(c-unknown)
return(value)
} else {
s[2] <- min(pbar[i,2],(max(0,sum(arg2*e)))/arg2[2])
s[1] <- min(pbar[i,1],(max(0,sum(arg2*e)-arg2[2]*s[2]))/arg2[1])
value <- -0.5*t(c-unknown)%*%diag(arg2/(c-s))%*%(c-unknown)
return(value)
}}
I've checked the formulation of the function, whose output is a scalar, and it is correct.
I also have 3 constraints on p*:
Constraints
where \bar{p} and x are given quantities.
I've found quadprog package but I don't know how to solve this particular problem using solve.QP function () which supposes an objective function as (− d^T b + 0.5 b^T D b). The problem is that the argument of my maximization should be p and not (c-p) (also the constrains are formulated w.r.t p).
How can i set up this in R?
I hope you are well. I was wondering if you could help me with the question provided in the attached link, please. Below the link I attach an R-code that solves the problem recursively for particular values of the parameters of the distributions involved. However, I realized that this method is inefficient. Thanks a lot for your help.
How to obtain the probability distribution of a sum of dependent discrete random variables more efficiently
library(boot) # The library boot is necessary to use the command inv.logit.
TMax <- 500 # In this R-code, I am using TMax instead of using T.
M <- 2000
beta0 <- 1
beta1 <- 0.5
Prob_S <- function(k, r){ # In this R-code, I am using r instead of using t.
if(r == 1){
Aux <- dbinom(x = k, size = M, prob = inv.logit(beta0))
}
if(r %in% 2:TMax){
Aux <- 0
for(u in 0:k){
Aux <- Aux + dbinom(x = k - u, size = M - u,
prob = inv.logit(beta0 + beta1 * u)) * Prob_S(u, r - 1)
}
}
Aux
}
m <- 300
P <- Prob_S(k = m, r = TMax) # Computing P takes a loooong time. :(
I am re-writting an algorithm I did in C++ in R for practice called the Finite Difference Method. I am pretty new with R so I don't know all the rules regarding vector/matrix multiplication. For some reason I am getting a non-conformable arguments error when I do this:
ST_u <- matrix(0,M,1)
ST_l <- matrix(0,M,1)
for(i in 1:M){
Z <- matrix(gaussian_box_muller(i),M,1)
ST_u[i] <- (S0 + delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
ST_l[i] <- (S0 - delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
}
I get this error:
Error in sqrt(T) %*% Z : non-conformable arguments
Here is my whole code:
gaussian_box_muller <- function(n){
theta <- runif(n, 0, 2 * pi)
rsq <- rexp(n, 0.5)
x <- sqrt(rsq) * cos(theta)
return(x)
}
d_j <- function(j, S, K, r, v,T) {
return ((log(S/K) + (r + (-1^(j-1))*0.5*v*v)*T)/(v*(T^0.5)))
}
call_delta <- function(S,K,r,v,T){
return (S * dnorm(d_j(1, S, K, r, v, T))-K*exp(-r*T) * dnorm(d_j(2, S, K, r, v, T)))
}
Finite_Difference <- function(S0,K,r,sigma,T,M,delta_S){
ST_u <- matrix(0,M,1)
ST_l <- matrix(0,M,1)
for(i in 1:M){
Z <- matrix(gaussian_box_muller(i),M,1)
ST_u[i] <- (S0 + delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
ST_l[i] <- (S0 - delta_S)*exp((r - (sigma*sigma)/(2.0))*T + sigma*sqrt(T)%*%Z)
}
Delta <- matrix(0,M,1)
totDelta <- 0
for(i in 1:M){
if(ST_u[i] - K > 0 && ST_l[i] - K > 0){
Delta[i] <- ((ST_u[i] - K) - (ST_l[i] - K))/(2*delta_S)
}else{
Delta <- 0
}
totDelta = totDelta + exp(-r*T)*Delta[i]
}
totDelta <- totDelta * 1/M
Var <- 0
for(i in 1:M){
Var = Var + (Delta[i] - totDelta)^2
}
Var = Var*1/M
cat("The Finite Difference Delta is : ", totDelta)
call_Delta_a <- call_delta(S,K,r,sigma,T)
bias <- abs(call_Delta_a - totDelta)
cat("The bias is: ", bias)
cat("The Variance of the Finite Difference method is: ", Var)
MSE <- bias*bias + Var
cat("The marginal squared error is thus: ", MSE)
}
S0 <- 100.0
delta_S <- 0.001
K <- 100.0
r <- 0.05
sigma <- 0.2
T <- 1.0
M <- 10
result1 <- Finite_Difference(S0,K,r,sigma,T,M,delta_S)
I can't seem to figure out the problem, any suggestions would be greatly appreciated.
In R, the %*% operator is reserved for multiplying two conformable matrices. As one special case, you can also use it to multiply a vector by a matrix (or vice versa), if the vector can be treated as a row or column vector that conforms to the matrix; as a second special case, it can be used to multiply two vectors to calculate their inner product.
However, one thing it cannot do is perform scalar multipliciation. Scalar multiplication of vectors or matrices always uses the plain * operator. Specifically, in the expression sqrt(T) %*% Z, the first term sqrt(T) is a scalar, and the second Z is a matrix. If what you intend to do here is multiply the matrix Z by the scalar sqrt(T), then this should just be written sqrt(T) * Z.
When I made this change, your program still didn't work because of another bug -- S is used but never defined -- but I don't understand your algorithm well enough to attempt a fix.
A few other comments on the program not directly related to your original question:
The first loop in Finite_Difference looks suspicious: guassian_box_muller(i) generates a vector of length i as i varies in the loop from 1 up to M, and forcing these vectors into a column matrix of length M to generate Z is probably not doing what you want. It will "reuse" the values in a cycle to populate the matrix. Try these to see what I mean:
matrix(gaussian_box_muller(1),10,1) # all one value
matrix(gaussian_box_muller(3),10,1) # cycle of three values
You also use loops in many places where R's vector operations would be easier to read and (typically) faster to execute. For example, your definition of Var is equivalent to:
Var <- sum((Delta - totDelta)^2)/M
and the definitions of Delta and totDelta could also be written in this simplified fashion.
I'd suggest Googling for "vector and matrix operations in r" or something similar and reading some tutorials. Vector arithmetic in particular is idiomatic R, and you'll want to learn it early and use it often.
You might find it helpful to consider the rnorm function to generate random Gaussians.
Happy R-ing!
How can I integrate over a PCHIP (Piecewise Cubic Hermite Interpolation Polynomial) function in R? pchip {pracma} returns interpolated point data, and to integrate we of course need a function. I see under the help menu for pchip(), "TODO: A `pchipfun' should be provided," I don't know how hard this would be to generate manually? Any other suggestions? You could fit an nth degree polynomial regression to the interpolated points and integrate off that to get a rough approximation, but that gets messy pretty quick...
Here's the source code for pchip {pracma} which returns points and not a function, I suppose returning a function is more of a math question not an R question, but I'm open for any and all suggestions! Please!
function (xi, yi, x)
{
h <- diff(xi)
delta <- diff(yi)/h
d <- .pchipslopes(h, delta)
n <- length(xi)
a <- (3 * delta - 2 * d[1:(n - 1)] - d[2:n])/h
b <- (d[1:(n - 1)] - 2 * delta + d[2:n])/h^2
k <- rep(1, length(x))
for (j in 2:(n - 1)) {
k[xi[j] <= x] <- j
}
s <- x - xi[k]
v <- yi[k] + s * (d[k] + s * (a[k] + s * b[k]))
return(v)
}
Thanks!
What does not work for you? You have to define a function using pchipfun() like this:
> library(pracma)
> xs <- linspace(0, pi, 10)
> ys <- sin(xs)
> pchipfun <- function(xi, yi) function(x) pchip(xi, yi, x)
> f <- pchipfun(xs, ys)
> integrate(f, 0, pi)
2.000749 with absolute error < 0.00017
I have updated pracma 1.7.2 on R-Forge to include pchipfun()
and added some error checking to pchip().