\name{HilbertCurve}
\alias{HilbertCurve}
\title{
Initialize a Hilbert curve
}
\description{
Initialize a Hilbert curve
}
\usage{
HilbertCurve(s, e, level = 4, mode = c("normal", "pixel"),
    reference = FALSE, reference_gp = gpar(lty = 3, col = "#999999"),
    arrow = TRUE, zoom = NULL, newpage = TRUE,
    background_col = "transparent", background_border = NA,
    title = NULL, title_gp = gpar(fontsize = 16),
    start_from = c("bottomleft", "topleft", "bottomright", "topright"),
    first_seg = c("horizontal", "vertical"), legend = list(),
    padding = unit(2, "mm"))
}
\arguments{

  \item{s}{position that will be mapped as the start of the Hilbert curve. The value should a single numeric value. If it is a vector, the minimum is used.}
  \item{e}{position that will be mapped as the end of the Hilbert curve. The value should a single numeric value. If it is a vector, the maximum is used.}
  \item{level}{iteration level of the Hilbert curve. There will by \code{4^level - 1} segments in the curve.}
  \item{mode}{"normal" mode is used for low \code{level} value and "pixel" mode is always used for high \code{level} value, so the "normal" mode is always for low-resolution visualization while "pixel" mode is used for high-resolution visualization. See 'details' for explanation.}
  \item{reference}{whether add reference lines on the plot. Only works under 'normal' mode. The reference line is only used for illustrating how the curve folds.}
  \item{reference_gp}{graphic settings for the reference lines. It should be specified by \code{\link[grid]{gpar}}.}
  \item{arrow}{whether add arrows on the reference line. Only works under 'normal' mode.}
  \item{zoom}{Internally, position are stored as integer values. To better map the data to the Hilbert curve,  the original positions are zoomed according to the range and the level of Hilbert curve. E.g. if  the curve visualizes data ranging from 1 to 2 but level of the curve is set to 4, the positions will be zoomed by ~x2000 so that values like 1.5, 1.555 can be mapped to the curve with more accuracy. You don't need to care the zooming thing,  proper zooming factor is calculated automatically.}
  \item{newpage}{whether call \code{\link[grid]{grid.newpage}} to draw on a new graphic device.}
  \item{background_col}{background color.}
  \item{background_border}{background border border.}
  \item{title}{title of the plot.}
  \item{title_gp}{graphic parameters for the title. It should be specified by \code{\link[grid]{gpar}}.}
  \item{start_from}{which corner on the plot should the curve starts?}
  \item{first_seg}{the orientation of the first segment.}
  \item{legend}{a \code{\link[grid:grid.grob]{grob}} object, a \code{\link[ComplexHeatmap]{Legends-class}} object, or a list of them.}
  \item{padding}{padding around the Hilbert curve.}

}
\details{
This funciton initializes a Hilbert curve with level \code{level} which corresponds
to the range between \code{s} and \code{e}.

Under 'normal' mode, there is a visible Hilbert curve which plays like a folded axis and
different low-level graphics can be added afterwards according to the coordinates.
It works nice if the level of the Hilbert curve is small (say less than 6).

When the level is high (e.g. > 10), the whole 2D space will be almost completely filled by the curve and
it is impossible to add or visualize e.g. points on the curve. In this case, the 'pixel'
mode visualizes each tiny 'segment' as a pixel and maps values to colors. Internally, the whole plot
is represented as an RGB matrix and every time a new layer is added to the plot, the RGB matrix
will be updated according to the color overlay. When all the layers are added, normally a PNG figure is generated
directly from the RGB matrix. So the Hilbert
curve with level 11 will generate a PNG figure with 2048x2048 resolution. This is extremely
useful for visualize genomic data. E.g. If we make a Hilbert curve for human chromosome 1 with
level 11, then each pixel can represent 60bp (\code{249250621/2048/2048}) which is of very high resolution.

Under 'pixel' mode, if the current device is an interactive deivce, every time a new layer is added,
the image will be add to the interactive device as a rastered image. But still you can use \code{\link{hc_png,HilbertCurve-method}}
to export the plot as PNG file.

To make it short and clear, under "normal" mode, you can use following low-level graphic functions:

\itemize{
  \item \code{\link{hc_points,HilbertCurve-method}}
  \item \code{\link{hc_segments,HilbertCurve-method}}
  \item \code{\link{hc_rect,HilbertCurve-method}}
  \item \code{\link{hc_polygon,HilbertCurve-method}}
  \item \code{\link{hc_text,HilbertCurve-method}}
}

And under "pixel" mode, you can use following functions:

\itemize{
  \item \code{\link{hc_layer,HilbertCurve-method}}
  \item \code{\link{hc_png,HilbertCurve-method}}
  \item \code{\link{hc_polygon,HilbertCurve-method}}
  \item \code{\link{hc_text,HilbertCurve-method}}
}

Notice, \code{s} and \code{e} are not necessarily to be integers, it can be any values (e.g. numeric or even negative values).
}
\value{
A \code{\link{HilbertCurve-class}} object.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
HilbertCurve(1, 100, reference = TRUE)
HilbertCurve(1, 100, level = 5, reference = TRUE)
HilbertCurve(1, 100, title = "title", reference = TRUE)
HilbertCurve(1, 100, start_from = "topleft", reference = TRUE)

# plot with one legend
require(ComplexHeatmap)
legend = Legend(labels = c("a", "b"), title = "foo",
    legend_gp = gpar(fill = c("red", "blue")))
hc = HilbertCurve(1, 100, title = "title", legend = legend)
hc_segments(hc, x1 = 20, x2 = 40)

# plot with more than one legend
require(circlize)
legend1 = Legend(labels = c("a", "b"), title = "foo",
    legend_gp = gpar(fill = c("red", "blue")))
col_fun = colorRamp2(c(-1, 0, 1), c("green", "white", "red"))
legend2 = Legend(col_fun = col_fun, title = "bar")
hc = HilbertCurve(1, 100, title = "title", legend = list(legend1, legend2))
hc_segments(hc, x1 = 20, x2 = 40)
}


print(paste0(Sys.time(), " --- Taxonomic effort - publications (boxplot + violin plot)"))

# Individual plots

## Mean number of species per publication by decade
median_N_spp_per_pub_decade <- df_publications_N[, list(median_N_spp=median(n_species)),
                                                 by="date.decade"]

calc_median <- function(x){
  return(c(y = -5, label = length(x)))
  # experiment with the multiplier to find the perfect position
}

plot_tax_pub_decade <-
    ggplot(data=df_publications_N, aes(x=date.decade, y=n_species)) +
        geom_violin(width=3, fill="grey", alpha=.7, color="grey40", trim=T) +
        # geom_boxplot(width=0.2, outlier.size=NULL, fill="white") +
        geom_jitter(shape=16, position=position_jitter(0.2),
                    size=0.2, alpha=0.2, color='grey10') +
        geom_point(data=median_N_spp_per_pub_decade[date.decade != "1750s"],
                  mapping=aes(x=date.decade, y=median_N_spp, group=1),
                  size=2, color='black') +
        geom_line(data=median_N_spp_per_pub_decade[date.decade != "1750s"],
                  mapping=aes(x=date.decade, y=median_N_spp, group=1),
                  size=1, color='black') +
        # geom_line(data=median_N_spp_per_pub_decade,
        #           mapping=aes(x=date.decade, y=mean_N_spp, group = 1),
        #           size=1.3, color="red", alpha=0.9, linetype='dashed') +
        scale_y_continuous(limit=c(-5, 40)) +
        # stat_summary(fun.data=calc_median, geom="text", fun=median,
        #              position=position_dodge(width = 0.75), size=3) +
        xlab("\nDecade") + ylab("Number of species described \nper publication\n") +
        theme

## Species per author across years
N_spp_per_des_decade <- df_describers_year[, list(mean_N_spp = mean(N),
                                                  median_N_spp=median(N)),
                                                  by="date.decade"]

plot_tax_des_decade <-
    ggplot(data=df_describers_year, aes(x=date.decade, y=N)) +
        geom_violin(width=3, fill="grey", alpha=.7, color="grey40") +
        # geom_boxplot(width=0.2, outlier.size=NULL, fill="white") +
        geom_jitter(shape=16, position=position_jitter(0.2),
                    size=0.2, alpha=0.2, color='grey10') +
        # geom_line(data=median_N_spp_per_pub_decade,
        #           mapping=aes(x=date.decade, y=mean_N_spp, group = 1),
        #           size=1.3, color="red", alpha=0.9, linetype='dashed') +
        geom_point(data=N_spp_per_des_decade[date.decade != "1750s"],
                  mapping=aes(x=date.decade, y=median_N_spp, group=1),
                  size=2, color='black') +
        geom_line(data=N_spp_per_des_decade[date.decade != "1750s"],
                  mapping=aes(x=date.decade, y=median_N_spp, group=1),
                  size=1, color='black') +
        # geom_line(data=N_spp_per_des_decade[date.decade != "1750s"],
        #           mapping=aes(x=date.decade, y=mean_N_spp, group=1),
        #           size=1, color='grey') +
        scale_y_continuous(limit=c(-5, 40)) +
        # stat_summary(fun.data=calc_median, geom="text", fun=median,
        #              position=position_dodge(width = 0.75), size=3) +
        xlab("\nDecade") + ylab("Number of species described \nper PTE\n") +
        theme

# Combined plots
ggsave(paste0(dir_plot, 'fig-2a.png'), plot_tax_pub_decade, units="cm", width=21, height=8, dpi=300)
ggsave(paste0(dir_plot, 'fig-2b.png'), plot_tax_des_decade, units="cm", width=21, height=8, dpi=300)

# Trend analysis
median_N_spp_per_pub_decade[date.decade != "1750s"]$median_N_spp
N_spp_per_des_decade[date.decade != "1750s"]$median_N_spp

res <- MannKendall(median_N_spp_per_pub_decade[date.decade != "1750s"]$median_N_spp)
summary(res)
res <- MannKendall(N_spp_per_des_decade[date.decade != "1750s"]$median_N_spp)
summary(res)


fn.in = file.path(PROJECT_DIR, "generated_data","MetaDE", "YF1-hedges-g.csv")
yf.res = fread(fn.in)

# load CD38 signature genes
fn.sig = file.path(PROJECT_DIR, "generated_data", "signatures", "CD38_ge_sig.txt")
cd38.genes = fread(fn.sig, header = F) %>% unlist(use.names=F) %>% toupper()

yf.cd38 = yf.res %>%
  dplyr::filter(toupper(Gene) %in% cd38.genes) %>%
  mutate(Gene = factor(Gene, levels=rev(cd38.genes)))

gene.na = (levels(yf.cd38$Gene) %in% yf.cd38$Gene)+1
gene.clr = c("grey50","black")[gene.na]

ggplot(yf.cd38, aes(Gene, Hedges.g)) +
  geom_point() +
  geom_errorbar(aes(ymin=Conf95.lower, ymax=Conf95.upper), width=0.2) +
  scale_x_discrete(drop=FALSE) +
  ylab("Effect size") +
  geom_hline(yintercept=0) +
  coord_flip(ylim = c(-1.6, 2.3)) +
  ggtitle("Yellow Fever vaccination (trial #1)") +
  theme_bw() + theme(axis.text.y = element_text(colour=gene.clr))

dn.fig = file.path(PROJECT_DIR, "figure_generation","MetaDE")
dir.create(dn.fig, showWarnings = F)
fn.fig = file.path(dn.fig, "YF_effect_size_plot")
ggsave(paste0(fn.fig, ".png"),w=4, h=3)
ggsave(paste0(fn.fig, ".pdf"),w=4, h=3)


# Leap year calculator functions
# Author: Dainius Masiliunas, team Rython
# Date: 7th of January, 2016
# License: Apache License 2.0

# Calculates whether the year entered is a leap year or not.
is.leap = function(year)
{
    input = year

    # If characters, try coercing into a numeric
    if (is.character(year))
        year = suppressWarnings(as.numeric(year))

    # Sanity checks
    if (!is.numeric(year))
        stop("Error: argument of class numeric expected")
    if (is.na(year))
    {
        # If it's NA, then it might be due to the user entering NA or a failed coercion; but it could be a date
        year = try(as.numeric(strsplit(input, " ")[[1]][6]), TRUE)
        if (!is.numeric(year) || is.na(year) || class(year) == "try-error")
            stop("Error: failed to parse input argument")
    }
    if (year < 1582)
        warning(paste(year, "is out of the valid range"))

    # Make sure input is integer
    year = floor(year)

    if (year %% 4 > 0)
        return(FALSE)
    else if (year %% 100 > 0)
        return(TRUE)
    else if (year %% 400 > 0)
        return(FALSE)
    return(TRUE)
}


# GetNoAudit100Data.r
sPlotFile <- "noaudit100.png"

source("../common/DataUtil.r")

# G E T   D A T A
if (exists("results")) {rm(results)}
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.auditannually <- fndfGetAuditData(results)

# T A B U L A T E   D A T A
# Tabulate columns by copies and sector lifetime.
tbl.auditannually <- data.frame(with(dat.auditannually,
            tapply(mdmlosspct, list(copies, lifem), FUN=identity)))

if(0){
# Re-form the data into a table for printing.
foo<-(with(dat.auditannually,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(results$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))
# Pretty-print this to a file with explanatory headings.
sOutputFilename <- "./Data_AuditAnnually.txt"
sTitle <- "Document losses with multiple copies and annual total auditing"
sSubtitle <- "Table of percentage loss of collection tabulated\n" %+%
    "by number of copies and sector half-lifetime"
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()
}#ENDIF0

# Micah succeeded in bending dcast to his will, thanks; see email.
library(reshape2)
bar.small <- dat.auditannually[,c("copies", "lifem", "mdmlosspct")]
bar.melted <- melt(bar.small, id=c("copies", "lifem"))
bar.recast <- dcast(bar.melted, copies~lifem)

# P L O T   D A T A
library(ggplot2)
source("../common/PlotUtil.r")

# Show lines for various copies, with no auditing, over wiiiide range.
nCopies <- 1; trows1 <- fnSelectCopies(dat.auditannually, nCopies)
nCopies <- 3; trows3 <- fnSelectCopies(dat.auditannually, nCopies)
nCopies <- 5; trows5 <- fnSelectCopies(dat.auditannually, nCopies)
nCopies <- 8; trows8 <- fnSelectCopies(dat.auditannually, nCopies)
nCopies <- 10; trows10 <- fnSelectCopies(dat.auditannually, nCopies)
nCopies <- 20; trows20 <- fnSelectCopies(dat.auditannually, nCopies)
trows <- rbind(trows1, trows3, trows5, trows10, trows20)

# Titles lib requires trows, so source here after it's defined.
source("../common/noaudittitles.r")

gp <- ggplot(data=trows
            , aes(x=lifem,y=safe(mdmlosspct), color=factor(copies))
            )
gp <- gp + labs(color="Number of\nCopies")
gp <- fnPlotLogScales(gp, x="YES", y="YES"
                ,xbreaks=c(2,5,10,20,30,50,100,300,1000)
                ,ybreaks=c(0.01,0.10,1.00,10.00,100.00)
                )
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

gp <- gp + annotate("rect", fill = "yellow", alpha = 0.25
                , xmin = 30, xmax = 1000-1
                , ymin = 0.001, ymax = 100
                )

gp <- gp + theme(legend.position=c(0.9,0.86))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))

