# -*- encoding: utf-8 -*-

# 目的: 实现基于网格的SVM近邻聚类算法(GCASK)，同时进行数值模拟以及复杂度分析

##########################################################
# 设置工作路径
##########################################################
setwd('E:/projects/grid_svm_knn/data')
# setwd('D:/个人/坚果云同步/我的坚果云/论文/grid_svm_knn/data')
###########################################################
# 基于网格的SVM近邻聚类算法相关代码
###########################################################

# 对数据空间进行网格化，返回各个维度上网格化的边界
Gridding <- function(X,l_grid=0){
    # 得到X的属性个数
    p <- ncol(X)
    # 得到X样本点个数
    n <- nrow(X)
    # 计算得到各个属性维度的最大值和最小值，确定数据空间的范围
    X_range <- matrix(ncol=2,nrow=p)
    # X_range的第一列为每个维度上的最大值
    X_range[,1] <- apply(X,2,max)
    # X_range的第二列为每个维度上的最小值
    X_range[,2] <- apply(X,2,min)
    # 若X_range的第一列和第二列相同，说明该属性取值都相同，应该删除该属性
    # Index <- (X_range[,1] == X_range[,2])
    # X <- X[,!Index]
    # X_range <- X_range[!Index,]
    # p <- ncol(X)
    # 计算整个空间的体积
    V <- cumprod(X_range[,1]-X_range[,2])[p]
    # 计算小网格的边长
    if (l_grid == 0){
        l_grid <- (V/n) ** (1/p)
    }
    # 计算每个维度上网格的个数
    n_grid <- ceiling((X_range[,1]-X_range[,2]) / l_grid)
    # 用DividingLine来存放各个维度上网格的划分边界线
    DivdingLine <- matrix(ncol=p,nrow=max(n_grid)+1)
    for(i in 1:p){
        DivdingLine[1:(n_grid[i]+1),i] <- X_range[i,2] + ((0:n_grid[i]) * l_grid)
    }
    Lst <- list(DivdingLine=DivdingLine,n_grid=n_grid)
    return(Lst)
}

# 判断格子里有没有点
box_point <- function(X,border){
    Index <- 1:nrow(X)
    p <- ncol(X)
    for(i in 1:p){
        new_X <- X[Index,]
        new_X <- matrix(new_X,ncol=p)
        Index <- which( (new_X[,i]>=border[i,1]) & (new_X[,i]<=border[i,2]) )
        if(length(Index) == 0){
            return(1)
        }
    }
    return(0)
}

# 生成小格子边界的索引
get_combinations <- function(n_grid,Index_matrix,Index = 1,row=1){
    for(i in 1:n_grid[Index]){
        if(Index == length(n_grid)){
            for(j in 1:n_grid[Index]){
                Index_matrix[which(is.na(Index_matrix[,Index]))[1],Index] <- j
                row <- row + 1
            }
            return(list(Index_matrix=Index_matrix, row=row))
        }else{
            Index_matrix[row:nrow(Index_matrix),Index] <- i
            Index <- Index + 1
            Lst <- get_combinations(n_grid,Index_matrix,Index,row)
            Index <- Index - 1
            row <- Lst$row
            Index_matrix <- Lst$Index_matrix
        }
    }
    return(Lst)
}

# 对稀疏区域进行插点
get_nothing_point <- function(X,l_grid=0){
    # 得到网格边界
    Lst <- Gridding(X,l_grid)
    DivdingLine <- Lst$DivdingLine
    n_grid <- Lst$n_grid
    # 得到网格索引矩阵
    Index_matrix <- matrix(ncol=length(n_grid),nrow=cumprod(n_grid)[length(n_grid)])
    Lst <- get_combinations(n_grid,Index_matrix,Index = 1,row=1)
    Index_matrix <- Lst$Index_matrix
    # 生成一个插点矩阵
    point_matrix <- matrix(nrow=nrow(Index_matrix),ncol=1)
    # 生成小格子border，并进行判别
    border <- matrix(ncol=2,nrow=ncol(X))
    for(i in 1:nrow(Index_matrix)){
        for(j in 1:ncol(Index_matrix)){
            border[j,1] <- DivdingLine[Index_matrix[i,j],j]
            border[j,2] <- DivdingLine[Index_matrix[i,j]+1,j]
        }
        point_matrix[i] <- box_point(X,border)
    }
    Index_matrix <- cbind(Index_matrix,point_matrix)
    # 得到稀疏区域点的坐标
    Index_matrix <- Index_matrix[Index_matrix[,ncol(Index_matrix)]==1 ,]
    nothing_point <- matrix(ncol=ncol(X),nrow=nrow(Index_matrix))
    for(i in 1:nrow(Index_matrix)){
        for(j in 1:ncol(X)){
            nothing_point[i,j] <- (DivdingLine[Index_matrix[i,j],j] + DivdingLine[Index_matrix[i,j]+1,j]) / 2
        }
    }
    return(nothing_point)
}

# 生成有监督学习的数据
get_newdata <- function(X,l_grid=0){
    nothing_point <- get_nothing_point(X,l_grid)
    label0 <- matrix(0,nrow=nrow(nothing_point),ncol=1)
    X1 <- cbind(nothing_point,label0)
    label1 <- matrix(1,nrow = nrow(X),ncol=1)
    X2 <- cbind(X,label1)
    newdata <- rbind(X1,X2)
    return(newdata)
}

# 找到最近的k个点
nearest_k_point <- function(x,X,C_S,k){
    x <- matrix(rep(x,nrow(X)), byrow = TRUE, ncol = ncol(X))
    dis_matrix <- diag((x-X) %*% t(x-X))
    dis_matrix[C_S] <- max(dis_matrix)+1
    Index <- c()
    kk <- sum(!((1:nrow(X)) %in% C_S))
    k <- min(k,kk)
    if(k==0){return(Index)}
    for(i in 1:k){
        Index <- c(Index,which.min(dis_matrix))
        dis_matrix[Index[i]] <- max(dis_matrix)+1
    }
    return(Index) # Index中最后的那个就是最远的那个
}

# 判断最近的k个点中有几个要生成新类
new_class_point <- function(x,X,Index,model){
    x <- matrix(rep(x,length(Index)), byrow = TRUE, ncol = ncol(X))
    med <- as.data.frame((x + X[Index,])/2)
    colnames(med) <- colnames(X)
    pred <- predict(model,med)
    # 需要生成新类的点
    newclass_point <- Index[!(as.logical(as.numeric(pred)-1))]
    # 不需要生成新类的点
    oldclass_point <- Index[as.logical(as.numeric(pred)-1)]
    point <- list(newclass_point=newclass_point, oldclass_point=oldclass_point)
    return(point)
}

NewClass <- function(class_list,k,Index){
    # k表示当前有几个类
    class_list[[k]] <- Index
    return(class_list)
}

# 函数：合并到上一类
CombindClass <- function(class_list,k,Index){
    # k表示当前类的个数
    class_list[[k]] <- c(class_list[[k]],Index)
    return(class_list)
}

# 融合形成新类
Combind <- function(X,C,C_S,model,class_list,k,k_class=0,Index1=1){
    # 若是第一个点，先生成一个类
    if(k_class == 0){
        k_class <- k_class+1
        class_list <- list()
        class_list[k_class] <- C[Index1]
        C_S <- c(C_S,C[Index1])
        #print(X[Index1,])
        #points(X[Index1,1],X[Index1,2],col=k_class,pch=18)
        #pause()
    }

    # 有了类之后可以进行判别聚类了
    # 只要还有点没有分类就执行代码
    while(length(C_S) <= length(C)){
        #readline('请按回车')
        # 找到聚类点
        #if(exists('new_center')){
        #    x <- new_center
        #}else{
        #    x <- X[C[Index1],]
        #}
        x <- X[C[Index1],]
        # 找到最近的k个点
        Index <- nearest_k_point(x,X,C_S,k)
        if(is.null(Index)){return(class_list)}
        # 对是否每个k近邻点需要生成新类进行分析
        point <- new_class_point(x,X,Index,model)
        # 判断是不是所有的点都需要生成新类
        if(length(point$newclass_point) == length(Index)){ # 所有点都要生成新类
            # 找到最近的那个点
            Index2 <- Index[1]
            C_S <- c(C_S,C[Index2])
            # 生成新类
            k_class <- k_class + 1
            class_list <- NewClass(class_list,k_class,C[Index2])
            #points(X[Index2,1],X[Index2,2],pch=20,col=k_class)
            #pause()
            Index1 <- Index2
        }else{
            Index2 <- point$oldclass_point
            C_S <- c(C_S,C[Index2])
            # 合并类
            class_list <- CombindClass(class_list,k_class,C[Index2])
            #points(X[Index2,1],X[Index2,2],pch=20,col=k_class)
            #pause()
            #Index1 <- Index2[length(Index2)] # 选择最远的同类点作为下一个迭代点
            #this_class_points <- X[class_list[[length(class_list)]],]
            #new_center <- apply(this_class_points, 2, mean)
            Index1 <- Index2[1] # 选择最近的同类点作为下一个迭代点
        }
    }
    return(class_list)
}

# 噪声点识别
get_noise_point<- function(dat,pred){
    index_1 <- sum(dat$g==0)
    noise_index <- dat$g == 1 & pred != dat$g
    noise_point <- dat[noise_index,]
    row.names(noise_point) <- as.numeric(row.names(noise_point)) - index_1
    not_noise_point_index <- dat$g == 1 & pred == dat$g
    not_noise_point <- dat[not_noise_point_index,]
    row.names(not_noise_point) <- as.numeric(row.names(not_noise_point)) - index_1
    res <- list(noise_point=noise_point, not_noise_point=not_noise_point)
    return(res)
}

grid_svm_knn <- function(newdata, gamma ,cost, k, Index1){
    # 若是没有加载e1071则加载该包
    if(!('e1071' %in% (.packages()))){library(e1071)}
    mydata <- get_newdata(newdata,l_grid = 0)
    dat <- as.data.frame(mydata)
    colnames(dat)[ncol(dat)] <- 'g'
    dat$g<- as.factor(dat$g)
    gamma <- 50
    model <- svm(g~.,data = dat,type='C',kernel='radial',gamma=gamma,cost=cost)
    #plot(model,dat)
    pred <- predict(model,dat[,-ncol(dat)])
    X <- as.matrix(newdata[,1:2])
    res <- get_noise_point(dat,pred)
    X <- as.matrix(res$not_noise_point[,1:2])
    index_X <- as.numeric(row.names(res$not_noise_point))
    C <- 1:nrow(X)
    C_S <- c()
    class_list <- list()
    class_list <- Combind(X,C,C_S,model,class_list,k = k, Index1=Index1)
    noise_point <- as.numeric(row.names(res$noise_point))
    #clusters_result <- list(class_list = class_list, noise_point = noise_point)
    # 对结果进行整理
    pred <- rep(0, dim(newdata)[1])
    for(i in 1:length(class_list)){
        pred[index_X[class_list[[i]]]] <- i
    }
    return(pred)
}

#########################################################################################
# 动态分位数Kmeans算法
#########################################################################################
Radius.KMeans <- function(x,p,q=0.5,t=1.5){
    lst <- FILTER(x,11,q,t)
    C <- lst$C
    R <- lst$R
    k <- COMBINE(C,R)
    km <- kmeans(x,k)
    plot(x,col=km$cluster,main = 'Radius.KMeans result')
    return(list(k = k,km = km))
}

# 中心筛选——对应2.3中的算法2
FILTER <- function(x,p,q=0.5,t=1.5){
    C <- matrix(nrow = 1,ncol = dim(x)[2])
    R <- c()
    # 生成中心点集合C以及对应的半径集合R
    for(k in 2:p){
        # 进行Kmeans聚类
        km <- kmeans(x,k)
        for (i in 1:k) {
            # 返回本次聚类属于第i类的样本
            samples <- x[km$cluster==i,]
            # 计算样本到对应聚类中心的距离
            d <- dist(km$centers[i,],samples)
            # 得到当前类聚类中心对应的半径
            r <- as.numeric(quantile(d,q))
            R <- c(R,r)
            # 聚类中心
            C <- rbind(C,km$centers[i,])
        }
    }
    # 绘制图像
    #plot(C,pch=19,col=2,xlim = c(-30,30),ylim = c(-30,30),main = 'Sizeable radiuses(中心筛选前)')
    library(plotrix)
    for(i in 1:length(R)){
        draw.circle(C[i,1],C[i,2],R[i])
    }
    C <- C[-1,]
    COL <- c()
    for (i in 1:length(R)) {
        for (j in 1:length(R)) {
            # 计算Condition1
            d_i_j <- sqrt(sum((C[i,] - C[j,])^2))
            MIN_i_j <- min(R[i],R[j])
            MAX_i_j <- max(R[i],R[j])
            Condition1 <- (d_i_j + MIN_i_j < (t * MAX_i_j))
            if ((i!=j) && Condition1) {
                col <- c(i,j)[which.max(R[c(i,j)])]
                COL <- c(COL,col)
            }
        }
    }
    COL <- unique(COL)
    C <- C[-COL,]
    R <- R[-COL]
    # 绘制图像
    #plot(C,pch=19,col=2,xlim = c(-5,20),ylim = c(-5,20),main = 'Sizeable radiuses(中心筛选后)')
    library(plotrix)
    for(i in 1:length(R)){
        draw.circle(C[i,1],C[i,2],R[i])
    }
    return(list(C=C,R=R))
}

