# Various useful functions

getPmat <- function(tmu,tv_ti_ratio,acgt) {
    # Returns the evolutionary substitution matrix
    if (any(acgt >= 1) || any(acgt <= 0)) {
        abort("The ACGT frequencies must be in the range 0 to 1")
    } else if (sum(acgt) != 1) {
        abort("The ACGT frequencies do not sum to 1")
    } else if (tv_ti_ratio <= 0) {
        abort("The transversion and transtition ratio cannot go under 0")
    }

    # Returns the substitution probability matrix.
    if (tv_ti_ratio == 1 && identical(acgt, c(0.25, 0.25, 0.25, 0.25))) {
        return(jukesCantorPmat(tmu))
    } else {
        Q <- qmatHKY85(tmu, tv_ti_ratio, acgt)
        r  <- eigen(Q)
        B <- r$vectors
        E  <- diag(exp(r$values))

        #      Q        The eigen vector change of basis
        #  M  ->   M
        #
        #  ^       ^
        #  |B^-1   |B
        #     Eig
        #  N  ->   N

        # Little trick to avoid numerical difficulties
        out <- solve(a=t(B), b=E %*% t(B))

        rownames(out) <- c("A","C","G","T")
        colnames(out) <- c("A","C","G","T")
        return(out)
    }
}

jukesCantorPmat2 <- function(tmu){
    # Using the Juke-Cantor model
    names <- c("A", "C", "G", "T")
    return(matrix(1 / 4 - exp(-tmu) / 4, nrow=4, ncol=4, dimnames=list(names, names)) + diag(exp(-tmu), 4, 4))
}

qmatHKY85 <- function(tmu, tv_ti, acgt) {
    # HKY85 model
    #               |  sum_1          pi_c * tv_ti   pi_g           pi_t * tv_ti  |
    #               |  pi_a * tv_ti   sum_2          pi_g * tv_ti   pi_t          |
    #  Q = tmu  *   |  pi_a           pi_c * tv_ti   sum_3          pi_t * tv_ti  |
    #               |  pi_a * tv_ti   pi_c           pi_g * tv_ti   sum_4         |
    #
    Qmat <- rbind(
        c(0, tv_ti, 1, tv_ti) * acgt,
        c(tv_ti, 0, tv_ti, 1) * acgt,
        c(1, tv_ti, 0, tv_ti) * acgt,
        c(tv_ti, 1, tv_ti, 0) * acgt)

    return(tmu * (Qmat - diag(rowSums(Qmat))))
}

metroDesc <- function(lpr, lol){
    # the logic in the Metropolis-Hastings step
    stopifnot(!is.na(lpr))
    stopifnot(!is.na(lol))

    return(log(runif(1)) < lpr - lol)
}

seqProbVecLambda <- function(lambda, lambda_disp, m, termini="both") {
    # Returns the position specific probability of being in an overhang
    pvals <- dnbinom(1:m - 1, prob=lambda, size=lambda_disp)
    psum <- (1 - cumsum(pvals)) / 2

    if (termini == "both") {
        return(c(psum[1:(m / 2)], rev(psum[1:(m / 2)])))
    } else if (termini == "5p") {
        return(psum)
    } else if (termini == "3p") {
        return(rev(psum))
    } else {
        abort("Invalid value for termini: '%s'", termini)
    }
}

