###############################################################################
#
#   audit_MLE_estimation.r
#   CLEANED UP VERSION OF [V6][8-17-2012]
#
###############################################################################

### setup #####################################################################

    # source
    library(epicalc)
    library(rms)

    # clear
    zap()
    rm(list=ls(all=TRUE))

    # set locations
    #rootdir <- SET ROOT DIRECTORY HERE

    workingdir <- paste(rootdir, "workingdir", sep="/") # STORE DATA FILES AND HELPER FILES HERE
    tabdir <- paste(rootdir, "tables", sep="/") # OUTPUT HERE

    setwd(workingdir)

### likelihood functions ######################################################

########### 1st order in t

    objfun.1st <- function(theta, tstar, Ts, months, years, ds){

        logps <- rep(0, NROW(Ts))

        for (i in 1:NROW(Ts)){

            T <- Ts[i]
            d <- ds[i]

            if(!is.na(months[i])){

                t <- months[i]

                logps[i] <- log(prob.1st.monthly(theta, tstar, t, T, d))
                for (tau in (t+1):T){
                    logps[i] <- logps[i] + log(1 - prob.1st.monthly(theta, tstar, tau, T, d))
                }

            } else if (!is.na(years[i])) {

                t <- years[i]

                logps[i] <- log(prob.1st.yearly(theta, tstar, t, 1, d))
                for (tau in (t*12 + 1):T){
                    logps[i] <- logps[i] + log(1 - prob.1st.monthly(theta, tstar, tau, T, d))
                }

            } else {

                # HARDCODED CUTOFF DATE HERE
                for (tau in (-22):T){
                    logps[i] <- logps[i] + log(1 - prob.1st.monthly(theta, tstar, tau, T, d))
                }

            }
        }

        return(-sum(logps))

    }

    prob.1st.monthly <- function(theta, tstar, t, T, d){

        temp <- theta[1]*as.numeric(t >= tstar) + theta[2]*as.numeric(d==11) + theta[3]*as.numeric(d==24) + theta[4]*as.numeric(d==29) + theta[5]*t
        return(exp(temp) / (1 + exp(temp)))

    }

    prob.1st.yearly <- function(theta, tstar, t, T, d){

        temp <- 1
        for (m in 1:12){
            temp <- temp * (1 - prob.1st.monthly(theta, tstar, (t-1)*12 + m, T, d))
        }
        return(1 - temp)

    }

    # test suite
    #theta <- rep(0,5)
    #prob.1st.monthly(theta, tstar=5, t=1, T=14, d=1)
    #prob.1st.yearly(theta, tstar=5, t=1, T=14, d=1)
    #objfun.1st(theta, tstar=5, Ts=c(14), months=c(NA), years=c(1), ds=c(1))
    #-log((1 - 0.5^12)*(0.5^2))
    #objfun.1st(theta, tstar=5, Ts=c(14,14), months=c(NA,13), years=c(1,NA), ds=c(1,1))
    #-log((1 - 0.5^12)*(0.5^2)) - log(0.5*0.5)

########### 2nd order in t

    objfun.2nd <- function(theta, tstar, Ts, months, years, ds){

        logps <- rep(0, NROW(Ts))

        for (i in 1:NROW(Ts)){

            T <- Ts[i]
            d <- ds[i]

            if(!is.na(months[i])){

                t <- months[i]

                logps[i] <- log(prob.2nd.monthly(theta, tstar, t, T, d))
                for (tau in (t+1):T){
                    logps[i] <- logps[i] + log(1 - prob.2nd.monthly(theta, tstar, tau, T, d))
                }

            } else if (!is.na(years[i])) {

                t <- years[i]

                logps[i] <- log(prob.2nd.yearly(theta, tstar, t, 1, d))
                for (tau in (t*12 + 1):T){
                    logps[i] <- logps[i] + log(1 - prob.2nd.monthly(theta, tstar, tau, T, d))
                }

            } else {

                # HARDCODED CUTOFF DATE HERE
                for (tau in (-22):T){
                    logps[i] <- logps[i] + log(1 - prob.2nd.monthly(theta, tstar, tau, T, d))
                }

            }
        }

        return(-sum(logps))

    }

    prob.2nd.monthly <- function(theta, tstar, t, T, d){

        temp <- theta[1]*as.numeric(t >= tstar) + theta[2]*as.numeric(d==11) + theta[3]*as.numeric(d==24) + theta[4]*as.numeric(d==29) + theta[5]*t + theta[6]*t*t
        return(exp(temp) / (1 + exp(temp)))

    }

    prob.2nd.yearly <- function(theta, tstar, t, T, d){

        temp <- 1
        for (m in 1:12){
            temp <- temp * (1 - prob.2nd.monthly(theta, tstar, (t-1)*12 + m, T, d))
        }
        return(1 - temp)

    }

### load data ######################################################

    data <- read.csv(paste0(workingdir, "/data/village_data_final.csv"))

    # restrict to villages with visits post-NREGA
    # (preferred cutoff == -22 == February 2005, the national start date)
    cutoff <- -22
    yearcutoff <- -1

    # Orissa BDO series with NAs
    or.bdo.data <- data[data$sid==24 & !is.na(data$did), ]
    or.bdo.data$q10_BDO_month[or.bdo.data$q10_BDO_month < cutoff] <- NA
    or.bdo.data$q10_BDO_year[or.bdo.data$q10_BDO_year < yearcutoff] <- NA

    # Orissa collector series with NAs
    or.collector.data <- data[data$sid==24 & !is.na(data$did), ]
    or.collector.data$q11_collector_month[or.bdo.data$q11_collector_month < cutoff] <- NA
    or.collector.data$q11_collector_year[or.bdo.data$q11_collector_year < yearcutoff] <- NA

    # set date to test: May 2007 = 5, April 2006 = -8, February 2006 = -10
    thetstar <- -10

### 1st-order polynomial in t ######################################################

########### BDO visits

    or.bdo.1.mle <- nlm(objfun.1st, rep(0,5),
                            tstar=thetstar,
                            Ts=rep(max(or.bdo.data$q10_BDO_month, na.rm=TRUE), NROW(or.bdo.data$q10_BDO_month)),
                            months=or.bdo.data$q10_BDO_month,
                            years=or.bdo.data$q10_BDO_year,
                            ds=or.bdo.data$did,
                            hessian=TRUE)
    or.bdo.1.se <- sqrt(diag(solve(or.bdo.1.mle$hessian)))
    or.bdo.1.e <- or.bdo.1.mle$estimate

    or.bdo.1.e
    or.bdo.1.se

########### MLEs for Collector visits

    or.collector.1.mle <- nlm(objfun.1st, rep(0,5),
                            tstar=thetstar,
                            Ts=rep(max(or.collector.data$q11_collector_month, na.rm=TRUE), NROW(or.collector.data$q11_collector_month)),
                            months=or.collector.data$q11_collector_month,
                            years=or.collector.data$q11_collector_year,
                            ds=or.collector.data$did,
                            hessian=TRUE)
    or.collector.1.se <- sqrt(diag(solve(or.collector.1.mle$hessian)))
    or.collector.1.e <- or.collector.1.mle$estimate

    or.collector.1.e
    or.collector.1.se

### 2nd-order polynomial in t ######################################################

########### BDO visits

    or.bdo.2.mle <- nlm(objfun.2nd, rep(0,6),
                            tstar=thetstar,
                            Ts=rep(max(or.bdo.data$q10_BDO_month, na.rm=TRUE), NROW(or.bdo.data$q10_BDO_month)),
                            months=or.bdo.data$q10_BDO_month,
                            years=or.bdo.data$q10_BDO_year,
                            ds=or.bdo.data$did,
                            hessian=TRUE)
    or.bdo.2.se <- sqrt(diag(solve(or.bdo.2.mle$hessian)))
    or.bdo.2.e <- or.bdo.2.mle$estimate

    or.bdo.2.e
    or.bdo.2.se

########### MLEs for Collector visits

    or.collector.2.mle <- nlm(objfun.2nd, rep(0,6),
                            tstar=thetstar,
                            Ts=rep(max(or.collector.data$q11_collector_month, na.rm=TRUE), NROW(or.collector.data$q11_collector_month)),
                            months=or.collector.data$q11_collector_month,
                            years=or.collector.data$q11_collector_year,
                            ds=or.collector.data$did,
                            hessian=TRUE)
    or.collector.2.se <- sqrt(diag(solve(or.collector.2.mle$hessian)))
    or.collector.2.e <- or.collector.2.mle$estimate

    or.collector.2.e
    or.collector.2.se

### output ###############################################################

    # load sigstar fn
    source(paste0(workingdir, "/files/lib_multiregtable.r"))
    source(paste0(workingdir, "/files/lib_hacktex.r"))

    # helper to fill in se cells
    secell <- function(est, se){
        return(paste("{\\scriptsize (",round(se,3),")$^{", multiregtable_sigsymbol(est/se) ,"}$}", sep=""))
    }

    out <- as.data.frame(matrix(0, nrow=NROW(or.bdo.2.e)*2, ncol=5))
    varname <- c("Shock","Koraput","Gajapati","Rayagada","Day","Day$^2$")
    for (i in 1:NROW(or.bdo.2.se)){

        out[1 + 2*(i-1), 1] <- varname[i]
        out[2 + 2*(i-1), 1] <- c("")
        if (i < 6){
            out[1 + 2*(i-1), 2] <- round(or.bdo.1.e[i], 3)
            out[2 + 2*(i-1), 2] <- secell(or.bdo.1.e[i], or.bdo.1.se[i])
            out[1 + 2*(i-1), 4] <- round(or.collector.1.e[i], 3)
            out[2 + 2*(i-1), 4] <- secell(or.collector.1.e[i], or.collector.1.se[i])
        } else{
            out[1 + 2*(i-1), 2] <- ""
            out[2 + 2*(i-1), 2] <- ""
            out[1 + 2*(i-1), 4] <- ""
            out[2 + 2*(i-1), 4] <- ""
        }
        out[1 + 2*(i-1), 3] <- round(or.bdo.2.e[i], 3)
        out[2 + 2*(i-1), 3] <- secell(or.bdo.2.e[i], or.bdo.2.se[i])
        out[1 + 2*(i-1), 5] <- round(or.collector.2.e[i], 3)
        out[2 + 2*(i-1), 5] <- secell(or.collector.2.e[i], or.collector.2.se[i])

    }

    result <- hacktex(out,file=paste(tabdir, "audit_MLE_february2006.tex", sep="/"),
                        label="tab:audit_MLE",
                        table.env=FALSE,
                        caption.loc="top",
                        rowname=NULL,
                        center="none",
                        colheads=c("Regressor","BDO","BDO","Collector","Collector"),
                        collabel.just=c("l","c","c","c","c"))


s = "12345"
s <- as.character(as.numeric(s) + 1)


modLR <- new_resultFrame()

df.split_valid <- h2o.splitFrame(train, ratios = c(0.8), seed = 1234) #validation set to size of 5-fold

#####ED-only model

glm_noreg <- h2o.glm(
family = "binomial",
training_frame = train,
nfolds = 5,
fold_assignment = "Stratified",
x = sel_feat_ed_big,
y = "alc_status",
model_id = "glm_noreg",
lambda = 0, #no penalty
compute_p_values = TRUE,
remove_collinear_columns = TRUE,
stopping_rounds = 5,
stopping_tolerance = 1e-4, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_each_iteration = T,
seed = 1234
)

# glm_noreg@model$coefficients_table %>% as.data.frame()

modLR <- add_cv_results(glm_noreg, modLR)
glm_noreg@model$cross_validation_metrics_summary
nrow(test)
# [1] 274428
glm_noreg %>% h2o.saveModel("./hypeTune_results/logistic_regression/LR_ED/")
modLR %>% write.csv("./hypeTune_results/logistic_regression/LR_ED/test_train_results.csv", row.names = F)

glm_noreg@model$cross_validation_metrics_summary %>% as.data.frame() %>%
write.csv("./hypeTune_results/logistic_regression/LR_ED/5fold_results.csv")

pred <- h2o.predict(glm_noreg, newdata = test)
pred %>% head()
df_test <- test["alc_status"] %>% as.data.frame
prob_test <- pred$p1 %>% as.data.frame()
LR_ED_ROC <- data.frame(prob = prob_test$p1, obs = df_test$alc_status)

LR_ED_ROC %>% saveRDS("./hypeTune_results/logistic_regression/LR_ED/LR_ED_ROC.rds")

###Now EDcihi

glm_noreg_edcihi <- h2o.glm(
family = "binomial",
training_frame = train,
nfolds = 5,
fold_assignment = "Stratified",
x = sel_feat,
y = "alc_status",
model_id = "glm_noreg_edcihi",
lambda = 0, #no penalty
compute_p_values = TRUE,
remove_collinear_columns = TRUE,
stopping_rounds = 5,
stopping_tolerance = 1e-3, ##early stop if AUCPR did not improve at least 0.1% over 5 consecutive turns
stopping_metric = "AUCPR",
score_each_iteration = T,
seed = 1234
)

# glm_noreg@model$coefficients_table %>% as.data.frame()

modLR <- add_cv_results(glm_noreg_edcihi, modLR)

glm_noreg_edcihi %>% h2o.saveModel("./hypeTune_results/logistic_regression/LR_EDCIHI/")
modLR[5,] %>% write.csv("./hypeTune_results/logistic_regression/LR_EDCIHI/test_train_results.csv", row.names = F)

glm_noreg_edcihi@model$cross_validation_metrics_summary %>% as.data.frame() %>%
write.csv("./hypeTune_results/logistic_regression/LR_EDCIHI/5fold_results.csv")

pred <- h2o.predict(glm_noreg_edcihi, newdata = test)
df_test <- test["alc_status"] %>% as.data.frame
prob_test <- pred$p1 %>% as.data.frame()
LR_EDCIHI_ROC <- data.frame(prob = prob_test$p1, obs = df_test$alc_status)

LR_EDCIHI_ROC %>% saveRDS("./hypeTune_results/logistic_regression/LR_EDCIHI/LR_EDCIHI_ROC.rds")

###########################################
###########################################ELASTIC NET TUNING
###########################################

hyper_params <- list(
lambda = c(1, 0.5, 0.1, 0.01, 0.001, 0.0001, 0.00001, 0),
alpha = seq(0,1,0.01)
)

hyper_params_final <- list(
lambda =  c(0.00001),
alpha = c(0.11,0.12,0.39, 0.24)
)
search_criteria = list(
strategy = "RandomDiscrete", #random grid search
max_runtime_secs = 3600 * 1,
max_models = 100,
seed = 1234)

t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params_final,
search_criteria = search_criteria,
algorithm = "glm",
grid_id = "EL_grid",
x = sel_feat_ed_big,
y = "alc_status",
family = "binomial",
training_frame = train,
nfolds = 5,
fold_assignment = "Stratified",
seed = 1234
)
print("Time elapsed for glm hyperTuning: ", Sys.time() - t)