# 中心融合——对应2.3中的算法3
COMBINE <- function(C,R){
    L_C <- length(R)
    # 生成pointer矩阵
    pointer <- matrix(0,nrow = L_C,ncol = L_C)
    s <- c()
    c_s <- 1:L_C
    for(i in 1:L_C){
        for(j in 1:L_C){
            d_i_j <- sqrt(sum((C[i,1:2] - C[j,1:2])^2))
            Condition2 <- d_i_j<(R[i]+R[j])
            if((i!=j) & Condition2){
                pointer[i,j] <- 1
                pointer[j,i] <- 1
            }
        }
    }
    k <- 0
    while (length(c_s) != 0) {
        lst <- RECURSION(pointer,s,c_s,c_s[1])
        s <- lst$s
        c_s <- lst$c_s
        k <- k + 1
    }
    return(k)
}

# 递归函数，完成类的寻找工作——对应2.3中的算法4
RECURSION <- function(pointer,s,c_s,ini_co){
    corrdin <- which(pointer[ini_co,] == 1)
    s <- c(s,ini_co)
    c_s <- c_s[which(c_s!=ini_co)]
    if(length(corrdin) != 0){
        for(i in 1:length(corrdin)){
            if(corrdin[i] %in% s){
                next
            }else{
                ini_co <- corrdin[i]
                lst <- RECURSION(pointer,s,c_s,ini_co)
                s <- lst$s
                c_s <- lst$c_s
            }
        }
    }
    return(list(s=s,c_s=c_s))
}

# 定义distance函数，计算类内所有点到聚类中心距离的排序
dist <- function(centers,X){
    d <- sqrt(diag((X - centers) %*% t(X - centers)))
    return(d)
}

######################################################################################
# 生成模拟数据
#####################################################################################
# 导入用到的包
library(MASS)
# 多图绘制
par(mfrow=c(2,2))
# =============================================案例1：三圆环数据=========================================
set.seed(123)
n1 <- 500  # 内部圆的样本点数量
n2 <- 500  # 中间圆环的样本点数量
n3 <- 500  # 外部圆环的样本点数量
X1 <- matrix(nrow = n1,ncol = 2)
mu <- c(0,0)
sigma <- matrix(c(1,0,0,1),nrow = 2,ncol = 2)
for(i in 1:n1){
    x <- mvrnorm(1,mu,sigma)
    while(TRUE){
        if((x[1]^2 + x[2]^2) >= 0 & (x[1]^2 + x[2]^2) <= 1){
            X1[i,] <- x
            break()
        }else{
            x <- mvrnorm(1,mu,sigma)
        }
    }

}

X2 <- matrix(nrow = n2,ncol = 2)
mu <- c(0,0)
sigma <- matrix(c(9,0,0,9),nrow = 2,ncol = 2)
for(i in 1:n2){
    x <- mvrnorm(1,mu,sigma)
    while(TRUE){
        if((x[1]^2 + x[2]^2) >= 2 & (x[1]^2 + x[2]^2) <= 3){
            X2[i,] <- x
            break()
        }else{
            x <- mvrnorm(1,mu,sigma)
        }
    }
}
X3 <- matrix(nrow = n3,ncol = 2)
mu <- c(0,0)
sigma <- matrix(c(36,0,0,36),nrow = 2,ncol = 2)
for(i in 1:n2){
    x <- mvrnorm(1,mu,sigma)
    while(TRUE){
        if((x[1]^2 + x[2]^2) >= 5 & (x[1]^2 + x[2]^2) <= 6){
            X3[i,] <- x
            break()
        }else{
            x <- mvrnorm(1,mu,sigma)
        }
    }
}
# 合并数据
X <- rbind(X1,X2,X3)
g <- c(rep(1,n1),rep(2,n2),rep(3,n3))
# 无标签绘图
plot(X,pch=20,col='blue',main='DataSet1',xlab = expression(X[1]),ylab=expression(X[2]))
# 有标签绘图
plot(X,col=g,pch=20,main='圆环数据',xlab = expression(X[1]),ylab=expression(X[2]))
# 保存数据
dataset1 <- cbind(X,g)
colnames(dataset1) <- c('X1','X2','g')
write.csv(dataset1, 'dataset1.csv', fileEncoding = 'utf-8', row.names = FALSE)
# ============================================案例2：块状数据===============================================
n <- 300
mu1 <- c(0,0)
mu2 <- c(0,-3)
mu3 <- c(3,-3)
mu4 <- c(3,3)
mu5 <- c(-3,3)
sigma <- matrix(c(0.1,0,0,0.1),nrow = 2,ncol = 2)
X1 <- mvrnorm(n,mu1,sigma)
X2 <- mvrnorm(n,mu2,sigma)
X3 <- mvrnorm(n,mu3,sigma)
X4 <- mvrnorm(n,mu4,sigma)
X5 <- mvrnorm(n,mu5,sigma)
X <- rbind(X1,X2,X3,X4,X5)
g <- rep(1:5,each=n)
# 无标签绘图
plot(X,pch=20,col='blue',main='DataSet2',xlab = expression(X[1]),ylab=expression(X[2]))
# 有标签绘图
plot(X,col=g,pch=20,main='块状数据',xlab = expression(X[1]),ylab=expression(X[2]))
# 保存数据
dataset2 <- cbind(X,g)
colnames(dataset2) <- c('X1','X2','g')
write.csv(dataset2, 'dataset2.csv', fileEncoding = 'utf-8', row.names = FALSE)
# ======================================案例3：块状数据+噪声==================================================
n <- 300
mu1 <- c(0,0)
mu2 <- c(0,-3)
mu3 <- c(3,-2)
mu4 <- c(2,2)
mu5 <- c(-1.5,3)
sigma <- matrix(c(0.1,0,0,0.1),nrow = 2,ncol = 2)
X1 <- mvrnorm(n,mu1,sigma)
X2 <- mvrnorm(n,mu2,sigma)
X3 <- mvrnorm(n,mu3,sigma)
X4 <- mvrnorm(n,mu4,sigma)
X5 <- mvrnorm(n,mu5,sigma)
X <- rbind(X1,X2,X3,X4,X5)
g <- rep(1:5,each=n)
n_noise <- 100
X_noise <- matrix(ncol=2,nrow = n_noise)
for(i in 1:n_noise){
    min_dist <- 0
    while(min_dist < 0.5){
        noise_x<- runif(1,-4,4)
        noise_y <- runif(1,-4,4)
        noise_one <- matrix(rep(c(noise_x, noise_y), times=dim(X)[1]), ncol = 2,byrow = TRUE)
        min_dist <- min(dist(noise_one, X))
    }
    X_noise[i,] <- noise_one[1,]
}
X <- rbind(X,X_noise)
g <- c(g,rep(6,n_noise))
# 无标签绘图
plot(X,pch=20,col='blue',main='DataSet3',xlab = expression(X[1]),ylab=expression(X[2]))
# 有标签绘图
plot(X,col=g,pch=20,main='带噪声的块状数据',xlab = expression(X[1]),ylab=expression(X[2]))
# 保存数据
dataset3 <- cbind(X,g)
colnames(dataset3) <- c('X1','X2','g')
write.csv(dataset3, 'dataset3.csv', fileEncoding = 'utf-8', row.names = FALSE)
# ==========================================案例4：圆弧数据+噪声==============================================
set.seed(123)
n1 <- 1000  # 上圆弧的样本点数量
n2 <- 1000  # 下圆弧的样本点数量
X1 <- matrix(nrow = n1,ncol = 2)
mu <- c(-0.5,0)
sigma <- matrix(c(1,0,0,1),nrow = 2,ncol = 2)
for(i in 1:n1){
    x <- mvrnorm(1,mu,sigma)
    while(TRUE){
        if(((x[1]+0.5)^2 + x[2]^2) >= 1 & ((x[1]+0.5)^2 + x[2]^2) <= 2 & x[2] > -0.5){
            X1[i,] <- x
            break()
        }else{
            x <- mvrnorm(1,mu,sigma)
        }
    }
}
X2 <- matrix(nrow = n2,ncol = 2)
mu <- c(0.5,0)
sigma <- matrix(c(1,0,0,1),nrow = 2,ncol = 2)
for(i in 1:n1){
    x <- mvrnorm(1,mu,sigma)
    while(TRUE){
        if(((x[1]-0.5)^2 + x[2]^2) >= 1 & ((x[1]-0.5)^2 + x[2]^2) <= 2 & x[2] < 0.5){
            X2[i,] <- x
            break()
        }else{
            x <- mvrnorm(1,mu,sigma)
        }
    }
}
# 合并数据
X <- rbind(X1,X2)
g <- c(rep(1,n1),rep(2,n2))
# 噪声数据
n_noise <- 100
X_noise <- matrix(ncol=2,nrow = n_noise)
for(i in 1:n_noise){
    min_dist <- 0
    while(min_dist < 0.1){
        noise_x<- runif(1,-2,2)
        noise_y <- runif(1,-2,2)
        noise_one <- matrix(rep(c(noise_x, noise_y), times=dim(X)[1]), ncol = 2,byrow = TRUE)
        min_dist <- min(dist(noise_one, X))
    }
    X_noise[i,] <- noise_one[1,]
}
X <- rbind(X,X_noise)
g <- c(g,rep(3,n_noise))
# 无标签绘图
plot(X,pch=20,col='blue',main='DataSet4',xlab = expression(X[1]),ylab=expression(X[2]))
# 有标签绘图
plot(X,col=g,pch=20,main='带噪声的弧形数据',xlab = expression(X[1]),ylab=expression(X[2]))
# 保存数据
dataset4 <- cbind(X,g)
colnames(dataset4) <- c('X1','X2','g')
write.csv(dataset4, 'dataset4.csv', fileEncoding = 'utf-8', row.names = FALSE)

# ==========================================案例3：混合数据+噪声==============================================
set.seed(123)
n1 <- 300  # 左边块的样本点数量
n2 <- 200  # 右边块的样本点数量
n3 <- 1000  # 圆弧的样本点数量
# 生成左边的块
X1 <- matrix(nrow = n1,ncol = 2)
mu1 <- c(-2,2)
sigma1 <- matrix(c(0.2,0,0,0.2),nrow = 2,ncol = 2)
X1 <- mvrnorm(n1,mu1,sigma1)
# 生成右边的块
X2 <- matrix(nrow = n2,ncol = 2)
mu2 <- c(2,2)
sigma2 <- matrix(c(0.2,0,0,0.2),nrow = 2,ncol = 2)
X2 <- mvrnorm(n2,mu2,sigma2)
# 生成圆弧
X3 <- matrix(nrow = n3,ncol = 2)
mu3 <- c(0,0)
sigma3 <- matrix(c(3,0,0,3),nrow = 2,ncol = 2)
for(i in 1:n3){
    x <- mvrnorm(1,mu3,sigma3)
    while(TRUE){
        if(((x[1])^2 + x[2]^2) >= 1 & ((x[1])^2 + x[2]^2) <= 1.5 & x[2] <= 0){
            X3[i,] <- x
            break()
        }else{
            x <- mvrnorm(1,mu3,sigma3)
        }
    }
}
# 添加噪声
n_noise <- 40
X_noise <- matrix(ncol=2,nrow = n_noise)
for(i in 1:n_noise){
    min_dist <- 0
    while(min_dist < 0.1){
        noise_x<- runif(1,-2,2)
        noise_y <- runif(1,-2,2)
        noise_one <- matrix(rep(c(noise_x, noise_y), times=dim(X)[1]), ncol = 2,byrow = TRUE)
        min_dist <- min(dist(noise_one, X))
    }
    X_noise[i,] <- noise_one[1,]
}

X <- rbind(X1,X2, X3,X_noise)
plot(X,pch=20,col='blue',main='DataSet4',xlab = expression(X[1]),ylab=expression(X[2]))