cat("Compiling C++ extension. This may take a moment ..\n")
sourceCpp(code='
// [[Rcpp::depends(RcppGSL)]]
#include <RcppGSL.h>

#include <gsl/gsl_sf_gamma.h>

// [[Rcpp::export]]
double logLikFunOneBaseFast(
    const Rcpp::NumericVector Gen,
    const Rcpp::NumericVector S,
    const Rcpp::NumericVector theta,
    const double deltad,
    const double deltas,
    const Rcpp::NumericVector laVec,
    const Rcpp::NumericVector nuVec,
    const int m,
    const int lin
) {
    Rcpp::NumericVector pDam(4);
    double result = 0;

    for (int i = 0; i < laVec.size(); i++) {
        double la = laVec[i];
        double nu = nuVec[i];
        double pct = nu * (la * deltas + deltad * (1 - la));
        double pga = (1 - nu) * (la * deltas + deltad * (1 - la));

        pDam[0] = theta(lin - 1, 0) * 1 + theta(lin - 1, 2) * pga;
        pDam[1] = theta(lin - 1, 1) * (1 - pct);
        pDam[2] = theta(lin - 1, 2) * (1 - pga);
        pDam[3] = theta(lin - 1, 1) * pct + theta(lin - 1, 3) * 1;

        double p1 = gsl_sf_lnfact(Gen(i)) -
            gsl_sf_lnfact(S(i, 0)) -
            gsl_sf_lnfact(S(i, 1)) -
            gsl_sf_lnfact(S(i, 2)) -
            gsl_sf_lnfact(S(i, 3));

        double p2 = S(i, 0) * log(pDam[0]) +
            S(i, 1) * log(pDam[1]) +
            S(i, 2) * log(pDam[2]) +
            S(i, 3) * log(pDam[3]);

        result += p1 + p2;
    }
    return result;
}')
cat("Compilation of C++ extension completed\n")

logLikAll <- function(dat, Theta, deltad, deltas, laVec, nuVec, m) {
    # Calculates the logLikelihood for all the bases
    if (deltad < 0 || deltad > 1 || deltas < 0 || deltas > 1) {
        return(-Inf)
    }

    Asub <- dat[, "A.C"] + dat[, "A.G"] + dat[, "A.T"]
    ALL <- logLikFunOneBaseFast(dat[,"A"], cbind(dat[,"A"]-Asub,dat[,"A.C"],dat[,"A.G"],dat[,"A.T"]),Theta,deltad,deltas,laVec,nuVec,m,1)

    Csub <- dat[, "C.A"] + dat[, "C.G"] + dat[, "C.T"]
    CLL <- logLikFunOneBaseFast(dat[,"C"], cbind(dat[,"C.A"],dat[,"C"]-Csub,dat[,"C.G"],dat[,"C.T"]),Theta,deltad,deltas,laVec,nuVec,m,2)

    Gsub <- dat[, "G.A"] + dat[, "G.C"] + dat[, "G.T"]
    GLL <- logLikFunOneBaseFast(dat[,"G"], cbind(dat[,"G.A"],dat[,"G.C"],dat[,"G"]-Gsub,dat[,"G.T"]),Theta,deltad,deltas,laVec,nuVec,m,3)

    Tsub <- dat[, "T.A"] + dat[, "T.C"] + dat[, "T.G"]
    TLL <- logLikFunOneBaseFast(dat[,"T"], cbind(dat[,"T.A"],dat[,"T.C"],dat[,"T.G"],dat[,"T"]-Tsub),Theta,deltad,deltas,laVec,nuVec,m,4)

    return(ALL + CLL + GLL + TLL)
}

getParams <- function(cp){
    #Utility function nice to update the MCMC iterations matrix
    return(c(cp$Theta,cp$Rho,cp$DeltaD,cp$DeltaS,cp$Lambda,cp$LambdaRight,cp$LambdaDisp))
}

plotTrace<- function(dat,main,k=111){
    #Running median of the MCMC iterations
    plot(1:length(dat),dat,xlab="Iteration",ylab="",main=main,type="l")
}

plotEverything <- function(mcmcOut,hi=0,pl,thin=100){
    #Plots the MCMC traceplot in the form of a running median and
    #histogram of the MCMC iterations
    if (sum(c(cu_pa$same_overhangs==FALSE,
                    cu_pa$fix_disp==FALSE,
                    cu_pa$fix_ti_tv==FALSE))>1){
        #Check if I need to add a extra row
        a_extra_row <- 1
    }else {
        a_extra_row <- 0
    }
    par(mfrow=c(3,2+a_extra_row))
    if(hi){
        hist(mcmcOut$out[,"Theta"],main=expression(theta),xlab="",freq=FALSE)
        if (!mcmcOut$cu_pa$fix_ti_tv){
            hist(mcmcOut$out[,"Rho"],main=expression(rho),xlab="",freq=FALSE)
        }
        hist(mcmcOut$out[,"DeltaD"],main=expression(delta[d]),xlab="",freq=FALSE)
        hist(mcmcOut$out[,"DeltaS"],main=expression(delta[s]),xlab="",freq=FALSE)
        hist(mcmcOut$out[,"Lambda"],main=expression(lambda),xlab="",freq=FALSE)
        if (!mcmcOut$cu_pa$same_overhangs){
            hist(mcmcOut$out[,"LambdaRight"],main=expression(lambda[r]),xlab="",freq=FALSE)
        }
        if (!mcmcOut$cu_pa$fix_disp){
            hist(mcmcOut$out[,"LambdaDisp"],main=expression(sigma[lambda]),xlab="",freq=FALSE)
        }
        hist(mcmcOut$out[,"LogLik"],main="LogLik",xlab="",freq=FALSE)
    }else {
        plotTrace(mcmcOut$out[,"Theta"],main=expression(theta))
        if (!mcmcOut$cu_pa$fix_ti_tv){
            plotTrace(mcmcOut$out[,"Rho"],main=expression(theta))
        }
        plotTrace(mcmcOut$out[,"DeltaD"],main=expression(delta[d]))
        plotTrace(mcmcOut$out[,"DeltaS"],main=expression(delta[s]))
        plotTrace(mcmcOut$out[,"Lambda"],main=expression(lambda))
        if (!mcmcOut$cu_pa$same_overhangs){
            plotTrace(mcmcOut$out[,"LambdaRight"],main=expression(lambda[r]))
        }
        if (!mcmcOut$cu_pa$fix_disp){
            plotTrace(mcmcOut$out[,"LambdaDisp"],main=expression(sigma[lambda]))
        }
        plotTrace(mcmcOut$out[,"LogLik"],main="LogLik")
    }
    par(mfrow=c(1,1))
}

accRat <- function(da){
    #A rough measure of the acceptance ratio
    return(length(unique(da))/length(da))
}

adjustPropVar <- function(mcmc,propVar){
    #Adjust the proposal variance to get something near .22
    for (i in colnames(mcmc$out)){
        if (i=="LogLik"){
            next
        } else if (i=="LambdaRight" & mcmc$cu_pa$same_overhangs){
            next
        } else if (i=="LambdaDisp" & mcmc$cu_pa$fix_disp){
            next
        } else if (i=="Rho" & mcmc$cu_pa$fix_ti_tv){
            next
        }
        rat <- accRat(mcmc$out[,i])
        if (rat<0.1){
            propVar[[i]] <- propVar[[i]]/2
        } else if (rat>0.3) {
            propVar[[i]] <- propVar[[i]]*2
        }
    }
    return(propVar)
}

runGibbs <- function(cu_pa,iter){
    #Sampling over the conditional posterior distribution
    #for the parameters.
    esti <- matrix(nrow=iter,ncol=8)
    colnames(esti) <- c("Theta","Rho","DeltaD","DeltaS","Lambda","LambdaRight","LambdaDisp","LogLik")
    for (i in 1:iter){
        cu_pa<-updateTheta(cu_pa)
        if (!cu_pa$fix_ti_tv){
            #Fix the transition and transversion ratio
            cu_pa<-updateRho(cu_pa)
        }
        cu_pa<-updateDeltaD(cu_pa)
        cu_pa<-updateDeltaS(cu_pa)
        cu_pa<-updateLambda(cu_pa)
        if (!cu_pa$same_overhangs){
            #Not the same overhangs update lambda right
            cu_pa <- updateLambdaRight(cu_pa)
        }
        if (!cu_pa$fix_disp){
            #Allowing dispersion in the overhangs
            cu_pa<-updateLambdaDisp(cu_pa)
        }
        esti[i,c(1:7)] <- getParams(cu_pa)
        esti[i,"LogLik"] <- logLikAll(cu_pa$dat,cu_pa$ThetaMat,cu_pa$DeltaD,cu_pa$DeltaS,cu_pa$laVec,cu_pa$nuVec,cu_pa$m)
        if (! (i %% 1000) && cu_pa$verbose){
            cat("MCMC-Iter\t",i,"\t",esti[i,"LogLik"],"\n")
        }
    }
    return(list(out=esti,cu_pa=cu_pa))
}

simPredCheck <- function(da,output){
    #Simulates one draw from the posterior predictive distribution
    #and the probability of a C>T substitution because of a cytosine
    #demnation.
    bases <- da[,c("A","C","G","T")]
    #Constructing the lambda vector
    if (output$cu_pa$same_overhangs){
        laVec <- seqProbVecLambda(sample(output$out[,"Lambda"],1),
                                  sample(output$out[,"LambdaDisp"],1),
                                  output$cu_pa$m,
                                  output$cu_pa$termini)
    }else {
        laVecLeft <- seqProbVecLambda(sample(output$out[,"Lambda"],1),
                                      sample(output$out[,"LambdaDisp"],1),
                                      output$cu_pa$m)
        laVecRight <- seqProbVecLambda(sample(output$out[,"LambdaRight"],1),
                                       sample(output$out[,"LambdaDisp"],1),
                                       output$cu_pa$m)
        laVec <- c(laVecLeft[1:(output$cu_pa$m/2)],laVecRight[(output$cu_pa$m/2+1):output$cu_pa$m])
    }
    #Constructing the nu vector
    nuVec <- output$cu_pa$nuVec

    #Sample the other parameters
    des <- sample(output$out[,"DeltaS"],1)
    ded <- sample(output$out[,"DeltaD"],1)
    the <- sample(output$out[,"Theta"],1)
    rho <- sample(output$out[,"Rho"],1)
    pmat <- getPmat(the,rho,output$cu_pa$acgt)
    ptransCT <- pmat["C","T"]
    ptransCC <- pmat["C","C"]
    ptransGA <- pmat["G","A"]
    ptransGG <- pmat["G","G"]
    #
    coln <- c("A.C","A.G","A.T","C.A","C.G","C.T","G.A","G.C","G.T","T.A","T.C","T.G")
    subs <- matrix(NA,nrow=nrow(output$cu_pa$dat),ncol=4+length(coln))
    colnames(subs) <- c("A","C","G","T",coln)
    #
    damProb <- rep(NA,nrow(output$cu_pa$dat))
    damProbGA <- damProb
    for (i in 1:nrow(output$cu_pa$dat)){
        #Construct the site specific probabilities
        pct <- nuVec[i]*(laVec[i]*des+ded*(1-laVec[i]))
        pga <- (1-nuVec[i])*(laVec[i]*des+ded*(1-laVec[i]))
        pDamMat <- matrix(c(
                         1,0,0,0,
                         0,1-pct,0,pct,
                         pga,0,1-pga,0,
                         0,0,0,1
                         ),nrow=4,byrow=TRUE)
        ThetapDam <- pDamMat %*% pmat
        #Calculate the probability C.T due to cytosine demanation
        damProb[i] <- ptransCC*pct/(ptransCC*pct+ptransCT)
        #Do not forget the reverse complement
        damProbGA[i] <- ptransGG*pga/(ptransGG*pga+ptransGA)
        #Then draw from a multinomial distribution
        subs[i,c("A.C","A.G","A.T")] <- t(rmultinom(1,output$cu_pa$dat[i,"A"],ThetapDam[1,]))[-1]/output$cu_pa$dat[i,"A"]
        subs[i,c("C.A","C.G","C.T")] <- t(rmultinom(1,output$cu_pa$dat[i,"C"],ThetapDam[2,]))[-2]/output$cu_pa$dat[i,"C"]
        subs[i,c("G.A","G.C","G.T")] <- t(rmultinom(1,output$cu_pa$dat[i,"G"],ThetapDam[3,]))[-3]/output$cu_pa$dat[i,"G"]
        subs[i,c("T.A","T.C","T.G")] <- t(rmultinom(1,output$cu_pa$dat[i,"T"],ThetapDam[4,]))[-4]/output$cu_pa$dat[i,"T"]
    }
    return(list(subs=subs,damProb=damProb,damProbGA=damProbGA))
}

calcSampleStats <- function(da,X){
    #Summary statistics of the posterior distributions
    return(data.frame(
                      x=1:nrow(da),
                      pos=da[,"Pos"],
                      mea=apply(X,1,mean),
                      med=apply(X,1,median),
                      loCI=apply(X,1,quantile,c(0.025), na.rm = TRUE),
                      hiCI=apply(X,1,quantile,c(0.975), na.rm = TRUE)
                      ))
}

postPredCheck <- function(da,output,samples=10000){
    #Plots the 95% posterior predictive intervals with the data as lines.
    #Returns the site specific probability of a C>T or G>A substitution
    #because of a cytosine demnation.
    CTs <- matrix(NA,nrow=nrow(da),ncol=samples)
    GAs <- matrix(NA,nrow=nrow(da),ncol=samples)
    REs <- matrix(NA,nrow=nrow(da),ncol=samples)
    C2TProbs <- matrix(NA,nrow=nrow(da),ncol=samples)
    G2AProbs <- matrix(NA,nrow=nrow(da),ncol=samples)
    #Two indices here, 1-based and the relative one
    da <- cbind(1:(nrow(da)),da)
    colnames(da)[1] <- "oneBased"
    #Get the breaks depending on parameters for pretty plots
    if (output$cu_pa$termini == "both") {
        bres <- c(seq(from=1,to=floor(nrow(da)/2),by=2),rev(seq(from=nrow(dat),to=floor(nrow(da)/2)+1,by=-2)))
    } else if (output$cu_pa$termini == "5p") {
        bres <- seq(from=1,to=nrow(da),by=2)
    } else if (output$cu_pa$termini == "3p") {
        bres <- seq(from=nrow(dat),to=1,by=-2)
    }else {
        abort("There is something fishy with the options")
    }
    labs <- dat[bres,"Pos"]
    #Sample from the posterior predicitive distibution
    for (i in 1:samples){
        sam <- simPredCheck(da,output)
        C2TProbs[,i] <- sam$damProb
        G2AProbs[,i] <- sam$damProbGA
        CTs[,i] <- sam$subs[,"C.T"]
        GAs[,i] <- sam$subs[,"G.A"]
        REs[,i] <- apply(sam$subs[,c("A.C","A.G","A.T","C.A","C.G","G.C","G.T","T.A","T.C","T.G")],1,mean)
    }
    CTsStats <- calcSampleStats(da,CTs)
    GAsStats <- calcSampleStats(da,GAs)
    REsStats <- calcSampleStats(da,REs)
    #Plotting the posterior predictive intervals
    p <- ggplot()+
         geom_point(aes(x,mea,colour="C->T"),data=CTsStats)+
         geom_point(aes(x,mea,colour="G->A"),data=GAsStats)+
         geom_point(aes(x,mea,colour="Others"),data=REsStats)+
         geom_errorbar(aes(x=x,ymin=loCI,ymax=hiCI,color="C->T"),data=CTsStats)+
         geom_errorbar(aes(x=x,ymin=loCI,ymax=hiCI,color="G->A"),data=GAsStats)+
         geom_errorbar(aes(x=x,ymin=loCI,ymax=hiCI,color="Others"),data=REsStats)+
         geom_line(aes(oneBased,C.T/C),color="red",data=data.frame(da))+
         geom_line(aes(oneBased,G.A/G),color="green",data=data.frame(da))+
         geom_line(aes(oneBased,((A.C+A.G+A.T)/A+(C.A+C.G)/C+(G.C+G.T)/G+(T.A+T.C+T.G)/T)/10),color="blue",data=data.frame(da))+
         labs(y = "Substitution rate",
              x = "Relative position",
              colour = "Subs. type",
              title = "Posterior prediction intervals")+
         scale_x_continuous(breaks=bres,labels=labs)
    if (output$cu_pa$use_bw_theme){
        p <- p+theme_bw()
    }
    plot(p)
    #The correcting probabilities
    coProbs <- cbind(da[,"Pos"],apply(C2TProbs,1,mean),apply(G2AProbs,1,mean))
    colnames(coProbs) <- c("Position","C.T","G.A")
    return(coProbs)
}

writeMCMC <- function(out,filename){
    #Writes the posterior samples to a file
    parameters <- c("Theta","DeltaD","DeltaS","Lambda")
    if (!out$cu_pa$fix_ti_tv){
        parameters <- c(parameters,"Rho")
    }
    if (!out$cu_pa$same_overhangs){
        parameters <- c(parameters,"LambdaRight")
    }
    if (!out$cu_pa$fix_disp){
        parameters <- c(parameters,"LambdaDisp")
    }
    parameters <- c(parameters,"LogLik")
    write.csv(out$out[,parameters],paste(filename,".csv",sep=""))
    #Now calculate summary statistic of the posterior distributions
    mea <- apply(out$out[,parameters],2,mean)
    std <- apply(out$out[,parameters],2,sd)
    qua <- apply(out$out[,parameters],2,quantile,seq(from=0,to=1,by=.025))
    acc <- apply(out$out[,parameters],2,accRat)
    summStat <- rbind(mea,std,acc,qua)
    rownames(summStat)[1] <- "Mean"
    rownames(summStat)[2] <- "Std."
    rownames(summStat)[3] <- "Acceptance ratio"
    write.csv(summStat,paste(filename,"_summ_stat.csv",sep=""))
}


distXY <- function(X, Y)
{
	nx <- dim(X)[1]
	ny <- dim(Y)[1]
	h.x <- rowSums(X^2)
	h.y <- rowSums(Y^2)
	ones.x <- rep(1,nx)
	ones.y <- rep(1,ny)
	D2xy <- h.x%*%t(ones.y) - 2*X %*% t(Y) + ones.x%*%t(h.y)
}


library(memuse)
library(merkhet)
suppressMessages(library(fmlr))

m = 1000000
n = 250
seed = 1234
type = "float"

# ------------------------------------------------------------------------------
b = bench(sprintf("crossprod - %dx%d (%s) type=%s", m, n, as.character(howbig(m, n, type=type)), type))

x_cpu = cpumat(m, n)
x_cpu$fill_runif(seed)
x_r = x_cpu$to_robj()

b$time(crossprod(x_r), name="R")

b$time(linalg_crossprod(x=x_cpu), name="fmlr - CPU")

if (fml_gpu())
{
  c = card()
  x_gpu = gpumat(c)
  x_gpu$from_robj(x_r)

  b$time({
    linalg_crossprod(x=x_gpu)
    c$synch()
  }, name="fmlr - GPU")
}

b$print()


# 4. faza: Analiza podatkov

require(ggdendro)

fit <- lm(data=PORABA, vrednost ~ as.numeric(leto))
l <- data.frame(leto=seq(2000,2025))
predict(fit,l)
napoved <- l %>% mutate(vrednost=predict(fit, .))

lin1 <- ggplot(PORABA, aes(x=as.numeric(leto), y=vrednost/1e6*1000000))+
  geom_line()+
  geom_point(data=napoved, aes(x=as.numeric(leto), y=vrednost/1e6*1000000), color='blue', size=3)+
  geom_smooth(method='lm', se=FALSE)+
  xlab('leto')+ylab('€/družinski član')

#shiny

graf.dostopnost <- function(spol,starost,dobrina){
  if(spol=='moski'){
    podatki <- DOSTOPNOST %>% filter(SPOL=='Moški' &
                                     STAROST==starost & DOBRINA==dobrina)
  }
  if(spol=='zenski'){
    podatki <- DOSTOPNOST %>% filter(SPOL=='Ženske' &
                                     STAROST==starost & DOBRINA==dobrina)
  }
  don <- xts(x=podatki$VREDNOST, order.by=as.yearqtr.default(podatki$LETO))
  dygraph(don) %>%
    dyOptions(labelsUTC = TRUE, fillGraph=TRUE, fillAlpha=0.1,
              drawGrid = FALSE, colors="#f09ce0") %>%
    dyCrosshair(direction = "vertical") %>%
    dyHighlight(highlightCircleSize = 5, highlightSeriesBackgroundAlpha = 0.2,
                hideOnMouseOut = FALSE)  %>%
    dyRoller(rollPeriod = 1) %>%
    dySeries("V1", label = "Število")
}


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

data <- read.csv('../../results/server_metadata_enabled/data_all.csv', sep = ';')

# Means
aggregate(data$time, list(data$combination), median)
# C0        4470.0
# C1K       4501.0
# C10K      1227.0
# C100K     1023.0
# C1000K    1043.5
# 0         4187.0
# 1K        4568.5
# 10K       1272.5
# 100K      1988.0
# 1000K     4491.0

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: Means of cached combinations are equal
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_0' | data$combination=='combination_1' | data$combination=='combination_2' | data$combination=='combination_3' | data$combination=='combination_4'),])
# p: 2.11e-07
# => Reject H0, non-equal means => Exec times decrease with increasing result counts

# H0: Means of non-cached combinations are equal
kruskal.test(time ~ combination, data = data[which(data$combination=='combination_5' | data$combination=='combination_6' | data$combination=='combination_7' | data$combination=='combination_8' | data$combination=='combination_9'),])
# p: 0.0005934
# => Reject H0, non-equal means => Exec times decrease with increasing result counts

data_thres_cached <- read.csv('../../results/server_metadata_enabled/threshold_serverload_cached.csv', sep = ';')
cor.test(data_thres_cached$threshold, data_thres_cached$load, method="pearson") # p: 0.4577, corr: 0.4406407

data_thres_notcached <- read.csv('../../results/server_metadata_enabled/threshold_serverload_notcached.csv', sep = ';')
cor.test(data_thres_notcached$threshold, data_thres_notcached$load, method="pearson") # p: 0.03266, corr: 0.9086962


# d: dataset, m: mean, sd: width, a: aplitude

maxLetality = 0.1
numberOfDaysDouble = 3
durationMax <- as.integer(log(population, 2 ** (1 / numberOfDaysDouble)))

print('Max Duration:')
print(durationMax)

log2Population <- as.integer(log2(population * maxLetality))

print('Log2 Max Dead:')
print(log2Population)

mTab <- seq(0, durationMax, by = 0.1)
sdTab <- seq(1.0, durationMax / 6, by = 0.1)

print(mTab)
print(sdTab)
vOrig = Inf

aApprox = 0
mApprox = 0
sdApprox = 0

for (sd in sdTab) {
  for(m in mTab) {
    pnFast <- pnorm(1:length(data), mean = m, sd = sd)

    n <- (log2Population - 1):1
    aTabPow <- 2 ** n
    aApproxCur = 2 ** log2Population
    vAtAApproxCur = Inf
    for (a in aTabPow) {
      v <- var(data - (pnFast * aApproxCur))
      vAp <- var(data - (pnFast * (aApproxCur + a)))
      vAm <- var(data - (pnFast * (aApproxCur - a)))

      if (v > vAp && vAm > vAp) {
        aApproxCur = aApproxCur + a
      } else if (v > vAm && vAp > vAm) {
        aApproxCur = aApproxCur - a
      }
      if (v < vAtAApproxCur) {
        aApproxCurMin = aApproxCur
        vAtAApproxCur = v
      }
    }
    if (vAtAApproxCur < vOrig) {
      sdApprox = sd
      mApprox = m
      aApprox = aApproxCurMin
      vOrig = vAtAApproxCur
    }
  }
}
print('sdApprox: ')
print(sdApprox)


#' V-structure bias, binary exposure and binary outcome.
#'
#' Explore bias due to sample ascertainment when the exposure and outcome are binary variables. This class explores the range or OR generated by parameters in the following model:
#' \eqn{P(S = 1 | A,Y) = \beta_0 + \beta_a A + \beta_y Y + \beta_{ay}AY}
#' Where A is a binary exposure, Y is a binary outcome and S indicates whether an individual is present in the dataset
#' \eqn{P(S = 1)} is the proportion of the population that is present in the data.
#'
#' @importFrom R6 R6Class
#' @export
VBB <- R6Class("VBB", list(

	#' @field param Dataframe of parameter range list
	param = NULL,
	details = list(),

	#' @description
	#' Calculate the expected OR under collider bias when null hypothoses of OR = 1 is true:
	#' @param b0 Baseline probability of being selected
	#' @param ba Effect of A on being selected
	#' @param by Effect of Y on being selected
	#' @param bay Effect of joint AY interaction on being selected
	#'
	#' @return Odds ratio
	or_calc = function(b0, ba, by, bay)
	{
		b0 * (b0 + ba + by + bay) / ((b0 + ba) * (b0 + by))
	},

	#' @description
	#' Calculate the proportion of samples included in the model for a given set of parameters
	#' @param b0 Baseline probability of being selected
	#' @param ba Effect of A on being selected
	#' @param by Effect of Y on being selected
	#' @param bay Effect of joint AY interaction on being selected
	#' @param pA \eqn{P(A = 1)} in the general population
	#' @param pY \eqn{P(Y = 1)} in the general population
	#' @param pAY \eqn{P(A = 1, Y = 1)} in the general population
	#'
	#' @return P(S = 1)
	ps_calc = function(b0, ba, by, bay, pA, pY, pAY)
	{
		b0 + ba * pA + by * pY + bay * pAY
	},

	#' @description
	#' Specify a set of parameters for the structural equation, and calculate the set of odds ratios that would be obtained, assuming the odds ratio of A on Y in the total population is 1.
	#' @param target_or Target odds ratio. e.g. in an observational study this OR is observed, and the researcher seeks to find parameter ranges that could explain it
	#' @param pS Proportion of the population present in the sample
	#' @param pA \eqn{P(A = 1)} in the general population
	#' @param pY \eqn{P(Y = 1)} in the general population
	#' @param pAY \eqn{P(A = 1, Y = 1)} in the general population
	#' @param b0_range Baseline probability of being selected. Provide a range of values to explore e.g. `c(0,1)`
	#' @param ba_range Effect of A on being selected into the sample. Provide a range of values to explore e.g. `c(-0.2, 0.2)`
	#' @param by_range Effect of Y on being selected into the sample. Provide a range of values to explore e.g. `c(-0.2, 0.2)`
	#' @param bay_range Effect of AY interaction on being selected into the sample. Provide a range of values to explore e.g. `c(-0.2, 0.2)`
	#' @param granularity Granularity of the search space. Default=`100`, going much higher can be computationally difficult
	#' @param pS_tol Tolerance of pS value Default=`0.0025`
	#' @return Data frame of parameters that satisfy the `target_or` and target `pS` values
	parameter_space = function(target_or, pS, pA, pY, pAY, b0_range, ba_range, by_range, bay_range, granularity=100, pS_tol=0.0025)
	{
		s <- sign(log(target_or))
		param <- expand.grid(
			pA = pA,
			pY = pY,
			pAY = pAY,
			b0 = seq(b0_range[1], b0_range[2], length.out=granularity) %>% unique(),
			ba = seq(ba_range[1], ba_range[2], length.out=granularity) %>% unique(),
			by = seq(by_range[1], by_range[2], length.out=granularity) %>% unique(),
			bay = seq(bay_range[1], bay_range[2], length.out=granularity) %>% unique()
		)
		message(nrow(param), " parameter combinations")
		self$details$parameter_combinations <- nrow(param)
		param <- param %>%
		dplyr::mutate(ps1 = self$ps_calc(b0=b0, ba=ba, pA=pA, by=by, pY=pY, bay=bay, pAY=pAY)) %>%
		dplyr::filter(ps1 >= pS - pS_tol & ps1 <= pS + pS_tol & b0 + by + ba + bay > 0) %>%
		dplyr::mutate(or = self$or_calc(b0=b0, ba=ba, by=by, bay=bay))
		message(nrow(param), " within pS_tol")
		self$details$within_ps_told <- nrow(param)
		if(target_or >= 1)
		{
			param <- subset(param, or >= target_or & or < 50)
		} else {
			param <- subset(param, or <= target_or & or > 0)
		}
		message(nrow(param), " beyond OR threshold")
		self$details$beyond_or <- nrow(param)
		self$param <- dplyr::as_tibble(param)
	},

	#' @description
	#' 3D scatterplot of output from `parameter_space` function. See [`plot3D::scatter3D`] for info on parameters
	#' @param ticktype Default=`"detailed"`
	#' @param theta Default=`130`
	#' @param phi Default=`0`
	#' @param bty Default=`"g"`
	#' @param xlab Default=`"ba"`
	#' @param ylab Default=`"by"`
	#' @param zlab Default=`"b0"`
	#' @param clab Default=`"OR"`
	#' @param ... Further parameters to be passed to [`plot3D::scatter3D`]
	#' @return Scatterplot
	scatter3d = function(ticktype="detailed", theta=130, phi=0, bty="g", xlab=expression(beta[A]), ylab=expression(beta[Y]), zlab=expression(beta[AY]), clab=expression(beta[0]), ...)
	{
		plot3D::scatter3D(x=self$param$ba, y=self$param$by, z=self$param$bay, colvar=self$param$b0, ticktype = ticktype, theta=theta, phi=phi, bty=bty, xlab=xlab, ylab=ylab, zlab=zlab, clab=clab, ...)
	},

	#' @description
	#' Simple scatterplot of output from parameter_space function. Plotted are the parameter values of `b0`, `ba` and `by` that can give rise to an OR \eqn{\ge} `target_or`
	scatter = function()
	{
		ggplot2::ggplot(self$param, ggplot2::aes(x=ba, y=by)) +
		ggplot2::geom_point(ggplot2::aes(colour=b0)) +
	    ggplot2::xlab(expression(beta[A])) +
    	ggplot2::ylab(expression(beta[Y])) +
    	ggplot2::labs(colour = expression(beta[0]))
	},

	#' @description
	#' Histogram of odds ratios across the range of parameter values
	#' @param bins How many bins to split histogram. Default=`30`
	#'
	#' @return ggplot object
	histogram = function(bins=30)
	{
		ggplot2::ggplot(self$param, ggplot2::aes(x=or)) +
		ggplot2::geom_histogram(bins=bins) +
		ggplot2::scale_x_log10() +
		ggplot2::xlab("OR")
	}

))


\name{supervised.pca}
\title{Supervised PCA}

\description{
	Performs dual supervised principal component analysis on the given
	data matrix and kernel matrix of target variable and returns the
	results as an object of class \code{pca}.
	The kernel matrix is implemented by \link[kernlab]{dots}.
}

\usage{
	supervised.pca <- function(X, Y,
       kernel.y = c("linear", "poly", "gaussian", "laplacian", "sigmoid",
       "anova", "precomputed"),
       degree.y = 3, scale.y = 1, offset.y = 1, sigma.y, order.y, center.x = TRUE, ...)
	transform.supervised.pca <- function(object, data, n.components)
}

\arguments{
	\item{X}{
	a numeric matrix. It could be a $n\times p$ training data matrix,
	where $n$ is the number of samples and $p$ is the number of features.
	Or it could be kernel matrix of training data.
	}
	\item{Y}{
	a $n\times l$ numeric matrix of target variable.
	}
	\item{Xnew}{
	a numeric matrix in which to apply the dimensionality reduction.
	}
	\item{n.components}{
	number of compents to keep.
	}
}
\value{
	The returned \code{spca} object of \code{supervised.pca} contains the following components.
	\item{components}{
	principal axes in feature space, representing the directions of maximum variance in the data
	}
	\item{sdev}{
	the standard deviations of the principal components
	}
	\item{center}{
	the means that were substracted.
	}
	The \code{transform.supervised.pca} returns a numeric matrix.
	The returned \code{skpca} object of \code{supervised.kernel.pca} contains the following components.
	\item{components}{
	principal axes in feature space, representing the directions of maximum variance in the data
	}
	\item{eigenvalues}{
	the eigenvalues of the principal components
	}
	\item{xmatrix}{
	the input \bold{X} matrix
	}
	\item{xkernel}{
	the prameters of kernel function of X
	}
	The \code{transform.supervised.kernel.pca} returns a numeric matrix.

}
\reference{
	E. Barshan, A. Ghodsi, Z. Azimifar, M. Jahromi
	Supervised principal component analysis: Visualization, classification and regression on subspaces and submanifolds
	Pattern Recognition 44:1357--1371, 2011.
}
\examples{
	set.seed(1)
	data("iris")
	y <- with(iris["Species"], model.matrix(~ Species + 0))
	index <- c(1:nrow(iris))
	train.index <- sample(index, 105)
	train.X <- as.matrix(iris[train.index, 1:4])
	train.Y <- y[train.index, ]
	test.X <- as.matrix(iris[-train.index, 1:4])
	test.Y <- y[-train.index, ]

	# supervised pca
	iris.pca <- supervised.pca(train.X, train.Y, kernel.y = "linear")
	transform.train <- transform.supervised.pca(iris.pca, data = train.X, n.components = 2)
	transform.test <- transform.supervised.pca(iris.pca, data = test.X, n.components = 2)
	plot(transform.train[,1], transform.train[,2], pch = 20,col = iris[train.index, 5])
	points(transform.test[,1], transform.test[,2], pch = 24, col = iris[-train.index, 5])

	# compare non-supervised pca to prcomp
	supervised.pca(train.X, diag(105), kernel.y = "precomputed")
	prcomp(train.X)

	# kernel supervised PCA
	iris.kernel.pca <- supervised.kernel.pca(train.X, train.Y, kernel.x = "gaussian", sigma.x = 10, kernel.y = "linear")
	transform.train.kernel <- transform.supervised.kernel.pca(iris.kernel.pca, Xnew = train.X, n.components = 2, "inherited")
	transform.test.kernel <- transform.supervised.kernel.pca(iris.kernel.pca, Xnew = test.X, n.components = 2, "inherited")
	plot(transform.train.kernel[,1], transform.train.kernel[,2], pch = 20,col = iris[train.index, 5])
	points(transform.test.kernel[,1], transform.test.kernel[,2], pch = 24, col = iris[-train.index, 5])

	set.seed(1)
	data("Sonar")
	y <- with(Sonar["Class"], model.matrix(~ Class + 0))
	index <- c(1:nrow(Sonar))
	train.index <- sample(index, 140)
	train.X <- as.matrix(Sonar[train.index, 1:4])
	train.Y <- y[train.index, ]
	test.X <- as.matrix(Sonar[-train.index, 1:4])
	test.Y <- y[-train.index, ]

	# supervised pca
	Sonar.pca <- supervised.pca(train.X, train.Y, kernel.y = "linear")
	transform.train <- transform.supervised.pca(Sonar.pca, data = train.X, n.components = 2)
	transform.test <- transform.supervised.pca(Sonar.pca, data = test.X, n.components = 2)
	plot(transform.train[,1], transform.train[,2], pch = 20,col = Sonar[train.index, 61])
	points(transform.test[,1], transform.test[,2], pch = 24, col = Sonar[-train.index, 61])

	# compare non-supervised pca to prcomp
	supervised.pca(train.X, diag(140), kernel.y = "precomputed")
	prcomp(train.X)

	# kernel supervised PCA
	Sonar.kernel.pca <- supervised.kernel.pca(train.X, train.Y, kernel.x = "gaussian", sigma.x = 1, kernel.y = "linear")
	transform.train.kernel <- transform.supervised.kernel.pca(Sonar.kernel.pca, Xnew = train.X, n.components = 2, "inherited")
	transform.test.kernel <- transform.supervised.kernel.pca(Sonar.kernel.pca, Xnew = test.X, n.components = 2, "inherited")
	plot(transform.train.kernel[,1], transform.train.kernel[,2], pch = 20,col = Sonar[train.index, 61])
	points(transform.test.kernel[,1], transform.test.kernel[,2], pch = 24, col = Sonar[-train.index, 61])
}


# dec to oct
as.octmode(x)
# dec to hex
as.hexmode(x)
# oct or hex to dec
as.integer(x)
# or
as.numeric(x)


1 + 2.0,
1+2,
x+y,
+x+x,
-y+2,
y+-2,
x + -2,
aa+(bb+cc),
aa + -(bb--cc),
((a))++c--(d--e)


 ZSPSV Example Program Results

 Solution
    (-4.0000, 3.0000) ( 3.0000,-2.0000) (-2.0000, 5.0000) ( 1.0000,-1.0000)

 Details of factorization
                    1                 2                 3                 4
 1  (-2.0954,-2.2011) (-0.1071,-0.3157) (-0.4823, 0.0150) ( 0.4426, 0.1936)
 2                    ( 4.4079, 5.3991) (-0.6078, 0.2811) ( 0.5279,-0.3715)
 3                                      (-2.8300,-0.0300) (-7.8600,-2.9600)
 4                                                        (-0.3900,-0.7100)

 Pivot indices
           1          2         -2         -2


library(float)

x = c(1, 2, -1, -2, 0, 100, -100, 0)
s = fl(x)

test = all.equal(sign(x), sign(s))
stopifnot(isTRUE(test))


library(psych)

# Read in the data
fa_data = readRDS('C:\\Users\\aleksander.molak\\Documents\\EDU\\DataCamp_-_Factor_Analysis\\conspiracy_data.rds')

# Build a model
EFA_model = fa(fa_data, nfactors = 2)

# View loadings
EFA_model$loadings

# Create a loadings diagram
fa.diagram(EFA_model)

head(EFA_model$scores)


library(readr)
library(data.table)
library(mice)
library(xgboost)
variance <- function(x) var(x)*(length(x)-1)/length(x)
stddev <- function(x) sqrt(variance(x))
mlogloss <- function(actual,pred){
	actual <- as.integer(as.factor(actual))
	probs <- rep(0,length(actual))
	for(i in 1:length(actual)) { probs[i] <- pred[i,actual[i]]}
	probs <- as.numeric(probs)
	probs[which(probs>1-1e-15)] <- 1-1e-15
	probs[which(probs<1e-15)] <- 1e-15
	return(-(1/length(actual))*sum(log(probs)))
}

path <- "../Data/"
train <- fread(paste0(path,"train.csv"))
train <- as.data.frame(train)
train$id <- NULL

tSNE <- fread(paste0(path,"train_tsne.csv"))
tSNE <- as.data.frame(tSNE)
train <- cbind(train,tSNE)

y <- train$target
y <- gsub('Class_','',y)
y <- as.integer(y)-1 #xgboost take features in [0,numOfClass)
train$target <- NULL
train$target <- y

for(i in 1:(ncol(train)-1)) { train[,i] <- as.numeric(train[,i])}

param <- list("objective" = "multi:softprob",
              "eval_metric" = "mlogloss",
              "num_class" = 9,
			  "max_depth" = 12,
			  "eta" = 0.01, # 0.002
			  "min_child_weight" = 10, # default 1; 4 ,gbm: 10
			  "subsample" =  0.9, # default 1, 0.9
			  "colsample_bytree" = 0.8 # default 1 0.8
			  )
cv.nround <- 10000
gc(TRUE)
set.seed(131)
bst <- xgb.cv(param=param, data=data.matrix(train[,c(-ncol(train))]), label=train$target,
nrounds=cv.nround, nfold=5, early.stop.round=10)
print(tmp <- min(bst$test.mlogloss.mean))
(minNum <- which.min(bst$test.mlogloss.mean))
stddev <- bst$test.mlogloss.std[minNum]
(sprintf("%s: %s+%s",minNum, tmp, stddev))

# eta 0.01: 2392, 0.452167 + 0.007736
# eta 0.025 : 974, 0.452789+0.007242
# eta 0.05  : 462, 0.455121+0.007011
# eta 0.1   : 235, 0.458957+0.007107

set.seed(131)
bst <- xgboost(param=param, data=data.matrix(train[,c(-ncol(train))]),
label=train$target, nrounds=minNum)

test  <- fread(paste0(path,"test.csv"))
test <- as.data.frame(test)
id <- test$id
test$id <- NULL
tSNE <- fread(paste0(path,"test_tsne.csv"))
tSNE <- as.data.frame(tSNE)
test <- cbind(test,tSNE)

for(i in 1:ncol(test)) { test[,i] <- as.numeric(test[,i])}
pred <- predict(bst,data.matrix(test))
pred <- matrix(pred,9,length(pred)/9)
pred <- t(pred)
submission <- data.frame(id,pred)
names(submission) <- c('id', paste0('Class_',1:9))
for(i in 1:ncol(submission)) { submission[,i] <- as.character(submission[,i])}
write_csv(submission,paste0(path,"xgb.csv"))

# retrain
rm(pred)

library(cvTools)
NAME <- paste0('Class_',1:9)
tmp <- matrix(rep(NA,9),nrow(train),9)
tmp <- as.data.frame(tmp)
colnames(tmp) <- NAME
submission <- cbind(id=1:nrow(train),tmp)
nfold <- 5
cv.folds <- cvFolds(nrow(train),nfold)
cvs <- cv.folds$which
id <- 1:nrow(train)
score <- rep(0,nfold)

for(NUMCV in 1:nfold){
test.x <- train[which(cvs==NUMCV),-ncol(train)]
test.y <- train[which(cvs==NUMCV),ncol(train)]
train.x <- train[which(cvs!=NUMCV),-ncol(train)]
train.y <- train[which(cvs!=NUMCV),ncol(train)]

set.seed(131)
bst <- xgboost(param=param, data=data.matrix(train.x), label=train.y, nrounds=minNum)
pred <- predict(bst,data.matrix(test.x))
pred <- matrix(pred,9,length(pred)/9)
submission[which(cvs==NUMCV),2:10] <- t(pred)
print(score[NUMCV] <- mlogloss(test.y,as.data.frame(t(pred))))
}
sprintf("mean: %s, stddev: %s", mean(score), stddev(score))

for(i in 1:ncol(submission)) { submission[,i] <- as.character(submission[,i])}
write_csv(submission,paste0(path,"xgb_retrain.csv"))

# nfold 10, eta 0.025:  "mean: 0.446157339370614, stddev: 0.00933124503154594"
# eta 0.01: "mean: 0.452150431771192, stddev: 0.00525177443564338"
# eta 0.025: "mean: 0.453862183666749, stddev: 0.00515462846734756"
# tsne cv score : "235: 0.458957+0.007107"
# score: 0.44172, 0.44407
# nfold 10: "mean: 0.451309402874783, stddev: 0.00871565654067067"
# nfold 8, "mean: 0.453524368582917, stddev: 0.01272269826227"
# nfold 6, "mean: 0.454186404467429, stddev: 0.0086829232150271"
# nfold 5, "mean: 0.458860357190608, stddev: 0.00455707136495085"
# nfold 3, "mean: 0.468769785104636, stddev: 0.0079971558899458"
# nfold 2, "mean: 0.48750612552813, stddev: 0.00130107011402603"

imp<-xgb.importance(names(train[,-ncol(train)]),model=bst)
print(imp)
xgb.plot.importance(imp)

#xgb.plot.tree(feature_names=names(train[,-ncol(train)]),model=bst, n_first_tree=2)


library("scales")
library("ggplot2")
library("gridExtra")

# data = aggregate(
#   cbind(Number=Accession) ~ Gene + Position + IndelType + InsLen,
#   data, FUN=length)
# data = data[data$IndelType == 'ins',]
# zzz = ave(data$Number, data$Position, function(x) rank(x, ties.method='first'))
# data$JitterX = runif(nrow(data), 0, 10)

mylog_trans <-
  function (base = exp(1), from = -0.3)
  {
    trans <- function(x) log(x, base) - from
    inv <- function(x) base^(x + from)
    trans_new("mylog", trans, inv, log_breaks(base = base), domain = c(base^from, Inf))
  }

plot_patterns <- function(pdfpath, genelen, data) {
  plot = ggplot(data, mapping=aes(y=Position, x=reorder(Pattern, -Count),
                                  ymin=Position, ymax=Position + InsLen)) +
    geom_linerange(size=2) + # position=position_dodge(.5)) +
    geom_text(size=2, aes(y=genelen, label=Count)) + # , hjust=0, vjust=0) +
    scale_y_continuous(expand = c(0, 5), limits = c(1, genelen), breaks = seq(0, genelen, 5)) +
    coord_flip() + theme_bw() +
    theme(axis.title.y=element_blank(),
      axis.text.y=element_blank(),
      axis.ticks.y=element_blank(),
      panel.border = element_blank(),
      axis.text.x = element_text(angle = 90, hjust = 1),
      # panel.grid.major = element_blank(),
      panel.grid.minor = element_blank(),
      plot.margin = margin(0.1, 0.2, 0.1, 0.2, "in"),
      axis.line = element_line(colour = "black"))
  pdf(pdfpath, width=24, height=8)
  print(plot)
  dev.off()
}

plot_histogram <- function(title, genelen, data) {
  plot = ggplot(data, aes(x=Position, y=Count)) +
    geom_col() +
    scale_x_continuous(expand = c(0, 0), limits = c(1, genelen), breaks = seq(0, genelen, 5)) +
    scale_y_continuous(expand = c(0, 0), trans = mylog_trans(base=10), breaks=c(1, 10, 100, 1000, 10000)) +
    theme_bw() + ggtitle(title) +
    theme(#axis.title.y=element_blank(),
          #axis.text.y=element_blank(),
          #axis.ticks.y=element_blank(),
          panel.border = element_blank(),
          axis.text.x = element_text(angle = 90, hjust = 1),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          plot.margin = margin(0.1, 0.2, 0.1, 0.2, "in"),
          axis.line = element_line(colour = "black"))
  plot
}

plot_gene <- function(gene, genelen) {
  data = read.csv(sprintf("/app/data/naiveStudies/%sNaiveIndels.csv", gene))
  data$InsLen = apply(matrix(data$InsertedCodons), 1, function(x) nchar(x) / 3)
  data$IndelTypeInt = apply(matrix(data$IndelType), 1, function(x) if (x == 'ins') 1 else -1)
  aggdata = aggregate(
    cbind(Count=Accession) ~ Position + IndelTypeInt,
    data, FUN=length)
  # aggdata$Count = aggdata$Count * aggdata$IndelTypeInt

  pdf(sprintf("/app/report/%s-naive-indels.pdf", gene), width=24, height=16)
  plots = list(
    plot_histogram(sprintf("Insertions of naive %s sequences", gene), genelen, aggdata[aggdata$IndelTypeInt == 1,]),
    plot_histogram(sprintf("Deletions of naive %s sequences", gene), genelen, aggdata[aggdata$IndelTypeInt == -1,])
  )
  grid.arrange(grobs=plots, nrow=2, ncol=1)
  dev.off()

  patterndata = data[data$IndelTypeInt == 1,]
  patterndata = aggregate(
    cbind(Pattern=sprintf('%s:%s', Position, InsLen)) ~ Accession,
    patterndata, FUN=function(x) paste(x, collapse=';')
  )
  data = merge(data[data$IndelTypeInt == 1,], patterndata, by='Accession')
  patternaggs = aggregate(
    cbind(Count=Accession) ~ Pattern + Position + InsLen,
    data, FUN=length)
  patternaggs = patternaggs[patternaggs$Count > 1,]
  plot_patterns(sprintf("/app/report/%s-ins-pattern.pdf", gene), genelen, patternaggs)
}

pdata = plot_gene('gag', 500)
plot_gene('gp41', 345)


dirneural <- read.delim("dirneural.dat",header = F,sep = ",")
celegans <- read.delim("celegans.dat",header = F,sep = ",")

#a <- matrix(c(0,0,0,0,0,1,0,0,0,0,0,1,0,1,1,1,1,0,0,0,0,0,0,1,0),
#            byrow = T,5,5,dimnames = list(c(seq(1,5)),c(seq(1,5))))
a <- dirneural
#a <- celegans
repeat{
  if(sum(dim(a))==0){
    print("Network is DAG")
    break
  }
  r <- as.numeric(which(colSums(a)==0))
  if(length(r)==0){
    print("Network is Cyclic")
    break
  }
  a <- a[-r,-r]
}


# 4. faza: Analiza podatkov
# Logistična regresija

df <- tabela2 %>% filter(!is.na(Prihranki))

prevediOcena <- function(beseda) {
  if (beseda == "dober") {
    return(1)
  } else {
    return(0)
  }
}

df$Ocena <- df$Ocena %>% lapply(prevediOcena) %>% unlist() %>% as.factor()

# train set, test set
indeksi <- createDataPartition(df$Ocena, p = 0.8, list = FALSE)
ucna <- df[indeksi, ]
testna <- df[-indeksi, ]

model1 <- glm(formula = Ocena ~ . - ID, family = binomial(link = logit), data = ucna)
#coef(summary(model1))[, 4] < 0.05

# statistično značilne spremenljivke
statSignificence <- as.logical(coef(summary(model1))[, 4] < 0.05)
statSignificence <- names(model1$coefficients[statSignificence])

df2 <- as.data.frame(coef(summary(model1)))
rownames(df2)[rownames(df2) == "`Velikost kredita`"] = "Velikost kredita"

napoved <- model1 %>% predict(testna, type = "response")
napoved[napoved > 0.5] = 1
napoved[napoved <= 0.5] = 0

tocnost <- mean(napoved == testna$Ocena)


# README: Compare TLP with SCAD and MCP (ncvreg)
library(tictoc)
source("tlpreg.r")
source("tlpreg1.r")
source("cv.tlpreg.r")
source("cv.tlpreg1.r")
source("./dev/mtlpreg0.r")
source("./dev/mtlpreg1.r")

#set.seed(2020)
n <- 500
p <- 500
q <- 50
X <- matrix(rnorm(n*p),n,p)
Z <- rnorm(n)
for(j in 1:p) {
  X[,j] <- X[,j] + Z
  X[,j] <- (X[,j] - mean(X[,j])) / sd(X[,j])
}
Y <- matrix(rnorm(n*q), n, q)
for (k in 1:q) {
    Y[,k] <- Y[,k] + 1 + 0.5*(X[,1 + k] - X[,2 + k] + X[,10 + k] - X[,15 + k])
}

# SPEED TEST
tic("TLP-Regularized")
m1 <- fit.mtlpreg0(X=X, Y=Y, nfold=5)
toc()

tic("L0-Constrained")
m2 <- fit.mtlpreg1(X=X, Y=Y, K=1:10, nfold=5)
toc()

# ACCURACY TEST
m11 <- m1[[1]]
m12 <- m1[[2]]
m13 <- m1[[3]]
m14 <- m1[[4]]
m15 <- m1[[5]]

which(m11$b!=0)
which(m12$b!=0)
which(m13$b!=0)
which(m14$b!=0)
which(m15$b!=0)

m21 <- m2[[1]]
m22 <- m2[[2]]
m23 <- m2[[3]]
m24 <- m2[[4]]
m25 <- m2[[5]]

which(m21$b!=0)
which(m22$b!=0)
which(m23$b!=0)
which(m24$b!=0)
which(m25$b!=0)

# Note: informative variables are X(1+k), X(2+k), X(10+k), X(50+k); k = 1,2,3,4,5.


onecor.partial.wtd <- function(x, y, preds=NULL, weight=NULL){
  if(sum((!is.na(x))*(!is.na(y)))>0){
    if(is.null(weight)){
      weight <- rep(1, length(x))
    }
    use <- !is.na(y) & !is.na(x)
    if(!is.null(preds))
      use <- !is.na(y) & !is.na(x) & !is.na(rowSums(preds))
    x <- x[use]
    y <- y[use]
    weight <- weight[use]
    if(!is.null(preds)){
      preds <- as.matrix(preds)[use,]
      corcoef <- coef(summary(lm(stdz(y, weight=weight)~stdz(x, weight=weight)+preds, weight=weight)))[2,]
    }
    else{
      corcoef <- coef(summary(lm(stdz(y, weight=weight)~stdz(x, weight=weight), weight=weight)))[2,]
    }
  }
  else
    corcoef <- rep(NA, 4)
  names(corcoef) <- rep("", 4)
  corcoef
}


 dat<-Read.summary.data()
 dat<-droplevels(subset(dat,Species=='Sandeel'& Year>=1975))
 ssb<-subset(dat,Quarter==1)
 bio<-aggregate(list(TSB=ssb$BIO/1000,SSB=ssb$SSB/1000),list(Year=ssb$Year),sum)

 rec<-subset(dat,Quarter==3 & Age==0, select=c(Year,N))
 a<-merge(bio,rec)
 a$N<-a$N/1000000
cleanup()
X11()
 par(mfcol=c(2,2))
plot(a$Year,a$N,type='b')

plot(a$SSB,a$N,type='p')
lines(smooth.spline(a$SSB,a$N,df=4),col='red')

plot(a$TSB,a$N,type='p')
lines(smooth.spline(a$TSB,a$N,df=4),col='red')

plot(a$TSB-a$SSB,a$N,type='p')
lines(smooth.spline(a$TSB-a$SSB,a$N,df=4),col='red')

a$age1<-a$TSB-a$SSB
library(mgcv)

X11(); par(mfcol=c(2,2))
aa<-gam(N~s(SSB),data=a)
summary(aa)
plot(aa)
plot(a$N,predict.gam(aa))
abline(a=0,b=1)

X11(); par(mfcol=c(2,2))
bb<-gam(N~s(SSB)+s(age1),data=a)
summary(bb)
plot(bb)

anova(aa,bb,test='F')

X11(); par(mfcol=c(2,2))
plot(a$N,predict.gam(bb))
abline(a=0,b=1)


#Access an app like this at
##########################################
# https://rr1964.shinyapps.io
##########################################

library(shiny)

if(!require("RColorBrewer"))
{
  install.packages("RColorBrewer")
}

library(RColorBrewer)

ourRed = colorRampPalette(brewer.pal(9,"Reds"))(6)
ourBlue = colorRampPalette(brewer.pal(9,"Blues"))(6)

ui <- fluidPage(

  # Application title
  titlePanel("Nice Two Meat You"),

  sidebarLayout(
    sidebarPanel(h3("Beef or Fish?"),
      sliderInput(inputId = "age",
                  label = h4("Age:"),
                  min = 18,
                  max = 100,
                  value = 30),
      sliderInput(inputId = "hot",
                  label = h4("Spice Tolerance:"),
                  min = 1,
                  max = 10,
                  value = 5),
      radioButtons("meat", h4("Meat Choice:"),
                   choices = list("Beef" = 1, "Fish" = 2),selected = 1),
      checkboxInput(inputId = "sauce",
                    label ="Pour on special sauce:",
                    value = FALSE), ##Start off with sauce option not checked.

      span(textOutput("checkSauce"), style = "color:red"), ##This means the output text will be red.
      ##There are many ways (such as using CSS or something) to obtain red output text.
      ##I feel this is the simplest way to do such.

      actionButton("goButton", "Submit Order") ###input name, display text.

    ),

    mainPanel(
      h4(textOutput("ageRange"), align = "middle"),
      h5(textOutput("sauceApplied"), align = "middle", style = paste0("color:",ourBlue[4])),###You can use h1, h2, h3, h4....as they are used in HTML.
      plotOutput("opinion")

    )
  )
)

server <- function(input, output) {

  ageRangeB<-function(yourAge , sauceAllowed)
  {
    lowBound = (sqrt(yourAge + 5)-9/11)^2 - (sauceAllowed*input$sauce)*(yourAge/2 -7)
    upBound = (sqrt(yourAge + 3)+2/23)^2
    interval = c(lowBound, upBound)
    return(interval)
  }

  ageRangeF<-function(yourAge , sauceAllowed)
  {
    lowBound = (sqrt(yourAge - 1)-1/19)^2
    upBound = (sqrt(yourAge + 5) + 3/23)^2 + (sauceAllowed*input$sauce)*(yourAge/2 -2)
    interval = c(lowBound, upBound)
    return(interval)
  }

  output$checkSauce <- renderText({

    if(input$sauce & ((input$age < 40 & input$meat == 2) | (input$age <25  & input$meat == 1)))
    {
      ##The sauce option can only be selected for fish if the user is over age 40
      ##The sauce option can only be selected for beef if they are between age 25 and 56 (inclusive)
      return("You are too young to check the special sauce option.")
    }

    else if(input$sauce & input$meat ==1 & input$age >56)

    {return("You are too old to select the sauce option for beef.")}

    return("")
  })

  output$ageRange <- renderText({

    input$goButton

    isolate({

      if(input$sauce & ((input$age < 40 & input$meat == 2) |
                          (input$age <25  & input$meat == 1) |
                          (input$age >56  & input$meat == 1)))
      {
        sauceAllowed = FALSE
      }
      else{sauceAllowed = TRUE}

      if(input$meat == 1)
      {
        compAges = round(ageRangeF(input$age, sauceAllowed), digits = 2)
      }
      else if(input$meat == 2)
      {
        compAges = round(ageRangeB(input$age, sauceAllowed), digits = 2)
      }

      return(paste("Your customer age range is:", compAges[1],"years to ", compAges[2], " years."))
    })##End of Isolate.
  })

  output$sauceApplied <- renderText({

    input$goButton

    isolate({

      if(input$sauce & ((input$age < 40 & input$meat == 2) |
                          (input$age <25  & input$meat == 1) |
                          (input$age >56  & input$meat == 1)))
      {

        return("You cannot have the special sauce.")
      }
      else if(input$sauce)
      {
        return("You will get the special sauce.")
      }

    })##End of Isolate.

  })

  output$opinion <- renderPlot({

    ####ourRed = colorRampPalette(brewer.pal(9,"Reds"))(6)

    input$goButton
    isolate({
      if(input$sauce & ((input$age < 40 & input$meat == 2) |
                          (input$age <25  & input$meat == 1) |
                          (input$age >56  & input$meat == 1)))
      {
        sauceAllowed = FALSE
      }
      else{sauceAllowed = TRUE}

      if(input$meat == 2)
      {
        ages = round(ageRangeF(input$age, sauceAllowed), digits = 2)
        spice = input$hot
        #sample(1:10, 1, prob = c(0.05, 0.05, 0.05, 0.1, 0.15, 0.2, 0.15, 0.15, 0.05, 0.05))

        randAges = runif(400, min = ages[1], max = ages[2])
        randHot = runif(400, min = spice-1.5, max = spice + 1.5) + rnorm(400, mean = 0, sd = 0.25)
        ##we add the rnorm part to avoid the strict boundaries.

        flavor = -0.025*randAges + randHot + rnorm(400, sd = 0.85)

        plot(x = abs(randHot), y = abs(flavor), xlim = c(-0.5, 10.5), ylim = c(-0.5, 10.5),
             main = "400 randomly sampled \n people in your age range", col = ourRed[5],
             pch = 1, cex=.85, xlab = "Spice Tolerance", ylab = "Flavor Rating")
      }

      if(input$meat == 1)
      {
        ages = round(ageRangeB(input$age, sauceAllowed), digits = 2)
        spice = input$hot
        #sample(1:10, 1, prob = c(0.05, 0.05, 0.05, 0.1, 0.15, 0.2, 0.15, 0.15, 0.05, 0.05))

        randAges = runif(400, min = ages[1], max = ages[2])
        randHot = runif(400, min = spice-1.5, max = spice + 1.5) + rnorm(400, mean = 0, sd = 0.25)
        ##we add the rnorm part to avoid the strict boundaries.

        oz = -0.015*randAges + randHot + rnorm(400, sd = 0.85)

        plot(x = abs(randHot), y = abs(oz), xlim = c(-0.5, 10.5), ylim = c(-0.5, 10.5),
             main = "400 randomly sampled \n people in your age range", col = ourRed[5],
             pch = 1, cex=.85, xlab = "Spice Tolerance", ylab = "Ounces Consumed")

      }
    })###End of isolate()
  })

}

# Run the application
shinyApp(ui = ui, server = server)


library(ggplot2)
library(ggthemes)
library(reshape2)

df = read.csv("runs.csv", stringsAsFactors=FALSE)
df$procs = df$size*df$threads

df_sub = df[, !(names(df) %in% c("m", "n", "size", "threads", "t_dbl_min", "t_dbl_mean", "t_flt_min", "t_flt_mean"))]
df_melt = melt(df_sub, c("method", "procs"))
precision = gsub(df_melt$variable, pattern="t_dbl_max", replace="fp64")
precision = gsub(precision, pattern="t_flt_max", replace="fp32")
df_melt$variable = precision

g = ggplot(df_melt, aes(procs, value, color=method)) +
  theme_minimal() +
  geom_point() +
  geom_line() +
  scale_color_tableau() +
  facet_wrap(~variable, nrow=1) +
  xlab("Cores") +
  ylab("Run Time in Seconds (lower is better)") +
  labs(color="Method") +
  theme(legend.position="bottom") +
  ggtitle("QR Benchmark on 10,000x2500 matrix (200 MB)")

g
# ggsave(g, file="pagerank.png")


library(npowerPrioR)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#####
scenario <- "B"
source(paste("data_logistic_regression_scenario_", scenario, ".r", sep = ""))
summary(glm(y_0 ~  X_0, family = "binomial"))

#### Sampling from the "prior"

prior <- stan_model("stan/simple_logistic_regression_prior.stan")

lgr.data <- list(
  N0 = N_0,
  X0 = X_0,
  P = P,
  y0 = y_0,
  a_0 = NULL
)

###
J <- 20
maxA <- 1
epsilon <- 0.05

adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior, eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10,
                                       stan.list = lgr.data, pars = c("alpha", "beta"))
)