sortedGrid <- h2o.getGrid("EL_grid", sort_by = "AUCPR", decreasing = TRUE)

bestModel <- h2o.getModel(sortedGrid@model_ids[[1]])

testRes <- new_resultFrame()
testRes <- add_test_results(h2o.performance(bestModel, newdata=test), testRes)
testRes <- add_cv_results(bestModel, testRes)
testRes %>% write.csv("./hypeTune_results/logistic_regression/ElasticNet_ED/test_train_results.csv")
bestModel %>% h2o.saveModel("./hypeTune_results/logistic_regression/ElasticNet_ED/")
sink("./hypeTune_results/logistic_regression/ElasticNet_ED/parameters.txt")
print(bestModel@parameters)
sink()

bestModel@model$cross_validation_metrics_summary %>% as.data.frame() %>%
write.csv("./hypeTune_results/logistic_regression/ElasticNet_ED/5fold_results.csv")

pred <- h2o.predict(bestModel, newdata = test)
df_test <- test["alc_status"] %>% as.data.frame
prob_test <- pred$p1 %>% as.data.frame()
EL_ED_ROC <- data.frame(prob = prob_test$p1, obs = df_test$alc_status)

EL_ED_ROC %>% saveRDS("./hypeTune_results/logistic_regression/ElasticNet_ED/EL_ED_ROC.rds")

################################ELASTIC NET FOR ED CIHI

hyper_params <- list(
lambda = c(1, 0.5, 0.1, 0.01, 0.001, 0.0001, 0.00001, 0),
alpha = seq(0,1,0.01)
)

hyper_params_final <- list(
lambda =  c(0.0001, 0.00001),
alpha = c(0.59,0.75,0.97, 0.25, 1) #tuned from prev files
)
search_criteria = list(
strategy = "RandomDiscrete", #random grid search
max_runtime_secs = 3600 * 1,
max_models = 200,
seed = 1234)

t <- Sys.time()
grid <- h2o.grid(
hyper_params = hyper_params_final,
search_criteria = search_criteria,
algorithm = "glm",
grid_id = "EL_grid_CIHI",
x = sel_feat,
y = "alc_status",
family = "binomial",
training_frame = train,
nfolds = 5,
fold_assignment = "Stratified",
seed = 1234
)
print("Time elapsed for glm hyperTuning: ", Sys.time() - t)

sortedGrid <- h2o.getGrid("EL_grid_CIHI", sort_by = "AUCPR", decreasing = TRUE)

bestModel <- h2o.getModel(sortedGrid@model_ids[[1]])

testRes <- add_test_results(h2o.performance(bestModel, newdata=test), testRes)
testRes <- add_cv_results(bestModel, testRes)
testRes %>% write.csv("./hypeTune_results/logistic_regression/ElasticNet_EDCIHI/test_train_results.csv")
bestModel %>% h2o.saveModel("./hypeTune_results/logistic_regression/ElasticNet_EDCIHI/")
sink("./hypeTune_results/logistic_regression/ElasticNet_EDCIHI/parameters.txt")
print(bestModel@parameters)
sink()

bestModel@model$cross_validation_metrics_summary %>% as.data.frame() %>%
write.csv("./hypeTune_results/logistic_regression/ElasticNet_EDCIHI/5fold_results.csv")

pred <- h2o.predict(bestModel, newdata = test)
df_test <- test["alc_status"] %>% as.data.frame
prob_test <- pred$p1 %>% as.data.frame()
EL_EDCIHI_ROC <- data.frame(prob = prob_test$p1, obs = df_test$alc_status)

EL_EDCIHI_ROC %>% saveRDS("./hypeTune_results/logistic_regression/ElasticNet_EDCIHI/EL_EDCIHI_ROC.rds")


rm(list=ls())
setwd("~/Dropbox/trw")
#setwd("~/trw")
source("startup.r")
source("trw_fit.r")
####################
#generate data
#
####################
set.seed(1140)

d=10
n=50
h<-huge.generator(n+1000,d=d,graph="random",prob=2/d)
h$data<-scale(h$data,center=T,scale=T)/8+0.5
#h$data<- pbeta(h$data,6,1)
#h$data<-h$data-colMeans(h$data)
#h$data<-qexp(pnorm(h$data),rate=12)
h$data[h$data>=1] = .99
h$data[h$data<=0] = .001
train<-h$data[1:n,]
test<-h$data[ (n+1):(n+100),]
#dat<-gauss.mix.sim(400,d=d)

sparsity<- h$sparsity*d*(d-1)/2

####################
#fit path for glasso
#
########################################

cc<-cov(train)
rho_start<- max( abs(cc-diag(diag(cc))) )

run_seq <- exp( seq(from=log(rho_start*.03), to =log(rho_start*1.1),length.out=50 ) )
#run_seq<- seq(from=1e-5,to=rho_start,length.out=25)
test_error<- vector(length=length(run_seq))
ind=0

glasso_out<-glassopath(s=cc,
           rholist=run_seq)$wi

glasso_out_relax<-mcmapply(FUN=function(x){
    ge<-get.edgelist(
      graph.adjacency( (glasso_out[,,x]==0),
                       mode="undirected")
    )
    if(dim(ge)[1]==0) ge<-NULL
    glasso(s=cc,
             rho=1e-5*rho_start,
             zero=ge
      )$wi
    },
    x=1:length(run_seq),
    SIMPLIFY="array"
)

test_error<-mcmapply(FUN=function(x){
  print(x)
  -mean( apply(test,1,function(xx)gaussian_lik(xx-colMeans(test),glasso_out[,,x])))
  },
  x=1:length(run_seq),
  SIMPLIFY=T,
  mc.cores=cores
)

test_error_relax<-mcmapply(FUN=function(x){
  print(x)
  -mean( apply(test,1,function(xx)gaussian_lik(xx-colMeans(test),glasso_out_relax[,,x])))
},
x=1:length(run_seq),
SIMPLIFY=T,
mc.cores=cores
)

num_nonzero<-mapply(function(x)(sum(glasso_out[,,x]!=0) -d)/2,x=1:length(run_seq))
num_nonzero_relax<-mapply(function(x)(sum(glasso_out_relax[,,x]!=0) -d)/2,x=1:length(run_seq))

#pdf("sim.pdf")
plot(num_nonzero,test_error,type="l",ylim=range(test_error,test_error_relax))
points(num_nonzero,test_error_relax,col="blue",type="l")
abline(v=sparsity,col="red")
#dev.off()

which.min(test_error_relax)
which.min(test_error)
min(test_error);min(test_error_relax)

####################
#fit path for trw
#
########################################

#edgelist<- get.edgelist( graph.full(d,directed=F) )
#g<-   erdos.renyi.game(d,2/d); #  g<- g+g
#g<-graph.empty(d)
g<-graph.full(d,directed=F)
edgelist<- get.edgelist(g)
clust<- clusters(g)$membership

edge_mean <- edge.means(train, edgelist, m, cores)
node_mean <- node.means(train , m,cores)
edge_mean_test <- edge.means(test, edgelist, m, cores)
node_mean_test <- node.means(test , m,cores)
weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])

edge_coef<- array(.1,dim=c(m,m,dim(edgelist)[1]))
node_coef<- matrix(0,d,m)

weights<- E(edge.Start(g,burn.in=10))$weight

norm<-apply(edge_mean,3,function(x)norm(x,"F"))%>%sort(decreasing=T)

fit<-parallelTrwFit(edge_coef,node_coef,edge_mean,node_mean,
               edgelist,weights,lambda=0,alpha_start=1,
               g,cores=cores)
fit$edge_quasi-edge_mean
fit$vert_quasi-node_mean

contour(fit$edge_den[,,1])
points(train[,edgelist[1,]])

lambda=.1
alpha_start=1

path<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
               edgelist,weights=NULL,alpha_start=10,
               g,cores=cores,limit=30,relax=F,edge.opt=T)
path_relax<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
               edgelist,weights=NULL,alpha_start=10,
               g,cores=cores,limit=30,relax=T,edge.opt=T)

risk_path<-lapply(path,function(x){
  -trw_lik(node_mean_test,edge_mean_test[,,x$eind,drop=F],x$vert_coef,x$edge_coef,x$part_fn)
})
risk_path_relax<-lapply(path_relax,function(x){
  -trw_lik(node_mean_test,edge_mean_test[,,x$eind,drop=F],x$vert_coef,x$edge_coef,x$part_fn)
})

risk_path<-simplify2array(risk_path)
risk_path_relax<-simplify2array(risk_path_relax)

plot(risk_path,type="l",ylim=range(risk_path,risk_path_relax,test_error_relax,test_error))
points(1:length(risk_path_relax),risk_path_relax,type="l",col="blue")
points(num_nonzero,test_error_relax,col="green",type="l")
points(num_nonzero,test_error,col="purple",type="l")
abline(v=sparsity,col="red")
legend("topright",c("trw","trw relax","glasso relax", "glasso"),col=c("red","blue","green","purple"))

par(mfcol=c(2,2))
for(i in sample(dim(path_relax[[20]]$edgelist)[1],4)){
contour(path_relax[[20]]$edge_den[,,i])
points(train[,path_relax[[20]]$edgelist[i,]])
}
########################################

summary(h$theta)
plot(train[,c(15,95)])
plot(train[,c(100,99)])
microbenchmark::microbenchmark(

path<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
         edgelist,weights,alpha_start=1,
         g,cores=cores,limit=25),
path<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
               edgelist,weights,alpha_start=1,
               g,cores=1,limit=25),
times=10

)

out<-rwrapper(
  edge_coef,
  node_coef,
  edge_mean,
  node_mean,
  edgelist,
  weights,
  legen.Vec,
  legen.array,
  lambda,
  alpha_start
)

weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])
parallelTrwFit(edge_coef,node_coef,edge_mean,node_mean,
               edgelist,weights,lambda=0,alpha_start=1,
               g,cores=1)$part_fn

lambda=.04;alpha_start=1
microbenchmark::microbenchmark(
  parallelTrwFit(edge_coef,node_coef,node_mean,edge_mean,
                 edgelist,weights,lambda=0,alpha_start=1,
                 g,cores=1),
  parallelTrwFit(edge_coef,node_coef,node_mean,edge_mean,
                 edgelist,weights,lambda=0,alpha_start=1,
                 g,cores=detectCores())
  ,times=10)

tree_obj<- edge.Start(g,burn.in=30)
parallelTrwFit(edge_coef,node_coef,edge_mean,node_mean,
               edgelist,E(tree_obj)$weight,lambda=0,alpha_start=1,
               g,cores=1)$part_fn


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.6.1
#criado:     10.07.2017
#modificado: 06.12.2019

#based on https://en.wikipedia.org/wiki/File:Local_maximum.png
f <- function(x,y){
    exp(1)^(-(x^2+y^2))+2*exp(1)^(-((x-1.5)^2+(y-1.5)^2))
}
x <- seq(-2,4,len=50)
y <- seq(-2,4,len=50)
z <- outer(x,y,f)

fnam <- "../images/concept_3.tiff"
tiff(file=fnam,units="in",width=5,height=4,res=300,compression="lzw")
par(mar=c(0.2,0.2,0.2,0.2))
persp(x,y,z,phi=20,theta=30,d=5,expand=0.5,box=FALSE)
dev.off()


#lang R
library(Rmpfr)
prec <- 1000 # precision in bits
`%:%` <- function(e1, e2) '/'(mpfr(e1, prec), mpfr(e2, prec)) # operator %:% for high precision division
# function for checking identity of tan of expression and 1, making use of high precision division operator %:%
tanident_1 <- function(x) identical(round(tan(eval(parse(text = gsub("/", "%:%", deparse(substitute(x)))))), (prec/10)), mpfr(1, prec))


library(leaps);

null <- lm(bug~1,data=data_training);

full <- lm(bug~.,data = data_training);

finalModel <- step(null,scope=list(lower=null,upper=full),direction="forward")

predictions <<- predict.lm(finalModel,data_testing);

data_testing$target <- predictions;

orderedData <- data_testing[order(-data_testing$target),];

data_testing$target <- NULL;

write.csv(orderedData,"E:\\STUDY\\THESIS\\STEP-WISE REGRESSION\\testDataOrderedByPredictions.csv",row.names=F);

cumulativeLOC <- cumsum(orderedData$loc);

cumulativeBugs <- cumsum(orderedData$bug);

totalLOC <- cumulativeLOC[NROW(cumulativeLOC)];
totalBugs <- cumulativeBugs[NROW(cumulativeBugs)];

percentLOC <- (cumulativeLOC/totalLOC)*100;
percentBugs <- (cumulativeBugs/totalBugs)*100;

lines(percentLOC,percentBugs,type="o",col="red",lwd = 0.5,pch=".",cex=0.8)


### Calculate matrix using Plucinski's Unsupervized Naive Bayes classifier

# calculate allele frequencies

# calculate likelihood of no relation and likelihood of relation

calculate_loglikelihood = function(v1,v2,p1,p2,ploid){
	# p1 is vector of allele frequencies in sample 1
	# p2 is vector of allele frequencies in sample 2
	n1 = length(p1)
	n2 = length(p2)
	loglikelihood0 = sum(log(p1))+sum(log(p2))
	loglikelihood1 = log(sum(sum(sapply(1:n1, function (i) sapply(1:n2,
				function (j) 1/n1/n2 * (v1[i] == v2[j])*exp((sum(log(p1[-i]))+sum(log(p2)))))))))
	if (length(v1) > 1 & length(v2) > 1) {
	pairs1 = combn(v1,2,simplify = FALSE)
	pairs2 = combn(v2,2,simplify = FALSE)
	npairs1 = length(pairs1)
	npairs2 = length(pairs2)

	loglikelihood2 = log(sum(sum(sapply(1:npairs1, function (i) sapply(1:npairs2,
				function (j) 1/npairs1/npairs2 * (sum(sort(pairs1[[i]]) == sort(pairs2[[j]]))==2)*
							exp((sum(log(p1[-match(pairs1[[i]],v1)]))+sum(log(p2)))))))))
	} else { loglikelihood2 = NA}
	if (ploid == 1) {
		loglikelihood2 = loglikelihood1
	}
	c(loglikelihood0,loglikelihood1,loglikelihood2)
}

##### modify epsilon value here

epsilon = 0.3072  #rate of missed alleles, estimated by Joel May 2 2019

