### from smillie et al
### https://github.com/cssmillie/ulcerative_colitis

qtrim = function(x, qmin=0, qmax=1, vmin=-Inf, vmax=Inf, rescale=NULL){

    # Trim by value
    x[x < vmin] = vmin
    x[x > vmax] = vmax

    # Trim by quantile
    u = quantile(x, qmin, na.rm=T)
    v = quantile(x, qmax, na.rm=T)
    x[x < u] = u
    x[x > v] = v

    return(x)
}

plot_tsne = function(seur=NULL, names=NULL, scores=NULL, coords=NULL, data=NULL, meta=NULL, regex=NULL, files=NULL, file.cols=NULL, file.regex=NULL, top=NULL, ident=TRUE, data.use='log2',
                     combine_genes='mean', cells.use=NULL, ymin=0, ymax=1, num_col='auto', pt.size=.75, font.size=11, do.label=T, label.size=5, do.title=TRUE, title.use=NULL, pal=NULL,
	             do.legend=TRUE, legend.title='log2(TP10K+1)', share_legend=FALSE, legend_width=.05, legend.cols=NULL, vmin=NA, vmax=NA, na.value='transparent', out=NULL, nrow=1.5, ncol=1.5, ...){

    # TSNE coordinates
    if(is.null(coords)){
        d = structure(as.data.frame(seur@reductions[['tsne']]@cell.embeddings[,1:2]), names=c('x', 'y'))
    } else {
        d = structure(as.data.frame(coords[,1:2]), names=c('x', 'y'))
    }

    # Cell identities
    if(!is.logical(ident)){
        d$Identity = ident
    } else if(ident & !is.null(seur)){
        d$Identity = seur@active.ident
    }

    # Cell scores
    if(!is.null(cells.use)){cells.use = intersect(cells.use, rownames(d))}
    scores = score_cells(seur=seur, names=names, combine_genes=combine_genes, cells.use=cells.use)
    if(!is.null(scores)){
        i = intersect(rownames(d), rownames(scores))
	ni = c(names(d), names(scores))
	d = cbind.data.frame(d[i,], scores[i,])
	colnames(d) = ni
    }

    # Subset cells
    if(is.null(cells.use)){cells.use = rownames(d)}
    d = data.frame(d[cells.use,])

    # Initialize plotlist
    cat('\nPlotting:', paste(colnames(subset(d, select=-c(x,y))), collapse=', '), '\n')
    ps = list()

    # Shuffle point order
    d = d[sample(1:nrow(d)),]

    # Get limits for shared legend
    if(share_legend == TRUE){
        j = names(which(sapply(subset(d, select=-c(x,y)), is.numeric)))
	cat('\nShared limits:', paste(j, collapse=', '), '\n')
        if(is.na(vmin)){vmin = na.omit(min(d[,j]))}
	if(is.na(vmax)){vmax = na.omit(max(d[,j]))}
	cat('> vmin =', vmin, '\n> vmax =', vmax, '\n')
    }

    for(col in setdiff(colnames(d), c('x', 'y'))){

        # plot NAs first
        d = d[c(which(is.na(d[,col])), which(!is.na(d[,col]))),]

	if(is.numeric(d[,col])){

	    # Continuous plot
	    d[,col] = qtrim(d[,col], qmin=ymin, qmax=ymax)
	    p = ggplot(d) +
	        geom_point(aes_string(x='x',y='y',colour=col), size=pt.size, ...) +
		scale_colour_gradientn(colours=material.heat(50), guide=guide_colourbar(barwidth=.5, title=legend.title), na.value=na.value, limits=c(vmin, vmax)) +
		theme_cowplot(font_size=font.size) +
		xlab('TSNE 1') + ylab('TSNE 2')

	} else {

	    # Discrete plot

	    # Get colors
	    if(do.label == TRUE){tsne.colors = set.colors} else {tsne.colors = set.colors}
	    if(!is.null(pal)){tsne.colors = pal}

	    p = ggplot(d) +
	        geom_point(aes_string(x='x',y='y',colour=col), size=pt.size, ...) +
		theme_cowplot(font_size=font.size) +
		xlab('TSNE 1') + ylab('TSNE 2') +
		scale_colour_manual(values=tsne.colors, na.value=na.value, drop=F) +
		theme(panel.border = element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +
		guides(colour=guide_legend(ncol=legend.cols, title=legend.title))

	    if(do.label == T){
	        t = aggregate(d[,c('x', 'y')], list(d[,col]), median)
		colnames(t) = c('l', 'x', 'y')
		p = p + geom_text_repel(data=t, aes(x=x, y=y, label=l, lineheight=.8), point.padding=NA, size=label.size, family='Helvetica') + theme(legend.position='none')
	    }
	}

	if(do.title == TRUE){
	    if(is.null(title.use)){title = col} else {title = title.use}
	    p = p + ggtitle(title)
	}
	if(do.legend == FALSE){p = p + theme(legend.position='none')}
	if(legend.title == ''){p = p + theme(legend.title=element_blank())}

	ps[[col]] = p
    }

    if(num_col == 'auto'){
        num_col = ceiling(sqrt(length(ps)))
    }

    ps = make_compact(plotlist=ps, num_col=num_col)
    if(length(ps) > 1){
        if(share_legend == TRUE){
            p = share_legend(ps, num_col=num_col, width=legend_width)
        } else {
            p = plot_grid(plotlist=ps, ncol=num_col, align='h')
        }
    }

    if(is.null(out)){
        p
    } else {
        save_plot(file=out, p, nrow=nrow, ncol=ncol)
    }
}

make_compact = function(plotlist, num_col, labels=TRUE, ticks=TRUE){

    # Make a "plot_grid" plotlist compact by removing axes from interior plots

    # x-axis
    if(length(plotlist) > num_col){
        i = setdiff(1:length(plotlist), rev(1:length(plotlist))[1:min(num_col, length(plotlist))])
	if(labels == TRUE){plotlist[i] = lapply(plotlist[i], function(p) p + theme(axis.title.x=element_blank()))}
	if(ticks == TRUE){plotlist[i] = lapply(plotlist[i], function(p) p + theme(axis.text.x=element_blank()))}
    }

    # y-axis
    if(num_col > 1){
        i = setdiff(1:length(plotlist), which(1:length(plotlist) %% num_col == 1))
	if(labels == TRUE){plotlist[i] = lapply(plotlist[i], function(p) p + theme(axis.title.y=element_blank()))}
	if(ticks == TRUE){plotlist[i] = lapply(plotlist[i], function(p) p + theme(axis.text.y=element_blank()))}
    }

    return(plotlist)
}

share_legend = function(plotlist, num_col, rel_widths=NULL, width=.1){

    # Get first legend in plotlist
    i = min(which(sapply(plotlist, function(p) 'guide-box' %in% ggplotGrob(p)$layout$name)))
    cat(paste('\nUsing shared legend:', names(plotlist)[i], '\n'))
    legend = get_legend(plotlist[[i]])

    # Remove all legends
    plotlist = lapply(plotlist, function(p) p + theme(legend.position='none'))

    # Make combined plot
    if(is.null(rel_widths)){rel_widths = rep(1, length(plotlist))}
    p = plot_grid(plotlist=plotlist, ncol=num_col, align='h', rel_widths=rel_widths)
    p = plot_grid(p, legend, ncol=2, rel_widths=c(1-width, width))

    return(p)
}

ggheatmap = function(data, Rowv='hclust', Colv='hclust', xlab='', ylab='', xsec=FALSE, ysec=FALSE, xstag=FALSE, xstag_space=.15, ystag=FALSE, ystag_space=.15, title='', legend.title='',
                     pal='nmf', do.legend=TRUE, font_size=7,
                     out=NULL, nrow=1.25, ncol=1.25, qmin=0, qmax=1, vmin=-Inf, vmax=Inf, symm=FALSE, xstrip=NULL, ystrip=NULL, hclust_met='complete', border='#cccccc', replace_na=NA,
		     labRow=NULL, labCol=NULL, ret.order=FALSE, ret.legend=FALSE, pvals=NULL, max_pval=1, pval_border='black', pval_width=.25){

    # Scale values
    data[is.na(data)] = replace_na
    data = qtrim(data, qmin=qmin, qmax=qmax, vmin=vmin, vmax=vmax)

    # Convert to long format
    x = as.data.frame(data) %>% rownames_to_column('row') %>% gather(col, value, -row)
    x$value = as.numeric(x$value)

    # Merge data and p-values
    if(is.null(pvals)){
        x$pval = border
    } else {
        if(ncol(pvals) == 3){
	    colnames(pvals) = c('row', 'col', 'pval')
	    pvals$row = as.character(pvals$row)
	    pvals$col = as.character(pvals$col)
	} else {
	    pvals = as.data.frame(pvals) %>% rownames_to_column('row') %>% gather(col, pval, -row)
	    pvals$pval = as.numeric(pvals$pval)
	}
	if(length(intersect(x$row, pvals$row)) == 0){
	    colnames(pvals) = c('col', 'row', 'pval')
	}
	x = as.data.frame(merge(as.data.table(x), as.data.table(pvals), by=c('row', 'col'), all.x=TRUE))
	x$pval = ifelse(x$pval <= max_pval, pval_border, NA)
	x$pval[is.na(x$pval)] = border
    }

    # Order rows
    if(length(Rowv) > 1){rowv = Rowv; Rowv = 'Rowv'} else {rowv = rev(rownames(data))}
    if(length(Colv) > 1){colv = Colv; Colv = 'Colv'} else {colv = colnames(data)}
    if(nrow(data) <= 2){Rowv = 'none'}
    if(ncol(data) <= 2){Colv = 'none'}
    if(Rowv == 'hclust'){
        rowv = rev(rownames(data)[hclust(dist(data), method=hclust_met)$order])
    }
    if(Colv == 'hclust'){
        colv = colnames(data)[hclust(dist(t(data)), method=hclust_met)$order]
    }
    if(Rowv == 'none'){
        rowv = rev(rownames(data))
    }
    if(Colv == 'none'){
        colv = colnames(data)
    }
    if(Rowv == 'min'){
        rowv = rev(rownames(data)[order(apply(data, 1, which.min))])
    }
    if(Rowv == 'max'){
    	i = match(colnames(data)[apply(data, 1, which.max)], colv)
	rowv = rev(rownames(data)[order(i)])
    }
    if(Colv == 'min'){
        i = match(rownames(data)[apply(data, 2, which.min)], rowv)
	colv = rev(colnames(data)[order(i)])
    }
    if(Colv == 'max'){
	i = match(rownames(data)[apply(data, 2, which.max)], rowv)
	colv = rev(colnames(data)[order(i)])
    }
    Rowv = rowv
    Colv = colv

    # Set order of row and column labels
    x$row = factor(x$row, levels=Rowv)
    x$col = factor(x$col, levels=Colv)

    # Get odd/even indices
    r1 = seq(1, length(Rowv), by=2)
    r2 = seq(2, length(Rowv), by=2)
    c1 = seq(1, length(Colv), by=2)
    c2 = seq(2, length(Colv), by=2)

    # Get plot data
    if(length(pal)==1){if(pal == 'nmf'){pal = rev(colorRampPalette(nmf.colors)(101))[10:101]} else {pal = colorRampPalette(brewer.pal(9, pal))(101)}}

    # Plot significant boxes last
    x = x[rev(order(x$pval != 'black')),]

    # Plot with geom_tile
    p = ggplot(x) +
        geom_tile(aes(x=as.numeric(col), y=as.numeric(row), fill=value), color=x$pval, size=pval_width) +
	labs(x=xlab, y=ylab, title=title, fill=legend.title) +
	theme_cowplot(font_size=font_size) +
	theme(axis.text.x=element_text(angle=90, hjust=1, vjust=.5), axis.line=element_blank())

    # Set scale
    if(is.infinite(vmin)){vmin = min(x$value)}
    if(is.infinite(vmax)){vmax = max(x$value)}
    limits = c(vmin, vmax)
    if(symm == TRUE){
        values = c(min(x$value), 0, max(x$value))
	p = p + scale_fill_gradientn(colours=pal, values=scales::rescale(values))
    } else {
        p = p + scale_fill_gradientn(colours=pal, limits=limits)
    }

    # Secondary x-axis
    if(xsec == FALSE){
        p = p + scale_x_continuous(breaks=1:length(Colv), labels=Colv, expand=c(0,0))
    } else {
	p = p + scale_x_continuous(breaks=c1, labels=Colv[c1], sec.axis=dup_axis(breaks=c2, labels=Colv[c2]), expand=c(0,0)) + theme(axis.text.x.top= element_text(angle=90, hjust=0, vjust=.5))
    }

    # Secondary y-axis
    if(ysec == FALSE){
        p = p + scale_y_continuous(breaks=1:length(Rowv), labels=Rowv, expand=c(0,0))
    } else {
	p = p + scale_y_continuous(breaks=r1, labels=Rowv[r1], sec.axis=dup_axis(breaks=r2, labels=Rowv[r2]), expand=c(0,0))
    }

    # Add axes with ggrepel (use both sides to fit as many labels as possible)
    if(!is.null(labRow)){
        p = p + theme(axis.text.y=element_blank(), axis.ticks.y=element_blank())
	if(!is.logical(labRow)){
	    lab.use = intersect(Rowv, labRow)
	    lab.l = ifelse(Rowv %in% lab.use[seq(from=1, to=length(lab.use), by=2)], Rowv, '')
	    lab.r = ifelse(Rowv %in% lab.use[seq(from=2, to=length(lab.use), by=2)], Rowv, '')
	    legend = get_legend(p)
	    p = p + theme(legend.position='none', plot.margin=margin(l=-10, unit='pt'))
	    axis.l = add_ggrepel_axis(plot=p, lab=lab.l, type='left', font_size=font_size)
	    axis.r = add_ggrepel_axis(plot=p, lab=lab.r, type='right', font_size=font_size)
	    p = plot_grid(axis.l, p, axis.r, nrow=1, rel_widths=c(.15,1,.15), align='h', axis='tb')
	    p = plot_grid(p, legend, nrow=1, rel_widths=c(.925, .075))
	}
    }

    if(!is.null(labCol)){
        p = p + theme(axis.text.x=element_blank(), axis.ticks.x=element_blank())
	if(xsec == TRUE & !is.logical(labCol)){
	    lab.use = intersect(Colv, labCol)
	    lab.u = ifelse(Colv %in% lab.use[seq(from=1, to=length(lab.use), by=2)], Colv, '')
	    lab.d = ifelse(Colv %in% lab.use[seq(from=2, to=length(lab.use), by=2)], Colv, '')
	    legend = get_legend(p)
	    p = p + theme(legend.position='none', plot.margin=margin(t=-10, b=-12.5, unit='pt'))
	    axis.u = add_ggrepel_axis(plot=p, lab=lab.u, type='up', font_size=font_size, do.combine=FALSE)
	    axis.d = add_ggrepel_axis(plot=p, lab=lab.d, type='down', font_size=font_size, do.combine=FALSE)
	    p = plot_grid(axis.u, p, axis.d, nrow=3, rel_heights=c(.15,1,.15), align='v', axis='lr')
	    p = plot_grid(p, legend, nrow=1, rel_widths=c(.925, .075))
	}
	if(xsec == FALSE & !is.logical(labCol)){
	    lab.use = ifelse(Colv %in% intersect(Colv, labCol), Colv, '')
	    legend = get_legend(p)
	    p = p + theme(legend.position='none')
	    axis.d = add_ggrepel_axis(plot=p, lab=lab.use, type='down', font_size=font_size, do.combine=FALSE)
	    p = plot_grid(p, axis.d, nrow=2, rel_heights=c(1, .15), align='v', axis='lr')
	    p = plot_grid(p, legend, nrow=1, rel_widths=c(.925, .075))
	}
    }

    if(xstag == TRUE){
        nudge = rep(c(0, 1), length.out=length(Colv))
	p = add_ggrepel_axis(plot=p, lab=Colv, dir='x', type='down', font_size=font_size, force=0, axis.width=xstag_space, nudge=nudge, ret.legend=ret.legend)
    }

    if(ystag == TRUE){
        nudge = rep(c(0, 1), length.out=length(Rowv))
	p = add_ggrepel_axis(plot=p, lab=Rowv, dir='y', type='left', font_size=font_size, force=0, axis.width=ystag_space, nudge=nudge, ret.legend=ret.legend)
    }

    if(do.legend == FALSE){p = p + theme(legend.position='none')}

    # Save plot
    if(!is.null(out)){
        save_plot(p, file=out, nrow=nrow, ncol=ncol)
    }

    if(ret.order == FALSE){p} else {list(p=p, Rowv=Rowv, Colv=Colv)}
}

add_ggrepel_axis = function(plot, lab, dir='both', type='left', lab.pos=NULL, lab.lim=NULL, nudge=0, force=1, axis.width=.10, legend.width=.075, font_size=8, ret.legend=FALSE, do.combine=TRUE){

    # Fix input arguments
    if(is.null(lab.pos)){lab.pos = 1:length(lab)}
    if(is.null(lab.lim)){lab.lim = c(min(lab.pos)-1, max(lab.pos)+1)}

    # Set label directions
    if(type == 'left'){x=0; y=lab.pos; xlim=c(-1,0); ylim=lab.lim; angle=0; nudge_x=-1*nudge; nudge_y=0}
    if(type == 'up'){x=lab.pos; y=0; xlim=lab.lim; ylim=c(0,1); angle=90; nudge_x=0; nudge_y=nudge}
    if(type == 'right'){x=0; y=lab.pos; xlim=c(0,1); ylim=lab.lim; angle=0; nudge_x=nudge; nudge_y=0}
    if(type == 'down'){x=lab.pos; y=0; xlim=lab.lim; ylim=c(-1,0); angle=90; nudge_x=0; nudge_y=-1*nudge}

    # Get data for ggplot
    d = data.frame(x=x, y=y, lab=lab, dir=dir, nudge_y=nudge_y)

    # Make ggrepel axis
    axis = ggplot(d, aes(x=x, y=y, label=lab)) +
           geom_text_repel(min.segment.length=grid::unit(0,'pt'), color='grey30', size=(font_size-1)/.pt, angle=angle, segment.color='#cccccc', segment.size=.15,
	                   direction=dir, nudge_x=nudge_x, nudge_y=nudge_y, force=force) +
	   scale_x_continuous(limits=xlim, expand=c(0,0), breaks=NULL, labels=NULL, name=NULL) +
	   scale_y_continuous(limits=ylim, expand=c(0,0), breaks=NULL, labels=NULL, name=NULL) +
    	   theme(panel.background = element_blank(), plot.margin = margin(0, 0, 0, 0, 'pt'))

    if(do.combine == FALSE){return(axis)}

    # Get plot legend
    legend = get_legend(plot)
    plot = plot + theme(legend.position='none')

    # Combine plots
    if(type == 'left'){
        plot = plot + scale_y_continuous(limits=lab.lim, expand=c(0,0))
        plot = plot + theme(plot.margin=margin(l=-12.5, unit='pt')) + theme(axis.text.y=element_blank(), axis.ticks.y=element_blank())
	p = plot_grid(axis, plot, nrow=1, align='h', axis='tb', rel_widths=c(axis.width, 1-axis.width))
	if(ret.legend == FALSE){p = plot_grid(legend, p, nrow=1, rel_widths=c(legend.width, 1-legend.width))}
    }
    if(type == 'up'){
        plot = plot + scale_x_continuous(limits=lab.lim, expand=c(0,0))
        plot = plot + theme(plot.margin=margin(t=-10, unit='pt')) + theme(axis.text.x=element_blank(), axis.ticks.x=element_blank())
	p = plot_grid(axis, plot, nrow=2, align='v', axis='lr', rel_heights=c(axis.width, 1-axis.width))
	if(ret.legend == FALSE){p = plot_grid(legend, p, nrow=1, rel_widths=c(legend.width, 1-legend.width))}
    }
    if(type == 'right'){
        plot = plot + scale_y_continuous(limits=lab.lim, expand=c(0,0))
        plot = plot + theme(plot.margin=margin(r=-10, unit='pt')) + theme(axis.text.y=element_blank(), axis.ticks.y=element_blank())
	p = plot_grid(plot, axis, nrow=1, align='h', axis='tb', rel_widths=c(1-axis.width, axis.width))
	if(ret.legend == FALSE){p = plot_grid(p, legend, nrow=1, rel_widths=c(1-legend.width, legend.width))}
    }
    if(type == 'down'){
        plot = plot + scale_x_continuous(limits=lab.lim, expand=c(0,0))
        plot = plot + theme(plot.margin=margin(b=-11.5, t=5, unit='pt')) + theme(axis.text.x=element_blank(), axis.ticks.x=element_blank())
	p = plot_grid(plot, axis, nrow=2, align='v', axis='lr', rel_heights=c(1-axis.width, axis.width))
	if(ret.legend == FALSE){p = plot_grid(p, legend, nrow=1, rel_widths=c(1-legend.width, legend.width))}
    }

    if(ret.legend == FALSE){p} else {list(p=p, legend=legend)}
}

plot_dots = function(x1=NULL, y1=NULL, x2=NULL, y2=NULL, de=NULL, big_first=FALSE, reorder=FALSE, replace_na=0, na.value='transparent', symm=FALSE, vmin=NULL, vmax=NULL, qmin=0, qmax=1, max_size=5,
                     fill_title='', size_title='', Rowv=NULL, Colv=NULL, pal=rev(brewer.pal(7, 'RdBu')), out=NULL, nrow=1, ncol=1, coord_flip=FALSE, sig_only=TRUE, xlab='', ylab='', font_size=10,
		     pvals=NULL){

    # input arguments
    # x1 = size matrix or list(row, col, size)
    # x2 = size matrix or list(row, col, size)
    # y1 = color matrix or list(row, col, color)
    # y2 = color matrix or list(row, col, color)
    # xanno = annotation track (named list)
    # yanno = annotation track (named list)
    # pvals = data.frame(row, col)

    # convert to long format
    if(!is.null(de)){
        de = as.data.table(de)
        if(sig_only == TRUE){de = de[padjD < .05]}
	x1 = de[,.(col=ident, row=gene, size=alpha)]
	x2 = de[,.(col=ident, row=gene, size=ref_alpha)]
	y1 = de[,.(col=ident, row=gene, color=coefD)]
	y2 = de[,.(col=ident, row=gene, color=coefD)]
    }
    if(!is.null(x1)){
        if(! all(c('row', 'col', 'size') %in% colnames(x1))){
	    cnames = rev(colnames(x1))
	    x1 = x1 %>% rownames_to_column('row')
	    x1$row = factor(x1$row, levels=x1$row)
	    x1 = x1 %>% gather(col, size, -row)
	    x1$col = factor(x1$col, levels=cnames)
	}
        x1 = as.data.table(x1)
    }
    if(!is.null(y1)){
        if(! all(c('row', 'col', 'color') %in% colnames(y1))){
	    cnames = rev(colnames(y1))
	    y1 = y1 %>% rownames_to_column('row')
	    y1$row = factor(y1$row, levels=y1$row)
	    y1 = y1 %>% gather(col, color, -row)
	    y1$col = factor(y1$col, levels=cnames)
	}
	y1 = as.data.table(y1)
    }
    if(!is.null(x2)){
        if(! all(c('row', 'col', 'size') %in% colnames(x2))){
	    cnames = rev(colnames(x2))
	    x2 = x2 %>% rownames_to_column('row')
	    x2$row = factor(x2$row, levels=x2$row)
	    x2 = x2 %>% gather(col, size, -row)
	    x2$col = factor(x2$col, levels=cnames)
	}
	colnames(x2)[colnames(x2) == 'size'] = 'size2'
	if(is.null(x1)){x1 = x2} else {x1 = merge(x1, x2, by=c('row', 'col'), all=T)}
        x2 = as.data.table(x2)
    }
    if(!is.null(y2)){
        if(! all(c('row', 'col', 'color') %in% colnames(y2))){
	    cnames = rev(colnames(y2))
	    y2 = y2 %>% rownames_to_column('row')
	    y2$row = factor(y2$row, levels=y2$row)
	    y2 = y2 %>% gather(col, color, -row)
	    y2$col = factor(y2$col, levels=cnames)
	}
	colnames(y2)[colnames(y2) == 'color'] = 'color2'
	if(is.null(y1)){y1 = y2} else {y1 = merge(y1, y2, by=c('row', 'col'), all=T)}
        y2 = as.data.table(y2)
    }

    # merge data
    d = merge(x1, y1, by=c('row', 'col'), all=T)
    for(j in c('size', 'color', 'size2', 'color2')){if(! j %in% colnames(d)){d[,j] = NA}}
    d = as.data.table(d)

    # replace missing values
    d[,'size'][is.na(d[,'size'])] = replace_na
    d[,'size2'][is.na(d[,'size2'])] = replace_na

    # fix plot order
    if(big_first == TRUE & all(c('size', 'size2') %in% colnames(d))){
        d[, order := size <= size2]
	d[order == TRUE, c('size', 'color', 'size2', 'color2') := .(size2, color2, size, color)]
    }
    else{

    }
    d = as.data.table(d)

    if(reorder != FALSE){
        if(! reorder %in% c('size', 'color', 'size2', 'color2')){stop('reorder != FALSE,size,color,size2,color2 - must specify attribute to use')}
	u = d[,.SD[which.max(abs(color)),row],col]
	Colv = u[order(factor(u[,V1], levels=Rowv)),col]
    }

    if(!is.null(Rowv)){
	d = d[d$row %in% Rowv]
        d$row = factor(d$row, levels=Rowv)
    }
    if(!is.null(Colv)){
	d = d[d$col %in% Colv,]
        d$col = factor(d$col, levels=rev(Colv))
    }

    # get palette
    if(length(pal) == 1){pal = brewer.pal(7, pal)}
    ci = c(d$color, d$color2)
    if(is.null(vmin)){vmin = min(ci, na.rm=T)}
    if(is.null(vmax)){vmax = max(ci, na.rm=T)}
    d$color = qtrim(d$color, vmin=vmin, vmax=vmax, qmin=qmin, qmax=qmax)
    d$color2 = qtrim(d$color2, vmin=vmin, vmax=vmax, qmin=qmin, qmax=qmax)
    border1 = ifelse(d$order, '#000000', '#999999')
    border2 = ifelse(d$order, '#999999', '#000000')
    d$sig = 'P > .05'

    # add p-values
    if(!is.null(pvals)){
        pvals$row = make.names(pvals$row)
	pvals$col = make.names(pvals$col)
        setkeyv(d, c('row', 'col'))
        d[pvals[,.(row, col)], 'sig'] = 'P <= .05'
	d$sig = factor(d$sig, levels=c('P <= .05', 'P > .05'))
	p = ggplot(d) + geom_point(aes(x=col, y=row, size=size, fill=as.numeric(color), color=sig), pch=21, stroke=.25) + scale_color_manual('', values=c('black', 'grey'))
    } else {
        p = ggplot(d) + geom_point(aes(x=col, y=row, size=size, fill=as.numeric(color)), pch=21, color=border1, stroke=.25)
    }

    p = p + theme_cowplot() + xlab(xlab) + ylab(ylab) +
	scale_size_area(size_title, max_size=max_size) +
	theme(panel.grid.major=element_line(colour='black'), axis.text.x=element_text(angle=-45, hjust=0, vjust=.5)) + panel_border() + background_grid(major='xy')

    if(any(d$size2 != 0)){p = p + geom_point(aes(x=col, y=row, size=size2, fill=as.numeric(color2)), pch=21, color=border2, stroke=.25)}

    if(symm == TRUE){
        values = c(vmin, 0, vmax)
	p = p + scale_fill_gradientn(fill_title, colours=pal, values=scales::rescale(values), na.value=na.value, limits=c(vmin, vmax))
    } else {
        p = p + scale_fill_gradientn(fill_title, colours=pal, na.value=na.value, limits=c(vmin, vmax))
    }
    if(coord_flip == TRUE){print('flip')
        p = p + coord_flip() + scale_x_discrete(limits=rev(levels(d$row))) + scale_y_discrete(limits=rev(levels(d$col)))
    } else {
        p = p + scale_x_discrete(limits=levels(d$col)) + scale_y_discrete(limits=levels(d$row))
    }
    if(!is.null(out)){
        save_plot(p, file=out, nrow=nrow, ncol=ncol)
    }

    p
}

plot_violin = function(seur=NULL, names=NULL, scores=NULL, data=NULL, meta=NULL,
                       regex=NULL, files=NULL, file.regex=NULL, file.cols=NULL, top=NULL, type='mean', group_by=NULL, color_by=NULL, pt.size=.25,
	               do.facet=FALSE, facet_by=NULL, facet_genes=NULL, facet_formula=NULL, facet_scales='free_y', qmin=0, qmax=1, vmin=NULL, vmax=NULL, do.scale=FALSE, num_col='auto', resort=NULL,
                       ident=TRUE, cells.use=NULL, do.title=TRUE, do.legend=FALSE, xlab='', ylab='log2(TP10K+1)', out=NULL, nrow=1.5, ncol=1.5, legend.title='Group',
		       coord_flip=FALSE, alpha=1, order=NULL, font_size=10, do.pvals=FALSE, combine_genes='scale2', ret.data=FALSE,
		       mar=unit(c(6,6,6,6),'pt')){

    # Initialize plots
    ps = list()

    # Get facet formula
    if(is.null(facet_formula)){
    if(do.facet == FALSE){
        facet_formula = ifelse(is.null(facet_by), '~ .', 'Facet ~ .')
    } else {
        do.title = FALSE
        facet_formula = ifelse(is.null(facet_by), 'Feature ~ .', 'Feature ~ Facet + .')
    }
    } else {facet_formula = as.formula(facet_formula)}

    # Fix input arguments
    if(is.null(group_by)){group_by = seur@active.ident}
    if(is.null(color_by)){color_by = group_by}
    if(is.null(facet_by)){facet_by = rep('', ncol(seur@assays[['RNA']]@data))}
    if(is.null(cells.use)){cells.use = colnames(seur@assays[['RNA']]@data)}

    # Plot data
    d = data.frame(Group=as.factor(group_by), Color=as.factor(color_by), Facet=as.factor(facet_by), row.names=colnames(seur@assays[['RNA']]@data))
    d = d[cells.use,,drop=F]
    if(coord_flip == TRUE){d$Group = factor(d$Group, levels=rev(levels(d$Group)))}

    # Cell scores
    scores = score_cells(seur=seur, data=data, meta=meta, scores=scores, names=names, regex=regex, files=files, top=top, file.regex=file.regex, file.cols=file.cols, cells.use=cells.use,
                         combine_genes=combine_genes)
    scores = scores[cells.use,,drop=F]
    names = colnames(scores)
    d = cbind.data.frame(d, scores)

    # Fix NAs
    d = d[!is.na(d$Facet),,drop=F]

    # Scale data
    j = sapply(d, function(a) !is.factor(a))
    d[,j] = apply(d[,j,drop=F], 2, function(a) qtrim(a, qmin=qmin, qmax=qmax, vmin=vmin, vmax=vmax))

    # Facet data
    if(do.facet == TRUE){
	d = gather(d, Feature, Value, -Group, -Color, -Facet)
	d$Feature = factor(d$Feature, levels=names)
    }

    if(!is.null(facet_genes)){
        d$Facet = facet_genes[d$Feature]
    }

    # Calculate p-values
    d$Group = droplevels(d$Group)
    if(do.pvals == TRUE){
    pvals = do.call(rbind, lapply(levels(d$Feature), function(fi) {do.call(rbind,
        lapply(levels(d$Group), function(gi) {do.call(rbind,
	    lapply(setdiff(levels(d$Facet), levels(d$Facet)[[1]]), function(hi){
                u = d[(d$Feature == fi & d$Group == gi) & d$Facet == levels(d$Facet)[[1]], 'Value']
	        v = d[(d$Feature == fi & d$Group == gi) & d$Facet == hi, 'Value']
                c(fi, gi, hi, max(v), tryCatch({wilcox.test(u,v,use='pairwise.complete.obs')$p.value}, error=function(e){1}))
	    })
	)})
    )}))

    pvals = data.frame(pvals, stringsAsFactors=F)
    colnames(pvals) = c('Feature', 'Group', 'Facet', 'Value', 'Pval')
    pvals$Value = as.numeric(pvals$Value)
    pvals$Pval = p.adjust(as.numeric(pvals$Pval), 'fdr')
    pvals$Pval[is.na(pvals$Pval)] = 1
    pvals$Label = ifelse(pvals$Pval <= 1e-3, '***', ifelse(pvals$Pval <= 1e-2, '**', ifelse(pvals$Pval <= .05, '*', '')))
    pvals$Color = pvals$Group
    pvals$Facet = factor(pvals$Facet, levels=levels(d$Facet))
    }

    # Violin plots
    for(col in setdiff(colnames(d), c('Group', 'Color', 'Facet', 'Value'))){

        # Convert to numeric?
	if(!is.factor(d[,col]) & !is.character(d[,col])){d[,col] = as.numeric(d[,col])}

        # Facet if necessary
        if(do.facet == TRUE){
	    if(!is.null(resort)){
	        i = d$Feature == levels(d$Feature)[[1]]
	        group_order = names(sort(tapply(d$Value[i], d$Group[i], resort)))
		d$Group = factor(d$Group, levels=group_order)
	    }
	    p = ggplot(data=d, aes_string(x='Group', y='Value', fill='Color'))
	} else {
	    if(!is.null(resort)){
	        group_order = names(sort(tapply(d$Group, d[,col], resort)))
		d$Group = factor(d$Group, levels=group_order)
	    }
	    p = ggplot(data=d, aes_string(x='Group', y=col, fill='Color'))
	}

	# Make violin plot
	p = p +
	    #geom_point(position=position_jitterdodge(dodge.width=0.6, jitter.width=1), size=pt.size, show.legend=F) +
	    geom_quasirandom(position=position_dodge(), size=pt.size, show.legend=F, method='pseudorandom') +
	    geom_violin(scale='width', alpha=alpha, size=.25) +
	    scale_fill_manual(values=set.colors) + theme_cowplot(font_size=font_size) +
	    xlab(xlab) + ylab(ylab) + labs(fill=legend.title) +
	    stat_summary(fun.y=mean, fun.ymin=mean, fun.ymax=mean, geom='crossbar', width=.5, show.legend=F, size=.25) +
	    theme(axis.text.x = element_text(angle = -45, hjust = 0))

	if(do.title == TRUE){
	    p = p + ggtitle(col)
	}

	if(do.legend == FALSE){
	    p = p + guides(fill=FALSE)
	}

	if(coord_flip == TRUE){
	    p = p + coord_flip()
	}

	if(facet_formula != '~ .'){
	    p = p + facet_grid(as.formula(facet_formula), scales=facet_scales)
	}

	if(do.pvals == TRUE){
	    p = p + geom_text(data=pvals, aes(x=Group, y=Value + .01*max(Value), label=Label))
	}

	ps[[col]] = p
    }

    if(num_col == 'auto'){
        num_col = ceiling(sqrt(length(ps)))
    }
    ps = make_compact(ps, num_col=num_col)
    p = plot_grid(plotlist=ps, ncol=num_col)
    p = p + theme(plot.margin=mar)
    if(!is.null(out)){
        save_plot(file=out, p, nrow=nrow, ncol=ncol)
    }
    p
}

matrix_barplot = function(data, group_by=NULL, pvals=NULL, xlab='', ylab='Frequency', value='mean', error='se', legend.title='Groups', colors='Paired', pos='dodge', border=NA,
                          out=NULL, nrow=1.5, ncol=1.5, coord_flip=FALSE, sig_only=F, do.facet=F, asterix.size=5){

    # Plot barplot of [M x N] matrix
    # x-axis = matrix columns (e.g. cell types)
    # y-axis = matrix values (e.g. frequencies)
    # fill = matrix rows (e.g. samples) or groups (e.g. conditions)

    # Arguments:
    # group.by = the group of each row
    # pvals = [G x N] matrix of p-values for each group and column
    # error = sd, se, or none

    # Groups (default = rows)
    if(is.null(group_by)){group_by = rownames(data)}
    if(nlevels(group_by) == 0){group_by = as.factor(group_by)}

    # Select significant comparisons
    if(sig_only == TRUE){
        j = apply(pvals, 2, min) <= .05
	if(sum(j) == 0){return(NULL)}
	data = data[,j,drop=F]
	pvals = pvals[,j,drop=F]
    }

    # Construct input data
    names = colnames(data)
    data = data.frame(group=group_by, data)
    group_levels = levels(group_by)
    colnames(data)[2:ncol(data)] = names
    data = as.data.table(gather_(data, 'x', 'y', setdiff(colnames(data), 'group')))

    # Value function
    if(value == 'mean'){vf = mean} else if(value == 'median'){vf = median} else {stop()}

    # Error function
    se = function(x, na.rm=T){sd(x, na.rm=na.rm)/sqrt(length(x))}
    if(error == 'sd'){ef = sd} else if(error == 'se'){ef = se} else {ef = function(x, ...){0}}

    # Estimate error bars
    data = data[,.(u=vf(y, na.rm=T), s=ef(y, na.rm=T)),.(group, x)]

    # Add p-values 1
    if(!is.null(pvals)){
        pvals = as.data.frame(pvals) %>% rownames_to_column('group') %>% gather(x, pval, -group) %>% as.data.table()
	setkeyv(data, c('x', 'group'))
	setkeyv(pvals, c('x', 'group'))
	data = merge(data, pvals, all=T)
	data$lab1 = ifelse(data$pval <= .001, '**', ifelse(data$pval <= .05, '*', ''))
    }

    if(coord_flip == TRUE){names = rev(names); group_levels=rev(group_levels)}
    data$x = factor(data$x, levels=names)
    data$group = factor(data$group, levels=group_levels)

    # Get colors
    if(length(colors) == 1){colors = set.colors[1:length(group_levels)]}

    # Plot data
    if(pos == 'stack'){
        if(error %in% c('sd', 'se')){p = ggplot(data) + geom_errorbar(aes(x=x, ymin=u-s, ymax=u+s, fill=group), stat='identity', width=.25)}
        p = p + geom_bar(aes(x=x, y=u, fill=group), colour=border, size=.25, stat='identity')
    } else {
        pos = position_dodge(.9)
        if(error %in% c('sd', 'se')){p = ggplot(data) + geom_errorbar(aes(x=x, ymin=u-s, ymax=u+s, fill=group), stat='identity', position=pos, width=.25)}
        p = p + geom_bar(aes(x=x, y=u, fill=group), colour=border, size=.25, stat='identity', position=pos)
    }

    p = p +
        scale_fill_manual(values=colors, name=legend.title) + xlab(xlab) + ylab(ylab) +
        scale_color_manual('', values=c('#000000', '#999999', '#cccccc'), guide='none')

    # Facet wrap
    if(do.facet == TRUE){
        p = p + facet_grid(group ~ ., scales='free')
    }

    dy = max(data$u + data$s, na.rm=T)*.01
    if(coord_flip == FALSE){
        p = p + theme(axis.text.x = element_text(angle = -45, hjust = 0))
	if(!is.null(pvals)){p = p + geom_text(aes(x=x, y=u+s+dy, label=lab1, group=group), hjust='center', vjust=0, size=asterix.size, angle=0, position=pos)}
    } else {
        p = p + coord_flip()
	if(!is.null(pvals)){p = p + geom_text(aes(x=x, y=u+s+dy, label=lab1, group=group), hjust='center', vjust=1, size=asterix.size, angle=90, position=pos)}
    }

    # Save plot
    if(!is.null(out)){save_plot(plot=p, filename=out, nrow=nrow, ncol=ncol)}
    p
}

simple_scatter = function(x, y, lab=NA, sig=FALSE, col=NULL, col.title='', size=NULL, size.title='', lab.use=NULL, lab.sig=FALSE, lab.near=0,  lab.n=0, lab.g=0, groups=NULL, lab.size=4, lab.type='up',
                          palette=NULL, legend.fontsize=10, border=F, edges=NULL, na.value='#cccccc',
                          xlab=NULL, ylab=NULL, out=NULL, nrow=1, ncol=1, min_size=1, max_size=3, xskip=c(0,0), yskip=c(0,0), xlim=NULL, ylim=NULL, alpha=1, unlab.grey=FALSE, auto_color='multi',
			  xmin=-Inf, xmax=Inf, ymin=-Inf, ymax=Inf, xmin.n=1, xmax.n=1, ymin.n=1, ymax.n=1){

    if(is.null(col)){col = rep('', length(x))}
    if(is.null(sig)){sig = rep(NA, length(x))}
    if(is.null(size)){size = rep(1, length(x))}

    if(!is.null(edges)){colnames(edges) = c('x', 'y', 'xend', 'yend')}

    # adjust range
    xmin = max(na.omit(sort(x))[[xmin.n]], xmin)
    xmax = min(na.omit(sort(x, decreasing=T))[[xmax.n]], xmax)
    ymin = max(na.omit(sort(y))[[ymin.n]], ymin)
    ymax = min(na.omit(sort(y, decreasing=T))[[ymax.n]], ymax)
    x[x < xmin] = xmin
    x[x > xmax] = xmax
    y[y < ymin] = ymin
    y[y > ymax] = ymax

    d = data.frame(x=x, y=y, lab=lab, col=col, size=size, flag='', sig=sig, stringsAsFactors=FALSE)
    i.lab = !is.na(d$lab)
    di = d[i.lab,]

    if(is.null(xlab)){xlab = deparse(substitute(x))}
    if(is.null(ylab)){ylab = deparse(substitute(y))}

    if(lab.n > 0 | lab.g > 0){

        i = c()

	if('up' %in% lab.type | 'down' %in% lab.type){

            # get breaks
	    if(!is.null(groups)){groups.use = groups} else {
	        breaks = seq(from=min(di$x, na.rm=T), to=max(di$x, na.rm=T), length.out=min(20, lab.n))
	        groups.use = cut(di$x, breaks=breaks, include.lowest=TRUE)
		groups.use[xskip[[1]] < di$x & di$x < xskip[[2]]] = NA
	    }

	    # get cells
	    if('up' %in% lab.type){
	        i = c(i, as.numeric(simple_downsample(cells=1:nrow(di), groups=groups.use, ngene=di$y, total_cells=lab.n)))
		i = c(i, order(-1*di$y)[1:lab.g])
	    }
	    if('down' %in% lab.type){
	        i = c(i, as.numeric(simple_downsample(cells=1:nrow(di), groups=groups.use, ngene=-1*di$y, total_cells=lab.n)))
		i = c(i, order(di$y)[1:lab.g])
	    }
	}

	if('right' %in% lab.type | 'left' %in% lab.type){

	    # get breaks
	    if(!is.null(groups)){groups.use = groups} else {
	        breaks = seq(from=min(di$y, na.rm=T), to=max(di$y, na.rm=T), length.out=min(20, lab.n))
	        groups.use = cut(di$y, breaks=breaks, include.lowest=TRUE)
		groups.use[yskip[[1]] < di$y & di$y < yskip[[2]]] = NA
	    }

	    # get cells
	    if('right' %in% lab.type){
	        i = c(i, as.numeric(simple_downsample(cells=1:nrow(di), groups=groups.use, ngene=di$x, total_cells=lab.n)))
		i = c(i, order(-1*di$x)[1:lab.g])
	    }

	    if('left' %in% lab.type){
	        i = c(i, as.numeric(simple_downsample(cells=1:nrow(di), groups=groups.use, ngene=-1*di$x, total_cells=lab.n)))
		i = c(i, order(di$x)[1:lab.g])
	    }
	}
	di[unique(i), 'flag'] = 'lab.n'
    }
    d[i.lab,] = di

    if(!is.null(lab.use)){

        # label neighbors
	if(lab.near > 0){
	    u = as.matrix(d[, c('x','y')])
	    v = as.matrix(d[lab %in% lab.use, c('x','y')])
	    i = unique(sort(unlist(apply(dist.matrix(u,v,skip.missing=TRUE,method='euclidean'), 2, order)[1:(lab.near + 1),])))
	    d$flag[i] = 'lab.near'
	}

        # label points
        d$flag[d$lab %in% lab.use] = 'lab.use'
    }

    if(lab.sig == TRUE){d$flag[d$sig == TRUE] = 'lab.use'; d$sig = FALSE}

    d$lab[d$flag == ''] = ''
    d = d[order(d$flag),]
    d$flag = factor(d$flag, levels=c('', 'lab.n', 'lab.use', 'lab.near'), ordered=T)

    if(auto_color == 'none'){d$col = ''}
    if(auto_color == 'bw' & all(col == '')){d$col = ifelse(d$flag == '', '', 'lab.n')}
    if(auto_color == 'multi' & all(col == '')){d$col = d$flag}

    # plot labeled points last
    d = d[order(d$flag),]
    i = is.na(d$col) | d$col == ''
    d = rbind(d[i,], d[!i,])

    if(unlab.grey == TRUE){d[d$lab == '',]$col = ''}

    p = ggplot(d)

    if(!is.null(edges)){p = p + geom_segment(data=edges, aes(x=x,y=y,xend=xend,yend=yend), color='black')}

    if(border == FALSE){
        p = p + geom_point(aes(x=x, y=y, col=col, size=size), alpha=alpha)
    } else {
        p = p + geom_point(aes(x=x, y=y, fill=col, size=size, stroke=ifelse(sig == TRUE, stroke, 0)), alpha=alpha, pch=21, colour=border)
    }
    p = p + geom_text_repel(data=d[(d$lab != '') | (1:nrow(d) %in% sample(1:nrow(d), min(nrow(d), 1000))),], aes(x=x, y=y, label=lab), size=lab.size, segment.color='grey') +
	theme_cowplot() + xlab(xlab) + ylab(ylab) + theme(legend.title=element_text(size=legend.fontsize), legend.text=element_text(size=legend.fontsize))

    if(all(size == 1)){p = p + scale_size(guide = 'none', range=c(min_size, max_size))} else {p = p + scale_size(name=size.title, range=c(min_size, max_size))}

    if(!is.null(xlim)){p = p + xlim(xlim)}
    if(!is.null(ylim)){p = p + ylim(ylim)}

    if(border == TRUE){
        if(!is.null(palette)){
            p = p + scale_fill_manual(name=col.title, values=palette, na.value=na.value, breaks=levels(as.factor(d$col)))
        } else {
            if(!is.numeric(d$col)){
	        p = p + scale_fill_manual(name=col.title, values=c('lightgrey', 'black', 'red', 'pink')) + theme(legend.position='none')
	    } else {
	        p = p + scale_fill_gradientn(name=col.title, colors=material.heat(100), na.value=na.value)
	    }
        }
    } else {
        if(!is.null(palette)){
            p = p + scale_color_manual(name=col.title, values=palette, na.value=na.value, breaks=levels(as.factor(d$col)))
        } else {
            if(!is.numeric(d$col)){
	        p = p + scale_color_manual(name=col.title, values=c('lightgrey', 'black', 'red', 'pink')) + theme(legend.position='none')
	    } else {
	        p = p + scale_color_gradientn(name=col.title, colors=material.heat(100), na.value=na.value)
	    }
        }
    }

    if(!is.null(out)){save_plot(plot=p, filename=out, nrow=nrow, ncol=ncol)}

    return(p)
}


#making a plot using R

#R --no-save << endip

#postscript(file="$3.ps", horizontal=FALSE,paper="letter",pointsize=10)
pdf(file="plots.pdf",width = 8, height = 11)
par(mfrow=c(3,2))

#=====================Monthly
inp <- read.table("MONTH")

num<-  inp[[1]]
round<-  inp[[2]]
step<- inp[[3]]
year<- inp[[4]]
mth<-  inp[[5]]
obs<-  inp[[6]]
sim<-  inp[[7]]

plot(mth[step==1][num==0],obs[step==1][num==0],type="l",lwd=4,col="black",xlab="All Months",ylab="Monthly Values",main="Solar Radiation",ylim=range(obs[step==1],sim[step==1]))
lines(mth[step==1][num==0],sim[step==1][num==0],type="l",lwd=2,col="cyan")

plot(mth[step==2][num==0],obs[step==2][num==0],type="l",lwd=4,col="black",xlab="All Months",ylab="Monthly Values",main="PET",ylim=range(obs[step==2],sim[step==2]))
lines(mth[step==2][num==0],sim[step==2][num==0],type="l",lwd=2,col="cyan")

plot (num[step==3][num>=1],obs[step==3][num>=1],type="l",lwd=4,col="black",xlab="Month",ylab="Monthly Values",main="Monthly" ,ylim=range(obs[step==3],sim[step==3]))
lines(num[step==3][num>=1],sim[step==3][num>=1],type="l",lwd=2,col="cyan")

#=====================Annual
inp <- read.table("ANNUAL")

round<-  inp[[1]]
step<- inp[[2]]
year<- inp[[3]]
obs<-  inp[[4]]
sim<-  inp[[5]]

plot (year[step==3][year>=1],obs[step==3][year>=1],type="l",lwd=4,col="black",xlab="Year",ylab="Annual Values",main="Annual",ylim=range(obs[step==3],sim[step==3]))
lines(year[step==3][year>=1],sim[step==3][year>=1],type="l",lwd=2,col="green")

#=====================Annual NS
inp <- read.table("NSyear")

round<-  inp[[1]]
step<- inp[[2]]
year<- inp[[3]]
ns<-   inp[[4]]

year<-year[ns>=-10]
step<-step[ns>=-10]
ns  <-  ns[ns>=-10]

plot(year[step==4],ns[step==4],type="p",lwd=7,col="red",xlab="Year",ylab="Nash Sutcliff",main="Nash Sutcliff")

boxplot(ns[step==4],col="red",xlab="All Years",ylab="Nash Sutcliff",main="Nash Sutcliff")

quit()
n
#endip

#gv $3.ps
#lpr -Pmargs NS$1_$1.ps
 #echo
 #echo Program has completed execution
 #echo


library(lubridate) #for date modifications
library(ggmap)
library(plotly)
library(VIM) #for aggr
library(dplyr) #for left join, count_,
library(DT) #for datatable
library(dbscan)
library(ggplot2)

#DATA FOR 2014

apr14 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-apr14.csv")
may14 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-may14.csv")
jun14 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-jun14.csv")
jul14 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-jul14.csv")
aug14 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-aug14.csv")
sep14 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-sep14.csv")

#### Bind all the files in one and then delete the individual files
apr_june14 <- bind_rows(apr14, may14, jun14)
july_sep14 <- bind_rows(jul14, aug14, sep14)
rm(apr14,may14,jun14,jul14,aug14,sep14)
gc()

#### Checking the data in the dataset
apr_june14 <- na.omit(apr_june14)
july_sep14 <- na.omit(july_sep14)
#summary(data_2014)
# #### Shows there are no more missing data (or na values)
# aggr(apr_june14)

#### Separate or mutate the Date/Time columns
#colnames(apr_june14)
colnames(apr_june14)[1] <- c("date_time")
colnames(july_sep14)[1] <- c("date_time")

# apr_june14$date_time <- mdy_hms(apr_june14$date_time)
# apr_june14$Day <- factor(day(apr_june14$date_time))
# apr_june14$Month <- factor(month(apr_june14$date_time))
# july_sep14$Month <- factor(month(july_sep14$date_time))
# apr_june14$Year <- factor(year(apr_june14$date_time))
# apr_june14$Weekday <- factor(wday(apr_june14$date_time))
# apr_june14$Hour <- factor(hour(apr_june14$date_time))
# apr_june14$Minute <- factor(minute(apr_june14$date_time))
# apr_june14$Second <- factor(second(apr_june14$date_time))

#### Plot the data of trips in NY city map
NYCMap <- get_map("New York", zoom = 10)
#ggmap(NYCMap) + geom_point(aes(x = Lon, y = Lat),data = data_2014)

test_april14 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-apr14.csv", nrows=10000)

## DATA ANALYSIS - MODEL 1

#### Making boroughs using DBSCAN
EPS <- 0.009
clusters_dbscan_train <- dbscan(select(test_april14, Lat, Lon), eps = EPS)
test_april14$cluster_db <- as.factor(clusters_dbscan_train$cluster)
groups <- test_april14 %>% filter(clusters_dbscan_train$cluster != 0)
noise_train <- test_april14 %>% filter(clusters_dbscan_train$cluster == 0)
noise_test <- july_sep14 %>% filter(clusters_dbscan_test$cluster == 0)

#### Making boroughs using DBSCAN
# EPS <- 0.2
# clusters_dbscan_train <- dbscan(select(apr_june14, Lat, Lon), eps = EPS)
# clusters_dbscan_test <- dbscan(select(july_sep14, Lat, Lon), eps = EPS)
# test_april14$cluster_db <- as.factor(clusters_dbscan$cluster)
# groups <- test_april14 %>% filter(clusters_dbscan$cluster != 0)
# noise_train <- apr_june14 %>% filter(clusters_dbscan_train$cluster == 0)
# noise_test <- july_sep14 %>% filter(clusters_dbscan_test$cluster == 0)

#### Making boroughs using KMeans
set.seed(20)
clusters_train <- kmeans(apr_june14[,2:3], 5)
clusters_test <- kmeans(july_sep14[,2:3], 5)
apr_june14$Borough <- as.factor(clusters_train$cluster)
july_sep14$Borough <- as.factor(clusters_test$cluster)

#### Making final data for 2014 to be used in Model 2
final_data14 <- bind_rows(apr_june14,july_sep14)
final_data14$date_time <- mdy_hms(final_data14$date_time)
final_data14$Month <- factor(month(final_data14$date_time))

#### Trying to plot the boroughs formed from KMean - Training Data
#ggplot(test_april14, aes(test_april14$Lon, test_april14$Lat, color = test_april14$cluster)) + geom_point()
ggmap(NYCMap) + geom_point(aes(x = Lon, y = Lat, colour = as.factor(Borough)),data = apr_june14) +
  #geom_point(aes(x = Lon, y = Lat, fill = "grey"), noise_train) +
  ggtitle("NYC Boroughs using KMean - Train")

#### Trying to plot the boroughs formed from KMean - Test Data
ggmap(NYCMap) + geom_point(aes(x = Lon, y = Lat, colour = as.factor(Borough)),data = july_sep14) +
  #geom_point(aes(x = Lon, y = Lat, fill = "grey"), noise_test) +
  ggtitle("NYC Boroughs using KMean - Test")

#### Trying to plot the boroughs formed from DBSCAN
ggmap(NYCMap) + geom_point(aes(x = Lon, y = Lat, colour = as.factor(cluster_db)),data = test_april14) +
  geom_point(aes(x = Lon, y = Lat, fill = "grey"), noise_train) +
  geom_point(aes(x = Lon, y = Lat, colour = as.factor(cluster_db)), groups)

#### Check the difference of number of rows between the orig table and after removing .na values
# data_2014_borough_omit = na.omit(data_2014_borough)
# outside_ny_pickup = nrow(data_2014_borough) - nrow(data_2014_borough_omit)
# outside_ny_pickup

## Data prepartion ends for 2014

## DATA FOR 2015
# Easier to work on 2015 data since it also have information about the Location Id rather than the longitude and latitude
# Even though the data is divided 50:50 according to the month, it's still a 40:60 distribution of trips.

# data_15 <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-janjune-15.csv")
#data_15_temp <- read.csv("/Users/Sejal/Desktop/DataAnalysis/uber-pickups-NYCity/uber-raw-data-janjune-15.csv", nrows=100000)
# na.omit(data_15)

#### Mapping the Borough acc to the Location ID from taxi_zone_lookup data
colnames(data_15_temp)[colnames(data_15_temp) == 'locationID'] <- "LocationID"
taxi_zone_lookup <- read.csv("https://s3.amazonaws.com/nyc-tlc/misc/taxi+_zone_lookup.csv")
final_data15 <- left_join(data_15, taxi_zone_lookup, by = c("locationID"="LocationID"))

#### Making Test Data and Training Data
##Only Month needed for now to divide the data.
##Also, rendering only the month and later other components of date is computationally efficient.
final_data15$Pickup_date <- ymd_hms(final_data15$Pickup_date)
final_data15$Month <- factor(month(final_data15$Pickup_date))

#Test data (January to March)
final_data15$Month <- as.numeric(as.character(final_data15$Month))

jan_mar15 <- filter(final_data15,final_data15$Month <= 3)
jan_mar15$Day <- factor(day(jan_mar15$Pickup_date))
jan_mar15$Year <- factor(year(jan_mar15$Pickup_date))
jan_mar15$Weekday <- factor(wday(jan_mar15$Pickup_date))
jan_mar15$Hour <- factor(hour(jan_mar15$Pickup_date))
jan_mar15$Minute <- factor(minute(jan_mar15$Pickup_date))
jan_mar15$Second <- factor(second(jan_mar15$Pickup_date))

#Training data (April to June)
apr_june15 <- filter(final_data15,final_data15$Month > 3)
apr_june15$Day <- factor(day(apr_june15$Pickup_date))
apr_june15$Year <- factor(year(apr_june15$Pickup_date))
apr_june15$Weekday <- factor(wday(apr_june15$Pickup_date))
apr_june15$Hour <- factor(hour(apr_june15$Pickup_date))
apr_june15$Minute <- factor(minute(apr_june15$Pickup_date))
apr_june15$Second <- factor(second(apr_june15$Pickup_date))

#rm(data_15,taxi_zone_lookup)
#rm(final_data15)

## Data preparation ends for 2015

## DATA ANALYSIS - MODEL 2
#### Number of Trips by month, Borough for 2014
final_data14$Month <- as.double(final_data14$Month)
month_borough_14 <- count_(final_data14, vars = c('Month', 'Borough'), sort = TRUE) %>%
  arrange(Month, Borough)
datatable(month_borough_14)

#### Number of Trips by month, Borough for 2015
month_borough_15 <- count_(final_data15, vars = c('Month', 'Borough'), sort = TRUE) %>%
  arrange(Month, Borough)
datatable(month_borough_15)

## Plots
## Monthly growth 2014
monthly_growth_all_14 <- month_borough_14 %>%
  mutate(Date = paste("04", Month)) %>%
  ggplot(aes(Month, n, colour = Borough)) + geom_line() +
  ggtitle("Uber Monthly Growth - 2014")
monthly_growth_all_14

## Monthly growth 2015
monthly_growth_all_15 <- month_borough_15 %>%
  filter(!(Borough %in% c ("EWR", "Unknown"))) %>%
  mutate(Date = paste("01", Month)) %>%
  ggplot(aes(Month, n, colour = Borough)) + geom_line() +
  ggtitle("Uber Monthly Growth - 2015")
monthly_growth_all_15

#### Changing names of columns so as to make names consistent between 2014 and 2015 data ####
## Might also delete columns + add columns
## NOTHING FOR NOW, ALREADY DONE EARLIER

## DATA ANALYSIS - MODEL 3

#### Model Deployment on Training Data
#### Number of Trips by Borough
trips_by_borough <- count_(jan_mar15, vars = "Borough", sort = TRUE)
#### Show in a table
datatable(trips_by_borough)

### Number of Trips by month, Borough
trips_by_month_borough <- count_(jan_mar15, vars = c('Month', 'Borough'), sort = TRUE) %>%
  arrange(Month, Borough)
datatable(trips_by_month_borough)

### Number of Trips by Weekday, Borough
##Sunday(1) - Saturday(7)
trips_by_weekday_borough <- count_(jan_mar15, vars = c('Weekday', 'Borough'), sort = TRUE) %>%
  arrange(Weekday, Borough)
datatable(trips_by_weekday_borough)

### Number of Trips by Weekday, Hour, Borough
trips_by_wd_hr_br <- count_(jan_mar15, vars = c('Hour', 'Weekday', 'Borough'), sort = TRUE) #%>%
#arrange(Weekday)
datatable(trips_by_wd_hr_br)

## Plots

## Rides by Borough and day
ggplot(jan_mar15) +
  geom_bar(aes(x=Weekday, fill=Borough),position="dodge") +
  ggtitle('Rides over the days by Borough') +
  xlab('Day of the Week') +
  ylab('Total Ride')

## Model 3 - Popular Destinations
## Home Destinations
train_Home_dest_weekday <- filter(jan_mar15, jan_mar15$Weekday %in% c(2,3,4,5) & jan_mar15$Hour %in% c(7,8,9,10)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(train_Home_dest_weekday)

## Brunch Destination Weekend
train_Brunch_dest_weekend <- filter(jan_mar15, jan_mar15$Weekday %in% c(1,6,7) & jan_mar15$Hour %in% c(11,12,13,14)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(train_Brunch_dest_weekend)

## Office/Return Destinations
train_Office_dest_weekday <- filter(jan_mar15, jan_mar15$Weekday %in% c(2,3,4,5) & jan_mar15$Hour %in% c(16,17,18,19)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(train_Office_dest_weekday)

## Party Destinations Weekend
train_Party_dest_weekend <- filter(jan_mar15, jan_mar15$Weekday %in% c(1,6,7) & jan_mar15$Hour %in% c(21,22,23,0,1)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(train_Party_dest_weekend)

## EVALUATIONS

# Con1: Top three most rides happen in: Manhattan > Brooklyn > Queens
# Con2: Top three popular Zone in the top three boroughs (through use of):
#       Return_dest_weekday, Party_dest_weekend, Brunch_dest_weekend and Office_dest_weekday.
# RESULT: Hence, given the borough, day of the week and time, we were able to identify the most popular pick-up destination.
# RESULT: These destination can be categorised as Office area, Brunch/party area, Residential Area accordingly.

## Deployment
#Checking the model against the apr_june15 data.

# Plots

## Rides by Borough and day
ggplot(apr_june15) +
  geom_bar(aes(x=Weekday, fill=Borough),position="dodge") +
  ggtitle('Rides over the days by Borough for Test Data') +
  xlab('Day of the Week') +
  ylab('Total Ride')

#Result1: Consistent with Con1.
# Top three most rides happen in: Manhattan > Brooklyn > Queens

## Model 3 DEPLOYMENT

## Home Destination Weekday morning
Home_dest_weekday_test <- filter(apr_june15, apr_june15$Weekday %in% c(2,3,4,5) & apr_june15$Hour %in% c(7,8,9,10)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(Home_dest_weekday_test)

## Brunch Destination Weekend morning
Brunch_dest_weekend_test <- filter(apr_june15, apr_june15$Weekday %in% c(1,6,7) & apr_june15$Hour %in% c(10,11,12,13)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(Brunch_dest_weekend_test)

## Office/Return Destinations Weekday evening
Office_dest_weekday_test <- filter(apr_june15, apr_june15$Weekday %in% c(2,3,4,5) & apr_june15$Hour %in% c(16,17,18,19)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(Office_dest_weekday_test)

## Party Destination Weekend night
Party_dest_weekend_test <- filter(apr_june15, apr_june15$Weekday %in% c(1,6,7) & apr_june15$Hour %in% c(22,23,12,1)) %>%
  count_(vars = c('Zone','Borough'),sort = TRUE)
datatable(Party_dest_weekend_test)


  # About ============================
  # @author: Adail Carvalho
  # @since : 2018-03-24
  # __________________________________

  #Required Libs ====
  checkAndInstallRequiredLib <- function(libname, extralib = NULL) {
    if (!require(libname)) {
      install.packages(libname)
    }

    if (!missing(extralib)) {
      if (!require(extralib)) {
        install.packages(extralib)
      }
    }
  }
  # Plotly: library that provides beaultiful chart tools.
  library(plotly)

  # Webshot: provides chart exports capabilities.
  library(webshot)

  # Matrices / DFrames headers ====
  modelHeader <- c("Coefficients", "Predictions", "RMSErrorRate", "Dataset", "YDependent", "XIndependent")
  lmHeader <- c("Observed Y","Predicted Y", "Residual E")

  #Error messages ====
  insuficientArgsException <- simpleError("Missing one or more required variables to proceed = ")
  insuficientArgsWarning <- "Missing one or more required variables to do the requested operation = "
  illegalArgsException <- simpleError("Invalid args: ")
  notSupportedException <- simpleError("Operation with the passed args are not supported yet.")

  # Main ====
  ' Entry point for our Linear Model program
   # input
   @filePath CSV file that represents the dataset
   @delimiter The CSV file delimiter (if its a TSV, then use "\t")
   @dependentVar Represents the Y column name in the dataset, where Y represents the dependent variable in the Linear Model.
        Colum Y must be numeric.
   @... Represents one or more datasets X columns names, where X represents the independent variables in the Linear Model.
        Columns X must be numerics.

   # returns
   @ model A List containing both Predictions and the Linear Model coefficients.
                 $Coefficients : list containing the values founded for the linear model coeficients
                 $Predictions  : matrix that shows the predicted values, the real values for Y and the E residuals
                 $RMSErrorRate : rating used to know how good our model is. A good model is always between -1< R <=1.
                 $Dataset: a matrix representation of the original dataset.
   # usage

   beearModel <- linearModel("C:/opt/beer_delivery.csv","\t", "Tempo", "NumCaixas", "Distancia")
   houses <- linearModel("C:/opt/houses_set.csv", ",", "SalePrice", "OverallQual", "YearBuilt", "MSSubClass", "BedroomAbvGr")

   # checking values

   houses$Coefficients
   houses$Predictions
  '
  linearModel <- function (filePath, delimiter, dependentVar, ...) {
    independentVarList <- list(...)

    if (is.null(dependentVar) || length(independentVarList) == 0) {
      stop(paste(insuficientArgsException, "{dependentVar, independentVarList}"))
    }

    matrixDataSet <- getFileToMatrix(filePath, delimiter)
    if (length(independentVarList) == 1) {
      model <- simpleLinearModel(matrixDataSet, dependentVar, independentVarList[[1]])
    } else {
      model <- multiLinearModel(matrixDataSet, dependentVar, independentVarList)
    }

    returnValue(model)
  }

  # Handle general operations to get the results
  # @returns results A list containing the coefficient values, RMSE error and the made predictions.
  simpleLinearModel <- function (matrixDataSet, dependentVar, independentVar) {
    if (!is.matrix(matrixDataSet)) {
      stop(illegalArgsException)
    }

    dependentIndex <- grep(dependentVar, colnames(matrixDataSet))
    independentIndex <- grep(independentVar, colnames(matrixDataSet))
    dependentVector <- matrixDataSet[,dependentIndex]
    independentVector <- matrixDataSet[,independentIndex]

    slope <- getSLRSlope(independentVector, dependentVector)
    intercept <- getSLRIntercept(independentVector, dependentVector, slope)

    resultModel <- doSimplePredictions(intercept, slope, independentVector, dependentVector)

    coefficientsMatrix <- matrix(nrow = 1, ncol = 2, dimnames = list(c(1),c("Intercept", independentVar)))
    coefficientsMatrix[,1] <- intercept
    coefficientsMatrix[,2] <- slope

    modelErrorRate <- estimateModelError(resultModel[,2])

    linearModel <- cbind(dependentVector,resultModel)
    colnames(linearModel) <- lmHeader

    # Gather generetade values
    model <- list(coefficientsMatrix, linearModel, modelErrorRate, matrixDataSet, dependentVar, independentVar)

    returnValue(model)
  }

  '
  Handle general operations to get the results
  @returns results A list containing the coefficient values, RMSE error and the made predictions.

  # Usage (directly)

  myModel <- multiLinearModel(dataMatrix, "Y var", as.list(c("var x1", "var x2", "var xn")))
  '
  multiLinearModel <- function (matrixDataSet, dependentVar, independentVarList) {
    if (!is.matrix(matrixDataSet)) {
      stop(illegalArgsException)
    }

    dependentColIndex <- grep(dependentVar, colnames(matrixDataSet))
    dependentMatrix <- matrixDataSet[,dependentColIndex]

    independentMatrix <- getIndependentVarsAsMatrix(matrixDataSet, independentVarList)

    levelsMatrix <- getRegressionLevelsMatrix(as.matrix(independentMatrix))

    xProductMatrix <- matrixTranposeAndMultiply(levelsMatrix, NULL)
    xProductMatrix <- getInverseMatrix(xProductMatrix)
    yProductMatrix <- matrixTranposeAndMultiply(levelsMatrix, as.matrix(dependentMatrix))

    coefficientsMatrix <- getMLRCoefficients(xProductMatrix, yProductMatrix, independentMatrix, independentVarList)

    resultModel <- doMultivariantPredictions(coefficientsMatrix, independentMatrix, dependentMatrix)

    modelErrorRate <- estimateModelError(resultModel[,2])

    linearModel <- cbind(dependentMatrix,resultModel)
    colnames(linearModel) <- lmHeader

    model <- list(coefficientsMatrix, linearModel, modelErrorRate, matrixDataSet, dependentVar, independentVarList)
    model <- handleDataHeaders(model, modelHeader)

    returnValue(model)
  }

  # Linear Model ====

  # Estimates the values for Y, using the calculated coefficients.
  # Apllies the following rule: ~Yi : B0 + (B1 * Xi)
  # Where ~Yi = estimated value for dependent value Y, B0 = Slope coefficient, B1 = Intercept coefficient, Xi = observed value for X,
  # and i, the iterator value over the X independent vector
  # returns a Matrix with the estimated values for Y and the residuals E, where E = real value of Y - estimated value for Y
  doSimplePredictions <- function(coefficientB0, coefficientB1, independentVector, dependentVector) {
    predictedY <- vector("numeric", length(dependentVector))
    residuals <- vector("numeric", length(independentVector))

    for (i in 1:length(independentVector)) {
      predictedY[i] <- coefficientB0 + (coefficientB1 * independentVector[i])
    }

    residualVector <- dependentVector - predictedY
    returnValue(cbind(predictedY, residualVector))
  }

  # Estimates the values for Y, using the calculated coefficients.
  # Apllies the following rule: ~Y : B0 + B1(X1 - ~X1) + B2(X2 - ~X2) + ... + Bn(Xn - ~Xn)
  # Where ~Y = estimated value for dependent value Y, Bi = Coeficient values, Xi = observed value for X, ~Xi = mean of X variable.
  # returns a Matrix with the estimated values for Y and the residuals E, where E = real value of Y - estimated value for Y
  doMultivariantPredictions <- function(coefficientsMatrix, independentMatrix, dependentMatrix = NULL) {
    predictedY <- matrix(0, nrow = nrow(independentMatrix), ncol = 1)
    residualMatrix <- matrix(0 , nrow = nrow(independentMatrix), ncol = 1)

    for (r in 1:nrow(independentMatrix)) {
      for (coe in 2:ncol(coefficientsMatrix)) {
        predictedY[r,1] <- predictedY[r,1] + (coefficientsMatrix[,coe] * independentMatrix[r,coe - 1])
      }
      predictedY[r,1] <- predictedY[r,1] + coefficientsMatrix[,1]
    }

    predictions <-NULL
    if (missing(dependentMatrix)) {
      predictions <- predictedY
    } else {
      residualMatrix <- dependentMatrix - predictedY
      predictions <- cbind(predictedY, residualMatrix)
    }

    returnValue(predictions)
  }

  # Matrices general operations ====
  getMLRCoefficients <- function(xProductMatrix, yProductMatrix, independentMatrix, xLabels) {
    avgIndMat <- colMeans(independentMatrix)

    coefficientsMatrix <- matrixMultiply(xProductMatrix, yProductMatrix)
    coefficientsMatrix <- t(coefficientsMatrix)
    slope <- coefficientsMatrix[,1]

    for(c in 2:ncol(coefficientsMatrix)) {
      slope <- slope + (coefficientsMatrix[,c] * (-avgIndMat[c - 1]))
    }
    coefficientsMatrix[,1] <- slope
    colnames(coefficientsMatrix) <-c("[Intercept]", xLabels)
    returnValue(coefficientsMatrix)

  }
  # Returns the (matriz)-¹ of a given matrix.
  # inv(x) is a funtion provided by the package matlib*
  getInverseMatrix <- function(matriz) {
    invertedMatrix <- solve(matriz)
    returnValue(invertedMatrix)
  }

  # Returns the mean of independent variables in multivariant linear model
  getRegressionLevelsMatrix <- function(matriz) {
    avgIndependentsVarMatrix <- t(as.matrix(colMeans(matriz)))
    levelsMatrix <- cbind(getX0Dimension(matriz), matriz)

    for (c in colnames(matriz)) {
      x <- matriz[,c]
      l <- vector(class(x), length(x))
      for (i in 1:length(x)) {
        l[i] <- x[i] - avgIndependentsVarMatrix[,c]
      }
      levelsMatrix[,c] <- l
    }
    returnValue(levelsMatrix)
  }

  # Represents the x0 coeficient in the lm equation, where x0 = 1. In the matrix of independent values, it is placed in the first column.
  getX0Dimension <- function(matriz) {
    numRows <- nrow(matriz)
    returnValue(matrix(rep(1, numRows), dimnames = list(c(1:numRows), c("X0"))))
  }

  # Return product of two matrices
  matrixMultiply <- function(matrixA, matrixB) {
    resultMatrix <- matrix(0, nrow = nrow(matrixA), ncol = ncol(matrixB))
    for (r in 1:nrow(matrixA)) {
      for (c in 1:ncol(matrixB)) {
        for (kol in 1:ncol(matrixA)) {
          resultMatrix[r,c] <- resultMatrix[r,c] + (matrixA[r,kol] * matrixB[kol, c])
        }
      }
    }

    returnValue(resultMatrix)

  }

  # Returns the product of matrices
  matrixTranposeAndMultiply <- function(matriz, matrixB) {
    transpMatrix <- t(matriz)

    if (is.null(matrixB)) {
      matrixY <- matriz
    } else {
      matrixY <- matrixB
    }

    returnValue(matrixMultiply(transpMatrix, matrixY))
  }

  # Linear Regression Rules Application ====
  # Estimate erros using RootMeanSquareError(RMSE).
  # @residualVector Vector that holds the E residuals of our model.
  estimateModelError <- function(residualVector) {
    rmse <- sqrt(sum(residualVector ** 2) / length(residualVector))
    returnValue(rmse)
  }

  # Returns SLR Slope value
  getSLRSlope <- function(independentVector, dependentVector) {
    levelsVectorX <- independentVector - mean(independentVector)
    levelsVectorY <- dependentVector - mean(dependentVector)

    numeratorB1 <- sum(levelsVectorX * levelsVectorY)
    denominatorB1 <- sum(levelsVectorX ** 2)
    slope <- numeratorB1 / denominatorB1

    returnValue(slope)
  }

  # Returns SLR Intercept value
  getSLRIntercept <- function (independentVector, dependentVector, slope) {
    intercept <- mean(dependentVector) - (slope * mean(independentVector))
    returnValue(intercept)
  }

  # Utils ====
  getIndependentVarsAsMatrix <- function(matrixData, independentVarList) {
    independentMatrix <- matrix(0, nrow = nrow(matrixData), ncol = length(independentVarList))
    colnames(independentMatrix) <- independentVarList

    for (i in independentVarList) {
      name <- grep(i, colnames(matrixData))
      independentMatrix[,i] <- matrixData[,name]
    }
    returnValue(independentMatrix)
  }

  getFileToMatrix <- function(filePath, delimiter) {
    rawDataSet <-  read.csv(filePath, sep = delimiter, header = TRUE)
    returnValue(data.matrix(rawDataSet))
  }

  ' Export charts as images.
   @p A chart object
   @filename Name of the file to be saved.
   @ext File extension
  '
  exportChartAsImg <- function(p, filename, ext) {
    export(p, paste(filename, ext))
  }

  handleDataHeaders <- function(data, header) {
    names(data) <- modelHeader
    returnValue(data)
  }

  # Charts ####
  # Add to a chart labels and title
  applyLayout <- function(p, xLabel, yLabel, chartTitle) {
    title <- NULL
    if (missing(chartTitle)) {
      title <- paste(yLabel, " by ", xLabel)
    } else {
      title <- chartTitle
    }

    p <- layout(p, title = title,
                xaxis = list(title = xLabel),
                yaxis = list (title = yLabel))
    returnValue(p)

  }

  'Export models as simple X vs Y line charts, from a given model.
  @ model A LinearRegressor object.
  @ dirToSave The directory where the plots will be exported
  '
  createChartsFromModel <- function(model, dirToSave = NULL) {
    for (x in model$XIndependent) {
      if (isTRUE(grepl('^[0-9]', x))) {
        x <- paste("X", x, sep = "")
      }

      print(paste("Generating chart for => ", x))

      p <- lmYXLineChart(model$Dataset[,x],
                         model$Dataset[,model$YDependent],
                         model$Predictions[,"Predicted Y"],
                         model$Predictions[,"Residual E"],
                         x,
                         model$YDependent)

      exportChartAsImg(p, paste(dirToSave, model$YDependent, " by ", x), ".png")
    }
  }

  # Creates a line chart, by ploting y in the y axis and x in the x axis.
  # lmYXLineChart(TipoMoradores, PrecoVenda, PrecoPrevisto, ResiduoModelo, "TipoMoradores", "PrecoVenda")
  lmYXLineChart <- function(xData, yData, yPredicted, eResid, xLabel, yLabel) {
    xName <- xLabel
    yName <- yLabel
    if (missing(xName)) {
      xName <- "X"
    }

    if (missing(yName)) {
      yName <- "Y"
    }

    chartFrame <- data.frame(xData, yData, yPredicted, eResid)
    aggData <- aggregate(chartFrame, by = list(chartFrame$xData), FUN = mean)

    lmPlot<- plot_ly(aggData, x = ~aggData$xData, name = xName)

    lmPlot <- add_trace(lmPlot, y= ~aggData$yData, name = yName, type = 'scatter', mode = 'lines')
    lmPlot <- add_trace(lmPlot, y = ~aggData$yPredicted, name = paste(yName, "(Pred)"), type = 'scatter', mode = 'lines')
    lmPlot <- add_trace(lmPlot, y = ~aggData$eResid, name = 'Residual', type = 'scatter', mode = 'markers')

    lmPlot <- applyLayout(lmPlot, xName, yName)
    returnValue(lmPlot)

  }


# have all phylogenies in one file
# have a file with the chromosome and window for each tree in the correct order
# have a popmap with the individual names and groupings wished to test
# have the outgroup labeled once in the popmap as "outgroup"

library(ape)
library(phytools)

options(scipen=999)

# read in trees, info, and popmap for 50kbp trees
x_trees <- read.tree("certhia_50kbp.trees")
x_info <- read.table("certhia_50kbp_tree_info.txt", sep="\t", stringsAsFactors=F)
x_popmap <- read.table("gsi_popmap.txt", sep="\t", stringsAsFactors=F)
x_output <- "b_gsi_50kbp_output.txt"

# define outgroup
outgroup <- x_popmap[x_popmap[,2] == "outgroup", 1]

# remove outgroup from popmap
x_popmap <- x_popmap[x_popmap[,2] != "outgroup", ]

# write initial line of output
write(c("chr", "start", "end", "pop", "gsi"), file=x_output, sep="\t", ncolumns=5)

# loop for each tree
for(a in 1:length(x_trees)) {
	# select the tree
	x <- x_trees[a][[1]]
	# reroot
	x <- midpoint.root(x)
	x <- root(x, outgroup, resolve.root=T)

	# define the groups
	groups <- unique(x_popmap[,2])

	# loop for each group of interest
	for(g in 1:length(groups)) {
		# define the group of interest
		group_of_interest <- x_popmap[x_popmap[,2] == groups[g],1]

		# calculate MRCA of group of interest
		group_mrca <- getMRCA(x, tip = group_of_interest)

		# calculate number of ndoes to reach common ancestor for each individual in group
		# and then remove redundant nodes
		nodes_needed <- c()
		for(b in 1:length(group_of_interest)) {
			# what is the number of this individual?
			b_number <- match(group_of_interest[b], x$tip.label)

			# loop throup edge table until reaching MRCA
			while_loop <- 0
			while(while_loop != group_mrca) {
				# add node
				nodes_needed <- c(nodes_needed, x$edge[x$edge[,2]==b_number,1])

				# change new number to that node and update the while_loop object to the node
				b_number <- x$edge[x$edge[,2]==b_number,1]
				while_loop <- b_number
			}
			# add the MRCA to the nodes_needed object
			nodes_needed <- c(nodes_needed, group_mrca)

			# only keep unique nodes
			nodes_needed <- unique(nodes_needed)
		}

		# calculate gsi

		# gs
		gs <- (length(group_of_interest) - 1) / length(nodes_needed)

		# max gs = 1
		max_gs <- 1

		# min gs = minimum number of nodes to connect all individuals (n - 1) / total number of nodes
		min_gs <- (length(group_of_interest) - 1) / length(unique(x$edge[,1]))

		# equation 4 of Cummings et al. 2008 (GSI paper)
		gsi <- (gs  - min_gs) / (max_gs - min_gs)

		# write output
		write(c(x_info[a,1], x_info[a,2], x_info[a,3], groups[g], gsi), file=x_output, sep="\t", ncolumns=5, append=T)
	}
}

# read in trees, info, and popmap for 100kbp trees
x_trees <- read.tree("certhia_100kbp.trees")
x_info <- read.table("certhia_100kbp_tree_info.txt", sep="\t", stringsAsFactors=F)
x_popmap <- read.table("gsi_popmap.txt", sep="\t", stringsAsFactors=F)
x_output <- "b_gsi_100kbp_output.txt"

# define outgroup
outgroup <- x_popmap[x_popmap[,2] == "outgroup", 1]

# remove outgroup from popmap
x_popmap <- x_popmap[x_popmap[,2] != "outgroup", ]

# write initial line of output
write(c("chr", "start", "end", "pop", "gsi"), file=x_output, sep="\t", ncolumns=5)

# loop for each tree
for(a in 1:length(x_trees)) {
	# select the tree
	x <- x_trees[a][[1]]
	# reroot
	x <- midpoint.root(x)
	x <- root(x, outgroup, resolve.root=T)

	# define the groups
	groups <- unique(x_popmap[,2])

	# loop for each group of interest
	for(g in 1:length(groups)) {
		# define the group of interest
		group_of_interest <- x_popmap[x_popmap[,2] == groups[g],1]

		# calculate MRCA of group of interest
		group_mrca <- getMRCA(x, tip = group_of_interest)

		# calculate number of ndoes to reach common ancestor for each individual in group
		# and then remove redundant nodes
		nodes_needed <- c()
		for(b in 1:length(group_of_interest)) {
			# what is the number of this individual?
			b_number <- match(group_of_interest[b], x$tip.label)

			# loop throup edge table until reaching MRCA
			while_loop <- 0
			while(while_loop != group_mrca) {
				# add node
				nodes_needed <- c(nodes_needed, x$edge[x$edge[,2]==b_number,1])

				# change new number to that node and update the while_loop object to the node
				b_number <- x$edge[x$edge[,2]==b_number,1]
				while_loop <- b_number
			}
			# add the MRCA to the nodes_needed object
			nodes_needed <- c(nodes_needed, group_mrca)

			# only keep unique nodes
			nodes_needed <- unique(nodes_needed)
		}

		# calculate gsi

		# gs
		gs <- (length(group_of_interest) - 1) / length(nodes_needed)

		# max gs = 1
		max_gs <- 1

		# min gs = minimum number of nodes to connect all individuals (n - 1) / total number of nodes
		min_gs <- (length(group_of_interest) - 1) / length(unique(x$edge[,1]))

		# equation 4 of Cummings et al. 2008 (GSI paper)
		gsi <- (gs  - min_gs) / (max_gs - min_gs)

		# write output
		write(c(x_info[a,1], x_info[a,2], x_info[a,3], groups[g], gsi), file=x_output, sep="\t", ncolumns=5, append=T)
	}
}


#===============================================================
# Combine the lists of retweets from earlier with the ideology
# estimates we just created. Use these to generate heatmaps
# of the ideology pairs of the retweet network for each day.
#
# Assumptions
#  - Retweets are stored in retweets_lists/
#  - Estimates are stored in estimates.Rdata
#  - Output folder plots/ exists
#===============================================================

library(reshape2)
library(ggplot2)

#===============================================================
# FORMAT_DATA: creates pairwise counts matrix of ideology pairs
# for original author and retweeter, then coerce them into a
# shape that is conducive to plotting later, and transform to
# proportions.
#===============================================================

format_data <- function(results, bin_size = 0.25) {
    # Axes will be ideologies
    retweeter <- results$ideology_retweeter
    retweeted <- results$ideology_retweeted

    # Round ideologies to the nearest multiple of bin_size
    retweeter <- round(retweeter / bin_size, 0) * bin_size
    retweeted <- round(retweeted / bin_size, 0) * bin_size

    # Construct table (does pairwise counts), then collapse into single column
    t <- table(retweeter, retweeted)
    t <- melt(t)

    # Add proportions to table
    t$prop <- t$value / sum(t$value)

    return(t)
}

#===============================================================
# CREATE HEATMAPS
# For each day of data, create a heatmap of the ideology pairs
# described above. To do this, we combine the retweets extracted
# ages ago with the estimates. The combined file is saved to
# an Rdata to save future time.
#===============================================================

load("estimates.Rdata")
estimates <- estimates[, c("id", "ideology")]

files <- list.files("retweet_lists/", full.names = TRUE)

# Last file doesn't have enough data
for (i in 1 : (length(files) - 1)) {
    retweets <- read.csv(files[i], header = FALSE,
                         col.names = c("date", "retweeter", "rewtweeted"))

    # Columns of retweets are "date" "retweeter" "retweeted", in that order.
    # We need to merge with the ideology estimates.

    # Set ID to retweeter, then join with the estimates, then reset names
    # Note that the column positions change on the join. It is unclear why.
    names(retweets)[2] <- "id"
    retweets <- merge(retweets, estimates, by = "id")
    names(retweets)[1] <- "retweeter"
    names(retweets)[4] <- "ideology_retweeter"

    # Next, set ID to retweeted, then join with the estimates, then reset names
    names(retweets)[3] <- "id"
    retweets <- merge(retweets, estimates, by = "id")
    names(retweets)[1] <- "retweeted"
    names(retweets)[5] <- "ideology_retweeted"

    # Save retweets + estimates dataframe for later (it is costly to compute)
    date <- as.character(retweets[1, 3])
    fname <- paste("retweet_estimates/", date, ".Rdata", sep = "")
    save(retweets, file = fname)

    # Construct heatmap -- a great deal of this plot function is credited to
    # the original authors, and the rest to StackOverflow and ggplot2 docs.
    rt_table <- format_data(retweets)

    # Format date as, e.g., "May 12," for the title of the plot
    date <- as.character(retweets[1, 3])
    date_name <- strftime(strptime(date, "%Y_%m_%d"), "%B %d")
    plt_title <- paste("Retweet Polarization on", date_name)

    plt <- ggplot(rt_table, aes(x=retweeted, y=retweeter)) +
           geom_raster(aes(fill=prop), color="white") +
           scale_y_continuous(limits=c(-3,3), expand=c(0,0)) +
           scale_x_continuous(limits=c(-3,3), expand=c(0,0)) +
           scale_fill_gradient(low="white", high="black", name="Proportion\nof tweets",
                               limits=c(0, 0.05), breaks=seq(0, 0.05, by=0.01)) +
           theme(panel.background = element_rect(fill="white"),
                 panel.border = element_rect(fill=NA)) +
           labs(x="Ideology Estimate for Original Author",
                y="Ideology Estimate for Retweeter",
                title=plt_title)

    # Save plot
    fname = paste("plots/heatmap_", date, ".png", sep="")
    ggsave(filename = fname, plot = plt, width=4, height=4)
}


\name{joint_estimate}
\alias{joint_estimate}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
 Joint inference of attachment function and node fitnesses
}
\description{
  This function jointly estimates the attachment function \eqn{A_k} and node fitnesses \eqn{\eta_i}. It first performs a cross-validation to select the optimal parameters \eqn{r} and \eqn{s}, then estimates \eqn{A_k} and \eqn{eta_i} using that optimal pair with the full data (Ref. 2).
}
\usage{
joint_estimate(net_object                               ,
              net_stat      = get_statistics(net_object),
              p             = 0.75                      ,
              stop_cond     = 10^-8                     ,
              mode_reg_A    = 0                         ,
              ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{net_object}{
    an object of class \code{PAFit_net} that contains the network.
  }
  \item{net_stat}{
    An object of class \code{PAFit_data} which contains summarized statistics needed in estimation. This object is created by the function \code{\link{get_statistics}}. The default value is \code{get_statistics(net_object)}.
  }
\item{p}{Numeric. This is the ratio of the number of new edges in the learning data to that of the full data. The data is then divided into two parts: learning data and testing data based on \code{p}. The learning data is used to learn the node fitnesses and the testing data is then used in cross-validation. Default value is \code{0.75}.}
\item{stop_cond}{Numeric. The iterative algorithm stops when \eqn{abs(h(ii) - h(ii + 1)) / (abs(h(ii)) + 1) < stop.cond} where \eqn{h(ii)} is the value of the objective function at iteration \eqn{ii}. We recommend to choose \code{stop.cond} at most equal to \eqn{10^(- number of digits of h - 2)}, in order to ensure that when the algorithm stops, the increase in posterior probability is less than 1\% of the current posterior probability. Default is \code{10^-8}. This threshold is good enough for most applications.}

\item{mode_reg_A}{Binary. Indicates which regularization term is used for \eqn{A_k}:
\itemize{
\item \code{0}: This is the regularization term used in Ref. 1 and 2.  Please refer to Eq. (4) in the tutorial for the definition of the term. It approximately enforces the power-law form \eqn{A_k = k^\alpha}. This is the default value.
\item \code{1}: Unlike the default, this regularization term exactly enforces the functional form \eqn{A_k = k^\alpha}. Please refer to Eq. (6) in the tutorial for the definition of the term. Its main drawback is it is significantly slower to converge, while its gain over the default one is marginal in most cases.
}
}
  \item{\dots}{
    %%     ~~Describe \code{\dots} here~~
  }
}

\value{
  Outputs a \code{Full_PAFit_result} object, which is a list containing the following fields:
  \itemize{
    \item \code{cv_data}: a \code{CV_Data} object which contains the cross-validation data. This is the testing data.

    \item \code{cv_result}: a \code{CV_Result} object which contains the cross-validation result. Normally the user does not need to pay attention to this data.

    \item \code{estimate_result}: this is a \code{PAFit_result} object which contains the estimated attachment function \eqn{A_k}, the estimated fitnesses \eqn{\eta_i} and their confidence intervals. In particular, the important fields are:
    \itemize{
    \item \code{ratio}: this is the selected value for the hyper-parameter \eqn{r}.
    \item \code{shape}: this is the selected value for the hyper-parameter \eqn{s}.
    \item \code{k} and \code{A}: a degree vector and the estimated PA function.
    \item \code{var_A}: the estimated variance of \eqn{A}.
    \item \code{var_logA}: the estimated variance of \eqn{log A}.
    \item \code{upper_A}: the upper value of the interval of two standard deviations around \eqn{A}.
    \item \code{lower_A}: the lower value of the interval of two standard deviations around \eqn{A}.

    \item \code{center_k} and \code{theta}: when we perform binning, these are the centers of the bins and the estimated PA values for those bins. \code{theta} is similar to \code{A} but with duplicated values removed.
     \item \code{var_bin}: the variance of \code{theta}. Same as \code{var_A} but with duplicated values removed.
    \item \code{upper_bin}: the upper value of the interval of two standard deviations around \code{theta}. Same as \code{upper_A} but with duplicated values removed.
    \item \code{lower_bin}: the lower value of the interval of two standard deviations around \code{theta}. Same as \code{lower_A} but with duplicated values removed.
    \item \code{g}: the number of bins used.
    \item \code{alpha} and \code{ci}: \code{alpha} is the estimated attachment exponent \eqn{\alpha} (when assume \eqn{A_k = k^\alpha}), while \code{ci} is the confidence interval.
    \item \code{loglinear_fit}: this is the fitting result when we estimate \eqn{\alpha}.
    \item \code{f}: the estimated node fitnesses.
    \item \code{var_f}: the estimated variance of \eqn{\eta_i}.
    \item \code{upper_f}: the estimated upper value of the interval of two standard deviations around \eqn{\eta_i}.
    \item \code{lower_f}: the estimated lower value of the interval of two standard deviations around \eqn{\eta_i}.
    \item \code{objective_value}: values of the objective function over iterations in the final run with the full data.
    \item \code{diverge_zero}: logical value indicates whether the algorithm diverged in the final run with the full data.
}
\item \code{contribution}: a list containing an estimate of the contributions of preferential attachment and fitness mechanisms in the growth process of the network. The calculation adapts a quantification method proposed in Section 3 of Ref. 4, which is for preferential attachment and transitivity, to preferential attachment and fitness.
\itemize{
\item \code{PA_contribution}: an array containing the contributions of preferential attachment at each time-step
\item \code{fit_contribution}: an array containing the contributions of the fitness mechanism at each time-step
\item \code{mean_PA_contrib}: the average contribution of preferential attachment through the whole growth process
\item \code{mean_fit_contrib}: the average contribution of the fitness mechanism through the whole growth process}
}
}
\author{
  Thong Pham \email{thongphamthe@gmail.com}
}
\references{
  1. Pham, T., Sheridan, P. & Shimodaira, H. (2015). PAFit: A Statistical Method for Measuring Preferential Attachment in Temporal Complex Networks. PLoS ONE 10(9): e0137796. (\doi{10.1371/journal.pone.0137796}).

  2. Pham, T., Sheridan, P. & Shimodaira, H. (2016). Joint Estimation of Preferential Attachment and Node Fitness in Growing Complex Networks. Scientific Reports 6, Article number: 32558. (\doi{10.1038/srep32558}).

 3. Pham, T., Sheridan, P. & Shimodaira, H. (2020). PAFit: An R Package for the Non-Parametric Estimation of Preferential Attachment and Node Fitness in Temporal Complex Networks. Journal of Statistical Software 92 (3). (\doi{10.18637/jss.v092.i03}).

4. Inoue, M., Pham, T. & Shimodaira, H. (2020). Joint Estimation of Non-parametric Transitivity and Preferential Attachment Functions in Scientific Co-authorship Networks. Journal of Informetrics 14(3). (\doi{10.1016/j.joi.2020.101042}).
}
\seealso{
  See \code{\link{get_statistics}} for how to create summarized statistics needed in this function.

  See \code{\link{Jeong}}, \code{\link{Newman}} and \code{\link{only_A_estimate}} for functions to estimate the attachment function in isolation.

    See \code{\link{only_F_estimate}} for a function to estimate node fitnesses in isolation.
}

\examples{
\dontrun{

  library("PAFit")
  #### Example 1: a linear preferential attachment kernel, i.e., A_k = k ############
  set.seed(1)
  # size of initial network = 100
  # number of new nodes at each time-step = 100
  # Ak = k; inverse variance of the distribution of node fitnesse = 5
  net        <- generate_BB(N        = 1000 , m             = 50 ,
                            num_seed = 100  , multiple_node = 100,
                            s        = 5)
  net_stats  <- get_statistics(net)

  # Joint estimation of attachment function Ak and node fitness
  result     <- joint_estimate(net, net_stats)

  summary(result)

  # plot the estimated attachment function
  true_A     <- pmax(result$estimate_result$center_k,1) # true function
  plot(result , net_stats, max_A = max(true_A,result$estimate_result$theta))
  lines(result$estimate_result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")

  # plot the estimated node fitnesses and true node fitnesses
  plot(result, net_stats, true = net$fitness, plot = "true_f")

  #############################################################################
  #### Example 2: a non-log-linear preferential attachment kernel ############
  set.seed(1)
  # size of initial network = 100
  # number of new nodes at each time-step = 100
  # A_k = alpha* log (max(k,1))^beta + 1, with alpha = 2, and beta = 2
  # inverse variance of the distribution of node fitnesse = 10
  net        <- generate_net(N       = 1000 , m             = 50 ,
                            num_seed = 100  , multiple_node = 100,
                            s        = 10   , mode = 3, alpha = 2, beta = 2)
  net_stats  <- get_statistics(net)

  # Joint estimation of attachment function Ak and node fitness
  result     <- joint_estimate(net, net_stats)

  summary(result)

  # plot the estimated attachment function
  true_A     <- 2 * log(pmax(result$estimate_result$center_k,1))^2 + 1 # true function
  plot(result , net_stats, max_A = max(true_A,result$estimate_result$theta))
  lines(result$estimate_result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")

  # plot the estimated node fitnesses and true node fitnesses
  plot(result, net_stats, true = net$fitness, plot = "true_f")
  #############################################################################
  #### Example 3: another non-log-linear preferential attachment kernel ############
  set.seed(1)
  # size of initial network = 100
  # number of new nodes at each time-step = 100
  # A_k = min(max(k,1),sat_at)^alpha, with alpha = 1, and sat_at = 100
  # inverse variance of the distribution of node fitnesse = 10
  net        <- generate_net(N       = 1000 , m             = 50 ,
                            num_seed = 100  , multiple_node = 100,
                            s        = 10   , mode = 2, alpha = 1, sat_at = 100)
  net_stats  <- get_statistics(net)

  # Joint estimation of attachment function Ak and node fitness
  result     <- joint_estimate(net, net_stats)

  summary(result)

  # plot the estimated attachment function
  true_A     <- pmin(pmax(result$estimate_result$center_k,1),100)^1 # true function
  plot(result , net_stats, max_A = max(true_A,result$estimate_result$theta))
  lines(result$estimate_result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")

  # plot the estimated node fitnesses and true node fitnesses
  plot(result, net_stats, true = net$fitness, plot = "true_f")
  }
}

\concept{preferential attachment}
\concept{attachment function}
\concept{fitness}


#install libraries
install.packages("RODBC")
install.packages("e1071")
install.packages("class")
install.packages("useful")

#import needed libraries
library("RODBC")
library("e1071")
library("class")
library("useful")

# create an ODBC connection to SQL Server
conn = odbcConnect("DataSets", "dm", "Passw0rd!")

# get dbo.Iris table
iris = sqlFetch(conn, "dbo.Iris")

# show iris data type
class(iris)

# count rows
nrow(iris)

# count columns
ncol(iris)

# show first rows
head(iris)

# ways to get a column (vector)
head(iris$petal_length_in_cm)
head(iris[[4]])
head(iris[,4])

# get a data frame slice
# for columns
head(iris[4])
head(iris[4:5])
head(iris[-4])
head(iris["petal_length_in_cm"])
head(iris[c("petal_length_in_cm", "petal_width_in_cm")])

# get a data frame slice
# for rows
head(iris[2,])
head(iris["10",])

# get a single "cell"
iris[[1,2]]

# filter rows using a "logical index vector"
IS = iris$class == "Iris-setosa"
nrow(iris[IS,])

# plot some data
BG = c("red", "green", "blue")
plot(iris$petal_length_in_cm, iris$petal_width_in_cm, bg=BG[unclass(iris$class)], pch=21)
plot(iris$sepal_length_in_cm , iris$sepal_width_in_cm, bg=BG[unclass(iris$class)], pch=21)
plot(iris[2:5], bg=BG[unclass(iris$class)], pch=21)

# what about correlation between columns?
cor(iris["petal_length_in_cm"], iris["sepal_length_in_cm"], method="pearson")

# define a functio to calculate Pearson Coefficient
panel.pearson = function(x, y, ...)
{
  horizontal = (par("usr")[1] + par("usr")[2]) / 2;
  vertical = (par("usr")[3] + par("usr")[4]) / 2;
  text(horizontal, vertical, format(abs(cor(x,y,method="pearson")), digits=2))
}

pairs(iris[2:5], bg=c("red", "green", "blue")[unclass(iris$class)], pch=21, upper.panel=panel.pearson)

#
# Test Supervised Machine Learning
#

# create test and train indexes
train.index = sample(nrow(iris), ceiling(nrow(iris) * 0.7))
test.index = (1:nrow(iris))[-train.index]

plot(iris[train.index,2:5], bg=BG[unclass(iris[train.index,]$class)], pch=21)
plot(iris[test.index,2:5], bg=BG[unclass(iris[test.index,]$class)], pch=21)

# create a naive-bayes classifier
nbc = naiveBayes(iris[train.index,2:5], iris[train.index,6])

# test classifier
confusion.matrix = table(predict(nbc, iris[test.index,-6]), iris[test.index,6], dnn=list('predicted','actual'))
confusion.matrix

# accuracy
sum(diag(confusion.matrix)) / sum(confusion.matrix)

# manual test / sample usage
iris.new = iris[1,]
iris.new[1,] = c(900, 5.2, 3.7, 1.6, 0.6, NA)
iris.new[2,] = c(901, 5.5, 2.5, 2.5, 2, NA)
iris.new[3,] = c(902, 6.0, 3.4, 5.8, 2, NA)

iris.new
plot(iris.new[2:5], bg=BG[unclass(iris.new$class)], pch=21)

# plot new and old values
iris.union = rbind(iris, iris.new)
plot(iris.union[2:5], bg=BG[unclass(iris.union$class)], pch=21)

# predict
predict(nbc, iris.new[,-6], type="raw")
predict(nbc, iris.new[,-6])
nbc

#
# Test unsupervised machine learning
#
iris.km = iris[2:5]
iris.km
pairs(iris.km)
plot(iris.km$sepal_width_in_cm, iris.km$sepal_length_in_cm)

km = kmeans(iris.km, 3)
km

table(iris$class, km$cluster)

pairs(iris.km, bg=BG[as.vector(km$cluster)], pch=21)


# Boxplot for selected GEO samples
source("http://www.bioconductor.org/biocLite.R")
library("Biobase")
library("GEOquery")
library("scales")

# load series and platform data from GEO
setwd("~/work/abe516/project1")
gset <- getGEO("GSE95636", GSEMatrix = TRUE, getGPL = FALSE, destdir = getwd())
if (length(gset) > 1) idx <- grep("GPL200", attr(gset, "names")) else idx <- 1
gset <- gset[[idx]]

# group names for all samples in a series
groups     = paste0("G", unlist(strsplit("3311100022233", '')))
ex         = exprs(gset)[, order(groups)] # order samples by group
fl         = as.factor(sort(groups))
labels     = c("E_faecalis", "B_subtilis", "E_faecium", "Control")
num_groups = len(labels)

palette(brewer_pal(type = "seq", palette = "Set2")(num_groups))
dev.new(width = 4 + dim(gset)[[2]]/5, height = 6)
par(mar = c(2 + round(max(nchar(sampleNames(gset))) / 2), 4, 2, 1))
title <- paste ("GSE95636", '/', annotation(gset), " selected samples", sep ='')
boxplot(ex,
        boxwex  = 0.6,
        notch   = TRUE,
        main    = title,
        outline = FALSE,
        las     = 2,
        col     = fl)
legend("topleft", labels, fill = palette(), bty="n")


# Testing dataset
setwd("C://Users//nan66//Google Drive//stt864//Project")
set.seed(52871775)
SubTestRlt<-TestResults
TestResults<-read.csv("Test_Results_Flint_513922_7.csv",head=T)

# modify the form of date
SubTestRlt[,2]<-as.Date(SubTestRlt[,2],format="%m/%d/%Y")
Startdate<-as.Date("2015-09-03",format="%Y-%m-%d")
DateDiff<-as.numeric(SubTestRlt[,2]-Startdate)
SubTestRlt<-data.frame(SubTestRlt,DateDiff)

# plot the original data
plot(SubTestRlt[,11],SubTestRlt[,4],xlab="Days",ylab="Pb")
plot(SubTestRlt[,11],SubTestRlt[,6],xlab="Days",ylab="Cu")

# remove samples which were not collected from flint
SubTestRlt<-SubTestRlt[SubTestRlt[,9]=="FLINT",]

# optional: remove the date before /after 120
SubTestRlt<-SubTestRlt[SubTestRlt[,11]>120,]
SubTestRlt<-SubTestRlt[SubTestRlt[,11]<=120,]

# remove the outlier of Pb level
SubTestRlt<-SubTestRlt[order(SubTestRlt[,4]),]
SubTestRlt<-SubTestRlt[1:(nrow(SubTestRlt)-2),]
SubTestRlt<-SubTestRlt[SubTestRlt[,4]<200,]

#  extract and transform variables
rTime<-SubTestRlt[,11]
rRespPb<-unlist(SubTestRlt[,4])
rRespCu<-unlist(SubTestRlt[,6])
plot(rTime,rRespPb)
plot(rTime,rRespCu)

#residregPb<-rRespPb-(coef(regPb)[1]+coef(regPb)[2]*(rTime^2))
plot(rTime,residregPb)
residnregPb<-rRespPb-coef(regPb)[1]*exp(-coef(regPb)[2]*rTime)
predict<-coef(regPb)[1]*exp(-coef(regPb)[2]*rTime)
plot(rTime,residnregPb)


library(RColorBrewer)#展示颜色版
display.brewer.all()#提取颜色条
cols<-brewer.pal(n=11,name='Grevs')#n为提取颜色数量
pie(rep(1,11),col=cols,labers='',border=NA)#制作任意数量的颜色条
my.colorbar<-colorRampPalette(colors=cols)#my.colorbar是一个函数
cols2<-my.colorbar(500)
pie(rep(1,500),col=cols2,labels='',border=NA)

#统计每年中雨、大雨、暴雨和大暴雨的天数（条形图
library(tidyverse)
path<-paste('D:\\observed station data\\daily precipitation\\data\\','58519.csv',sep='')
prcp<-read.csv(file=path,header=TRUE,stringsAsFactors = FALSE)
year<-str_sub(string=prcp$date,start=1,end=4)
year<-as.numeric(year)
year.unique<-unique(year)[-1]#去掉数据不完整的第一年
year.unique
counts<-sapply(X=year.unique,FUN=function(x){#将每一行作为变量
  ind<-which(year==x)
  group<-cut(prcp$precip[ind],breaks=c(10,24.9,49.9,100,10000),
             include.lowest = TRUE,labels=c('moderate','big','heavy','storm'))
  nums<-table(group)
  nums
})
counts
counts<-t(counts)#矩阵转置
storm<-data.frame(year=year.unique,counts)

#单变量
ggplot(data=storm[1:10,],mapping=aes(x=year,y=moderate))+
  geom_bar(stat='identity',fill=brewer.pal(9,'Set1')[3],
           colour=brewer.pal(9,'Set1')[2],lwd=1.5)
#mapping为映射，fill为条形图内部区域颜色，colour为条形图边框颜色，lwd为线宽度

#双变量
storm2<-data.frame(year=rep(x=storm$year[1:10],times=2),
                   counts=c(storm$moderate[1:10],storm$big[1:10]),
                   types=rep(c('moderate','big'),each=10))
ggplot(data=storm2,mapping=aes(x=year,y=counts,fill=types))+
  geom_bar(stat='identity',position='stack',width=0.6)+
  scale_fill_brewer(palette='Set2')
#scale_fill_brewer:属于标度，控制颜色条
#position:控制是否分列（stack,dodge）

#折线图:单变量
ggplot(data=storm,mapping=aes(x=year,y=moderate))+
  geom_line()
ggplot(data=storm,mapping=aes(x=year,y=moderate))+
  geom_line()+geom_point()

#折线图：双变量
storm3<-gather(data=storm[,1:3],key='group',value='counts',-year)
ggplot(data=storm3,
       mapping=aes(x=year,y=counts,group=group,color=group))+
  geom_line()+geom_point(size=2,shape=21)
?(gather)


CB<-function(x){
  BA<-get(EQ1[as.integer(x[["EQ"]])])(as.numeric(x[["Dens..g.cm3."]]),
  as.numeric(x[["D...cm."]]),
  as.numeric(x[["Alt"]]),
  as.numeric(x[["AB"]]))
  return(BA)
}
DT1$BAKg<-apply(DT1,1,CB)
print(DT1$BAKg)


range: func [pair [pair! block!] /local min max result][
    min: first pair
    max: second pair
    result: copy []
    for n min max either min < max [1] [-1] [
        append result n
    ]
    result
]

list: func [
	{Performs a list comprehension.}
    comprehension [block!]
    /type
    	datatype [datatype!]
    /local
	    args
	    action
	    elems
	    filter
	    index
	    list
	    result
	    rules
	    skip
	    vars
][
    vars: make object! []
    rules: [
        set action [block!]
        some [
            'for
            set var word!
            'in
            set list [word! | series! | pair!]
            (if pair? list [list: range list])
            (vars: make vars reduce [to-set-word var either paren? list [do list] [list]])
        ]
        opt [
            'where
            set filter [block!]
        ]
    ]
    unless parse comprehension rules [
        make error! "The list comprehension was not valid."
    ]
    action: func copy at first vars 2 action
    filter: func copy at first vars 2 either found? filter [filter] [[true]]
    elems: 1
    foreach field at first vars 2 [
        unless found? result [
            result: make either type [datatype] [type? vars/(field)] none
        ]
        elems: elems * (length? vars/(field))
    ]
    for n 0 (elems - 1) 1 [
        skip: elems
        args: copy []
        foreach field at first vars 2 [
            list: vars/(field)
            skip: skip / length? list
            index: (mod to-integer (n / skip) length? list) + 1
            append args list/(index)
        ]
        if do compose [filter (args)] [
            append/only result do compose [action (args)]
        ]
    ]
    result
]