write.csv(adaptive.ca0.estimates$result,
          file = paste("../../data/constant_data/RegressionLogistic_logCA0_J=", J,
                       "_scenario_", scenario, ".csv", sep = ""), row.names = FALSE)

save(adaptive.ca0.estimates, file = paste("../../data/sensitivity_data/RegressionLogistic_logCA0_J=", J,
                                          "_scenario_", scenario, ".RData", sep = ""))


rm(list = ls()) # clean workspace
library(wCorr)
# read data
merged <- read.delim("result_online.csv", header = TRUE, quote = "")
# config used data and methods here
LIST_DATA   = c("zxcvbn_guess_number", "zxcvbn_score")
LIST_METHOD = c("wspearman")
REF    = merged$strength # used as refernce
WEIGHT = merged$weight   # used as weight
###########################
results = matrix(numeric(0),
                 nrow = length(LIST_DATA),
                 ncol = length(LIST_METHOD))
# main loop
row_index = 0
for (COL in LIST_DATA) {
  row_index = row_index + 1
  cat(COL, "\t")
  SAM = merged[, COL]
  col_index = 0
  for (METHOD in LIST_METHOD) {
    col_index = col_index + 1
    if (METHOD == "wspearman") {
      C = weightedCorr(REF, SAM, method = "spearman", weights = WEIGHT)
    } else{
      C = -1
    }
    cat(round(C, digits = 3), "\t") # output to stdout
  }
  cat("\n")
}
# -1.0 means strong negative correlation; meter works but 'strong' passwords are in fact 'weak' and the other way round
#  0.0 means no correlation; meter is randomly guessing, and not estimating password strength
#  1.0 means strong positive correlation; meter works perfectly