gp <- fnPlotTitles(gp
            , titleline=sTitleLine
            , xlabel=sXLabel
            , ylabel=sYLabel
        )

# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, sPlotFile)

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


source('./r_files/flatten_HTML.r')

############### Library Declarations ###############
libraryRequireInstall("ggplot2");
libraryRequireInstall("plotly")
libraryRequireInstall("tidyverse")
####################################################

################### Actual code ####################

fix_colnames <- function(df){
  colnames(df) <- str_replace_all(colnames(df), "[^A-Za-z0-9]", "_")
  colnames(df) <- paste0("a", colnames(df))
  return(df)
}

#PBI_PARAM fitting of scatterplot points
#Type:bool, Default:TRUE, Range:NA, PossibleValues:NA, Remarks: NA
fitting = TRUE
if(exists("settings_fitting_params_fitting")){
  fitting = settings_fitting_params_fitting
}

fitting_se = TRUE
if(exists("settings_fitting_params_se")){
  fitting_se = settings_fitting_params_se
}

fitting_level = 0.95
if(exists("settings_fitting_params_level")){
  fitting_level = as.numeric(settings_fitting_params_level)
}

scatter_size = 1
if(exists("settings_scatter_params_size")){
  scatter_size = as.numeric(settings_scatter_params_size)
}

scatter_alpha = 1
if(exists("settings_scatter_params_opacity")){
  scatter_alpha = as.numeric(settings_scatter_params_opacity)/100
}

x_label <- colnames(x)[[1]]
y_label <- colnames(y)[[1]]

color_label <- NULL
facet_row_label <- NULL
facet_col_label <- NULL

x <- fix_colnames(x)
y <- fix_colnames(y)

x_colname <- colnames(x)[[1]]
y_colname <- colnames(y)[[1]]
color_colname <- NULL
facet_row_colname <- "."
facet_col_colname <- "."

dataset <- cbind(x, y)

if(exists("color")) {
  color_label <- colnames(color)[[1]]
  color <- fix_colnames(color)

  dataset <- cbind(dataset, color)
  color_colname <- colnames(color)[[1]]
} else {
  scatter_color = "orange"
  if(exists("settings_scatter_params_color")) {
    scatter_color = settings_scatter_params_color
  }
}

if(exists("facet_row")) {
  facet_row_label <- colnames(facet_row)[[1]]
  facet_row <- fix_colnames(facet_row)

  dataset <- cbind(dataset, facet_row)
  facet_row_colname <- colnames(facet_row)[[1]]

  fix_facet_row_label <- function(label) {
    paste0(facet_row_label, ": ", label)
  }
  #fix_facet_row_label <- as_labeller(fix_facet_row_label)
} else {
  fix_facet_row_label <- NULL
}

if(exists("facet_col")) {
  facet_col_label <- colnames(facet_col)[[1]]
  facet_col <- fix_colnames(facet_col)

  dataset <- cbind(dataset, facet_col)
  facet_col_colname <- colnames(facet_col)[[1]]

  fix_facet_col_label <- function(label) {
    paste0(facet_col_label, ": ", label)
  }
  #fix_facet_col_label <- as_labeller(fix_facet_col_label)
} else {
  fix_facet_col_label <- NULL
}

p <- ggplot(data = dataset,
            mapping = aes_string(
                x_colname,
                y_colname,
                color = color_colname))

if(exists("color")) {
  p <- p + geom_point(size = scatter_size,
                      alpha = scatter_alpha)
} else {
  p <- p + geom_point(size = scatter_size,
                      alpha = scatter_alpha,
                      color = scatter_color)
}

if (fitting) {
  p <- p + geom_smooth(method = "lm", se = fitting_se, level = fitting_level)
}

if (exists("facet_row") | exists("facet_col")) {
  p <- p + facet_grid(reformulate(facet_col_colname, facet_row_colname), # the formula generated is "facet_row_colname ~ facet_col_colname"
                      labeller = labeller(#.rows = as_labeller(fix_facet_row_label,
                                           #                   default = label_value),
                                          .cols = as_labeller(fix_facet_col_label,
                                                              default = label_value)))
}

p <- p + labs(x = x_label,
              y = y_label,
              color = color_label
              )

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

############# Create and save widget ###############
p <- ggplotly(p);
internalSaveWidget(p, 'out.html');
####################################################


# dependencies

install.packages("psych")
install.packages("pastecs")
install.packages("dplyr")
install.packages("ggplot2")
install.packages("corrplot")
install.packages("descr")
install.packages("car")

# for mac os
# install.packages("data.table", dependencies=TRUE)
# update.packages()
install.packages("MASS")
install.packages("caret")
install.packages("glmnet")
install.packages("BLR")
install.packages("lars")
install.packages("corrplot")
install.packages("ggpubr")
install.packages("GGally")
install.packages("BCA")
install.packages("backports")
install.packages("gvlma")
install.packages("lmtest")

library(corrplot)
library(lars)
library(BLR)
library(glmnet)
library(caret)
library(MASS)
library(car)
library(stats)
library(descr)
library(corrplot)
library(ggplot2)
library(dplyr)
library(psych)
library(pastecs)
library(dplyr)
library(ggpubr)
library(GGally)
library(lmtest)
library(gvlma)
library(MASS)

# Load data , please set the folder

#setwd(dir = "f://diabetes")

setwd(dir = "/Users/gregory/Documents/pucp/diabetes")
data <- read.csv(file="data.csv", header=TRUE, sep=",", colClasses = c("character"))

names(data)
head(data)

# categorical columns
data$SEXO  <- as.factor(data$SEXO)
data$ECIVIL  <- as.factor(data$ECIVIL)
data$TRATAMIENTO  <- as.factor(data$TRATAMIENTO)
data$PIEDIABETICO  <- as.factor(data$PIEDIABETICO)
data$HTA  <- as.factor(data$HTA)

# numeric columns

data$EDAD <- as.numeric(data$EDAD)
data$TIEMPODIAG <- as.numeric(data$TIEMPODIAG)
data$PESO <- as.numeric(data$PESO)
data$TALLA <- as.numeric(data$TALLA)
data$IMC <- as.numeric(data$IMC)  # indice de masa corporal
data$HEMOGLOBINA <- as.numeric(data$HEMOGLOBINA) # indicador para medir la anemia
data$GLICOSILADA <- as.numeric(data$GLICOSILADA) # indicador para medir la diabetes
data$TRIGLICERIDOS <- as.numeric(data$TRIGLICERIDOS) #
data$COLESTEROL <- as.numeric(data$COLESTEROL) #
data$HDL <- as.numeric(data$HDL) #
data$ALBUMINA <- as.numeric(data$ALBUMINA) #
data$BUN <- as.numeric(data$BUN) #
data$UREA <- as.numeric(data$UREA) #
data$CREATININA <- as.numeric(data$CREATININA) #
data$TFGCKD <- as.numeric(data$TFGCKD) # tasa de filtracion glomerular
data$TFGMDRD <- as.numeric(data$TFGMDRD)

dim(data) # 30 row , 22 columns
str(data)

# select only numeric columns for initial analisis

data_selected <- select(data, -EDAD,-PESO,-TALLA,-ALIAS,-SEXO,-ECIVIL,-TRATAMIENTO,-HTA,-PIEDIABETICO,-TFGMDRD,-CREATININA)

names(data_selected)
# rename columns to generate a nice graphs

colnames(data_selected) <- c("TIE", "IMC", "HEMO", "GLI", "TRI", "COL", "HDL", "ALB","BUN", "URE",  "TFG" )

describe(data_selected) # summary(data_selected)

# scale to have a nice graph
data_scaled <- as.data.frame(scale(data_selected))

# box plot the data distribution

boxplot(data_scaled)

# deteccion outliers
boxplot.stats(data_selected$TIE)

# generate pie chart to categorical variables

par(mfrow=c(2,3))

casados = length(which(data$ECIVIL == "CASADO"))
solteros = length(which(data$ECIVIL == "SOLTERO"))
slices <- c(casados, solteros, viudos)
lbls <- c(
  paste("Casados", "\n" , casados, sep=""),
  paste("Solteros", "\n" , solteros, sep="")
)
pie(slices, labels = lbls, col =  c("#7FDBFF", "#B10DC9"))

insulina = length(which(data$TRATAMIENTO == "INSULINA"))
metformina = length(which(data$TRATAMIENTO == "ADO"))
ninguna = length(which(data$TRATAMIENTO == "NINGUNO"))

slices <- c(insulina, metformina, ninguna)
lbls <- c(
  paste("Insulina", "\n" , insulina, sep=""),
  paste("ADO", "\n" , metformina, sep=""),
  paste("Ninguna", "\n" , ninguna, sep=""))
pie(slices, labels = lbls, col =  c("#7FDBFF", "#01FF70", "#3D9970"))

masculinos = length(which(data$SEXO == "M"))
femeninos = length(which(data$SEXO == "F"))
slices <- c(masculinos, femeninos)
lbls <- c( paste("Hombre", "\n" , masculinos, sep=""), paste("Mujer", "\n" , femeninos, sep=""))
pie(slices, labels = lbls, col = c("#7FDBFF", "#B10DC9"))

hta_si = length(which(data$HTA == "SI"))
hta_no = length(which(data$HTA == "NO"))

slices <- c(hta_si, hta_no)
lbls <- c(
  paste("HTA SI", "\n" , hta_si, sep=""),
  paste("HTA NO", "\n" , hta_no, sep=""))
pie(slices, labels = lbls, col =  c("#7FDBFF", "#01FF70"))

isquemico = length(which(data$PIEDIABETICO == "ISQUEMICO"))
neuropatico = length(which(data$PIEDIABETICO == "NEUROPATICO"))

slices <- c(isquemico, neuropatico)
lbls <- c(
  paste("Isquemico", "\n" , isquemico, sep=""),
  paste("Neuropatico", "\n" , neuropatico, sep=""))
pie(slices, labels = lbls, col =  c("#7FDBFF", "#01FF70"))

