Related
I'm new to optimisation/calibration of models in R, but i'm eager to learn and really need some help. My question relates to demographic modelling.
I've done some research and found help here and here but neither have quite answered my question.
I have a matrix of scalars (propensities) where each column must total to 1. These propensities are used to estimate the number of households that would arise from a given population (persons by age). The propensities model tends to overestimate the number of households in history (for which I know the true number of households).
I want to calibrate the model to minimise the error in the number of households by tweaking the propensities such that the columns still add to 1 and propensities with an initial value of zero must remain zero.
Simple example:
# Propensities matrix
mtx <- matrix(c(0.00, 0.00, 0.85, 0.00, 0.15, 0.35, 0.45, 0.00,
0.20, 0.00, 0.65, 0.15, 0.00, 0.20, 0.00), ncol = 3)
# Population by age cohort
pop <- c(2600, 16200, 13400)
# True number of households
target <- c(7000, 4500, 5500)
# Function to optimise
hh <- function(mtx, pop, target) {
# Estimate living arrangements
x <- mtx %*% pop
# Estimate number of households using parent cohorts (1,2 and 4)
x <- c(x[1,1]/2, x[2,1]/2, x[4,1]) - target
return(x)
}
I haven't included any of my code for the optimisation/calibration step as it would be embarrassing and I've haven't been able to get anything to work!
Ideally i will have one set of propensities that generalises well for lots of different regions at the end of this process. Any advice on how i should go about achieving it? Helpful links?
Update
The snippet of code below executes the local search method as suggested by Enrico.
library(tidyverse)
library(NMOF)
data <- list(mtx = matrix(c(0.00, 0.00, 0.90, 0.00, 0.10, 0.25, 0.50, 0.00,
0.25, 0.00, 0.60, 0.20, 0.00, 0.20, 0.00), ncol = 3),
pop = c(2600, 16200, 13400),
target = c(7190, 4650, 5920))
# True mtx
mtx.true <- matrix(c(0.00, 0.00, 0.75, 0.00, 0.25, 0.35, 0.45, 0.00,
0.20, 0.00, 0.65, 0.15, 0.00, 0.20, 0.00), ncol = 3)
# Function to optimise
households <- function(x, data) {
# Estimate living arrangements
z <- x %*% data$pop
# Estimate number of households using parent cohorts (1,2 and 4)
z <- c(z[1,1]/2, z[2,1]/2, z[4,1]) - data$target
sum(abs(z))
}
# Local search function to perturb propensities
neighbour <- function(x, data) {
# Choose random column from mtx
i <- sample(1:ncol(x), 1)
# Select two non-zero propensities from mtx column
j <- which(x[, i] != 0) %>% sample(2, replace = FALSE)
# Randomnly select one to perturb positively
x[j[1], i] <- 0.1 * (1 - x[j[1], i]) + x[j[1], i]
# Perturb second propensity to ensure mtx column adds to 1
x[j[2], i] <- x[j[2], i] + (1 - sum(x[,i]))
x
}
# Local search algorithm inputs
localsearch <- list(x0 = data$mtx,
neighbour = neighbour,
nS = 50000,
printBar = FALSE)
# Execute
now <- Sys.time()
solution <- LSopt(OF = households, algo = localsearch, data)
#>
#> Local Search.
#> Initial solution: 2695
#> Finished.
#> Best solution overall: 425.25
Sys.time() - now
#> Time difference of 6.33272 secs
# Inspect propensity matrices
print(solution$xbest)
#> [,1] [,2] [,3]
#> [1,] 0.0000000 0.3925 0.6
#> [2,] 0.0000000 0.4250 0.2
#> [3,] 0.2937976 0.0000 0.0
#> [4,] 0.0000000 0.1825 0.2
#> [5,] 0.7062024 0.0000 0.0
print(mtx.true)
#> [,1] [,2] [,3]
#> [1,] 0.00 0.35 0.65
#> [2,] 0.00 0.45 0.15
#> [3,] 0.75 0.00 0.00
#> [4,] 0.00 0.20 0.20
#> [5,] 0.25 0.00 0.00
Thanks!
I can only comment on the optimisation part.
The code you have provided is sufficient; only your objective function evaluates to a vector. You will need to transform this vector into a single number that is to be minimised, such as the sum of squares or of absolute values.
When it comes to methods, I would try heuristics; in fact, I would try a Local-Search method. These methods operate on the solution through functions which you define; thus, you may code your solution as a matrix. More specifically, you would need two functions: the objective function (which you essentially have) and a neighbourhood function, which takes as input a solution and modifies it. In your particular case, it could take a matrix, select two none-zero elements from one column, and increase one and decrease the other. Thus, the column sum would remain unchanged.
Perhaps the tutorial http://enricoschumann.net/files/NMOF_Rmetrics2012.pdf is of interest, with R code http://enricoschumann.net/files/NMOF_Rmetrics2012.R .
I am multplying a matrix tm by a vector tb to produce a "response" vector. I need to apply this to a list of n tb vectors, which would produce a list containing n response vectors. I am struggling to get this to iterate over the list, for a single case it is this:
set.seed(19)
n <- 10
k <- 4
tb <- list(split(rnorm(n*k, 0, 1),seq(1:n)))
tm <- matrix(c(1.0, 0.1, 0.2, 0.3, 0.1, 1.0, 0.2, 0.1, 0.2, 0.2, 1.0, 0.5, 0.3, 0.1, 0.5, 1.0), ncol = k)
tm %*% as.vector(unlist(tb[[1]][1]))
Which produces the first response vector when doing this calculation in isolation:
> tm %*% as.vector(unlist(tb[[1]][1]))
[,1]
[1,] -0.4014836
[2,] 0.8348435
[3,] 2.0416294
[4,] 1.9114801
However, I've tried to get all 10 response vectors using lapply/sapply but this gives me an unexpected output:
> sapply(tm, function(x) x %*% as.vector(unlist(tb)))
[,1] [,2] [,3] [,4] [,5]
[1,] -1.189453745 -0.1189453745 -0.2378907491 -0.3568361236 -0.1189453745
[2,] 0.518629988 0.0518629988 0.1037259975 0.1555889963 0.0518629988
[3,] 1.423423.. ... ... ...
Just showing a snippet of the output here, it's 16 columns and 40 rows, in other words - one column per element of the matrix, and n x k rows. It's seemingly taking the first cell of the matrix, and doing the calculation, then the second cell, and the third cell and so on - as you can see this matches the output from sapply when I take a single element of tm:
> tm[1] %*% as.vector(unlist(tb[[1]][1]))
[,1] [,2] [,3] [,4]
[1,] -1.189454 0.51863 1.423423 1.504741
My question is, how do I get this multiplication to take the whole matrix when using lapply/sapply as it does when I do it in isolation?
I think you just need to remove the list() function from your tb definition:
set.seed(19)
n <- 10
k <- 4
tb <- split(rnorm(n*k, 0, 1),seq(1:n))
tm <- matrix(c(1.0, 0.1, 0.2, 0.3, 0.1, 1.0, 0.2, 0.1, 0.2, 0.2, 1.0, 0.5, 0.3, 0.1, 0.5, 1.0), ncol = k)
you can then produce your first response vector simpler:
tm %*% tb[[1]]
[,1]
[1,] -0.4014836
[2,] 0.8348435
[3,] 2.0416294
[4,] 1.9114801
and all the response vectors with sapply:
sapply(tb, function(x) x %*%tm )
1 2 3 4 5 6 7 8 9 10
[1,] -0.4014836 0.1513720 -0.1113092 -0.28636882 1.1300914 -0.7037464 1.5886556 -0.8908194 -0.6891749 -0.4927336
[2,] 0.8348435 0.6747836 0.6135654 -0.01236765 0.6523212 -0.3599526 -0.2293118 1.5190890 0.1165567 -0.7644372
[3,] 2.0416294 -0.9832891 0.3399474 1.04671293 -0.1986427 -0.4779628 1.3585457 1.0673985 -1.7597788 -0.4059126
[4,] 1.9114801 -0.7064887 0.5356257 0.57154412 0.8048432 -1.6563305 2.9935210 -1.3916476 -1.3746462 -0.9662248
I have spent a fair amount of time searching for an answer to my novice question and am still confused. I am trying to plot initial magnetization of an FID versus time. My initial magnetizations are in a matrix and my time values corresponding to each column of the matrix is a list. How do I run the nls for a exponential decay over each column of data with the corresponding value in the list of times? I am trying to have the nls function input the first time value from the list and run use the initial magnetization values columnwise and return the rates in a matrix of the same dimensions as m0_matrix.
> m0_matrix
[,1] [,2] [,3] [,4]
[1,] 19439311560 15064186946 11602185622 9009147617
[2,] 9437620734 7135488585 5348160563 4156154903
[3,] 11931439242 9584153017 7765094983 6470870180
[4,] 9367920785 7612552829 5927424214 4331819248
[5,] 12077347835 8892705185 6866664357 5530601653
[6,] 20191716524 15729555553 11920147205 8964406945
[7,] 20177137879 15744074858 12364404080 9971845743
[8,] 15990100401 12464163359 9724743390 8294038306
[9,] 19409862926 16085027074 13110425604 10330007806
[10,] 15367044986 11994945813 9565243969 7535061239
r2_from_decay_matrix = matrix(data = NA, nrow = nrow(m0_matrix), ncol =
ncol(m0_matrix))
t <- c(0.1, 0.2, 0.3, 0.4)
for (i in seq(1,nrow(m0_matrix))) {
m0 <- m0_matrix[,i]
t <- t[i]
r <- 1
mCPMG_function <- function(m0, t)
results <- paste(a = m0, b = t)
mCPMG_formula <- mCPMG ~ m0*exp(-r*t)
fit_start <- c(m0= 19439311560, r=1)
fit_data <- list(m0=m0, t=t)
r2 <- nls(mCPMG_formula, fit_data, fit_start)
r2_from_decay_matrix <- r2$m$getPars()["r"][i]
}
Thank you for helping!
I'm working with adjacency matrices that look like this:
N <- 5
A <- matrix(round(runif(N^2),1),N)
diag(A) <- 0
1> A
[,1] [,2] [,3] [,4] [,5]
[1,] 0.0 0.1 0.2 0.6 0.9
[2,] 0.8 0.0 0.4 0.7 0.5
[3,] 0.6 0.8 0.0 0.8 0.6
[4,] 0.8 0.1 0.1 0.0 0.3
[5,] 0.2 0.9 0.7 0.9 0.0
Probabilistic and directed.
Here is a slow way to calculate the probability that i is linked to j through at least one other node:
library(foreach)
`%ni%` <- Negate(`%in%`) #opposite of `in`
union.pr <- function(x){#Function to calculate the union of many probabilities
if (length(x) == 1){return(x)}
pr <- sum(x[1:2]) - prod(x[1:2])
i <- 3
while(i <= length(x)){
pr <- sum(pr,x[i]) - prod(pr,x[i])
i <- 1+i
}
pr
}
second_order_adjacency <- function(A, i, j){#function to calculate probability that i is linked to j through some other node
pr <- foreach(k = (1:nrow(A))[1:nrow(A) %ni% c(i,j)], .combine = c) %do% {
A[i,k]*A[k,j]
}
union.pr(pr)
}
#loop through the indices...
A2 <- A * NA
for (i in 1:N){
for (j in 1:N){
if (i!=j){
A2[i,j] <- second_order_adjacency(A, i, j)
}
}}
diag(A2) <- 0
1> A2
[,1] [,2] [,3] [,4] [,5]
[1,] 0.000000 0.849976 0.666112 0.851572 0.314480
[2,] 0.699040 0.000000 0.492220 0.805520 0.831888
[3,] 0.885952 0.602192 0.000000 0.870464 0.790240
[4,] 0.187088 0.382128 0.362944 0.000000 0.749960
[5,] 0.954528 0.607608 0.440896 0.856736 0.000000
This algorithm scales like N^2, and I've got thousands of nodes. And my matrix isn't all that sparse -- a lot of small numbers with a few big ones. I could parallelize it, but I'd only be dividing by the number of cores. Is there some vectorized trick that allows me to take advantage of the relative speed of vectorized operations?
tl;dr: how can I quickly calculate a second-order adjacency matrix in a probablistic directed graph?
Your union.pr function is slower by 500 times than a simple and efficient way. So replace your union.pr by 1-prod(1-pr) and you'll get 500X speed.
x <- runif(1000)*0.01
t1 <- proc.time()
for (i in 1:10000){
y <- union.pr(x)
}
t1 <- proc.time()-t1
print(t1)
# user system elapsed
# 21.09 0.02 21.18
t2 <- proc.time()
for (i in 1:10000){
y <- 1-prod(1-x)
}
t2 <- proc.time() - t2
print(t2)
# user system elapsed
# 0.04 0.00 0.03
So #Julius's answer was useful for reminding me of some elementary probability rules, but it didn't speed up the rate of computation much. The following function, however, helps a ton:
second_order_adjacency2 <- function(A, i, j){#function to calculate probability that i is linked to j through some other node
a1 <- A[i,1:nrow(A) %ni% c(i,j)]
a2 <- t(A)[j,1:nrow(A) %ni% c(i,j)]
1-prod(1-a1*a2)
}
It still scales like N^2 because it is a loop, but takes advantage of vectorization in the calculation of the various paths from i to j. As such it is much faster.
I have a R script I'm running now that is currently using 3 correlated variables. I'd like to add a 4th, and am wondering if there's a simple way to input matrix data, particularly for correlation matrices---some Matlab-like technique to enter a correlation matrix, 3x3 or 4x4, in R without the linear to matrix reshape I've been using.
In Matlab, you can use the semicolon as an end-row delimiter, so it's easy to keep track of where the cross correlations are.
In R, where I first create
corr <- c(1, 0.1, 0.5,
0.1, 1, 0.9,
0.5, 0.9, 1)
cormat <- matrix(corr, ncol=3)
Versus
cormat = [1 0.1 0.5;
0.1 1 0.9;
0.5 0.9 1]
It just feels clunkier, which makes me suspect there's a smarter way I haven't looked up yet. Thoughts?
Welcome to the site! :) you should be able to do it in one step:
MyMatrix = matrix(
c(1, 0.1, 0.5,
0.1, 1, 0.9,
0.5, 0.9, 1),
nrow=3,
ncol=3)
Here is another way:
CorrMat <- matrix(scan(),3,3,byrow=TRUE)
1 0.1 0.5
0.1 1 0.9
0.5 0.9 1
Trailing white line is important.
If you want to input a symmetric matrix, you can use the xpnd() function in the MCMCpack library.
xpnd() takes a vector which corresponds to the upper-triangle of the matrix (thus you only have to enter each value once). For instance, if you want to input:
$\left(\begin{array}{c c c}
1 & 0.1 & 0.5 \\
0.1 & 1 & 0.9 \\
0.5 & 0.9 & 1
\end{array}\right)$
You would use
library(MCMCpack)
xpnd(c(1, 0.1, 0.5, 1, 0.9, 1), 3)
where 3 refers to the number of rows in the matrix.
Help page for xpnd.
rbind(c(1, 0.1, 0.5),
c(0.1, 1, 0.9),
c(0.5, 0.9, 1))
For the existing solutions. That may only work for 3*3 matrix. I tried this one.
a<-diag(3)
m<-diag(3)
m[lower.tri(m,diag=F)]<-c(0.1, 0.5, 0.9)
m<-m+t(m)-a
As you are working with correlation matrices, you are probably not interested in entering the diagonal, and both the upper and lower parts. You can manipulate/extract those three parts separately using diag(), upper.tri() and lower.tri().
> M <- diag(3) # create 3x3 matrix, diagonal defaults to 1's
> M[lower.tri(M, diag=F)] <- c(0.1, 0.5, 0.9) # read in lower part
> M # lower matrix containing all information
[,1] [,2] [,3]
[1,] 1.0 0.0 0
[2,] 0.1 1.0 0
[3,] 0.5 0.9 1
If you want the full matrix:
> M[upper.tri(M, diag=F)] <- M[lower.tri(M)] # fill upper part
> M # full matrix
[,1] [,2] [,3]
[1,] 1.0 0.1 0.5
[2,] 0.1 1.0 0.9
[3,] 0.5 0.9 1.0