# Authors: Grzegorz Protaziuk, Robert Bembenik
# Script EDAMI lab6

#Subject: Classification
#1. Classification with usage of "C5.0" library
#2. Classification with usage of  rpart library
#3. Random forest

#install.packages("gmodels")
#install.packages("Hmisc")
#install.packages("caret")
#install.packages("rpart")
#install.packages("e1071")
#install.packages("C50")
#install.packages("randomForest")
#install.packages("rpart.plot")

library(gmodels) #results analysis
library(Hmisc) #results analysis
library(caret)
library(rpart) # rpart() - decision tree classifier
library(rpart.plot)
library(e1071)
library(C50) # C5 classifer
library(randomForest)

################################################################
#    data preprocessing                                       #
################################################################

download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/car/car.data', 'car.data')

#date reading
cars = read.csv("car.data", header = FALSE,
                col.names = c('buying', 'maint', 'doors', 'persons', 'lug_boot','safety', "category") )
summary(cars)

set.seed(7777)

#creating training and test datasets
sam <- sample(2, nrow(cars), replace=TRUE, prob=c(0.7, 0.3))
sam
carTrain1 <- cars[sam==1,]
carTest1 <- cars[sam==2,]

#class distribution in sets
prop.table(table(carTrain1$category))
prop.table(table(carTest1$category))