par(mfrow=c(1,1))

# histogram views to numeric variables

par(mfrow=c(2,3))

hist(data$EDAD, col="#39CCCC", main="", xlab="Edad en años", ylab="Frecuencia")
hist(data$TIEMPODIAG, col="#39CCCC", main="", xlab="Años diagnostico", ylab="Frecuencia")
hist(data$PESO, col="#39CCCC", main="", xlab="Peso en kilogramos", ylab="Frecuencia")
hist(data$TALLA, col="#39CCCC", main="", xlab="Talla en metros", ylab="Frecuencia")
hist(data$HEMOGLOBINA, col="#39CCCC", main="", xlab="Hemoglobina (g/dL)", ylab="Frecuencia")
hist(data$GLICOSILADA, col="#39CCCC", main="", xlab="Hemoglobina Glicosilada (%)", ylab="Frecuencia")
hist(data$TRIGLICERIDOS, col="#39CCCC", main="", xlab="Trigliseridos (mg/dL) Glicosilada (%)", ylab="Frecuencia")
hist(data$COLESTEROL, col="#39CCCC", main="", xlab="Colesterol (mg/dL)", ylab="Frecuencia")
hist(data$HDL, col="#39CCCC", main="", xlab="HDL (mg/dL)", ylab="Frecuencia")
hist(data$ALBUMINA, col="#39CCCC", main="", xlab="Albumina (g/dL)", ylab="Frecuencia")
hist(data$BUN, col="#39CCCC", main="", xlab="BUN (mg/dL)", ylab="Frecuencia")
hist(data$UREA, col="#39CCCC", main="", xlab="UREA (mg/dL)", ylab="Frecuencia")
hist(data$CREATININA, col="#39CCCC", main="", xlab="Creatinina (mg/dL)", ylab="Frecuencia")

par(mfrow=c(1,1))

"
La colinealidad indica si en el modelo alguna variable independiente es combinación lineal de otras.
http://www.hrc.es/bioest/Reglin_15.html
http://analisisydecision.es/tag/vif/
https://www.statmethods.net/stats/rdiagnostics.html
"
ggpairs(data_selected[,-11] )

# remove URE varibale because has colineality with BUN

data_non_colineal <- select(data_selected, -URE )

# analize correlation between independ variables and depend variables

ggpairs(data_non_colineal) # cor(data_scaled)

# BUN, HEMO, GLI

#  ========================== simple lineal regrasion tfg - bun

ggplot(data_non_colineal, aes( x = BUN, y = TFG)) + geom_point(shape=1) + geom_smooth(method=lm)
lm_tfg_bun = lm(TFG ~ BUN, data = data_non_colineal)
summary(lm_tfg_bun)

par(mfrow=c(2,2))
plot(lm_tfg_bun)
par(mfrow=c(1,1))

# normal test of residuals for less than 30 elements ; p-value > 0.05 es normal

shapiro.test(lm_tfg_bun$residuals) # < 0.5 this is not a normal distribution

# distribution of studentized residuals
residuos <- studres(lm_tfg_bun)
hist(residuos, freq=FALSE, main="")
xfit<-seq(min(residuos),max(residuos),length=40)
yfit<-dnorm(xfit)
lines(xfit, yfit)

# Breusch-Pagan test. p-value > 0.05 homosedasticity
ncvTest(lm_tfg_bun)

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

#  ========================== simple lineal regrasion tfg - HEMO

ggplot(data_non_colineal, aes( x = HEMO, y = TFG)) + geom_point(shape=1) + geom_smooth(method=lm)
lm_tfg_hemo = lm( TFG ~ HEMO, data = data_non_colineal)
summary(lm_tfg_hemo) # p value superior a 0.5 y R Square bajo descartamos esta regresion simple

# normal test of residuals for less than 30 elements
shapiro.test(lm_tfg_hemo$residuals) # ; p-value > 0.05 es normal
# Breusch-Pagan test. p-value > 0.05 homosedasticity
ncvTest(lm_tfg_bun)

# distribution of studentized residuals
residuos <- studres(lm_tfg_bun)
hist(residuos, freq=FALSE, main="")
xfit<-seq(min(residuos),max(residuos),length=40)
yfit<-dnorm(xfit)
lines(xfit, yfit)

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

#  ========================== simple lineal regrasion TFG - GLI

ggplot(data_non_colineal, aes( x = GLI, y = TFG)) + geom_point(shape=1) + geom_smooth(method=lm)
lm_tfg_gli = lm(TFG~GLI, data = data_non_colineal)
summary(lm_tfg_gli) # p value superior a 0.5 y R Square bajo descartamos esta regresion simple

# normal test of residuals for less than 30 elements
shapiro.test(lm_tfg_gli$residuals) #  ; p-value > 0.05 es normal
# Breusch-Pagan test. p-value > 0.05 homosedasticity
ncvTest(lm_tfg_gli)

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

#  ========================== multi lineal  regrasion TFG

# step wise utilization

lm_full  <- lm(TFG ~ ., data = data_non_colineal)
lm_null  <- lm(TFG ~ 1, data = data_non_colineal)

# step backward
lm_backward <- step(lm_full, direction= "backward")
summary(lm_backward) # HEMO, COL, HDL, BUN ,  R2 = 0.838

lm_forward <- step(lm_null,scope =list(lower= lm_null, upper=lm_full), direction = "forward")
summary(lm_forward) # BUN COL HEMO HDL, R2  = 0.838

lm_both <- step(lm_null,scope =list(upper=lm_full), direction = "both")
summary(lm_both) # BUN COL HEMO HDL, R2 = 0.838

par(mfrow=c(2,2)) # Change the panel layout to 2 x 2
plot(lm_both)
par(mfrow=c(1,1)) # Change back to 1 x 1

# we must reduce the number of variabnles in the model to guarantee the best mean of the independ variable againts depend variable.

lm_final = lm(TFG ~ BUN, data = data_non_colineal)
summary(lm_final) # R2 0.726

# step wise recommendation

lm_final_full = lm(TFG ~ BUN + COL + HEMO + HDL, data = data_non_colineal)
summary(lm_final_full) # R2 0.838

# model without HDL
lm_final_full_n_hdl = lm(TFG~BUN + COL + HEMO, data = data_non_colineal)
summary(lm_final_full_n_hdl) # R2 0.8303

anova(lm_final_full, lm_final_full_n_hdl) # significancia menor a 0.5 por lo que si hay diferencia

# model without HEMO
lm_final_full_n_HEMO = lm(TFG ~ BUN + COL, data = data_non_colineal)
summary(lm_final_full_n_HEMO) # R2 0.82
anova(lm_final_full_n_hdl, lm_final_full_n_HEMO)

# pruebas de bondad
#http://data.library.virginia.edu/diagnostic-plots/
#https://www.statmethods.net/stats/rdiagnostics.html

lm_tfg_model = lm(TFG ~ BUN + COL, data = data_non_colineal)

qqPlot(lm_tfg_model, main="") #qq plot for studentized resid

par(mfrow=c(2,2)) # Change the panel layout to 2 x 2
plot(lm_tfg_model)
par(mfrow=c(1,1)) # Change back to 1 x 1

# normal test of residuals for less than 30 elements
shapiro.test(lm_tfg_model$residuals) #  ; p-value > 0.05 es normal
# Breusch-Pagan test. p-value > 0.05 homosedasticity
ncvTest(lm_tfg_model)

# Influential Observations added variable plots
# av.Plots(lm_tfg_model) Cook's D plot
# identify D values > 4/(n-k-1)
cutoff <- 4/((nrow(data_non_colineal)-length(lm_tfg_model$coefficients)-2))
plot(lm_tfg_model, which=4, cook.levels=cutoff)

# Influence Plot
# Data points with large residuals (outliers) and/or high leverage may distort the outcome and accuracy of a regression. Cook's distance measures the effect of deleting a given observation. Points with a large Cook's distance are considered to merit closer examination in the analysis.

influencePlot(lm_tfg_model,	id.method="identify", main="Influence Plot", sub="Circle size is proportial to Cook's Distance" )

# Normality of Residuals
# qq plot for studentized resid
qqPlot(lm_tfg_model, main="Lineal Model QQ Plot")

# distribution of studentized residuals
library(MASS)
sresid <- studres(lm_tfg_model)
hist(sresid, freq=FALSE, main="Distribucion de los residuos")
xfit<-seq(min(sresid),max(sresid),length=40)
yfit<-dnorm(xfit)
lines(xfit, yfit)

# Evaluate homoscedasticity
# non-constant error variance test
ncvTest(lm_tfg_model)
bptest(lm_tfg_model)
# plot studentized residuals vs. fitted values
spreadLevelPlot(lm_tfg_model)

# Evaluate Collinearity
vif(lm_tfg_model) # variance inflation factors
sqrt(vif(lm_tfg_model)) > 2 # problem?

# summary test
library(gvlma)
gvmodel <- gvlma(lm_tfg_model)
summary(gvmodel)

summary(lm_tfg_model)$r.squared

# Now we will add the  categorical variables
names(data)
str(data)

# best model numeric variables
lm_tfg__categorical = lm(TFGCKD ~ BUN + COLESTEROL, data = data)

# evaluate tratamiento
lm_tfg__tratamiento = lm(TFGCKD ~ BUN + COLESTEROL + TRATAMIENTO  , data = data)

anova(lm_tfg__categorical, lm_tfg__tratamiento) # p-value > 0.05

lm_tfg__categorical = lm(TFGCKD ~ BUN + COLESTEROL  , data = data)
lm_tfg__categorical_sexo = lm(TFGCKD ~ BUN + COLESTEROL + SEXO  , data = data)
anova(lm_tfg__categorical, lm_tfg__categorical_sexo)

lm_tfg__categorical = lm(TFGCKD ~ BUN + COLESTEROL  , data = data)
lm_tfg__categorical_pie = lm(TFGCKD ~ BUN + COLESTEROL + PIEDIABETICO  , data = data)
anova(lm_tfg__categorical, lm_tfg__categorical_pie)

# PIE Diabetico is a categorical variable that increment the significance
summary(lm_tfg__categorical_pie)

par(mfrow=c(2,2)) # Change the panel layout to 2 x 2
plot(lm_tfg__categorical_pie)
par(mfrow=c(1,1)) # Change back to 1 x 1

# test normalidad
shapiro.test(lm_tfg__categorical_pie$residuals)
# test homocedasticidad
ncvTest(lm_tfg__categorical_pie)

gvmodel <- gvlma(lm_tfg__categorical_pie)
summary(gvmodel)

coefficients(lm_tfg__categorical_pie) # model coefficients
confint(lm_tfg__categorical_pie, level=0.95)
# test anova
anova(lm_tfg__categorical_pie)
# covariance matrix
vcov(lm_tfg__categorical_pie)

install.packages("relaimpo")
library(relaimpo)
calc.relimp(lm_tfg__categorical_pie,type=c("lmg","last","first","pratt"),
            rela=TRUE)
boot <- boot.relimp(lm_tfg__categorical_pie, b = 1000, type = c("lmg",
                                            "last", "first", "pratt"), rank = TRUE,
                    diff = TRUE, rela = TRUE)
booteval.relimp(boot) # print result
plot(booteval.relimp(boot,sort=TRUE)) # plot result


#' Plot numbers at age
#'
#' Plots both estimated numbers and proportions as stacked barplot.
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @export

PlotNAA <- function(asap,save.plots,od,plotf,liz.palette){
  par(mfrow=c(1,1) )
  ## stacked barplot of NAA

  N.max=max(apply(asap$N.age,1,sum))

  barplot( t(asap$N.age), beside=F  ,  cex.names=0.75 ,
           width=1, space=rep(0,(asap$parms$nyears)),
           xlab = 'Year', ylab ='ASAP Estimated NAA', ylim = c(0,1.15*N.max),
           xlim=c(0.5,asap$parms$nyears+1-0.5), col=liz.palette[1:asap$parms$nages] )

  legend('top', horiz=T, legend=seq(1, asap$parms$nages),
         pch=15, col=liz.palette[1:asap$parms$nages], cex=0.8 )

  if (save.plots==T) savePlot(paste0(od, 'NAA.barplot.stacked.', plotf), type=plotf)

  #----same information, but proportion at age each year
  barplot( t(asap$N.age/apply(asap$N.age,1,sum)), beside=F  ,  cex.names=0.75 ,
           width=1, space=rep(0,(asap$parms$nyears)),
           xlab = 'Year', ylab ='ASAP Estimated Proportion (NAA)', ylim = c(0,1.1),
           xlim=c(0.5,asap$parms$nyears+1-0.5), col=liz.palette[1:asap$parms$nages] )

  legend('top', horiz=T, legend=seq(1, asap$parms$nages),
         pch=15, col=liz.palette[1:asap$parms$nages], cex=0.8 )

  if (save.plots==T) savePlot(paste0(od, 'NAA.proportion.barplot.stacked.', plotf), type=plotf)

  return()
} # end function