#################################################################################
# 利用各种方法进行聚类
#################################################################################
# 绘制聚类结果图
plot_clustering <- function(X, res, main){
    pch_set=c(1,2,3,5,7,8,9)
    plot(X[,1], X[,2],xlab = expression(X[1]),ylab=expression(X[2]),main=main, col='white')
    for(i in 1:length(res_grid_svm_knn)){
        if(res[i] == 0){
            points(x = X[i,1], y = X[i,2], col=res[i]+1, pch=15)
        }else{
            points(x = X[i,1], y = X[i,2], col=res[i]+1, pch=pch_set[res[i]])
        }
    }
}

# 加载一些包
library(fpc)
library(dbscan)
library(ellipse)
X <- dataset1[,1:2]; g <- dataset1[,3]
# X <- dataset2[,1:2]; g <- dataset2[,3]
# X <- dataset3[,1:2]; g <- dataset3[,3]
# X <- dataset4[,1:2]; g <- dataset4[,3]
# grid_SVM_knn
res_grid_svm_knn <- grid_svm_knn(X, gamma=10 ,cost=10, k=18, Index1=1213)  # dataset1
#res_grid_svm_knn <- grid_svm_knn(X, gamma=5 ,cost=0.36, k=18, Index1=1)
res_grid_svm_knn <- grid_svm_knn(X, gamma=20,cost=0.01, k=18, Index1=1213)
res_grid_svm_knn <- grid_svm_knn(X, gamma=10, cost=0.02265, k=25, Index1=1213)
res_grid_svm_knn <- grid_svm_knn(X, gamma=10, cost=0.023, k=18, Index1=1213)
# 绘制聚类结果
plot_clustering(X, res_grid_svm_knn, 'DataSet1')
# dbscan
kNNdistplot(X,k = 20)  # 找最优eps
res_db <- dbscan(X,eps=0.2,minPts=8)
res_db <- res_db$cluster
plot_clustering(X, res_db, 'DataSet4聚类效果图')
# DP-Kmeans
res_DP_Kmeans <- Radius.KMeans(X,1213,q=0.5,t=1.2)
res_DP_Kmeans <- res_DP_Kmeans$km$cluster
plot_clustering(X, res_DP_Kmeans,'DataSet4聚类效果图')
# 汇总上面的结果并保存
res1 <- cbind(res_grid_svm_knn, res_db, res_DP_Kmeans)
write.csv(res1, 'res1.csv', row.names = FALSE, fileEncoding = 'utf-8')

res2 <- cbind(res_grid_svm_knn, res_db, res_DP_Kmeans)
write.csv(res2, 'res2.csv', row.names = FALSE, fileEncoding = 'utf-8')

res3 <- cbind(res_grid_svm_knn, res_db, res_DP_Kmeans)
write.csv(res3, 'res3.csv', row.names = FALSE, fileEncoding = 'utf-8')

res4 <- cbind(res_grid_svm_knn, res_db, res_DP_Kmeans)
write.csv(res4, 'res4.csv', row.names = FALSE, fileEncoding = 'utf-8')
# birch用python处理

# 解除多图绘制
par(mfrow=c(1,1))
###############################################################################
# 聚类效果评估
###############################################################################
library(NMI)
NMI(res_db$cluster, g)

###############################################################################
# 对算法的时间复杂度进行分析
###############################################################################
library(MASS)
create_data <- function(n){
    n <- n/2
    mu1 <- c(0,2)
    mu2 <- c(0,-2)
    sigma <- matrix(c(0.1,0,0,0.1),nrow = 2,ncol = 2)
    X1 <- mvrnorm(n,mu1,sigma)
    X2 <- mvrnorm(n,mu2,sigma)
    X <- rbind(X1,X2)
    return(X)
}
X <- create_data(500)
# 无标签绘图
plot(X,pch=20,col='blue',xlab = expression(X[1]),ylab=expression(X[2]))
res_grid_svm_knn <- grid_svm_knn(X, gamma=1,cost=1, k=5, Index1=1213)

# 随n增大的时间消耗情况
n_set <- (1:20)*50
time_set <- matrix(nrow = length(n_set), ncol = 1)
for(i in 1:length(n_set)){
    print(i)
    n <- n_set[i]
    X <- create_data(n)
    t1 <- proc.time()
    res_grid_svm_knn <- grid_svm_knn(X, gamma=1,cost=1, k=5, Index1=1213)
    t2 <- proc.time()
    t <- t2 - t1
    time_set[i] <- t[3][[1]]
}
plot(x = n_set, y = time_set, type = 'b', main='the influence of n to running time', ylab = 'Time', xlab='n')

# 随k增大的时间消耗情况
time_set <- matrix(nrow = length(k_set), ncol = 10)
for(j in 1:10){
    k_set <- 5:30
    for(i in 1:length(k_set)){
        print(paste0('正在处理 行',i,' 列',j))
        k <- k_set[i]
        X <- create_data(1000)
        t1 <- proc.time()
        res_grid_svm_knn <- grid_svm_knn(X, gamma=1,cost=1, k=k, Index1=1213)
        t2 <- proc.time()
        t <- t2 - t1
        time_set[i,j] <- t[3][[1]]
    }
}
time_set_mean <- apply(time_set, 1, mean)
plot(x = k_set, y = time_set_mean, type = 'b', main='the influence of k to running time', ylab = 'Time', xlab='k')

k_set <- 1:30
time_set1 <- matrix(nrow = length(k_set), ncol = 1)
for(i in 1:length(k_set)){
    print(paste0('正在处理 行',i))
    k <- k_set[i]
    set.seed(1213)
    X <- create_data(2000)
    t1 <- proc.time()
    res_grid_svm_knn <- grid_svm_knn(X, gamma=1,cost=1, k=k, Index1=1213)
    t2 <- proc.time()
    t <- t2 - t1
    time_set1[i] <- t[3][[1]]
}
plot(x = k_set, y = time_set1, type = 'b', main='the influence of k to running time', ylab = 'Time', xlab='k')

# 随gamma增大的时间消耗情况
gamma_set <- 10**(-6:6)
time_set <- matrix(nrow = length(gamma_set), ncol = 1)
for(i in 1:length(gamma_set )){
    print(i)
    gamma <- gamma_set[i]
    X <- create_data(1000)
    t1 <- proc.time()
    res_grid_svm_knn <- grid_svm_knn(X, gamma=gamma,cost=1, k=20, Index1=1213)
    t2 <- proc.time()
    t <- t2 - t1
    time_set[i] <- t[3][[1]]
}
plot(x = gamma_set, y = time_set, type = 'b', main='gamma对算法运行时间的影响', ylab = '消耗时间', xlab='gamma')

# 随cost增大的时间消耗情况
cost_set <- 10**(-4:4)
time_set <- matrix(nrow = length(cost_set), ncol = 1)
for(i in 1:length(cost_set )){
    print(i)
    cost <- cost_set[i]
    X <- create_data(3000)
    t1 <- proc.time()
    res_grid_svm_knn <- grid_svm_knn(X, gamma=1,cost=cost, k=20, Index1=1213)
    t2 <- proc.time()
    t <- t2 - t1
    time_set[i] <- t[3][[1]]
}
plot(x = cost_set, y = time_set, type = 'b', main='cost对算法运行时间的影响', ylab = '消耗时间', xlab='cost')


bp_km <- function(r_times){

  # get a 2x2 df with #resp per second
  res <- 1
  x <- seq(1,180,res)
  resp_sec <- r_times %>%
  {
    bins <- .
    rate <- f_table(bins,1,180,res) # f_table is a custom fn
    rate
  }

  resp_sec <- data.frame(x = x, y = resp_sec)
  resp_sec_scaled <- apply(resp_sec, 2, scale) # clustering works better scaled
  colnames(resp_sec_scaled) <- c("x","y")
  set.seed(123)

  gap <- clusGap(resp_sec_scaled,pam,K.max = 4, B = 100) # gap statistic
  # to compute the optimal number of clusters btw 1 and 4
  k <- maxSE(gap$Tab[, "gap"], gap$Tab[, "SE.sim"], method = "Tibs2001SEmax")

  data.frame(opt_k = k)
}


REBOL [
       Title: "Day 4"
       Author: "George Pollard"
]