#creating training and test datasets
?createDataPartition
idTrainData <- unlist(createDataPartition(cars$category,p=0.7))
#str(idTrainData)

carTrain <-cars[idTrainData,]
carTest <-cars[-idTrainData,]

#class distribution in sets
prop.table(table(carTrain$category))
prop.table(table(carTest$category))

table(carTrain$category)
table(carTest$category)

################################################################
# 1.  C5.0 classifier                                         #
################################################################

?C5.0
#model building - a decision tree
car_C50 <- C5.0(carTrain[,-7], carTrain$category)
summary(car_C50)
plot(car_C50)

#quality of classification for training data
car_c50_trainPred <- predict(car_C50, carTrain)

?CrossTable
CrossTable(car_c50_trainPred, carTrain$category, prop.chisq = FALSE,prop.c = FALSE,
           prop.r = FALSE, dnn = c('predicted class', 'actual class'))

?confusionMatrix
confusionMatrix(car_c50_trainPred, carTrain$category, mode="everything")

#quality of classification for test data
car_c50_testPred <- predict(car_C50, carTest)
CrossTable(car_c50_testPred, carTest$category, prop.chisq = FALSE,prop.c = FALSE,
           prop.r = FALSE, dnn = c('predicted class', 'actual class'))

confusionMatrix(car_c50_testPred, carTest$category, mode="everything")