calculate_loglikelihood2 = function(v1,v2,p1,p2,ploid){
	# p1 is vector of allele frequencies in sample 1
	# p2 is vector of allele frequencies in sample 2
	n1 = length(p1)
	n2 = length(p2)
	loglikelihood0 = sum(log(p1))+sum(log(p2))
	loglikelihood1 = log(max(sapply(1:n1, function (i) sapply(1:n2,
				function (j)  (v1[i] == v2[j])*exp((sum(log(p1[-i]))+sum(log(p2)))))),na.rm=TRUE))
	if (length(v1) > 1 & length(v2) > 1) {
	pairs1 = combn(v1,2,simplify = FALSE)
	pairs2 = combn(v2,2,simplify = FALSE)
	npairs1 = length(pairs1)
	npairs2 = length(pairs2)

	loglikelihood2 = log(max(sapply(1:npairs1, function (i) sapply(1:npairs2,
				function (j) (sum(sort(pairs1[[i]]) == sort(pairs2[[j]]))==2)*
							exp((sum(log(p1[-match(pairs1[[i]],v1)]))+sum(log(p2)))))),na.rm=TRUE))
	} else { loglikelihood2 = NA}

	if (loglikelihood1 == -Inf) {
		loglikelihood1 = log(epsilon * min(c(p1,p2)))
	}
	if (loglikelihood2 == -Inf & ploid > 1) {
		nsharedalleles = max(sapply(1:npairs1, function (i) sapply(1:npairs2,
						function (j) (length(intersect(pairs1[[i]], pairs2[[j]])))))) ## modified line - used to be:
									                               ## function (j) (sum(sort(pairs1[[i]]) == sort(pairs2[[j]]))))))
		loglikelihood2 = log((epsilon*min(c(p1,p2))) ^ (2-nsharedalleles))
	}
	if (ploid == 1) {
		loglikelihood2 = loglikelihood1
	}
	c(loglikelihood0,loglikelihood1,loglikelihood2)
}

alleles = list()
frequencies = list()

for (j in 1:nloci) {
	locicolumns = grepl(paste(locinames[j],"",sep=""),colnames(data))
	raw_alleles = c(as.matrix(data[,locicolumns]))
	raw_alleles[raw_alleles == "NA"] = NA
	raw_alleles[raw_alleles == 0] = NA
	alleles[[j]] = unique(raw_alleles[!is.na(raw_alleles)])
	frequencies[[j]] = sapply(alleles[[j]], function(x) sum(raw_alleles == x,na.rm=TRUE))
	frequencies[[j]] = frequencies[[j]] / sum(frequencies[[j]])

}

observeddatamatrix = list()
for (j in 1:nloci) {
	locus = locinames[j]
	locicolumns = grepl(paste(locus,"",sep=""),colnames(data))
	oldalleles = as.vector(data[,locicolumns])
	oldalleles [oldalleles == "NA"] = NA
	oldalleles [oldalleles == 0] = NA
	if (length(dim(oldalleles)[2]) == 0) {
		oldalleles = matrix(oldalleles,length(oldalleles),1)
	}
	observeddatamatrix[[j]] = oldalleles
}

pairwisedistance = function(isolate1,isolate2){
	print(((isolate2-1)*nids+isolate1)/ (nids*nids))
	print(isolate1)
	print(isolate2)
	loglik = matrix(NA,nloci,3)
	for (j in 1:nloci) {
		v1 = observeddatamatrix[[j]][isolate1,]
		v1 = v1[!is.na(v1)]
		p1 = frequencies[[j]][match(v1,alleles[[j]])]
		v2 = observeddatamatrix[[j]][isolate2,]
		v2 = v2[!is.na(v2)]
		p2 = frequencies[[j]][match(v2,alleles[[j]])]
		if (length(v1) > 0 & length(v2) > 0) {
			loglik[j,] = calculate_loglikelihood2(v1,v2,p1,p2,ploidy[j])
		} else { loglik[j,] = c(NA,NA,NA)}
	}
	loglik_allloci = (colSums(matrix(loglik,ncol=3),na.rm=TRUE))
	lik_allloci = exp(loglik_allloci) / sum(exp(loglik_allloci))
	sum(lik_allloci*c(0,1,2))
}

allpossiblepairs = expand.grid(1:nids,1:nids)
allpossiblepairs = unique(allpossiblepairs[allpossiblepairs[,1] <= allpossiblepairs[,2],])

# pairwisedistancevector = unlist(lapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistance(allpossiblepairs[x,1],allpossiblepairs[x,2]))) # not parallel

				  ###### MODIFY NUMBER OF CORES BELOW - mc.cores=###

pairwisedistancevector = unlist(mclapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistance(allpossiblepairs[x,1],allpossiblepairs[x,2]),mc.cores=12)) # parallel

pairwisedistancematrix = matrix(NA,nids,nids)
sapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistancematrix[allpossiblepairs[x,1],allpossiblepairs[x,2]] <<- pairwisedistancevector[x])
sapply(1:dim(allpossiblepairs)[1], function (x) pairwisedistancematrix[allpossiblepairs[x,2],allpossiblepairs[x,1]] <<- pairwisedistancevector[x])

colnames(pairwisedistancematrix) = ids
rownames(pairwisedistancematrix) = ids
###write.csv(pairwisedistancematrix,"pairwisedistancematrix_Bayesian.csv")

Bayesian_pairwisedistancematrix = pairwisedistancematrix

pairwisedistancematrix

colv_clustering = rep(rgb(0,0,0), length(ids))

print("Calculation of Bayesian matrix complete")


#' SVD
#'
#' Singular value decomposition.
#'
#' @param x
#' An fmlmat matrix.
#' @param nu,nv
#' The number of left/right singular vectors to return. NOTE: currently only
#' supports 0 or non-zero values.
#' @param LINPACK
#' Ignored.
#'
#' @name svd
#' @rdname svd
NULL

utils::globalVariables(c("n", "p"))

La_svd_fml = function(x, nu=min(n, p), nv=min(n, p))
{
  n = DATA(x)$nrows()
  p = DATA(x)$ncols()

  if (n == 0 || p == 0)
    stop("a dimension is zero")

  nu = as.integer(nu)
  if (is.na(nu) || nu < 0)
    stop("argument must be coercible to non-negative integer")

  nv = as.integer(nv)
  if (is.na(nv) || nv < 0)
    stop("argument must be coercible to non-negative integer")

  x_cp = DATA(x)$dupe()
  d = skeleton_vec(x_cp)

  if (nu == 0 && nv == 0)
    linalg_svd(x_cp, d)
  else
  {
    u = skeleton_mat(x_cp)
    vt = skeleton_mat(x_cp)
    linalg_svd(x_cp, d, u, vt)
  }

  ret = list()
  ret$d = wrapfml(d)
  if (nu)
    ret$u = wrapfml(u)
  if (nv)
    ret$vt = wrapfml(vt)

  ret
}

svd_fml = function(x, nu=min(n, p), nv=min(n, p), LINPACK=FALSE)
{
  n = DATA(x)$nrows()
  p = DATA(x)$ncols()

  ret = La_svd_fml(x, nu, nv)
  if (nv)
  {
    ret$v = wrapfml(linalg_xpose(DATA(ret$vt)))
    ret$vt = NULL
  }

  ret
}

#' @rdname svd
#' @export
setMethod("La.svd", signature(x="fmlmat"), La_svd_fml)

#' @rdname svd
#' @export
setMethod("svd", signature(x="fmlmat"), svd_fml)


# Gwen Eadie
# lab 3

library(DAAG)

####### 2.3

# check the structure of the possum data
str(possum)

# uncomment this AND dev.off() below if you want to save the plot
# pdf(file = "q2-3_eadie.pdf" )

hist(x = possum$earconch, xlab="earconch")
box()

# boxplot of female and male earconch
plot(formula = earconch ~ sex, data = possum)

# the measurement distributions differ in their median with the female earconch having a higher median than the male earconch. However, overall the ranges overlap a lot.

# I predict that the histograms look assymetric, with the females having a long tail towards lower values, and the males having a long tail towards higher values

# plot the females' earconch distribution
plot(density(possum$earconch[possum$sex=="f"]), xlab = "earconch", main="Female Earconch Distribution")

# plot the females' earconch distribution
plot(density(possum$earconch[possum$sex=="m"]), xlab = "earconch", main="Male Earconch Distribution")

# weird, they are both bimodal... maybe because of age?
plot(density(na.omit(possum$age)), main="age distribution")

# ages could be it!

# uncomment this if you want to save the plot
# dev.off()

###### 2.5

pdf(file = "q2-5_eadie.pdf")

plot(formula = cbreadth ~ clength, data=cuckoohosts, ylim=c(12, 18), xlim=c(16, 24))
points(formula= hbreadth ~ hlength, data=cuckoohosts, col="blue", pch=19)

for(i in 1:12){
  with(cuckoohosts, expr = lines(c(clength[i], hlength[i]), c(cbreadth[i], hbreadth[i])))

}

legend("topleft", legend = c("cuckoo", "host"), pch=c(1,19), col=c("black", "blue"))

dev.off()

###### 2.10

library(MASS)

with( Animals, cor(brain, body) )

with( Animals, cor(log(brain), log(body)) )

# note that the spearman rank coefficient gives the same answer whether it is logged or not, as long as the data have a monotonic function? i.e. the ranks don't change under the transformation
with( Animals, cor(log(brain), log(body), method="spearman" ))
with( Animals, cor(brain, body, method="spearman" ))

with(Animals, plot(log(brain), log(body)))

# pearson correlation coefficient is the covariance divided by variance squared

###### 2.13
str(galaxies)

plot(density(galaxies), main= "emperical density distribution of galaxies")

# or make a nicer plot from the example in ?galaxies
gal <- galaxies/1000
c(width.SJ(gal, method = "dpi"), width.SJ(gal))
plot(x = c(0, 40), y = c(0, 0.3), type = "n", bty = "l",
     xlab = "velocity of galaxy (1000km/s)", ylab = "density", main="example from galaxies help file")
rug(gal)
lines(density(gal, width = 3.25, n = 200), lty = 1)
lines(density(gal, width = 2.56, n = 200), lty = 3)

# shut off the plots
dev.off()


#!/usr/bin/env Rscript

createImage <- function(positions, i) {
		png(filename="stars.png")
		par(mar = c(0,0,1,0))
		par(pch=19)
		plot(positions, ylim = rev(range(positions[1,])), asp=1, main=i)
		dev.off()
}

positions = read.csv("pos.txt")
velocities = read.csv("vel.txt")

previousVariation <- var(positions[,1])

i <- 0
repeat {
	positions <- positions + velocities
	currentVariation <- var(positions[,1])

	if (previousVariation < currentVariation) {
		createImage(positions - velocities, i)
		break
	}
	previousVariation <- currentVariation
	i <- i + 1
}


#' Plotting a matrix of co-occurences between two metacell covers of the same dataset
#'
#' @param mc_id1 first mc object to use
#' @param mc_id2 second mc object to use
#' @param ord_1 optional ordering of first MC set (default is original order)
#' @param ord_2 optional ordering of second MC set (Default is based on max intersection with the first set)
#' @param not_log use this to avoid using log scale on the colors - making the best match MC more pronanouced
#'
#' @export
mcell_plot_cross_mc = function(mc_id1, mc_id2, ord_1=NULL, ord_2=NULL, not_log=F)
{
	mc1 = scdb_mc(mc_id1)
	mc2 = scdb_mc(mc_id2)
	if(is.null(mc1) | is.null(mc2)) {
		stop("missing metacell ids = ", mc_id1, " or ", mc_id2)
	}
	n1 = max(mc1@mc)
	n2 = max(mc2@mc)
	joint_c = intersect(names(mc1@mc), names(mc2@mc))
	i_mc1 = mc1@mc[joint_c]
	i_mc2 = mc2@mc[joint_c]
	all=union(names(i_mc1), names(i_mc2))
	i_mc1[setdiff(all,names(i_mc1))] = 0
	i_mc2[setdiff(all,names(i_mc2))] = 0
	cross = t(matrix(tabulate(i_mc1 * (n2+1) + i_mc2 + 1, nbins=(1+n1)*(1+n2)), nrow=(n2+1)))

#	hc = hclust(dist(cor(cross)), "ward.D2")
	if(is.null(ord_1)) {
		ord_1 = 1:nrow(cross)
	} else {	#adding the 0 row
		ord_1 = c(1, ord_1+1)
	}
	if(is.null(ord_2)) {
		ord_2 = order(apply(cross[ord_1,],2, which.max))
	} else { #adding the 0 column
		ord_2 = c(1, ord_2+1)
	}

	fig_nm = scfigs_fn(mc_id1, sprintf("_cross_%s", mc_id2))
	shades = colorRampPalette(c("white", "pink", "red", "black", "brown", "orange"))(1000)
	width = min(n1*50+400,3000)
	height = min(n2*50+400,3000)
	png(fig_nm, width = width, height = height)
	layout(matrix(c(1,4,2,3),nrow=2),
					widths=c(150, width-150),
					heights=c(height-100, 100))
	top_marg=c(0,8,4,0)
	par(mar=top_marg)
	image(t(as.matrix(1:(n2+1),nrow=1)), col=(c("white",mc2@colors))[ord_2], yaxt='n', xaxt='n')
	mtext((0:n2)[ord_2], at=seq(0,1,l=n2+1), las=2, side=2, cex=1.5)
	top_marg=c(0,0,4,4)
	par(mar=top_marg)
	if(not_log) {
		image(log2(1+cross)[ord_1,ord_2], col=shades, xaxt='n', yaxt='n')
	} else {
		image(log2(1+cross)[ord_1,ord_2], col=shades, xaxt='n', yaxt='n')
	}
	lower_marg=c(4,0,0,4)
	par(mar=lower_marg)
	image(as.matrix(1:(n1+1),ncol=1), col=c("white", mc1@colors)[ord_1], yaxt='n', xaxt='n')
	mtext((0:n1), at=seq(0,1,l=n1+1), las=2, side=1, cex=1.5)
	dev.off()
}


# --------------------------------------------------------------------------------------
# Programmer: Jason Thorpe
# Date        02/24/2011
# Language:   R (Version 2.6.0)
# Purpose:    This package has functions for application of the PEB algorithm
# Comments:
# --------------------------------------------------------------------------------------

