#' humidex
#'
#' Computes canadian Humidex index.
#'
#' @param t  numeric  Air temperature in degC.
#' @param rh  numeric Relative humidity in percentage.
#' @return humidex in degC.
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  humidex, canada
#' @references Masterson, J. et Richardson, F. A., Humidex, A Method of Quantifying Human Discomfort Due to Excessive Heat and Humidity, Downsview, Ontario, Environnement Canada, 1979, 45.
#' @export
#'
#'
#'
#'

humidex=function(t,rh) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=humidex(t[i],rh[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


## Summarizes data.
## Gives count, mean, standard deviation, standard error of the mean, and confidence interval (default 95%).
##   data: a data frame.
##   measurevar: the name of a column that contains the variable to be summariezed
##   groupvars: a vector containing names of columns that contain grouping variables
##   na.rm: a boolean that indicates whether to ignore NA's
##   conf.interval: the percent range of the confidence interval (default is 95%)
summarySE <- function(data=NULL, measurevar, groupvars=NULL, na.rm=FALSE,
                      conf.interval=.95, .drop=TRUE) {
    library(plyr)

    # New version of length which can handle NA's: if na.rm==T, don't count them
    length2 <- function (x, na.rm=FALSE) {
        if (na.rm) sum(!is.na(x))
        else       length(x)
    }

    # This does the summary. For each group's data frame, return a vector with
    # N, mean, and sd
    datac <- ddply(data, groupvars, .drop=.drop,
      .fun = function(xx, col) {
        c(N    = length2(xx[[col]], na.rm=na.rm),
          mean = mean   (xx[[col]], na.rm=na.rm),
          sd   = sd     (xx[[col]], na.rm=na.rm)
        )
      },
      measurevar
    )

    # Rename the "mean" column
    datac <- rename(datac, c("mean" = measurevar))

    datac$se <- datac$sd / sqrt(datac$N)  # Calculate standard error of the mean

    # Confidence interval multiplier for standard error
    # Calculate t-statistic for confidence interval:
    # e.g., if conf.interval is .95, use .975 (above/below), and use df=N-1
    ciMult <- qt(conf.interval/2 + .5, datac$N-1)
    datac$ci <- datac$se * ciMult

    return(datac)
}


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 8, 2016
# clear; Rscript plot1.r; xdg-open ./plots/plot1.eps

# inputs: nothing
# outputs: figures/plot1.eps

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

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

# Define 2 vectors
cars <- c(1, 3, 6, 4, 9)
trucks <- c(2, 5, 4, 5, 12)

# Calculate range from 0 to max value of cars and trucks
g_range <- range(0, cars, trucks)

# Graph autos using y axis that ranges from 0 to max
# value in cars or trucks vector.  Turn off axes and
# annotations (axis labels) so we can specify them ourself
plot(cars,
     type="o",
     col="blue",
     ylim=g_range,
     axes=FALSE,
     ann=FALSE)

# Make x axis using Mon-Fri labels
axis(1, at=1:5, lab=c("Mon","Tue","Wed","Thu","Fri"))

# Make y axis with horizontal labels that display ticks at
# every 4 marks. 4*0:g_range[2] is equivalent to c(0,4,8,12).
axis(2, las=1, at=4*0:g_range[2])

# Create box around plot
box()

# Graph trucks with red dashed line and square points
lines(trucks, type="o", pch=22, lty=2, col="red")

# Create a title with a red, bold/italic font
title(main="Autos", col.main="red", font.main=4)

# Label the x and y axes with dark green text
title(xlab="Days", col.lab=rgb(0,0.5,0))
title(ylab="Total", col.lab=rgb(0,0.5,0))

# Create a legend at (1, g_range[2]) that is slightly smaller
# (cex) and uses the same line colors and points used by
# the actual plots
legend(1, g_range[2], c("cars","trucks"), cex=0.8,
   col=c("blue","red"), pch=21:22, lty=1:2);

# Turn off device driver
#dev.off()


library(dHRUM)
nHrus <- 1
Areas <- 4300000
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhruBP <- initdHruModel(nHrus,Areas,IdsHrus)

filname2 = "../dHRUM/inst/tests/indata/BP_1960_01_01.txt"
setPTInputsToAlldHrusFromFile(dhruBP, filname2)
# Hamon PET
calcPetToAllHrus(dhruBP,50.1,"Hamon")
# Oudin PET
# calPetToAllHrus(dHRU_ptr = dhruBP,50.1,"Oudin")

ParBP =readRDS(file="../tests/param0dBrejl.rds")
setParamsToAlldHrus(dhruBP,as.numeric(ParBP[1,]),names(ParBP))
calcHBInAlldHrus(dhruBP)
gatherHBdata(dhruBP)

dta <- getOutput(dhruBP)
dF <-data.frame(dta$outDta)
names(dF) <- dta$VarsNams

# celkovy odtok
plot(dF$TOTR, type='l')
# zakladni odtok
plot(dF$BASF, type='l')
# primy odtok
plot(dF$DIRR, type='l')
# zasoba vody v pude
plot(dF$SOIS, type='l')
# zasoba vody v podzemni vode
plot(dF$GROS, type='l')

VecDATE = c()
for(i in 1:nrow(dF)){
  VecDATE[i] = paste0(as.character(dF[i,1]),"-",as.character(dF[i,2]),"-",as.character(dF[i,3]))
}
VecDATE=as.Date(VecDATE)

Prec=dF$PREC
Temp=dF$TEMP

nHrus <- 1
Areas <- 4300000
IdsHrus <- paste0("ID",seq(1:length(Areas)))
dhruBP1 <- initdHruModel(nHrus,Areas,IdsHrus)
setPTDateInputsToAlldHrus(dhruBP1,Prec = Prec,Temp = Temp,DateVec = VecDATE)
calcPetToAllHrus(dhruBP1,Latitude = 50.1,PetTypeStr = "Hamon")
setParamsToAlldHrus(dhruBP1,as.numeric(ParBP[1,]),names(ParBP))
calcHBInAlldHrus(dhruBP1)
gatherHBdata(dhruBP1)
dta1 <- getOutput(dhruBP1)
dF1 <-data.frame(dta1$outDta)
names(dF1) <- dta1$VarsNams

plot(dF$PREF,dF1$PREF)
sum(dF$PREF-dF1$PREF)


clusters <- hclust(dist(iris[, -5]))
plot(clusters)


#' spvol
#'
#' Gets the specific volume of air/water vapor mixture [m^3/kg].
#'
#' @param t numeric Air temperature in degC.
#' @param hum_ratio numeric Humidity ratio.
#' @param pair numeric Air pressure in (hPa).
#' @return  Specific volume
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  spvol
#'
#' @export
#'
#'
#'
#'

spvol=function(t,hum_ratio,pair) {
                         ct$assign("ta", as.array(t))
                         ct$assign("hum_ratio", as.array(hum_ratio))
                         ct$assign("pa", as.array(pair))
                         ct$eval("var res=[]; for(var i=0, len=ta.length; i < len; i++){ res[i]=spvol(ta[i],hum_ratio[i],pa[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


ratio<-function(decimal){
  denominator=1
  while(nchar(decimal*denominator)!=nchar(round(decimal*denominator))){
    denominator=denominator+1
  }
  str=paste(decimal*denominator,"/",sep="")
  str=paste(str,denominator,sep="")
  return(str)
}


# GWAS follow-up: left-handedness (LH) / T2D
# V.Odintsova, J.van Dongen

# load GWAS summary statistics (GWAShand)
# load meta-analysis EWAS summary statistics (EWAShand)
# CHR = chromosome
# POS = position
# PVAL = p-value

# include fraction of SNPs at p <5x10-08
GWAShand <- GWAShand[which(GWAShand$PVAL < 5e-08),]

# detect CpGs located in 1Mb window from SNPs
w1Mb   <- 1000000
samechrom <- matrix(0,nrow=nrow(EWAShand),ncol=nrow(GWAShand))
distance <-  matrix(0,nrow=nrow(EWAShand),ncol=nrow(GWAShand))

for (j in 1:nrow(EWAShand)) {
  samechrom[j,which(GWAShand$CHR==EWAShand$CHR[j])] <- 1
  distance[j,] <- abs(EWAShand$POS[j] - GWAShand$POS)
}

withinw1Mb <-  matrix(0,nrow=nrow(EWAShand),ncol=nrow(GWAShand))
for (j in 1:nrow(EWAShand))
{
withinw1Mb[j,which(samechrom[j,]==1 & distance[j,] < w1Mb)] <- 1
}

CpGs_w1Mb <- rownames(EWAShand[which(rowSums(withinw1Mb) > 0),])

# label CpGs located in 1Mb window and other CpGs in meta-analysis EWAS summary statistics
pathway <- rep("other",nrow(EWAShand))
pathway[which(rownames(EWAShand) %in% CpGs_w1Mb)] <- "handCpGs_w1Mb"
table(pathway)
pvalues <- data.frame(results$P.value,pathway)
handCpGs_w1Mb <- pvalues[,1]
handCpGs_w1Mb [which(!pvalues$pathway=="handCpGs_w1Mb")] <- NA
All_other_CpGs <- pvalues[,1]
All_other_CpGs[which(!pvalues$pathway=="other")] <- NA
pvals <- cbind(handCpGs_w1Mb,All_other_CpGs)
handCpGs_w1Mb <- rep(0,nrow(pvals))
handCpGs_w1Mb[which(pathway=="handCpGs_w1Mb")] <- 1
dataenrich <- data.frame(results$P.value,abs(results$t),handCpGs_w1Mb)
colnames(dataenrich) [1:2] <- c("P.value","t")
rownames(dataenrich) <- rownames(results)

# regression model
linReg0a <- lm(formula = t ~ handCpGs_w1Mb, data = dataenrich)
summary(linReg0a)
out <- summary(linReg0a$coefficients)

# bootstrapping to calculate p-value
library(simpleboot)
boot0a <- lm.boot(linReg0a,R = 2000)
summary(boot0a)


#' Most variable CpG sites
#'
#' Returns the most variable CpG sites (rows) in the methylation matrix.
#'
#' @param  beta Output from \code{\link{meffil.normalize.samples}()},
#' either a matrix or a GDS filename.
#' @param n Number of CpG sites to return.
#' @param sites Subset of CpG sites to consider (row names of beta) (Default: NULL).
#' @param samples Subset of samples to consider (column names of beta) (Default: NULL).
#' @param  autosomal If true, remove probes on sex chromosomes (Default: TRUE).
#' @param winsorize.pct Apply to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: NA).
#' @param outlier.iqr.factor Apply to methylation after setting,
#' for each CpG site, values less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @return The \code{n} CpG site identifiers (rownames of \code{x}) with the greatest variance in \code{x}.
#'
#' @export
meffil.most.variable.cpgs <- function(beta, n=1000, sites=NULL, samples=NULL, autosomal=T, winsorize.pct=NA, outlier.iqr.factor=NA) {
    stopifnot(n > 0)
    if (is.matrix(beta)) {
        stopifnot(!is.null(rownames(beta)))
        stopifnot(!is.null(colnames(beta)))
        all.sites <- rownames(beta)
        all.samples <- colnames(beta)
    } else {
        beta.dims <- meffil:::retrieve.gds.dims(beta)
        all.sites <- beta.dims[[1]]
        all.samples <- beta.dims[[2]]
    }

    if (is.null(sites)) sites <- all.sites
    else sites <- intersect(sites, all.sites)
    stopifnot(length(sites)>0)

    if (autosomal) {
        featureset <- meffil:::guess.featureset(all.sites)
        autosomal.sites <- meffil.get.autosomal.sites(featureset)
        sites <- intersect(autosomal.sites, sites)
    }

    if (is.null(samples)) samples <- all.samples
    else samples <- intersect(samples, all.samples)
    stopifnot(length(samples)>0)

    if (is.matrix(beta)) {
        beta <- beta[sites,samples,drop=F]
        beta <- meffil.handle.outliers(beta, winsorize.pct, outlier.iqr.factor)
        vars <- matrixStats::rowVars(beta, na.rm=T)
    } else {
        var.fun <- function(x,winsorize.pct, outlier.iqr.factor) var(x, na.rm=T)
        if (is.numeric(winsorize.pct) || is.numeric(outlier.iqr.factor))
            var.fun <- function(x, winsorize.pct, outlier.iqr.factor) {
                x <- meffil::meffil.handle.outliers(x, winsorize.pct, outlier.iqr.factor)
                var(x, na.rm=T)
            }

        vars <- meffil:::lapply.gds(
            beta,
            margin=1,
            sites=sites,
            samples=samples,
            type="double",
            FUN=var.fun,
            winsorize.pct=winsorize.pct,
            outlier.iqr.factor=outlier.iqr.factor)
    }
    n <- min(length(sites), n)
    sites[order(vars, decreasing=TRUE)[1:n]]
}


 DGBCON Example Program Results

 Estimate of condition number =  5.64E+01


library(ggplot2)
library(scales)
library(bayesplot)
library(matrixStats)
library(cowplot)
#library(svglite)
library(boot)

source("usa/code/utils/read-data-usa.r")

round.choose <- function(x, roundTo, dir = 1) {
  if(dir == 1) {  ##ROUND UP
    x + (roundTo - x %% roundTo)
  } else {
    if(dir == 0) {  ##ROUND DOWN
      x - (x %% roundTo)
    }
  }
}

make_covariate_effect_size_plot = function(JOBID,  StanModel, ext = ".png", filename=NULL, country="usa", exclude_vars = NULL) {
  if(is.null(filename)) {
    load(paste0(country, '/results/', StanModel, "-", JOBID, '-stanfit.Rdata'))
  } else {
    load(filename)
  }

  out = rstan::extract(fit)

  my.plot = function(alpha,label,plot_labels=colnames(alpha), ylab = "Mobility\n",
                     xlabs = c("0%\n(no effect on transmissibility)","25%","50%","75%","100%\n(ends transmissibility)"),
                     xbreaks = seq(0,1,.25),
                     line = 1) {
    data = mcmc_intervals_data(alpha,prob_outer=.95,transformation=function(x) 1-2*inv.logit(-x),point_est="mean")

    levels(data$parameter) = gsub("t(", "", levels(data$parameter), fixed=TRUE)
    levels(data$parameter) = sub("\\)$", "", levels(data$parameter), fixed=FALSE)
    data$parameter = (as.character(data$parameter))

    no_point_est <- all(data$point_est == "none")
    x_lim <- range(c(data$ll, data$hh))
    x_range <- diff(x_lim)
    x_lim[1] <- x_lim[1] - 0.05 * x_range
    x_lim[2] <- x_lim[2] + 0.05 * x_range
    layer_vertical_line <- if (0 > x_lim[1] && 0 < x_lim[2]) {
      vline_0(color = "gray90", size = 0.5)
    } else {
      geom_blank(
        mapping = NULL, data = NULL,
        show.legend = FALSE, inherit.aes = FALSE)
    }
    args_outer <- list(mapping = aes_(x = ~ll, xend = ~hh, y = ~parameter,
                                      yend = ~parameter)) #, color = bayesplot::get_color("mid"))
    args_inner <- list(mapping = aes_(x = ~l, xend = ~h, y = ~parameter,
                                      yend = ~parameter), size = 2, show.legend = FALSE)
    args_point <- list(mapping = aes_(x = ~m, y = ~parameter),
                       data = data, size = 4, shape = 21)

    args_point$color <- "blue" #get_color("dark_highlight")

    point_func <- geom_point
    layer_outer <- do.call(geom_segment, args_outer)
    layer_inner <- do.call(geom_segment, args_inner)
    layer_point <- do.call(point_func, args_point)

    data$parameter = factor(as.character(data$parameter),levels=plot_labels[order(plot_labels,decreasing=T)])
    # data = data[order(-data$m),]
    p = ggplot(data) +theme_bw() +  geom_point(aes(x=m,y=parameter),position = position_dodge(-.5), size = 6) +
      geom_linerange(aes(xmin=ll,xmax=hh,y=parameter),
                     position = position_dodge(-.5), size=1) +
      scale_x_continuous(breaks=xbreaks,labels = xlabs,
                         expand=c(0.005,0.005),expression(paste("\nRelative % reduction in  ",R[t])))  +
      #scale_colour_manual(name = "", #labels = c("50%", "95%"),
      #                    values = c(("coral4"), ("seagreen"))) +

      geom_vline(xintercept=c(0,line),colour="darkgray") +
      scale_y_discrete(ylab) +
      theme(plot.margin = margin(0, 2, 0, .5, "cm"),
            text = element_text(size=16))
    print(paste0("saving usa/figures/covars_effect_sizes_", label, "_", JOBID, ext))
    ggsave(paste0("usa/figures/covars_effect_sizes_", label, "_", JOBID, ext), p, height = 6, width = 8)

    if (label == "country"){
      reductions <- data.frame("parameter" = data$parameter,
                               "text" = sprintf("%0.1f\\%% [%0.1f\\%% - %0.1f\\%%]",
                                                data$m*100,
                                                round.choose(data$ll*100, 0.1, 0),
                                                round.choose(data$hh*100, 0.1, 1)))
      saveRDS(reductions, paste0("usa/results/", JOBID, "-covariate-reductions.RDS"), version = 2)
    }

  }

  if(length(exclude_vars) != 0) {
    alpha = data.frame(as.matrix(out$alpha[,-exclude_vars]))
    colnames(alpha) = labels(terms(formula))[-exclude_vars]
  }
  else {
    alpha = data.frame(as.matrix(out$alpha))
    colnames(alpha) = labels(terms(formula))
  }

  colnames(alpha) <- c("Average mobility", "Transit", "Residential")
  my.plot(alpha,"country")

  if(exists("formula_partial_regional")) {
     #alpha = data.frame(out$alpha_region[,,2])
    alpha = data.frame(out$alpha_region)
     df <- read_death_data("jhu")
     # region_codes = read.csv("usa/data/usa-regions.csv")
     # region_codes = unique(region_codes[,c("region_census_sub_revised","region_code")])
     # region_codes = region_codes[order(region_codes$region_code),]
     # write.csv(region_codes,"usa/data/usa-region-codes.csv",row.names=F)
     region_names = read.csv("usa/data/usa-region-codes.csv",stringsAsFactors = F)$region_census_sub_revised
     # region_names = unique(df$region_census_sub_revised)
     if(ncol(alpha) > 8) {
      colnames(alpha) = c(region_names,region_names)
      my.plot(alpha[,1:8], plot_labels = colnames(alpha[,1:8]), #c(unique(df$region_census_sub_revised)),
              label = "regional-intercept", ylab = "Intercept\n",
              xlabs = c("-50%", "-25%", "0%","25%","50%"),
              xbreaks = seq(-0.5,0.5,.25),
              line = 0)
      my.plot(alpha[,9:16], plot_labels = colnames(alpha[,9:16]), #c(unique(df$region_census_sub_revised)),
              label = "regional-mobility", ylab = "Average mobility\n",
              xlabs = c("-50%", "-25%", "0%","25%","50%"),
              xbreaks = seq(-0.5,0.5,.25),
              line = 0)

     } else{
       colnames(alpha) = region_names
       my.plot(alpha, plot_labels = colnames(alpha), #c(unique(df$region_census_sub_revised)),
               label = "regional", ylab = "Average mobility\n",
               xlabs = c("-50%", "-25%", "0%","25%","50%"),
               xbreaks = seq(-0.5,0.5,.25),
               line = 0)

     }

  }
  if(exists("formula_partial_state")) {
    alpha = data.frame(out$alpha_state)
    colnames(alpha) = states
    transit_states <- c('NY', 'DC', 'MA', 'CA', 'WA', 'IL', 'MD', 'NJ')
    transit_states <- transit_states[order(transit_states)]
    alpha <- select(alpha, transit_states)
    colnames(alpha) <- c("California", "District of Columbia", "Illinos", "Massachusetts", "Maryland", "New Jersey", "New York" ,"Washington")
    my.plot(alpha, plot_labels = c("California", "District of Columbia", "Illinos", "Massachusetts", "Maryland", "New Jersey", "New York" ,"Washington"), label = "state", ylab = "Transit\n",
            xlabs = c("-50%", "-25%", "0%","25%","50%"),
            xbreaks = seq(-0.5,0.5,.25),
            line = 0)
  }
}

#make_covariate_effect_size_plot(1063344,"regional-state",filename="~/stanfits/regional-state-1063344-stanfit.Rdata")
#make_covariate_effect_size_plot(294774,"regional-state",filename="~/stanfits/regional-state-294774-stanfit.Rdata")


#Open psv file
fil<-file(file.path(data.path,"sms.psv"), "rb")

#Read dimension of vector = number of parameters
dim<-readBin(fil,integer(),1)
dim

#read values, assume a very high number of observations
psv<-readBin(fil, numeric(), 1E6)
close(fil)

# calc number of MCMC set
dim2<-length(psv)/dim

#reformat
psv<-matrix(psv,  dim,dim2)

CV<-round(abs(apply(psv,1,sd)/apply(psv,1,mean)*100))

a<-read.table(file.path(data.path,"sms.std"),comment.char = "#",header=FALSE,skip=1)
tmp<-data.frame(index=a$V1,name=a$V2, mean=a$V3, CV.round=round(a$V4/a$V3*100), std=a$V4)
print(tmp)

cleanup()
dev<-"screen"
nox<-4
noy<-4
newplot(dev,nox,noy);

j<-1
first<-600
last<-789

for (i in (first:last)) {
  j<-j+1
  if (j==noxy) {newplot(dev,nox,noy); j<<-0 }
  plot(density(psv[i,]),main=paste(i,tmp[i,'name']))
#   plot((psv[i,]),main=paste("par:",i),type='l',ylab='')

}


#' km
#'
#' k-means via Lloyd's Algorithm.
#'
#' Note that the function does not respect \code{set.seed()} or
#' \code{comm.set.seed()}.  For managing random seeds, use the \code{seed}
#' parameter.
#'
#' @details
#' The iterations stop either when the maximum number of iterations have been
#' achieved, or when the centers in the current iteration are basically the same
#' (within \code{1e-8} for double precision and \code{1e-4} single precision)
#' as the centers from the previous iteration.
#'
#' For best performance, the data should be as balanced as possible across all
#' MPI ranks.
#'
#' @section Communication:
#' Most of the computation is local. However, at each iteration there is a
#' length \code{n*k} and a length \code{k} allreduce call to update the centers.
#' There is also a check at the beginning of the call to find out how many
#' observations come before the current process's data, which is an allgather
#' operation.
#'
#' @param x
#' A shaq.
#' @param k
#' The 'k' in k-means.
#' @param maxiter
#' The maximum number of iterations possible.
#' @param seed
#' A seed for determining the (random) initial centroids.  Each process has to
#' use the same seed or very strange things may happen.  If you do not provide
#' a seed, a good initial seed will be chosen.
#'
#' @return
#' A list containing the cluster centers (global), the observation labels i.e.
#' the assignments to clusters (distributed shaq), and the total number of
#' iterations (global).
#'
#' @references
#' Phillips, J.. Data Mining: Algorithms, Geometry, and Probability.
#' https://www.cs.utah.edu/~jeffp/DMBook/DM-AGP.html
#'
#' @useDynLib clustrgame R_kmeans
#' @export
km_game = function(x, k=2, maxiter=100, seed=1234)
{
  kazaam:::check.is.shaq(x)
  kazaam:::check.is.posint(k)
  kazaam:::check.is.posint(maxiter)
  kazaam:::check.is.posint(seed)

  k = as.integer(k)
  maxiter = as.integer(maxiter)
  comm_ptr = pbdMPI::get.mpi.comm.ptr(.pbd_env$SPMD.CT$comm)

  pbdMPI::comm.set.seed(seed, diff=FALSE)

  if (is.float(DATA(x)))
    data = DATA(x)@Data
  else
  {
    data = DATA(x)
    if (!is.double(data))
      storage.mode(data) = "double"
  }

  m = nrow(x)
  m = as.integer(m) # FIXME

  out = .Call(R_kmeans, data, m, k, maxiter, comm_ptr)

  if (is.float(DATA(x)))
    out$centers = float32(out$centers)

  labels.shaq = shaq(matrix(out$labels), ncols=1L, checks=FALSE)
  list(centers=out$centers, labels=labels.shaq, iterations=out$niters)
}


context("Survival Model Testing")

library(keras)
#library(devtools)
library(survival)
library(tensorflow)
library(dplyr)
#document()
data(lung)

lung <- lung %>%
  mutate(status = status - 1,
         sex = as.factor(sex),
         ph.ecog = as.factor(ph.ecog))

#tf$config$run_functions_eagerly(TRUE)
dc_fit <- dcoxph(
  lung,
  Surv(time, status) ~ sex + age + meal.cal + wt.loss + ph.ecog,
#  hidden_layers = c(6),
#  hidden_layers_activation = c("sigmoid"),
  verbose = TRUE,
  epochs = 200,
  validation_split = .2)
get_weights(dc_fit$model)
cph <- coxph(Surv(time, status) ~ sex + age + meal.cal + wt.loss + ph.ecog,
             lung)

plot(dc_fit$history)

predict(dc_fit, lung)


> x
[1]  1  3  5  7  9 11 13 15 17
> # sample 2 items from x
> sample(x, 2)
[1] 13  9
> # sample with replacement
> sample(x, replace = TRUE)
[1] 15 17 13  9  5 15 11 15  1
> # if we simply pass in a positive number n, it will sample
> # from 1:n without replacement
> sample(10)
[1]  2  4  7  9  1  3 10  5  8  6
> sample(c("H","T"),10, replace = TRUE)
[1] "H" "H" "H" "T" "H" "T" "H" "H" "H" "T"


#' Function for plotting posterior regression line
#'
#' This function takes as input some continuous covariate \code{x} and predictions from NDPMix, ZDPMix, fDPMix, etc. It outputs a credible band and posterior mean line of the predictions across \code{x}
#'
#' Please see \url{https://stablemarkets.github.io/ChiRPsite/index.html} for examples and details.
#'
#' @import stats
#'
#' @param x A vector of type \code{as.numeric} to plot on the x dimension of the plot.
#' @param post_draws matrix with dimensions length(x) by # posterior draws.
#' @param col_gradient Optional. Defaults to lightblue. Darkest color that gradient goes to.
#' @param col_mean_line Optional. Defaults to steelblue. Color of the posterior mean regression line.
#' @return overlays credible band and posterior mean line.
#' @keywords Dirichlet Process
#' @examples
#' set.seed(1)
#'
#' N = 200
#' x<-seq(1,10*pi, length.out = N) # confounder
#' y<-rnorm(n = length(x), sin(.5*x), .07*x )
#' d <- data.frame(x=x, y=y)
#' d$x <- as.numeric(scale(d$x))
#' d$y <- as.numeric(scale(d$y))
#'
#' d_test = data.frame(x=seq(max(d$x), max(d$x+1 ), .01 ))
#'
#'
#' res = fDPMix(d_train = d, d_test = d_test, formula = y ~ x,
#'              iter=100, burnin=50, tau_x = c(.01, .001) )
#'
#'
#'
#' par(mfrow=c(1,1))
#' plot(d$x,d$y, pch=20, xlim=c(min(d$x), max(d$x)+1 ), col='gray')
#'
#' credible_gradient(d$x, res$train)
#' credible_gradient(d_test$x, res$test, col_gradient = 'pink', col_mean_line = 'darkred')
#'
#' points(d$x, d$y, pch=20, col='gray') ## re-plot points to bring the to the top.
#' abline(v=max(d$x), lty=2)
#'
#' @export
credible_gradient = function(x, post_draws,
                             col_gradient='lightblue',
                             col_mean_line='steelblue'){

  func_args<-mget(names(formals()),sys.frame(sys.nframe()))
  error_check_credible_gradient(func_args)

  colfunc <- colorRampPalette(c("white", col_gradient))
  ci_perc = seq(.99,.01,-.01)
  colvec = colfunc(length(ci_perc))
  names(colvec) = ci_perc

  for(i in ci_perc){
    pci = apply(post_draws, 1, quantile, probs=c( (1-i)/2, (1+i)/2  ) )
    polygon(c(x,rev(x)),c(pci[1,],rev(pci[2,])),
            col = colvec[as.character(i)], border = FALSE)
  }

  lines(x, apply(post_draws, 1, mean), col=col_mean_line , pch=20 )
}


 E04KFJ Example Program Results

 E04KF, First order method for bound-constrained problems
 Begin of Options
     Print File                    =                   6     * d
     Print Level                   =                   1     * U
     Print Options                 =                 Yes     * d
     Print Solution                =                 All     * U
     Monitoring File               =                   9     * U
     Monitoring Level              =                   3     * U
     Foas Monitor Frequency        =                   0     * d
     Foas Print Frequency          =                   5     * U

     Infinite Bound Size           =         1.00000E+20     * d
     Task                          =            Minimize     * d
     Stats Time                    =                  No     * d
     Time Limit                    =         1.00000E+06     * d
     Verify Derivatives            =                  No     * d

     Foas Estimate Derivatives     =                  No     * d
     Foas Finite Diff Interval     =         1.05367E-08     * d
     Foas Iteration Limit          =            10000000     * d
     Foas Memory                   =                  11     * d
     Foas Progress Tolerance       =         1.08158E-12     * d
     Foas Rel Stop Tolerance       =         1.08158E-12     * d
     Foas Restart Factor           =         6.00000E+00     * d
     Foas Slow Tolerance           =         1.01316E-02     * d
     Foas Stop Tolerance           =         1.00000E-06     * d
     Foas Tolerance Norm           =            Infinity     * d
 End of Options

 Status: converged, an optimal solution was found
 Value of the objective             4.00000E-02
 Norm of inactive gradient          0.00000E+00
 Norm of projected direction        0.00000E+00

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1  -1.00000E+00    8.00000E-01    8.00000E-01
     2  -2.00000E+00    6.40000E-01    2.00000E+00

 Box bounds dual variables:
   idx   Lower bound       Value       Upper bound       Value
     1  -1.00000E+00    0.00000E+00    8.00000E-01    4.00000E-01
     2  -2.00000E+00    0.00000E+00    2.00000E+00    0.00000E+00

 Solution found:
  Objective function value at solution:   4.0E-02
  Gradient at solution:                  -4.0E-01   0.0E+00

  Estimated Lagrange multipliers: blx     0.0E+00   0.0E+00
  Estimated Lagrange multipliers: bux     4.0E-01   0.0E+00


x <- read.table("all_results.txt")

#rename columns
attr(x, "names") <- c("mtf50", "angle", "dev")

angles <- unique(sort(x$angle))
mtfs <- unique(sort(x$mtf50))

y <- list()
max_dev <- 0
min_dev <- 1
for (a in angles) {
    y[[a]] <- subset(x, angle == a)
    max_dev <- max(max_dev, y[[a]]$dev)
    min_dev <- min(min_dev, y[[a]]$dev)
}

pdf("accuracy_plot.pdf", width=(200/25.4), height=(120/25.4), pointsize=8)

plot(mtfs, aggregate(y[[angles[1]]]$dev, list(Sig=y[[angles[1]]]$mtf50), median)$x,
  ylim=c(min_dev, max_dev), type="l",
  xlab="MTF50 (c/p)", ylab="Error (c/p)",
  main="MTF50 error by slant angle"
)
for (a in 2:length(angles)) {
    lines(mtfs, aggregate(y[[angles[a]]]$dev, list(Sig=y[[angles[a]]]$mtf50), median)$x, ylim=c(min_dev, max_dev), col=a)
}

legend("topleft", legend=c("angle=4 deg", "angle=10 deg", "angle=30 deg"), fill=c(1,2,3), inset=0.05)
dev.off()


source("power_priors_aux.r")
source("data_Gaussian.r")

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

#### Sampling from the "prior"
compiled.model.prior <- stan_model("stan/simple_Gaussian_posterior_unnormalised_fixed_a0.stan") ## lying a bit, this is the posterior

gs.data <- list(
  N0 = N_0,
  y0 = y_0,
  mu0 = mu_0,
  kappa0 = kappa_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  N = N,
  y = y
)
####################
J <- 20
maxA <- 10
epsilon <- 0.05

source("grid_builder.r")
#
uniform.a0s <- seq(epsilon, maxA, length.out = J)
uniform.time <- system.time(
  uniform.ca0.estimates <- create_lc_df(a0_grid = uniform.a0s, stan.list = gs.data, pars = c("mu", "sigma"))
)
## for the sensitivity analysis all we need are estimates of parameters, no need for l(a_0)
adaptive.derivOnly.time <- system.time(
    adaptive.ca0.estimates.derivOnly <- build_grid_derivOnly(eps = epsilon,
                                                           M = maxA, J = J, v1 = 10, v2 = 10,
                                                           stan.list = gs.data, pars = c("mu", "sigma"))
)
## Exporting
write.csv(uniform.ca0.estimates$result, row.names = FALSE,
          file =  paste("../data/constant_data/Gaussian_posterior_logCA0_uniform", "_J=", J,
                        ".csv", sep = ""))
write.csv(adaptive.ca0.estimates.derivOnly$result, row.names = FALSE,
          file = paste("../data/constant_data/Gaussian_posterior_logCA0_adaptive_derivOnly", "_J=", J,
                       ".csv", sep = ""))

## Exporting sensitivity stuff

summaries.uniform <- uniform.ca0.estimates$summaries
for (i in 1:length(summaries.uniform)){
  summaries.uniform[[i]] <- data.frame(summaries.uniform[[i]], a_0 = uniform.ca0.estimates$result$a0[i])
}
summaries.uniform.dt <- do.call(rbind, summaries.uniform)

summaries.adaptive <- adaptive.ca0.estimates.derivOnly$summaries
for (j in 1:length(summaries.adaptive)){
  summaries.adaptive[[j]] <- data.frame(summaries.adaptive[[j]],
                                        a_0 = adaptive.ca0.estimates.derivOnly$result$a0[j])
}
summaries.adaptive.dt <- do.call(rbind, summaries.adaptive)

write.csv(summaries.uniform.dt,
          file = paste("../data/sensitivity_data/posteriorSensitivity_simpleGaussian_uniform_J=", J, ".csv", sep = ""))

write.csv(summaries.adaptive.dt,
          file = paste("../data/sensitivity_data/posteriorSensitivity_simpleGaussian_adaptive_J=", J, ".csv", sep = ""))


#' mmHG2inches
#'
#' @description Return inches from millimeter of mercure.
#'
#' @param mm millimeter
#' @references
#' Istituto di Biometeorologia Firenze Italy
#' @author  Alfonso crisci \email{a.crisci@@ibimet.cnr.it} Marco Morabito \email{m.morabito@@unifi.it}
#' @examples
#'
#'
#' @export

mmHG2inches<-function(mm)
{
  return( mm * 0.0393701);
}


# 4. faza: Analiza podatkov

#NAPOVED ŠTEVILA POROK

tabela1$Vrsta <- "Podatki"
model <- lm(Stevilo_sklenjenih_zakonskih_zvez~Leto, data=tabela1)
pr <- predict(model, data.frame(Leto=seq.int(2020, 2025, 1)))
napoved_porok <- data.frame(Leto = c(2020, 2021, 2022, 2023, 2024, 2025), Stevilo_sklenjenih_zakonskih_zvez = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_porok$Vrsta <- "Napoved"
skupna_tabela <- rbind(tabela1, napoved_porok)

graf_napoved <- ggplot(skupna_tabela, aes(x=Leto, y=Stevilo_sklenjenih_zakonskih_zvez, shape=Vrsta)) +
  geom_smooth(method=lm, se=FALSE, fullrange = TRUE) +
  geom_point(data=tabela1, aes(x=Leto, y=Stevilo_sklenjenih_zakonskih_zvez), color="red", size=3) +
  labs(title="Napoved števila porok", y="Število porok", x="Leto") + geom_point(color="red")

#NAPOVED POVPREČNE STAROSTI PRI VSTOPU V ZAKONSKO ZVEZO

#za ženske

slovenija = c('Slovenija')
sprememba_starosti_a <- tabela7 %>% filter(Drzava=="Slovenija", Meritev=="povprečna starost žensk" )
sprememba_starosti_a$Vrsta <- "Podatki"
sprememba_starosti_a$Meritev <- NULL
model_a <- lm(Povprecna_starost~Leto, data=sprememba_starosti_a)
pr <- predict(model_a, data.frame(Leto=seq.int(2020, 2025, 1)))
napoved_spremembe_starosti_a <- data.frame(Leto = c(2020, 2021, 2022, 2023, 2024, 2025), Povprecna_starost = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_spremembe_starosti_a$Drzava <- slovenija
napoved_spremembe_starosti_a$Vrsta <- "Napoved"
skupna_tabela_a <- rbind(sprememba_starosti_a, napoved_spremembe_starosti_a)

Španija = c('Španija')
sprememba_starosti_b <- tabela7 %>% filter(Drzava=="Španija", Meritev=="povprečna starost žensk" )
sprememba_starosti_b$Vrsta <- "Podatki"
sprememba_starosti_b$Meritev <- NULL
model_b <- lm(Povprecna_starost~Leto, data=sprememba_starosti_b)
pr <- predict(model_b, data.frame(Leto=seq.int(2020, 2025, 1)))
napoved_spremembe_starosti_b <- data.frame(Leto = c(2020, 2021, 2022, 2023, 2024, 2025), Povprecna_starost = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_spremembe_starosti_b$Drzava <- Španija
napoved_spremembe_starosti_b$Vrsta <- "Napoved"
skupna_tabela_b <- rbind(sprememba_starosti_b, napoved_spremembe_starosti_b)

Danska = c('Danska')
sprememba_starosti_c <- tabela7 %>% filter(Drzava=="Danska", Meritev=="povprečna starost žensk" )
sprememba_starosti_c$Vrsta <- "Podatki"
sprememba_starosti_c$Meritev <- NULL
model_c <- lm(Povprecna_starost~Leto, data=sprememba_starosti_c)
pr <- predict(model_c, data.frame(Leto=seq.int(2020, 2025, 1)))
napoved_spremembe_starosti_c <- data.frame(Leto = c(2020, 2021, 2022, 2023, 2024, 2025), Povprecna_starost = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_spremembe_starosti_c$Drzava <- Danska
napoved_spremembe_starosti_c$Vrsta <- "Napoved"
skupna_tabela_c <- rbind(sprememba_starosti_c, napoved_spremembe_starosti_c)

napoved_starosti <- rbind(skupna_tabela_a, skupna_tabela_b, skupna_tabela_c)

graf_napoved2 <- ggplot(napoved_starosti , aes(x=Leto, y=Povprecna_starost, col=Drzava, shape=Vrsta)) +
  geom_point() + ggtitle("Napoved povprečne starosti žensk ob vstopu v zakonsko zvezo") +
  xlab("Leto") + ylab("Povprečna starost") + facet_grid(. ~ Drzava) + stat_smooth(method="lm") + theme(axis.text.x=element_text(angle=90))

#za moške

slovenija = c('Slovenija')
sprememba_starosti_s <- tabela7 %>% filter(Drzava=="Slovenija", Meritev== "povprečna starost moških" )
sprememba_starosti_s$Vrsta <- "Podatki"
sprememba_starosti_s$Meritev <- NULL
model_s <- lm(Povprecna_starost~Leto, data=sprememba_starosti_s)
pr <- predict(model_s, data.frame(Leto=seq.int(2020, 2025, 1)))
napoved_spremembe_starosti_s <- data.frame(Leto = c(2020, 2021, 2022, 2023, 2024, 2025), Povprecna_starost = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_spremembe_starosti_s$Drzava <- slovenija
napoved_spremembe_starosti_s$Vrsta <- "Napoved"
skupna_tabela_s <- rbind(sprememba_starosti_s, napoved_spremembe_starosti_s)

Danska = c('Danska')
sprememba_starosti_d <- tabela7 %>% filter(Drzava=="Danska", Meritev== "povprečna starost moških" )
sprememba_starosti_d$Vrsta <- "Podatki"
sprememba_starosti_d$Meritev <- NULL
model_d <- lm(Povprecna_starost~Leto, data=sprememba_starosti_d)
pr <- predict(model_d, data.frame(Leto=seq.int(2020, 2025, 1)))
napoved_spremembe_starosti_d <- data.frame(Leto = c(2020, 2021, 2022, 2023, 2024, 2025), Povprecna_starost = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_spremembe_starosti_d$Drzava <- Danska
napoved_spremembe_starosti_d$Vrsta <- "Napoved"
skupna_tabela_d <- rbind(sprememba_starosti_d, napoved_spremembe_starosti_d)

Španija = c('Španija')
sprememba_starosti_sp <- tabela7 %>% filter(Drzava=="Španija", Meritev== "povprečna starost moških" )
sprememba_starosti_sp$Vrsta <- "Podatki"
sprememba_starosti_sp$Meritev <- NULL
model_sp <- lm(Povprecna_starost~Leto, data=sprememba_starosti_sp)
pr <- predict(model_sp, data.frame(Leto=seq.int(2020, 2025, 1)))
napoved_spremembe_starosti_sp <- data.frame(Leto = c(2020, 2021, 2022, 2023, 2024, 2025), Povprecna_starost = c(pr[1], pr[2], pr[3], pr[4], pr[5], pr[6]))
napoved_spremembe_starosti_sp$Drzava <- Španija
napoved_spremembe_starosti_sp$Vrsta <- "Napoved"
skupna_tabela_sp <- rbind(sprememba_starosti_sp, napoved_spremembe_starosti_sp)

napoved_starosti_moski <- rbind(skupna_tabela_s, skupna_tabela_d, skupna_tabela_sp)

graf_napoved3 <- ggplot(napoved_starosti_moski , aes(x=Leto, y=Povprecna_starost, col=Drzava, shape=Vrsta)) +
  geom_point() + ggtitle("Napoved povprečne starosti moških ob vstopu v zakonsko zvezo") +
  xlab("Leto") + ylab("Povprečna starost") + facet_grid(. ~ Drzava) + stat_smooth(method="lm") +
  theme(axis.text.x=element_text(angle=90))


###############################
###  2009, David Ellinghaus ###
###############################

## input: data.frame with genotype counts
##         - columns: geno.11: counts for AA
##                    geno.12: counts for AB
##                    geno.22: counts for BB

makeDefinetti <- function(snpSummary, label)
{
  switchStrand <- rep(c(TRUE, FALSE), length = nrow(snpSummary))
  snpSummary$n <- with(snpSummary, geno.11 + geno.12 + geno.22)
  freqs <- with(snpSummary,
                data.frame(freqsA =  (geno.11 + 0.5 * geno.12) / n,
                           freqsAB = geno.12 / (geno.11 + geno.12 + geno.22)))
  freqs$freqsA[switchStrand] <- 1 - freqs$freqsA[switchStrand]

  #print(freqs)
  plot(1, type="n", col="black", xlim = c(0, 1), ylim = c(0,1),
       main=paste("De Finetti diagram", "-  ", label),
       xlab="p", ylab=expression(p[12]),
       xaxs = "i", yaxs = "i", las = 1, xaxt="n", yaxt="n")

  axis(1, seq(0, 1, by = 0.1), tick = T, labels = seq(0,1,by = 0.1))
  axis(2, seq(0, 1, by = 0.1), tick = T, labels = seq(0,1,by = 0.1))

  lines(c(0,0.5,1, 0),c(0,1,0, 0), type="l", col="black", ylab=expression(p[12])) # triangle
  with(freqs, points(freqs$freqsA, freqs$freqsAB,
                     cex = 0.5, pch = 20))
  text(x=0.2, y=0.55, labels=expression(p[22]), cex=1.2)
  text(x=0.8, y=0.55, labels=expression(p[11]), cex=1.2)

  # horizontal lines
  for ( i in seq(0,1,by = 0.1))
      lines(c(0,1), c(i,i), lty=3, lwd=0.5, col="black")

  # triangle grid
  for ( i in seq(0,1,by = 0.1))
      lines(c(i,i+0.5-i/2), c(0,1-i), lty=1, lwd=0.5, col="black")
  for ( i in seq(0,1,by = 0.1))
      lines(c(i,i-i/2), c(0,i), lty=1, lwd=0.5, col="black")
  for ( i in seq(0.05,0.95,by = 0.1))
      lines(c(i,i+0.5-i/2), c(0,1-i), lty=3, lwd=0.5, col="black")
  for ( i in seq(0.05,0.95,by = 0.1))
      lines(c(i,i-i/2), c(0,i), lty=3, lwd=0.5, col="black")
  for ( i in seq(0.05,0.95,by = 0.1))
      lines(c(i/2,1-i/2), c(i,i), lty=3, lwd=0.5, col="black")

  # ticks
  y <- seq(0.1,0.9,by=.1)
  x <- y/2
  segments(x-.01, y, x, y, col="black")
  text(x = x-.03, y = y, labels = as.character(rev(seq(0.1,0.9,by=.1))), cex=1.3)

  y2 <- rev(seq(0.1,0.9,by=.1))
  x2 <- y/2 + .5
  segments(x2+.01, y2, x2, y2, col="black")
  text(x = x2+.03, y = y2, labels = as.character(seq(0.1,0.9,by=.1)), cex=1.3)

  ## HWE curve
  curve(2 * (x - x^2), from = 0, to = 1, col = "red", lwd = 2, add = TRUE)
}

file.hardy              <- commandArgs()[4] # hardy input file
file.out.controls       <- commandArgs()[5] # output filename controls
file.out.cases          <- commandArgs()[6] # output filename cases
file.out.cases.controls <- commandArgs()[7] # output filename cases and controls

hardy <-read.table(file=file.hardy,header=T,stringsAsFactor=F)

# Controls
genos <-matrix(unlist(strsplit(subset(hardy, hardy$TEST == "UNAFF")$GENO, "/")), ncol=3, byrow=T)
genos <-data.frame(geno.11 = as.numeric(genos[,1]),
                geno.12 = as.numeric(genos[,2]),
                geno.22 = as.numeric(genos[,3]))
jpeg(file=paste(file.out.controls, ".jpg", sep=""), quality=100,width=900,height=700)
makeDefinetti(genos, label = "Controls")
dev.off()

# Cases
genos <-matrix(unlist(strsplit(subset(hardy, hardy$TEST == "AFF")$GENO, "/")), ncol=3, byrow=T)
genos <-data.frame(geno.11 = as.numeric(genos[,1]),
                geno.12 = as.numeric(genos[,2]),
                geno.22 = as.numeric(genos[,3]))
jpeg(file=paste(file.out.cases, ".jpg", sep=""), quality=100,width=900,height=700)
makeDefinetti(genos, label = "Cases")
dev.off()

# Cases and Controls
genos <-matrix(unlist(strsplit(subset(hardy, hardy$TEST == "ALL")$GENO, "/")), ncol=3, byrow=T)
genos <-data.frame(geno.11 = as.numeric(genos[,1]),
                geno.12 = as.numeric(genos[,2]),
                geno.22 = as.numeric(genos[,3]))
jpeg(file=paste(file.out.cases.controls, ".jpg", sep=""), quality=100,width=900,height=700)
makeDefinetti(genos, label = "Cases_Controls")
dev.off()


#simple occupancy model with data in long format (one line per visit)
#this version has List Length as a covariate and Site effect
occDetBUGScode <- function(){
  # Priors
  # state model priors
  for(t in 1:nyear){
    a[t] ~ dunif(-10,10)
  }

  # RANDOM EFFECT for SITE
  for (i in 1:nsite) {
    eta[i] ~ dnorm(0, tau2)       # extra random site-effect op occ. (previously it was mu2: changed Jan 2014)
  }

  tau2 <- 1/(sigma2 * sigma2) # NOT NEEDED IN SIMPLE MODEL
  sigma2 ~ dunif(0, 5)

  # observation model priors
  for (t in 1:nyear) {
    alpha.p[t] ~ dnorm(mu.lp, tau.lp)            # p random year
  }

  mu.lp ~ dnorm(0, 0.01)
  tau.lp <- 1 / (sd.lp * sd.lp)
  sd.lp ~ dunif(0, 5)

  LL.p ~ dunif(dtype2p_min, dtype2p_max)

  # State model
  for (i in 1:nsite){
    for (t in 1:nyear){
      z[i,t] ~ dbern(muZ[i,t]) # True occupancy z at site i
      logit(muZ[i,t])<- a[t] + eta[i] # plus random site effect
    }}

  # Observation model
  # go through the visits and find the matching year and site identity
  for(j in 1:nvisit) {
    #for each visit, find the matching site and year identities
    Py[j]<- z[Site[j],Year[j]]*p[j]
    logit(p[j]) <- alpha.p[Year[j]] + LL.p*logL[j]
    y[j] ~ dbern(Py[j])
    Presi[j] <- abs(y[j]-p[j])
    y.new[j] ~ dbern(Py[j])
    Presi.new[j] <- abs(y.new[j]-p[j])
  }

  # Bayesian Goodness-of-Fit
  fit <- sum(Presi[])
  fit.new <- sum(Presi.new[])

  # Derived parameters state model

  # Finite sample occupancy
  for (t in 1:nyear) {
    psi.fs[t] <- sum(z[1:nsite,t])/nsite
  }

  # Overall trend in occpuancy
  sumY <- sum(psi.fs[1:nyear])
  for (t in 1:nyear) {
    sumxy[t] <- psi.fs[t]*t
  }
  sumXY <- sum(sumxy[1:nyear])
  regres.psi <- (sumXY - ((sumX*sumY)/nyear))/(sumX2 - ((sumX*sumX)/nyear))

  # Derived parameters observation model
  for (t in 1:nyear) {
    pdet.alpha[t] <- exp(alpha.p[t])/(1 + exp(alpha.p[t]))
  }

  # overall trend in pdet.alpha
  sumYpdet <- sum(pdet.alpha[1:nyear])
  for (t in 1:nyear) {
    sumxypdet[t] <- pdet.alpha[t]*t
  }
  sumXYpdet <- sum(sumxypdet[1:nyear])
  regres.pdet <- (sumXYpdet - ((sumX*sumYpdet)/nyear))/(sumX2 - ((sumX*sumX)/nyear))

  # end of model formulation
}


require(caret)
a <- read.csv("/Users/tom/projects-workspace/set-game/data/train-out-colour.csv", header=FALSE)
colnames(a)[colnames(a)=="V1"] <- "label"
a$label <- as.factor(a$label)
set.seed(1)
aFit <- train(label ~ ., data = a, method = "svmRadial", preProc = c("center", "scale"),
              tuneLength = 10,
              tr = trainControl(method = "repeatedcv", repeats = 5, classProbs = TRUE))
aFit

aFitKnn <- train(label ~ ., data = a, method = "knn", preProc = c("center", "scale"))
aFitKnn

# Try using the model to predict test data labels
testData <- read.csv("/Users/tom/projects-workspace/set-game/data/test-out-colour.csv", header=FALSE)
colnames(testData)[colnames(testData)=="V1"] <- "label"
testData$label <- as.factor(testData$label)
testDataNoLabel <- testData[-c(1)]

predictions <- predict(aFitKnn, newdata = testDataNoLabel)
predictions

print(postResample(pred=predictions, obs=as.factor(testData$label)))


#This script is for only calculation of t-test for either COUL /LJ interactions between 2 systems WT and var
#x variale run over residue number
#name has input file name
#change input-output file names

x<-1:343
out<-c()
for(i in x)
{	for(j in x)
	{
		if(j>i)
		{
			#name<-"coul-sr-30sample-"+i+"-"+j+".txt"
			name <-paste0('30sample/coul-sr-30sample-',i,'-',j,'.txt', collapse = "" )  #paste0('coul-sr-30sample-',i,'-',j,'.txt', collapse = "" )
	#	 	cat(i,"\t", j,"\n")
			f<-read.delim(file=name,sep="\t", header=F)
			wt<-f[,2]
			v<-f[,3]
			#t.test(wt,v)
			mwt<-mean(wt)
			mv<-mean(v)
			pval<-t.test(wt,v)$p.value
			diff<-mwt-mv
			absdiff<-abs(diff)
			a<-cbind(i,j,pval)
			out<-rbind(out,a)

			#sink("../pval.txt")
			cat(i,"\t",j,"\t",pval,"\n")
			line=paste(i,' ',j,' ',pval,' ',mwt,' ',mv,' ',diff,' ',absdiff, collapse = "" )
			write(line,file="30-coul-pval.txt",append=TRUE)
		}
	}
}
#sink("../pval.txt")
#print(out)
#sink()


a<- Read.summary.data()

a<-subset(a,Year>=1975)
b<-subset(a,Species=='Cod' )
M2<-aggregate(M2~Year+Age,data=b,sum)

a[a$Species %in% c('Grey seal','H. porpoise'),'SSB'] <-a[a$Species %in% c('Grey seal','H. porpoise'),'N']
SSB<-droplevels(subset(a,Species %in% c('Cod','Grey seal','Whiting') & Quarter==1))
COD<-aggregate(SSB~Year+Species,data=SSB,sum)

CODs<-aggregate(list(maxSSB=COD$SSB),list(Species=COD$Species),max)
#COD<-merge(COD,CODs)
#COD$SSB<-COD$SSB/COD$maxSSB
#COD$maxSSB<-NULL

COD<-reshape(COD,v.names='SSB',timevar='Species',idvar='Year',direction="wide")
names(COD)<-c("Year","COD","GSE","WHG")

a<-merge(M2,COD)
a<-merge(a,M2)
a<-droplevels(subset(a,Age<=3))

cleanup()
newplot(dev='screen',nox=3,noy=4)
by(a,list(a$Age),function(x) {
 plot(x$COD,x$M2,type='b', ylab='M2',xlab='Cod SSB')
 title(main=paste('Age',x[1,'Age']))
})
by(a,list(a$Age),function(x) {
 plot(x$WHG,x$M2,type='b', ylab='M2',xlab='WHG SSB')
 title(main=paste('Age',x[1,'Age']))
})
by(a,list(a$Age),function(x) {
 plot(x$GSE,x$M2,type='b', ylab='M2',xlab='GSE SSB')
 title(main=paste('Age',x[1,'Age']))
})

########################   new try

M2<-Read.part.M2.data()
M<-droplevels(subset(M2,Prey=='Cod' & Prey.age<=3,select=c(Predator,Prey,Year,Quarter,Prey.age,Part.M2)))
M<-aggregate(list(Part.M2=M$Part.M2),list(Year=M$Year,Prey.Age=M$Prey.age,Pred=M$Predator),sum)
head(M)

a<- Read.summary.data()
a$SSB<-a$SSB/1000
a$BIO<-a$BIO/1000
#head(subset(a,Species=='G. gurnards')

a<-subset(a,Quarter==1 & Species %in% c('Grey seal','Cod','Whiting','G. gurnards','H. porpoise') )
a[a$Species %in% c('Grey seal','H. porpoise'),'SSB'] <-a[a$Species %in% c('Grey seal','H. porpoise'),'N']
a[a$Species %in% c('Grey seal','H. porpoise'),'BIO'] <-a[a$Species %in% c('Grey seal','H. porpoise'),'N']
a[a$Species %in% c('G. gurnards'),'SSB'] <-a[a$Species %in% c('G. gurnards'),'BIO']

b<-subset(a,select=c(Species,Age,Year, SSB,BIO))
b<-aggregate(list(SSB=a$SSB,TSB=a$BIO),list(Year=a$Year,Pred=a$Species),sum)
head(b)

ab<-merge(M,b)
#
#  Year        Pred Prey.Age     Part.M2      SSB    TSB
#1 1963         Cod        0 0.379811633 140015.3 319475
#2 1963         Cod        3 0.006765105 140015.3 319475

ab<-droplevels(ab)
xyplot(Part.M2~Year|paste(factor(Prey.Age),Pred),data=ab, #subset=Year>1981,
 scales=list(relation='free') ,
 panel = function(x, y) {
           panel.grid(h = -1, v = 2)
           panel.xyplot(x, y)
           panel.loess(x, y, span=1)
       }
)

xyplot(Part.M2~SSB|paste(factor(Prey.Age),Pred),data=ab, #subset=Year>1981,
 scales=list(relation='free') ,
 panel = function(x, y) {
           panel.grid(h = -1, v = 2)
           panel.xyplot(x, y)
           panel.loess(x, y, span=1)
       }
)

by(ab,list(ab$Prey.Age,ab$Pred),function(x) {
 #aa<-glm(Part.M2*100~Pred:SSB,data=x,family=Gamma(link = "inverse"))
 aa<-glm(Part.M2*100~SSB,data=x)
  print(summary(aa))
})


  df2 <- subset(df, !is.na(df$samplingCount_risky))
  m3 <- lm(rt~samplingCount_risky + samplingCount_safe, df2)
  stargazer(m3,
            type = "text",
            title= "Sample Count Predicting Reaction time",
            column.labels = c("Model 3"),
            dep.var.labels = "Reaction Time (in secs.)",
            star.cutoffs = c(0.05, 0.01,0.001),
            covariate.labels = c("Risky Sample Count", "Safe Sample Count", "Intercept"),
            notes = "")
  rm(df2,m2,m3)


library(tidyverse)
library(caret)
library(xlsx)
library(cluster)
library(factoextra)
library(sqldf)
library(plotly)
library(plotrix)
gait_a = read.xlsx("D:/Downloads/Desktop/gait_datasets_used/cluster2_gait.xlsx",1)
gait_filter <- gait_a[164:9502,]
gait_b <- scale(gait_filter)
k_gait <- kmeans(gait_b, centers = 7, nstart = 25)
cluster_info <- str(k_gait)
fviz_cluster(k_gait,data = gait_b)
#total = 9339
x<-k_gait$cluster
write.csv(x, file="D:/Downloads/Desktop/gait_datasets_used/cluster_result.csv")
cluster_gait <- read.csv("D:/Downloads/Desktop/gait_datasets_used/cluster_result.csv",1)
plot(cluster_gait$Index,cluster_gait$x, pch = 1, cex = 1, col = "blue", main = "Phase Classification", xlab = "Index", ylab = "phase")


#' Pairwise SERE for two samples
#'
#' Compute the SERE coefficient for two samples
#'
#' @param observed \code{matrix} with two columns containing observed counts of two samples
#' @return The SERE coefficient for the two samples
#' @references Schulze, Kanwar, Golzenleuchter et al, SERE: Single-parameter quality control and sample comparison for RNA-Seq, BMC Genomics, 2012
#' @author See paper published

SERE <- function(observed){
  #calculate lambda and expected values
  observed = as.matrix(observed)
  laneTotals <- colSums(observed)
  total <- sum(laneTotals)
  fullObserved <- observed[rowSums(observed)>0,]
  fullLambda <- rowSums(fullObserved)/total
  fullLhat <- fullLambda > 0
  fullExpected<- outer(fullLambda, laneTotals)

  #keep values
  fullKeep <- which(fullExpected > 0)

  #calculate degrees of freedom (nrow*(ncol -1) >> number of parameters - calculated (just lamda is calculated >> thats why minus 1)
  #calculate pearson and deviance for all values
  oeFull <- (fullObserved[fullKeep] - fullExpected[fullKeep])^2/ fullExpected[fullKeep] # pearson chisq test
  dfFull <- length(fullKeep) - sum(fullLhat!=0)

  sqrt(sum(oeFull)/dfFull)
}


library(data.table)
library(stringi)
library(stringr)
library(lubridate)
library(stats)
library(matrixStats)
# We require a specific version of GJRM:
# remotes::install_version("GJRM", "0.2-2")
library(GJRM)

# Declare working directory beforehand in an environment variable
# SPB_COVID_STUDY_PATH = "path_to_your_folder"
# with the aid of usethis::edit_r_environ()
# Restart R session for the changes to make effect
setwd(Sys.getenv('SPB_COVID_STUDY_PATH'))

# Load and prepare the serosurvey data for model fit
source("code/analysis/wave1.5/create_serosurvey_data_for_model_fit.r")

############################
# Parametric sample selection bivariate probit fit

# Define regressors list
basic_regressors <- "agegroup + male + highereduc + higherincome + lives_alone + washing_hands_more + was_sick + selftested_covid + district + interview_week"

# Fit the models with given scenarios
regression_scenarios <- c("basic")

# Define serological tests to consider
serological_tests <- c("IgG_testB", "IgA_or_G_or_M_testC")

# Fit the models with given regressors
for(scenario in regression_scenarios) {

	# Debug: scenario <- "demographic"; serotest <- "IgG_testB"

	regressors_used <- get(paste0(scenario, "_regressors"))

	for(serotest in serological_tests) {

		model_fit <- estimate_bivariate_selection(data = serosurvey_data, subset_condition = NULL, selection_type = "2step", agreementvar = "agreed", clinicvisitvar = "agreed_and_tested", outcomevar = serotest, regressors = regressors_used, semiparametric_age = F, exclusion_restriction_clinicvisit = "offered_taxi", error_distribution = "N", surveyweightsvar = "raking_weight")

		# Save to an R object with a naming convention
		# Example: out.demographic.IgG_testB
		assign(paste("out", scenario, serotest, sep = "."), model_fit)

		print(paste0("Fit model ", scenario, ", test ", serotest))

	}

}

############################
# Prevalence estimation by variable

# Set test characteristics
## Abbott from own validation
sensitivity_igg_abbott <- 0.677
specificity_igg_abbott <- 1

## Genetico CoronaPass from own validation
sensitivity_iga_g_m_genetico <- 0.920
specificity_iga_g_m_genetico <- 1

# Specify which prevalences to estimate
prevalence_types <- c("naive", "univariate")

# Which variables to group by
grouping_vars <- str_trim(unlist(strsplit(basic_regressors, "+", fixed = T)))

# Initiate an object to store the results
prevalence_by_variable_level <- data.table()

for(scenario in regression_scenarios) {

	for(serotest in serological_tests) {

		for(group_var in grouping_vars) {

			for( surveyweight in c("no", "raking") ) {

				# Debug: scenario <- "basic"; serotest <- "IgG_testB"; group_var <- "education_level"

				# Retrieve the specified model
				model <- get(paste("out", scenario, serotest, sep = "."))

				# Set test characteristics
				test_sensitivity <- ifelse(grepl("testB", serotest), sensitivity_igg_abbott, ifelse(grepl("testC", serotest), sensitivity_iga_g_m_genetico, ifelse(grepl("testA", serotest), sensitivity_igg_m_sugentech, NA_real_)))
				test_specificity <- ifelse(grepl("testB", serotest), specificity_igg_abbott, ifelse(grepl("testC", serotest), specificity_iga_g_m_genetico, ifelse(grepl("testA", serotest), specificity_igg_m_sugentech, NA_real_)))

				# Consider a special case when we
				# perform logical OR or AND on tests
				## testB OR testC
				if( serotest == "testB_or_testC") {

					test_sensitivity <- 0.96
					test_specificity <- 1

				}
				## testB AND testC
				if( serotest == "testB_and_testC") {

					test_sensitivity <- 1
					test_specificity <- 0.996

				}

				# Enumerate levels of grouping variable
				# (respecting the order of appearance for ordered factors)
				group_var_levels <- model$fit$gam2$model[[group_var]]

				if( is.factor(group_var_levels) ) {

					group_var_levels <- levels(group_var_levels)

				} else {

					group_var_levels <- unique(group_var_levels)

				}

				# For each level of grouping variable
				for( var in group_var_levels ) {

					# True/False indicators for variable levels
					# Debug: var <- "Primary education"
					## Outcome equation
					var_indicators_outcome <- model$fit$gam2$model[[group_var]] == var
					## Selection equation
					var_indicators_selection <- model$fit$gam1$model[[group_var]] == var

					# Take the subset of survey weights that corresponds to a group of interest
					if( surveyweight != "no" ) {

						group_survey_weights_outcome <- model$fit$survey_weights_outcome[var_indicators_outcome]
						group_survey_weights_selection <- model$fit$survey_weights_visit[var_indicators_selection]

					} else {

						group_survey_weights_outcome <- rep(1, sum(var_indicators_outcome))
						group_survey_weights_selection <- rep(1, sum(var_indicators_selection))

					}

					# Count number
					n_var_indicators_outcome <- sum(var_indicators_outcome)
					n_var_indicators_selection <- sum(var_indicators_selection)

# Store the adjusted and unadjusted versions alongside
					for( adjusted in c(T, F) ) {

						# Naive prevalence by group
						var_prev_naive <- adjust_prev_test_chars(prev_modified(model$fit, ind = var_indicators_outcome, type = "naive", sw = group_survey_weights_outcome, delta = T), sensitivity = ifelse(adjusted, test_sensitivity, 1), specificity = ifelse(adjusted, test_specificity, 1))
						# Univariate prevalence by group
						var_prev_univariate <- adjust_prev_test_chars(prev_modified(model$fit, ind = var_indicators_selection, type = "univariate", sw = group_survey_weights_selection, delta = T), sensitivity = ifelse(adjusted, test_sensitivity, 1), specificity = ifelse(adjusted, test_specificity, 1))
						# Joint prevalence by group
						#var_prev_joint <- adjust_prev_test_chars(prev_modified(model$fit, ind = var_indicators_selection, type = "joint", sw = group_survey_weights_selection, delta = T), sensitivity = ifelse(adjusted, test_sensitivity, 1), specificity = ifelse(adjusted, test_specificity, 1))

						# Append to an object
						## Naive
						prevalence_by_variable_level <- rbind(prevalence_by_variable_level, data.table(serotest = serotest, prevalence_type = "naive", surveyweight = surveyweight, sensitivity = var_prev_naive$sensitivity, specificity = var_prev_naive$specificity, variable = group_var, variable_level = var, lowerbound = var_prev_naive$res[1], pointest = var_prev_naive$res[2], upperbound = var_prev_naive$res[3], n_selection = n_var_indicators_selection, n_outcome = n_var_indicators_outcome), fill = T)
						## Univariate
						prevalence_by_variable_level <- rbind(prevalence_by_variable_level, data.table(serotest = serotest,  prevalence_type = "univariate",  surveyweight = surveyweight, sensitivity = var_prev_univariate$sensitivity, specificity = var_prev_univariate$specificity, variable = group_var, variable_level = var, lowerbound = var_prev_univariate$res[1], pointest = var_prev_univariate$res[2], upperbound = var_prev_univariate$res[3], n_selection = n_var_indicators_selection, n_outcome = n_var_indicators_outcome), fill = T)
						## Joint
						#prevalence_by_variable_level <- rbind(prevalence_by_variable_level, data.table(serotest = serotest,  prevalence_type = "joint",  surveyweight = surveyweight, sensitivity = var_prev_joint$sensitivity, specificity = var_prev_joint$specificity, variable = group_var, variable_level = var, lowerbound = var_prev_joint$res[1], pointest = var_prev_joint$res[2], upperbound = var_prev_joint$res[3], n_selection = n_var_indicators_selection, n_outcome = n_var_indicators_outcome), fill = T)

					}

				}

			}

		}
	}

}

#####
# Compute naive prevalence by blood draw week

## Make data conformable
test_results_basic_regressors_abbott <- na.omit(serosurvey_data[, c(grouping_vars, "draw_week", "IgG_testB"), with = F ])
test_results_basic_regressors_genetico <- na.omit(serosurvey_data[, c(grouping_vars, "draw_week", "IgA_or_G_or_M_testC"), with = F ])

# Test result means and their CIs by week
naive_prevalence_by_draw_sample_week_abbott <- test_results_basic_regressors_abbott[, list(pointest = mean(IgG_testB, na.rm = T), se = sd(IgG_testB, na.rm = T)/sqrt(.N), N = .N), by = "draw_week"]
naive_prevalence_by_draw_sample_week_genetico <- test_results_basic_regressors_genetico[, list(pointest = mean(IgA_or_G_or_M_testC, na.rm = T), se = sd(IgA_or_G_or_M_testC, na.rm = T)/sqrt(.N), N = .N), by = "draw_week"]

naive_prevalence_by_draw_sample_week_abbott[, upperbound := pointest+qnorm(0.975)*se]
naive_prevalence_by_draw_sample_week_abbott[, lowerbound := pointest-qnorm(0.975)*se]

naive_prevalence_by_draw_sample_week_genetico[, upperbound := pointest+qnorm(0.975)*se]
naive_prevalence_by_draw_sample_week_genetico[, lowerbound := pointest-qnorm(0.975)*se]

naive_prevalence_by_draw_sample_week_adjusted <- data.table()

# Apply test performance adjustments to a manually constructed object with naive prevalences
for(w in unique(naive_prevalence_by_draw_sample_week_abbott$draw_week)) {

	# Weekly adjusted and unadjusted prevalence
	for( adjusted in c(T, F) ) {

		abbot_prev <- adjust_prev_test_chars(list(res = unlist(unname(naive_prevalence_by_draw_sample_week_abbott[draw_week == w, c("lowerbound", "pointest", "upperbound")])), prob.lev = 0.05, sim.prev = NA), sensitivity = ifelse(adjusted, sensitivity_igg_abbott, 1), specificity = ifelse(adjusted, specificity_igg_abbott, 1))$res
		names(abbot_prev) <- c("lowerbound", "pointest", "upperbound")

		out_abbott <- data.table(serotest = "IgG_testB", prevalence_type = "naive", surveyweight = "no", sensitivity = ifelse(adjusted, sensitivity_igg_abbott, 1), specificity = ifelse(adjusted, specificity_igg_abbott, 1), variable = "draw_week", variable_level = w, t(abbot_prev), n_outcome = naive_prevalence_by_draw_sample_week_abbott[draw_week == w]$N)

		genetico_prev <- adjust_prev_test_chars(list(res = unlist(unname(naive_prevalence_by_draw_sample_week_genetico[draw_week == w, c("lowerbound", "pointest", "upperbound")])), prob.lev = 0.05, sim.prev = NA), sensitivity = ifelse(adjusted, sensitivity_iga_g_m_genetico, 1), specificity = ifelse(adjusted, specificity_iga_g_m_genetico, 1))$res
		names(genetico_prev) <- c("lowerbound", "pointest", "upperbound")

		out_genetico <- data.table(serotest = "IgA_or_G_or_M_testC", prevalence_type = "naive", surveyweight = "no", sensitivity = ifelse(adjusted, sensitivity_iga_g_m_genetico, 1), specificity = ifelse(adjusted, specificity_iga_g_m_genetico, 1), variable = "draw_week", variable_level = w, t(genetico_prev), n_outcome = naive_prevalence_by_draw_sample_week_genetico[draw_week == w]$N)

		naive_prevalence_by_draw_sample_week_adjusted <- rbind(naive_prevalence_by_draw_sample_week_adjusted, out_abbott, out_genetico)

	}

}

# Append those results to the main data set with prevalence
prevalence_by_variable_level <- rbind(prevalence_by_variable_level, naive_prevalence_by_draw_sample_week_adjusted, fill = T)

# Same, but biweekly
test_results_basic_regressors_abbott[draw_week %in% c(30, 31), draw_biweek := 30.5]
test_results_basic_regressors_abbott[draw_week %in% c(32, 33), draw_biweek := 32.5]

test_results_basic_regressors_genetico[draw_week %in% c(30, 31), draw_biweek := 30.5]
test_results_basic_regressors_genetico[draw_week %in% c(32, 33), draw_biweek := 32.5]

naive_prevalence_by_draw_sample_biweek_abbott <- test_results_basic_regressors_abbott[!is.na(draw_biweek), list(pointest = mean(IgG_testB, na.rm = T), se = sd(IgG_testB, na.rm = T)/sqrt(.N), N = .N), by = "draw_biweek"]
naive_prevalence_by_draw_sample_biweek_genetico <- test_results_basic_regressors_genetico[!is.na(draw_biweek), list(pointest = mean(IgA_or_G_or_M_testC, na.rm = T), se = sd(IgA_or_G_or_M_testC, na.rm = T)/sqrt(.N), N = .N), by = "draw_biweek"]

naive_prevalence_by_draw_sample_biweek_abbott[, upperbound := pointest+qnorm(0.975)*se]
naive_prevalence_by_draw_sample_biweek_abbott[, lowerbound := pointest-qnorm(0.975)*se]

naive_prevalence_by_draw_sample_biweek_genetico[, upperbound := pointest+qnorm(0.975)*se]
naive_prevalence_by_draw_sample_biweek_genetico[, lowerbound := pointest-qnorm(0.975)*se]

naive_prevalence_by_draw_sample_biweek_adjusted <- data.table()

# Apply test performance adjustments to a manually constructed object with naive biweekly prevalences
for(w in unique(naive_prevalence_by_draw_sample_biweek_abbott$draw_biweek)) {

	# Biweekly adjusted and unadjusted prevalence
	for( adjusted in c(T, F) ) {

		abbot_prev <- adjust_prev_test_chars(list(res = unlist(unname(naive_prevalence_by_draw_sample_biweek_abbott[draw_biweek == w, c("lowerbound", "pointest", "upperbound")])), prob.lev = 0.05, sim.prev = NA), sensitivity = ifelse(adjusted, sensitivity_igg_abbott, 1), specificity = ifelse(adjusted, specificity_igg_abbott, 1))$res
		names(abbot_prev) <- c("lowerbound", "pointest", "upperbound")

		out_abbott <- data.table(serotest = "IgG_testB", prevalence_type = "naive", surveyweight = "no", sensitivity = ifelse(adjusted, sensitivity_igg_abbott, 1), specificity = ifelse(adjusted, specificity_igg_abbott, 1), variable = "draw_biweek", variable_level = w, t(abbot_prev), n_outcome = naive_prevalence_by_draw_sample_biweek_abbott[draw_biweek == w]$N)

		genetico_prev <- adjust_prev_test_chars(list(res = unlist(unname(naive_prevalence_by_draw_sample_biweek_genetico[draw_biweek == w, c("lowerbound", "pointest", "upperbound")])), prob.lev = 0.05, sim.prev = NA), sensitivity = ifelse(adjusted, sensitivity_iga_g_m_genetico, 1), specificity = ifelse(adjusted, specificity_iga_g_m_genetico, 1))$res
		names(genetico_prev) <- c("lowerbound", "pointest", "upperbound")

		out_genetico <- data.table(serotest = "IgA_or_G_or_M_testC", prevalence_type = "naive", surveyweight = "no", sensitivity = ifelse(adjusted, sensitivity_iga_g_m_genetico, 1), specificity = ifelse(adjusted, specificity_iga_g_m_genetico, 1), variable = "draw_biweek", variable_level = w, t(genetico_prev), n_outcome = naive_prevalence_by_draw_sample_biweek_genetico[draw_biweek == w]$N)

		naive_prevalence_by_draw_sample_biweek_adjusted <- rbind(naive_prevalence_by_draw_sample_biweek_adjusted, out_abbott, out_genetico)

	}

}

# Append those results to the main data set with prevalence
prevalence_by_variable_level <- rbind(prevalence_by_variable_level, naive_prevalence_by_draw_sample_biweek_adjusted, fill = T)

# Round the results
prevalence_by_variable_level[, c("lowerbound", "pointest", "upperbound") := lapply(.SD, function(x) { round(x*100, 1) }), .SDcols = c("lowerbound", "pointest", "upperbound") ]

# Ordering
setorderv(prevalence_by_variable_level, c("serotest", "prevalence_type", "variable", "variable_level"))

# Save the object with computed prevalences for future use
save(prevalence_by_variable_level, file = "estimates/wave1.5/prevalence_by_variable_level.rdata", compress = "gzip")


bound <- function(x, p = 0.0001) {
    pmax(pmin(x, 1 - p), p)
}

truncate <- function(x, p = 0.01) {
    pmin(pmax(x, p), 1 - p)
}

gfun <- function(a, w) {
    pscore <- plogis(2 - 1 / (- rowSums(w) / 4 + 1))
    return(a * pscore + (1 - a) * (1 - pscore))
}

gdeltafun <- function(a, w, delta){
    pscore <- delta * gfun(1, w) / (delta * gfun(1, w) + 1 - gfun(1, w))
    return(a * pscore + (1 - a) * (1 - pscore))
}

gdelta1 <- function(g, delta){
    delta * g / (delta * g + 1 - g)
}

pl <- function(l, a, w) {
    prob1 <- plogis(rowMeans(w) - a - log(2) + 0.2)
    return(l * prob1 + (1 - l) * (1 - prob1))
}

pz <- function(z, l, a, w) {
    prob1 <- plogis(rowSums(log(3) * w[, -3]) + a - l)
    return(z * prob1 + (1 - z) * (1 - prob1))
}

my <- function(z, l, a, w) {
    plogis(1 - 3 / (2 + rowSums(w) / 3 - l - 3 * a + z))
    ## plogis((rowSums(w) - l + 3 * a * z))
}

pzaw <- function(z, a, w) pz(z, 1, a, w) * pl(1, a, w) + pz(z, 0, a, w) * pl(0, a, w)
pzw  <- function(z, w) pzaw(z, 1, w) * gfun(1, w) + pzaw(z, 0, w) * gfun(0, w)

u <- function(z, a, w) my(z, 1, a, w) * pl(1, a, w) + my(z, 0, a, w) * pl(0, a, w)
v <- function(l, a, w) my(1, l, a, w) * pzaw(1, a, w) + my(0, l, a, w) * pzaw(0, a, w)
s <- function(l, a, w) my(1, l, a, w) * pzw(1, w) + my(0, l, a, w) * pzw(0, w)

ubar <- function(a, w) u(1, a, w) * pzaw(1, a, w) + u(0, a, w) * pzaw(0, a, w)
sbar <- function(a, w) s(1, a, w) * pl(1, a, w) + s(0, a, w) * pl(0, a, w)
vbar <- ubar
q <- function(a, w) u(1, a, w) * pzw(1, w) + u(0, a, w) * pzw(0, w)

simdata <- function(n_obs = 1000) {
    ## helper functions for nuisance parameter estimation
    ## baseline covariate -- simple, binary
    w_1 <- rbinom(n_obs, 1, prob = 0.6)
    w_2 <- rbinom(n_obs, 1, prob = 0.3)
    w_3 <- rbinom(n_obs, 1, prob = pmin(0.2 + (w_1 + w_2) / 3, 1))
    w <- cbind(w_1, w_2, w_3)
    w_names <- paste("W", seq_len(ncol(w)), sep = "")

    ## exposure/treatment
    a <- as.numeric(rbinom(n_obs, 1, prob = gfun(1, w)))

    ## mediator-outcome confounder affected by treatment
    l <- rbinom(n_obs, 1, pl(1, a, w))

    ## mediator (possibly multivariate)
    z <- rbinom(n_obs, 1, pz(1, l, a, w))
    z_names <- "Z"

    ## outcome
    y <- rbinom(n_obs, 1, my(z, l, a, w))

    colnames(w) <- w_names
    ## construct data for output
    dat <- as.data.frame(cbind(W = w, A = a, Z = z, L = l, Y = y))
    return(dat)
}

truth <- function(n_obs = 1e7, delta = 2){

    w_1 <- rbinom(n_obs, 1, prob = 0.6)
    w_2 <- rbinom(n_obs, 1, prob = 0.3)
    w_3 <- rbinom(n_obs, 1, prob = pmin(0.2 + (w_1 + w_2) / 3, 1))
    w <- cbind(w_1, w_2, w_3)
    w_names <- paste("W", seq_len(ncol(w)), sep = "")

    ## exposure/treatment
    a <- as.numeric(rbinom(n_obs, 1, prob = gfun(1, w)))

    ## mediator-outcome confounder affected by treatment
    l <- rbinom(n_obs, 1, pl(1, a, w))

    ## mediator (possibly multivariate)
    z <- rbinom(n_obs, 1, pz(1, l, a, w))
    z_names <- "Z"

    ## outcome
    y <- rbinom(n_obs, 1, my(z, l, a, w))

    eif10 <- pzaw(z, a, w) / pz(z, l, a, w) * (y - my(z, l, a, w)) +
        v(l, a, w) - vbar(a, w) + u(z, a, w)

    eif1d <- gdeltafun(a, w, delta) / gfun(a, w) * pzaw(z, a, w) / pz(z, l, a, w) *
        (y - my(z, l, a, w)) +
        gdeltafun(a, w, delta) / gfun(a, w) * (v(l, a, w) - vbar(a, w) + u(z, a, w)) +
        (1 - gdeltafun(a, w, delta) / gfun(a, w)) *
        (ubar(1, w) * gdeltafun(1, w, delta) + ubar(0, w) * gdeltafun(0, w, delta))

    eif2d <- gdeltafun(a, w, delta) / gfun(a, w) * pzw(z, w) / pz(z, l, a, w) *
        (y - my(z, l, a, w)) +
        gdeltafun(a, w, delta) / gfun(a, w) * (s(l, a, w) - sbar(a, w)) +
        u(z, 1, w) * gdeltafun(1, w, delta) + u(z, 0, w) * gdeltafun(0, w, delta) +
        gdeltafun(a, w, delta) / gfun(a, w) * (q(a, w) - (q(1, w) * gdeltafun(1, w, delta) +
                                                          q(0, w) * gdeltafun(0, w, delta)))

    efbde <- var(eif10 - eif2d)
    efbie <- var(eif2d - eif1d)

    de <- mean(eif10 - eif2d)
    ie <- mean(eif2d - eif1d)

    return(data.frame(parameter = c('DE', 'IE'),
                      truth = c(de, ie),
                      eff_bound = c(efbde, efbie)))

}


#' Function to convert SST data to d18O
#'
#' Takes a matrix of SST data (in degrees C) against time (in days), information
#' about the d18O value (in permille VSMOW) of the water and how it changes
#' through the year and the transfer function used for of the record (e.g.
#' Kim and O'Neil, 1997 or Grossman and Ku, 1986). Converts the SST data to d18O
#' data using the supplied empirical transfer function.
#'
#' @param SST Matrix with a time column (values in days) and an SST column
#' (values in degrees C)
#' @param d18Ow Either a single value (constant d18Ow) or a vector of length
#' equal to the period in SST data (365 days by default) containing information
#' about seasonality in d18Ow. Defaults to constant d18Ow of 0 permille VSMOW
#' (the modern mean ocean value)
#' @param transfer_function String containing the name of the transfer function
#' (for example: \code{"KimONeil97"} or \code{"GrossmanKu86"}). Defaults to
#' Kim and O'Neil (1997).
#' @return A vector containing d18O values for each SST value in \code{"SST"}
#' @references Grossman, E.L., Ku, T., Oxygen and carbon isotope fractionation in biogenic
#' aragonite: temperature effects, _Chemical Geology_ **1986**, _59.1_, 59-74.
#'     \doi{10.1016/0168-9622(86)90057-6}
#' Kim, S., O'Niel, J.R., Equilibrium and nonequilibrium oxygen
#' isotope effects in synthetic carbonates, _Geochimica et Cosmochimica Acta_
#' **1997**, _61.16_, 3461-3475.
#'     \doi{10.1016/S0016-7037(97)00169-5}
#' Dettman, D.L., Reische, A.K., Lohmann, K.C., Controls on the stable isotope
#' composition of seasonal growth bands in aragonitic fresh-water bivalves
#' (Unionidae), _Geochimica et Cosmochimica Acta_ **1999**, _63.7-8_, 1049-1057.
#'     \doi{10.1016/S0016-7037(99)00020-4}
#' Brand, W.A., Coplen, T.B., Vogl, J., Rosner, M., Prohaska, T., Assessment of
#' international reference materials for isotope-ratio analysis (IUPAC Technical
#' Report), _Pure and Applied Chemistry_ **2014**, _86.3_, 425-467.
#'     \doi{10.1515/pac-2013-1023}
#' Kim, S.-T., Coplen, T. B., and Horita, J.: Normalization of stable
#' isotope data for carbonate minerals: Implementation of IUPAC
#' guidelines, Geochim. Cosmochim. Ac. **2015** 158, 276-289.
#'     \doi{10.1016/j.gca.2015.02.011}
#' @examples
#' # Create dummy SST data
#' t <- seq(1, 40, 1)
#' T <- sin((2 * pi * (seq(1, 40, 1) - 8 + 10 / 4)) / 10)
#' SST <- cbind(t, T)
#' # Run d18O model function
#' d18O <- d18O_model(SST, 0, "KimONeil97")
#' @export
d18O_model <- function(SST, # Function that converts SST values into d18O
    d18Ow = 0, # Information on the d18O of seawater (d18Ow), should be either one single number (constant) or a vector of length 365 (value for every day of the year)
    transfer_function = "KimONeil97" # Supply transfer function. Current options are: Kim and O'Neil (calcite calibration; 1997; "KimONeil97") or Grossman and Ku (aragonite calibration; 1986; "GrossmanKu86")
    ){

    if(!is.numeric(d18Ow)){
        d18Ow <- rep(0, length(SST[,1])) # Set default d18Ow vector to constant at d18Ow = 0
    }else if(length(d18Ow) == 1){
        d18Ow <- rep(d18Ow, length(SST[,1])) # Create constant d18Ow vector if only one number is given
    }else{
        d18Ow <- c(0, rep(d18Ow, length(SST[,1])/length(d18Ow))) # If d18Ow is a vector with more than one value, multiply it to reach the same length of SST (multiply by "years")
    }
    if(transfer_function == "KimONeil97"){
        d18Oc <- cbind(SST[,1], (exp((18.03 * 1000 / (SST[,2] + 273.15) - 32.42) / 1000) - 1) * 1000 + (0.97001 * d18Ow - 29.99)) # Use Kim and O'Neil (1997) with conversion between VSMOW and VPDB by Brand et al. (2014) and Kim et al. (2015)
    }else if(transfer_function == "GrossmanKu86"){
        d18Oc <- cbind(SST[,1], (20.6 - SST[,2]) / 4.34 + d18Ow + 0.2) # Use Grossmann and Ku (1986) modified by Dettmann et al. (1999)
    }else{
        return("ERROR: Supplied transfer function is not recognized")
    }
    return(d18Oc)
}


FWEIGHT<-function(data2=FAge_w, sy=1978, fy=fyear){
  require(mgcv)

  data2$PERIOD<-"F"
  data2$PERIOD[data2$YEAR>1990]<-"D1"
  data2$PERIOD[data2$YEAR>1995]<-"D2"
  data2$PERIOD<-as.factor(data2$PERIOD)

   test<-gam(log(WEIGHT)~PERIOD+as.factor(YEAR)+s(AGE,by=PERIOD,YEAR),gamma=1.4,data=data2)
   test1<-gam(log(WEIGHT)~PERIOD+s(AGE,by=as.factor(PERIOD)),gamma=1.4,data=data2)

  FWeight<-subset(data2,!is.na(data2$WEIGHT))
  FWeight$AGE1<-FWeight$AGE
  FWeight$AGE1[FWeight$AGE>15]<-15
  FWEIGHT<-aggregate(list(WEIGHT=FWeight$WEIGHT),by=list(AGE=FWeight$AGE1,YEAR=FWeight$YEAR, PERIOD=FWeight$PERIOD),FUN=mean)
  FNUMBER<-aggregate(list(NUMBER=FWeight$WEIGHT),by=list(AGE=FWeight$AGE1,YEAR=FWeight$YEAR,PERIOD=FWeight$PERIOD),FUN=length)
  FWEIGHT$NUMBER<-FNUMBER$NUMBER
  grid=expand.grid(YEAR=sort(unique(FWEIGHT$YEAR)),AGE=c(min(data2$AGE):15))
  FWEIGHT_A<-merge(grid,FWEIGHT,all=T)
  FWEIGHT_A$NUMBER[is.na(FWEIGHT_A$NUMBER)]<-0
  FWEIGHT_A$PERIOD<-"F"
  FWEIGHT_A$PERIOD[FWEIGHT_A$YEAR>1990]<-"D1"
  FWEIGHT_A$PERIOD[FWEIGHT_A$YEAR>1995]<-"D2"
  FWEIGHT_A$PERIOD<-as.factor(FWEIGHT_A$PERIOD)

  #test<-gam(log(WEIGHT)~PERIOD+as.factor(YEAR)+s(AGE,by=PERIOD,YEAR),gamma=1.4,data=subset(FWEIGHT_A,is.na(FWEIGHT_A$AGE)==F))

  FWEIGHT_A$pred<-exp(predict(test,newdata=FWEIGHT_A))
  FWEIGHT_A$WEIGHT2[FWEIGHT_A$NUMBER>=20]<-FWEIGHT_A$WEIGHT[FWEIGHT_A$NUMBER>=20]
  FWEIGHT_A$WEIGHT2<-FWEIGHT_A$pred
  #FWEIGHT_A$WEIGHT2<-FWEIGHT_A$WEIGHT
  #FWEIGHT_A$WEIGHT2[is.na(FWEIGHT_A$WEIGHT2)==T]<-FWEIGHT_A$pred[is.na(FWEIGHT_A$WEIGHT2)==T]

  GRID<-expand.grid(YEAR=c(sy:fy),AGE=c(2:15))
  FWEIGHT_B<-merge(GRID,FWEIGHT_A,all=T)
  FWEIGHT_B$PERIOD<-"F"
  FWEIGHT_B$PERIOD[FWEIGHT_B$YEAR>1990]<-"D1"
  FWEIGHT_B$PERIOD[FWEIGHT_B$YEAR>1995]<-"D2"
  FWEIGHT_B$PERIOD<-as.factor(FWEIGHT_B$PERIOD)

  FWEIGHT_B$pred<-exp(predict(test1,newdata=FWEIGHT_B))
  #FWEIGHT_B$WEIGHT2[is.na(FWEIGHT_B$WEIGHT)==F]<-FWEIGHT_B$WEIGHT[is.na(FWEIGHT_B$WEIGHT)==F]
  FWEIGHT_B$WEIGHT2[is.na(FWEIGHT_B$WEIGHT2)==T]<-FWEIGHT_B$pred[is.na(FWEIGHT_B$WEIGHT2)==T]

  F_AGE_WEIGHT<-data.frame(matrix(ncol=15,nrow=length(unique(FWEIGHT_B$YEAR))))
  names(F_AGE_WEIGHT)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
  F_AGE_WEIGHT$YEAR<-c(sy:fy)

  Years1<-c(sy:fy)
  for( i in 1:length(Years1)){
  F_AGE_WEIGHT[i,2:15]<-FWEIGHT_B$WEIGHT2[FWEIGHT_B$YEAR==Years1[i]][1:14]
  }

  FWEIGHT<-list( FWEIGHT=FWEIGHT_B,AGE_WEIGHT=F_AGE_WEIGHT)
  FWEIGHT
}


## EWAS of schizophrenia
## uses a standard linear regression model

args<-commandArgs(trailingOnly = TRUE)
source(args[1])

setwd(dataDir)

load(normData)

## remove total samples and cell types with less than 10 samples
pheno<-pheno[which(pheno$Cell.type != "Total"),]
nSample<-table(pheno$Cell.type)
pheno<-pheno[pheno$Cell.type %in% names(nSample[which(nSample > 9)]),]

celltypenormbeta<-celltypenormbeta[,pheno$Basename]

outtab<-matrix(data = NA, ncol = 26, nrow = nrow(celltypenormbeta))
rownames(outtab)<-rownames(celltypenormbeta)
colnames(outtab)<-c("SCZ_coeff", "SCZ_SE", "SCZ_P", "CellType_P", "NeuN_coeff", "NeuN_SE", "NeuN_P", "SOX10_coeff", "SOX10_SE", "SOX10_P", "CellType_SCZ_P", "SCZ_coeff", "SCZ_SE", "SCZ_P", "NeuN_coeff", "NeuN_SE", "NeuN_P", "SOX10_coeff", "SOX10_SE", "SOX10_P", "NeuN_SCZ_coeff", "NeuN_SCZ_SE","NeuN_SCZ_P", "SOX10_SCZ_coeff", "SOX10_SCZ_SE","SOX10_SCZ_P")

for(i in 1:nrow(celltypenormbeta)){

	model<-lm(celltypenormbeta[i,] ~ pheno$Phenotype + pheno$CCDNAmAge + pheno$Sex + pheno$Cell.type + pheno$Tissue.Centre)
	ctNull<-lm(celltypenormbeta[i,] ~ pheno$Phenotype + pheno$CCDNAmAge + pheno$Sex  + pheno$Tissue.Centre)
	modelInt<-lm(celltypenormbeta[i,] ~ pheno$Phenotype + pheno$CCDNAmAge + pheno$Sex + pheno$Cell.type + pheno$Phenotype * pheno$Cell.type + pheno$Tissue.Centre)
	outtab[i,1:3]<-summary(model)$coefficients["pheno$PhenotypeControl",c(1,2,4)]
	outtab[i,4]<-anova(model, ctNull)[2,6]
	outtab[i,5:7]<-summary(model)$coefficients["pheno$Cell.typeNeuN +ve",c(1,2,4)]
	outtab[i,8:10]<-summary(model)$coefficients["pheno$Cell.typeSox10 +ve",c(1,2,4)]
	outtab[i,11]<-anova(modelInt,model)[2,6]
	outtab[i,12:14]<-summary(modelInt)$coefficients["pheno$PhenotypeControl",c(1,2,4)]
	outtab[i,15:17]<-summary(modelInt)$coefficients["pheno$Cell.typeNeuN +ve",c(1,2,4)]
	outtab[i,18:20]<-summary(modelInt)$coefficients["pheno$Cell.typeSox10 +ve",c(1,2,4)]
	outtab[i,21:23]<-summary(modelInt)$coefficients["pheno$PhenotypeControl:pheno$Cell.typeNeuN +ve",c(1,2,4)]
	outtab[i,24:26]<-summary(modelInt)$coefficients["pheno$PhenotypeControl:pheno$Cell.typeSox10 +ve",c(1,2,4)]
}

save(outtab, file = "Analysis/Schizophrenia/LM.rdata")


# [Contoh Pemodelan Decision Tree dengan Machine Learning](https://academy.dqlab.id/main/livecode/81/152/657)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
# Menggunakan C5.0
drop_columns <- c("kpr_aktif", "pendapatan_setahun_juta", "risk_rating", "rata_rata_overdue")
datafeed <- dataCreditRating[ , !(names(dataCreditRating) %in% drop_columns)]
modelKu <- C5.0(datafeed, as.factor(dataCreditRating$risk_rating))
summary(modelKu)

# [Data Preparation untuk Class Variable](https://academy.dqlab.id/main/livecode/81/153/659)
library("openxlsx")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
str(dataCreditRating)
# Melakukan konversi kolom risk_rating menjadi factor
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
# Melihat struktur setelah konversi
str(dataCreditRating)

# [Data Preparation untuk Input Variables](https://academy.dqlab.id/main/livecode/81/153/660)
library("openxlsx")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Merubah tipe data class variable sebagai factor
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
str(dataCreditRating)
# Menghilangkan beberapa variable input dari dataset
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
str(datafeed)

# [Mempersiapkan Training dan Testing Set](https://academy.dqlab.id/main/livecode/81/153/662)
library("openxlsx")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan porsi index acak untuk training dan testing set
set.seed(100)
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]

str(input_training_set)
str(class_training_set)
str(input_testing_set)

# [Menghasilkan Model dengan Fungsi C5.0](https://academy.dqlab.id/main/livecode/81/153/663)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan dan menampilkan summary model
risk_rating_model <- C5.0(input_training_set, class_training_set)
summary(risk_rating_model)

# [Menghasilkan Plot dari Model C5.0](https://academy.dqlab.id/main/livecode/81/153/696)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan dan menampilkan summary model
risk_rating_model <- C5.0(input_training_set, class_training_set)
plot(risk_rating_model)

# [Label dari Class](https://academy.dqlab.id/main/livecode/81/154/665)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
summary(risk_rating_model)

# [Jumlah Data dan Variable yang Digunakan](https://academy.dqlab.id/main/livecode/81/154/673)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan", "kpr_aktif")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 780)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
summary(risk_rating_model)

# [Merubah Label Class Variable](https://academy.dqlab.id/main/livecode/81/154/691)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating[dataCreditRating$risk_rating == "1"]  <-  "satu"
dataCreditRating$risk_rating[dataCreditRating$risk_rating == "2"]  <-  "dua"
dataCreditRating$risk_rating[dataCreditRating$risk_rating == "3"]  <-  "tiga"
dataCreditRating$risk_rating[dataCreditRating$risk_rating == "4"]  <-  "empat"
dataCreditRating$risk_rating[dataCreditRating$risk_rating == "5"]  <-  "lima"
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
summary(risk_rating_model)

# [Menggunakan Fungsi Predict](https://academy.dqlab.id/main/livecode/81/155/672)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
# menggunakan model untuk prediksi testing set
predict(risk_rating_model, input_testing_set)

# [Menggabungkan Hasil Prediksi](https://academy.dqlab.id/main/livecode/81/155/693)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
# menyimpan hasil prediksi testing set ke dalam kolom hasil_prediksi
input_testing_set$risk_rating <- dataCreditRating[-indeks_training_set,]$risk_rating
input_testing_set$hasil_prediksi <- predict(risk_rating_model, input_testing_set)
# menampilkan variable input_testing_set
print(input_testing_set)

# [Membuat Table Confusion Matrix](https://academy.dqlab.id/main/livecode/81/155/686)
library("openxlsx")
library("C50")
library("reshape2")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
# menyimpan risk_rating dari data awal dan hasil prediksi testing set ke dalam kolom hasil_prediksi
input_testing_set$risk_rating <- dataCreditRating[-indeks_training_set,]$risk_rating
input_testing_set$hasil_prediksi <- predict(risk_rating_model, input_testing_set)
# membuat confusion matrix
dcast(hasil_prediksi ~ risk_rating, data=input_testing_set)

# [Jumlah Data dengan Prediksi Benar](https://academy.dqlab.id/main/livecode/81/155/701)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
# menyimpan risk_rating dari data awal dan hasil prediksi testing set ke dalam kolom hasil_prediksi
input_testing_set$risk_rating <- dataCreditRating[-indeks_training_set,]$risk_rating
input_testing_set$hasil_prediksi <- predict(risk_rating_model, input_testing_set)
# Menghitung jumlah prediksi yang benar
nrow(input_testing_set[input_testing_set$risk_rating==input_testing_set$hasil_prediksi,])

# [Jumlah Data dengan Prediksi Salah](https://academy.dqlab.id/main/livecode/81/155/702)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan model
risk_rating_model <- C5.0(input_training_set, class_training_set, control = C5.0Control(label="Risk Rating"))
# menyimpan risk_rating dari data awal dan hasil prediksi testing set ke dalam kolom hasil_prediksi
input_testing_set$risk_rating <- dataCreditRating[-indeks_training_set,]$risk_rating
input_testing_set$hasil_prediksi <- predict(risk_rating_model, input_testing_set)
# Menghitung jumlah prediksi yang salah
nrow(input_testing_set[input_testing_set$risk_rating!=input_testing_set$hasil_prediksi,])

# [Mempersiapkan Data Pengajuan Baru](https://academy.dqlab.id/main/livecode/81/156/682)
# Membuat data frame aplikasi baru
aplikasi_baru <- data.frame(jumlah_tanggungan = 6, durasi_pinjaman_bulan = 12)
print(aplikasi_baru)

# [Melakukan Prediksi terhadap Data Pengajuan Baru](https://academy.dqlab.id/main/livecode/81/156/681)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan dan menampilkan summary model
risk_rating_model <- C5.0(input_training_set, class_training_set)
# Membuat data frame aplikasi baru
aplikasi_baru <- data.frame(jumlah_tanggungan = 6, durasi_pinjaman_bulan = 12)
# melakukan prediksi
predict(risk_rating_model, aplikasi_baru)

# [Merubah Durasi Pinjaman](https://academy.dqlab.id/main/livecode/81/156/692)
library("openxlsx")
library("C50")
# Mempersiapkan data
dataCreditRating <- read.xlsx(xlsxFile = "https://academy.dqlab.id/dataset/credit_scoring_dqlab.xlsx")
# Mempersiapkan class dan input variables
dataCreditRating$risk_rating <- as.factor(dataCreditRating$risk_rating)
input_columns <- c("durasi_pinjaman_bulan", "jumlah_tanggungan")
datafeed <- dataCreditRating[ , input_columns ]
# Mempersiapkan training dan testing set
set.seed(100) # untuk menyeragamkan hasil random antar tiap komputer
indeks_training_set <- sample(900, 800)
# Membuat dan menampilkan training set dan testing set
input_training_set <- datafeed[indeks_training_set,]
class_training_set <- dataCreditRating[indeks_training_set,]$risk_rating
input_testing_set <- datafeed[-indeks_training_set,]
# menghasilkan dan menampilkan summary model
risk_rating_model <- C5.0(input_training_set, class_training_set)
# Membuat data frame aplikasi baru
aplikasi_baru <- data.frame(jumlah_tanggungan = 6, durasi_pinjaman_bulan = 64 )
# melakukan prediksi
predict(risk_rating_model, aplikasi_baru)

R/Kelas Penerapan/Data Science in Finance Credit Risk Analysis/Data Science in Finance Credit Risk Analysis.r


executeHClust <- function(dataSetTransformed, base, definitions, executionStatus) {

  # loading packages
  loadRankingPackages()

  # loading functions
  source(here("R/functions", "coverage.r"))
  source(here("R/functions", "utils.r"))
  source(here("R/functions", "chart.r"))

  # generating a random folder name
  folderName <- randomName()
  folderName <- paste("H", executionStatus$BaseSelected, folderName, sep="_")
  createPath(here("R/results", executionStatus$Tecnique, folderName))

  executionStatus$IdExecution <- folderName

  # CONSTANTS
  K <- executionStatus$params$tecnique$k
  numberOfAttributes <- length(as.array(names(dataSetTransformed)))

  ms <- dist(dataSetTransformed[,2:numberOfAttributes], method = "euclidean")
  agrupamento <- hclust(ms, method = "ward.D")

  grupos <- cutree(agrupamento, K)

  get_cluster <- head(grupos,1)
  # = 24

  # recuperando os sistemas no mesmo cluster
  systems_candidates <- dataSetTransformed[grupos==get_cluster,]

  pdf(here("R/results", executionStatus$Tecnique, folderName, "hclust.pdf"), width = 250, height = 100)
  plot(agrupamento, main = "Agrupamento Hierárquico Aglomerativo", xlab = "Sistemas", ylab = "Distância")

  rect.hclust(agrupamento, k=K, border="red")

  executionStatus$AmountOfRecomendedSystems <- nrow(systems_candidates)

  if(nrow(systems_candidates) < executionStatus$amountOfCandidatesRecomendation)
    closest_systems_candidates <- systems_candidates[0:nrow(systems_candidates),]
  else
    closest_systems_candidates <- systems_candidates[0:executionStatus$amountOfCandidatesRecomendation,]

  # coverage status
  executionStatus <- calculateCoverageStatus(closest_systems_candidates, executionStatus, folderName)

  # generate HeatMap
  generateHeatMap(closest_systems_candidates, executionStatus, folderName)

  executionStatus
}


  ts.collapse = function ( x, vars ) {
    out = NULL
    for (v in vars) {
      u = x[which(x$variable==v),]
      wm = NULL
      for (w in sort(unique(as.numeric(as.character(u$yr))))) {
        q = u[ which(u$yr==w), ]
        mean = wtd.mean(q$mean, q$sumwgt, normwt=T, na.rm=T)
        variance = wtd.var(q$mean, q$sumwgt, normwt=T, na.rm=T) # from Hmisc
        nsets = length(is.finite(q$mean))
        wm = data.frame(mean=mean, variance=variance, nsets=nsets, yr=w, variable=v )
        out = rbind(out, wm)
      }
    }
  return (out)
  }


#######################################################################
# A visual and qualitative comparison with SW-RASTER
# This is basically an addition to a benchmark performed in
# "Introduction to stream: An Extensible Framework for Data Stream Clustering Research with R"
# — by Hahsler, M., Bolanos, M. and Forrest, J.
set.seed(1000)
library("stream")
if(!exists('SWRaster', mode='character')) source('swraster.r')

# Store stream to memory so that it can be reset for each algorithm
stream <- DSD_Memory(DSD_BarsAndGaussians(noise=0.1), n = 2000)

algorithms <- list(
  # 'Sample'= DSC_TwoStage(micro = DSC_Sample(k = 100),
  #                        macro = DSC_Kmeans(k = 4)),
  'Window'= DSC_TwoStage(micro = DSC_Window(horizon = 100),
                         macro = DSC_Kmeans(k = 4)),
  'D-Stream' = DSC_DStream(gridsize = 0.7, Cm = 1.5),
  # 'BICO' = DSC_BICO(k = 3, p = 10, space = 100, iterations = 10),
  'DBSTREAM' = DSC_DBSTREAM(r = 0.55),
  'SW-RASTER' = DSC_SWRaster(0.3, m=5, t=7, window_size=3, period_size = 1000)
)

# Clustering
for(a in algorithms) {
  reset_stream(stream)
  t <- system.time({update(a, stream, 2000) })
  print(a)
  print(t)
}

# Plotting
op <- par(no.readonly = TRUE)
layout(mat = matrix(1:length(algorithms), ncol = 2))
for(a in algorithms) {
  reset_stream(stream)
  plot(a, stream, main = description(a), assignment = FALSE, weights = FALSE, type = "both")
}
par(op)

# Evaluations
res <- sapply(algorithms, nclusters, type = "micro")
print(res)

evaluations <- sapply(algorithms, FUN=function(a) {
  reset_stream(stream, pos = 1001)
  evaluate(
    a, stream,
    measure = c("numMacroClusters", "numMicroClusters", "purity", "SSQ", "cRand", "silhouette", "Manhattan"),
    type = "micro",
    n = 500
  )
})
print(evaluations)