#model building - rules
car_C50R <- C5.0(carTrain[,-7], carTrain$category,  rules = TRUE)
summary(car_C50R)

#quality of classification for test data
car_c50_testPred <- predict(car_C50R, carTest)
CrossTable(car_c50_testPred, carTest$category, prop.chisq = FALSE,prop.c = FALSE,
           prop.r = FALSE, dnn = c('predicted class', 'actual class'))

confusionMatrix(car_c50_testPred, carTest$category, mode="everything")

#Ensemble classifier (boosting)
?churn
data(churn)
summary(churnTrain)
summary(churnTest)

#tree
churn_C50 <- C5.0(churnTrain[, -20], churnTrain$churn)
churn_C50_testPred =predict(churn_C50, churnTest)
confusionMatrix(churn_C50_testPred, churnTest$churn, mode="everything")

#ensemble tree
churn_C50B <- C5.0(churnTrain[, -20], churnTrain$churn,trials = 10)
churn_C50B_testPred =predict(churn_C50B, churnTest)
confusionMatrix(churn_C50B_testPred, churnTest$churn, mode="everything")
summary(churn_C50B)

###################################################################3333333
#dane iris (https://archive.ics.uci.edu/ml/datasets/Iris)
data(iris)
#str(iris)
#View(iris)

idTrainData1 <- unlist(createDataPartition(iris$Species,p=0.7))
#str(idTrainData)

irisTrain <-iris[idTrainData1,]
irisTest <-iris[-idTrainData1,]

table(irisTest$Species)

#setting the class attribute
irisFormula <-  Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width

################################################################
# 2.  rpart - recursive partitioning trees                       #
################################################################

?rpart
# tree building
iris_rpart <- rpart(irisFormula,  method="class", data=irisTrain)
print(iris_rpart)

#  CP - complexity parameter: serves as a penalty to control the size of the tree;
#the greater the CP value, the fewer the number of splits there are
#  rel error represents the average deviance of the current tree divided
#by the average deviance of the null tree
#  xerror value represents the relative error estimated by a 10-fold classification
#  xstd stands for the standard error of the relative error

summary(iris_rpart)

?rpart.plot
#plot(iris_rpart, main="Classification for Iris")
#text(iris_rpart, use.n=TRUE, all=TRUE, cex=.7)
rpart.plot(iris_rpart, main="Classification for Iris")

?prp
prp(iris_rpart, faclen = 0, cex = NULL, extra = 1, main="Classification for Iris")

iris_rpart <- rpart(irisFormula,  method="class", data=irisTrain)
print(iris_rpart)

#training data classification - confusion matrix
iris_rpat_trainPred = predict(iris_rpart,irisTrain,type = "class")
table(iris_rpat_trainPred, irisTrain$Species)

#test data classification - confusion matrix
iris_rpat_testPred = predict(iris_rpart,irisTest,type = "class")
table(iris_rpat_testPred, irisTest$Species)

confusionMatrix(iris_rpat_testPred, irisTest$Species, mode="everything")

#Loss matrix - a row the actual class, a column - predicted class
#(The loss matrix must have zeros on the diagonal and positive off-diagonal elements)
lossM=matrix(c(0,1,1,1,0,4,1,1,0), byrow=TRUE, nrow=3)
lossM
iris_rpartLM <-  rpart(irisFormula,  method="class", data=irisTrain, parms = list(loss = lossM ))

#training data classification - confusion matrix
iris_rpatLM_trainPred = predict(iris_rpartLM,irisTrain,type = "class")
table(iris_rpatLM_trainPred, irisTrain$Species)

#test data classification - confusion matrix
iris_rpatLM_testPred = predict(iris_rpartLM,irisTest,type = "class")
table(iris_rpatLM_testPred, irisTest$Species)

#changing the values of parameters
rpControl = rpart.control(minbucket =30, maxDepth = 1);
rpTree <- rpart(irisFormula,  method="class", data=irisTrain,
                control =rpControl,
                parms = list(split = "information" ))
rpart.plot(rpTree, main="Classification for Iris")

iris_rpartS = predict(rpTree,irisTrain,type = "class")
table(iris_rpartS, irisTrain$Species)

#tree pruning

#The cost complexity pruning algorithm considers the cost complexity of a tree to be a function of
# the number of leaves in the tree and the error rate of the tree (where the error rate is the
# percentage of tuples misclassified by the tree). It starts from the bottom of the tree. For
# each internal node, N, it computes the cost complexity of the subtree at N, and the cost
# complexity of the subtree at N if it were to be pruned (i.e., replaced by a leaf node). The
# two values are compared. If pruning the subtree at node N would result in a smaller cost
# complexity, then the subtree is pruned. Otherwise, it is kept.
# A pruning set of class-labeled tuples is used to estimate cost complexity. This set is
# independent of the training set used to build the unpruned tree and of any test set used
# for accuracy estimation. The algorithm generates a set of progressively pruned trees. In
# general, the smallest decision tree that minimizes the cost complexity is preferred.

#the minimal  cross-validation error
min(iris_rpartLM$cptable[,"xerror"])
which.min(iris_rpartLM$cptable[,"xerror"])
rpTree.cp=iris_rpartLM$cptable[3,"CP"]
rpTree.cp
?prune
iris_rpartLM_Pruned<- prune(iris_rpartLM, cp = rpTree.cp)

#iris_rpartLM_Pruned <- prune(iris_rpartLM, cp = rpTree$cptable[which.min(rpTree$cptable[,"xerror"]),"CP"])

rpart.plot(iris_rpartLM, main="Classification for Iris")
rpart.plot(iris_rpartLM_Pruned, main="Classification for Iris - pruned")

################################################################
#  3. randomForest                                             #
################################################################

?randomForest
car_Forest = randomForest(category~., data = carTrain, importance = TRUE, nodesize = 10, mtry = 4, ntree = 100 )
#nodesize = minimal number of objects in a node
#mtry - the number of randomly selected attributes for searching the best test split in nodes
#ntree -  number of trees in a forest
#importance - calculation of attriubte importance

print(car_Forest)
plot(car_Forest)

?importance
round(importance(car_Forest, type = 1),2)

car_Forest_testPred = predict (car_Forest, newdata = carTest[-7])
confusionMatrix(car_Forest_testPred, carTest$category, mode = "everything")

#looking for the best values of parameters by means of K-fold validation
?trainControl
trControl <- trainControl(method = "cv", number = 10, search = "grid")

#arguments
#- method = "cv": The method used to resample the dataset.
#- number = n: Number of folders to create
#- search = "grid": Use the search grid method. For randomized method, use "grid"

?train
tuneGrid <- expand.grid(mtry = c(1:6))
tuneGrid
car_Frestores_mtry <- train(category~.,  data = carTrain,
                            method = "rf",
                            metric = "Accuracy",
                            tuneGrid = tuneGrid,
                            trControl = trControl,
                            importance = TRUE,    # randomForest function parameter
                            nodesize = 10,        # randomForest function parameter
                            ntree = 250)          ## randomForest function parameter
print(car_Frestores_mtry)

treesModels <- list()
for (nbTree in c(5,10,25, 50, 100, 250, 500))
{
  car_F_maxtrees <- train(category~.,  data = carTrain,
                          method = "rf",
                          metric = "Accuracy",
                          tuneGrid = tuneGrid,
                          trControl = trControl,
                          importance = TRUE,
                          nodesize = 10,
                          ntree = nbTree)
  key <- toString(nbTree)
  treesModels[[key]] <- car_F_maxtrees
}

?resamples
results_tree <- resamples(treesModels)
summary(results_tree)

#ko?cowy model
car_Forest2 = randomForest(category~., data = carTrain, importance = TRUE, mtry = 6, ntree = 250, nodesize = 10)

print(car_Forest2)
plot(car_Forest2)

car_Forest2_testPred = predict (car_Forest, newdata = carTest[-7])
confusionMatrix(car_Forest2_testPred, carTest$category, mode = "everything")

varImpPlot(car_Forest2)

################################################
#Comparision of classifiers
###############################################
car_rpart <- rpart(category~., data=carTrain)
car_rpart_testPred = predict(car_rpart, carTest, type = "class")

klasyfikator = c('C50', 'rpart',  'rForest')
dokladnosc = c( mean(car_c50_testPred == carTest$category),
                mean(car_rpart_testPred == carTest$category),
                mean(car_Forest2_testPred == carTest$category))

res <- data.frame(klasyfikator, dokladnosc)
View(res)

#######################################
#datasets for the task

#Wines
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-red.csv', 'wine_red.csv');
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv', 'wine_white.csv');
wineRed_ds = read.table("wine_red.csv", header = TRUE, sep=";", na.strings= "*")

#creating a new attribute with 3 values(classses) based on
# the orignal class atribute - quality
wineRed_ds$Q2 = lapply(wineRed_ds[,12], function (x)
{
  if(x >6)  { "A"}
  else if(x >4)  {"B"}
  else { "C"}
})

wineRed_ds$Q2 = unlist(wineRed_ds$Q2);
wineRed_ds$Q2 = as.factor(wineRed_ds$Q2)

#cars
#download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/car/car.data', 'car.data')
#cars_ds = read.csv("E:\\dydaktyka\\als\\lab\\datasets\\car.data", header = FALSE,
#  col.names = c('buying', 'maint', 'doors', 'persons', 'lug_boot','safety', "category") )

#abalone
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/abalone/abalone.data', 'abalone.data')
abalone  = read.table("abalone.data", header = FALSE, sep=",", na.strings= "*")
colnames(abalone) <- c('Sex', 'Length','Diameter','Height','Whole', 'Shucked', 'Viscera','Shell','Rings')

abalone$Age = lapply(abalone[,'Rings'], function (x)
{
  if(x >10)  { "Old"}
  else if(x >8)  {"Middle"}
  else { "Young"}
})
abalone$Age = unlist(abalone$Age);
abalone$Age = as.factor(abalone$Age)
#abalone$Rings <- NULL
download.file('http://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv', 'wine_white.csv');
wineRed_ds = read.table("wine_red.csv", header = TRUE, sep=";", na.strings= "*")