#' Functions that apply the Parametric Empirical Bayes (PEB) algorithm
#'
#' Functions that apply the Parametric Empirical Bayes (PEB) algorithm.
#'
#' \code{zpeb(x,[n,ybar,]...)} returnes the z-score for a marker value after applying the PEB algorithm
#'
#' \code{ppeb(x,[n,ybar,]...)} returnes the p-values for a marker value after applying the PEB algorithm
#'
#' \code{qpeb(p,n,ybar,...,conf.level)} returnes the quantiles for a marker if the PEB is
#' to algorithm with a specificity \code{p}. In particular, if the normality
#' assumptions are satisified, the probability that a marker exceeds
#' \code{threshold = qpeb(p,n,ybar,...)} is \code{p}.
#'
#' @name peb
#' @family peb
#'
#' @param x A vector of marker values to be interpreted by the PEB.  \strong{Note}
#' If n and ybar are not specified, x is interpreted to be a series of observed
#' marker levels from a single individual
#'
#' @param n \code{n[i]} is the number of prior observations from the same
#' individual which preceed the i'th observation (\code{x[i]}).  Note that
#' n and ybar are required paremeters for qpeb and for zpeb and ppeb, must
#' both be present or both be absent.
#'
#' @param ybar \code{n[i]} is the mean of prior observations from the same
#' individual which preceed the i'th observation (\code{x[i]}).  Note that
#' n and ybar are required paremeters for qpeb and for zpeb and ppeb, must
#' both be present or both be absent.
#'
#' @param details If True, a data frame containing resutls from each
#' sub-calculation is returned,otherwise a vector with the z-scores
#' or p-values is returned. (Default = FALSE)
#'
#' @param na.rm If TRUE and the parameters \code{n} and \code{ybar} are not passed, then
#' mising values in X are ignored when calculationg n and ybar from x. \strong{Note}
#' that if \code{n} and \code{ybar} are not passed and all values following the first missing
#' value in x will also be missing.
#'
#' @param conf.level (optional) confidence level for the False Positve Rate (FPR)
#' for the thresholds provided \code{qpeb()}. If conf.level is specified, \code{length(p)}
#' must be 1 and the PEB parameters must be specified by the object returned by
#' \code{PEBparams()} using the \code{'Iterative'} method, as in:
#'
#' \code{params = PEBparams(x,id,method='Iterative',iterations=2);
#' qpeb(p,params,conf.level=0.95)}
#'
#' @inheritParams pebVarArgs
#'
#' @note Note that each function requires just 2 of the 4 parameters v,sigma2,tau2, and beta (=beta1)
#' \strong{Note} also that mu,sigma2,tau2,v, and beta may be substitured by a the object returned by \code{\link{PEBparams}}
#'
#' @examples
#'
#' n = 10
#' m = 200
#' params <- PEBparams(x = rnorm(m*n) + rep(rnorm(m),each=n), id=gl(m,n,m*n))
#' x <- rnorm(10) + 6
#' plot(seq(length(x)),ppeb(x,params))
#'
#' # interesting facts about the PEB...
#' b1 = .7
#'
#' # this should be uniformly distributed by definition
#' hist(ppeb(rnorm(5000)*sqrt(1-b1),mu=0,v=1,beta=b1))
#'
#' # this should be positive on the outset.
#' hist(ppeb(rnorm(5)*sqrt(1-b1) + 3,mu=0,v=1,beta=b1)) # 10/sqrt(1-b1) standard deviations above normal!!
#'
#' # but even this should be uniformly distributed in the long run
#' hist(ppeb(rnorm(5000)*sqrt(1-b1) + 10,mu=0,v=1,beta=b1)) # 10/sqrt(1-b1) standard deviations above normal!!
#'

NULL

#' @export
#' @rdname peb
#' @usage zpeb(x, ..., [n, ybar,] na.rm = FALSE, details = FALSE)
zpeb<- function(x,...,n,ybar,na.rm=FALSE,details=FALSE) {
	if(missing(n) != missing(ybar))
		stop("parameters 'n' and 'ybar' must be either both present or both absent")

	if(missing(n)){
		if(na.rm){
			x.na <- is.na(x)
			ybar <- n <- rep(NA,length(x))
			if(any(!x.na)){
				# personal means
				ybar[!x.na] <- ybarCalc(x[!x.na])
				# number of prior results
				n[!x.na] <- nCalc(x[!x.na])
			}
		}else{
			# personal means
			ybar <- ybarCalc(x)
			# number of prior results
			n <- nCalc(x)
		}
	}

	# DO THE WORK
	out <- with(pebVarArgs(...),{
			bn <- bn(n)
			vn_hat <- sigma2 + (tau2*(1-bn))
			sdn_hat <- sqrt(vn_hat)
			yn_hat <- mu*(1-bn) + ybar*bn
			z <- (x - yn_hat)/sdn_hat
			data.frame(x=x,
				  n=n,
				  ybar=ybar,
				  bn=bn,
				  z=z,
				  mu_n=yn_hat,
				  sd_n=sdn_hat,
				  z=z)
			})
	if(details)
		return(cbind(out
					,p=pnorm(out[,'z'])
					))
	else
		return(out$z)
}

#' @export
#' @usage ppeb(x, ..., [n, ybar,] na.rm = FALSE, details = FALSE)
#' @rdname peb
ppeb<-function(...,details=FALSE)  {
	# determine the probability of a sereies of marker values
	if(details)
		return(zpeb(...,details = T))
	else
		return(pnorm(zpeb(...,details = F)))
}

#-- "
#--
#-- source('r:/Urban_N/UrbanGrp/Data Analysis/JThorpe/RTools/PEB/R/peb-parameters.r')
#-- source('r:/Urban_N/UrbanGrp/Data Analysis/JThorpe/RTools/PEB/R/peb-utils.r')
#-- source('r:/Urban_N/UrbanGrp/Data Analysis/JThorpe/RTools/PEB/R/peb-functions.r')
#--
#-- params_iter <-  PEBparams(x,id,method='iterative',iterations=2)
#-- params_icc  <-  PEBparams(x,id,method='ICC')
#-- params
#--
#-- pebVarArgs(params_iter)
#-- pebVarArgs(params_icc )
#--
#-- qpeb(p=0.95, params, n=3, ybar=.5,conf.level=0.95)
#--
#-- "

#' @export
#' @usage qpeb(p, ..., n, ybar, verbose = FALSE)
#' @rdname peb
#' @importFrom CompQuadForm davies
qpeb<-function(p,...,n,ybar,conf.level,conf.method='davies', verbose = FALSE)  {

	pebArgs  <-  pebVarArgs(...)
	with(pebArgs,{
				bn_fun <<- bn(n)
				bn <- bn(n)
				bn <<- bn
				s2 <<- sigma2
				t2 <<- tau2
				v_n <<- sigma2 + (tau2*(1-bn))
				sd_n <<- sqrt(sigma2 + (tau2*(1-bn)))
				mu_n <<- mu*(1-bn) + ybar*bn
				})
	if(length(p) == 1){
		threshold  <-  qnorm(p,mean = mu_n,sd=sd_n)
		if(missing(conf.level))
			return(threshold)
		params  <-  list(...)[[1]]
		if((!inherits(params,'PEBparams')) || (params$method != 'iterative'))
			stop("If 'conf.level' specified, qpeb must be supplied with a iteragive PEB params object.  (See notes in help file)")

		UN <-  unique(n)
		conf = PEB.conf.int(p,UN,conf.level,params)
		indx  <- match(n,UN)
 		return(cbind(quantile=threshold,
					  p.lower.CI = conf[,'p.lower.CI'][indx],
					  p.upper.CI = conf[,'p.upper.CI'][indx]))
	}

	if(!missing(conf.level))
		stop("'conf.level' not supported when length(p) > 1")

	out <- matrix(NA,length(n),length(p))
	for(i in 1:length(p))
		out[,i] <- qnorm(p[i],mean = mu_n,sd=sd_n)
	dimnames(out) <- list(if(!is.null(names(n)))names(N) else seq(length(n)),
						  paste('p =',p))
	return(out)
}

# just a couple of utility functions so that the 'if(mising(n))){...}' block in zpeb() is not to ugly
ybarCalc <- function(x)
	return(if(length(x) > 1)
				c(0,cumsum(x[-length(x)])/seq(length(x)-1))
			else 0
			)

nCalc <- function(x)
	return(if(length(x) > 1)
				c(0,seq(length(x)-1))
			else 0
			)

#' Confidence intervals for personalized PEB thresholds
#'
#' Confidence intervals for personalized PEB thresholds.
#'
#' @export
#' @family peb
#'
#' @param p probability (specificity)
#'
#' @param n Number of previous observations in the individual's history. If \code{length(n) == 1}, n is expanded to \code{seq(0,n)}.
#'
#' @param conf.level Confidence level of the interval.
#'
#' @param params A PEBparams object returned by \code{PEBparams(...,method='iterative')}
#'
#' @examples
#' PEB.conf.int(p=0.95, n=6, conf.level=0.9, params=params)

PEB.conf.int  <-  function(p,n,conf.level,params){
	if((!inherits(params,'PEBparams')) || (params$method != 'iterative'))
		stop("If 'conf.level' specified, qpeb must be supplied with a iteragive PEB params object.  (See notes in help file)")

	if(length(n) == 1)
		n  <-  seq(0,n)

	with(pebVarArgs(params),
	{
		bn <<- bn <- bn(n)
		sd_n <<- sqrt(sigma2 + (tau2*(1-bn)))
	})

	threshold  <-  qnorm(p,sd=sd_n)
	p.lower.CI <-
	p.upper.CI <- numeric(0)

	with(params,
	{
		alpha <- 1 - conf.level
		cint <- c(alpha/2,1-alpha/2)

		FUN <- function(x,bn,prob){
			CompQuadForm::davies(x,
				   lambda=c(s2/(N-m),t2*(1-bn)/nstar),
				   h = c(N-m  ,nstar),# degrees of freedom

				   # sigma2 *DOES NOT* ACCOUNT FOR THE STANDARD ERROR IN THE ESTIMATE
				   # OF THE INDIVIDUALS ESTIMATED MEAN WITH N PRIOR OBSERVATIONS
				   # B/C THE PEB THRESHOLD IS SET AS THE SUM OF THE MEAN + THE SQRT
				   # OF THE WEIGHTED AVERAGE OF TWO CHI-SQUARED VARIALBLES (S2 AND T2)
				   # WHEREAS, THIS sigma2 PARAMETER IS IS ADDED TO THE WEIGHTED AVERAGE
				   # *WITHIN* THE SQUARE ROOT...
				   # sigma=(1-bn)*mu.se + bn*(sqrt(s2)/n),

				   lim=10000,
				   acc=0.0001)$Qq-prob
		}

		for(i in 1:length(bn)){
			(INT <- (t2*(1-bn[i])*qchisq(p=cint,df = nstar)/(nstar)) +
					(s2*qchisq(p=cint,df = N-m  )/(N-m  )))
			sd.upper.ci <<- sqrt(uniroot(FUN,
										 interval = INT,
										 bn=bn[i],
										 prob=1-alpha/2)$root)
			sd.lower.ci <<- sqrt(uniroot(FUN,
										 interval = INT,
										 bn=bn[i],
										 prob=alpha/2)$root)
			p.lower.CI[i] <<- pnorm(threshold[i], sd=sd.lower.ci)
			p.upper.CI[i] <<- pnorm(threshold[i], sd=sd.upper.ci)
		}
	})
	return(cbind(n,
				 p.lower.CI = p.lower.CI,
				 p.upper.CI = p.upper.CI))
}


envelop <- function(x, np=3) {
  for (k in 1:np) {
#
# Fill minima
#
    dm1 = x[1]
    dz = x[2]
    for (j in 2:(length(x)-1)) {
      dp1 = x[j+1]
      if (dm1 > dz & dp1 > dz)
        x[j] <- 0.5 * (dm1 + dp1)
      dm1 = dz
      dz = dp1
    }
#
# Smooth non-maxima
#
    dm1 = x[1]
    dz = x[2]
    for (j in 2:(length(x)-1)) {
      dp1 = x[j+1]
      if (dm1 >= dz || dp1 >= dz)
        x[j] <- 0.25*dm1 + 0.5*dz + 0.25*dp1
      dm1 = dz
      dz = dp1
    }
  }
  x
}

polevne <- function(x, np=3) {
  for (k in 1:np) {
    #
    # Degrade maxima
    #
    dm1 = x[1]
    dz = x[2]
    for (j in 2:(length(x)-1)) {
      dp1 = x[j+1]
      if (dm1 < dz & dp1 < dz)
        x[j] <- 0.5 * (dm1 + dp1)
      dm1 = dz
      dz = dp1
    }
    #
    # Smooth non-maxima
    #
    dm1 = x[1]
    dz = x[2]
    for (j in 2:(length(x)-1)) {
      dp1 = x[j+1]
      if (dm1 >= dz || dp1 >= dz)
        x[j] <- 0.25*dm1 + 0.5*dz + 0.25*dp1
      dm1 = dz
      dz = dp1
    }
  }
  x
}


###############################
###  2010, David Ellinghaus ###
###############################

rm(list=ls())

file.lmiss = commandArgs()[4]
fraction_miss.thresh = as.numeric(commandArgs()[5])

lmiss = read.table(file.lmiss, as.is=T, header=T)
lmiss.log10F_MISS = log10(lmiss$F_MISS)

png(file=paste(file.lmiss, ".logscale.2.png", sep=""), width=960, height=960)

hist(lmiss.log10F_MISS, xlim=c(-4,0), main="All SNPs", xlab="SNP missingness", ylab="Number of SNPs", col="grey", border="black", axes=F)
axis(1, at=c(-4,-3,-2,log10(fraction_miss.thresh),-1,0), labels=c(0.0001,0.001,0.01,fraction_miss.thresh,0.1,1))
axis(2, at=seq(0,2000000,20000), tick=T)
abline(v=log10(fraction_miss.thresh), col="red", lty=2)

dev.off()


 DBDSDC Example Program Results

 Singular values of B:
         4.0001        3.0006        1.9960        0.9998


library(tidyverse)

# Add Data
county.gdp <- readr::read_csv("bea_county_gdp.csv", quote="\'", col_names=T)

# Calculate per capita measures
county.gdp$pc.gdp.2012 <- county.gdp$allindustries_2012/county.gdp$pop_2012
county.gdp$pc.gdp.2013 <- county.gdp$allindustries_2013/county.gdp$pop_2013
county.gdp$pc.gdp.2014 <- county.gdp$allindustries_2014/county.gdp$pop_2014
county.gdp$pc.gdp.2015 <- county.gdp$allindustries_2015/county.gdp$pop_2015

# Create full names for future labels
county.gdp$full_name <- ifelse(county.gdp$state_name=="AK",
  str_c(county.gdp$county_name,", ", county.gdp$state_name),
  ifelse(county.gdp$state_name=="LA",
    str_c(county.gdp$county_name, " Parish",", ", county.gdp$state_name) ,str_c(county.gdp$county_name, " County",", ", county.gdp$state_name)))