# Title: Homework 4
library(tidyverse)
library(lubridate)
library(rvest)
library(ggplot2)
#
# install.packages("rvest")
# install.packages("tidyverse")
# install.packages("progress")

air <- read_html("https://www.radarbox.com/statistics/total") %>%
  html_node("table#datatable") %>%
  html_table()

# Трохи приведемо до лау назви колонок, для зручності
colnames(air) <- colnames(air) %>%
  str_replace("  ", "_") %>%
  str_replace(" ", ".") %>%
  str_to_lower()

#1
dates <- as.Date(air$day, format = "%Y-%m-%d")
week_numbers <- dates %>% week

#2
us_non_us_flights <- air %>% select(us_non.us, day)

#3
air_with_dates <- us_non_us_flights %>% transform(date = as.Date(day, format = "%Y-%m-%d"))
sorted_by_dates <- air_with_dates %>% arrange(date)

#4
air_with_dates_parts <- sorted_by_dates %>% transform(year = year(date),  month = month(date), day = day(date))

#5
airs_repeated <- air_with_dates_parts %>% group_by(month, day) %>% filter(n() == 2)

#6
airs_compared_by_years <- air_with_dates_parts %>%
  pivot_wider(id_cols = c("day", "month"),
              names_from = "year",
              values_from = "us_non.us",
              names_prefix = "y")
airs_compared_named <- airs_compared_by_years %>% mutate(comparison = paste(day, ".", month, ".", "2019", " vs ", day, ".", month, ".", "2020", " : ", y2019-y2020, sep = ""))

#7
prepare_covid <- function(url, col_name) {
  d <- read.csv(url) %>%
    rename(region = Province.State, country = Country.Region) %>%
    pivot_longer(cols = -c(region, country, Lat, Long),
                 names_to = "date",
                 names_prefix = "X",
                 values_to = col_name
    ) %>%
    mutate(date = mdy(date)) %>%
    select(-c(Lat, Long)) %>%
    group_by(country, date) %>%
    summarise(col_name = sum(get(col_name)))

  cnames <- colnames(d)
  cnames[cnames == "col_name"] <- col_name
  colnames(d) <- cnames
  return(d)
}

covid19 <- prepare_covid("https://bit.ly/3aLLfKw", "cases") %>%
  full_join(prepare_covid("https://bit.ly/2XdZ6W0", "recovered")) %>%
  full_join(prepare_covid("https://bit.ly/2yEhPQg", "deaths")) %>%
  mutate(active_cases = cases - recovered - deaths,
         date = as.Date(date))

flights_during_pandemy <- covid19 %>% filter(country == "US") %>% left_join(air_with_dates, "date") %>% rename(flights = us_non.us)

#8
flights_during_pandemy %>% write.csv("./Final.csv")

#8 additional
input <- flights_during_pandemy[, c("flights", "date")]
plot(x = input$date,y = input$flights,
     xlab = "Flights",
     ylab = "Date",
     main = "Covid vs Flights")


hospitals_data =
  read_csv(
    "data/hospitals.csv",
    na = c("NA", "NOT AVAILABLE"),
    col_types = list(
      COUNTYFIPS = col_double()
    ),
  ) %>%
  select(
    county_code = COUNTYFIPS,
    hospital_beds = BEDS
  ) %>%
  mutate(
    # Negative numebrs are placeholders for missing in this data.
    hospital_beds = ifelse(hospital_beds < 0, NA, hospital_beds)
  ) %>%
  group_by(county_code) %>%
  summarise(
    # Ignore missing values.
    hospital_beds = sum(hospital_beds, na.rm = TRUE)
  )


#' @title Calculate Rate Sums
#' @param flt_data dataframe of filtered data
#' @param id_cols names of columns to use as id
#' @param numer_cols names of columns used in numerators
#' @param denom_cols names of columns used in denominators
#' @param group_cols names of columns to be preserved for further grouping
#' @return dataframe of numerator and denominator sums
calc_rate_sums <- function(flt_data, id_cols, numer_cols, denom_cols, group_cols=NULL){
  # Figure out quosure or scoped approach to stuff this into dplyr
  idvals <- apply(flt_data[,id_cols, drop=FALSE], 1, FUN=paste, sep="", collapse="")

  flt_data %>%
    mutate(
      id=idvals,
      timepoint=report_month,
      numerator=rowSums(select_at(., .vars=numer_cols)),
      denominator=rowSums(select_at(., .vars=denom_cols)),
      misses=denominator - numerator) %>%
    select_at(c("id", "timepoint", "numerator", "denominator", "misses", group_cols))
}


#t_pulse是单次射出所需的时间
#t_pulse，随着电压频率fv的上升而改变；随着流量而改变；

#以流量为划分

#设定工作目录
setwd("D:/data")
library(xlsx)

#读取数据
sink15<-read.xlsx("t_pulse.xls", sheetName = "single_q_15", header = TRUE)
sink27<-read.xlsx("t_pulse.xls", sheetName = "single_q27", header = TRUE)
sink54<-read.xlsx("t_pulse.xls", sheetName = "single_q54", header = TRUE)
sink180<-read.xlsx("t_pulse.xls", sheetName = "single_q180", header = TRUE)

#保存数据
#pdf("t_pulse_mixed_q.pdf")

#设定空间位置
par(mfrow = c(2,2), mar = c(4,4,2,2), oma = c(2,2,2,2))