digits: charset [#"0" - #"9"]
letters: charset [#"a" - #"z"]
hexDigits: charset [#"0" - #"9" #"a" - #"f"]

numInRange: func [minValue maxValue] [
        func [x] compose [
                x: to-integer x
                okMin: x >= (minValue)
                okMax: x <= (maxValue)
                okMin and okMax
        ]
]

BirthYear: make object! [ field: "byr" validation: numInRange 1920 2002 ]
IssueYear: make object! [ field: "iyr" validation: numInRange 2010 2020 ]
ExpirationYear: make object! [ field: "eyr" validation: numInRange 2020 2030 ]
HairColor: make object! [ field: "hcl" validation: func [x]  [ parse/all x ["#" 6 hexDigits] ] ]
EyeColor: make object! [ field: "ecl" validation: func [x] [ parse/all x ["amb" | "blu" | "brn" | "gry" | "grn" | "hzl" | "oth"] ] ]
PassportID: make object! [ field: "pid" validation: func [x]  [ parse/all x [9 digits] ] ]

Height: make object! [
        field: "hgt"
        validation: function [x] [valid parseCM parseIN parsed] [
                valid: false
                parseCM: func [x] [ x: to-integer x valid: (x >= 150) and (x <= 193) ]
                parseIN: func [x] [ x: to-integer x valid: (x >= 59) and (x <= 76) ]
                parse/all x [copy v some digits [ "in" (parseIN v) | "cm" (parseCM v) ] ]
                valid
        ]
]

Required: reduce [BirthYear IssueYear ExpirationYear Height HairColor EyeColor PassportID]

spacer: charset reduce [newline #" "]
non-space: complement spacer
value: [copy k [some letters] ":" copy v [some non-space] (append current-record reduce [k v]) skip]
record: [(current-record: make hash! []) some value (append/only records current-record)]
file: [record any ["^/" record] end]

records: make block! 0
data: %/home/george/day4.txt
either parse/all read data file [
        print [length? records "records"]
] [
        throw "unable to parse input"
]

valid: 0
foreach record records [
        isValid: foreach x Required [
                either find record x/field [
                        either x/validation record/(x/field) [
                                true
                        ] [
                                print ["invalid" x/field record/(x/field)]
                                break/return false
                        ]
                ] [
                        print ["missing" x/field]
                        break/return false
                ]
        ]

        if isValid [
                valid: valid + 1
        ]
]

print [valid "valid"]


# 3. faza: Vizualizacija podatkov

#--------------------
# GRAFA 1 IN 2

graf1 <-  tabela6 %>%
        filter(VRSTA.VODE=="SKUPAJ") %>%
        ggplot(aes(x=LETO, y=NACRPANO)) +
        geom_bar(stat="identity", fill="blue") +
        ylab("Načrpana voda skupaj v 100.000 * m^3") +
        xlab("Leto")

povprecje <- tabela6 %>%
        filter(VRSTA.VODE!="SKUPAJ") %>%
        group_by(VRSTA.VODE) %>%
        summarise(Povprečje=sum(NACRPANO)) %>%
        mutate(delez=round(100*Povprečje/sum(Povprečje), 1)) %>%
        arrange(desc(VRSTA.VODE)) %>%
        mutate(lab.ypos = cumsum(delez) - 0.5*delez)

dvojnistolpci <-tabela6 %>%
        filter(VRSTA.VODE!="SKUPAJ") %>%
        ggplot(aes(fill=VRSTA.VODE, x=LETO, y=NACRPANO)) +
        geom_bar(position="dodge", stat="identity") +
        xlab("Leto") +
        ylab("Načrpano v 100.000 * m^3")

graf2 <- ggplot(povprecje, aes(x="", y=delez, fill=VRSTA.VODE)) +
        geom_bar(width=1, stat="identity", color="white") +
        coord_polar("y", start=0) +
        geom_text(aes(y=lab.ypos, label=delez), color="white") +
        theme_void() +
        labs(fill="Vrsta vode") +
        ggtitle("Povprečno razmerje med načrpano vodo v letih
                2013-2019")

#--------------------------
# GRAFA 3 IN 4

graf3 <- tabela2 %>%
        filter(regija=="SLOVENIJA") %>%
        ggplot(aes(x=leto, y=vrednost), group=1, asp=2) +
        geom_point(color="red") +
        geom_line(group=1) +
        xlab("Leto") +
        ylab("Dobavljena voda v m^3 na prebivalca")

tortni2 <- tabela2 %>%
        filter(regija!="SLOVENIJA", leto=="2019") %>%
        mutate(delezi=100*vrednost / sum(vrednost)) %>%
        arrange(desc(regija)) %>%
        mutate(lab.ypos=cumsum(delezi) - 0.5*delezi)

graf4 <- ggplot(tortni2, aes(x="", y=delezi, fill=regija)) +
        geom_bar(width=1, stat="identity", color="white") +
        coord_polar("y", start=0) +
        geom_text(aes(y=lab.ypos, label=paste0(round(delezi, 2), "%"), x=1.3)) +
        theme_void() +
        labs(title="Porazdelitev dostavljene vode", fill="Regija")

#-----------------------------
# GRAF 5

graf5 <- odpadkiletnonaprebivalca %>%
        filter(leto=="povprecje") %>%
        arrange(`odpad na prebivalca`) %>%
        ggplot(aes(x=`odpad na prebivalca`, y=Regija)) +
        geom_col(color="Brown", fill="Brown") +
        xlab("Povprečen letni odpad na prebivalca v kg") +
        ylab("Regija") +
        labs("Povprečen letni odpad na prebivalca")

#------------
# ZEMLJEVID

zemljevid <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB",
                             pot.zemljevida="OB", encoding="Windows-1250")

proj4string(zemljevid) <- CRS("+proj=utm +zone=10+datum=WGS84")

levels(zemljevid$OB_UIME) <- levels(zemljevid$OB_UIME) %>%
        { gsub("Slovenskih", "Slov.", .) } %>% { gsub("-", " - ", .) }

zemljevid1 <- tm_shape(merge(zemljevid, tabelazakarto, by.x="OB_UIME", by.y="obcina")) +
        tm_polygons("odpadki19kgnaprebivalca", title="Odpad v kg") +
        ggtitle("Odpad na prebivalca v letu 2019")


library(tidyverse)
library(sf)
library(RColorBrewer)
library(leaflet)

#read wales msoa shapefiles
msoas <- read_sf("./wales_msoa.shp")#read wales shapefiles

#read in ookla tiles for Wales
tiles <- read_sf("./data/y-2020-q1-type-fixed.shp")

#map msoa shapes to same projection as the ookla data
msoas <- st_transform(msoas, st_crs(tiles))

#this lets us filter data by area - this example filters for Pembrokeshire
subset_msoas <- msoas %>% filter(str_detect(msoa11_nam, "^Pem"))

#this if filtered on msoa - keeps only square that corresp0nd to chosen msoa area
tiles_in_msoas <- st_join(subset_msoas, tiles)

#filter the tiles by the ones that match the join keys above
filter_tiles <- tiles %>% filter(quadkey %in% tiles_in_msoas$quadkey)

#set up a colour pallette
pal <- colorNumeric("RdYlBu", filter_tiles$avg_d_kbps/1000)

#plot the tiles and msoa boundaries
leaflet(filter_tiles) %>% addProviderTiles(providers$CartoDB)  %>%
  addPolygons( stroke=FALSE, fillColor = ~pal(avg_d_kbps/1000),
               fillOpacity = 0.9) %>%
  addPolygons(data = subset_msoas, fillOpacity = 0, color = "black", weight = 0.8) %>%
  addLegend(pal = pal, values = filter_tiles$avg_d_kbps/1000, opacity = 0.8, title = "Mb/s")


#' Quantile regression
#'
#' This fits a quantile regression to the data and draws the fitted quantiles
#' with lines. This is as a continuous analogue to [geom_boxplot()].
#'
#' @eval rd_aesthetics("geom", "quantile")
#' @export
#' @inheritParams layer
#' @inheritParams geom_point
#' @inheritParams geom_path
#' @param method.args List of additional arguments passed on to the modelling
#'   function defined by `method`.
#' @param geom,stat Use to override the default connection between
#'   `geom_quantile()` and `stat_quantile()`.
#' @examples
#' m <-
#'   ggplot(mpg, aes(displ, 1 / hwy)) +
#'   geom_point()
#' m + geom_quantile()
#' m + geom_quantile(quantiles = 0.5)
#' q10 <- seq(0.05, 0.95, by = 0.05)
#' m + geom_quantile(quantiles = q10)
#'
#' # You can also use rqss to fit smooth quantiles
#' m + geom_quantile(method = "rqss")
#' # Note that rqss doesn't pick a smoothing constant automatically, so
#' # you'll need to tweak lambda yourself
#' m + geom_quantile(method = "rqss", lambda = 0.1)
#'
#' # Set aesthetics to fixed value
#' m + geom_quantile(colour = "red", size = 2, alpha = 0.5)
geom_quantile <- function(mapping = NULL, data = NULL,
                          stat = "quantile", position = "identity",
                          ...,
                          lineend = "butt",
                          linejoin = "round",
                          linemitre = 10,
                          na.rm = FALSE,
                          show.legend = NA,
                          inherit.aes = TRUE) {

  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomQuantile,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list2(
      lineend = lineend,
      linejoin = linejoin,
      linemitre = linemitre,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
#' @include geom-path.r
GeomQuantile <- ggproto("GeomQuantile", GeomPath,
  default_aes = defaults(
    aes(weight = 1, colour = "#3366FF", size = 0.5),
    GeomPath$default_aes
  )
)


library (gsubfn)
setwd('C:/Users/midingoy/Documents/crop2mlcatalog/SQ_Energy_Balance/src/r')
source('Netradiation.r')
source('Netradiationequivalentevaporation.r')
source('Priestlytaylor.r')
source('Conductance.r')
source('Diffusionlimitedevaporation.r')
source('Penman.r')
source('Ptsoil.r')
source('Soilevaporation.r')
source('Evapotranspiration.r')
source('Soilheatflux.r')
source('Potentialtranspiration.r')
source('Cropheatflux.r')
source('Canopytemperature.r')

model_energybalance <- function (minTair = 0.7,
         maxTair = 7.2,
         albedoCoefficient = 0.23,
         stefanBoltzman = 4.903e-09,
         elevation = 0.0,
         solarRadiation = 3.0,
         vaporPressure = 6.1,
         extraSolarRadiation = 11.7,
         lambdaV = 2.454,
         hslope = 0.584,
         psychrometricConstant = 0.66,
         Alpha = 1.5,
         vonKarman = 0.42,
         heightWeatherMeasurements = 2.0,
         zm = 0.13,
         d = 0.67,
         zh = 0.013,
         plantHeight = 0.0,
         wind = 124000.0,
         deficitOnTopLayers = 5341.0,
         soilDiffusionConstant = 4.2,
         VPDair = 2.19,
         rhoDensityAir = 1.225,
         specificHeatCapacityAir = 0.00101,
         tau = 0.9983,
         tauAlpha = 0.3,
         isWindVpDefined = 1){
    #'- Name: EnergyBalance -Version: 001, -Time step: 1
    #'- Description:
    #'            * Title: EnergyBalance
    #'            * Author: Pierre MARTRE
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2: Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA/LEPSE
    #'            * ExtendedDescription: see documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * ShortDescription: This component calculates the canopy temperature and energy balance
    #'- inputs:
    #'            * name: minTair
    #'                          ** description : minimum air temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** default : 0.7
    #'                          ** unit : °C
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: maxTair
    #'                          ** description : maximum air Temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** default : 7.2
    #'                          ** unit : °C
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: albedoCoefficient
    #'                          ** description : albedo Coefficient
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.23
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: stefanBoltzman
    #'                          ** description : stefan Boltzman constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 4.903E-09
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: elevation
    #'                          ** description : elevation
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0
    #'                          ** min : -500
    #'                          ** max : 10000
    #'                          ** unit : m
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: solarRadiation
    #'                          ** description : solar Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 3
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : MJ m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: vaporPressure
    #'                          ** description : vapor Pressure
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 6.1
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : hPa
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: extraSolarRadiation
    #'                          ** description : extra Solar Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 11.7
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : MJ m2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: lambdaV
    #'                          ** description : latent heat of vaporization of water
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 2.454
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** unit : MJ kg-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: hslope
    #'                          ** description : the slope of saturated vapor pressure temperature curve at a given temperature
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.584
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : hPa °C-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: psychrometricConstant
    #'                          ** description : psychrometric constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.66
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: Alpha
    #'                          ** description : Priestley-Taylor evapotranspiration proportionality constant
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.5
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: vonKarman
    #'                          ** description : von Karman constant
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0.42
    #'                          ** unit : dimensionless
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'            * name: heightWeatherMeasurements
    #'                          ** description : reference height of wind and humidity measurements
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** default : 2
    #'                          ** unit : m
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: zm
    #'                          ** description : roughness length governing momentum transfer, FAO
    #'                          ** parametercategory : constant
    #'                          ** inputtype : parameter
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0.13
    #'                          ** unit : m
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: d
    #'                          ** description : corresponding to 2/3. This is multiplied to the crop heigth for calculating the zero plane displacement height, FAO
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.67
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit : dimensionless
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547rl
    #'            * name: zh
    #'                          ** description : roughness length governing transfer of heat and vapour, FAO
    #'                          ** parametercategory : constant
    #'                          ** inputtype : parameter
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** default : 0.013
    #'                          ** unit : m
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: plantHeight
    #'                          ** description : plant Height
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'            * name: wind
    #'                          ** description : wind
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 124000
    #'                          ** min : 0
    #'                          ** max : 1000000
    #'                          ** unit : m/d
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: deficitOnTopLayers
    #'                          ** description : deficit On TopLayers
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 5341
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: soilDiffusionConstant
    #'                          ** description : soil Diffusion Constant
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** default : 4.2
    #'                          ** min : 0
    #'                          ** max : 10
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: VPDair
    #'                          ** description :  vapour pressure density
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 2.19
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : hPa
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: rhoDensityAir
    #'                          ** description : Density of air
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 1.225
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: specificHeatCapacityAir
    #'                          ** description : Specific heat capacity of dry air
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.00101
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: tau
    #'                          ** description : plant cover factor
    #'                          ** parametercategory : species
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.9983
    #'                          ** min : 0
    #'                          ** max : 100
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: tauAlpha
    #'                          ** description : Fraction of the total net radiation exchanged at the soil surface when AlpaE = 1
    #'                          ** parametercategory : soil
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.3
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'            * name: isWindVpDefined
    #'                          ** description : if wind and vapour pressure are defined
    #'                          ** parametercategory : constant
    #'                          ** datatype : INT
    #'                          ** default : 1
    #'                          ** min : 0
    #'                          ** max : 1
    #'                          ** unit :
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : parameter
    #'- outputs:
    #'            * name: netRadiation
    #'                          ** description :  net radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : MJ m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: netOutGoingLongWaveRadiation
    #'                          ** description : net OutGoing Long Wave Radiation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: netRadiationEquivalentEvaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** description : net Radiation in Equivalent Evaporation
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: evapoTranspirationPriestlyTaylor
    #'                          ** description : evapoTranspiration of Priestly Taylor
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: diffusionLimitedEvaporation
    #'                          ** description : the evaporation from the diffusion limited soil
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: energyLimitedEvaporation
    #'                          ** description : energy Limited Evaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: conductance
    #'                          ** description : the boundary layer conductance
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : m/d
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: evapoTranspirationPenman
    #'                          ** description :  evapoTranspiration of Penman Monteith
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: soilEvaporation
    #'                          ** description : soil Evaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: evapoTranspiration
    #'                          ** description : evapoTranspiration
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : mm
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: potentialTranspiration
    #'                          ** description : potential Transpiration
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: soilHeatFlux
    #'                          ** description : soil Heat Flux
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: cropHeatFlux
    #'                          ** description :  crop Heat Flux
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: minCanopyTemperature
    #'                          ** description : minimal Canopy Temperature
    #'                          ** datatype : DOUBLE
    #'                          ** variablecategory : state
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** unit : degC
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'            * name: maxCanopyTemperature
    #'                          ** description : maximal Canopy Temperature
    #'                          ** datatype : DOUBLE
    #'                          ** variablecategory : state
    #'                          ** min : -30
    #'                          ** max : 45
    #'                          ** unit : degC
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    list[netRadiation, netOutGoingLongWaveRadiation] <- model_netradiation(minTair, maxTair, albedoCoefficient, stefanBoltzman, elevation, solarRadiation, vaporPressure, extraSolarRadiation)
    conductance <- model_conductance(vonKarman, heightWeatherMeasurements, zm, zh, d, plantHeight, wind)
    diffusionLimitedEvaporation <- model_diffusionlimitedevaporation(deficitOnTopLayers, soilDiffusionConstant)
    netRadiationEquivalentEvaporation <- model_netradiationequivalentevaporation(lambdaV, netRadiation)
    evapoTranspirationPriestlyTaylor <- model_priestlytaylor(netRadiationEquivalentEvaporation, hslope, psychrometricConstant, Alpha)
    energyLimitedEvaporation <- model_ptsoil(evapoTranspirationPriestlyTaylor, Alpha, tau, tauAlpha)
    evapoTranspirationPenman <- model_penman(evapoTranspirationPriestlyTaylor, hslope, VPDair, psychrometricConstant, Alpha, lambdaV, rhoDensityAir, specificHeatCapacityAir, conductance)
    soilEvaporation <- model_soilevaporation(diffusionLimitedEvaporation, energyLimitedEvaporation)
    evapoTranspiration <- model_evapotranspiration(isWindVpDefined, evapoTranspirationPriestlyTaylor, evapoTranspirationPenman)
    soilHeatFlux <- model_soilheatflux(netRadiationEquivalentEvaporation, tau, soilEvaporation)
    potentialTranspiration <- model_potentialtranspiration(evapoTranspiration, tau)
    cropHeatFlux <- model_cropheatflux(netRadiationEquivalentEvaporation, soilHeatFlux, potentialTranspiration)
    list[minCanopyTemperature, maxCanopyTemperature] <- model_canopytemperature(minTair, maxTair, cropHeatFlux, conductance, lambdaV, rhoDensityAir, specificHeatCapacityAir)
    return (list ("netRadiation" = netRadiation,"netOutGoingLongWaveRadiation" = netOutGoingLongWaveRadiation,"netRadiationEquivalentEvaporation" = netRadiationEquivalentEvaporation,"evapoTranspirationPriestlyTaylor" = evapoTranspirationPriestlyTaylor,"diffusionLimitedEvaporation" = diffusionLimitedEvaporation,"energyLimitedEvaporation" = energyLimitedEvaporation,"conductance" = conductance,"evapoTranspirationPenman" = evapoTranspirationPenman,"soilEvaporation" = soilEvaporation,"evapoTranspiration" = evapoTranspiration,"potentialTranspiration" = potentialTranspiration,"soilHeatFlux" = soilHeatFlux,"cropHeatFlux" = cropHeatFlux,"minCanopyTemperature" = minCanopyTemperature,"maxCanopyTemperature" = maxCanopyTemperature))
}


## run this script to confirm sorted cell fractions are labelled correctly and data clusters as expected
## use QC metrics for phenotype data!!
## within adult samples do PCA to cluster sample types

library(bigmelon)
library(pheatmap)
library(glmnet)

setwd(dataDir)

gfile<-openfn.gds(gdsFile, readonly = FALSE)

## filter samples
## exclude low intensity; incomplete bisulfite conversion, incorrect sex prediction, discordant with SNP data
load(qcData)
if(sexCheck){
	QCSum<-cbind(QCmetrics$bisulfCon > thresBS,as.character(QCmetrics$predSex) == as.character(QCmetrics$Sex),(QCmetrics$M.median > intenThres & QCmetrics$U.median > intenThres), QCmetrics$rmsd < nvThres)
	colnames(QCSum)<-c("BSConversion", "SexPrediction", paste0("intens<", intenThres), paste0("normviolence<", nvThres))
} else {
	QCSum<-cbind(QCmetrics$bisulfCon > thresBS,(QCmetrics$M.median > intenThres & QCmetrics$U.median > intenThres),QCmetrics$rmsd < nvThres)
	colnames(QCSum)<-c("BSConversion",  paste0("intens<", intenThres), paste0("normviolence<", nvThres))
}
if(snpCheck){
	QCSum<-cbind(QCSum, QCmetrics$genoCheck > 0.8)
	colnames(QCSum)[ncol(QCSum)]<-"snpCheck"
}
rownames(QCSum)<-QCmetrics$Basename
QCSum<-cbind(QCSum, rowSums(QCSum, na.rm = TRUE) == rowSums(!is.na(QCSum)))
colnames(QCSum)[ncol(QCSum)]<-"passS2"

passQC<-rownames(QCSum)[QCSum[,"passS2"]]

sampleSheet<-QCmetrics
sampleSheet<-sampleSheet[match(passQC, sampleSheet$Basename),]

rawbetas<-gfile[,, node = "betas"]
rawbetas<-rawbetas[,match(passQC, colnames(rawbetas))]
auto.probes<-which(fData(gfile)$chr != "chrX" & fData(gfile)$chr != "chrY")
rawbetas<-rawbetas[auto.probes,]

cellTypes<-unique(sampleSheet$Cell.type)
cellTypes<-cellTypes[!is.na(cellTypes)]
## sort so colours lines up correctly
cellTypes<-sort(cellTypes)
cellCols<-c("darkgreen", "darkblue", "darkmagenta", "deeppink", "darkgray") ## assumes celltypes are ordered alphabetically

## filter out NAs
rawbetas<-na.omit(rawbetas)

## filter out SNPs
rawbetas<-rawbetas[-grep("rs", rownames(rawbetas)),]

## use Mahalanobis to calculate difference with cell type medians from PCAs

pca <- prcomp(t(rawbetas))
betas.scores = pca$x
colnames(betas.scores) = paste(colnames(betas.scores), '_betas', sep='')
betas.pca<-pca$sdev^2/sum(pca$sdev^2)
betas.scores<-betas.scores[,which(betas.pca > 0.01)]

cellMedPCA<-aggregate(betas.scores, by = list(sampleSheet$Cell.type), median, na.rm = TRUE)
rownames(cellMedPCA)<-cellMedPCA[,1]
cellMedPCA<-as.matrix(t(cellMedPCA[,-1]))

## calc cell type covariance matrices
cov_sigmaPCA<-list()
for(each in colnames(cellMedPCA)){
	cov_sigmaPCA[[each]]<-cov(betas.scores[which(sampleSheet$Cell.type == each),], use = "p")
}

mahDistPCA<-matrix(data = 10^9, ncol = ncol(cellMedPCA), nrow = nrow(sampleSheet))
colnames(mahDistPCA)<-colnames(cellMedPCA)
for(each in colnames(cellMedPCA)){
	if(det(cov_sigmaPCA[[each]]) > 1){
		mahDistPCA[,each]<-mahalanobis(betas.scores, cellMedPCA[,each], cov_sigmaPCA[[each]], na.rm = TRUE,tol=1e-20)
	}
}

closestCellTypePCA<-colnames(mahDistPCA)[unlist(apply(mahDistPCA, 1, which.min))]
predLabelledCellType<-sampleSheet$Cell.type == closestCellTypePCA

sampleSheet<-cbind(sampleSheet, closestCellTypePCA, predLabelledCellType)
write.csv(sampleSheet[which(predLabelledCellType == "FALSE"),], paste0(qcOutFolder, "SamplesPredictedDiffCellTypePCAMahDist.csv"))

## instead calculate outliers

cellMeanPCA<-aggregate(betas.scores, by = list(sampleSheet$Cell.type), mean, na.rm = TRUE)
rownames(cellMeanPCA)<-cellMeanPCA[,1]
cellMeanPCA<-as.matrix(t(cellMeanPCA[,-1]))

cellSDPCA<-aggregate(betas.scores, by = list(sampleSheet$Cell.type), sd, na.rm = TRUE)
rownames(cellSDPCA)<-cellSDPCA[,1]
cellSDPCA<-as.matrix(t(cellSDPCA[,-1]))

lowerBound<-cellMeanPCA-2*cellSDPCA
upperBound<-cellMeanPCA+2*cellSDPCA

pcaCellClassify<-rep(NA, nrow(sampleSheet))
for(i in 1:length(cellTypes)){
	pcaCellClassify[which(betas.scores[,1] < upperBound[1,i] & betas.scores[,1] > lowerBound[1,i] & betas.scores[,2] < upperBound[2,i] & betas.scores[,2] > lowerBound[2,i])]<-colnames(lowerBound)[i]
}

sampleSheet<-cbind(sampleSheet, pcaCellClassify)

write.csv(sampleSheet[which(pcaCellClassify !=  sampleSheet$Cell.type | is.na(pcaCellClassify)),],paste0(qcOutFolder, "SamplesPredictedDiffCellTypePCAOutlier.csv"))

predLabelledCellType<-sampleSheet$Cell.type == pcaCellClassify
predLabelledCellType[is.na(predLabelledCellType)]<-FALSE
## keep all TOTAL samples
predLabelledCellType[which(sampleSheet$Cell.type == "Total")]<-TRUE
sampleSheet$predLabelledCellType<-predLabelledCellType

## for time being take more stringent approach.
add.gdsn(gfile, 'QCdata', val = sampleSheet, replace = TRUE)

## need to close gds file in order to open in another R session
closefn.gds(gfile)

save(betas.scores, mahDistPCA, file = paste0(qcOutFolder,"WithinCellPCAValues.rdata"))

## add outcome to qc summary

sampleSheet<-sampleSheet[match(rownames(QCSum), sampleSheet$Basename),]
QCSum<-cbind(QCSum, sampleSheet$predLabelledCellType)
colnames(QCSum)[ncol(QCSum)]<-"predLabelledCellType"

write.csv(QCSum, paste0(qcOutFolder,"PassQCStatusAllSamples.csv"))


library(randomForest)

#train_tf_idf = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_train_tf_idf.csv")
train_wc = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_train_wc.csv")
#test_wc = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_test_wc.csv")

features = train_wc[0:3000,c(-1,-502)]
label = as.factor(train_wc$Predict[0:3000])
features_v = train_wc[3000:4000,c(-1,-502)]
label_v = as.factor(train_wc$Predict[3000:4000])

bestmtry <- tuneRF(features,label, ntreeTry=100,
     stepFactor=1.5,improve=0.01, trace=TRUE, plot=TRUE, dobest=FALSE)

rf <- randomForest(x=features, y=label, mtry=163, ntree=500,
     keep.forest=TRUE, importance=TRUE)

rf2 <- randomForest(x=features, y=label, mtry=163, ntree=500, classwt=c(2474,526), importance=TRUE)
rf3 <- randomForest(x=features, y=label, mtry=163, ntree=500, classwt=c(526,2474), importance=TRUE)

#=======================================================

rf.pr = predict(rf2,newdata=features_v)
error = mean(rf.pr!=label_v)
library(Epi)
ROC(form=label_v~rf.pr, plot="ROC")
important_varibles = importance(rf,type=1)
selected_features = important_varibles[order(important_varibles,decreasing=T),]
top_features = selected_features[selected_features>4]
# top_features = selected_features[:225,]

selected_new_features = features[,selected_features>4]
bestmtry <- tuneRF(selected_new_features,label, ntreeTry=100,
     stepFactor=1.5,improve=0.01, trace=TRUE, plot=TRUE, dobest=FALSE)

rf_selected_features <- randomForest(x=selected_new_features, y=label, mtry=33, ntree=500,
     keep.forest=TRUE, importance=TRUE)
#=======================================================
train_tf_idf = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_train_tf_idf.csv")
train_wc = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_train_wc.csv")
#test_wc = read.csv("/Users/ouyamei/Documents/GitHub/kaggle-crisis/data/kaggle_test_wc.csv")

features_tf = train_tf_idf[0:3000,c(-1,-502)]
#label_tf = as.factor(train_tf_idf$Predict[0:3000])
features_wc = train_wc[0:3000,c(-1,-502)]
label = as.factor(train_wc$Predict[0:3000])
features = cbind(features_tf,features_wc)
#label = cbind(label_tf,label_wc)

features_v = train_wc[3000:4000,c(-1,-502)]
label_v = as.factor(train_wc$Predict[3000:4000])

bestmtry <- tuneRF(features,label, ntreeTry=100,
     stepFactor=1.5,improve=0.01, trace=TRUE, plot=TRUE, dobest=FALSE)

rf <- randomForest(x=features, y=label, mtry=163, ntree=500,
     keep.forest=TRUE, importance=TRUE)

rf2 <- randomForest(x=features, y=label, mtry=163, ntree=500, classwt=c(2474,526), importance=TRUE)
rf3 <- randomForest(x=features, y=label, mtry=163, ntree=500, classwt=c(526,2474), importance=TRUE)


library(RcppCNPy)
library(optrdd)

#Load data from simulations
gauss = npyLoad('./sweeps/Gaussian_1000.npz.npy')
lif = npyLoad('./sweeps/param_w_N_19_i_10_j_10_c_0.010000_deltaT_simulations.npz.npy')

# Simple regression discontinuity with discrete X
threshold = 0
X = gauss
W = as.numeric(X >= threshold)
# using 0.4 for max.second.derivative would have been enough
out.1 = optrdd(X=X, W=W, max.second.derivative = 0.5, estimation.point = threshold)
print(out.1); plot(out.1, xlim = c(-1.5, 1.5))

j = 5
threshold = 1
X = lif[,j]
W = as.numeric(X >= threshold)
# using 0.4 for max.second.derivative would have been enough
out.1 = optrdd(X=X, W=W, max.second.derivative = 3, estimation.point = threshold)
print(out.1); plot(out.1, xlim = c(0, 1.5))

prespike = out.1$gamma.fun.0
postspike = out.1$gamma.fun.1

#Save this back in numpy format...
npySave("optimal_filter_prespike.npy", prespike)
npySave("optimal_filter_postspike.npy", postspike)


#process factored variables (i.e,. strategy)
factor2ind <- function(x, baseline){
  xname <- deparse(substitute(x))
  n <- length(x)
  x <- as.factor(x)
  if(!missing(baseline)) x <- relevel(x, baseline)
  X <- matrix(0, n, length(levels(x)))
  X[(1:n) + n*(unclass(x)-1)] <- 1
  X[is.na(x),] <- NA
  dimnames(X) <- list(names(x), paste(xname, levels(x), sep = ":"))
  return(X[,-1,drop=FALSE])
}


# /*Authors: Zenan Wang */
# /*Created: 11/29/2016 */
# /*Last edited: 11/29/2016*/

# This file cleans GIS data and visualize the data

# Load libraries
x <- c("rgdal", "rgeos", "sp", "sf", "maptools", "rasterVis", "tidyverse","magrittr","raster", "parallel", "doParallel", "foreach", "haven","readxl")

# install.packages(x) # warning: uncommenting this may take a number of minutes
lapply(x, library, character.only = TRUE) # load the required packagesgetwd

# Sets encoding to utf-8, solves encoding issues
getCPLConfigOption("SHAPE_ENCODING")
setCPLConfigOption("SHAPE_ENCODING", "UTF-8")
# Importing China county boundary GIS data
china_cnty <- readOGR(dsn="Data/1999County",layer="BOUNT_poly")
# Change projection into WGS84
china_cnty <- china_cnty %>%
  spTransform( CRS("+init=epsg:4326"))%>%
  st_as_sf%>%
  st_set_crs(4326)%>%
  st_simplify

# Now cleaning the data I scraped
bio_gis <- read_csv("Data/bio_hist_gis.csv")
data <- bio_gis%>%select(lon, lat,pid, birthyr_en, dynasty)%>%
  group_by(pid) %>% filter(row_number() == 1) %>% ungroup
# Fixed some problems in GIS information. Those are human inputing errors.
# Examples are placing the dot at the wrong place
data[which(data$lon==1053.6),"lon"] <- 105.36
# or reversing the order of the longitutde and latitude
temp <- data[which(data$lat>90),c("lon","lat")]
data[which(data$lat>90),c("lon","lat")] <- c(temp["lat"],temp["lon"])
data[which(data$lon<70),"lon"] <- 100+data[which(data$lon<70),"lon"]

# Convert the dataframe into spatial points.
ToSpatialPoint <- function(data){
  # This function will transform the bio location data to gps point.
  ### Get long and lat from data.frame. Make sure that the order is in lon/lat.
  xy <- data[c("lon","lat")]
  #  Dropping NAs
  xy %<>%filter(!is.na(lon),!is.na(lat))
  data%<>%filter(!is.na(lon),!is.na(lat))
  bio_pts <- SpatialPointsDataFrame(coords=xy, data=as.data.frame(data),proj4string = CRS("+init=epsg:4326"))
  return(bio_pts)
}

bio_pts <- ToSpatialPoint(data)%>%st_as_sf%>%st_set_crs(4326)

bio_pts%>% write_rds("Data/bio_pts.rds")
china_cnty%>%saveRDS("Data/china_cnty.rds")

# Aggregate the biography data onto county level, counting how many people falling into each county
bio_agg <- aggregate(x = bio_pts['pid'], by = china_cnty, FUN = length)
# add this into the china_cnty dataset
china_cnty$n_bios <-bio_agg$pid

# Importing night light data
# Note: raw night light data is from NOAA, but data used here has been cropped by myself for other project.
light05.chn <- raster("Data/light05chn.tif")
# Increase by a factor of 20 to 10*10 arcminutes,approxmiately 18.5km (1 minute is 1.852 km )
light05.chn <- aggregate(light05.chn,fact=20, fun=mean)
# Change raster to polygon and Change projection into WGS84
light <- rasterToPolygons(light05.chn)%>% spTransform( CRS("+init=epsg:4326"))%>%
  st_as_sf%>%
  st_set_crs(4326)
# Give it a name
light <- light%>% rename(light=light05chn)
# Aggregate the biography data onto county level, averaging the level of luminosity of the county at night
light_agg <- aggregate(x = light["light"], by = china_cnty, FUN = mean)
# add this into the china_cnty dataset
china_cnty$light <-light_agg$light

# Graphical analysis
# Need to fortify the spatial data in order to plot in ggplot
china_cnty <- china_cnty%>%mutate(log_n = log(n_bios), log_light=log(light))

# Visualize spatial distribution of those records
ggplot(china_cnty)+
  geom_sf(size=0.1)+
  geom_sf(data = bio_pts,color='red',size=0.1)+
theme_bw()+
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank())
ggsave("Results/fig1_bio_pts.png")

# Visualize spatial distribution of the record after aggregating to county level
ggplot(china_cnty)+
  geom_sf(size=0.1,aes(fill = log_n))+
  scale_fill_gradient(low = "#fff7ec", high = "#d7301f",na.value = 'NA')+
  theme_bw()+
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank())
ggsave("Results/fig2_bio_county.png")

# Visualize the raw raster data of night light
gplot(light05.chn,maxpixels=1440000)+
  geom_tile(aes(fill=value), alpha=0.8)+
  scale_fill_gradient2( low = "#081d58",mid = "#0066FF", high = "yellow", na.value = 'NA',midpoint = 30)+
  theme_bw()+
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank())
ggsave("Results/fig3_light_raw.png")

# Visualize spatial distribution of the night light after aggregating to county level
ggplot(china_cnty)+
  geom_sf(size=0.1, aes(fill = log_light))+
  scale_fill_gradient2( low = "#081d58",mid = "#0066FF", high = "yellow", na.value = 'NA',midpoint = -2)+
  theme_bw()+
    theme(panel.grid.major = element_blank(),
          panel.grid.minor = element_blank())
ggsave("Results/fig4_light_county.png")

# Simple regression analysis
reg <- lm(light~n_bios,china_cnty)
summary(reg)
library(stargazer)
stargazer(reg, type = "html",out = "Results/reg_results.html",
 title = "Number of records and 2005 night light level",
 covariate.labels = "Number of records during Ming and Qing",
          dep.var.labels   = " Night light level in 2005")

# Visualize the regression
ggplot(data=china_cnty,aes(x=n_bios, y=light))+
  geom_point()+scale_x_log10()+scale_y_log10()+ geom_smooth(method="lm")
ggsave("Results/reg.png")


# ---
# Get information about the passed "R thing" and put it into a data frame
# which is then returned
# ---

jungle <- function(x) {

   names <- c( "typeof"
              ,"mode"
              ,"storage.mode"
              ,"attributes"
              ,"classes"
              ,"implicit class"
              ,"homogeneous"
              ,"matrix"
              ,"array")

   # "res" is a list with names; this is the value to be returned.
   # Initialize it with NAs at first.

   res <- rep(list(NA), length(names))
   attr(res, "names") <- names

   # str(x) outputs to terminal (why can't I capture the output?)

   # message("Structure via str(x)")
   # str(x)

   # -- storage mode

   res[["typeof"]] <- typeof(x)
   res[["mode"]]   <- mode(x)
   if (typeof(x) != storage.mode(x)) {
      res[["storage.mode"]] <- storage.mode(x)
   }
   else {
      res[["typeof"]] <- paste0(res[["typeof"]]," (same as 'storage.mode')")
      res[["storage.mode"]] <- NULL
   }

   # -- attributes (including 'class')

   if (!is.null(attributes(x))) {
      res[["attributes"]] <- listofy(names(attributes(x)));
   }
   else {
      res[["attributes"]] <- NULL
   }

   # -- class attribute

   if (!is.null(attr(x, "class"))) {
      res[["classes"]] <- listofy(class(x));
      res[["implicit class"]] <- NULL
   }
   else {
      res[["classes"]] <- NULL
      res[["implicit class"]] <- class(x)
   }

   # -- homogeneous type

   res[["homogeneous"]] <- is.atomic(x)
   res[["matrix"]]      <- is.matrix(x)
   res[["array"]]       <- is.array(x)
   if (res[["homogeneous"]]) {

   }

#   if (is.atomic(x) || is.list(x)) {
#      message("This is a vector of type: ", typeof(x), " and length: ", length(x))
#      if (is.recursive(x)) {
#         message("This is a list, also known as a 'recursive vector'")
#      }
#      if (is.atomic(x)) {
#         message("This is an atomic vector");
#      }
#      if (is.atomic(x) & is.recursive(x)) {
#         message("The vector is both atomic and recursive. Something is wrong.")
#      }
#   }
#
#   else {
#      message("This is not a vector")
#   }

   return(res)
}

listofy <- function(l) {
   text <- ""
   addcomma <- FALSE
   for (name in l) {
      if (addcomma) {
         text <- paste0(text,",")
      }
      text <- paste0(text,"\"",name,"\"")
      addcomma <- TRUE
   }
   return(text)
}

bp <- function(txt,l) {
   message(paste0("=== ",txt," ==="))
   for (name in names(l)) {
      message(paste0("   ",sprintf("%20s = ",name),l[[name]]))
   }
}

bp("NULL", jungle(NULL))
bp("NA", jungle(NA))
bp("TRUE", jungle(TRUE))
bp("logical(0)", jungle(logical(0)))
bp("1", jungle(1))
bp("c(1)", jungle(c(1)))
bp("list(1)", jungle(list(1)))
bp("matrix(1)", jungle(matrix(1)))
bp("tibble(1)", jungle(tibble(1)))


# Overview of packages

# install.packages(), which as you can expect, installs a given package.
# library() which loads packages, i.e. attaches them to the search list on your R workspace.
# using search() command within R console will show the packages currently installed in the R workspace

# Load the ggplot2 package
library("ggplot2")

# Retry the qplot() function
qplot(mtcars$wt, mtcars$hp)

# Check out the currently attached packages again
search()


train_model <- function(X, Y, ...){
  feats = read.table("task0/data/processed/abt_features.txt", stringsAsFactors=FALSE)[,1]
  rhs = paste(feats, collapse=" + ")
  formula = paste0('target ~ ', rhs)

  X$target = Y
  glm(formula, data=X, family=binomial)
}

predict_model <- function(mod, X, type=NA, ...){
  scores = predict(mod, newdata=X, type="response")
  if(!is.na(type) && type == "class"){
    scores = scores > .5
  }
  scores
}


#########################################################################################
# Script to create verbal-nonverbal convergence scores
# Eleanor Collier
# 1/27/22
#########################################################################################

# Set up workspace
library(tidyverse)

get_data_here  <- "/Volumes/GoogleDrive/My Drive/UCR/UCR SNL/Research Projects/SyncDisclosures/Pilot/Analysis/Data/processed/moment_to_moment/"

# Load data
VADER_data     <- read_csv(paste0(get_data_here, 'transcripts_by_window_vader.csv')) %>% distinct()
accoustic_data <- read_csv(paste0(get_data_here, "accoustic_features_by_time.csv")) %>%
  mutate(sound = case_when(pitch > 0 ~ 'speaking', pitch == 0 ~ 'silence'))

#########################################################################################
## Mean by disclosure ----
verbal_nonverbal_convergence <-
  inner_join(VADER_data, accoustic_data, by=c('ID', 'disclosure', 'time')) %>%
  # Filter for moments of speech only
  filter(sound=="speaking") %>%
  group_by(ID, disclosure) %>%
  summarize(
    arousal_pitch_conv = cor(vader_arousal, pitch),
    arousal_f1_conv = cor(vader_arousal, f1),
    valence_f2_conv = cor(vader_valence, f2)
  ) %>%
  ungroup()

# Save data
save_data_here <- "/Volumes/GoogleDrive/My Drive/UCR/UCR SNL/Research Projects/SyncDisclosures/Pilot/Analysis/Data/processed/mean_by_disclosure/"
write_csv(verbal_nonverbal_convergence, paste0(save_data_here, "verbal_nonverbal_convergence.csv"))

#########################################################################################
## Moment to moment ----
verbal_nonverbal_convergence_by_window <-
  inner_join(VADER_data, accoustic_data, by=c('ID', 'disclosure', 'time')) %>%
  # Filter for moments of speech only
  filter(sound=="speaking") %>%
  group_by(ID, disclosure) %>%
  summarize(
    arousal_pitch_conv = cor(vader_arousal, pitch),
    valence_f2_conv = cor(vader_valence, f2)
  ) %>%
  ungroup()

# Save data
save_data_here <- "/Volumes/GoogleDrive/My Drive/UCR/UCR SNL/Research Projects/SyncDisclosures/Pilot/Analysis/Data/processed/moment_to_moment/"
write_csv(verbal_nonverbal_convergence_by_window, paste0(save_data_here, "verbal_nonverbal_convergence_by_window.csv"))


library(lme4)
library(tidyverse)
library(ordinal)
## load('data/cleanedData.RData')

## naDate <- as.Date(NA)

## dat <- dat%>%
##   mutate(rownum=1:n())%>%
##   filter(Date>as.Date("1900-01-01"))%>%
##   arrange(Date)%>%
##   group_by(StudyId)%>%
##   mutate(lagDate=lag(Date))%>%
##   mutate_at(
##     vars(-Date,-StudyId,-lagDate,-BirthYear,-ends_with('_R'),-Site,-age,-rownum),
##     list(
##       lastObs=~na.locf(if_else(!is.na(lag(.)),lagDate,naDate),na.rm=FALSE),
##       lag=~na.locf(lag(.),na.rm=FALSE)
##     )
##   )%>%
##   select(-lagDate)%>%
##   arrange(rownum)%>%
##   select(-rownum)

## save(dat,file='cleanedDataWithLags.RData')

load('cleanedDataWithLags.RData')

dat <- dat%>%
  group_by(StudyId)%>%
  mutate_at(vars(BirthYear,ends_with('_R'),Site,age),~if(any(!is.na(.))) na.omit(.)[1] else NA)%>%
  mutate(cd4_100=cd4/100,cd4_100_lag=cd4_lag/100)%>%
  ungroup()

dat <- droplevels(dat)

## adhere as a function of lagged depression

ggplot(dat,aes(log(dep_total_lag+1),adhere))+geom_jitter()+geom_smooth(method='lm')

dat%>%group_by(adhere,dep_total_lag)%>%mutate(n=n())%>%
  ggplot(aes(log(dep_total_lag+1),adhere))+geom_point(aes(size=n),show.legend=FALSE)+
  geom_smooth(method='lm',method.args=list(weights=n))+scale_size(range=c(.5,100))

 dat%>%
   mutate(depLagCat=paste('Lagged Depression=',ifelse(dep_total_lag==0,0,ifelse(dep_total_lag<4,'1-3','4+'))))%>%
   ggplot(aes(adhere))+geom_bar(aes(y = (..count..)/sum(..count..)))+coord_flip()+facet_wrap(~depLagCat,nrow=1)+
   scale_y_continuous('Percentage',labels=scales::percent)

dat%>%group_by(dep_total_lag)%>%summarize(n=n(),avg.adhere=mean(adhere,na.rm=TRUE))%>%
  ggplot(aes(log(dep_total_lag+1),avg.adhere,size=n))+geom_point(show.legend=FALSE)+
  geom_smooth(method='lm',show.legend=FALSE)+scale_size(range=c(.5,20))
ggsave('laggedDepressionVsMeanAdhere.jpg')

dat%>%group_by(dep_total_lag)%>%summarize(n=n(),avg.adhere=mean(adhere,na.rm=TRUE))%>%
  ggplot(aes(dep_total_lag,avg.adhere,size=n))+geom_point(show.legend=FALSE)+
  geom_smooth(method='lm',show.legend=FALSE)+scale_size(range=c(.5,20))
ggsave('laggedDepressionVsMeanAdhereNoLog.jpg')

dat$adDepDist <- (dat$Date-dat$dep_total_lastObs)/1000

#aaa <- lmer(adhere~log(dep_total_lag+1)+adDepDist+I(as.numeric(adDepDist)^2)+as.factor(adhere_lag)+(adDepDist+I(as.numeric(adDepDist)^2)|StudyId),data=dat)
AdDep2 <- update(AdDep,.~.+age+Site+PresentSex_R+Hispanic_R+as.factor(Race_R))
#AdDep0 <- lmer(adhere~log(dep_total_lag+1)+adDepDist+as.factor(adhere_lag)+(1|StudyId),data=dat)

#AdDepInt <- lmer(adhere~dep_total_lag*as.factor(adhere_lag)*adDepDist+(adDepDist|StudyId),data=dat)

AdDepNoLog <- lmer(adhere~dep_total_lag+adDepDist+as.factor(adhere_lag)+age+Site+birthSex_R+Hispanic_R+Race_R+(adDepDist|StudyId),data=dat)

AdDepOrd <- clmm(factor(adhere,ordered=TRUE)~log(dep_total_lag+1)+adDepDist+as.factor(adhere_lag)+(adDepDist|StudyId),data=dat)
save(AdDepOrd,AdDep,AdDep2,file='fittedModels/AdDepOrd.RData')
AdDepOrd0 <- clmm(factor(adhere,ordered=TRUE)~log(dep_total_lag+1)+adDepDist+as.factor(adhere_lag)+(1|StudyId),data=dat)
anova(AdDepOrd,AdDepOrd0)
AdDepOrd2 <- clmm(factor(adhere,ordered=TRUE)~log(dep_total_lag+1)+adDepDist+as.factor(adhere_lag)+(adDepDist|StudyId)+age+Site+birthSex_R+Hispanic_R+Transgendered_R+Race_R,data=dat)
save(AdDepOrd2,file='fittedModels/AdDepOrd2.RData')

nd <- within(dat,{adDepDist=0;adhere=3})[rownames(model.frame(AdDep)),]
ppp <- predict(AdDep,nd)
nd%>%
  mutate(adhere=ppp+resid(AdDep))%>%
  group_by(dep_total_lag)%>%summarize(n=n(),avg.adhere=mean(adhere,na.rm=TRUE))%>%
  ggplot(aes(log(dep_total_lag+1),avg.adhere,size=n))+geom_point(show.legend=FALSE)+
  geom_smooth(method='lm',show.legend=FALSE)+scale_size(range=c(.5,5))+ylim(1,5)
ggsave('laggedDepressionVsMeanAdhereAdj.jpg')

## cd4 count as function of depression and adhere

p <- dat%>%
  mutate(depLagCat=paste('Lagged Depression=',ifelse(dep_total_lag==0,0,ifelse(dep_total_lag<4,'1-3','4+'))))%>%
  ggplot(aes(factor(adhere_lag,exclude=NA),cd4_100))+
  geom_boxplot()+
  geom_smooth(aes(adhere_lag,cd4_100),method='lm')+
  labs(x='Lagged Adherence',y='CD4 Count/100')+
  scale_x_discrete(na.translate=FALSE)
ggsave('adhereLagVsCD4.jpg',p)

ggsave('adhereLagVsCD4byDepLag.jpg',p+facet_wrap(~depLagCat,nrow=1))

dat$depDist <- (dat$Date-dat$dep_total_lastObs)/1000
dat$adhereDist <- (dat$Date-dat$adhere_lastObs)/1000
dat$cd4Dist <- (dat$Date-dat$cd4_lastObs)/1000

cd4AdDep <- lmer(cd4_100~log(dep_total_lag+1)+depDist+adhere_lag+adhereDist+cd4_100_lag+(depDist+adhereDist+cd4Dist|StudyId),data=dat)
summary(update(cd4AdDep,subset=cd4Dist>=adhereDist))
cd4AdDep2 <- update(cd4AdDep,.~.+age+Site+PresentSex_R+Hispanic_R+as.factor(Race_R)

save(cd4AdDep,cd4AdDep2,file='fittedModels/cd4AdDep.RData')

mmm <- colMeans(model.matrix(cd4AdDep))

nd <- within(dat,{dep_total_lag=exp(1.06)-1;depDist=0;adhereDist=0;cd4_100_lag=5.3})[rownames(model.frame(cd4AdDep)),]

ppp <- predict(cd4AdDep,nd)

p <- nd%>%
  mutate(cd4_100=ppp+resid(cd4AdDep))%>%
  ggplot(aes(factor(adhere_lag,exclude=NA),cd4_100))+
  geom_boxplot()+
  geom_smooth(aes(adhere_lag,cd4_100),method='lm')+
  labs(x='Lagged Adherence',y='CD4 Count/100')+
  scale_x_discrete(na.translate=FALSE)+ylim(1,5)
#ggsave('adhereLagVsCD4.jpg',p)

## qol as function of depression, adhere, cd4

dat%>%
  mutate(
    #depLagCat=paste('Lagged Depression=',ifelse(dep_total_lag==0,0,ifelse(dep_total_lag<4,'1-3','4+'))),
    cd4LagCat=round(as.numeric(as.character(cut(dat$cd4_lag,quantile(dat$cd4_lag,seq(0,1,.05),na.rm=TRUE),labels=quantile(dat$cd4_lag,seq(0.05,1,.05)-.025,na.rm=TRUE)))),-1)
    #adhere_lag=paste('Lagged Adhere=\n',adhere_lag)
  )%>%
  filter(!is.na(dep_total_lag),!is.na(cd4_lag),!is.na(adhere_lag))%>%
  gather("predictor","value",dep_total_lag,cd4LagCat,adhere_lag)%>%
  group_by(predictor,value)%>%
  summarize(n=n(),avg.qol=mean(qol1_5_total,na.rm=TRUE))%>%
  ungroup()%>%
  ggplot(aes(value,avg.qol))+
  geom_point(aes(size=n),show.legend=FALSE)+
  geom_smooth(method='lm',formula=y~poly(x,2))+
  facet_wrap(~predictor,scales="free_x")

ggsave('qolByDepCd4Adhere.jpg')

dat$cd4Dist <- (dat$Date-dat$cd4_lastObs)/1000

qolAdDepCd4 <- clmm(factor(qol1_5_total,ordered=TRUE)~log(dep_total_lag+1)+depDist+adhere_lag+adhereDist+cd4_100_lag+cd4Dist+qol1_5_total_lag+(depDist+adhereDist+cd4Dist|StudyId),data=dat)

qolAdDepCd4int <- clmm(factor(qol1_5_total,ordered=TRUE)~log(dep_total_lag+1)*cd4_100_lag*adhere_lag+
                      depDist+adhereDist+cd4Dist+qol1_5_total_lag+(depDist+adhereDist+cd4Dist|StudyId),data=dat)

qolAdDepCd4.1 <- update(qolAdDepCd4,.~.+age+Site+birthSex_R+Hispanic_R+Transgendered_R+Race_R)

qolAdDepCd4int.1 <- update(qolAdDepCd4int,.~.+age+Site+birthSex_R+Hispanic_R+Transgendered_R+Race_R)

save(list=grep('qolAdDepCd4',ls(),value=TRUE),file='fittedModels/qolAdDepCd4.RData')
  ## group_by(dep_total_lag,adhere_lag,cd4LagCat)%>%
  ## summarize(n=n(),avg.qol=mean(qol1_5_total,na.rm=TRUE),cd4Lag=mean(cd4,na.rm=TRUE))%>%

cat('Increasing log depression by 1 sd decreases adherence by 0.06 sd')
cat('Increasing adherence by 1 (=1SD) increases cd4 count by 8')
# increasing cd4 by 100 increases odds of moving to higher qol level by 1%
# increasing adherences by 1 increases odds "" by 10%


pdf_file<-"pdf/histograms_7x7.pdf"
cairo_pdf(bg="grey98", pdf_file,width=25,height=25)

par(omi=c(2,0.75,2.5,0.25),mai=c(0,0,0,0),mfrow=c(7,7),family="Lato Light")
library(memisc)

# Import data and prepare chart

ZA4804<-spss.system.file("mydata/ZA4804_v3-0-0.sav")

myData<-subset(ZA4804,select=c(s002evs,s003,x047d))
attach(myData)
t<-subset(myData,x047d>0 & s002evs=="2008-2010")

tMedians<-aggregate(as.numeric(x047d),list(as.factor(s003)),median,na.rm =T)

tCountries<-tMedians[order(tMedians$x),1]

# Create chart

attach(t)
for (i in 1:(length(tCountries)-2))
{
Country<-subset(t,s003==tCountries[i])
hist(Country$x047d,main="",axes=F,xlab="",ylab="",xlim=c(0,8),ylim=c(0,1000),border="white",col="red",breaks=seq(from=-2,to=16,by=0.5))
text(4,900,tCountries[i],cex=3.0)
box(lty='dotdash',col='grey')
if (i==43) axis(1,cex.axis=3,at=c(0,8),labels=c("Less\nthan €150","€8,000"),mgp=c(0,8,1))
}

# Titling

mtext("European Value Study 2008-2010: Income Distribution of 47 Countries",3,line=10,adj=0,cex=3.8,family="Lato Black",outer=T)
mtext("Monthly Household Income (PPP Adjusted) in Euro",3,line=3,adj=0,cex=3.5,font=3,outer=T)
mtext("Source: ZA4804 European Values Study Longitudinal Data File 1981-2008, www.gesis.org",1,line=7,adj=1.0,cex=2,font=3,outer=T)
dev.off()


\eqn{\sqrt{x}}


#!/usr/bin/R
# Combine mutliple networks using Quantile Combine method (ref: Hien's Thesis)

# source("/home/mblab/ykang/proj_hien_thesis/hliowThesisScript.R")
quantileCombine <- function(scoreList, plot = FALSE, verbose = FALSE, returnScoreListOfAllRepresentation = FALSE) {
	# quantile combination of scores: score can either be specified in list(...) or scoreList
	# plot: whether to plot the histogram of the distribution of each score
	# returnScoreListOfAllRepresentation: whether to return the combination using every representative distribution or only the final combined score
	require("matrixStats");
	if (missing(scoreList)) scoreList <- list(...); # put scores in scoreList
	rawScoreMat <- do.call("cbind", lapply(scoreList, c)); # each score source as a column in the matrix
	absScoreList <- lapply(scoreList, abs);
	nonNaCount <- colSums(!is.na(rawScoreMat)); # number of non NA entries of each member
	combinedScoreMat <- rawScoreMat * NA; # matrix to store combined scores, each column is a combination using one representative distribution
	if (verbose) cat("Ranking scores ... ");
	rankMat <- apply(abs(rawScoreMat), 2, rank);  # rawScoreMat converted to ranks
	rankMat[is.na(rawScoreMat)] <- NA;
	if (verbose) cat("DONE\n");
	if (length(unique(nonNaCount)) == 1) { # if every member has the same amount of non NA entries, invoke sort and rank functions to combine scores really fast
		if (verbose) cat("Sorting scores ... ");
		sorted <- apply(abs(rawScoreMat), 2, sort);
		ix1 <- head(rep(sequence(nrow(sorted)), each = 2), -1);
		ix2 <- tail(rep(sequence(nrow(sorted)), each = 2), -1);
		sortedWithHalfwayValue <- (sorted[ix1, , drop = FALSE] + sorted[ix2, , drop = FALSE]) / 2; # sorted absScores with halfway values
		for (i in sequence(ncol(combinedScoreMat))) {
			# if (verbose) cat(i, "\n");
			convertedMat <- rankMat * NA; # matrix to store scores converted to the representative quantiles
			convertedMat[!is.na(rawScoreMat)] <- sortedWithHalfwayValue[c(rankMat[!is.na(rawScoreMat)]) * 2 - 1, i]; # quantile conversion
			combinedScoreMat[, i] <- rowMeans(convertedMat * sign(rawScoreMat), na.rm = TRUE); # averaging the converted scores
		}
	} else { # if members have different amounts of non NA entries, cannot invoke sort and rank, quantiles need to be estimated
		if (verbose) cat("Generating empirical cdf... ");
		qList <- lapply(scoreList, ecdf); # list if ecdf
		portionMat <- (rankMat - 1) / rep(colMaxs(rankMat, na.rm = TRUE) - 1, each = nrow(rankMat)); # rankMat scaled to [0, 1]
		portionMatrix[naIx] <- 0;
		convertedMat <- rankMat * NA; # matrix to store scores converted to the representative quantiles
		for (estimatedDistribution in qList) {
			if (plot) hist(estimatedDistribution);
			if (verbose) print(dim(convertedMat));
			convertedMat[!is.na(rawScoreMat)] <- quantile(estimatedDistribution, c(portionMatrix[!is.na(rawScoreMat)]), na.rm = TRUE); # quantile conversion
			combinedScoreMat[, i] <- rowMeans(convertedMat * sign(rawScoreMat), na.rm = TRUE); # averaging the converted scores
		}
	}
	if (verbose) cat("DONE\n");
	if (returnScoreListOfAllRepresentation) { # reshape combinedScoreMat to a list of combined scores, each is bases on one representative distribution
		combinedScoreList <- list();
		for (i in sequence(ncol(combinedScoreMat))) {
			combinedScoreList[[i]] <- scoreList[[1]] * NA;
			combinedScoreList[[i]][] <- combinedScoreMat[, i];
		}
		names(combinedScoreList) <- names(scoreList);
		combinedScoreList;
	} else { # combine combined scores based on different representative distributions
		combinedRankMat <- apply(abs(combinedScoreMat), 2, rank) * sign(combinedScoreMat);
		combinedRankMat[is.na(combinedScoreMat)] <- NA;
		score <- scoreList[[1]] * NA; # to store final combined score
		score[] <- rowMeans(combinedRankMat);
		score;
	}
}

# main script
args <- commandArgs(trailingOnly=TRUE)
data <- list()
cat("Loading network ... ")
for (i in 1:(length(args)-1)) {
	data[length(data)+1] <- list(as.matrix(read.table(toString(args[i]))))
}
cat("DONE\n")
combined <- quantileCombine(data, verbose=TRUE, returnScoreListOfAllRepresentation=TRUE)
write.table(combined[[1]],args[length(args)],row.names=FALSE,col.names=FALSE,quote=FALSE)


library(data.table)
library(magrittr)
library(dplyr)

a = fread("C:/Users/dzj/.julia/v0.6/FastGroupBy/hehe5.csv")

library(ggplot2)

ggplot(a) + geom_bar(aes(x = as.factor(n), fill = factor(algo), weight = log(x1)), position = "dodge")

ggplot(a) +
  geom_line(aes(x = log(n,2), color = factor(algo), y = log(x1)))

ggplot(a %>% filter(n > 2^16-1)) +
  geom_line(aes(x = log(n,2), color = factor(algo), y = log(x1,10)))

ggplot(a %>% filter(n <= 2^16-1)) +
  geom_line(aes(x = log(n,2), color = factor(algo), y = log(x1,10)))


library(jsonlite)
library(readr)
library(zoo)

json_data <- fromJSON('https://www.koronavirus.hr/json/?action=po_danima_zupanijama')

write(toJSON(json_data), 'data/latest/last_data_po_danima_zupanijama.json')
write(toJSON(json_data), paste('data/per_day/po_danima_zupanijama_', format(Sys.time(), '%Y_%m_%d'), '.json', sep=''))

json_data <- json_data[, c("Datum", "PodaciDetaljno")]

# drop newly added, previously missing data as we have it stored in data/missing_data.json and there were issues with the new data
json_data<-json_data[!json_data$Datum=="2021-11-02 00:00", ]
json_data<-json_data[!json_data$Datum=="2021-11-08 00:00", ]
json_data<-json_data[!json_data$Datum=="2021-11-10 00:00", ]
json_data<-json_data[!json_data$Datum=="2021-11-15 00:00", ]
json_data<-json_data[!json_data$Datum=="2021-11-18 00:00", ]

json_data <- unique(json_data, by = "Datum")

# not all info is correct in the missing_data.json (e.g. active cases is wrong for sure)
missing_data <- fromJSON('data/missing_data.json')

json_data$Datum <- as.Date(json_data$Datum, format="%Y-%m-%d")
missing_data$Datum <- as.Date(missing_data$Datum, format="%Y-%m-%d")

# add missing data
json_data <- rbind(json_data, missing_data)

# sort by date
data_sorted <- json_data[order(json_data$Datum),]

# all counties
counties <- data_sorted[1, ]$PodaciDetaljno[[1]]$Zupanija

col_classes = c("Date", rep("integer", length(counties)))
col_names = c('Datum', counties)

cumulative_cases <- read.table(text="", colClasses=col_classes, col.names=col_names)

for(d in 1:nrow(data_sorted)) {
  cumulative_cases[nrow(cumulative_cases) + 1,] = data.frame(data_sorted[d, ]$Datum, t(data_sorted[d, ]$PodaciDetaljno[[1]]$broj_zarazenih))
}

# sum all counties data to get total for Croatia
cumulative_cases$Hrvatska <- rowSums(cumulative_cases[,-c(1)])

# hack to fix wrong data caused by some issues in the koronavirus.hr json data
true_d = c(27, 24, 19, 166, 14, 15, 17, 17, 11, 7, 62, 8, 26, 2, 14, 221, 16, 4, 29, 43, 63, 805)
reported_d = c(28, 27, 21, 167, 10, 3, 19, 22, 14, 9, 61, 4, 23, 0, -3, 230, 10, 4, 24, 46, 86, 805)

diff_to_add = true_d - reported_d
cumulative_cases[cumulative_cases$Datum >= '2021-09-01', -c(1)] <- cumulative_cases[cumulative_cases$Datum >= '2021-09-01', -c(1)] + rep(diff_to_add, each = nrow( cumulative_cases[cumulative_cases$Datum >= '2021-09-01', ]))

diff_df <- cumulative_cases[-1, -c(1)] - cumulative_cases[-nrow(cumulative_cases), -c(1)]
diff_df$Datum <- cumulative_cases$Datum[-c(nrow(cumulative_cases))]

# more issues
diff_df[diff_df$Datum=='2021-09-24', c(4, 9, 13)] <- c(364, 0, 59)

# save diff data frame to data/latest/
# this will contain numbers of cases per day per county and the total
write.csv(diff_df, 'data/latest/diff_df.csv', row.names=FALSE, quote=FALSE)

cumulative_deaths <- read.table(text="", colClasses=col_classes, col.names=col_names)

for(d in 1:nrow(data_sorted)) {
  cumulative_deaths[nrow(cumulative_deaths) + 1,] = data.frame(data_sorted[d, ]$Datum, t(data_sorted[d, ]$PodaciDetaljno[[1]]$broj_umrlih))
}

# # hack to fix wrong data
cumulative_deaths[cumulative_deaths$Datum == '2021-08-30', c(10)] <- 150
cumulative_deaths[cumulative_deaths$Datum == '2021-08-30', c(17)] <- 641

cumulative_deaths[cumulative_deaths$Datum == '2021-09-01', c(5)] <- 2564 # zagreb
cumulative_deaths[cumulative_deaths$Datum == '2021-09-01', c(21)] <- 255 # zadarska

cumulative_deaths$Hrvatska <- rowSums(cumulative_deaths[,-c(1)])

diff_deaths_df <- cumulative_deaths[-1, -c(1)] - cumulative_deaths[-nrow(cumulative_deaths), -c(1)]

diff_deaths_df$Datum <- cumulative_deaths$Datum[-c(nrow(cumulative_deaths))]

# save diff data frame to data/latest/
# this will contain numbers of cases per day per county and the total
write.csv(diff_deaths_df, 'data/latest/diff_deaths_df.csv', row.names=FALSE, quote=FALSE)

avg7_df <- as.data.frame(rollapply(diff_df[, 1:ncol(diff_df) - 1], 7, mean, fill=NA, align="right"))

avg7_df_lag <- rbind(NA, head(avg7_df, -7))

percentage_change = (tail(avg7_df, n=nrow(avg7_df_lag)) / avg7_df_lag - 1) * 100

sum_14_df = (tail(avg7_df, n=nrow(avg7_df_lag)) + avg7_df_lag) * 7
sum_7_df = tail(avg7_df, n=nrow(avg7_df_lag)) * 7

colnames(sum_14_df) <- paste("ukupno_14d", colnames(percentage_change), sep = "_")
colnames(sum_7_df) <- paste("ukupno_7d", colnames(percentage_change), sep = "_")

avg7_df$Datum <- cumulative_cases$Datum[-c(nrow(cumulative_cases))]
avg7_df_lag$Datum <- cumulative_cases$Datum[c(8:nrow(cumulative_cases) - 1)]

sum_14_df$Datum <- cumulative_cases$Datum[c(8:nrow(cumulative_cases) - 1)]
sum_7_df$Datum <-  cumulative_cases$Datum[c(8:nrow(cumulative_cases) - 1)]
#
# write.csv(cumulative_cases, 'data/latest/cumulative_cases.csv', row.names=FALSE, quote=FALSE)
# write.csv(avg7_df, 'data/latest/avg7_df.csv', row.names=FALSE, quote=FALSE)

colnames(percentage_change) <- paste("tjedna_razlika", colnames(percentage_change), sep = "_")

percentage_change$Datum <- cumulative_cases$Datum[c(8:nrow(cumulative_cases) - 1)]

save(percentage_change, file='data/latest/percentage_change.Rda')
save(cumulative_cases, file='data/latest/cumulative_cases.Rda')
save(avg7_df, file='data/latest/avg7_df.Rda')
save(sum_7_df, file='data/latest/sum_7_df.Rda')
save(sum_14_df, file='data/latest/sum_14_df.Rda')

last_date <- strftime(percentage_change$Datum[nrow(percentage_change)], "%d.%m.%Y.")
last_date_ <- strftime(percentage_change$Datum[nrow(percentage_change)], "%Y_%m_%d")

save(last_date, file='data/latest/last_date.Rda')
save(last_date_, file='data/latest/last_date_.Rda')

# get age data
json_data <- fromJSON('https://www.koronavirus.hr/json/?action=po_osobama')
write(toJSON(json_data), 'data/latest/last_data_po_osobama.json')