county.gdp$int <- paste(county.gdp$specialize,county.gdp$metro, sep=".")
# Scatter Plot
p.2015 <- ggplot(county.gdp) +
  aes(x = log(pop_2015), y = log(pc.gdp.2015)) +
  geom_point(alpha = 0.5, size = 1, color = "#E69F00") +
  geom_text(aes(label=ifelse(log(pc.gdp.2015)>5.75,as.character(full_name),'')), hjust=0, vjust=0, nudge_x = 0.05, nudge_y = 0.05, size = 3, family="Open Sans Condensed Light") +
  geom_text(aes(label=ifelse(log(pc.gdp.2015)<2,as.character(full_name),'')), hjust=0, vjust=0, nudge_x = 0.05, nudge_y = 0.05, size = 3, family="Open Sans Condensed Light") +
  geom_smooth(method = "lm", se = FALSE, size=0.5, color="#2b2b2b", alpha=0.5) +
  # Theming
  labs(
    title="County-level Gross Domestic Product",
    subtitle="Log per capita GDP & log population, All U.S. counties, 2015",
    caption="Author: Chris Goodman (@cbgoodman), Data: U.S. Bureau of Economic Analysis (experimental) & U.S. Census Bureau",
    y="Log of Per Capita GDP",
    x="Log of Population") +
  theme_minimal(base_family="Open Sans Condensed Light") +
  theme(
    legend.position = "bottom",
    legend.title.align = 0.5,
    legend.text.align = 0) +
  # light, dotted major y-grid lines only
  theme(panel.grid=element_line())+
  theme(panel.grid.major.y=element_line(color="#2b2b2b", linetype="dotted", size=0.15))+
  theme(panel.grid.major.x=element_blank())+
  theme(panel.grid.minor.x=element_blank())+
  theme(panel.grid.minor.y=element_blank())+
  # light x-axis line only
  theme(axis.line=element_line())+
  theme(axis.line.y=element_blank())+
  theme(axis.line.x=element_blank())+
  # tick styling
  theme(axis.ticks=element_line())+
  theme(axis.ticks.x=element_blank())+
  theme(axis.ticks.y=element_blank())+
  theme(axis.ticks.length=unit(5, "pt"))+
  # x-axis labels
  theme(axis.text.x=element_text(size=10, hjust=0.95,vjust=0.2))+
  # breathing room for the plot
  theme(plot.margin=unit(rep(0.5, 4), "cm"))+
  # move the y-axis tick labels over a bit
  theme(axis.text.y=element_text(margin=margin(r=-5)))+
  theme(axis.text.x=element_text(margin=margin(r=-5)))+
  # make the plot title bold and modify the bottom margin a bit
  theme(plot.title=element_text(family="Open Sans Condensed Bold", margin=margin(b=15)))+
  # make the subtitle italic
  theme(plot.subtitle=element_text(family="Open Sans Condensed Light Italic"))+
  theme(plot.caption=element_text(size=8, hjust=0, margin=margin(t=15)))
ggsave(plot=p.2015, "gdp-2015.png", width=10, height=7, units="in", dpi="retina")

summary(lm(data=county.gdp, log(pc.gdp.2015)~log(pop_2015)))


## 12장. interactive graph
#### 12-1 plotly 패키지로 인터랙티브 그래프 만들기####

## ------------- 인터랙티브 그래프 만들기 ----------------- ##
install.packages('htmlwidgets')
install.packages("plotly")
library(plotly)

library(ggplot2)
p <- ggplot(data = mpg, aes(x = displ, y = hwy, col = drv)) +
  geom_point()

ggplotly(p)

# clarity : http://dsmarket.tistory.com/155
p <- ggplot(data = diamonds, aes(x = cut, fill = clarity)) +
  geom_bar(position = "dodge")

ggplotly(p)

library(htmlwidgets)

saveWidget(ggplotly(p), file = "plotly.html")

#### 12-2 dygraphs 패키지로 인터랙티브 시계열 그래프 만들기 ####

## ---------- 인터랙티브 시계열 그래프 만들기 ------------- ##
install.packages("dygraphs")
library(dygraphs)

economics <- ggplot2::economics
head(economics)

# - ggplot을 이용하여 date를 x축으로 unemploy y축으로 시계열
# - 그래프를 그래보세요.

library(xts)
eco <- xts(economics$unemploy, order.by = economics$date)
head(eco)
class(eco)
str(eco)

# 그래프 생성
dygraph(eco)

# 날짜 범위 선택 기능
dygraph(eco) %>% dyRangeSelector()

# 저축률 : personal saving rate
eco_a <- xts(economics$psavert, order.by = economics$date)

# 실업자 수
eco_b <- xts(economics$unemploy/1000, order.by = economics$date)

eco2 <- cbind(eco_a, eco_b)                 # 데이터 결합
colnames(eco2) <- c("psavert", "unemploy")  # 변수명 바꾸기
head(eco2)

dygraph(eco2) %>% dyRangeSelector()


# Goal: R syntax where model specification is an argument to a function.

# Invent a dataset
x <- runif(100); y <- runif(100); z <- 2 + 3*x + 4*y + rnorm(100)
D <- data.frame(x=x, y=y, z=z)

amodel <- function(modelstring) {
  summary(lm(modelstring, D))
}

amodel(z ~ x)
amodel(z ~ y)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/o10.r


sd.raster <- function(ldata,pmean=TRUE) {
    llayers=nlayers(ldata)
    ones=rep(1,llayers)
    lmean=stackApply(ldata,ones,'mean',na.rm=TRUE)
    ldelt=ldata-lmean

    ldelt=ldelt*ldelt

    lvarn=stackApply(ldelt,ones,'sum',na.rm=TRUE)/llayers

    lvarn=sqrt(lvarn)
    if (pmean) lvarn=lvarn/abs(lmean)
    return(lvarn)

}


#Fit dirlichet models to functional groups of fungi from Tedersoo et al. Temperate Latitude Fungi.
#rarefying to different depths to understand how this affects prediction.
#request at least 18 processors for parallel run.
#clear environment
rm(list = ls())
library(data.table)
library(doParallel)
source('paths.r')
source('NEFI_functions/ddirch_site.level_JAGS.r')

#detect and register cores.----
n.cores <- detectCores()
n.cores <- 18
registerDoParallel(cores=n.cores)

#set output path.----
output.path <- ted_fg_ddirch_fit_seqdepth.path

#load tedersoo data.----
d <- data.table(readRDS(tedersoo_ITS_clean_map.path))
#d <- d[1:35,] #for testing
y <- readRDS(tedersoo_ITS_fg_list.path)
y <- y$abundances
d <- d[,.(SRR.id,pC,cn,pH,moisture,NPP,map,mat,forest,conifer,relEM)]
d <- d[complete.cases(d),] #optional. This works with missing data.
y <- y[rownames(y) %in% d$SRR.id,]

#rarefy species table to multiple depths.
y.frame <- list()
seq.depth <- c(100,200,300,500,1000,2000)
for(i in 1:length(seq.depth)){
  r.y <- vegan::rrarefy(y, seq.depth[i]) + 1 #dd 1, dirichlet cannot handle zeros.
  r.y <- r.y / rowSums(r.y)
  y.frame[[i]] <- as.data.frame(r.y)
}
names(y.frame) <- paste0('d_',seq.depth)

#Drop in intercept, setup predictor matrix.----
#IMPORTANT: LOG TRANSFORM MAP.
d$intercept <- rep(1,nrow(d))
d$map <- log(d$map)
x <- d[,.(intercept,pC,cn,pH,NPP,mat,map,forest,conifer,relEM)]

#fit model using function.----
#This take a long time to run, probably because there is so much going on.
#fit <- site.level_dirlichet_jags(y=y.frame[[1]],x_mu=x,adapt = 50, burnin = 50, sample = 100)
#for running production fit on remote.
output.list<-
  foreach(i = 1:length(y.frame)) %dopar% {
    fit <- site.level_dirlichet_jags(y=y.frame[[i]],x_mu=x,adapt = 200, burnin = 1000, sample = 1000, parallel = F)
    return(fit)
  }

#name the items in the list, save output.----
names(output.list) <- paste0('d_',seq.depth)

cat('Saving fit...\n')
saveRDS(output.list, output.path)
cat('Script complete. \n')


#------------------------------------------------------------------------------------------------------------------------------------------
getEstimatedTPR_FPR <- function(dts, alg, k){
  rownames(dts) <- 1:length(dts$class)

  if(length(which(table(dts$class) < 10))>0) k <- min(table(dts$class))

  folds <- createFolds(dts$class, k=k)
  vfpr <- NULL
  vtpr <- NULL

  for(i in 1:k){

    classifier <- construcClassifiers(dts[-folds[[i]],], alg)

    re <- applyModel(classifier, dts[folds[[i]],])

    cm <- confusionMatrix(as.factor(re), as.factor(dts$class[folds[[i]]]))

    fpr <- 1-cm[[4]][[2]]
    tpr <- cm[[4]][[1]]

    vfpr <- c(vfpr, fpr)
    vtpr <- c(vtpr, tpr)

  }
  TprFpr <- data.frame(tpr=mean(vtpr), fpr= mean(vfpr))
  #print(TprFpr)
  return(TprFpr)
}


EstimateModel <- function(dat, formula, var = NULL) {
  # This function extracts the important parameters from the model(s).
  # If var is given, it means that there is the need to make the model run on
  # the same variable grouped by different rows.
  #
  # ARGS
  # - dat      [data table] is the data we are giving to the model
  # - formula  [character]  the formula binding the variables in the model
  # - var      [character]  is the column name of the variable we want to put
  #                         in the model to group by
  #
  # RETURN
  # - mod      [list]       a list containing the model parameters

  if (!is.null(var)) {
    mod <- dlply(dat, var, function(dt)
      lm(eval(as.formula(formula)), data = dt))

  } else {
    mod <- lm(eval(as.formula(formula)), data = dat)
  }

  return(mod)
}


input <- read.csv("input.csv")
# Part 1
for (x in input$entry){
  for(y in input$entry) {
    if(sum(x,y) == 2020) {
      print(x*y)
    }
  }
}

# Part 2
for (x in input$entry){
  for(y in input$entry) {
    for(z in input$entry)
    if(sum(x,y,z) == 2020) {
      print(x*y*z)
    }
  }
}


### fimd8.R
### R code from Van Buuren, S. (2012).
###		Flexible Imputation of Missing Data.
###		CRC/Chapman & Hall, Boca Raton, FL.
### (c) 2012 Stef van Buuren, www.multiple-imputation.com
### Version 1, 22mar2012
### Version 2, 4nov2015 tested with mice 2.23
### Tested with Mac OS X 10.7.3, R2.14-2, mice 2.12

if (packageVersion("mice")<'2.12') stop("This code requires mice 2.12.")

library("mice")
library("lattice")

### Section 8.1 Correcting for selective drop-out

data <- pops
pred <- pops.pred
if (!is.data.frame(data)) stop("The code for section 8.1 requires access to the POPS data.")

### Section 8.1.4 A degenerate solution (TIME CONSUMING (30 MINUTES))

imp1 <- mice(data, pred=pred, maxit=20, seed=51121)

### Figure 8.2

tp82 <- plot(imp1, c("a10u","a10b","adhd"),col=mdc(5),lty=1:5)
print(tp82)

### Section 8.1.5 A better solution

##  TIME CONSUMING (30 MINUTES)
pred2 <- pred
pred2[61:86,61:86] <- 0
imp2 <- mice(data, pred=pred2, maxit=20, seed=51121)

### Figure 8.3

tp83 <- bwplot(imp2, iq+e_tot+l19_sd+b19_sd+coping+seffz~.imp,
        layout=c(2,3))
print(tp83)

### Section 8.1.6 Results

### Full responders
summary(lm(as.numeric(a10u)~1,data,na.action=na.omit))
summary(lm(as.numeric(a10b)~1,data,na.action=na.omit))
summary(lm(as.numeric(adhd)~1,data,na.action=na.omit))

### All children
summary(pool(with(imp2,lm(as.numeric(a10u)~1))))
summary(pool(with(imp2,lm(as.numeric(a10b)~1))))
summary(pool(with(imp2,lm(as.numeric(adhd)~1))))

### Section 8.2 Correcting for nonresponse

library("mice")
data <- fdgs

### Section 8.2.4 Augmenting the sample

nimp <- c(400, 600, 75, 300, 200, 400)
regcat <- c("North","City","North","East","North","City")
reg <- rep(regcat, nimp)

nimp2 <- floor(rep(nimp, each=2)/2)
nimp2[5:6] <- c(38,37)
sex <- rep(rep(c("boy","girl"),6), nimp2)

minage <- rep(c(0, 0, 10, 10, 14, 14), nimp)
maxage <- rep(c(10, 10, 14, 14, 21, 21), nimp)
set.seed(42444)
age <- runif(length(minage), minage, maxage)

id <- 600001:601975

pad <- data.frame(id, reg, age, sex, hgt=NA, wgt=NA, hgt.z=NA, wgt.z=NA)
data2 <- rbind(data, pad)

### Figure 8.4

## inspect the age by region pattern
means <- aggregate(data$hgt.z, by=list(reg=data$reg,
             age=floor(data$age)), mean, na.rm=TRUE)
tp84 <- xyplot(x~age, means, group=reg, type=c("g","l"),
             lty=1:5,col=mdc(4),
             xlim=c(-1,22), ylim=c(-0.6, 0.8),
             ylab="Height (SDS)", xlab="Age (years)",
             key=list(
               text=list(levels(means$reg)),
               lines=list(lty=1:5, col=mdc(4)),
               x=0.1, y=0.98, background="white",
               columns=3, between.columns=0),
             scales=list(x=list(tck=c(1,0)),
               y=list(tck=c(1,0))))
print(tp84)

### Section 8.2.5 Imputation model

## add interaction terms
na.opt <- options(na.action=na.pass)
int <- model.matrix(~I(age-10)*hgt.z+I(age-10)*wgt.z+age*reg, data=data2)[,-(1:9)]
options(na.opt)
data3 <- cbind(data2, int)

### define the imputation model

ini <- mice(data3, maxit=0)

meth <- ini$meth
meth["hgt"] <- ""
meth["wgt"] <- ""
meth["hgt.z"] <- "norm"
meth["wgt.z"] <- "norm"
meth["I(age - 10):hgt.z"] <- "~I(I(age-10)*hgt.z)"
meth["I(age - 10):wgt.z"] <- "~I(I(age-10)*wgt.z)"

pred <- ini$pred
pred[,c("hgt","wgt")] <- 0
pred["hgt.z", c("id","I(age - 10):hgt.z")] <- 0
pred["wgt.z", c("id","I(age - 10):wgt.z")] <- 0

vis <- ini$vis[c(3,5,4,6)]

### run the imputation model

imp <- mice(data3, meth=meth, pred=pred, vis=vis, m=10, maxit=20, seed=28107)

### Figure 8.5