##################################画图--占空比k为1.5nl/min#######################
plot(sink15$fv, sink15$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Pulse time t_pulse (ms)", main = "Pulse time in Q = 1.5nl/min", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 1050), ylim = c(0, 1.5))

#model1 = loess(sink15$X0.2 ~ sink15$fv, span = 0.8 , degree = 2)
lines(sink15$fv, sink15$X0.2,  col="#458B74", lwd=2, type="l", lty=2)

#model2 = loess(sink15$X0.3 ~ sink15$fv, span = 0.8, degree = 2)
lines(sink15$fv, sink15$X0.3, col="#FF00FF", lwd=2, type="l", lty=2)

#model3 = loess(sink15$X0.4 ~ sink15$fv, span = 0.8, degree = 2)
lines(sink15$fv, sink15$X0.4, col="#EE0000", lwd=2, type="l", lty=2)

#model4 = loess(sink15$X0.5 ~ sink15$fv, span = 0.8, degree =2)
lines(sink15$fv, sink15$X0.5, col="#27408B", lwd=2, type="l", lty=2)

#区域划线

legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

##################################画图--占空比k为27nl/min#######################
plot(sink27$fv, sink27$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Pulse time t_pulse (ms)", main = "Pulse time in Q = 27nl/min", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 550), ylim = c(0,  1.5))

#model1 = loess(sink27$X0.2 ~ sink27$fv, span = 0.8 , degree = 2)
lines(sink27$fv, sink27$X0.2,  col="#458B74", lwd=2, type="l", lty=2)

#model2 = loess(sink27$X0.3 ~ sink27$fv, span = 0.8, degree = 2)
lines(sink27$fv, sink27$X0.3, col="#FF00FF", lwd=2, type="l", lty=2)

#model3 = loess(sink27$X0.4 ~ sink27$fv, span = 0.8, degree = 2)
lines(sink27$fv, sink27$X0.4, col="#EE0000", lwd=2, type="l", lty=2)

#model4 = loess(sink27$X0.5 ~ sink27$fv, span = 0.8, degree =2)
lines(sink27$fv, sink27$X0.5, col="#27408B", lwd=2, type="l", lty=2)

#区域划线

legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

##################################画图--占空比k为54nl/min#######################
plot(sink54$fv, sink54$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Pulse time t_pulse (ms)", main = "Pulse time in Q = 54nl/min", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 1050), ylim = c(0, 1.5))

#model1 = loess(sink54$X0.2 ~ sink54$fv, span = 0.8 , degree = 2)
lines(sink54$fv, sink54$X0.2,  col="#458B74", lwd=2, type="l", lty=2)

#model2 = loess(sink54$X0.3 ~ sink54$fv, span = 0.8, degree = 2)
lines(sink54$fv, sink54$X0.3, col="#FF00FF", lwd=2, type="l", lty=2)

#model3 = loess(sink54$X0.4 ~ sink54$fv, span = 0.8, degree = 2)
lines(sink54$fv, sink54$X0.4, col="#EE0000", lwd=2, type="l", lty=2)

#model4 = loess(sink54$X0.5 ~ sink54$fv, span = 0.8, degree =2)
lines(sink54$fv, sink54$X0.5, col="#27408B", lwd=2, type="l", lty=2)

#区域划线

legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

##################################画图--占空比k为180nl/min#######################
plot(sink180$fv, sink180$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Pulse time t_pulse (ms)", main = "Pulse time in Q = 180nl/min", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 3550), ylim = c(0, 1.5))

#model1 = loess(sink180$X0.2 ~ sink180$fv, span = 0.8 , degree = 2)
lines(sink180$fv, sink180$X0.2,  col="#458B74", lwd=2, type="l", lty=2)

#model2 = loess(sink180$X0.3 ~ sink180$fv, span = 0.8, degree = 2)
lines(sink180$fv, sink180$X0.3, col="#FF00FF", lwd=2, type="l", lty=2)

#model3 = loess(sink180$X0.4 ~ sink180$fv, span = 0.8, degree = 2)
lines(sink180$fv, sink180$X0.4, col="#EE0000", lwd=2, type="l", lty=2)

#model4 = loess(sink180$X0.5 ~ sink180$fv, span = 0.8, degree =2)
lines(sink180$fv, sink180$X0.5, col="#27408B", lwd=2, type="l", lty=2)

#区域划线

legend("topright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

#dev.off()


# PROPOSAL TO CALCULATE WINDOW MEAN
# =================================
# =================================

# Idea: Get Data From all words in timespan, calculate, write back

# Steps
#   Connect to DB
#   Get all data from DB
#   Reshape 1: make big table
#   Calculation
#   Plot Example Word "Flugzeug"
#   Reshape II: make tall table (date, w_id, window_value)
#   Write back into DB

# GET DATA FROM DB
# ================
#get all data in timespan
sql_all_words_in_daterange = "
SELECT w_id, date, freq
FROM daily_words
WHERE date>'2015-03-5 00:00:00' AND date<'2015-03-31 00:00:00'"
rs = dbSendQuery(mydb, sql_all_words_in_daterange)
marchData = fetch(rs, n=-1) #fetch n number of results to get (-1 all)
marchData$date <- as.Date(marchData$date[]) # format date in class Date
#check Datespan if necessary
min(marchData$date)
max(marchData$date)


library(Biobase)

fn.in = "data/CHI/expression/corrected.batch.txt"
dat = fread(file.path(PROJECT_DIR, fn.in), header=T, data.table=F)

info = dat[,c(1,3)]

info = info %>%
  mutate(subject = as.character(subject)) %>%
  mutate(time.point = paste0(ifelse(time<0,"pre","day"),abs(time))) %>%
  mutate(sample = paste(subject, time.point, sep="_"))

dat2 = dat[,-c(1:3)] %>% data.matrix()
rownames(dat2) = info$sample
dat2 = t(dat2)

# output gene expression data and sample info
dir.create("generated_data/CHI", showWarning = F)
fn.ge = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_GE_matrix.txt")
fn.si = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_sample_info.txt")
dat2 %>% as.data.frame() %>% tibble::rownames_to_column("ID") %>%
  fwrite(fn.ge, sep="\t", quote=T)
fwrite(info, fn.si, sep="\t", quote=T)


#' Adds a new category to the given weight matrix and map field.
#'
#' This function returns a new weight matrix which is identical to the
#' given weight matrix except that it contains one more category which
#' is initialized to all 1's. It also returns a new map field matrix
#' which is identical to the given map field matrix except that it contains
#' one more element initialized to 0.
#' @title ARTMAP_Add_New_Category
#' @param weight Matrix of size NumFeatures-by-NumCategories which holds the weights of the network.
#' @param mapField Matrix of size 1-by-NumCategories which holds the associations between categories and classes.
#' @return Pair of values [RESIZEDWEIGHT, RESIZEDMAPFIELD]. The RESIZEDWEIGHT is a matrix of size NumFeatures-by-NumCategories+1
#' which holds the weights of the old matrix plus a new category of all
#' values of 1. The RESIZEDMAPFIELD is a matrix of size 1-by-NumCategories+1
#' which holds the given map field matrix except that it contains
#' one more element initialized to 0.
#'
ARTMAP_Add_New_Category=function(weight, mapField)
{
  # Make sure that the user specified the weight and map field matrices.
  if(nargs() != 2)
  {
    stop('You must specify the weight and map field parameters.');
  }

  # Create the return weight matrix with the right dimensions.
  numFeatures=ncol(weight);
  numCategories= nrow(weight);

  newCategory = matrix(1,1,numFeatures);
  resizedWeights = rbind(weight,newCategory);

  # Create the return map field matrix with the right dimensions.
  resizedMapField = rbind(mapField, 0); #Assuming matrix and not concatenation result (c())

  return (list(resizedWeights,resizedMapField));
}


set_model_params <- function(alpha_priors,
                             beta_priors,
                             alpha_epsilons,
                             beta_epsilosn,
                             noise_parameters,
                             world_EIGs,
                             max_observation){

  model_params_df <- crossing(
    alpha_prior = alpha_priors,
    beta_prior = beta_priors,
    alpha_epsilon = alpha_epsilons,
    beta_epsilon = beta_epsilosn,
    noise_parameter = noise_parameters,
    world_EIG = world_EIGs,
    max_observation = max_observation
  ) %>%
    mutate(params_info = paste("ae", alpha_epsilon,
                               "be", beta_epsilon,
                               "ap", alpha_prior,
                               "bp", beta_prior,
                               "np", noise_parameter,
                               "wEIG", world_EIG, sep = "_"))

  return(model_params_df)

}

set_stim_params <- function(sequence_scheme, features_df){

  stimulus_sequence_df <- expand_grid(sequence_scheme, features_df)%>%
    rowwise() %>%
    mutate(
    #  total_features_n = features_df$total_features_n,
   #   on_features_n = features_df$on_features_n,
      stimuli_sequence = nest(scheme_to_stimuli(sequence_scheme,
                                                n_features = n_features,
                                                on_features_n = on_features_n), data = everything())) %>%
    ungroup() %>%
    mutate(stim_info = paste("nf", n_features,
                             "of", on_features_n,
                             "ss", sequence_scheme,
                             sep = "_"))

  return(stimulus_sequence_df)
}

make_simulation_params <- function(n_sim,
                                   model_params,
                                   stim_params
){

  expand_grid(model_params, stim_params) %>%
    left_join(expand_grid(sub_id = 1:n_sim, params_id = model_params$params_id))

}

scheme_to_stimuli <- function(sequence_scheme, n_features, on_features_n){

  background_creature <- sample(c(rep(FALSE, n_features - on_features_n),
                                  rep(TRUE, on_features_n)))

  # construct deviant creature from background creature
  deviant_creature <- background_creature

  # if not all features can be flipped, then select a random subset of the features to flip as many as possible
  if (on_features_n > n_features * .5){
    # randomly select a subset of features to be flipped
    # R has annoying behaviors for sample when the vector length is 1
    # can't use if_else because it has an annoying behavior that forces both clause return the same thing

    if (n_features - on_features_n == 1 | n_features == on_features_n){

      on_location <-  sample(which(background_creature == TRUE), 1)
      off_location <-  which(background_creature == FALSE)
    }else{
      on_location <- sample(which(background_creature == TRUE), size = n_features - on_features_n)
      off_location <- sample(which(background_creature == FALSE), size = n_features - on_features_n)
    }

  # if all features can be flipped, flip all features
  }else{
    on_location <- which(background_creature == TRUE)
    off_location <- sample(x = which(background_creature == FALSE), size = on_features_n)
  }

  deviant_creature <- background_creature
  deviant_creature[on_location] <- FALSE
  deviant_creature[off_location] <- TRUE

  block_list <- strsplit(sequence_scheme, "")[[1]]

  background_sequence <- replicate(length(block_list), background_creature, simplify = FALSE)
  background_sequence[which(block_list == "D")] <- replicate(length(which(block_list == "D")),
                                                             deviant_creature, simplify = FALSE)

  tidy_creature_sequence <- bind_rows(lapply(background_sequence,
                                             function(x) x %>% as_tibble_row(.name_repair = make.names)))

  # renaming columns
  rename_column <- function(x){paste0("V", x)}
  tidy_column_names <- lapply(1:length(background_creature), rename_column)
  colnames(tidy_creature_sequence) <- tidy_column_names
  tidy_creature_sequence <- tidy_creature_sequence %>%
    mutate(trial_number = row_number())

  return(tidy_creature_sequence)

}


#!/usr/bin/env Rscript

#' @author Noah Ollikainen, Charlotte A Lai, Peter Chovanec

if(!require(ggplot2)){
    install.packages("ggplot2", repos='http://cran.us.r-project.org')
    library(ggplot2)
}

SINGLETON        <- 1
FROM_2_TO_10     <- 2
FROM_11_TO_100   <- 3
FROM_101_TO_1000 <- 4
OVER_1000        <- 5

getCount <- function(x, n) x[[n]]

incrementCount <- function(x, cat, num) {
    x[[cat]] <-  x[[cat]] + num
    x
}

normalizeCount  <- function(x) {
    total <- sum(unlist(x))
    lapply(x, function(l) l / total)
}

processFile <- function(f) {
    sizes <- list(0, 0, 0, 0, 0)

    tryCatch({
        con <- file(f, open = 'r')
        while (length(oneLine <- readLines(con, n = 1, warn = FALSE)) > 0) {
            numReads <- length(unlist(strsplit(oneLine, "\t"))) - 1  # First column is barcode
            if      (numReads == 1)    sizes <- incrementCount(sizes, SINGLETON, numReads)
            else if (numReads <= 10)   sizes <- incrementCount(sizes, FROM_2_TO_10, numReads)
            else if (numReads <= 100)  sizes <- incrementCount(sizes, FROM_11_TO_100, numReads)
            else if (numReads <= 1000) sizes <- incrementCount(sizes, FROM_101_TO_1000, numReads)
            else                       sizes <- incrementCount(sizes, OVER_1000, numReads)
        }
    }, finally = {
        close(con)
    })

    sizes <- normalizeCount(sizes)
    df <- data.frame(unlist(sizes))
    colnames(df) <- c("count")
    fs <- c("SINGLETON", "FROM_2_TO_10", "FROM_11_TO_100", "FROM_101_TO_1000", "OVER_1000")
    df$category <- factor(fs, levels = c(fs[1], fs[2], fs[3], fs[4], fs[5]))
    df$filename <- basename(f)
    df
}

parseArgs <- function() {
    args <- commandArgs(trailingOnly = TRUE)
    if (length(args) != 2) stop("get_cluster_sizes <directory> <pattern>")
    args
}

plotCounts <- function(df, dir_out) {
    p <- ggplot(df, aes(x = filename, y = count, fill = category))
    p <- p + geom_bar(stat = "identity")
    p <- p + theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1))

    png(paste(dir_out, "/cluster_sizes.png", sep=""))
    print(p)
    graphics.off()

    pdf(paste(dir_out, "/cluster_sizes.pdf", sep=""))
    print(p)
    graphics.off()
}

main <- function() {
    args <- parseArgs()
    files <- list.files(path = args[1], pattern = args[2], full.names = TRUE, recursive = FALSE)
    dfs <- lapply(files, processFile)
    df <- do.call("rbind", dfs)
    plotCounts(df, args[1])
}

main()


# Load libraries
library(rvest)
library(tidyverse)
library(ggrepel)
library(scales)
library(stringr)
library(grid)
library(lubridate)
source("http://peterhaschke.com/Code/multiplot.R") # Load a function to plot multiple ggplot charts

# Download ballpark capacity
url <- "https://en.wikipedia.org/wiki/List_of_Major_League_Baseball_stadiums"
capacity <- url %>%
	read_html() %>%
	html_nodes(xpath='//*[@id="mw-content-text"]/div/table[2]') %>%
	html_table() %>%
	`[[`(1) %>%
	mutate_at(vars(3, 6), ~str_remove_all(., "\\[[^\\]]*\\]")) %>%
	mutate_at(vars(3), ~str_remove_all(., ",") %>% as.numeric()) %>%
	arrange(Team)

# Download attendance data
url <- "http://www.espn.com/mlb/attendance" # Set the URL of the page
attendance <- url %>%
	read_html() %>%
	html_nodes(xpath='//*[@id="my-teams-table"]/div/div/table') %>% # Select the table
	html_table() %>%
	`[[`(1) %>%
	set_names("Rank2016","Team","HomeGames","HomeTotal","HomeAverage","HomePct","RoadGames","RoadAverage","RoadPct","OverallGames","OverallAverage","OverallPct") %>% # Label the columns
	slice(-c(1:2)) %>%
	mutate_at(vars(4, 5, 8, 11), ~str_remove_all(., ",")) %>%
	mutate_at(vars(1, 3:12), as.numeric) %>%
	arrange(Team) %>%
	bind_cols(capacity %>% select(Capacity)) %>%
	mutate(HomePct = HomeAverage / Capacity,
		   Abbrev = c("ARI","ATL","BAL","BOS","CHC","CHW","CIN","CLE","COL","DET","HOU","KCR","LAA","LAD","MIA","MIL","MIN","NYM","NYY","OAK","PHI","PIT","SDP","SFG","SEA","STL","TBR","TEX","TOR","WSN")) # Add three-letter labels for each team, for the plotting

a <- ggplot(attendance, aes(HomeAverage,HomePct)) + # Make the first graph, attendance vs. percent attendance
    geom_text_repel( # This plots the labels, but around the points.
    	aes(label=Abbrev),
    	size = 3) + # Set the font size
	geom_point(size=1) + # Tiny points
	scale_x_continuous(labels=comma, # Insert commas into the x-axis labels
					   breaks=c(15000,25000,35000,45000,55000)) + # Set the breaks
	scale_y_continuous(labels=percent_format(accuracy = 1)) + # Convert the y-axis into percentages.
	labs(title = paste0( # Title the plot dynamically
		year(Sys.Date()), # The current year
		" MLB home attendance vs. capacity (through ",
		strftime(Sys.Date()-1, format = "%m/%d"), # Yesterday
		")"),
		y = "Attendance as percent of capacity") +
	theme(axis.title.x = element_blank())

b <- ggplot(attendance, aes(HomeAverage,Capacity)) + # Make the second graph, attendance vs. capacity
    geom_text_repel(aes(label=Abbrev), size = 3) + #Set the font size
	geom_point(size=1) + # Tiny points
    scale_x_continuous(labels=comma, breaks=c(15000,25000,35000,45000,55000)) +
	scale_y_continuous(labels=comma_format(scale = 0.001, suffix = "K"), limits=c(20000,60000)) +
	labs(caption = "By David Montgomery, github.com/dhmontgomery",
		 x = "Average home attendance",
		 y = "Ballpark capacity")

# Save as a square PNG
ggsave("attendance.png",plot=multiplot(a,b), device="png", height=10, width=10)

attendance %>% select(2:6) %>% write_csv("mlb-attendance.csv")


paramNames <- c("r", "nloci", "nploidy", "ninit0" ,"ninit1",
	"distlocal", "scmajor", "sclocal", "ngen", "nrep", "rec", "k"
)

plot_pop <- function(nav) {
  ggplot(nav[[2]]) +
  geom_line(aes(x=Generation, y=Popsize_avg)) + geom_ribbon(aes(x=Generation, ymin=Popsize_avg-sqrt(Popsize_var), ymax=Popsize_avg+sqrt(Popsize_var)), fill = "blue", alpha = 0.3) +
  geom_line(aes(x=Generation, y=Major0_avg)) + geom_ribbon(aes(x=Generation, ymin=Major0_avg-sqrt(Major0_avg), ymax=Major0_avg+sqrt(Major0_avg)), fill = "red", alpha = 0.3) +
  geom_line(aes(x=Generation, y=Major1_avg)) + geom_ribbon(aes(x=Generation, ymin=Major1_avg-sqrt(Major1_avg), ymax=Major1_avg+sqrt(Major1_avg)), fill = "green", alpha = 0.3) +
  theme_minimal() + xlab("Generation") + ylab("Populationsize")
}

plot_intro <- function(nav) {
  ggplot(nav[[2]]) +
  geom_line(aes(x=Generation, y=Introgressed0_avg)) +
  geom_ribbon(aes(x=Generation, ymin=Introgressed0_avg-sqrt(Introgressed0_var), ymax=Introgressed0_avg+sqrt(Introgressed0_var)), fill = "red", alpha = 0.3) +
  geom_line(aes(x=Generation, y=Introgressed1_avg)) +
  geom_ribbon(aes(x=Generation, ymin=Introgressed1_avg-sqrt(Introgressed1_var), ymax=Introgressed1_avg+sqrt(Introgressed1_var)), fill = "green", alpha = 0.3) +
  theme_minimal() +
  xlab("Generation") +
  ylab("Introgression")
}

RunAllSimulation <- function(pars){
  pkgIntrogression::ShinyInitializeSimulation(pars)

  withProgress(message="Running simulations",value = 0,{
    for(x in c(1:pars$nrep)){
      incProgress(1/pars$nrep, detail = paste("Doing replicate", x))
      pkgIntrogression::ShinyRunSimulation()
    }
  })

  pkgIntrogression::ShinyWriteOutputandCleanup()
}

function(input, output, session) {

  getParams <- function(prefix) {
    input[[paste0(prefix, "_recalc")]]

    params <- list()
    length(params) <- 12
    params <- lapply(paramNames, function(p) {input[[paste0(prefix, "_", p)]]})
    names(params) <- paramNames
    as.list(params)
  }

  navA <- eventReactive(input$a_recalc, RunAllSimulation(getParams("a")) ) #

  output$a_PopulationPlot <- renderPlot({
    suppressWarnings(plot_pop(navA()))
  })

  output$a_IntrogressionPlot <- renderPlot({
    suppressWarnings(plot_intro(navA()))
  })

  output$fixation_output <- renderText({
    paste("The fixation probability is: ", navA()$fixation)
  })

  output$a_lociPlot <- renderPlotly({
  #allelefrequencies
  dataallelemean <-tidyr::gather(as.data.frame(navA()[[3]]), locus, value, 2:ncol(as.data.frame(navA()[[3]])))
  dataallelevar <-tidyr::gather(as.data.frame(navA()[[4]]), locus, value, 2:ncol(as.data.frame(navA()[[4]])))
  dataallele <- dplyr::bind_cols(dataallelemean,dataallelevar[3])
  dataallele <- dplyr::mutate(dataallele, col=factor(locus,locus))
  allelefrequencyplot <- ggplot(dataallele, aes(col, value, ymin=value-sqrt(value1),ymax=value+sqrt(value1))) +
  geom_pointrange(aes(frame = Generation), shape=22) +
  theme_minimal() +
  xlab("Locus") +
  ylab("Allelefrequency") +
  theme(axis.text.x = element_blank())

  suppressWarnings(ggplotly(allelefrequencyplot))
})

}


#' A multidimensional \code{which} function
#'
#' @param x     N-dimensional logical array
#' @param drop  Return a vector if called on a vector
#' @return      A matrix with indices where \code{A == TRUE}
#' @export
which = function(x, drop=TRUE) {
    if (!drop)
        x = as.array(x)

    re = base::which(x, arr.ind=TRUE)
    colnames(re) = names(dimnames(x))
    re
}


#' Try/catch with exponential backoff
#'
#' Attempts the expression in \code{expr} up to the number of tries specified
#' in \code{max_attempts}. Each time a failure results, the functions sleeps
#' for a random amount of time before re-attempting the expression. The upper
#' bound of the backoff increases exponentially after each failure.
#'
#' For details on exponential backoff, see:
#' \url{http://en.wikipedia.org/wiki/Exponential_backoff}
#'
#' @param expr an R expression to try.
#' @param silent logical: should the report of error messages be suppressed?
#' @param max_tries the maximum number of times to attempt the expression
#' \code{expr}
#' @param verbose logical: Should detailed messages be reported regarding each
#' attempt? Default: no.
#' @return the value of the expression in \code{expr}. If the final attempt was
#' a failure, the objected returned will be of class try-error".
#' @examples
#' # Example that will never succeed.
#' try_backoff(log("a"), verbose=TRUE, max_attempts=5)
try_backoff <- function(expr, silent=FALSE, max_attempts=10, verbose=FALSE) {
  for (attempt_i in seq_len(max_attempts)) {
    results <- try(expr=expr, silent=silent)
    if (class(results) == "try-error") {
      backoff <- runif(n=1, min=0, max=2^attempt_i - 1)
      if (verbose) {
        message("Backing off for ", backoff, " seconds.")
      }
      Sys.sleep(backoff)
    } else {
       if (verbose) {
         message("Succeeded after ", attempt_i, " attempts.")
       }
      break
    }
 }
 results
}


##Madelyn Ore
##Feb 2017

#necessary libraries to conduct this effort
library(assertr)

#reading in the proper files
ML_data <- read.csv("data/ML_song_recordings.csv")
XC_data <- read.csv("data/XC_song_recordings.csv")

# Macauley Library assertions ---------------------------------------------
#all states where breeding Townsend's Warblers would be
states <- c("Alaska", "California", "Montana", "Oregon", "Washington", "Alberta", "British Columbia")
#nickname of database
MLname_of_database <- c("ML")

ML_data %>%
  #verifys there are the correct number of columns
  verify(ncol(.)==20) %>%

  #checks that it is the correct database being tested
  assert(in_set(MLname_of_database), Database.type)

  #checks that the location is a factor
  verify(is.factor(Locality)) %>%

  #checks there is a reasonable number of songs in the recording, no misplaced zeros
  assert(within_bounds(0,100), Songs.In.Recording) %>%

  #checks that the location of the recordings makes sense
  assert(in_set(states),  State) %>%

  verify(is.numeric(Longitude))

# Xeno Canto assertions ---------------------------------------------------
#nickname of database
XCname_of_database <- c("XC")

XC_data %>%
  #verifys there are the correct number of columns
    verify(ncol(.)==17) %>%

  #checks that it is the correct database being tested
    assert(in_set(name_of_database), Database.type)

  #checks that the location is a factor
  verify(is.factor(Locality)) %>%

    #checks there is a reasonable number of songs in the recording, no misplaced zeros
    assert(within_bounds(0,100), Songs.In.Recording) %>%

    #checks that the location of the recordings makes sense
    assert(in_set(states),  State)


nalevs <- function(x, naset=NULL, setmid=NULL, set1=NULL, set0=NULL, setmean=NULL, weight=NULL){
  x[x %in% naset] <- NA
  q <- (x %in% setmid)
  r <- (x %in% set1)
  s <- (x %in% set0)
  t <- (x %in% setmean)
  x[q || r || s || t] <- NA
  x <- as.numeric(x)
  x <- (x-range(x, na.rm=TRUE)[1])/range((x-range(x, na.rm=TRUE)[1]), na.rm=TRUE)[2]
  x[q] <- .5
  x[r] <- 1
  x[s] <- 0
  if(!is.null(weight))
    x[t] <- wtd.mean(x, weight, na.rm=TRUE)
  else
    x[t] <- mean(x, na.rm=TRUE)
  x
}


#data <- read.csv(file="ads_1.csv", header=TRUE, sep=",")
#library("RColorBrewer")
args = commandArgs(trailingOnly=TRUE)
data <- read.csv(file=args[1], header=TRUE, sep=",",check.names=FALSE)
pdf(args[2])
s <- 1.5
par(mar=c(4, 11, 4, 4)) # Resize the margin to fit the y axis labels
xx <- barplot(as.numeric(data[1,]), main=args[4], horiz=TRUE, names.arg=colnames(data), las=1, font.lab=1, font.main=1, family='serif', legend=args[3], xlim=c(0,100), args.legend = list(x ="bottomright"), xlab="Precision at k (%)", cex.names=s, cex.axis=s, cex.lab=2.5, cex.main=2.5, cex.sub=s)
#xx <- barplot(as.matrix(data),col=brewer.pal(n = 3, name = "RdBu"),  main="Precision at K", horiz=TRUE, names.arg=colnames(data), las=1, font.lab=1, font.main=1, family='serif', xlim=c(0,100)) #font.lab and font.main defines font size
#xx <- barplot(as.matrix(data),col=c("grey","#F7F7F7"),  main="Precision at K", horiz=TRUE, names.arg=colnames(data), las=1, font.lab=1, font.main=1, family='serif', xlim=c(0,100), legend=c("k=10", "k=12"), args.legend = list(x ="bottomright")) #font.lab and font.main defines font size
#xx <- barplot(as.numeric(data[1,]), main="Precision at K", horiz=TRUE, names.arg=colnames(data), las=1, font.lab=1, font.main=1, family='serif', xlim=c(0,100)) #font.lab and font.main defines font size

mm <- max(data)
text(y = xx-0.3, x = as.numeric(data[1,]) + 8, label = as.numeric(data[1,]), pos = 3, cex = s, family="serif") # show text on top of each bar

dev.off()


# cps data at: https://github.com/open-source-economics/Tax-Calculator/blob/master/taxcalc/cps.csv.gz
# cps info at: http://open-source-economics.github.io/Tax-Calculator/#cli-spec-funits

#****************************************************************************************************
#                Libraries ####
#****************************************************************************************************
library("magrittr")
library("plyr") # needed for ldply; must be loaded BEFORE dplyr
library("tidyverse")
options(tibble.print_max = 60, tibble.print_min = 60) # if more than 60 rows, print 60 - enough for states
# ggplot2 tibble tidyr readr purrr dplyr

library("scales")
library("hms") # hms, for times.
library("stringr") # stringr, for strings.
library("lubridate") # lubridate, for date/times.
library("forcats") # forcats, for factors.
library("readxl") # readxl, for .xls and .xlsx files.
library("haven") # haven, for SPSS, SAS and Stata files.
library("vctrs")
library("precis")

library("grDevices")
library("knitr")

library("zoo") # for rollapply

library("btools") # library that I created (install from github)
library("bdata")

#****************************************************************************************************
#                Globals ####
#****************************************************************************************************
cps_dir <- "D:/Data/cps_puf/cps.csv/"
cps_file <- "cps.csv"

#****************************************************************************************************
#                Get cps data ####
#****************************************************************************************************
cps <- read_csv(paste0(cps_dir, cps_file))

glimpse(cps)
names(cps) %>% sort

saveRDS(cps, paste0(cps_dir, "cps.rds"))

#****************************************************************************************************
#                Explore cps data ####
#****************************************************************************************************
precis(cps)

count(cps, fips)

cps %>%
  group_by(agi_bin) %>%
  summarise(n=n(), weight=sum(s006))


#  James Rekow

computeClusterSSE = function(inputMat, centers){

  #  ARGS:
  #
  #  RETURNS:

  #  perform kmeans on the input data matrix using the given number of centers
  kmr = kmeans(inputMat, centers = centers, iter.max = 1000, nstart = 100)

  SSE = sum(kmr$tot.withinss)

  return(SSE)

} #  end computeClusterSSE function


library(ggplot2)
#Cit.HepPh.Unique<-unique(Cit.HepPh)
#cit.HepPh.dates.Unique<-unique(cit.HepPh.dates)

paperMonth<-data.frame(month=1:12,paperCount=0)

year<-2000
for(m in 1:12){
  if(m<10){
    month<-as.character(paste('0',m,sep = ""))
  }else{
    month<-as.character(m)
  }
  pattern <- paste(year,'-',month,'-*', sep = "")
  group <- grep(pattern, cit.HepPh.dates.Unique[,2],
                ignore.case = FALSE, perl = FALSE, value = FALSE,
                fixed = FALSE, useBytes = FALSE, invert = FALSE)
  paperMonth[paperMonth$month==m,]$paperCount <- length(group)
}
myplot<-ggplot(paperMonth,aes(x=as.character(month),y=paperCount,fill=month))
myplot+geom_bar(stat="identity")+geom_point()+
  geom_text(aes(label=paperCount),hjust=0.5, vjust=-0.5 )+
  labs(x='Month', y=paste('paperCount of ',year, sep = ""))


# Evaluate streamflow observations
library(dataRetrieval)
library(data.table)
library(ggplot2)
library(foreach)
library(rwrfhydro)

#~~~~~~ Download USGS streamflow to evaluate. Uses the USGS 'data retrieval' package~~~~~~
# we already know the USGS gauge IDs that match the forecast points we have modelled

gageID <- c("01374559", "01374581", "0137462010")
obsDF <- readNWISuv(siteNumbers=gageID, parameterCd="00060", startDate="2011-08-25", endDate="2011-09-03")
colnames(obsDF) <- c("agency","site_no","dateTime","streamflow_cfs","quality_flag", "time_zone")
obsDF$q_cms <- obsDF$streamflow_cfs/35.31

#find the "reference file" from the test case. This file contains the index number of the gauge (i.e. 1, 2, 3, etc)
referenceFile <- "/home/wrudisill/WRF_HYDRO-R2/example_case/Gridded/croton_frxst_pts_csv.csv"
refDF <- read.csv(referenceFile, colClasses = c("integer", "numeric", "numeric", "character", "character"))

# merge the index numer into the observation data frame
obsDF <- merge(obsDF,  refDF[, c("FID", "Site_No")], by.x = "site_no", by.y = "Site_No")
obsDF$station <- obsDF$FID  ## adding the feature_id

#~~~~~~ Read in Model Discharge Outputs ~~~~~~#
modelOutputPath <- "/home/wrudisill/WRF_HYDRO-R2/example_case/Gridded/frxst_pts_out.txt"
simQ <- read.csv(modelOutputPath, col.names =  c("TimeFromStart", "dateTime", "station", "longitude", "latitude", "q_cms","q_cfs", "stage"), colClasses = c("integer", "character", "character", rep("numeric", 5)), header = FALSE)

#~~~~~~ Create a ggplot of the observations versus the model simulation ~~~~~~~#
obsDF$run <- "Observation"
simQ$run <- "Gridded Baseline"
selected_cols<-c("dateTime", "station", "q_cms","run")

# merge the observations and model data frames w/ only the most important columns
merged <- rbind(obsDF[,selected_cols], simQ[,selected_cols])

# make sure that the station number is numeric, not a character
merged$station <- as.numeric(merged$station)

# plot the data
ggplot(data = merged) + geom_line(aes(dateTime, q_cms, color=run)) + facet_wrap(~station, ncol = 1)


setwd("/home/yuanhao/github_repositories/DISC/reproducibility")
utilities_path = "./source/utilities.r"
source(utilities_path)
#### STEP 1
#Here, we use BONE_MARROW dataset. The detail information of this dataset can be seen at https://raw.githack.com/iyhaoo/DISC/master/reproducibility/data_preparation_and_imputation/data_preprocessing_BONE_MARROW.nb.html.</br>
#  We used the raw data after gene selection for cell identification.
gene_bc_mat = readh5_loom("./data/BONE_MARROW/raw.loom")
gene_bc_filt = gene_bc_mat[gene_selection(gene_bc_mat, 10), ]
dim(gene_bc_filt) #  13813, 6939
used_genes = rownames(gene_bc_filt)
output_dir = "./results/BONE_MARROW"
dir.create(output_dir, showWarnings = F, recursive = T)
#### STEP 2
#Following this script (https://github.com/Winnie09/imputationBenchmark/blob/master/data/code/process/07_hca_assign_celltype.R), we use the bulk-sequence data (https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=GSE74246) of 13 normal hematopoietic cell types and 3 acute myeloid leukemia cell types for cell identification, the file is downloaded from https://www.ncbi.nlm.nih.gov/geo/download/?acc=GSE74246&format=file&file=GSE74246%5FRNAseq%5FAll%5FCounts%2Etxt%2Egz.
if(!file.exists("./data/BONE_MARROW/cell_type.rds")){
  library(scran)
  scran_normalization = function(gene_bc_mat){
    #  The source of this function is https://github.com/Winnie09/imputationBenchmark/blob/master/data/code/process/06_make_hca_MantonBM6.R
    dimnames_gene_bc_mat = dimnames(gene_bc_mat)
    dimnames(gene_bc_mat) = list()
    sce = SingleCellExperiment(list(counts = gene_bc_mat))
    no_cores = max(c(detectCores() - 1, 1))
    if(ncol(gene_bc_mat) < 21){
      sce = computeSumFactors(sce, BPPARAM = MulticoreParam(workers = no_cores), sizes = c(5, 10, 15, 20))
    } else {
      sce = computeSumFactors(sce, BPPARAM = MulticoreParam(workers = no_cores))
    }
    sf = sizeFactors(sce)
    dimnames(gene_bc_mat) = dimnames_gene_bc_mat
    return(log2(sweep(gene_bc_mat, 2, sf, "/") + 1))
  }
  scalematrix = function(data){
    cm = rowMeans(data)
    csd = apply(data, 1, sd)
    (data - cm) / csd
  }
  corfunc = function(m1, m2){
    scalematrix(t(m1)) %*% t(scalematrix(t(m2))) / (nrow(m1) - 1)
  }
  gene_bulk_all = as.matrix(read.table("./data/BONE_MARROW/original_data/GSE74246_RNAseq_All_Counts.txt.gz", header = T, row.names = 1))
  gene_bulk_mat = gene_bulk_all[, grep("^X", colnames(gene_bulk_all))]
  #  Use annotation information
  gz_path = "./data/hg19/Homo_sapiens.GRCh37.87.gtf.gz"
  annotation_mat = get_map(gz_path)
  tgngl = tapply(annotation_mat[, "gene_length"] / 1000, annotation_mat[, "gene_name"], max)
  gngl = as.vector(tgngl)
  names(gngl) = names(tgngl)
  gene_bulk_filt = gene_bulk_mat[row.names(gene_bulk_mat) %in% names(gngl),]
  gene_bulk_norm = sweep(gene_bulk_filt / gngl[rownames(gene_bulk_filt)], 2, colSums(gene_bulk_filt) / 1e6, "/")
  bulk_data = log2(gene_bulk_norm[rowSums(gene_bulk_norm) > 0,] + 1)
  bulk_cell_type = sapply(colnames(bulk_data), function(x){
    strsplit(x,"\\.")[[1]][2]
  }, USE.NAMES = F)
  sc_data = scran_normalization(gene_bc_filt)
  rownames(sc_data) = sub(".*:", "", rownames(gene_bc_filt))
  used_genes = intersect(rownames(bulk_data), rownames(sc_data))
  bulk_filt = bulk_data[used_genes, ]
  sc_filt = sc_data[used_genes, ]
  #  The expression level for each cell type in bulk sequencing
  bulk_mean = sapply(unique(bulk_cell_type),function(x) {
    rowMeans(bulk_filt[ , bulk_cell_type == x])
  })
  #  Find 100 top postive differentially expressed genes for each celltype pair.
  DEG_list = list()
  top_number = 100
  unique_celltype_pairs = combn(ncol(bulk_mean), 2)
  for(ii in seq(ncol(unique_celltype_pairs))){
    celltype_1 = colnames(bulk_mean)[unique_celltype_pairs[1, ii]]
    celltype_2 = colnames(bulk_mean)[unique_celltype_pairs[2, ii]]
    sort_result = sort(bulk_mean[ , celltype_1] - bulk_mean[ , celltype_2], decreasing = FALSE)
    DEG_list[[paste(celltype_2, celltype_1, sep = "-")]] = names(sort_result)[seq(top_number)]
    DEG_list[[paste(celltype_1, celltype_2, sep = "-")]] = names(sort_result)[seq(from = length(sort_result), to = length(sort_result) - (top_number - 1))]
  }
  #  Calculate the mean expression of these top-gene combinations across cell types (bulk) or cells (single-cell).
  expression_mean_function = function(gene_bc_norm, DEG_list){
    return(t(sapply(DEG_list, function(x){
      colMeans(gene_bc_norm[x, ])
    })))
  }
  bulk_DEG_expression_mean = expression_mean_function(bulk_mean, DEG_list)
  sc_DEG_expression_mean = expression_mean_function(sc_filt, DEG_list)
  #  Calculate the expression variation of these top-gene combinations across cell types (bulk) or cells (single-cell).
  expression_variation_function = function(x){
    return((x - rowMeans(x)) / apply(x, 1, sd))
  }
  bulk_DEG_expression_variation = expression_variation_function(bulk_DEG_expression_mean)
  sc_DEG_expression_variation = expression_variation_function(sc_DEG_expression_mean)
  #  Each top-gene combination correspond a cell type.
  bulk_DEG_combination_rank = apply(bulk_DEG_expression_variation, 2, rank)
  sc_DEG_combination_rank = apply(sc_DEG_expression_variation, 2, rank)
  #  Cell type identification.
  maxcorcut = 0.6
  difcorcut = 0
  cormat = corfunc(sc_DEG_combination_rank, bulk_DEG_combination_rank)
  maxcor = apply(cormat, 1, max)
  max2cor = apply(cormat, 1, function(x){
    sort(x, decreasing = T)[2]
  })
  cell_type = colnames(cormat)[apply(cormat, 1, which.max)]
  cell_type[maxcor < maxcorcut] = NA
  cell_type[maxcor - max2cor < difcorcut] = NA
  names(cell_type) = colnames(sc_data)
  saveRDS(cell_type, "./data/BONE_MARROW/cell_type.rds")
}else{
  cell_type = readRDS("./data/BONE_MARROW/cell_type.rds")
}
print("Cell Type ... OK!")
### Trajectory evaluation
#After cell identification, we evaluate the trajectory performance using monocle following these scripts(https://github.com/Winnie09/imputationBenchmark/blob/93f27e890a86fdc732257a4036bf38a52faf9f33/trajectory/code/hca/monocle2/01_get_score.R, https://github.com/Winnie09/imputationBenchmark/blob/93f27e890a86fdc732257a4036bf38a52faf9f33/trajectory/code/hca/tscan/01_get_score.R).
ctlevel <- data.frame(cell_type=c('HSC','MPP','LMPP','CMP','CLP','GMP','MEP',"Bcell","CD4Tcell","CD8Tcell",'NKcell','Mono','Ery'),level=c(1,2,3,3,4,4,4,5,5,5,5,5,5),immunepath=c(1,1,1,0,1,0,0,1,1,1,1,0,0),monopath=c(1,1,1,1,0,1,0,0,0,0,0,1,0),erypath=c(1,1,0,1,0,0,1,0,0,0,0,0,1),stringsAsFactors = F)
row.names(ctlevel) <- ctlevel[,1]
correctorder <- wrongorder <- NULL
for(pid in c('immunepath','monopath','erypath')) {
  evct <- ctlevel[ctlevel[,pid]==1,1]
  pair <- expand.grid(evct,evct)
  pair[,1] <- as.character(pair[,1])
  pair[,2] <- as.character(pair[,2])
  pair <- pair[pair[,1]!=pair[,2],]
  corid <- which(ctlevel[pair[,1],'level'] < ctlevel[pair[,2],'level'])
  wroid <- which(ctlevel[pair[,1],'level'] > ctlevel[pair[,2],'level'])
  correctorder <- c(correctorder,sapply(corid,function(si) paste0(pair[si,],collapse = '_')))
  wrongorder <- c(wrongorder,sapply(wroid,function(si) paste0(pair[si,],collapse = '_')))
}
correctorder <- unique(correctorder)
wrongorder <- unique(wrongorder)
###  monocle2
library(monocle)
get_cds_monocle2 = function(gene_bc_mat, cell_type, ctlevel){
  #  Firstly make a new CDS and use DDRTree for dimension reduction.
  pd = new("AnnotatedDataFrame", data = data.frame(row.names = colnames(gene_bc_mat), cell = colnames(gene_bc_mat)))
  fd = new("AnnotatedDataFrame", data = data.frame(row.names = rownames(gene_bc_mat), gene_short_name = rownames(gene_bc_mat)))
  cds = newCellDataSet(gene_bc_mat, phenoData = pd, featureData = fd, expressionFamily = negbinomial.size())
  cds = estimateSizeFactors(cds)
  cds = estimateDispersions(cds)
  disp_table = dispersionTable(cds)
  ordering_genes = subset(disp_table, mean_expression >= 0.1)
  cds = setOrderingFilter(cds, ordering_genes)
  print("Reducing dimension...")
  cds = reduceDimension(cds)
  cds = orderCells(cds)
  print("Looking for the root state...")
  cell_states = as.numeric(as.character(pData(cds)$State))
  names(cell_states) = colnames(gene_bc_mat)
  unique_states = unique(cell_states)
  checkroot = sapply(unique_states, function(x){
    cds = orderCells(cds, root_state = x)
    return(length(cds@auxOrderingData[[cds@dim_reduce_type]]$root_cell))
  })
  unique_states_filt = unique_states[checkroot > 0]
  root_state = unique_states_filt[which.min(sapply(unique_states_filt, function(x){
    return(mean(ctlevel[cell_type[names(cell_states)[cell_states == x]], 2], na.rm = T))
  }))]
  #  Reorder the cells.
  return(orderCells(cds, root_state = root_state))
}
get_order_pairs_monocle2 = function(cds, cell_type){
  pair_list = list()
  if(length(cds@auxOrderingData[[cds@dim_reduce_type]]$branch_points) > 0){
    for(ii in seq(length(cds@auxOrderingData[[cds@dim_reduce_type]]$branch_points))){
      cds_reduced = buildBranchCellDataSet(cds, branch_point = ii)
      df = data.frame(pData(cds_reduced),stringsAsFactors = F)[names(cell_type), ]
      df = df[order(df$Pseudotime), ]
      compare_order = c()
      for(jj in unique(df$Branch)){
        branch_cell = as.character(df[df$Branch == jj, 1])
        branch_celltype = cell_type[branch_cell]
        index_pair = combn(length(branch_cell), 2)
        if(min(index_pair[2,] - index_pair[1,]) < 0){
          stop("index_pair error")
        }
        branch_order = sprintf('%s_%s',branch_celltype[index_pair[1, ]], branch_celltype[index_pair[2, ]])
        branch_pair = sprintf('%s_%s',branch_cell[index_pair[1, ]], branch_cell[index_pair[2, ]])
        names(branch_order) = branch_pair
        compare_order = c(compare_order, branch_order)
      }
    pair_list[[ii]] = compare_order
    }
  }else{
    print("Trajectory has only 1 branch.")
    df = data.frame(pData(cds),stringsAsFactors = F)[names(cell_type), ]
    df = df[order(df$Pseudotime), ]
    branch_cell = as.character(df[, 1])
    branch_celltype = cell_type[branch_cell]
    index_pair = combn(length(branch_cell), 2)
    if(min(index_pair[2,] - index_pair[1,]) < 0){
      stop("index_pair error")
    }
    branch_order = sprintf('%s_%s',branch_celltype[index_pair[1, ]], branch_celltype[index_pair[2, ]])
    branch_pair = sprintf('%s_%s',branch_cell[index_pair[1, ]], branch_cell[index_pair[2, ]])
    names(branch_order) = branch_pair
    pair_list[[1]] = branch_order
  }
  return(pair_list)
}
acc_function = function(pair_list, correctorder, wrongorder, compare_pairs = NULL){
  acc = 0
  for(ii in pair_list){
    if(is.null(compare_pairs)){
      score = c(sum(ii %in% correctorder), sum(ii %in% wrongorder))
    }else{
      compare_order = ii[intersect(names(ii), compare_pairs)]
      score = c(sum(compare_order %in% correctorder), sum(compare_order %in% wrongorder))
    }
    acc = max(c(acc, score[1] / sum(score)))
  }
  return(acc)
}
get_compare_pairs = function(pair_list_list){
  library(stringi)
  flag = TRUE
  compair_list = list()
  compare_pairs = NULL
  for(ii in names(pair_list_list)){
    select_pair = c()
    select_order = NULL
    for(jj in pair_list_list[[ii]]){
      this_pair = names(jj)
      cat(ii, " - ", length(this_pair), " pairs\n")
      this_unique_pair = unique(this_pair)
      this_reverse_pair = apply(stri_list2matrix(stri_split_fixed(this_unique_pair, "_"))[c(2, 1), ], 2, stri_join, collapse = "_")
      candidate_pair = union(this_unique_pair, this_reverse_pair)
      if(length(select_pair) < length(candidate_pair)){
        select_pair = candidate_pair
        select_order = jj
      }
    }
    if(flag){
      compare_pairs = select_pair
      flag = FALSE
    }else{
      compare_pairs = intersect(compare_pairs, select_pair)
    }
    compair_list[[ii]] = select_order
  }
  cat("Use ", length(compare_pairs), " pairs to compare.\n")
  return(list(compare_pairs = compare_pairs, compair_list = compair_list))
}

###
gene_bc_mat = readh5_loom("./data/BONE_MARROW/DISC.loom")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/DISC_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_loom("./data/BONE_MARROW/Raw.loom")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/Raw_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_imputation("./data/BONE_MARROW/scVI.hdf5")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/scVI_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_imputation("./data/BONE_MARROW/scImpute.hdf5")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/scImpute_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_imputation("./data/BONE_MARROW/DeepImpute.hdf5")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/DeepImpute_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_imputation("./data/BONE_MARROW/scScope.hdf5")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/scScope_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_imputation("./data/BONE_MARROW/MAGIC.hdf5")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/MAGIC_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_imputation("./data/BONE_MARROW/DCA.hdf5")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/DCA_result_monocle2_new.rds"))

###
gene_bc_mat = readh5_imputation("./data/BONE_MARROW/VIPER.hdf5")
gene_bc_filt = gene_bc_mat[used_genes, ]
cds = get_cds_monocle2(gene_bc_filt, cell_type, ctlevel)
pair_list = get_order_pairs_monocle2(cds, cell_type)
acc = acc_function(pair_list, correctorder, wrongorder)
print(acc)
result_list = list(cds = cds, pair_list = pair_list, acc = acc)
saveRDS(result_list, paste0(output_dir, "/VIPER_result_monocle2_new.rds"))

###
method_names = c("Raw", "DISC", "scImpute", "VIPER", "MAGIC", "DCA", "DeepImpute", "scScope", "scVI")
pair_list_list = list()
for(ii in method_names){
  result_list = readRDS(paste0(output_dir, "/", ii, "_result_monocle2_new.rds"))
  pair_list_list[[ii]] = result_list[["pair_list"]]
  print(ii)
}

for(ii in method_names){
  result_list = readRDS(paste0(output_dir, "/", ii, "_result_monocle2_new.rds"))
  result_list[["acc"]] = acc_function(result_list[["pair_list"]], correctorder, wrongorder)
  cat(ii, " - ", result_list[["acc"]], "\n")
}

compair_list = get_compare_pairs(pair_list_list)
acc_all = c()
for(ii in names(compair_list[["compair_list"]])){
  acc_all = c(acc_all, acc_function(compair_list[["compair_list"]][[ii]], correctorder, wrongorder, compair_list[["compare_pairs"]]))
}
names(acc_all) = names(compair_list[["compair_list"]])
print(acc_all)

pair_list_list1 = list(DISC = pair_list_list[["DISC"]], Raw = pair_list_list[["Raw"]])
compair_list1 = get_compare_pairs(pair_list_list1)
acc_all1 = c()
for(ii in names(compair_list)){
  acc_all1 = c(acc_all1, acc_function(compair_list1[["compair_list"]][[ii]], correctorder, wrongorder, compair_list1[["compare_pairs"]]))
}
names(acc_all1) = names(compair_list1)
print(acc_all1)

DISC_res = readRDS(paste0(output_dir, "/DISC_result_monocle2_new.rds"))
scVI_res = readRDS(paste0(output_dir, "/scVI_result_monocle2_new.rds"))
scScope_res = readRDS(paste0(output_dir, "/scScope_result_monocle2_new.rds"))

Raw_res = readRDS(paste0(output_dir, "/Raw_result_monocle2_new.rds"))
DeepImpute_res = readRDS(paste0(output_dir, "/DeepImpute_result_monocle2_new.rds"))
DCA_res = readRDS(paste0(output_dir, "/DCA_result_monocle2_new.rds"))

VIPER_res = readRDS(paste0(output_dir, "/VIPER_result_monocle2_new.rds"))
scImpute_res = readRDS(paste0(output_dir, "/scImpute_result_monocle2_new.rds"))
MAGIC_res = readRDS(paste0(output_dir, "/MAGIC_result_monocle2_new.rds"))

p = plot_cell_trajectory(Raw_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_Raw_new.pdf"), p)
pData(Raw_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(Raw_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(Raw_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_Raw_cell_type_new.pdf"), p)
p = plot_cell_trajectory(Raw_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_Raw_level_new.pdf"), p)

p = plot_cell_trajectory(DISC_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_DISC_new.pdf"), p)
pData(DISC_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(DISC_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(DISC_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_DISC_cell_type_new.pdf"), p)
p = plot_cell_trajectory(DISC_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_DISC_level_new.pdf"), p)

p = plot_cell_trajectory(scVI_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_scVI_new.pdf"), p)
pData(scVI_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(scVI_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(scVI_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_scVI_cell_type_new.pdf"), p)
p = plot_cell_trajectory(scVI_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_scVI_level_new.pdf"), p)

p = plot_cell_trajectory(scScope_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_scScope_new.pdf"), p)
pData(scScope_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(scScope_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(scScope_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_scScope_cell_type_new.pdf"), p)
p = plot_cell_trajectory(scScope_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_scScope_level_new.pdf"), p)

p = plot_cell_trajectory(DeepImpute_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_DeepImpute_new.pdf"), p)
pData(DeepImpute_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(DeepImpute_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(DeepImpute_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_DeepImpute_cell_type_new.pdf"), p)
p = plot_cell_trajectory(DeepImpute_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_DeepImpute_level_new.pdf"), p)

p = plot_cell_trajectory(VIPER_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_VIPER_new.pdf"), p)
pData(VIPER_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(VIPER_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(VIPER_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_VIPER_cell_type_new.pdf"), p)
p = plot_cell_trajectory(VIPER_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_VIPER_level_new.pdf"), p)

p = plot_cell_trajectory(scImpute_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_scImpute_new.pdf"), p)
pData(scImpute_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(scImpute_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(scImpute_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_scImpute_cell_type_new.pdf"), p)
p = plot_cell_trajectory(scImpute_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_scImpute_level_new.pdf"), p)

p = plot_cell_trajectory(DCA_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_DCA_new.pdf"), p)
pData(DCA_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(DCA_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(DCA_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_DCA_cell_type_new.pdf"), p)
p = plot_cell_trajectory(DCA_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_DCA_level_new.pdf"), p)

p = plot_cell_trajectory(MAGIC_res[["cds"]], color_by = "Pseudotime")
ggsave(paste0(output_dir, "/monocle2_MAGIC_new.pdf"), p)
pData(MAGIC_res[["cds"]])$CellType = cell_type[colnames(gene_bc_mat)]
pData(MAGIC_res[["cds"]])$level = as.character(ctlevel[cell_type[colnames(gene_bc_mat)], "level"])
p = plot_cell_trajectory(MAGIC_res[["cds"]], color_by = "CellType")
ggsave(paste0(output_dir, "/monocle2_MAGIC_cell_type_new.pdf"), p)
p = plot_cell_trajectory(MAGIC_res[["cds"]], color_by = "level")
ggsave(paste0(output_dir, "/monocle2_MAGIC_level_new.pdf"), p)


pdf_file<-"pdf/dotcharts_heights.pdf"
cairo_pdf(bg="grey98", pdf_file,width=8,height=9)

par(omi=c(0.5,0.5,1.1,0.5),mai=c(0,2,0,0.5),family="Lato Light",las=1)
myColour_dotchart<-rgb(55,55,55,maxColorValue=255)
par(omi=c(0,0,1,0),mai=c(0.75,0,0,1))
myPersons<-read.xls("myData/persons.xlsx", encoding="latin1")
mySelection<-subset(myPersons,s=="m")
attach(mySelection)
sort.mySelection<-mySelection[order(h),]
attach(sort.mySelection)
group3<-factor(group3)
dotchart(h,labels=name,cex=.6,groups=group3,xlab="cm",gcolor=myColour_dotchart,color=markings)

# Titling

mtext("Body height of selected celebrities",3,adj=0,line=1,cex=1.5,col="black")
dev.off()


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')

setwd("/Users/mengmengjiang/all datas/voltage")
library(xlsx)

# reading and compare the datas from gly1 and he-25g

k1<-read.xlsx("he-32g.xlsx", sheetName = "2kv18", header = TRUE)
k2<-read.xlsx("qd3.xlsx", sheetName = "v1", header = TRUE)
k3<-read.xlsx("qd3.xlsx", sheetName = "v2", header = TRUE)
k4<-read.xlsx("qd3.xlsx", sheetName = "v3", header = TRUE)

##
yan<-c("red","blue","black","green3")
pcc<-c(0,1,2,5)

##
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
  if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
    stop("vectors must be same length")
  arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}
##

plot(k1$fv,1/k1$d_Rn, col=0,xlab = expression(italic(f["v"]) (Hz)),
     ylab = expression(italic(ratio)) , mgp=c(1.1, 0, 0),tck=0.02,
     main = "", xlim = c(0,4000),ylim=c(0,20))

     mtext("32G-18nl/min-ratio",3,line=0.2,font=2,cex=1.2)

lines(k1$fv,1/k1$d_eRn,col=yan[1],pch=pcc[1],type="b",lwd=2,lty=2)
lines(k2$fv,k2$raeva,col=yan[2],pch=pcc[2],type="b",lwd=2,lty=2)
lines(k3$fv,k3$raeva,col=yan[3],pch=pcc[3],type="b",lwd=2,lty=2)
lines(k4$fv,k4$raeva,col=yan[4],pch=pcc[4],type="b",lwd=2,lty=2)

error.bar(k1$fv,1/k1$d_eRn,0,col=yan[1])
error.bar(k2$fv,k2$raeva,k2$rastd/2,col=yan[2])
error.bar(k3$fv,k3$raeva,k3$rastd/2,col=yan[3])
error.bar(k4$fv,k4$raeva,k4$rastd/2,col=yan[4])

leg<-c("V0+0:0kv+2Kv","Va+Vb:1.7kv-2kv","Va+Vb:1.8kv-2kv","Va+Vb:1.9kv-2kv")

legend("topleft",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,inset=.03,bty="n",cex=0.9)