I like to draw nrep times from a binomial distribution with theta parameter, to create one k length sequence for each theta, and build them in a matrix dimension nrep x k. How can create a matrix of the results in R?
The code below draws (nrep * k) each from a different theta i.e sequence is not k length from same theta. [My aim is to draw nrep times a binomial probability theta length k.]
### simulate some binary sequence data in matrix ted (1000 x 20)
nrep <- 1000
s <- 7; k <- 20
theta <- rbeta(nrep, shape1=s+1, shape2=k-s+1)
ted <- 0
ted <- matrix(rbinom(k * nrep, 1, theta), ncol = k, nrow = nrep)
hist(ted)
rbinom is vectorized over parameter prob, so you can use rep(theta, k) to achieve
ted <- matrix(rbinom(k * nrep, 1, rep(theta, k)), ncol = k, nrow = nrep)
Related
Following this question: How to get the value of `t` so that my function `h(t)=epsilon` for a fixed `epsilon`?
I first sampling 500 eigenvectors v of a random matrix G and then generate 100 different random vectors initial of dimension 500. I normalized them in mats.
#make this example reproducible
set.seed(100001)
n <- 500
#Sample GOE random matrix
A <- matrix(rnorm(n*n, mean=0, sd=1), n, n)
G <- (A + t(A))/sqrt(2*n)
ev <- eigen(G)
l <- ev$values
v <- ev$vectors
#size of multivariate distribution
mean <- rep(0, n)
var <- diag(n)
#simulate bivariate normal distribution
initial <- MASS::mvrnorm(n=1000, mu=mean, Sigma=var) #ten random vectors
#normalized the first possible initial value, the initial data uniformly distributed on the sphere
xmats <- lapply(1:1000, function(i) initial[i, ]/norm(initial[i, ], type="2"))
Then I compute res
h1t <- function(t,x_0) {
h10 <- c(x_0 %*% v[, n])
denom <- vapply(t, function(.t) {
sum((x_0 %*% v)^2 * exp(-4*(l - l[n]) * .t))
}, numeric(1L))
abs(h10) / sqrt(denom)
}
find_t <- function(x, epsilon = 0.01, range = c(-50, 50)) {
uniroot(function(t) h1t(t, x) - epsilon, range,
tol = .Machine$double.eps)$root
}
I want to get res:
res <- lapply(xmats, find_t)
However, it shows error that Error in uniroot(function(t) h1t(t, x) - epsilon, range, tol = .Machine$double.eps) : f() values at end points not of opposite sign
res is a list. I run hist(unlist(res)) and it worked well.
I want to solve the optimazation problem to search best weights for groups of vectors. Would you like to give some suggestions about how to solve it by R? Thanks very much.
The problem is as follows.
Given there are N groups, we know their similarity matrix among these N groups. The dimension of S is N*N.
In each group, there are K vectors . There are M elements in each vector which value is 0 or 1. .
we can fit an average vector based on these K vectors. For example, average vector
Based on these avearge vectors in each group, we could calculate the correlation among these avearge vectors.
The object is to minimize the differene between correlation matrix C and known similarity matrix S.
Beacuse you didn't provide any data I will generate random and demonstrate way you can approach your problem.
Similarity matrix:
N <- 6
S <- matrix(runif(N^2, -1, 1), ncol = N, nrow = N)
similarity_matrix <- (S + t(S)) / 2
N is number of groups. Each value of similarity matrix is between -1 and 1 and matrix is symmetric (beacuse you want to compare it to covariance matrix these makes sense).
group vectors:
M <- 10
K <- 8
group_vectors <- replicate(N, replicate(K, sample(c(0, 1), M, TRUE)), FALSE)
M is dimension of vector and K is number of binary vectors in each group.
fitness function
fitness <- function(W, group_vectors, similarity_matrix){
W <- as.data.frame(matrix(W, nrow = K, ncol = N))
SS <- cov(
mapply(function(x,y) rowSums(sweep(x, 2, y, "*")), group_vectors, W)
)
sum(abs(SS - similarity_matrix))
}
fitness for given weights calculates described covariance matrix and its distance from similarity_matrix.
differential evolution approach
res <- DEoptim::DEoptim(
fn = fitness,
lower = rep(-1, K*N),
upper = rep(1, K*N),
group_vectors = group_vectors,
similarity_matrix = similarity_matrix,
control = DEoptim::DEoptim.control(VTR = 0, itermax = 1000, trace = 50, NP = 100)
)
W <- matrix(res$optim$bestmem, nrow = K, ncol = N)
genetic algorithm approach
res <- GA::ga(
type = "real-valued",
fitness = function(W, ...) -fitness(W, ...),
lower = rep(-1, K*N),
upper = rep(1, K*N),
group_vectors = group_vectors,
similarity_matrix = similarity_matrix,
maxiter = 10000,
run = 200
)
W <- matrix(res#solution[1,], nrow = K, ncol = N)
I'm asked to simulate 50 survival times from an exponential distribution with rate 1.
n <- 50
Tstar <- rexp(n, rate = 1)
Then I have the following quantities:
Y(t) capturing the individuals at risk at time t, i.e.
Y <- function(t){sum(Tstar > t)}
and S(t) is the Kaplan-Meier estimator
S <- function(t)(1 - 1/n * sum(Tstar < t)
But how do I define the following function?
Here Tstar[i] indicates T_i.
If I understand my mathematical notations, consider Reduce + sapply to serve as iterator and summation across specific values:
set.seed(4621)
n <- 50
Tstar <- rexp(n, rate = 1)
Y <- function(t) sum(Tstar > t)
S <- function(t) (1 - 1/n * sum(Tstar < t))
sigma_sq <- function(t) {
Tstar <- Tstar[Tstar < t]
S(t)^2 * Reduce(`+`, sapply(Tstar, function(T_i) 1/(Y(t)*(T_i)^2)))
}
I have a joint p.d.f.
And I am now comparing the theoretical value of the conditional probability and the empirical value which I
ran the Monte Carlo Approach.
I have to do this in replications 10,000, 100,000, and 1,000,000 draws. May I ask how to put replications in the R code?
Also, for the last step, the conditional probability,
I was using Monte Carlo Approach to do it.
Is there any R code which I can use for multivariate Uniform
distribution to calculate the conditional probability?
Any suggestions would be highly appreciated! Thanks!!
My code was as below:
# f(x.y) = (1/4)*xy, 0<x<2, 0<y<2
# Find P(A) = P(X>1)
f <- function(x){(1/2)*x} # Marginal P(X)
probE <-integrate(f, lower = 1, upper = 2)
cat('\n Pr[ 1 < X ] is \n')
print(probE)
n <- 10000
x<-runif(n, 1,2)
probE.MC <- ((2-1)/n)*sum((1/2)*x)
cat('\n Monte Carlo Pr[1< X ] =',probE.MC,'\n')
# Find P(B) = P(Y<1)
f <- function(y){(1/2)*y} # Marginal P(Y)
probB <-integrate(f, lower = 0, upper = 1)
cat('\n Pr[ 1< Y ] is \n')
probB
typeof(probB)
n <- 10000
y<-runif(n, 0,1)
probB.MC <- ((1-0)/n)*sum((1/2)*y)
cat('\n Monte Carlo Pr[Y < 1] =',probB.MC,'\n')
# Pr[A intersect B]
# P[X>1 and Y <1]
f <- function(x,y){return((1/4)*x*y)}
n <- 100000
a11<-1; a12 <-2; a21 <- 0; a22 <-1
x <-runif(n, a11, a12)
y <- runif(n,a21, a22)
probMC <- ((a12-a11)*(a22-a21)/n)*sum(f(x,y))
probMC
typeof(probMC)
# P[A|B] = p[A intersect B]/ P(B)
probAB <- probMC/probB
First, I reformatted the functions and gave them separate names.
fX <- function(x) {
0.5 * x # Marginal P(X)
}
# Find P(B) = P(Y<1)
fY <- function(y) {
0.5 * y # Marginal P(Y)
}
fXY <- function(x, y) {
1 / length(x) * sum(0.25 * x * y) # joint X,Y
}
The simplest way to do multiple runs is to wrap the MC code in a for loop and save each calculation in an array. Then, at the end, take the mean of the stored values.
So for P[A] you have:
n <- 10000
probA.MC <- numeric(n) # create the array
for (i in 1:10000) {
x<-runif(n, 1,2)
probA.MC[i] <- ((2-1) / n) * sum(0.5 * x)
}
cat('\n Monte Carlo Pr[1 < X] =',mean(probA.MC),'\n')
(I assume probE.MC should have been probA.MC.) The result was Monte Carlo Pr[1 < X] = 0.7500088. The code is analogous for P[B] and that result as Monte Carlo Pr[Y < 1] = 0.2499819.
For the joint probability we use fXY.
n <- 10000
probMC <- numeric(n)
for (i in 1:10000) {
x <- runif(n, 1, 2)
y <- runif(n, 0, 1)
probMC[i] <- ((a12-a11) * (a22-a21)) * fXY(x, y)
}
cat('\n Monte Carlo Pr[X,Y] =',mean(probMC),'\n')
This result was Monte Carlo Pr[X,Y] = 0.1882728.
The last calculation you did should read as follows (note the probB$value from the integration result):
# P[A|B] = p[A intersect B]/ P(B)
probAB <- mean(probMC) / probB$value
print(probAB)
This calculation yielded the result 0.7530913.
I am trying to write a code to solve the following problem (As stated in HW5 in the CalTech course Learning from Data):
In this problem you will create your own target function f
(probability in this case) and data set D to see how Logistic
Regression works. For simplicity, we will take f to be a 0=1
probability so y is a deterministic function of x. Take d = 2 so you
can visualize the problem, and let X = [-1; 1]×[-1; 1] with uniform
probability of picking each x 2 X . Choose a line in the plane as the
boundary between f(x) = 1 (where y has to be +1) and f(x) = 0 (where y
has to be -1) by taking two random, uniformly distributed points from
X and taking the line passing through them as the boundary between y =
±1. Pick N = 100 training points at random from X , and evaluate the
outputs yn for each of these points xn. Run Logistic Regression with
Stochastic Gradient Descent to find g, and estimate Eout(the cross
entropy error) by generating a sufficiently large, separate set of
points to evaluate the error. Repeat the experiment for 100 runs with
different targets and take the average. Initialize the weight vector
of Logistic Regression to all zeros in each run. Stop the algorithm
when |w(t-1) - w(t)| < 0:01, where w(t) denotes the weight vector at
the end of epoch t. An epoch is a full pass through the N data points
(use a random permutation of 1; 2; · · · ; N to present the data
points to the algorithm within each epoch, and use different
permutations for different epochs). Use a learning rate of 0.01.
I am required to calculate the nearest value to Eout for N=100, and the average number of epochs for the required criterion.
I wrote and ran the code but I'm not getting the right answers (as stated in the solutions, these are Eout is near 0.1 and the number of epochs is near 350). The required number of epochs for a delta w of 0.01 comes to far too small (around 10), leaving the error too big (around 2). I then tried to replace the criterion with |w(t-1) - w(t)| < 0.001 (rather than 0.01). Then, the average required number of epochs was about 250 and out of sample error was about 0.35.
Is there something wrong with my code/solution, or is it possible that the answers provided are faulty? I've added comments to indicate what I intend to do at each step. Thanks in advance.
library(pracma)
h<- 0 # h will later be updated to number of required epochs
p<- 0 # p will later be updated to Eout
C <- matrix(ncol=10000, nrow=2) # Testing set, used to calculate out of sample error
d <- matrix(ncol=10000, nrow=1)
for(i in 1:10000){
C[, i] <- c(runif(2, min = -1, max = 1)) # Sample data
d[1, i] <- sign(C[2, i] - f(C[1, i]))
}
for(g in 1:100){ # 100 runs of the experiment
x <- runif(2, min = -1, max = 1)
y <- runif(2, min = -1, max = 1)
fit = (lm(y~x))
t <- summary(fit)$coefficients[,1]
f <- function(x){ # Target function
t[2]*x + t[1]
}
A <- matrix(ncol=100, nrow=2) # Sample data
b <- matrix(ncol=100, nrow=1)
norm_vec <- function(x) {sqrt(sum(x^2))} # vector norm calculator
w <- c(0,0) # weights initialized to zero
for(i in 1:100){
A[, i] <- c(runif(2, min = -1, max = 1)) # Sample data
b[1, i] <- sign(A[2, i] - f(A[1, i]))
}
q <- matrix(nrow = 2, ncol = 1000) # q tracks the weight vector at the end of each epoch
l= 1
while(l < 1001){
E <- function(z){ # cross entropy error function
x = z[1]
y = z[2]
v = z[3]
return(log(1 + exp(-v*t(w)%*%c(x, y))))
}
err <- function(xn1, xn2, yn){ #gradient of error function
return(c(-yn*xn1, -yn*xn2)*(exp(-yn*t(w)*c(xn1,xn2))/(1+exp(-yn*t(w)*c(xn1,xn2)))))
}
e = matrix(nrow = 2, ncol = 100) # e will track the required gradient at each data point
e[,1:100] = 0
perm = sample(100, 100, replace = FALSE, prob = NULL) # Random permutation of the data indices
for(j in 1:100){ # One complete Epoch
r = A[,perm[j]] # pick the perm[j]th entry in A
s = b[perm[j]] # pick the perm[j]th entry in b
e[,perm[j]] = err(r[1], r[2], s) # Gradient of the error
w = w - 0.01*e[,perm[j]] # update the weight vector accorng to the formula involving step size, gradient
}
q[,l] = w # the lth entry is the weight vector at the end of the lth epoch
if(l > 1 & norm_vec(q[,l] - q[,l-1])<0.001){ # given criterion to terminate the algorithm
break
}
l = l+1 # move to the next epoch
}
for(n in 1:10000){
p[g] = mean(E(c(C[1,n], C[2, n], d[n]))) # average over 10000 data points, of the error function, in experiment no. g
}
h[g] = l #gth entry in the vector h, tracks the number of epochs in the gth iteration of the experiment
}
mean(h) # Mean number of epochs needed
mean(p) # average Eout, over 100 experiments