cda <- complete(imp, "long", include=TRUE)
means2 <- aggregate(cda$hgt.z, by=list(reg=cda$reg, age=floor(cda$age), imp=cda$.imp), mean, na.rm=TRUE)
tp85 <- xyplot(x~age|reg,means2, group=imp, subset=(reg=="North"|reg=="City"),
              type=c("g","l"),lwd=c(4,rep(1,imp$m)),
              lty=1:5,col=c(mdc(4),rep(mdc(6),imp$m)),
              ylab="Height (SDS)", xlab="Age (years)",
              ylim=c(-0.5,0.8), xlim=c(-2,23),
              scales=list(x=list(alternating=FALSE, tck=c(1,0)),
                y=list(tck=c(1,0))),
                strip = strip.custom(bg="grey95"))
print(tp85)


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

suppressMessages(library(caret))

crossValidateOLS <- function(data,func,kfolds=10)
{
	flds <- createFolds(data$agb,k=kfolds,list=FALSE)
	lar <- list()
	results <- matrix(nrow=kfolds,ncol=2)
	for(i in 1:kfolds)
	{
		training <- data[flds != i,]
		test <- data[flds == i,]
		v <- matrix(nrow=nrow(test),ncol=1)
		model <- fitOLS(training,func)
		yhats <- yhatOLSArithmetic(test,model,corrected=TRUE)
		accuracy_ratio <- yhats / test$agb
		log_accuracy_ratio <- log(accuracy_ratio)
		median_symmetric_accuracy <- 100*(exp(median(abs(log_accuracy_ratio)))-1)
		symmetric_signed_percentage_bias <- 100*sign(median(log_accuracy_ratio))*(exp(abs(median(log_accuracy_ratio)))-1)
		#
		lar[[i]] <- log_accuracy_ratio
		results[i,1] <- median_symmetric_accuracy
		results[i,2] <- symmetric_signed_percentage_bias
	}
	return(list(lar,results))
}


library(huge)
library(clime)
library(glasso)
library(Rcpp)
library(clime)
library(parallel)
library(mclust)
setwd("~")
source("~/Forest Density/treeLoader.R");
loadTree()
set.seed(1434)
########################

n<-100
ntest<-200
dlist<- c(30,50,100,120) #,120,150)
#dlist=30
reps=5

out_len=10
m1=m2=2
#err=syst=sparsity=array(0,dim=c(len,3,length(dlist),reps))
source("~/trw/startup.r")

err<-array(0,dim=c(6,length(dlist),reps))
roc<-array(0,dim=c(5,length(dlist),reps,2))
diter=0
for(d in dlist){
	limit=floor(2*d)
	diter=diter+1
	h<-huge.generator(reps*(n+ntest),d=d,graph="random",prob=2/d)
	h$data<-scale(h$data,center=T,scale=T)/8+0.5
	h$data[h$data>=1] = .99
	h$data[h$data<=0] = .001
	sig<- diag(1/8,d)%*%h$sigma%*%diag(1/8,d)
	entropy<- (d/2)*(1+log(2*pi))+(1/2)*log(det(sig))
	for(r in 1:reps){
		dnum=0
		print(paste("dim : ",d))
		train<-h$data[((r-1)*n+1):(r*n),]
		test<-h$data[(reps*n+((r-1)*ntest+1)) : (reps*n+(r*ntest)),]
		rho_start<- max( abs(cov(train)-diag(diag(cov(train)))) )
		sequ <- exp( seq(from=log(rho_start*.2), to =log(rho_start*1.1),length.out=50 ) )
		#sequ<-log(rev(seq(from=exp(.01),to=exp(0.3),length.out=len))) *(1/20)
		gl<-glassopath(cov(train),sequ)
		glasso_out_relax<-mcmapply(FUN=function(x){
		ge<-get.edgelist(
			graph.adjacency( (gl$wi[,,x]==0),
				mode="undirected")
			)
			if(dim(ge)[1]==0) ge<-NULL
			glasso(s=cov(train),
			rho=1e-4,
			zero=ge,
			penalize.diagonal=F
		)$wi
		},
		x=1:length(sequ),
		SIMPLIFY="array"
		)

		gl_seq<-apply(gl$wi,3,
			function(x){.5*sum(diag(x%*%cov(test)))-.5*log(det(x))+(d/2)*log(2*pi)}
		)
		gl_seq_relax<-apply(glasso_out_relax,3,
			function(x){.5*sum(diag(x%*%cov(test)))-.5*log(det(x))+(d/2)*log(2*pi)}
		)
		err[1,diter,r]<-min(gl_seq)
		err[2,diter,r]<-min(gl_seq_relax)
		ind= row(h$theta)<=(col(h$theta)-1)
		spar=h$sparsity*d*(d-1)/2
		#glroc<-which.min(apply(gl$wi,3,function(x) sum( (h$theta[ind]!=0) & (x[ind]==0) )+sum( (x[ind]!=0) & (h$theta[ind]==0))))
 		glroc<-which.min(abs(apply(gl$wi,3,function(x)sum(x[ind]!=0))-spar))
		roc[1,diter,r,1]<-1-sum( (h$theta[ind]!=0) & (gl$wi[,,glroc][ind]==0) ) /spar
		roc[1,diter,r,2]<- 1-sum( (gl$wi[,,glroc][ind]!=0) & (h$theta[ind]==0) ) /(d*(d-1)/2-spar)
		#roc[2,diter,r,1]<-1-sum( (h$theta[ind]!=0) & (glasso_out_relax[,,glrocrelax)][ind]==0) )/spar
		#roc[2,diter,r,2]<- 1- sum( (glasso_out_relax[,,glrocrelax][ind]!=0) & (h$theta[ind]==0) )/(d*(d-1)/2-spar)

		g<-graph.full(d,directed=F)
		edgelist<- get.edgelist(g)
		clust<- clusters(g)$membership
		edge_mean <- edge.means(train, edgelist, m2, cores)
		node_mean <- node.means(train , m1,cores)
		edge_mean_test <- edge.means(test, edgelist, m2, cores)
		node_mean_test <- node.means(test , m1,cores)
		#weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])
		edge_coef<- array(0,dim=c(m2,m2,dim(edgelist)[1]))
		node_coef<- matrix(0,d,m2)

		lambda=0
		alpha_start=1
		cores=detectCores()
		path<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
		edgelist,weights=NULL,alpha_start=alpha_start,
			g,cores=cores,limit=limit,relax=F,edge.opt=T,out_len=out_len)
		path_relax<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
		edgelist,weights=NULL,alpha_start=alpha_start,
			g,cores=cores,limit=limit,relax=T,edge.opt=T,out_len=out_len)

		risk_path<-lapply(path,function(x){
		-trw_lik(node_mean_test,edge_mean_test[,,x$eind,drop=F],x$vert_coef,x$edge_coef,x$part_fn)
		})
		risk_path_relax<-lapply(path_relax,function(x){
		-trw_lik(node_mean_test,edge_mean_test[,,x$eind,drop=F],x$vert_coef,x$edge_coef,x$part_fn)
		})
		err[3,diter,r]<-min(unlist(risk_path))
		err[4,diter,r]<-min(unlist(risk_path_relax))
		#trwroc<-which.min(lapply(path,function(x) sum( (h$theta[ind]!=0) & (x$tree_obj[]==0)[ind] )+sum( (x$tree_obj[]!=0)[ind] & (h$theta[ind]==0))))
 		trwroc<-which.min(abs(unlist(lapply(path,function(x)sum( (x$tree_obj[]!=0)[ind] ) -spar))))
		#gr_relax=graph.edgelist(path_relax[[which.min(risk_path_relax)]]$edgelist,directed=F)
		roc[3,diter,r,1]<-1-sum( (h$theta[ind]!=0) & (path[[trwroc]]$tree_obj[]==0)[ind] )/spar
		roc[3,diter,r,2]<-  1-sum( (path[[trwroc]]$tree_obj[]!=0)[ind] & (h$theta[ind]==0) )/(d*(d-1)/2-spar)
		#roc[4,diter,r,1]<-1-.5*sum( (h$theta!=0) & (gr_relax[]==0) )/spar
		#roc[4,diter,r,2]<- 1- .5*sum( (gr_relax[]!=0) & (h$theta==0) )/(d*(d-1)/2-spar)

		graphs = forestDensityEst(train, 5*d)
		likehd_out = computeLogLikehd(train, test, list(graphs));
		err[5,diter,r]<- -likehd_out$likehd_ls
		roc[5,diter,r,1]<-1-sum( (h$theta[ind]!=0) & (graphs[][ind]==0) ) /spar
		roc[5,diter,r,2]<- 1-sum( (graphs[][ind]!=0) & (h$theta[ind]==0) ) /(d*(d-1)/2-spar)
		mcl<-densityMclust(train)
		err[6,diter,r]<-mixlik(test,mcl$parameters)
		save(err,roc,file="~/trw/Experiments/rep_gaussian.rdata")

	}
}

save.image("~/trw/Experiments/rep_gaussian.rdata")


#!/usr/bin/Rscript

# to customize: input data
inputdir <- c(
              "foxe1_20130217/foxe1_fourth_run_multiplier_8",
              "foxe1_20130217/foxe1_fourth_run_multiplier_6",
              "foxe1_20130217/foxe1_fourth_run_multiplier_10",
              "foxe1_20130218/foxe1_fourth_run_multiplier_8",
              "foxe1_20130218/foxe1_fourth_run_multiplier_6",
              "foxe1_20130218/foxe1_fourth_run_multiplier_10"
              )

for(datadir in inputdir){
  mydata <- read.csv(paste(datadir, "/data/final_result.csv", sep=""), sep=",", head=TRUE)
  #experiment_indices=34

  #print(mydata)
  mydata["p_value_secure"] <- NA
  mydata$p_value_secure <- 2 * pnorm(-abs(mydata[, 1]))

  mydata["p_value_plain"] <- NA
  mydata$p_value_plain <- 2 * pnorm(-abs(mydata[, 2]))

  write.table(mydata, file=paste(datadir, "/data/p_value.csv", sep=""), sep=",", quote=F, row.names=F, col.names=T)
}


library(Hmisc)

#Load Data
loan_dat <- read.csv(file="E:/I/datascience/module3/datascience/R/QRS_02_SEP_2018/loan_data_new.csv",header=True)
attach(loan_dat)
summary(loan_dat)

loan_dat_status <- subset(loan_dat,select=c("status","loan_amount",
                          "annual_income", "purpose", "home_ownership"))
summary(loan_dat_status)
attach(loan_dat_status)

describe(loan_dat_status)

#Get charged off stats
loan_dat_status_charged <- subset(loan_dat_status, status=="Charged Off")

#loan_dat_status_charged = filter(loan_dat_status,status=="Charged Off")

summary(loan_dat_status_charged)
describe(loan_dat_status_charged)
##This will get stats for loan amount
var(loan_dat_status_charged$loan_amount)
sd(loan_dat_status_charged$loan_amount)
quantile(loan_dat_status_charged$loan_amount, c(0.05,0.25,0.5,0.75,0.95))

##This will get stats for Anual income
var(loan_dat_status_charged$annual_income)
sd(loan_dat_status_charged$annual_income)
quantile(loan_dat_status_charged$annual_income, c(0.05,0.25,0.5,0.75,0.95))

boxplot(loan_dat_status_charged$loan_amount, main="Box plot for ")

#Get Default stats
loan_dat_status_default <- subset(loan_dat_status, status=="Default")
summary(loan_dat_status_default)
describe(loan_dat_status_default)
var(loan_dat_status_default$loan_amount)
sd(loan_dat_status_default$loan_amount)
quantile(loan_dat_status_default$loan_amount, c(0.05,0.25,0.5,0.75,0.95))
##This will get stats for Anual income
var(loan_dat_status_default$annual_income)
sd(loan_dat_status_default$annual_income)
quantile(loan_dat_status_default$annual_income, c(0.05,0.25,0.5,0.75,0.95))

#Get Default stats
loan_dat_status_paid <- subset(loan_dat_status, status=="Fully Paid")
summary(loan_dat_status_paid)
describe(loan_dat_status_paid)
var(loan_dat_status_paid$loan_amount)
sd(loan_dat_status_paid$loan_amount)
quantile(loan_dat_status_paid$loan_amount, c(0.05,0.25,0.5,0.75,0.95))
##This will get stats for Anual income
var(loan_dat_status_paid$annual_income)
sd(loan_dat_status_paid$annual_income)
quantile(loan_dat_status_paid$annual_income, c(0.05,0.25,0.5,0.75,0.95))

