R/mod_processes.R

In lampoverde/Der: Derivatives and Structured Products

# TODO: il nome mand_pos ha ridondanze
genGrid<-function(t=NULL, from=0, to,step=1,mand=list()){
    ifelse(is.null(t),t<-seq(from,to,by=step/252),t<-t)
    t<-sort(unique(do.call(c, as.list(c(t,mand)))))
    ifelse(length(mand)>0,mand_pos<-lapply(mand,match,t),mand_pos<-NA)
    list(t=t,mand_pos=mand_pos)
}

# Simulazione nei punti mandatories
at_mand<-function(path, pos){
    lapply(X = pos, FUN = at, x=path)
}


gbmTimeVar<-function(t=NULL, from=0, to,step=1,mand=list(), f_disc=function(t) 1, f_dvd=function(t) 0, f_sd=function(t) 0,
                     f_fxvol=function(t) 0, fxcor=0, s0=1,f_rand=rnorm,p_rand=list(n=NULL)){
    # Genera un path (GBM r e vol time varying)

    grid<-genGrid(t=t,from=from,to=to,step=step,mand)

    N<-length(grid$t)
    dt<-grid$t[-1]-grid$t[-N]

    #Sostituire sapply con vapply x efficienza
    sd<-sapply(grid$t[-1],f_sd)
    dvd<-sapply(grid$t[-1],f_dvd)
    disc<-sapply(grid$t, f_disc)
    fxvol<-sapply(grid$t[-1], f_fxvol)

    p_rand[[1]]<-N-1
    f_rand<-f_rand
    # COnsiderare se portare nella closure disc[-N]/disc[-1] etc per minimizzare il lavoro a ogni iterazione
    if(is.null(f_rand)) function(z) cumprod(c(s0, disc[-N]/disc[-1]*exp(  (-sd^2/2 - dvd - fxcor*fxvol*sd)*dt + sd*z*sqrt(dt))))
    else function()cumprod(c(s0, disc[-N]/disc[-1]*exp(  (-sd^2/2 - dvd - fxcor*fxvol*sd)*dt + sd*do.call(f_rand,p_rand)*sqrt(dt))))
}


# FUNZIONE-SHORTCUT: Caso particolare del timeVar
gbmFixed<-function(t=NULL, from=0, to,step=1,mand=list(), r, dvd, sd, fxvol=0, fxcor=0, s0=1,f_rand=rnorm,p_rand=list(n=NULL)){
    gbmTimeVar(t, from, to,step,mand, f_disc=discFix(r), f_dvd=function(t) dvd, f_sd=function(t) sd,
               f_fxvol=function(t) fxvol, fxcor=fxcor, s0=s0,
               f_rand=f_rand,p_rand=p_rand)
}


# Limitato per costruzione a gbm, ideale sarebbe che potesse accogliere ogni tipo di processo
# il problema dato dalle closure

gbmVectTimeVar<-function(t=NULL, from=0, to,step=1,mand=list(), gens, f_rand=rmvnorm,p_rand=list(n=NULL,sigma=diag(length(gens)))){

    grid<-genGrid(t=t,from=from,to=to,step=step,mand)

    N<-length(grid$t)
    dt<-grid$t[-1]-grid$t[-N]

    K<-length(gens)
    s0<-array(NA,K)
    DISC<-matrix(NA,N,K)
    DVD<-FXVOL<-SD<-matrix(NA,N-1,K)
    FXCOR<-matrix(NA,N-1,K)
    i<-1
    for(g in gens){
        s0<-environment(g)$s0
        DISC[,i]<-environment(g)$disc
        DVD[,i]<-environment(g)$dvd
        FXVOL[,i]<-environment(g)$fxvol
        SD[,i]<-environment(g)$sd
        FXCOR[,i]<-environment(g)$fxcor
        i<-i+1
    }

    p_rand[[1]]<-N-1

    if(is.null(f_rand)){
        function(z){
            apply(
                rbind(s0, DISC[-N,]/DISC[-1,]*exp(  (-SD^2/2 - DVD - FXCOR*FXVOL*SD)*dt + SD*z*sqrt(dt))),
                2, cumprod)
        }
    }
    else{
        function(){
            apply(
                rbind(s0, DISC[-N,]/DISC[-1,]*exp(  (-SD^2/2 - DVD - FXCOR*FXVOL*SD)*dt + SD*do.call(f_rand, p_rand)*sqrt(dt))),
                2, cumprod)
        }
    }

}



# ======================================== CPP ================================================


#verificare se possono essere costruite delle closure (le funz primitive non hanno enclosing env)

gbmTimeVar_RCPP<-function(t=NULL, from=0, to,step=1,mand=list(), f_disc=function(t) 1, f_dvd=function(t) 0, f_sd=function(t) 0,
                     f_fxvol=function(t) 0, fxcor=0, s0=1,f_rand=rnorm,p_rand=list(n=NULL)){
    # Genera un path (GBM r e vol time varying)

    grid<-genGrid(t=t,from=from,to=to,step=step,mand)

    N<-length(grid$t)
    dt<-grid$t[-1]-grid$t[-N]

    #Sostituire sapply con vapply x efficienza
    sd<-sapply(grid$t[-1],f_sd)
    dvd<-sapply(grid$t[-1],f_dvd)
    disc<-sapply(grid$t, f_disc)
    fxvol<-sapply(grid$t[-1], f_fxvol)

    p_rand[[1]]<-N-1
    f_rand<-f_rand
    # COnsiderare se portare nella closure disc[-N]/disc[-1] etc per minimizzare il lavoro a ogni iterazione
    # e portare la generazione dei nr casuali in C++
    if(is.null(f_rand)) function(z) .Call('_DeR_gbmTimeVarCPP', PACKAGE = 'DeR', s0, disc, sd, dvd, fxvol, dt, fxcor, z)
    else function(){
        z<-do.call(f_rand,p_rand)
        .Call('_DeR_gbmTimeVarCPP', PACKAGE = 'DeR', s0, disc, sd, dvd, fxvol, dt, fxcor, z)
    }
}



dupireTimeVar<-function(t=NULL, from=0, to,step=1,mand=list(), f_disc=function(t) 1, f_dvd=function(t) 0, lv=list(t,s,vol),
                          f_fxvol=function(t) 0, fxcor=0, s0=1,f_rand=rnorm,p_rand=list(n=NULL)){
    # Genera un path (GBM r e vol time varying)

    grid<-genGrid(t=t,from=from,to=to,step=step,mand)

    N<-length(grid$t)
    dt<-grid$t[-1]-grid$t[-N]

    #Sostituire sapply con vapply x efficienza
    sd<-interp2d(grid$t[-1],lv$t, lv$s, lv$vol)   # <<======== FARE FARE FARE... (interpola lungo il tempo)
    dvd<-sapply(grid$t[-1],f_dvd)
    disc<-sapply(grid$t, f_disc)
    fxvol<-sapply(grid$t[-1], f_fxvol)

    p_rand[[1]]<-N-1
    f_rand<-f_rand
    # COnsiderare se portare nella closure disc[-N]/disc[-1] etc per minimizzare il lavoro a ogni iterazione
    # e portare la generazione dei nr casuali in C++
    if(is.null(f_rand)) function(z) .Call('_DeR_dupireTimeVarCPP', PACKAGE = 'DeR', s0, disc, sd, dvd, fxvol, dt, fxcor, z)
    else function(){
        z<-do.call(f_rand,p_rand)
        .Call('_DeR_dupireTimeVarCPP', PACKAGE = 'DeR', s0, disc, sd, dvd, fxvol, dt, fxcor, z)
    }
}