I am looking for something like the 'msm' package, but for discrete Markov chains. For example, if I had a transition matrix defined as such
Pi <- matrix(c(1/3,1/3,1/3,
0,2/3,1/6,
2/3,0,1/2))
for states A,B,C. How can I simulate a Markov chain according to that transition matrix?
A while back I wrote a set of functions for simulation and estimation of Discrete Markov Chain probability matrices: http://www.feferraz.net/files/lista/DTMC.R.
Relevant code for what you're asking:
simula <- function(trans,N) {
transita <- function(char,trans) {
sample(colnames(trans),1,prob=trans[char,])
}
sim <- character(N)
sim[1] <- sample(colnames(trans),1)
for (i in 2:N) {
sim[i] <- transita(sim[i-1],trans)
}
sim
}
#example
#Obs: works for N >= 2 only. For higher order matrices just define an
#appropriate mattrans
mattrans <- matrix(c(0.97,0.03,0.01,0.99),ncol=2,byrow=TRUE)
colnames(mattrans) <- c('0','1')
row.names(mattrans) <- c('0','1')
instancia <- simula(mattrans,255) # simulates 255 steps in the process
Argh, you found the solution whilst I was writing it up for you. Here's a simple example that I came up with:
run = function()
{
# The probability transition matrix
trans = matrix(c(1/3,1/3,1/3,
0,2/3,1/3,
2/3,0,1/3), ncol=3, byrow=TRUE);
# The state that we're starting in
state = ceiling(3 * runif(1, 0, 1));
cat("Starting state:", state, "\n");
# Make twenty steps through the markov chain
for (i in 1:20)
{
p = 0;
u = runif(1, 0, 1);
cat("> Dist:", paste(round(c(trans[state,]), 2)), "\n");
cat("> Prob:", u, "\n");
newState = state;
for (j in 1:ncol(trans))
{
p = p + trans[state, j];
if (p >= u)
{
newState = j;
break;
}
}
cat("*", state, "->", newState, "\n");
state = newState;
}
}
run();
Note that your probability transition matrix doesn't sum to 1 in each row, which it should do. My example has a slightly altered probability transition matrix which adheres to this rule.
You can now use the markovchain package available in CRAN. The user manual. is pretty good and has several examples.
Related
I am coding a SIR model in a metapopulation in R, I want to integrate the systema and for that I am using de deSolve with C compiled code, I have used this before but in the case having a few parameters, now I would have Nxm parameters where N is the dimension of the system,so I would like that
/* file age3classp.c */
#include <R.h>
static double parms[3];
static double forc[1];
#define N parms[0]
#define N1 parms[1]
#define gam3 parms[2]
That this parms are vector or matrix NxN
It is posible?
In C my model will be of the form:
# SIR metapopulation model:
SIR <- function(t, state, parameters) {
with(as.list(c(state, parameters)),{
dS = c()
dI = c()
dR = c()
for(i in c(1:dim)){
dS[i] <- delta_N[i]*(S[i]+I[i]+R[i])
dI[i] <- 10
dR[i] <- 10
}
list(c(dS, dI, dR))
})
}
population <- c(S <- matrix(100,ncol=N,nrow =1 ), I <- matrix(10,ncol=N,nrow =1 ),
R <- matrix(0,ncol=N,nrow =1 ))
z <- ode(population, times, SIR, parameters)
In this way it does not recognise S[i] or the others as variables just as initial condition values.
How can I do in order to recognise it as a variable?
Yes this is possible, and there are different ways to do it, depending on your C programming skills. The easiest is to put both states and parameters in two long vectors and then split it at the C level using numbered parameter and variable indices. The equations are then formulated as for-loops.
To improve readability, it is also possible to use
preprocessor constants for the indices or
unions and structs (see below)
a vector for the states and a list for the parameters
The states (y) are always treated as vector, both on the R and the C level, but parameters (p) can also be passed down as lists and then split up at the C level. This can be tricky and requires some understanding of R's data structures.
However, I recommend to start vectorization on the R level. R is quite fast with vectorized models, so the speedup may not compensate for the C programming effort. An example how to implement a vectorized predator-prey model can be found here.
Another idea is to use a code generator, so you may have a look at the CRAN package rodeo that creates fast Fortran code from equations formulated as tabular (i.e. LibreOffice or Excel) tables. Usage does not require kowledge of Fortran.
More about rodeo can be found in a paper (https://doi.org/10.1016/j.envsoft.2017.06.036) and the package documentation at https://dkneis.github.io/
If one really wants to program it in C here a small implementation of a Lotka-Volterra-Competition model see Wikipedia with 3 states. The parameters are handed over as parameter vector p at the C level while a union is used to improve readability:
/* file model.c */
#include <R.h>
union parvec {
struct {
double r[3], a[6];
};
double value[9];
} p;
/* initializer */
void initmod(void (* odeparms)(int *, double *))
{
int N = 9; /* total number of parameters */
odeparms(&N, p.value);
}
/* Derivatives */
void derivs (int *neq, double *t, double *y, double *ydot,
double *yout, int *ip) {
double y_sum = 0;
for (int i = 0; i < *neq; i++) {
y_sum = 0;
for (int j = 0; j < *neq; j++) y_sum += p.a[i + *neq * j] * y[j];
ydot[i] = p.r[i] * y[i] * (1 - y_sum);
}
}
And here the calling R code:
# file call_model.R
library(deSolve)
system("R CMD SHLIB model.c")
dyn.load("model.dll")
p <- c(r = c(0.1, 0.3, 0.04), A = c(0.2, 0.3, 0.3, 0.5, 0.4, 0.2))
y <- c(X = c(2, 2, 2))
times <- seq(0, 200, by = 0.1)
out <- ode(y, times, func = "derivs", parms = p,
dllname = "model", initfunc = "initmod")
matplot.0D(out)
dyn.unload("model.dll")
More elaborated solutions are possible, of course.
I'm trying to solve the problem #14 of Project Euler.
So the main objective is finding length of Collatz sequence.
Firstly I solved problem with regular loop:
compute <- function(n) {
result <- 0
max_chain <- 0
hashmap <- 1
for (i in 1:n) {
chain <- 1
number <- i
while (number > 1) {
if (!is.na(hashmap[number])) {
chain <- chain + hashmap[number]
break
}
if (number %% 2 == 0) {
chain <- chain + 1
number <- number / 2
} else {
chain <- chain + 2
number <- (3 * number + 1) / 2
}
}
hashmap[i] <- chain
if (chain > max_chain) {
max_chain <- chain
result <- i
}
}
return(result)
}
Only 2 seconds for n = 1000000.
I decided to replace while loop to recursion
len_collatz_chain <- function(n, hashmap) {
get_len <- function(n) {
if (is.na(hashmap[n])) {
hashmap[n] <<- ifelse(n %% 2 == 0, 1 + get_len(n / 2), 2 + get_len((3 * n + 1) / 2))
}
return(hashmap[n])
}
get_len(n)
return(hashmap)
}
compute <- function(n) {
result <- 0
max_chain <- 0
hashmap <- 1
for (i in 1:n) {
hashmap <- len_collatz_chain(i, hashmap)
print(length(hashmap))
if (hashmap[i] > max_chain) {
max_chain <- hashmap[i]
result <- i
}
}
return(result)
}
This solution works but works so slow. Almost 1 min for n = 10000.
I suppose that one of the reasons is R creates hashmap object each time when call function len_collatz_chain.
I know about Rcpp packages and yes, the first solution works fine but I can't understand where I'm wrong.
Any tips?
For example, my Python recursive solution works in 1 second with n = 1000000
def len_collatz_chain(n: int, hashmap: dict) -> int:
if n not in hashmap:
hashmap[n] = 1 + len_collatz_chain(n // 2, hashmap) if n % 2 == 0 else 2 + len_collatz_chain((3 * n + 1) // 2, hashmap)
return hashmap[n]
def compute(n: int) -> int:
result, max_chain, hashmap = 0, 0, {1: 1}
for i in range(2, n):
chain = len_collatz_chain(i, hashmap)
if chain > max_chain:
result, max_chain = i, chain
return result
The main difference between your R and Python code is that in R you use a vector for the hashmap, while in Python you use a dictionary and that hashmap is transferred many times as function argument.
In Python, if you have a Dictionary as function argument, only a reference to the actual data is transfered to the called function. This is fast. The called function works on the same data as the caller.
In R, a vector is copied when used as function argument. This is potentially slow, but safer in the sense that the called function cannot alter the data of the caller.
This the main reason that Python is so much faster in your code.
You can however alter the R code slightly, such that the hashmap is not transfered as function argument anymore:
len_collatz_chain <- local({
hashmap <- 1L
get_len <- function(n) {
if (is.na(hashmap[n])) {
hashmap[n] <<- ifelse(n %% 2 == 0, 1 + get_len(n / 2), 2 + get_len((3 * n + 1) / 2))
}
hashmap[n]
}
get_len
})
compute <- function(n) {
result <- rep(NA_integer_, n)
for (i in seq_len(n)) {
result[i] <- len_collatz_chain(i)
}
result
}
compute(n=10000)
This makes the R code much faster. (Python will probably still be faster though).
Note that I have also removed the return statements in the R code, as they are not needed and add one level to the call stack.
I have problems implementing a gradient descent in R for an exponential function.
Let's say
foo <- function(x) {
y = -2 + 2.5 * exp(0.1*x^2-0.7*x)
return(y) }
is my exponential function then
grad <- function(x) {
y = 2.5*exp(0.1*x^2-0.7*x)*(0.2*x-0.7)
return(y) }
is the gradient function of foo(x).
The task is to implement a function called
gdescent <- function(x0, fc, grd, diff, step) {}
where
x0 is a random initial value
foo is the exponential function I want to minimize
grad is the gradient function (derivative of foo(x))
diff is the difference that terminates the algo
step is the size of the steps (i.e. the learning rate)
The result of the function shall be a list containing
par - the value of x in the minimum;
value - the corresponding value of foo(par) at the minimum;
and iter - the number of iterations it took the algo to find the minimum.
The update rule after every iteration shall be:
xi+1 = xi - step * grd(xi) # i didn't understand this at all
How do I implement this in R?
My understanding of the gradient descent method so far:
pick a random initial value x0 insert x0 in the gradient function grd(x)
if grd(x0) < 0, reduce x0 by "step" (x0+1=x0-step);
if grd(x0) > 0, increase x0 by "step" (x0+1=x0+step); and go back to 2) with x0+1 as initial value
my solution so far:
gdescent <- function(x0, fc, grd, diff, step) {
x = x0
x_history = vector("numeric", iter)
for(i in 1:iter) {
x = x - step * grad(x)
if( x > diff ) { #not sure how to proceed here
}
}
How can I solve this without a fixed number of iterations? so without initialising iter
I'm trying to speed up code that takes time series data and limits it to a maximum value and then stretches it forward until sum of original data and the "stretched" data are the same.
I have a more complicated version of this that is taking 6 hours to run on 100k rows. I don't think this is vectorizable because it uses values calculated on prior rows - is that correct?
x <- c(0,2101,3389,3200,1640,0,0,0,0,0,0,0)
dat <- data.frame(x=x,y=rep(0,length(x)))
remainder <- 0
upperlimit <- 2000
for(i in 1:length(dat$x)){
if(dat$x[i] >= upperlimit){
dat$y[i] <- upperlimit
} else {
dat$y[i] <- min(remainder,upperlimit)
}
remainder <- remainder + dat$x[i] - dat$y[i]
}
dat
I understand you can use ifelse but I don't think cumsum can be used to carry forward the remainder - apply doesn't help either as far as I know. Do I need to resort to Rcpp? Thank you greatly.
I went ahead and implemented this in Rcpp and made some adjustments to the R function:
require(Rcpp);require(microbenchmark);require(ggplot2);
limitstretchR <- function(upperlimit,original) {
remainder <- 0
out <- vector(length=length(original))
for(i in 1:length(original)){
if(original[i] >= upperlimit){
out[i] <- upperlimit
} else {
out[i] <- min(remainder,upperlimit)
}
remainder <- remainder + original[i] - out[i]
}
out
}
The Rcpp function:
cppFunction('
NumericVector limitstretchC(double upperlimit, NumericVector original) {
int n = original.size();
double remainder = 0.0;
NumericVector out(n);
for(int i = 0; i < n; ++i) {
if (original[i] >= upperlimit) {
out[i] = upperlimit;
} else {
out[i] = std::min<double>(remainder,upperlimit);
}
remainder = remainder + original[i] - out[i];
}
return out;
}
')
Testing them:
x <- c(0,2101,3389,3200,1640,0,0,0,0,0,0,0)
original <- rep(x,20000)
upperlimit <- 2000
system.time(limitstretchR(upperlimit,original))
system.time(limitstretchC(upperlimit,original))
That yielded 80.655 and 0.001 seconds respectively. Native R is quite bad for this. However, I ran a microbenchmark (using a smaller vector) and got some confusing results.
res <- microbenchmark(list=
list(limitstretchR=limitstretchR(upperlimit,rep(x,10000)),
limitstretchC=limitstretchC(upperlimit,rep(x,10000))),
times=110,
control=list(order="random",warmup=10))
print(qplot(y=time, data=res, colour=expr) + scale_y_log10())
boxplot(res)
print(res)
If you were to run that you would see nearly identical results for both functions. This is my first time using microbenchmark, any tips?
I am trying to migrate some code from JAGS to Stan. Say I have the following dataset:
N <- 10
nchoices <- 3
ncontrols <- 3
toydata <- list("y" = rbinom(N, nchoices - 1, .5),
"controls" = matrix(runif(N*ncontrols), N, ncontrols),
"N" = N,
"nchoices" = nchoices,
"ncontrols" = ncontrols)
and that I want to run a multinomial logit with the following code (taken from section 9.5 of the documentation):
data {
int N;
int nchoices;
int y[N];
int ncontrols;
vector[ncontrols] controls[N];
}
parameters {
matrix[nchoices, ncontrols] beta;
}
model {
for (k in 1:nchoices)
for (d in 1:ncontrols)
beta[k,d] ~ normal(0,100);
for (n in 1:N)
y[n] ~ categorical(softmax(beta * controls[n]));
}
I now want to fix the first row of beta to zero. In JAGS I would simply declare in the model block that
for (i in 1:ncontrols) {
beta[1,i] <- 0
}
but I am not sure about how to do this in Stan. I have tried many combinations along the lines of section 6.2 of the documentation (Partially Known Parameters) like, for instance,
parameters {
matrix[nchoices, ncontrols] betaNonObs;
}
transformed parameters {
matrix[nchoices, ncontrols] beta;
for (i in 1:ncontrols) beta[1][i] <- 0
for (k in 2:nchoices) beta[k] <- betaNonObs[k - 1]
}
but none of them work. Any suggestions?
It would be helpful to mention the error message. In this case, if beta is declared to be a matrix, then the syntax you want is the R-like syntax
beta[1,i] <- 0.0; // you also omitted the semicolon
To answer your broader question, I believe you were on the right track with your last approach. I would create a matrix of parameters in the parameters block called free_beta and copy those elements to another matrix declared in the model block called beta that has one extra row at the top for the fixed zeros. Like
data {
int N;
int nchoices;
int y[N];
int ncontrols;
vector[ncontrols] controls[N];
}
parameters {
matrix[nchoices-1, ncontrols] free_beta;
}
model {
// copy free beta into beta
matrix[nchoices,ncontrols] beta;
for (d in 1:ncontrols)
beta[1,d] <- 0.0;
for (k in 2:nchoices)
for (d in 1:ncontrols)
beta[k,d] <- free_beta[k-1,d];
// priors on free_beta, which execute faster this way
for (k in 1:(nchoices-1))
row(free_beta,k) ~ normal(0.0, 100.0);
// likelihood
for (n in 1:N)
y[n] ~ categorical(softmax(beta * controls[n]));
}