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 have a correlation matrix
cor.mat <- structure(c(1, -0.25, 0.11, 0.25, 0.18, -0.25, 1, -0.14, -0.22,
-0.15, 0.11, -0.14, 1, 0.21, 0.19, 0.25, -0.22, 0.21, 1, 0.53,
0.18, -0.15, 0.19, 0.53, 1), .Dim = c(5L, 5L))
I also have a matrix of standard errors
sd <- structure(c(0.33, 0.62, 1, 0.54, 0.47), .Dim = c(1L, 5L))
dim(cor.mat)
#[1] 5 5
dim(sd)
#[1] 1 5
is.matrix(cor.mat)
#[1] TRUE
is.matrix(sd)
#[1] TRUE
cov.mat <-cor2cov(cor.mat, sd)
# Error in sds * R : non-conformable arrays
So, the matrices have compatible dimensions, why doesn't cor2cov function work for me?
OK, I don't know where your cor2cov comes from. But actually, it is really straightforward to obtain covariance matrix from correlation matrix and standard errors:
cov.mat <- sweep(sweep(cor.mat, 1L, sd, "*"), 2L, sd, "*")
# [,1] [,2] [,3] [,4] [,5]
#[1,] 0.108900 -0.051150 0.0363 0.044550 0.027918
#[2,] -0.051150 0.384400 -0.0868 -0.073656 -0.043710
#[3,] 0.036300 -0.086800 1.0000 0.113400 0.089300
#[4,] 0.044550 -0.073656 0.1134 0.291600 0.134514
#[5,] 0.027918 -0.043710 0.0893 0.134514 0.220900
Yes, it is just a symmetric row & column rescaling.
We can verify this by transforming this covariance matrix back to correlation matrix using cov2cor, which is exactly your correlation matrix:
all.equal(cov2cor(cov.mat), cor.mat)
# [1] TRUE
My guess on your cor2cov
If you read How to rescale a matrix by row / column, you will see there are lots of different ways for rescaling. The sweep used above is just one option.
R base function cov2cor(V) is using:
Is <- sqrt(1/diag(V)) ## inverse of square root diagonal (inverse of sd)
Is * V * rep(Is, each = p)
I think your cor2cov(R, sds) is written in the same style:
sds * R * rep(sds, each = p) ## `sd` must be a vector
If so, sd must be a vector, otherwise "*" will complain (note, the error message you got is indeed reported from "*").
Your argument "the matrices have compatible dimensions" is a bogus one. Purely in terms of linear algebra, you need sd to be a diagonal matrix, so that you can do:
sd %*% cor.mat %*% sd
But row / column rescaling is never done by matrix computations as this is too expensive.
By definition of correlation and covariance matrix, you can simply do this:
cov.mat <- cor.mat * matrix(outer(sd, sd), nrow=5, byrow=TRUE)
cov.mat
[,1] [,2] [,3] [,4] [,5]
[1,] 0.108900 -0.051150 0.0363 0.044550 0.027918
[2,] -0.051150 0.384400 -0.0868 -0.073656 -0.043710
[3,] 0.036300 -0.086800 1.0000 0.113400 0.089300
[4,] 0.044550 -0.073656 0.1134 0.291600 0.134514
[5,] 0.027918 -0.043710 0.0893 0.134514 0.220900
I think I might have found an answer on another post: Non-conformable arrays error in code
When I treat sd matrix as vertor, it works (I hope, it's correct?)
sd = as.vector(sd)
cov.mat <- cor2cov(cor.mat, sd)
Thank you and please let me know if this operation makes the results not equivalent to what I was initially asking about.
I tried the Page Rank function on a normal matrix with no Null Node. The ith row shows the node and the jth column shows the transition. So Matrix[i,j] denotes the transition from the ith row to the jth column
Transition Matrix
library(igraph)
#-----B is the matrix----#
g2<-graph_from_adjacency_matrix(B, mode = "directed" , weighted = TRUE)
plot(g2)
B1<-page.rank(g2, damping = 1)$vector
C1<-as.data.frame(B1)
This gave me the result(no damping):
The PageRank comes out to be (3/9, 2/9, 2/9, 2/9)
Now, I applied the same to another matrix with the Null node:
New Matrix with 3rd Row being the Null node
What I should get is a row vector of 0,0,0,0 but what I get on using the function is:
The PageRank comes out to be (0.2, 0.2666666,0.2666666,0.2666666)
What am I doing wrong?
As far as I understand PageRank it is not defined when there are nodes with an out-degree of zero (as you have here). According to this answer to a related question: How does pageranking algorithm deal with webpage without outbound links? this is commonly dealt with by connecting the offending node to all of the others (including itself) with equal probability.
I tried this out with your example
B1 <- structure(c(0, 0.5, 0.25, 0, 0.333333333333333, 0, 0.25, 0.5,
0.333333333333333, 0, 0.25, 0.5, 0.333333333333333, 0.5, 0.25,
0), .Dim = c(4L, 4L))
g1 <- graph_from_adjacency_matrix(B1, mode = "directed", weighted = TRUE)
page_rank(g1, damping = 1)$vector
and this gives
[1] 0.2000000 0.2666667 0.2666667 0.2666667
which is the same as you have.
[Updated from comments]
Under the hood igraph is using prpack so this must be accounting for nodes with zero out degree. If you want to flag up the problem before you run the page_rank function you could just check for:
any(degree(g1, mode = "out") == 0)
so actually get the zero vector that you want and preserve node names it could be something like:
outdeg <- degree(g1, mode = "out")
if (any(outdeg==0)) {
B2 <- 0*outdeg
} else {
B2 <- page_rank(g1, damping = 1)
}
or even smaller
B2 <- any(degree(g1, mode = "out") == 0) * page_rank(g1, damping = 1)
My question is related to this one on producing a confusion matrix in R with the table() function. I am looking for a solution without using a package (e.g. caret).
Let's say these are our predictions and labels in a binary classification problem:
predictions <- c(0.61, 0.36, 0.43, 0.14, 0.38, 0.24, 0.97, 0.89, 0.78, 0.86, 0.15, 0.52, 0.74, 0.24)
labels <- c(1, 1, 1, 0, 0, 1, 1, 1, 0, 1, 0, 0, 1, 0)
For these values, the solution below works well to create a 2*2 confusion matrix for, let's say, threshold = 0.5:
# Confusion matrix for threshold = 0.5
conf_matrix <- as.matrix(table(predictions>0.5,labels))
conf_matrix
labels
0 1
FALSE 4 3
TRUE 2 5
However, I do not get a 2*2 matrix if I select any value that is smaller than min(predictions) or larger than max(predictions), since the data won't have either a FALSE or TRUE occurrence e.g.:
conf_matrix <- as.matrix(table(predictions>0.05,labels))
conf_matrix
labels
0 1
TRUE 6 8
I need a method that consistently produces a 2*2 confusion matrix for all possible thresholds (decision boundaries) between 0 and 1, as I use this as an input in an optimisation. Is there a way I can tweak the table function so it always returns a 2*2 matrix here?
You can make your thresholded prediction a factor variable to achieve this:
(conf_matrix <- as.matrix(table(factor(predictions>0.05, levels=c(F, T)), labels)))
# labels
# 0 1
# FALSE 0 0
# TRUE 6 8
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