Happy newyear! Simulating a model pertaining to circulation, I encounter some questions here! I generate Y correctly as it makes no sense and adds NAs on dataframe into which I am planning to simulate Y 5000 times to integrate. I don't have a idea on that,and really appreciate for any help or suggestions, Guys! Thanks!
[#Investment simulation
library(tidyverse)
library(ggplot2)
library(statmod)
library(invGauss)
library(dplyr)
library(estimatr)
Res<-as.data.frame(matrix(nrow = 27))
k=1
while(k <=5000){#this circulation probably collapesed
Y=c(1610,1550)
DeviaY=c(0)
Pos_value=c(0)
Years<-c(1986,1987)
DiffY=c(0)
prob_poi=(6/13)*(exp(1)^(-(6/13)))
expec<-c()
q <- rinvgauss(27, mean=0.5, disp=0.5) # generate vector of 10 random numbers
p <- pinvgauss(q, mean=0.5, disp=0.5) # p should be uniformly distributed
for(i in 3:27){
regree<-lm_robust(Y~Years)
expec<- predict(regree,newdata=data.frame(Years=1985+i))
DiffY\[i-1\]=0.7*(Y\[i-1\]-tail(expec,1))
DeviaY\[i-1\]=p\[i\]*sd(Y)
Pos_value\[i-1\]=sample(x=c(-1,1,0),replace = T,size = 1,prob = c(prob_poi/2,prob_poi/2,1-prob_poi))
Y\[i\]<- Y\[i-1\]-DiffY\[i-1\]+DeviaY\[i-1\]+Pos_value\[i-1\]*rinvgauss(1,mean = 60,dispersion = 25)
Years\[i\]<-1985+i
if(i == 27) return(Y)
}
Res\[,k\] <- Y#and corresponding to the first'while' on line 10
k<- k+1 #and corresponding to the first'while' on line 10
} #and corresponding to the first'while' on line 10
#My purpose is to repeat the correct calculating processes on line11 to line30 for framing dataframe,but it returns NAs and it make no sense.][1]
Related
Happy newyear! Simulating a model pertaining to circulation, I encounter some questions here! I generate Y correctly as it makes no sense and adds NAs on dataframe into which I am planning to simulate Y 5000 times to integrate. I don't have a idea on that,and really appreciate for any help or suggestions, Guys! Thank[enter image description here][1]
[1]: https://i.stack.imgur.com/kaFqA.png`#Investment simulation
library(tidyverse)
library(ggplot2)
library(statmod)
library(invGauss)
library(dplyr)
library(estimatr)
Res<-as.data.frame(matrix(nrow = 27))
k=1
while(k <=5000){#this circulation probably collapesed
Y=c(1610,1550)
DeviaY=c(0)
Pos_value=c(0)
Years<-c(1986,1987)
DiffY=c(0)
prob_poi=(6/13)*(exp(1)^(-(6/13)))
expec<-c()
q <- rinvgauss(27, mean=0.5, disp=0.5) # generate vector of 10 random numbers
p <- pinvgauss(q, mean=0.5, disp=0.5) # p should be
uniformly distributed
for(i in 3:27){
regree<-lm_robust(Y~Years)
expec<- predict(regree,newdata=data.frame(Years=1985+i))
DiffY[i-1]=0.7*(Y[i-1]-tail(expec,1))
DeviaY[i-1]=p[i]*sd(Y)
Pos_value[i-1]=sample(x=c(-1,1,0),replace = T,size = 1,prob = c(prob_poi/2,prob_poi/2,1-prob_poi))
Y[i]<- Y[i-1]-DiffY[i-1]+DeviaY[i-1]+Pos_value[i-1]*rinvgauss(1,mean = 60,dispersion = 25)
Years[i]<-1985+i
if(i == 27) return(Y)
}
Res[,k] <- Y#and corresponding to the first'while' on line 10
k<- k+1 #and corresponding to the first'while' on line 10
} #and corresponding to the first'while' on line 10
#My purpose is to repeat the correct calculating processes on line11 to line30 for framing dataframe,but it returns NAs and it make no sense.`
I am trying to randomly sample 10 individuals from a population and repeat 1000 times. Is this possible? Here is my code so far and I am not quite sure if I am on the right track. I keep receiving the error "number of items to replace is not a multiple of replacement length".
Here is my code:
B<-1000
for (i in 1:B){
FR3_Acropora_Sample[i]<-(sample(FR3_Acropora$Ratio,size=10,replace=TRUE))
}
Consider replicate (wrapper to sapply):
# MATRIX
sample_matrix <- replicate(B, sample(FR3_Acropora$Ratio, size=10, replace=TRUE))
# LIST
sample_list <- replicate(B, sample(FR3_Acropora$Ratio, size=10, replace=TRUE),
simplify = FALSE)
I believe you can accomplish this as follows. I create a sample dataset of numbers 1 through 50 - you'll skip this step of course. I initialize a vector of lists with a length of 100. I loop from 1 to 100 and choose a random sample to assign to each empty space in my vector. I can then access any sample with sampleList[[x]] where x is any number 1 to 100.
x <- c(1:50)
sampleList <- vector(mode="list", length=100)
for (i in 1:100) {
sampleList[[i]] = sample(x, size = 10, replace = TRUE)
}
Using your variable names, this would look like:
B<-1000
FR3_Acropora_Sample <- vector(mode="list", length=1000)
for (i in 1:B){
FR3_Acropora_Sample[[i]]=sample(FR3_Acropora$Ratio,size=10,replace=TRUE)
}
I am working on Spike Trains and my code to get a spike train like this:
for 20 trials is written below. The image is representational for 5 trials.
fr = 100
dt = 1/1000 #dt in milisecond
duration = 2 #no of duration in s
nBins = 2000 #10msSpikeTrain
nTrials = 20 #NumberOfSimulations
MyPoissonSpikeTrain = function(p, fr= 100) {
p = runif(nBins)
q = ifelse(p < fr*dt, 1, 0)
return(q)
}
set.seed(1)
SpikeMat <- t(replicate(nTrials, MyPoissonSpikeTrain()))
plot(x=-1,y=-1, xlab="time (s)", ylab="Trial",
main="Spike trains",
ylim=c(0.5, nTrials+1), xlim=c(0, duration))
for (i in 1: nTrials)
{
clip(x1 = 0, x2= duration, y1= (i-0.2), y2= (i+0.4))
abline(h=i, lwd= 1/4)
abline(v= dt*which( SpikeMat[i,]== 1))
}
Each trial has spikes occuring at random time points. Now what I am trying to work towards, is getting a random sample time point that works for all 20 trials and I want to get the vector consisting of length of the intervals this point falls into, for each trial. The code to get the time vector for the points where the spikes occur is,
A <- numeric()
for (i in 1: nTrials)
{
ISI <- function(i){
spike_times <- c(dt*which( SpikeMat[i, ]==1))
ISI1vec <- c(diff(spike_times))
A <- c(A, ISI1vec)
return(A)}
}
Then you call ISI(i) for whichever trial you wish to see the Interspike interval vector for. A visual representation of what I want is:
I want to get a vector that has the lengths of the interval where this points fall into, for each trial. I want to figure out it's distribution as well, but that's for later. Can anybody help me figure out how to code my way to this? Any help is appreciated, even if it's just about how to start/where to look.
Your data
set.seed(1)
SpikeMat <- t(replicate(nTrials, MyPoissonSpikeTrain()))
I suggest transforming your sparse matrix data into a list of indices where spikes occur
L <- lapply(seq_len(nrow(SpikeMat)), function(i) setNames(which(SpikeMat[i, ] == 1), seq_along(which(SpikeMat[i, ] == 1))))
Grab random timepoint
set.seed(1)
RT <- round(runif(1) * ncol(SpikeMat))
# 531
Result
distances contains the distances to the 2 nearest spikes - each element of the list is a named vector where the values are the distances (to RT) and their names are their positions in the vector. nearest_columns shows the original timepoint (column number) of each spike in SpikeMat.
bookend_values <- function(vec) {
lower_val <- head(sort(vec[sign(vec) == 1]), 1)
upper_val <- head(sort(abs(vec[sign(vec) == -1])), 1)
return(c(lower_val, upper_val))
}
distances <- lapply(L, function(i) bookend_values(RT-i))
nearest_columns <- lapply(seq_along(distances), function(i) L[[i]][names(distances[[i]])])
Note that the inter-spike interval of the two nearest spikes that bookend RT can be obtained with
sapply(distances, sum)
In this example I'm trying to generate a random time series for 3 individuals at 4 time points (below x contains the 1st timepoints for each individual). I want the values to be randomly increasing rather than decreasing in time. Below is my current solution.
set.seed(0)
x <- rnorm(3)
x
[1] 1.2629543 -0.3262334 1.3297993
y <- c(x,
x*runif(1,.8,1.2),
x*runif(1,.9,1.3),
x*runif(1,1,1.4))
y
[1] 1.2629543 -0.3262334 1.3297993 1.4642135 -0.3782206 1.5417106 1.6138915 -0.4168839 1.6993107 1.5967772
[11] -0.4124631 1.6812906
This has some problems.
For each individual the same coefficient is used for calculating the values for same timepoint resulting in identical trends. How could I get a random coefficient for each multiplication? I could use lapply but then the vector will be "grouped" by individuals not by timepoints.
I don't wish to write the formulas for last timepoints separately and be so precise. Exact coefficients are not important, I just need the values to have a tendency to slightly increase but occasional decreasing should also be allowed. How could I extend the vector more "effectively"?
How to make negative values to also increase?
I managed to solve this thanks to Federico Manigrasso. The solution is below.
TimeSer <- function(num.id, years, init.val) {
df <- data.frame(id = factor(rep(1:num.id, length(years))),
year = rep(years, each = num.id))
yrs <- length(years) - 1
minim <- seq(-.1, by = -.1, len = yrs)
maxim <- seq(.4, by = .4, len = yrs)
val <- list(init.val)
for (i in 1:yrs) {
val[[i + 1]] <- unlist(lapply(init.val, function (x) {
x + (x * runif(1, minim[i], maxim[i]))
}))
}
df$val <- unlist(val)
df
}
df <- TimeSer(num.id = 3, years = 2006:2016, init.val = rnorm(3,1e5, 1e5))
Visual representation of the results:
num.id <- length(unique(df$id))
par(mfrow=c(1,num.id))
lapply(1:num.id, function(x) {
plot(unique(df$year), df$val[df$id == x], type = 'l', col = x)
})
I suggest to put the output in a list, It a lot less messy and you can transform into a vector later (using unlist).
This is how I would rewrite your code
x<-rnorm(3)
time<-3
output<-list(x) #init output list with initial data
par1<-c(0.8,0.9,1)
par2<-c(1.2,1.3,1.4)
for( i in 1:time){
a<-unlist(lapply(x,function(x){x+runif(1,par1[i],par2[i])}))
output[[i+1]]<-a
x<-a
}
let me know if this solves all your problems..
I made a matrix based population model, however, I would like to run more than one simultaneously in order to represent different groups of animals, in order that dispersing individuals can move between matrices. I originally just repeated everything to get a second matrix but then I realised that because I run the model using a for loop and break() under certain conditions (when that specific matrix should stop running, ie that group has died out) it is, understandably, stopping the whole model rather than just that singular matrix.
I was wondering if anyone had any suggestions on the best ways to code the model so that instead of breaking, and stopping the whole for loop, it just stops running across that specific matrix. I'm a little stumped. I have include a single run of one matrix below.
Also if anyone has a more efficient way of creating and running 9 matrices than writing everything out 9 times advice much appreciated.
n.steps <- 100
mats <- array(0,c(85,85,n.steps))
ns <- array(0,c(85,n.steps))
ns[1,1]<-0
ns[12,1]<-rpois(1,3)
ns[24,1]<-rpois(1,3)
ns[85,1] <- 1
birth<-4
nextbreed<-12
for (i in 2:n.steps){
# set up an empty matrix;
mat <- matrix(0,nrow=85,ncol=85)
surv.age.1 <- 0.95
x <- 2:10
diag(mat[x,(x-1)]) <- surv.age.1
surv.age.a <- 0.97
disp <- 1:74
disp <- disp*-0.001
disp1<-0.13
disp<-1-(disp+disp1)
survdisp<-surv.age.a*disp
x <- 11:84
diag(mat[x,(x-1)])<-survdisp
if (i == nextbreed) {
pb <- 1
} else {
pb <- 0
}
if (pb == 1) {
(nextbreed <- nextbreed+12)
}
mat[1,85] <- pb*birth
mat[85,85]<-1
death<-sample(c(replicate(1000,
sample(c(1,0), prob=c(0.985, 1-0.985), size = 1))),1)
if (death == 0) {
break()}
mats[,,i]<- mat
ns[,i] <- mat%*%ns[,i-1]
}
group.size <- apply(ns[1:85,],2,sum)
plot(group.size)
View(mat)
View(ns)
As somebody else suggested on Twitter, one solution might be to simply turn the matrix into all 0s whenever death happens. It looks to me like death is the probability that a local population disappears? It which case it seems to make good biological sense to just turn the entire population matrix into 0s.
A few other small changes: I made a list of replicate simulations so I could summarize them easily.
If I understand correctly,
death<-sample(c(replicate(1000,sample(c(1,0), prob=c(0.985, 1-0.985), size =1))),1)
says " a local population dies completely with probability 1.5% ". In which case, I think you could replace it with rbinom(). I did that below and my plots look similar to those I made with your code.
Hope that helps!
lots <- replicate(100, simplify = FALSE, expr = {
for (i in 2:n.steps){
# set up an empty matrix;
mat <- matrix(0,nrow=85,ncol=85)
surv.age.1 <- 0.95
x <- 2:10
diag(mat[x,(x-1)]) <- surv.age.1
surv.age.a <- 0.97
disp <- 1:74
disp <- disp*-0.001
disp1<-0.13
disp<-1-(disp+disp1)
survdisp<-surv.age.a*disp
x <- 11:84
diag(mat[x,(x-1)])<-survdisp
if (i == nextbreed) {
pb <- 1
} else {
pb <- 0
}
if (pb == 1) {
(nextbreed <- nextbreed+12)
}
mat[1,85] <- pb*birth
mat[85,85]<-1
death<-rbinom(1, size = 1, prob = 0.6)
if (death == 0) {
mat <- 0
}
mats[,,i]<- mat
ns[,i] <- mat%*%ns[,i-1]
}
ns
})
lapply(lots, FUN = function(x) apply(x[1:85,],2,sum))