#-------------------------------------------------------------------
# vtfn -- Generate spectrum of vocal tract response given formant
#         frequency, amplitude, and bandwidth.
#
# Args:
#  pars -- A vector of named parameters. The first parameter is the
#          number of poles and zeros described in subsequent triplets
#          (frequency, bandwidth, amplitude) of parameters. Poles are
#          distinguished from zeros by having positive instead of
#          negative frequency values.
#
#  np   -- The number of points of spectrum values to cover the
#          Nyquist range from 0 - fs/2. This is deceptive because,
#          to be consistent with FFT concentions, there will really
#          be an np+1 point spectrum returned with the first value
#          corresponding to DC and the last to the Nyquist frequency.
#
#  fs   -- Sampling frequency in Hz.
#
# Notes: This is the "parallel formant" version with each formant
#        curve calculated independently and added to the others.
#        Each formant is also multiplied by an amplitude factor
#        that is passed as a quantity in dB via the pars vector.
#        Additionally, this function called the underlying formant
#        function with scaled=TRUE so that every formant response
#        curve is generated with a theoretical peak amplitude of 1.0.
#
# 1/10/20 -- htb
#-------------------------------------------------------------------

vtfn2 <- function(pars, np=512, fs=16000) {
  maxf <- fs/2
  nres <- pars[1]
  s <- rep(0,np+1)
  z <- rep(1,np+1)
  for (j in seq(2,nres*3,3)) {
    af <- 10^(pars[j+2]/20)
    if (pars[j] > 0) {
      s <- s + af * formant(pars[j],pars[j+1],np,maxf)
      #cat(paste0('pole: af=',af,'; f=',pars[j],'; b=',pars[j+1],'\n'))
    } else {
      z <- z * af / formant(pars[j],pars[j+1],np,maxf)
      #cat(paste0('zero: af=',af,'; f=',pars[j],'; b=',pars[j+1],'\n'))
    }
  }
  s*z
}


cat("Initialize Markov chain; ")
# Initialize Markov Chain;
pmprior <- unitmask
rm(unitmask)
# pmgenpars <- c(6.0,1) # just tried this
#pmgenpars <- c(0,3.158971,1.516190) # Andrew estimated from traced links using China data;
#pmgenpars <- c(0,1.423395,4.528192)
pmgenpars <- c(0,2.001668,2.493639)
sigth <- rep(0,length(invtransfpar(pmgenpars)))
# adjust sigp to achieve good acceptance rate
# sigp <- 1.5
sigp <- 0.25;
pmppars <- matrix(1,ncol=length(timedata),nrow=length(timedata))*pmprior
newtypes <- mctype(typedata,freqtype)
oldtypes <- newtypes
# typemat <- mctypemat(oldtypes)
typemat <- typemask
rm(typemask)
updtype <- 0
tu <- updtype
oldtheta <- invtransfpar(pmgenpars)
linklist <- makelinklist(oldtheta,timedata)*typemat
ltppars <- matrix(c(oldtheta,rep(0.5,length(oldtheta))),nrow=3) #oldpmat <- out.data[[1]],
oldpmat <- matrix(NA,nrow=length(timedata),ncol=length(timedata))
# for (i in 1:length(timedata)){
#   oldpmat[i,]<-initvec2(i,timedata,
#                         typemat[1:length(timedata)],invtransfpar(pmgenpars))
# }
oldpmat <- sapply(1:length(timedata),
  function(x) initvec(x,timedata,typemat[1:length(timedata)],
                       invtransfpar(pmgenpars)))
# oldpmat <- normalize(matrix(1,nrow=length(timedata),ncol=length(timedata)))
oldlogpost <- logpost(timedata,oldtheta,linklist,oldpmat)
logoldpost <- -2*oldlogpost
pmpost <- logoldpost

posttrail <- list(pmpost)
thetatrail <- list(oldtheta)
#pmtrail <- list(oldpmat)
typetrail <- list(oldtypes)

rej <- 0
acc <- 0
sk <- 1
iterskip <- 1

# system.time(btest(sk))


Bio1<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-2.235282155+(2.3733*(log(DAP)))) # bs-T de alvarez et al. (en preparacion)
Bio2<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.544182155+(2.3733*(log(DAP)))) # bh-T de alvarez et al. (en preparacion)
Bio3<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.908382155+(2.3733*(log(DAP)))) # bp-T de alvarez et al. (en preparacion)
Bio4<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.865582155+(2.3733*(log(DAP)))) # bh-PM de alvarez et al. (en preparacion)
Bio5<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-1.662982155+(2.3733*(log(DAP)))) # bh-MB de alvarez et al. (en preparacion)
Bio6<-function(Dens=NULL,DAP,Alt=NULL,AB=NULL) exp(-2.616382155+(2.3733*(log(DAP)))) # bh-M de alvarez et al. (en preparacion)

CargarIndividuos<-function(y){
tryCatch({
Individuos<-read.csv(y,enc="latin1")
return (list(FALSE,Individuos))
}, error = function(ex) {
print("No se pudo cargar el archivo de individuos")
return (TRUE)
})
}

CargarParcelas<-function(x){
tryCatch({
Parcela<-read.csv(x,enc="latin1")
return (list(FALSE,Parcela))
}, error = function(ex) {
print("No se pudo cargar el archivo de parcelas")
return (TRUE)
})
}

organizarInfo<-function(i,p){
tryCatch({
base1<-merge(i,p)
base1a<-subset(base1,DAP>=10)
base2<-subset(base1a,Familia!="Arecaceae")
str(base2)
summary(base2)
return (list(FALSE,base2,base1))
}, error = function(ex) {
print("Error en el analisis de la informacion de los archivos")
return(TRUE)
})
}

CalculaBiomasa<-function(x){
 tryCatch({
  EcuacionesAlometricas<-c('Bio1','Bio2','Bio3','Bio4','Bio5','Bio6')
  Biomasa<-get(EcuacionesAlometricas[as.integer(x[["Ecuacion"]])])(as.numeric(x[["Dens"]]),
  as.numeric(x[["DAP"]]),
  as.numeric(x[["Alt"]]),
  as.numeric(x[["AB"]]))
  return(Biomasa)
  }, error = function(ex) {
print("No se pudo realizar el calculo de la Biomasa")
})
}

calcularBiomasaCarbono<-function(base2){
tryCatch({
base2$BiomasaKg<-apply(base2,1,CalculaBiomasa)
ParcelasBiomasa<-aggregate(base2$BiomasaKg/((base2$Area*10000)/10),list(Plot=base2[,"Plot"]),sum,na.rm=TRUE)
#base3<-merge(Parcela,ParcelasBiomasa)
base3<-merge(base1,ParcelasBiomasa)
base3$Biomasa<-base3$x
base3$Carbono<-base3$Biomasa*0.5
base4<-subset(base3,select=c(Plot,FID,DAP,Familia,Area,Bosque,Ecuacion,Biomasa,Carbono))
return(list(FALSE,base4,ParcelasBiomasa))
}, error = function(ex) {
print("Error al realizar el calculo de la biomasa y el carbono")
return (TRUE)
})
}

cargarExtremeValues<-function(){
tryCatch({
  library(extremevalues)
  return(FALSE)
}, error = function(ex) {
  return(TRUE)
})
}

Atipicos<-function(p,x,y)
{
tryCatch({
base3<-merge(p,x)
ParcelaBiomasa<-subset(y,select=c(Plot,Area,Bosque,Biomasa))
lognormal<-getOutliersII(ParcelaBiomasa$Biomasa,distribution="lognormal")
ParcelaSinOuts<-ParcelaBiomasa[-c(lognormal$iRight,lognormal$iLeft),]
return(list(FALSE,ParcelaBiomasa,ParcelaSinOuts))
	}, error = function(ex) {
print("Error realizando el calculo de los datos Atipicos");
return (TRUE)
})
}

var.wtd.mean.cochran <- function(x,w,na.rm=TRUE)
{
  if (na.rm){
  x<-x[!is.na(w)]
  w<-w[!is.na(w)]
  }
	n = length(w)
	xWbar = weighted.mean(x,w)
	wbar = mean(w)
	out = n/((n-1)*sum(w)^2)*(sum((w*x-wbar*xWbar)^2)-2*xWbar*sum((w- wbar)*(w*x-wbar*xWbar))+xWbar^2*sum((w-wbar)^2))
	return (out)
}

AtipicosTodos<-function(ParcelaBiomasa){
tryCatch({
varzas<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque,Area),var))
desv.estand<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque),sd))
ns1<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque),length))
ponderaciones<-(1/varzas)/apply((1/varzas),1,sum,na.rm=TRUE)
apply(ponderaciones,1,sum,na.rm=TRUE)
medias1<-with(ParcelaBiomasa,tapply(Biomasa,list(Bosque,Area),mean))
medias2<-apply(medias1*ponderaciones,1,sum,na.rm=TRUE)
medias3<-with(ParcelaBiomasa,tapply(Biomasa,Bosque,mean))
sec1<-1:nrow(medias1)
var.wtd.media<-function(i,medias,varianzas,na.rm=TRUE){
   var.wtd.mean.cochran(medias1[i,],1/varianzas[i,],na.rm=TRUE)
   }
r1<-sapply(sec1,var.wtd.media,medias1,varzas)

SalidaTodos<-data.frame(ns=ns1,
                  media_w=medias2,desv.estand_w=sqrt(r1),
                  CV_w=sqrt(r1)/medias2*100,
                  IC_w=1.96*sqrt(r1))
return (list(FALSE,SalidaTodos))
}, error = function(ex) {
print("No se pudo realizar el analisis de los Valores Atipicos")
return (TRUE)
})
}

AtipicosSin<-function(ParcelaSinOuts){
tryCatch({
varzas<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque,Area),var))
desv.estand<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque),sd))
ns1<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque),length))
ponderaciones<-(1/varzas)/apply((1/varzas),1,sum,na.rm=TRUE)
apply(ponderaciones,1,sum,na.rm=TRUE)
medias1<-with(ParcelaSinOuts,tapply(Biomasa,list(Bosque,Area),mean))
medias2<-apply(medias1*ponderaciones,1,sum,na.rm=TRUE)
medias3<-with(ParcelaSinOuts,tapply(Biomasa,Bosque,mean))
sec1<-1:nrow(medias1)
var.wtd.media<-function(i,medias,varianzas,na.rm=TRUE){
   var.wtd.mean.cochran(medias1[i,],1/varianzas[i,],na.rm=TRUE)
   }
r1<-sapply(sec1,var.wtd.media,medias1,varzas)

SalidaSinOuts<-data.frame(ns=ns1,
                  media_w=medias2,desv.estand_w=sqrt(r1),
                  CV_w=sqrt(r1)/medias2*100,
                  IC_w=1.96*sqrt(r1))
return (list(FALSE,SalidaSinOuts))
}, error = function(ex) {
print("No se pudo realizar el analisis de los Valores Atipicos")
return (TRUE)
})
}


#弯月面Meniscus的高度和角度随流量，极间距离，电压变化而变化
#针头三种液体，ethanol，acetone， isoproply
#height高度和angle角度，在一张图上，分为上下部分
#三张图，分别对应三种x轴，流量，极间距离，电压
#两张大图，分别对应height和angle
#函数名为men_ah & men_aa, men_ah & men_aa，men_ih & men_ia

#设定工作区间
setwd("D:/data")
library(xlsx)

#读取数据

men_ah<-read.xlsx("meniscus.xls",sheetName="distance_h",header=TRUE)
men_aa<-read.xlsx("meniscus.xls",sheetName="distance_a", header=TRUE)

#规划figure界面
par(mfrow=c(2,1), mar=c(4,4,2,2), oma=c(1,1,1,1))

#############针对distance极间距离###########

#保存pdf
#pdf("men_distance.pdf")

################################画图-高度曲线###########################
plot(men_ah$distance, men_ah$ethanol, col=0, xaxs="i", xlim=c(0, 4.2), ylim=c(0, 0.9),
xlab="Distance (mm)", cex.lab=1, ylab="Height of Meniscus (mm)", main="Height with H in meniscus")