##boxplot
boxplot(loan_dat_status_charged$loan_amount,loan_dat_status_default$loan_amount,loan_dat_status_paid$loan_amount,
	main="Loan Amount distribution
	     as per Status
	Charged Off , default and paid")

##boxplot
boxplot(loan_dat_status_charged$loan_amount,loan_dat_status_charged$annual_income,
	main="Loan Amount distribution
	     as per Status
	Charged Off , default and paid")

boxplot(loan_dat_status_charged$annual_income,loan_dat_status_default$annual_income,loan_dat_status_paid$annual_income,
	main="Annual income
	     as per Status
	Charged Off , default and paid")


require(rms)
#
# Time to progression/death for patients with monoclonal gammopathy
# Competing risk curves (cumulative incidence)
# status variable must be a factor with first level denoting right censoring
m <- upData(mgus1, stop = stop / 365.25, units=c(stop='years'),
            labels=c(stop='Follow-up Time'), subset=start == 0)
f <- npsurv(Surv(stop, event) ~ sex, data=m)
levels(m$event)
f$n.risk
## Compute long-hand for checking
times <- f$time
sex <- c(rep('female', f$strata['sex=female']),
         rep('male',   f$strata['sex=male']))
n <- length(times)
nrisk <- numeric(n)
fu <- m$stop
for(i in 1 : n) nrisk[i] <- sum(fu >= times[i] - 1e-7 & m$sex == sex[i])
w <- data.frame(sex, times, nrisk, f$n.risk)
w
## xless(w)

times <- seq(0, 36, by=4)
g <- summary(f, times=times, print.it=FALSE)
## unclass(g)
sex <- as.character(g$strata)
n <- length(times)
nrisk <- matrix(0, nrow=length(times), ncol=2)
colnames(nrisk) <- c('female', 'male')
for(sx in c('female', 'male'))
  for(i in 1 : n) nrisk[i, sx] <- sum(fu >= times[i] - 1e-7 & m$sex == sx)
nrisk

par(mar=c(8, 4, 1, 1))
survplot(f, state='pcm', n.risk=TRUE, xlim=c(0, 20), ylim=c(0, .5), col=1:2,
         y.n.risk=-.15)

survplotp(f, state='pcm', xlim=c(0, 20), ylim=c(0, .5))

survplot(f, state='death', add=TRUE, col=3)

f <- npsurv(Surv(stop, event) ~ sex, data=m)
survplot(f, state='death', n.risk=TRUE, conf='diffbands')


# Import dataset

dataframe = read.csv('BikeData.csv')

# Get all the daily cyclists
daily_cyclists = subset(dataframe, cyc_freq == 'Daily')

# Count the number of daily cyclists
nrow(daily_cyclists)
# 47

# Count the number of male and female daily cyclists
table(daily_cyclists$gender)
# M: 38
# F: 9

# Mean age of daily cyclists
colMeans(daily_cyclists['age'])
# Age: 33.65

# Mean age of daily female cyclists
colMeans(subset(daily_cyclists, gender == 'F')['age'])

# Mean age of daily male cyclists
colMeans(subset(daily_cyclists, gender == 'M')['age'])


 ZHESVX Example Program Results

 Solution(s)
                    1                 2
 1  ( 2.0000, 1.0000) (-8.0000, 6.0000)
 2  ( 3.0000,-2.0000) ( 7.0000,-2.0000)
 3  (-1.0000, 2.0000) (-1.0000, 5.0000)
 4  ( 1.0000,-1.0000) ( 3.0000,-4.0000)

 Backward errors (machine-dependent)
       7.9E-17    8.2E-17

 Estimated forward error bounds (machine-dependent)
       2.5E-15    3.2E-15

 Estimate of reciprocal condition number
       1.5E-01


H02BBJ Example Program Results

 *** IP solver

 Parameters
 ----------

 Linear constraints......         3        First integer solution..       OFF
 Variables...............         2        Max depth of the tree...         4

 Feasibility tolerance...  1.05E-08        Print level.............        10
 Infinite bound size.....  1.00E+20        EPS (machine precision).  1.11E-16

 Integer feasibility tol.  1.00E-05        Iteration limit.........        50
 Max number of nodes.....      NONE

 ** Workspace provided with MAXDPT =     4: LRWORK =    84  LIWORK =   137
 ** Workspace required with MAXDPT =     4: LRWORK =    84  LIWORK =   137

   *** Optimum LP solution ***   -17.50000

 Varbl State     Value     Lower Bound   Upper Bound    Lagr Mult   Residual

 V  1    FR    3.92857       0.00000         None        0.000       3.929
 V  2    FR    1.42857       0.00000         None        0.000       1.429

 L Con State     Value     Lower Bound   Upper Bound    Lagr Mult   Residual

 L  1    UL    15.0000         None        15.0000      -1.000       0.000
 L  2    UL    5.00000         None        5.00000     -0.5000     -8.8818E-16
 L  3    FR    14.6429       5.00000         None        0.000       9.643

   *** Start of tree search ***

  Node  Parent   Obj       Varbl  Value      Lower      Upper      Value   Depth
   No    Node   Value      Chosen Before     Bound      Bound      After
    2     1   No Feas Soln    1    3.93       4.00       None       4.00       1
    3     1    -16.2          1    3.93       0.00       3.00       3.00       1
    4     3    -15.5          2    1.80       2.00       None       2.00       2
    5     3    -13.0          2    1.80       0.00       1.00       1.00       2
      *** Integer solution ***

  Node  Parent   Obj       Varbl  Value      Lower      Upper      Value   Depth
   No    Node   Value      Chosen Before     Bound      Bound      After
    6     4   No Feas Soln    1    2.50       3.00       3.00       3.00       3
    7     4    -14.8          1    2.50       0.00       2.00       2.00       3
    8     7    -12.0     CO   2    2.20       3.00       None       3.00       4
    9     7    -14.0          2    2.20       2.00       2.00       2.00       4
      *** Integer solution ***

     *** End of tree search ***

 Total of     9 nodes investigated.

 Exit IP solver - Optimum IP solution found.

 Final IP objective value =   -14.00000

 Varbl State     Value     Lower Bound   Upper Bound    Lagr Mult   Residual

 V  1    UL    2.00000       0.00000       2.00000      -3.000       0.000
 V  2    EQ    2.00000       2.00000       2.00000      -4.000       0.000

 L Con State     Value     Lower Bound   Upper Bound    Lagr Mult   Residual

 L  1    FR    14.0000         None        15.0000       0.000       1.000
 L  2    FR    0.00000         None        5.00000       0.000       5.000
 L  3    FR    10.0000       5.00000         None        0.000       5.000


source("emma.r")

xy <- read.csv("xy.csv")
K <- read.csv("k.csv",header=FALSE)

stopifnot(ncol(xy) > 1)
stopifnot(diff(dim(K)) == 0)
stopifnot(nrow(xy) == nrow(K))

n <- nrow(xy)
m <- ncol(xy) - 1

X <- as.matrix(xy[-ncol(xy)])
X[X==0] <- -1
X <- cbind(intercept=1, X)
y <- as.matrix(xy[ncol(xy)])
K <- as.matrix(K)

eq <- paste(colnames(X), collapse=' + ')
eq <- paste("0 + ", eq, sep="")
eq <- paste(colnames(y), eq, sep=" ~ ")

cat("***************\n")
cat("* Linear Model\n")
cat("***************\n")
d <- as.data.frame(cbind(X,y))
fit <- lm(as.formula(eq), data=d)
print(summary(fit))
print(anova(fit))

cat("\n\n")

cat("*********************\n")
cat("* Linear Mixed Model\n")
cat("*********************\n")

reml <- emma.REMLE(y,X,K)
V <- reml$vg * K + reml$ve * diag(n)

W <- V / reml$ve
W <- backsolve(chol(W), diag(n))
W <- t(W)
X1 <- W %*% X
y1 <- W %*% y

d <- as.data.frame(cbind(X1,y1))
fit <- lm(as.formula(eq), data=d)
print(summary(fit))
print(anova(fit))


library(insee)
library(tidyverse)
library(scales)
library(readr)
library(janitor)
library(ggplot2)
library(plotly)
library(lubridate)
library(patchwork)
library(slider)

bdf <- read_delim(file="http://webstat.banque-france.fr/fr/downloadFile.do?id=5385691&exportType=csv", delim=";") |>
  clean_names() |>
  slice(-1:-5) |>
  rename(time = titre) |>
  mutate(across(.cols = -time, ~as.numeric(str_replace(.x, ",",".")))) |>
  mutate(time=dmy(time),
         timem = floor_date(time, unit="month")) |>
  group_by(timem) |>
  summarise(r10ans = mean(emprunt_phare_10_ans , na.rm=TRUE)) |>
  mutate(y = year(timem),
         m = month(timem)) |>
  select(-timem)

frigit <- c("20.0%", "10.2%", "9.5%", "9.8%", "9.2%", "8.8%", "7.9%", "6.5%", "6.1%", "6.5%", "6.4%", "6.4%", "6.3%", "7.5%", "8.2%", "8.3%", "8.9%", "8.1%", "7.3%", "7.5%", "6.8%", "6.0%", "5.7%", "5.9%", "5.1%", "5.1%", "4.6%", "4.3%", "4.3%", "3.8%", "4.1%", "5.1%", "4.5%", "4.0%", "4.0%", "3.8%", "3.8%", "3.8%", "3.8%", "3.8%", "3.8%", "3.9%", "3.8%", "3.8%", "3.7%", "3.6%", "3.7%", "4.0%", "6.6%", "5.7%", "5.4%", "5.4%", "4.1%", "3.9%", "4.4%", "4.6%", "4.4%", "4.5%", "4.3%", "4.5%", "4.4%", "4.5%", "4.4%", "4.5%", "4.6%", "4.5%", "4.5%", "4.4%", "4.4%", "4.3%", "4.8%", "5.7%", "5.6%", "5.4%", "5.0%", "4.7%", "4.5%", "4.3%", "4.1%", "3.8%", "3.6%", "3.6%", "3.7%", "3.9%", "3.9%", "3.8%", "3.7%", "3.8%", "3.7%", "3.6%", "3.3%", "3.2%", "3.1%", "3.1%", "3.0%", "3.0%", "3.0%", "2.9%", "3.0%", "3.0%", "3.0%", "3.0%", "3.0%", "3.1%", "3.1%", "3.1%", "3.1%", "3.2%", "3.2%", "3.1%", "3.1%", "3.2%", "3.3%", "3.5%", "3.7%", "4.4%", "4.9%", "5.0%", "5.1%", "5.2%", "5.9%", "6.7%", "6.4%", "6.3%", "6.7%", "7.6%", "8.9%", "7.4%", "6.0%", "5.4%", "4.7%", "4.7%", "5.2%", "5.8%", "6.1%", "5.7%", "6.3%", "6.7%", "6.9%", "5.7%", "5.9%", "4.5%", "3.8%", "3.8%", "3.8%", "3.6%", "4.4%", "5.0%", "5.9%", "6.8%", "7.0%", "7.0%", "6.7%", "6.4%", "6.4%", "6.0%", "6.3%", "6.5%", "6.7%", "5.9%", "5.8%", "5.6%", "5.7%", "5.3%", "5.5%", "6.2%", "6.6%", "6.8%", "7.2%", "8.3%", "8.8%", "8.5%", "8.1%", "8.9%", "10.9%", "10.5%", "10.4%", "11.0%", "10.7%", "10.6%", "13.9%", "16.4%", "16.6%", "14.6%", "13.3%", "11.7%", "8.8%", "9.6%", "9.1%", "8.8%", "9.9%", "9.0%", "8.6%", "6.9%", "7.4%", "7.6%", "6.4%", "5.6%", "4.7%", "4.7%", "5.5%", "5.0%", "4.9%", "4.2%", "4.2%", "3.5%", "3.9%", "4.4%", "4.3%", "3.7%", "3.2%", "3.4%", "2.6%", "2.3%", "1.7%", "0.9%", "0.5%", "0.8%", "0.8%", "0.2%", "-0.1%")
frigit <-  tibble( y=1800:2020, r_frig = frigit |> str_remove("%") |> as.numeric())

taux <- left_join(left_join(expand.grid(y=1800:2021, m=1:12), frigit, by='y'), bdf, by=c("y","m")) |>
  arrange(y,m) |>
  mutate(time = ym(str_c(y," ",m)))

taux.a <- taux |>
  group_by(y) |>
  summarize(r_frig=mean(r_frig, na.rm=TRUE),
            r10ans=mean(r10ans, na.rm=TRUE)) |>
  mutate(r = if_else(is.na(r10ans), r_frig, r10ans),
         year = y)
# ggplotly(ggplot(taux |> filter(y>1949))+geom_line(aes(x=time, y=r10ans))+geom_line(data=~.x |> filter(y<1987),aes(x=time, y=r_frig)) + theme_minimal())

datas <- get_dataset_list() %>% as_tibble()
apu <- get_idbank_list("CNA-2014-CSI")
pib <- get_idbank_list("CNA-2014-PIB") |>
  filter(INDICATEUR=="CNA_PIB", PRIX_REF =="VAL") |>
  pull(idbank) |>
  get_insee_idbank() |>
  mutate(year = TIME_PERIOD,
         pib = OBS_VALUE) |>
  select(year, pib) |>
  arrange(year) |>
  mutate(g = pib/lag(pib)-1,
         g_bck = (lag(pib)/lag(pib, 6))^(1/5)-1,
         g_fwd = head(slide_dbl(c(pib, last(pib)*(1.03)^(1:9)), ~(last(.x)/first(.x))^(1/length(.x))-1, .after=9), -9))

interets <- apu |>
  filter(OPERATION %in%c("D41", "B9NF"), SECT_INST == "S13") |>
  pull(idbank) |>
  get_insee_idbank() |>
  mutate(year = TIME_PERIOD) |>
  left_join(pib, by="year") |>
  mutate(interets = OBS_VALUE/pib,
         year = TIME_PERIOD) |>
  select(year, interets, pib, g, g_bck, g_fwd, IDBANK) |>
  mutate(type = case_when(
    IDBANK=="010563497" ~ "verses",
    IDBANK=="010563498" ~ "recus",
    IDBANK=="010563277" ~ "cf"),
    year = as.numeric(year)) |>
  select(-IDBANK) |>
  pivot_wider(names_from = type, values_from = interets) |>
  mutate(defp = -cf - verses,
         time = lubridate::ym(str_c(year, " 01")))

ids <- get_idbank_list("CNA-2014-DETTE-APU") |>
  filter(SECT_INST == "S13", PRIX_REF =="PCT_PIB") |>
  pull(idbank, name=INDICATEUR)

dette <- 	ids |>
  get_insee_idbank() |>
  mutate(IDBANK = names(ids)[map_int(IDBANK, ~which(.x==ids))]) |>
  select(year = TIME_PERIOD,
         dette = OBS_VALUE,
         var = IDBANK) |>
  mutate(var = str_remove(var, "CNA_FINANCES_")) |>
  pivot_wider(names_from = var, values_from = dette) |>
  rename(dette = DETTE, dette_nette = DETTENETTE, deficit = DEFICIT) |>
  left_join(pib, by="year") |>
  mutate(dstar = g_bck/(1+g_bck)*dette/100,
         year = as.numeric(year),
         time = lubridate::ym(str_c(year, " 01")))

# dette historique de la France, source FMI (https://www.imf.org/external/pubs/ft/wp/2010/wp10245.pdf & https://data.imf.org/?sk=806ED027-520D-497F-9052-63EC199F5E63)
HPDD <- read_csv("HPDD_04-26-2020 18-59-27-12.csv") |>
  janitor::clean_names() |>
  rename(year=time_period, dette_IMF=value, country = country_name) |>
  filter(country=="France") |>
  full_join(dette, by="year") |>
  full_join(interets |> select(cf, verses, recus, defp, year), by="year") |>
  arrange(year) |>
  left_join(taux.a, by="year") |>
  mutate(rapp2=verses*100/dette_IMF,
         rapp1=verses*100/dette,
         time = ym(str_c(year," 01")),
         ec_app = if_else(year<1978, rapp2-g_fwd, rapp1-g_fwd),
         ec_app_p = if_else(ec_app>=0, ec_app, NA_real_),
         ec_app_m  = if_else(ec_app<0, ec_app, NA_real_),
         ec = r/100-g_fwd,
         ec_p = if_else(ec>=0, ec, NA_real_),
         ec_m  = if_else(ec<0, ec, NA_real_))

taux <- left_join(taux, interets |> select(-time), by=c("y"="year"))

gdette <- ggplot(HPDD |> filter(year>=1949))+
  geom_step(data=~filter(.x,year<1978),aes(x=time, y=dette_IMF), color="dodgerblue4", direction="mid")+
  geom_step(aes(x=time, y=dette), col="dodgerblue1", direction="mid")+
  ylim(c(0,120))+
  geom_segment(aes(y=0, yend=0, x=ym("1949 01"), xend=ym("1977 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=1, x=ym("1949 01"), xend=ym("1949 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=1, x=ym("1977 01"), xend=ym("1977 01")), size=0.1, col="grey25")+
  annotate(geom="text", y=1, x=ym("1949 2"), label = "IMF historical public debt database", hjust=0, vjust = 0, size=1.5)+
  geom_segment(aes(y=0, yend=0, x=ym("1978 01"), xend=ym("2020 06")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=1, x=ym("1978 01"), xend=ym("1978 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=1, x=ym("2020 06"), xend=ym("2020 06")), size=0.1, col="grey25")+
  annotate(geom="text", y=1, x=ym("1978 2"), label = "CN 2020 INSEE", hjust=0, vjust = 0, size=1.5)+
  scale_x_date(breaks = ym(str_c(c(1949, seq(1960, 2010, 10), 2020), " 01")), date_labels = "%Y", limits=c(ym("1949 01"), ym("2021 12")))+
  labs(title="Dette publique en % du PIB")

gtaux <- ggplot(taux |> filter(y>=1949))+
  geom_step(data=~filter(.x, y>= 1987), aes(x=time, y=r10ans), col="dodgerblue1", direction="mid")+
  geom_step(data=~filter(.x, y<1987),aes(x=time, y=r_frig), col="dodgerblue4", direction="mid")+
  geom_segment(aes(y=0, yend=0, x=ym("1949 01"), xend=ym("1987 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=0.1, x=ym("1949 01"), xend=ym("1949 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=0.1, x=ym("1987 01"), xend=ym("1987 01")), size=0.1, col="grey25")+
  annotate(geom="text", y=0.1, x=ym("1949 2"), label = "CN 2020 INSEE et CGEDD J.Friggit", hjust=0, vjust = 0, size=1.5)+
  geom_segment(aes(y=0, yend=0, x=ym("1987 01"), xend=ym("2021 11")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=.1, x=ym("1987 01"), xend=ym("1987 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=.1, x=ym("2021 11"), xend=ym("2021 11")), size=0.1, col="grey25")+
  annotate(geom="text", y=0.1, x=ym("1988 2"), label = "CN 2020 INSEE", hjust=0, vjust = 0, size=1.5)+
  scale_x_date(breaks = ym(str_c(c(1949, seq(1960, 2010, 10), 2021), " 01")), date_labels = "%Y", limits=c(ym("1949 01"), ym("2021 12")))+
  labs(title="Taux souverain (10 ans, en %/an)")

gcharge <- ggplot(interets)+
  geom_step(aes(x=time, y=100*verses), col="dodgerblue1", direction="mid")+
  geom_segment(aes(y=0, yend=0, x=ym("1949 01"), xend=ym("2020 06")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=0.05, x=ym("1949 01"), xend=ym("1949 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=0.05, x=ym("2020 06"), xend=ym("2020 06")), size=0.1, col="grey25")+
  annotate(geom="text", y=0.05, x=ym("1949 2"), label = "CN 2020 INSEE", hjust=0, vjust = 0, size=1.5)+
  scale_x_date(breaks = ym(str_c(c(1949, seq(1960, 2010, 10), 2020), " 01")), date_labels = "%Y", limits=c(ym("1949 01"), ym("2021 12")))+
  ylim(c(0,4))+
  labs(title="Charge d'intérêts en % du PIB")

(gecartc <- ggplot(HPDD |> filter(year>=1949))+
  geom_step(data=~filter(.x,year<1987),aes(x=time, y=100*ec), color="dodgerblue4", direction="mid")+
  geom_step(data=~filter(.x,year>=1987),aes(x=time, y=100*ec), color="dodgerblue1", direction="mid")+
  geom_col(aes(x=time, y=100*ec_p), fill="red", alpha=0.1, col=NA, width=years(1)/days(1),)+
  geom_col(aes(x=time, y=100*ec_m), fill="green", alpha=0.1, width=years(1)/days(1), col=NA)+
  geom_segment(aes(y=0, yend=0, x=ym("1949 01"), xend=ym("1986 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=0.1, x=ym("1949 01"), xend=ym("1949 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=0.1, x=ym("1986 01"), xend=ym("1986 01")), size=0.1, col="grey25")+
  annotate(geom="text", y=0.1, x=ym("1949 2"), label = "CN 2020 INSEE/CGEDD", hjust=0, vjust = 0, size=1.5)+
  geom_segment(aes(y=0, yend=0, x=ym("1987 01"), xend=ym("2020 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=.1, x=ym("1987 01"), xend=ym("1987 01")), size=0.1, col="grey25")+
  geom_segment(aes(y=0, yend=.1, x=ym("2020 01"), xend=ym("2020 01")), size=0.1, col="grey25")+
  annotate(geom="text", y=-0.1, x=ym("1988 2"), label = "CN 2020 INSEE", hjust=0, vjust = 1, size=1.5)+
  scale_x_date(breaks = ym(str_c(c(1949, seq(1960, 2010, 10), 2020), " 01")), date_labels = "%Y", limits=c(ym("1949 01"), ym("2021 12")))+
  labs(title="r - g (en %/an)"))

g_altereco <- (gdette + gtaux)/(gecartc+gcharge) +
  plot_annotation(caption="Sources: INSEE, Banque de France, FMI, J. Friggit/CGEDD \n code: github.com/OFCE/AE_11-21") &
  ylab("") &
  xlab("") &
  theme_minimal(base_family = "sans") &
  theme(plot.title = element_text(size=10, face = "plain", hjust = 0.5),
        plot.caption = element_text(size=7, face = "plain", hjust = 0),
        axis.text =  element_text(size=6),
        panel.grid.major = element_line(color="grey90", size=0.25),
        panel.grid.minor = element_line(color="grey90", size=0.25))
ggsave(plot=g_altereco, filename="altereco.svg", width = 180, height = 180, units = "mm")


for (i in 1:12) {
  for (j in 1:12) {
    cat(format(i*j, width=4))
  }
  cat('\n')
}


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), function(s) {
  a <- s[1:(length(s)/2)]
  b <- s[(length(s)/2+2):(length(s)+1)]
  paste(sapply(a, as.integer) * sapply(b, as.integer), collapse=" ")
}), sep="\n")


                   FUNCTION:NAME
                          :BEGIN sizeof(int8_t) = 1
sizeof(int16_t) = 2
sizeof(int32_t) = 4
sizeof(int64_t) = 8
sizeof(intptr_t) = 8
sizeof(uint8_t) = 1
sizeof(uint16_t) = 2
sizeof(uint32_t) = 4
sizeof(uint64_t) = 8
sizeof(uintptr_t) = 8

-- @@stderr --
dtrace: script 'test/unittest/types/tst.inttypes.d' matched 1 probe


library(DESeq2)

dds <- makeExampleDESeqDataSet(betaSD=1,interceptMean=10)
dds$batch <- factor(rep(c("A","B"),each=6))

vsd <- vst(dds)
plotPCA(vsd, "batch")

assay(vsd) <- limma::removeBatchEffect(assay(vsd), vsd$batch)
plotPCA(vsd, "batch")


rmnl <- function(Data,Z,R=1000,keep=1,ss.b=.4){

  ## load libraries
  library(bayesm)

################################################################################

  ## internal functions

  rmultiregG = function (Y, X, Bbar, A, nu, V) {
    n = nrow(Y)
    m = ncol(Y)
    k = ncol(X)
    RA = chol(A)
    W = rbind(X, RA)
    Z = rbind(Y, RA %*% Bbar)
    IR = backsolve(chol(crossprod(W)), diag(k))
    Btilde = crossprod(t(IR)) %*% crossprod(W, Z)
    S = crossprod(Z - W %*% Btilde)
    rwout = rwishart(nu + n, chol2inv(chol(V + S)))
    B = Btilde + IR %*% matrix(rnorm(m * k), ncol = m) %*% t(rwout$CI)
    return(list(B = B, Sigma = rwout$IW))
  }
################################################################################

  ## Unpack Data
  X = Data[[1]]$X[,,1] # Design differes for most respondents respondents: array(K,A,J)
  Y = Data[[1]]$Y  # J*K matrix of ranked respones

################################################################################

  ## define constants
  J = length(Y) #number of choice taskts
  K1 = nrow(X) #number of alternatives per choice set
  A = ncol(X) #total number of attributes
  N = length(Data) #number of respondents
  Sig1 = IMat1 = diag(K1)
  sigi1=chol2inv(chol(Sig1))

  #ss.b = .07
  ssB = double(N)
  ssB = ssB + ss.b

################################################################################

  ## allocate storage space
  betadraw = array(double((R/keep)*N*A),dim=c(R/keep,A,N))
  bbardraw = matrix(double((R/keep)*A),ncol=A)
  vbetakeep = matrix(double(A*A*R/keep),ncol=A*A)
  nacceptB = matrix(double(N),ncol=1)
  lltemp = matrix(double(N),ncol=1)
  llkeep = matrix(double(N*R/keep),ncol=N)

################################################################################
  ## Starting values for beta

  ## Uniform [-.01,.01]
  betaM = betaMnew = matrix(runif(N*A,-.01,.01),ncol=A)

  ## Initialize variables
  beta = c(double(A))
  bbar = c(double(A))
  ztemp = c(1:K1)
  LB = -50
  UB = 50
  iota = matrix(1,ncol=1,nrow=N)

  ## Prior values
  bbar.p = c(double(A)) + 2
  nu = A+3
  A.b = 0.01
  V.b = Sig.b = diag(A)*nu #*.1 pp 74 in text
  rooti.b = backsolve(chol(V.b*5),diag(A))

  ## mcmc variables starting values
  llold.b = 0
  pold.b = lndMvn(beta,bbar,rooti.b)

################################################################################

  ## Estimation Algorithm

  cat(" ", fill = TRUE)
  cat("Starting Estimation Routine for Hierarchical MNL:", fill = TRUE)
  itime = proc.time()[3]
  cat("MCMC Iteration (est time to end - min) ", fill = TRUE)
  flush.console()
  for(rep in 1:R){

  ## Unit Loop
    for(nhh in 1:N){

################################################################################

      ## unpack data for household nhh
      X1.nhh = Data[[nhh]]$X
      Y1 = Data[[nhh]]$Y
      betaold = betaM[nhh,]

      llold = lltemp[nhh,]
      ss.b = ssB[nhh]

################################################################################
      ## Step 1. Draw beta|else - via M-H (evaluate likelihood using GHK)

      if(rep==1){
      ## Compute current value of likelihood & prior
      llold = 0

      ## Compute for first set of choices (4 alt)
      for(ntask in 1:J){
        Y = Data[[nhh]]$Y[ntask]
        X = X1.nhh[,,ntask]
        mu = X%*%betaold
        ltemp = exp(mu)/sum(exp(mu))
        llold = llold + log(ltemp[Y])
      }

      }

      pold.b = lndMvn(betaold,as.vector(bbar),rooti.b)

      ## draw betanew
      betanew = betaold + rnorm(length(betaold),0,ss.b)

      ## Compute likelihood & prior for new values of beta
      llnew = 0
      for(ntask in 1:J){
        Y = Data[[nhh]]$Y[ntask]
        X = X1.nhh[,,ntask]
        mu = X%*%betanew
        ltemp = exp(mu)/sum(exp(mu))
        llnew = llnew + log(ltemp[Y])
      }

      pnew.b = lndMvn(betanew,as.vector(bbar),rooti.b)

      ## metropolis step
      ldiff = llnew + pnew.b - llold - pold.b

      alpha = min(1,exp(ldiff))
      if (alpha<1) {unif=runif(1)} else {unif=0}

      ## update variables and save draws if accepted
      if (unif <= alpha)
      {
        llold = llnew
        betaold = betanew
        nacceptB[nhh,] = nacceptB[nhh,] + 1 } else { }

      betaM[nhh,] = betaold
      betaMnew[nhh,] = betanew

      lltemp[nhh,] = llold

      } ## end unit loop

################################################################################
      ## Step 4. Draw hierarchical priors
      if(N>1){

      ## Distribution of heterogeneity for beta
      rmout = rmultiregG(betaM,iota,bbar.p,A.b,nu,V.b)
      bbar = rmout$B
      Sig.b = rmout$Sigma
      rooti.b = backsolve(chol(rmout$Sigma),diag(A))

      } ## End N>1 condition

################################################################################
  ## Print Time & Parameter Estimates
  if (rep%%100 == 0) {
    ctime = proc.time()[3]
    timetoend = ((ctime-itime)/rep) * (R-rep)
    cat(" ", rep, " ", round(timetoend/60,1), " ", round(bbar,2),
        " ", round(mean(nacceptB/10),2)," ",
        sum(lltemp), " ", fill = TRUE)
    flush.console()
  }

################################################################################
  ## Save Draws
  if (rep%%keep == 0){
    betadraw[rep/keep,,] = t(betaM)
    bbardraw[rep/keep,] = bbar
    vbetakeep[rep/keep,] = as.vector(rmout$Sigma)
    llkeep[rep/keep,] = as.vector(lltemp)
  }

  ## Dynamically update step size

  if(rep%%10 == 0){
    if(rep<R/2){
      for(ii in 1:N){
        if(nacceptB[ii]/10 < .2) ssB[ii] = ssB[ii]*.9
        if(nacceptB[ii]/10 > .4) ssB[ii] = ssB[ii]*1.1
      }
    }
    nacceptB = nacceptB*0
  }

  } ## end MCMC

  return(list(betadraw=betadraw, bbardraw=bbardraw, vbetadraw=vbetakeep,
              llkeep = llkeep))
}


# function for sampling waits and total travel times from uniform random arrivals
# within a time period
add_waits <- function(trips,sample_times){
	# select the next time from a vector
	next_time <- function(etime,etimes){
		later = etimes[etimes >= etime]
		next_time = if( length(later) > 0 ) min(later) else NA
		return(next_time)
	}
	# get sample time points based on distinct days in the trips data
	sample = sample_times[sample_times$service_id %in% unique(trips$service_id), 'etime' ]
	# get arrival time for each sample point
	o_etime = sapply(sample, next_time, etimes=trips$o_etime)
	# bind them together in a table
	results = data.frame(cbind(sample,o_etime))
	# calculate wait times
	results$wait = (results$o_etime-results$sample) / 60
	# join to trips
	x = merge( x=results, y=trips, by='o_etime', type='left', all.x=T )
	# get the total travel time with wait included
	x$total = x$wait + x$travel_time
	# trim implausible outliers
	x = x[x$wait<30,]
	return(x)
}


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 12, 2016
# ref: http://harding.edu/fmccown/r/
# clear; Rscript dotChart.r ; rm *~

# inputs: data/autos.dat
# outputs: figures/dotChart.eps

# set the working directory
setwd("~/Copy/Programming/R/rprograms/plotting/2dplots/")

# Start device driver to save output to figure.pdf
#postscript(file="figures/dotChart.eps", height=10.5, width=5)

# Read values from tab-delimited autos.dat
autos_data <- read.table("data/autos.dat", header=T, sep="\t")

# Create a colored dotchart for autos with smaller labels
dotchart(t(autos_data),
         color=c("red","blue","darkgreen"),
         main="Dotchart for Autos", cex=0.8)

# Turn off device driver (to flush output)
#dev.off()