lines(lowess(men_ah$distance, men_ah$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ah$distance, men_ah$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ah$distance, men_ah$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topleft", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

##############################画图--角度曲线############################
plot(men_aa$distance, men_aa$ethanol, col=0, xaxs="i", xlim=c(0, 4.2), ylim=c(45, 100),
xlab="Distance (mm)", cex.lab=1, ylab="Taylor Angle （°）", main="Angle with H in meniscus")

lines(lowess(men_aa$distance, men_aa$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_aa$distance, men_aa$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_aa$distance, men_aa$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("bottomleft", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

#dev.off()


library(quantmod)                                                               # Load quantmod
library(tidyquant)                                                              # Loads tidyquant, tidyverse, lubridate, quantmod, TTR, and xts
library(TTR)                                                                    # Technical Trading Rules package
# SPL Processing -----------------------------------------------------------------------------------
SPL <- tq_get("SPL.AX")                                                         # Get SPL Stock Prices
SPL<-SPL[complete.cases(SPL),]                                                  # Delete NA
date_1 <- SPL$date                                                              # Create date variable
date <- date_1 + 1
key<-paste(as.character(format(date, "%Y")), as.character(format(date, "%m")),  # Create Key
    as.character(format(date, "%d")), "spl", sep = "")
# Create Table -------------------------------------------------------------------------------------
tblPrice <- data.frame(key,SPL,"spl", date)                                     # Create Stock Price Table
# Delete Table NA ----------------------------------------------------------------------------------
tblPrice<-tblPrice[complete.cases(tblPrice),]                                   # Delete tblPrice NA's
# Rename Table columns -----------------------------------------------------------------------------
colnames(tblPrice) <- c("key","date-1", "open", "high", "low", "close", "volume",
    "adjusted", "symbol", "date" )                                              # Rename tblPBands Table Columns
# Indexing  ----------------------------------------------------------------------------------------
tblPrice <- tibble::rowid_to_column(tblPrice, "Index")                          # Add Index to tblPrice
# Reorder  -----------------------------------------------------------------------------------------
tblPrice <- tblPrice[, c(2, 1, 11, 3, 10, 4, 5, 6, 7, 9, 8)]                    # Reorder tblPrice columns
# Create Simulation Matrix  -----------------------------------------------------------------------------------
mtxDeltPrice <- data.matrix(Delt(tblPrice$adjusted, k=1:200))                   # Create Adjusted Price Matrix
mtxDeltPrice[is.infinite(mtxDeltPrice) | is.na(mtxDeltPrice)] <- 0              # Check for inf or na's and convert to 0
rownames(mtxDeltPrice) <- rownames(mtxDeltPrice, do.NULL = FALSE, prefix = "")  # Add Row Name - Index Value
colnames(mtxDeltPrice) <- c(1:200)                                              # Add Column Name Value 1 - 200
# Create Simulation Data Frame  -----------------------------------------------------------------------------
tblDeltPrice <- data.frame(mtxDeltPrice)
sprintf("x%03d", tblDeltPrice)
# Top / Bottom n Values  ------------------------------------------------------------------------------------
tblDeltPriceBotN <- data.frame(head(sort(mtxDeltPrice), 50))                    # Bottom N Prices
tblDeltPriceBotIdx<- data.frame(which(mtxDeltPrice<=sort(mtxDeltPrice,          # Bottom N Prices Index
                decreasing = F)[50], arr.ind = T))
tblDeltPriceTopN <- data.frame(head(sort(mtxDeltPrice,decreasing = TRUE), 50))  # Top N Prices
tblDeltPriceTopIdx<- data.frame(which(mtxDeltPrice>=sort(mtxDeltPrice,          # Top N Prices Index
                decreasing = T)[50], arr.ind = T))


out_file = 'inner_distance'
pdf('inner_distance.inner_distance_plot.pdf')
fragsize=rep(c(-247.5,-242.5,-237.5,-232.5,-227.5,-222.5,-217.5,-212.5,-207.5,-202.5,-197.5,-192.5,-187.5,-182.5,-177.5,-172.5,-167.5,-162.5,-157.5,-152.5,-147.5,-142.5,-137.5,-132.5,-127.5,-122.5,-117.5,-112.5,-107.5,-102.5,-97.5,-92.5,-87.5,-82.5,-77.5,-72.5,-67.5,-62.5,-57.5,-52.5,-47.5,-42.5,-37.5,-32.5,-27.5,-22.5,-17.5,-12.5,-7.5,-2.5,2.5,7.5,12.5,17.5,22.5,27.5,32.5,37.5,42.5,47.5,52.5,57.5,62.5,67.5,72.5,77.5,82.5,87.5,92.5,97.5,102.5,107.5,112.5,117.5,122.5,127.5,132.5,137.5,142.5,147.5,152.5,157.5,162.5,167.5,172.5,177.5,182.5,187.5,192.5,197.5,202.5,207.5,212.5,217.5,222.5,227.5,232.5,237.5,242.5,247.5),times=c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,49,631,549,591,635,692,778,1071,1614,2467,3810,5820,8914,13177,18980,24179,30826,36146,40412,44101,48215,48389,49792,49007,48154,45683,43616,40804,37813,34090,30615,28166,24895,22351,20048,17184,15222,13515,11981,10325,9036,7915,6941,5967,5365,4584,3964,3560,2956,2727,2362,2092,1954,1691,1592,1445,1344,1189,1081))
frag_sd = sd(fragsize)
frag_mean = mean(fragsize)
frag_median = median(fragsize)
write(x=c("Name","Mean","Median","sd"), sep="	", file=stdout(),ncolumns=4)
write(c(out_file,frag_mean,frag_median,frag_sd),sep="	", file=stdout(),ncolumns=4)
hist(fragsize,probability=T,breaks=100,xlab="mRNA insert size (bp)",main=paste(c("Mean=",frag_mean,";","SD=",frag_sd),collapse=""),border="blue")
lines(density(fragsize,bw=10),col='red')
dev.off()


## @knitr kprats-cph-np
require(rms)
options(prType='latex')
group <- c(rep('Group 1',19),rep('Group 2',21))
group <- factor(group)
dd    <-  datadist(group); options(datadist='dd')
days <-
  c(143,164,188,188,190,192,206,209,213,216,220,227,230,
    234,246,265,304,216,244,142,156,163,198,205,232,232,
    233,233,233,233,239,240,261,280,280,296,296,323,204,344)
death <- rep(1,40)
death[c(18,19,39,40)] <- 0
units(days) <- 'Day'
df <- data.frame(days, death, group)
S <- Surv(days, death)

f <- npsurv(S ~ group, type='fleming')
for(meth in c('exact', 'breslow', 'efron')) {
  g <- cph(S ~ group, method=meth, surv=TRUE, x=TRUE, y=TRUE)
  # print(g) to see results
}
f.exp <- psm(S ~ group, dist='exponential')
fw    <- psm(S ~ group, dist='weibull')
phform <- pphsm(fw)

co <- gray(c(0, .8))
survplot(f, lty=c(1, 1), lwd=c(1, 3), col=co,
         label.curves=FALSE, conf='none')
survplot(g, lty=c(3, 3), lwd=c(1, 3), col=co,  # Efron approx.
         add=TRUE, label.curves=FALSE, conf.type='none')
legend(c(2, 160), c(.38, .54),
       c('Nonparametric Estimates', 'Cox-Breslow Estimates'),
       lty=c(1, 3), cex=.8, bty='n')
legend(c(2, 160), c(.18, .34), cex=.8,
       c('Group 1', 'Group 2'), lwd=c(1,3), col=co, bty='n')

## @knitr kprats-cumhaz-ratio
f <- cph(S ~ strat(group), surv=TRUE)
# For both strata, eval. S(t) at combined set of death times
times <- sort(unique(days[death == 1]))
est   <- survest(f, data.frame(group=levels(group)),
                 times=times, conf.type="none")$surv
cumhaz  <- - log(est)
plot(times, cumhaz[2,] / cumhaz[1,], xlab="Days",
     ylab="Cumulative Hazard Ratio", type="s")
abline(h=1, col=gray(.80))

## @knitr kprats-hazard-ratios
hazard.ratio.plot(g$x, g$y, e=12, pr=TRUE, legendloc='none')

## @knitr km-age-sex
n <- 2000
set.seed(3)
age <- 50 + 12 * rnorm(n)
label(age) <- 'Age'
sex <- factor(1 + (runif(n) <= .4), 1:2, c('Male', 'Female'))
cens <- 15 * runif(n)
h <- .02 * exp(.04 * (age - 50) + .8 * (sex == 'Female'))
ft <- -log(runif(n)) / h
e <- ifelse(ft <= cens, 1, 0)
print(table(e))
ft <- pmin(ft, cens)
units(ft) <- 'Year'
Srv <- Surv(ft, e)
age.dec <- cut2(age, g=10, levels.mean=TRUE)
label(age.dec) <- 'Age'
dd <- datadist(age, sex, age.dec);  options(datadist='dd')
f.np <- cph(Srv ~ strat(age.dec) + strat(sex), surv=TRUE)
# surv=TRUE speeds up computations, and confidence limits when
# there are no covariables are still accurate.
p <- Predict(f.np, age.dec, sex, time=3, loglog=TRUE)
# Treat age.dec as a numeric variable (means within deciles)
p$age.dec <- as.numeric(as.character(p$age.dec))
ggplot(p, ylim=c(-5, -.5))

## @knitr spline-age-sex-noia
f.noia <- cph(Srv ~ rcs(age,4) + strat(sex), x=TRUE, y=TRUE)
# Get accurate C.L. for any age by specifying x=TRUE y=TRUE
# Note: for evaluating shape of regression, we would not
# ordinarily bother to get 3-year survival probabilities -
# would just use X * beta
# We do so here to use same scale as nonparametric estimates
w <- latex(f.noia, file='f.noia.tex', inline=TRUE, digits=3)
print(anova(f.noia), size='normalsize')
p <- Predict(f.noia, age, sex, time=3, loglog=TRUE)
ggplot(p, ylim=c(-5, -.5))

## @knitr spline-age-sex-ia
f.ia <- cph(Srv ~ rcs(age,4) * strat(sex), x=TRUE, y=TRUE,
            surv=TRUE)
w <- latex(f.ia, file='f.ia.tex', inline=TRUE, digits=3)
print(anova(f.ia), size='normalsize')
p <- Predict(f.ia, age, sex, time=3, loglog=TRUE)
ggplot(p, ylim=c(-5, -.5))

## @knitr spline-age-sex-ia-surv
p <- Predict(f.ia, age, sex, time=3)
ggplot(p)

## @knitr spline-age-sex-ia-nomogram
surv    <- Survival(f.ia)
surv.f  <- function(lp) surv(3, lp, stratum='sex=Female')
surv.m  <- function(lp) surv(3, lp, stratum='sex=Male')
quant   <- Quantile(f.ia)
med.f   <- function(lp) quant(.5, lp, stratum='sex=Female')
med.m   <- function(lp) quant(.5, lp, stratum='sex=Male')
at.surv <- c(.01, .05, seq(.1,.9,by=.1), .95, .98, .99, .999)
at.med  <- c(0, .5, 1, 1.5, seq(2, 14, by=2))
n <- nomogram(f.ia, fun=list(surv.m, surv.f, med.m,med.f),
         funlabel=c('S(3 | Male)','S(3 | Female)',
                    'Median (Male)','Median (Female)'),
         fun.at=list(c(.8,.9,.95,.98,.99),
                     c(.1,.3,.5,.7,.8,.9,.95,.98),
                     c(8,10,12),c(1,2,4,8,12)))
plot(n, col.grid=FALSE, lmgp=.2)   # Fig. (*\ref{fig:cox-spline-age-sex-ia-nomogram}*)
latex(f.ia, digits=3)

## @knitr ef-spline
# acath2 <- sas.get('.','acath2')
if(FALSE) {
acath2 <- subset(acath2, ejfx == trunc(ejfx)) # non-imputed values
acath2 <- upData(acath2,
                 lvef = ejfx / 100,
                 labels=c(lvef = 'LVEF'))
nk <- 3
d <- datadist(acath2);  options(datadist='d')
with(acath2,
     rcspline.plot(lvef, d.time, model='cox', event=cdeath,
                   main='', statloc=c(.42, -1), nk=nk,
                   ylim=c(-4, -.9)))
if(nk == 3) print(cph(Surv(d.time, cdeath) ~ pmin(lvef,.5), data=acath2))
}

## @knitr ef.martingale
if(FALSE) {
cox <- cph(Surv(d.time,cdeath) ~ lvef, data=acath2, iter.max=0)
res <- resid(cox)
g <- loess(res ~ lvef, data=acath2)
plot(g, coverage=0.95, confidence=7, xlab='LVEF', ylab='Martingale Residual')

g <- ols(res ~ rcs(lvef, 5), data=acath2)
plot(Predict(g, lvef))  # not added to previous plot as really shown

with(acath2, {
  s <- ! is.na(res + lvef)
  lines(lowess(lvef[s], res[s], iter=0), lty=3)
  ## lowess doesn't handle NAs
})

legend(.20, 1.15, c('loess Fit and 0.95 Confidence Bars',
	'ols Spline Fit and 0.95 Confidence Limits',
	'lowess Smoother'), lty=1:3, bty='n', cex=cex.legend)
box()
}

## @knitr valung-ratios
getHdata(valung)
with(valung, {
  hazard.ratio.plot(1 * (cell == 'Squamous'), Surv(t, dead),
                    e=25, subset=cell != 'Large',
                    pr=TRUE, pl=FALSE)
  hazard.ratio.plot(1 * kps, Surv(t, dead), e=25,
                    pr=TRUE, pl=FALSE) })

## @knitr rel-random
n <- 200
p <-  20
set.seed(6)
xx <- matrix(rnorm(n * p), nrow=n, ncol=p)
y  <- runif(n)
units(y) <- "Year"
e   <- c(rep(0, n / 2), rep(1, n / 2))
f   <- cph(Surv(y, e) ~ xx, x=TRUE, y=TRUE,
           time.inc=.5, surv=TRUE)
cal <- calibrate(f, u=.5, B=200)
plot(cal, ylim=c(.4, 1), subtitles=FALSE)
calkm <- calibrate(f, u=.5, m=40,  cmethod='KM', B=200)
plot(calkm, add=TRUE)   # Figure (*\ref{fig:cox-rel-random}*)

## @knitr val-random
latex(validate(f, B=200), digits=3, file='',
      caption='Bootstrap validation of a Cox model with random predictors',
      table.env=TRUE, label='tab:cox-val-random')