get_accuracy_mtrx = function(results_datatable, dict_codes_variable, hand_codes_variable, tie_break_order) {

    # data.table -> matrix
    # matrix has colnames precision, recall, f1, support, and trend_correlation, and row names 1:5, "avg_sum"

    # > test_dt = data.table(MAXENT_LABEL = c(4, 5, 5, 1, 2), SVM_LABEL = c(3, 5, 5, 3, 2), RF_LABEL = c(4, 4, 5, 2, 1), code = c(3, 5, 4, 1, 2), year = c(1980, 1980, 1990, 1990, 1990))
    # > test_dt
    #    MAXENT_LABEL SVM_LABEL RF_LABEL code year
    # 1:            4         3        4    3 1980
    # 2:            5         5        4    5 1980
    # 3:            5         5        5    4 1990
    # 4:            1         3        2    1 1990
    # 5:            2         2        1    2 1990
    # > round(get_accuracy_mtrx(test_dt, labels=), 2)
    #           precision   recall     f1     support    trend correlation
    # 1               NaN        0    NaN           1                   NA
    # 2                 1        1      1           1                    1
    # 3                 0        0    NaN           1                   -1
    # 4                 0        0    NaN           1                   -1
    # 5               0.5        1   0.67           1                    1
    # overall         NaN      NaN    NaN           5                   NA

    get_precision = function(tp, fp) {
        # two integer values -> single numeric value
        # > get_precision(0, 0)
        # [1] NaN
        # > get_precision(1, 0)
        # [1] 1
        # > get_precision(0, 1)
        # [1] 0
        # > get_precision(0, 1)
        # [1] 0
        # > get_precision(1, 1)
        # [1] 0.5
        return(tp/(tp+fp))
    }

    get_recall = function(tp, fn) {
        # two integer values -> single numeric value
        # > get_recall(0, 1)
        # [1] 0
        # > get_recall(1, 0)
        # [1] 1
        # > get_recall(0, 1)
        # [1] 0
        # > get_recall(0, 1)
        # [1] 0
        # > get_recall(1, 0)
        # [1] 1
        return(tp/(tp+fn))
    }

    get_f1 = function(precision, recall) {
        # two integer values -> single numeric value
        # > get_f1(NaN, 0)
        # [1] NaN
        # > get_f1(1, 1)
        # [1] 1
        # > get_f1(0, 0)
        # [1] NaN
        # > get_f1(0, 0)
        # [1] NaN
        # > get_f1(0.5, 1)
        # [1] 0.6666667
        return(2*precision*recall/(precision + recall))
    }

    get_support = function(tp, fn) {
        # two integer values -> single integer value
        # > get_support(0, 1)
        # [1] 1
        # > get_support(1, 0)
        # [1] 1
        # > get_support(0, 1)
        # [1] 1
        # > get_support(0, 1)
        # [1] 1
        # > get_support(1, 0)
        # [1] 1
        return(tp + fn)
    }

    get_tp = function(hand_coded_logical, dict_coded_logical) {
        # two logical vectors -> single integer value
        # > get_tp(c(FALSE, FALSE, FALSE, TRUE, FALSE), c(FALSE, FALSE, FALSE, FALSE, FALSE))
        # [1] 0
        # > get_tp(c(FALSE, FALSE, FALSE, FALSE, TRUE), c(FALSE, FALSE, FALSE, FALSE, TRUE))
        # [1] 1
        # > get_tp(c(TRUE, FALSE, FALSE, FALSE, FALSE), c(FALSE, FALSE, FALSE, TRUE, FALSE))
        # [1] 0
        # > get_tp(c(FALSE, FALSE, TRUE, FALSE, FALSE), c(TRUE, FALSE, FALSE, FALSE, FALSE))
        # [1] 0
        # > get_tp(c(FALSE, TRUE, FALSE, FALSE, FALSE), c(FALSE, TRUE, TRUE, FALSE, FALSE))
        # [1] 1
        out = 0
        for(i in 1:length(hand_coded_logical)) {
            if(hand_coded_logical[i] & dict_coded_logical[i]) out = out + 1
        }
        return(out)
    }

    get_fp = function(hand_coded_logical, dict_coded_logical) {
        # two logical vectors -> single integer value
        # > get_fp(c(FALSE, FALSE, FALSE, TRUE, FALSE), c(FALSE, FALSE, FALSE, FALSE, FALSE))
        # [1] 0
        # > get_fp(c(FALSE, FALSE, FALSE, FALSE, TRUE), c(FALSE, FALSE, FALSE, FALSE, TRUE))
        # [1] 0
        # > get_fp(c(TRUE, FALSE, FALSE, FALSE, FALSE), c(FALSE, FALSE, FALSE, TRUE, FALSE))
        # [1] 1
        # > get_fp(c(FALSE, FALSE, TRUE, FALSE, FALSE), c(TRUE, FALSE, FALSE, FALSE, FALSE))
        # [1] 1
        # > get_fp(c(FALSE, TRUE, FALSE, FALSE, FALSE), c(FALSE, TRUE, TRUE, FALSE, FALSE))
        # [1] 1
        out = 0
        for(i in 1:length(hand_coded_logical)) {
            if(!hand_coded_logical[i] & dict_coded_logical[i]) out = out + 1
        }
        return(out)
    }

    get_fn = function(hand_coded_logical, dict_coded_logical) {
        # two logical vectors -> single integer value
        # > get_fn(c(FALSE, FALSE, FALSE, TRUE, FALSE), c(FALSE, FALSE, FALSE, FALSE, FALSE))
        # [1] 1
        # > get_fn(c(FALSE, FALSE, FALSE, FALSE, TRUE), c(FALSE, FALSE, FALSE, FALSE, TRUE))
        # [1] 0
        # > get_fn(c(TRUE, FALSE, FALSE, FALSE, FALSE), c(FALSE, FALSE, FALSE, TRUE, FALSE))
        # [1] 1
        # > get_fn(c(FALSE, FALSE, TRUE, FALSE, FALSE), c(TRUE, FALSE, FALSE, FALSE, FALSE))
        # [1] 1
        # > get_fn(c(FALSE, TRUE, FALSE, FALSE, FALSE), c(FALSE, TRUE, TRUE, FALSE, FALSE))
        # [1] 0
        out = 0
        for(i in 1:length(hand_coded_logical)) {
            if(hand_coded_logical[i] & !dict_coded_logical[i]) out = out + 1
        }
        return(out)
    }

    get_hand_coded_logical = function(category, hand_codes_variable) {
        # character/integer value and character/integer vector -> logical vector
        # > get_hand_coded_logical(1, test_dt$code)
        # [1] FALSE FALSE FALSE TRUE FALSE
        # > get_hand_coded_logical(2, test_dt$code)
        # [1] FALSE FALSE FALSE FALSE TRUE
        # > get_hand_coded_logical(3, test_dt$code)
        # [1] TRUE FALSE FALSE FALSE FALSE
        # > get_hand_coded_logical(4, test_dt$code)
        # [1] FALSE FALSE TRUE FALSE FALSE
        # > get_hand_coded_logical(5, test_dt$code)
        # [1] FALSE TRUE FALSE FALSE FALSE
        return(hand_codes_variable==category)
    }

    get_dict_coded_logical = function(category, dict_codes_variable) {
        # character/integer value and character vector -> logical vector
        # > get_dict_coded_logical(1, as.character(c(4, 5, 5, 3, 2)))
        # [1] FALSE FALSE FALSE FALSE FALSE
        # > get_dict_coded_logical(2, as.character(c(4, 5, 5, 3, 2)))
        # [1] FALSE FALSE FALSE FALSE TRUE
        # > get_dict_coded_logical(3, as.character(c(4, 5, 5, 3, 2)))
        # [1] FALSE FALSE FALSE TRUE FALSE
        # > get_dict_coded_logical(4, as.character(c(4, 5, 5, 3, 2)))
        # [1] TRUE FALSE FALSE FALSE FALSE
        # > get_dict_coded_logical(5, as.character(c(4, 5, 5, 3, 2)))
        # [1] FALSE TRUE TRUE FALSE FALSE
        return(dict_codes_variable==category)
    }

    get_time_corr = function(hand_coded_logical, dict_coded_logical) {
        # two logical vectors -> single numeric value (correlation)
        # > get_time_corr(c(FALSE, FALSE, FALSE, TRUE, FALSE), c(FALSE, FALSE, FALSE, FALSE, FALSE))
        # [1] NA
        # > get_time_corr(c(FALSE, FALSE, FALSE, FALSE, TRUE), c(FALSE, FALSE, FALSE, FALSE, TRUE))
        # [1] 1
        # > get_time_corr(c(TRUE, FALSE, FALSE, FALSE, FALSE), c(FALSE, FALSE, FALSE, TRUE, FALSE))
        # [1] -1
        # > get_time_corr(c(FALSE, FALSE, TRUE, FALSE, FALSE), c(TRUE, FALSE, FALSE, FALSE, FALSE))
        # [1] -1
        # > get_time_corr(c(FALSE, TRUE, FALSE, FALSE, FALSE), c(FALSE, TRUE, TRUE, FALSE, FALSE))
        # [1] 1
        get_hand_coded_proportion_by_year = function(hand_coded_logical) {
            # logical vector -> numeric vector
            # > get_hand_coded_proportion_by_year(c(FALSE, FALSE, FALSE, TRUE, FALSE))
            # [1] 0 0.333333
            # > get_hand_coded_proportion_by_year(c(FALSE, FALSE, FALSE, FALSE, TRUE))
            # [1] 0 0.333333
            # > get_hand_coded_proportion_by_year(c(TRUE, FALSE, FALSE, FALSE, FALSE))
            # [1] 0.5 0
            # > get_hand_coded_proportion_by_year(c(FALSE, FALSE, TRUE, FALSE, FALSE))
            # [1] 0 0.333333
            # > get_hand_coded_proportion_by_year(c(FALSE, TRUE, FALSE, FALSE, FALSE))
            # [1] 0.5 0
            hand_coded_logical_by_year = data.table(year=results_datatable$year, weight=results_datatable$weight, hand_coded_logical = hand_coded_logical)
            proportion_by_year = hand_coded_logical_by_year[ , sum(weight[hand_coded_logical])/sum(weight), by=year]
            setorder(proportion_by_year, year)
            return(proportion_by_year$V1)
        }

        get_dict_coded_proportion_by_year = function(dict_coded_logical) {
            # logical vector -> numeric vector
            # > get_dict_coded_proportion_by_year(c(FALSE, FALSE, FALSE, FALSE, FALSE))
            # [1] 0 0
            # > get_dict_coded_proportion_by_year(c(FALSE, FALSE, FALSE, FALSE, TRUE))
            # [1] 0 0.333333
            # > get_dict_coded_proportion_by_year(c(FALSE, FALSE, FALSE, TRUE, FALSE))
            # [1] 0 0.333333
            # > get_dict_coded_proportion_by_year(c(TRUE, FALSE, FALSE, FALSE, FALSE))
            # [1] 0.5 0
            # > get_dict_coded_proportion_by_year(c(FALSE, TRUE, TRUE, FALSE, FALSE))
            # [1] 0.5 0.333333

            dict_coded_logical_by_year = data.table(year=results_datatable$year, weight=results_datatable$weight, dict_coded_logical = dict_coded_logical)
            proportion_by_year = dict_coded_logical_by_year[ , sum(weight[dict_coded_logical])/sum(weight), by=year]
            setorder(proportion_by_year, year)
            return(proportion_by_year$V1)
        }

        hand_coded_proportion_by_year = get_hand_coded_proportion_by_year(hand_coded_logical)
        dict_coded_proportion_by_year = get_dict_coded_proportion_by_year(dict_coded_logical)

        return(cor(hand_coded_proportion_by_year, dict_coded_proportion_by_year))
    }

    labels = rev(tie_break_order)
    hand_coded_logical = sapply(labels, get_hand_coded_logical, hand_codes_variable) # should return matrix with a column for each code
    dict_coded_logical = sapply(labels, get_dict_coded_logical, dict_codes_variable)

    tp = sapply(labels, function(x) get_tp(hand_coded_logical[,x], dict_coded_logical[,x])) # should return a length-5 vector of counts
    fp = sapply(labels, function(x) get_fp(hand_coded_logical[,x], dict_coded_logical[,x])) # "
    fn = sapply(labels, function(x) get_fn(hand_coded_logical[,x], dict_coded_logical[,x])) # "

    precision = sapply(labels, function(x) get_precision(tp[x], fp[x]), USE.NAMES=FALSE)
    recall = sapply(labels, function(x) get_recall(tp[x], fn[x]), USE.NAMES=FALSE)
    f1 = sapply(labels, function(x) get_f1(precision[x], recall[x]), USE.NAMES=FALSE)
    support = sapply(labels, function(x) get_support(tp[x], fn[x]), USE.NAMES=FALSE)
    trend_correlation = sapply(labels, function(x) get_time_corr(hand_coded_logical[,x], dict_coded_logical[,x]), USE.NAMES=FALSE)
    accuracy_mtrx = cbind(precision, recall, f1, support, trend_correlation)

    overall_precision = sum(precision*support)/sum(support)
    overall_recall = sum(recall*support)/sum(support)
    overall_f1 = sum(f1*support)/sum(support)
    sum_support = sum(support)
    avg_correlation = sum(trend_correlation*support)/sum(support)

    overall = c(overall_precision, overall_recall, overall_f1, sum_support, avg_correlation)

    accuracy_mtrx = rbind(accuracy_mtrx, overall)
    dimnames(accuracy_mtrx) = list(c(labels, "overall"), c("precision", "recall", "f1", "support", "trend_correlation"))
    return(accuracy_mtrx)
}


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

# set up a device driver to plot
#postscript(file='~/Copy/Programming/R/rprograms/plotting/legends/greek1.eps')

plot(1:3,
     #ylab = expression("Diameter of apeture (" * mu ~ "m)"),
     ylab = expression(paste("Diameter of aperture ( ", hat(mu), " )")),
     xlab = expression("Force spaces with ~" ~ mu ~ pi * sigma ~ pi),
     main = expression("This is another Greek character with space" ~ sigma))

#example 2
# mu <- 2.8
# plot(1:3, main=bquote(mu == .(mu)))

#example 3

# turn off device driver
#dev.off()


###PCA3d on a data frame names f_table2, without the two first columns used for grouping
### with one column named "group"
for (i in 1: nrow(f_table)){
  f_table$sum[i]=sum(f_table[i,4:14])
}

require(rgl)
#####PCA
create.mean.table <- function(data_table,groups,data_cols=1,group_col=ncol(data_table)) {
  mean_table = data.frame()
	sd_table = data.frame()
	se_table = data.frame()
	for (g in groups) {
		data = data_table[data_table[group_col]==g,]
		mean_table = rbind(mean_table,data.frame(t(colMeans(data[data_cols],na.rm=TRUE))))
		sd_table = rbind(sd_table,data.frame(t(sd(data[data_cols],na.rm=TRUE))))
		se_table = sd_table/sqrt(nrow(data))
	}
	rownames(mean_table) = groups
	rownames(sd_table) = groups

	erg <- list(mean_table,sd_table,se_table)
	names(erg) <- c("means","sds","ses")
	return(erg)
}
##

h_table<-f_table2[,c(3:(length(f_table2)))]
rownames (h_table) = paste (c(1:length(f_table2[,1])),f_table2[,2])
#h_table<-f_table2[,c(3:13,16:length(f_table2))]
g_table <- na.omit(h_table)
 head(g_table)
mydata.pca <- prcomp(g_table, retx= TRUE, center= TRUE, scale.=TRUE)
sd <- mydata.pca$sdev
loadings <- mydata.pca$rotation
rownames(loadings) <- colnames(g_table)
scores <- mydata.pca$x

PCA_res= data.frame(scores)
PCA_res$group = i_table[,2]

PCA1to3 = data.frame(PCA_res$PC1,PCA_res$PC2,PCA_res$PC3,PCA_res$group)
Mean_PCA_3d = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),1:3)

scalingfact=15
###
### Plot variables plot in 3D (arrow plot)

plot3d(loadings[,1]*scalingfact,loadings[,3]*scalingfact,loadings[,2]*scalingfact,
       type = "n",box =FALSE,axes=TRUE,xlab="PC1",ylab="PC3",zlab="PC2")

for (j in 1:nrow(loadings)){
A=matrix (c(0,0,0,loadings[j,1]*scalingfact,loadings[j,3]*scalingfact,loadings[j,2]*scalingfact),2,3,byrow =TRUE)
segments3d(A, col=j)

text3d(loadings[j,1]*scalingfact*1.1,loadings[j,3]*scalingfact*1.1,loadings[j,2]*scalingfact*1.1,
     rownames(loadings)[j], col=j+1, cex=0.7, add=TRUE)
}

###
### Plot data, mean +- ses on the 3 axes, and ellipse of X=20% confidence interval
## beware: no legend
LEV=0.7
plot3d(loadings[,1]*scalingfact,loadings[,3]*scalingfact,loadings[,2]*scalingfact,
       type = "n",box =FALSE,axes=TRUE,xlab="PC1",ylab="PC3",zlab="PC2")

  for (i in 1:length(levels(PCA_res$group))){
  X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
  points= data.frame(X$PC1, X$PC3,X$PC2)
  plot3d(points, col=i,type= "p",add=TRUE)
  #plot3d(X$PC1, X$PC3,X$PC2, col=i,type= "p",add=TRUE)
  #Ell= sd(points)/sqrt(nrow(points))
  plot3d(ellipse3d(cor(points), centre = mean(points), level=LEV), col=i, alpha=0.3 , add=TRUE)

  plot3d(ellipse3d(cov(points), centre = mean(points), level=LEV), col=i+2, alpha=0.3 , add=TRUE)

x=Mean_PCA_3d$means$PCA_res.PC1[i]
y=Mean_PCA_3d$means$PCA_res.PC3[i]
z=Mean_PCA_3d$means$PCA_res.PC2[i]
x2=Mean_PCA_3d$ses$PCA_res.PC1[i]
y2=Mean_PCA_3d$ses$PCA_res.PC3[i]
z2 =Mean_PCA_3d$ses$PCA_res.PC3[i]
  A= matrix (c(x-x2,y,z,x+x2,y,z,x,y-y2,z,x,y+y2,z,x,y, z-z2,x,y,z+z2),6,3, byrow =TRUE)
  segments3d(A, col=i)
  }

 # text3d(max(points[1]),max(points[3]),max(points[2]),
 #    levels(PCA_res$group)[i], col=i, cex=0.7, add=TRUE)

#################
###################
#################
########## code to move the visualisation
 rgl.viewpoint(theta = 0, phi = 0, fov = 45, zoom = 0.8)

########## code for making a snapshot

######## multiple snapshot to transform into a video
for (i in 0:180) {
   rgl.viewpoint(theta = -180+2*i, phi =-90+(i ), fov = 45, zoom = 1)
   filename <- paste("pic1_",1000+i,".png",sep="")

  #rgl.snapshot(filename, fmt="png")
}
for (k in 0:90) {

   rgl.viewpoint(theta = 0, phi =k, fov = 45, zoom = 1)
   filename <- paste("pic2_",1000+k,".png",sep="")
  #rgl.snapshot(filename, fmt="png")
                     }

# F=c()
# for (g in 1: nrow(loadings)) F=c(F,0)
#
# loadings2= rbind(loadings,F)


setwd("doc/distributions")
png(file = "normal.png", width = 800, height = 600, pointsize = 12, bg = "white",  res = NA)
colors=c("blue")
x<-seq(-3,3,length=10000)
plot(x, dnorm(x,0,1) ,xlab="", ylab="" ,lwd=3, col=colors[1],type="l", cex.axis=2, col.axis="gray40")
title("Normal Distribution",col.main="gray50",cex.main=1.5)
legend(1.5,0.4,legend="N(0,1)",lwd=c(4,4,4,1),col=colors,cex=1.5)
grid()
dev.off()


library("broom")
library("ggplot2")
library("reshape2")
setwd("~/dev/BitFunnel/src/Scripts")

args = commandArgs(trailingOnly=TRUE)
if (length(args) != 4) {
   stop("Required args: [interpreter QueryPipelineStats filename], [compiler QPS filename], [cachelines vs time filename], [matches vs. time filename]", call.=FALSE)
}
int_name = args[1]
comp_name = args[2]
out_name1 = args[3]
out_name2 = args[4]

print("Reading input.")
interpreter <- read.csv(header=TRUE, file=int_name)
compiler <- read.csv(header=TRUE, file=comp_name)

df <- data.frame(interpreter$cachelines, compiler$match)
names(df)[names(df) == 'interpreter.cachelines'] <- 'Cachelines'
names(df)[names(df) == 'compiler.match'] <- 'MatchTime'

# print("Plotting cachelines vs. time.")
# png(filename=out_name1,width=1600,height=1200)
# ggplot(df, aes(x=Cachelines,y=MatchTime)) +
# theme_minimal() +
# geom_point(alpha=1/100) +
# theme(axis.text = element_text(size=40),
#       axis.title = element_text(size=40)) +
# ylim(0, 0.001)
# dev.off()

# print("Plotting matches vs. time.")
# png(filename=out_name2,width=1600,height=1200)
# ggplot(compiler, aes(x=matches,y=match)) +
# theme_minimal() +
# geom_point(alpha=1/20) +
# theme(axis.text = element_text(size=40),
#       axis.title = element_text(size=40))
# dev.off()

# print("Computing cacheline regression.")
# df <- data.frame(interpreter$cachelines, compiler$matches, compiler$match)
# names(df)[names(df) == 'interpreter.cachelines'] <- 'Cachelines'
# names(df)[names(df) == 'compiler.matches'] <- 'Matches'
# names(df)[names(df) == 'compiler.match'] <- 'Time'

# fit <- lm(Time ~ Matches, data=df)
# print(summary(fit))

# fit <- lm(Time ~ Cachelines, data=df)
# print(summary(fit))

# fit <- lm(Time ~ ., data=df)
# print(summary(fit))

# print("Residual plot.")
# df <- augment(fit)

# # TODO: don't hardcode filename.
# png(filename="time-residual.png",width=1600,height=1200)
# ggplot(df, aes(x = .fitted, y = .resid)) +
# theme_minimal() +
# geom_point(alpha=1/10) +
# theme(axis.text = element_text(size=40),
#       axis.title = element_text(size=40))
# dev.off()

print("Computing quadword regression.")
df <- data.frame(interpreter$quadwords, compiler$matches, compiler$match)
names(df)[names(df) == 'interpreter.quadwords'] <- 'Quadwords'
names(df)[names(df) == 'compiler.matches'] <- 'Matches'
names(df)[names(df) == 'compiler.match'] <- 'Time'

fit <- lm(Time ~ Matches, data=df)
print(summary(fit))

fit <- lm(Time ~ Quadwords, data=df)
print(summary(fit))

fit <- lm(Time ~ ., data=df)
print(summary(fit))

df <- data.frame(interpreter$quadwords, compiler$match)
names(df)[names(df) == 'interpreter.quadwords'] <- 'Quadwords'
names(df)[names(df) == 'compiler.match'] <- 'MatchTime'

print("Plotting quadwords vs. time.")
# png(filename=out_name1,width=1600,height=1200)
ggplot(df, aes(x=Quadwords,y=MatchTime)) +
theme_minimal() +
geom_smooth(method = "lm", se = FALSE) +
theme(aspect.ratio=1/2) +
geom_point(alpha=1/10) +
theme(axis.text = element_text(size=20),
      axis.title = element_text(size=20)) +
# ylim(0, 0.0005) +
scale_y_continuous(name="Match Time (us)", labels=c("0", "100", "200", "300", "400", "500"), breaks=c(0, 0.0001, 0.0002, 0.0003, 0.0004, 0.0005), limits=c(0, 0.0005)) +
# dev.off()
ggsave(out_name1, width = 10, height=5)

# df <- data.frame(interpreter$matches, compiler$match)
# names(df)[names(df) == 'interpreter.matches'] <- 'Matches'
# names(df)[names(df) == 'compiler.match'] <- 'MatchTime'

# print("Plotting quadwords vs. time.")
# png(filename=out_name1,width=1600,height=1200)
# ggplot(df, aes(x=Matches,y=MatchTime)) +
# theme_minimal() +
# geom_point(alpha=1/10) +
# theme(axis.text = element_text(size=40),
#       axis.title = element_text(size=40)) +
# ylim(0, 0.002)
# dev.off()


#' Jacobian transformation adjustment
#'
#' compute the Jacobian adjustment for transformations as done in the X-13ARIMA-SEATS program
#'
#' @param Y numeric vector, original time series.
#' @param Nspobs Integer scalar, Length of \code{Y}.
#' @param Nintvl Integer scalar, Number of differences in model used. Default is 2.
#' @param Adj numeric vector, prior adjustment factor time series. Default is NULL, which indicates there is no prior adjustment.
#' @param Logit logical scalar, if TRUE the logit transformation is used. Default is FALSE.
#' @param Trans logical scalar, if TRUE a Box-Cox transform is used. Default is TRUE
#' @param Lam numeric scalar, Box-Cox transformation parameter. Default is 0 (Log transform).
#' @return Jacobean adjustment to the likelihood of estimated models to allow AIC and other likelihood statistics to be compared for different transformations.
#' @examples
#' Nspobs <- length(ic_obs)
#' ic_jacadj_log   <- jacobian_trans_adj(ic_obs, Nspobs, 2, Trans = TRUE, Lam = 0.0)
#' @import stats
#' @export
jacobian_trans_adj <- function(Y, Nspobs, Nintvl = 2, Adj = NULL, Logit = FALSE, Trans = TRUE, Lam=0.0) {
    # Author: Brian C. Monsell (OEUS), Version 2.5, 3/2/2022
   this_index <- seq(Nintvl+1, Nspobs)
   if (is.null(Adj)) {
      Adj <- rep(1.0, Nspobs)
   } else {
      nadj <- length(Adj)
      if (nadj != Nspobs) {
         stop("series and prior adjustments not the same length")
      }
   }

   yi   <- Y[this_index]
   jaci <- Adj[this_index]

#           logit adjustment : jaci=jaci/(jaci*Y(i)-Y(i)**2)
   if (Logit) {
      jacadj <- sum(log(jaci/(yi - yi*yi)))
   } else {
#  transformation adjustment : jaci=(abs(yi)**(Lam-ONE))/jaci
      if (Trans) {
         jacadj <- sum(log((abs(yi)^(Lam-1))/jaci))
      } else {
         jacadj <- 0
      }
   }

   return(jacadj)
}


rm(list=ls())
library(testthat)
library(ShipPowerModel)

NewValues<- data.frame(matrix(nrow = nrow(TestShipsKrist),ncol=0))

context("Test Ship Power Calculation for Kristensen method")
#===========================================
NewValues$ship.speed<- calcSpeedUnitConversion(TestShipsKrist$shipSpeed)

NewValues$displacement<- calcDispUnitConversion(TestShipsKrist$Displacement, seawaterDensity = 1.025)

NewValues$nProp<- calcPropNum(TestShipsKrist$ship.type)

NewValues$Cb<- calcCb(NewValues$displacement, TestShipsKrist$lwl, TestShipsKrist$breadth, TestShipsKrist$maxDraft)

#==============================================
NewValues$actual.disp<-calcActualDisp(TestShipsKrist$Cb,
                                   TestShipsKrist$Cbw,
                                   TestShipsKrist$actualDraft,
                                   TestShipsKrist$maxDraft,
                                   NewValues$displacement)
test_that("calcActualDisp works",{

  expect_equal(NewValues$actual.disp,
               TestShipsKrist$actual.disp
  )
})
#==============================================

NewValues$froudeNum<- calcFroudeNum(NewValues$ship.speed,
                                    TestShipsKrist$lwl)
test_that("calcFroudeNum works",{

  expect_equal(NewValues$froudeNum,
               TestShipsKrist$froudeNum
  )
})
#==============================================
NewValues$Cm<-calcCm(TestShipsKrist$ship.type,
           TestShipsKrist$Cbw,
           TestShipsKrist$maxDraft,
           TestShipsKrist$actualDraft,
           CmEquationType="kristensen")

test_that("calcCm works",{

  expect_equal(NewValues$Cm,
               TestShipsKrist$Cm
  )
})
#==============================================
NewValues$Cp<-calcCp(NewValues$Cm,
                     TestShipsKrist$Cbw,
                     TestShipsKrist$ship.type,
                     bounds="none")

test_that("calcCp works",{

  expect_equal(NewValues$Cp,
               TestShipsKrist$Cp
  )
})
#==============================================
NewValues$propDiam<-calcPropDia(TestShipsKrist$ship.type,
                      TestShipsKrist$maxDraft)

test_that("calcPropDia works",{

  expect_equal(NewValues$propDiam,
               TestShipsKrist$propDiam
  )
})
#==============================================

NewValues$M<- calcShipM(NewValues$actual.disp,
                            TestShipsKrist$lwl)

test_that("calcPropDia works",{

  expect_equal(NewValues$M,
               TestShipsKrist$M
  )
})

#=============================================================
#Frictional Resistance
NewValues$Cf<-calcCf(NewValues$ship.speed,
                     TestShipsKrist$lwl,
                     15,
                     seawaterDensity=1.025)

test_that("calcCf works",{

  expect_equal(NewValues$Cf,
               TestShipsKrist$Cf
  )
})
#=============================================================
#Wetted Surface Area
NewValues$wettedSA<-calcKristWettedSA(TestShipsKrist$ship.type,
                            NewValues$displacement,
                            TestShipsKrist$maxDraft,
                            TestShipsKrist$actualDraft,
                            TestShipsKrist$lwl,
                            TestShipsKrist$breadth,
                            TestShipsKrist$Cbw,
                            seawaterDensity=1.025)

test_that("calcKristWettedSA works",{

  expect_equal(NewValues$wettedSA,
               TestShipsKrist$wettedSA
  )
})
#==========================================
#Incremental Resistance
NewValues$Ca<-calcKristCa(TestShipsKrist$ship.type,
                          NewValues$actual.disp)

test_that("calcKristCa works",{

  expect_equal(NewValues$Ca,
               TestShipsKrist$Ca,
               tolerance=1e-07
  )
})
#==========================================
#Air Resistance
NewValues$Caa<-calcKristCaa(TestShipsKrist$ship.type,
                            TestShipsKrist$dwt)

test_that("calcKristCaa works",{

  expect_equal(NewValues$Caa,
               TestShipsKrist$Caa
  )
})
#==========================================
#Residual Resistance
NewValues$Cr<-calcKristCr(TestShipsKrist$ship.type,
                          NewValues$M,
                          NewValues$froudeNum,
                          TestShipsKrist$actualDraft,
                          TestShipsKrist$breadth,
                          NewValues$Cp)

test_that("calcKristCr works",{

  expect_equal(NewValues$Cr,
               TestShipsKrist$Cr
  )
})
#=============================================================
#Thrust Deduction Factor
NewValues$t<-calcKristThrustFactor(TestShipsKrist$ship.type,
                                   TestShipsKrist$breadth,
                                   TestShipsKrist$lwl,
                                   TestShipsKrist$Cbw,
                                   NewValues$propDiam,
                                   NewValues$M,
                                   NewValues$nProp
                              )

test_that("calcKristThrustFactor works",{

  expect_equal(NewValues$t,
               TestShipsKrist$t
  )
})
#=============================================================
#Wake Fraction

NewValues$w<-calcKristWakeFrac(TestShipsKrist$ship.type,
                          TestShipsKrist$breadth,
                          TestShipsKrist$lwl,
                          TestShipsKrist$Cbw,
                          NewValues$propDiam,
                          NewValues$M,
                          NewValues$nProp)

test_that("calcKristWakeFrac works",{

  expect_equal(NewValues$w,
               TestShipsKrist$w
  )
})
#==========================================================
#Total Resistance
NewValues$Rtot<-calcKristTotalRes(NewValues$wettedSA,
                               NewValues$Cf,
                               NewValues$Cr,
                               NewValues$Ca,
                               NewValues$Caa,
                     seawaterDensity=1.025,
                     NewValues$ship.speed,
                     serviceMargin=15)

test_that("calcKristTotalRes works",{

  expect_equal(NewValues$Rtot,
               TestShipsKrist$Rtot,
               tolerance=0.01
  )
})
#==========================================================
# Open Water Efficiency
NewValues$openwatereff<-calcOpenWaterEff(NewValues$Rtot,
                               NewValues$t,
                               NewValues$nProp,
                               NewValues$w,
                               NewValues$propDiam,
                               NewValues$ship.speed,
                     seawaterDensity=1.025)

test_that("calcOpenWaterEff works",{

  expect_equal(NewValues$openwatereff,
               TestShipsKrist$openwatereff,
               tolerance=1e-05
  )
})
#=============================================================
NewValues$Power<-calcResistanceShipPwr(Rtot=NewValues$Rtot,
                                       shipSpeed=NewValues$ship.speed,
                             hullEff=calcHullEff(NewValues$t, NewValues$w),
                             openWaterEff=NewValues$openwatereff,
                             totalInstalledPwr =  TestShipsKrist$MCR,
                             shaftEff=0.98,
                             relRotationEff=1,
                              pwrUpperBoundPercent = 2)

test_that("calcResistanceShipPwr works",{

  expect_equal(NewValues$Power,
               TestShipsKrist$Power
  )
})

test_that("calcKristPwr works",
          {
          expect_equal(
                       calcKristPwr(totalInstalledPwr = TestShipsKrist$Power,
                                    shipSpeed         = NewValues$ship.speed,
                                    actualDraft       = TestShipsKrist$actualDraft,
                                    maxDraft          = TestShipsKrist$maxDraft,
                                    shipType          = TestShipsKrist$ship.type,
                                    lwl               = TestShipsKrist$lwl,
                                    breadth           = TestShipsKrist$breadth,
                                    maxDisplacement   = NewValues$displacement,
                                    Cb                = NewValues$Cb,
                                    nProp             = NewValues$nProp,
                                    dwt               = TestShipsKrist$dwt
                                      ),
                       TestShipsKrist$Power
                       )
          }
          )

#=============================================================
# names<- names(TestShipsKrist)[names(TestShipsKrist)%in%names(NewValues)]
# TestShipsKrist[,names]<-NewValues[,names]
# write.csv(TestShipsKrist, "data/Sample.Ships.Updated.Kristensen.csv", row.names=FALSE)


#### Sequences and numbers####

# The simplest way of creating sequences of numbers
1:20

# R has several built-in constants (ready-made objects embedded in base R):
# LETTERS, letters, month.abb, month.name, pi.
# Run these objects to see their contents.

# We can use one of them to illustrate sequences of real numbers (decimal).
pi:10

# Sequences of numbers work in reverse as well!
10:1

# Just like with functions, we can check the documentation for operators as well!
# You just need to enclose the operator in quotation marks or backticks.
?":"
?`:`

# You can have more control over a sequence with the seq () function. The following
# line does the same as the first example in the script (which used a colon).
seq(1, 10)

# Adding the by argument changes the increments of the sequence.
seq(1, 10, by = 0.5)

# The length argument is pretty self-explanatory - it changes the length of the
# sequence, instead of the increments. For obvious reasons, the two arguments
# are mutually exclusive.
x <- seq(1, 10, length = 30)

# Base R also has the length () function, which gives you the length of any object
# you pass as an argument. This will come in handy later on.
length(x)

# The rep () function is short for replicate. This example replicates a value ten
# times.
rep(1, times = 10)

# The argument can be a vector, or any other kind of data structure (see the
# data structures section to see what that is).
rep(c(0, 1, 2), times = 10)

# You can repeat each component of the vector a certain number of times.
rep(c(0, 1, 2), each = 10)

#### Data types/classes####

# All of the objects we used last week were vectors, but most of them had a
# length of one. This is the most common data structure. The most important
# thing about a vector is that it can only contain objects of the same class.

# A list is represented as a vector but can contain objects of different classes,
# which is its primary use case.

# Run the following lines of code to generate a data frame with the different
# data types/classes and data structures.

data_types <- c("character", "numeric", "integer", "logical", "complex")
data_structures <- c("(atomic) vector", "list", "matrix", "data frame", "factors")
tvs_df <- data.frame(data_types, data_structures)

# Clicking on the tvs_df object in the environment will open up a table that
# you can consult.

# R has five basic or "atomic" classes of objects (which are demonstrated
# with several example vectors depicted below)

# The first two classes represent numbers

# Numeric (real numbers)

x <- c(0.1, 0.2, 1)

# Integer (easily differentiated from numerics by placing an L suffix)
y <- c(1L, 2L, 3L, 4L)

# Some other information connected to numbers that you should know is that
# dividing 1 by 0 gives us an infinite value (Inf)
1 / 0

# The result of dividing 0 by 0 is displayed as NaN (not a number)
0 / 0

# Back to the other data types/classes...

# Character (each element of the vector needs to be put in quotation marks)

z <- c("1", "2", "3")

# Logical (TRUE/FALSE)

l <- c(TRUE, FALSE)

# This class comes in handy when we work with logical operators. More on that
# next week.

# The complex class is not necessary for our particular use case.

# If we try combining multiple data types/classes in a single vector, then R
# will try to convert some elements to match the others. This is called
# implicit coercion. Some data classes have priority over others (more specific
# types are converted in more general ones -  logical < integer < numeric <
# complex < character).

# Combining a numeric and a character results in a character vector

y <- c(1.7, "a")
y

# Combining a logical and a numeric results in a numeric vector.

y <- c(TRUE, 2)

# Combining a character and a logical results in a character vector.

y <- c("a", TRUE)

# You get the idea.

# In addition to implicit, there is also explicit coercion - which can be done
# via the functions below.

as.integer(x)

as.numeric(x)

as.character(x)

# Feel free to experiment with explicit coercion on your own objects

# Sometimes, R can't figure out how to coerce an object and this can result in
# NAs (not available) being produced.

# When nonsensical coercion takes place, you will usually get a warning from R.
x <- c("a", "b", "c")
as.numeric(x)

# The following is a common situation that arises when importing .csv files from
# Microsoft Excel. The columns are sometimes mistakenly considered as character
# instead of numeric vectors. We often need to manually do this conversion so
# that we can properly work with the data.

x <- c("1", "2", "3")
x

# Don't forget to overwrite x, otherwise what you did will only be printed in
# the console and it won't be stored in the environment
x <- as.numeric(x)
x

#### Data structures####
# Refer to the tvs_df data frame again.There are five main data structures in R:
# vectors, lists, matrices, data frames, and factors.
# The following code creates a data frame explaining the crucial differences
# between the first four data structures. Study this table carefully.

d1d2_df <- data.frame(
  c("1-D", "2-D"), c("atomic vector", "matrix"),
  c("list", "dataframe")
)
names(d1d2_df) <- c("Dimensions", "Homogenous", "Heterogeneous")

#### Lists####
# Lists are a special type of vector that can contain elements of different
# classes. As shown in d1d2_df, they are one dimensional data structures,
# just like vectors.
# Lists can be explicitly created using the list() function, which takes an
# arbitrary number of arguments.

x <- list(1, "a", TRUE)
x

#### Matrices####
# Matrices are vectors with a dimension attribute (look at d1d2_df).

m <- matrix(nrow = 2, ncol = 3)
m

# The dimension attribute is  itself an integer vector of length 2 (number of
# rows, number of columns).The dim function returns the number of rows and
# columns that the matrix has.

dim(m)

# Matrices are constructed column-wise, i.e. stating from the top left and
# running down the columns.
m <- matrix(1:6, nrow = 2, ncol = 3)
m

# Let's make two integer vectors
x <- 1:3
y <- 10:12

# The cbind () function allows you to combine these vectors into a matrix as
# columns.

m <- cbind(x, y)

# The rbind function does the same, but treats the vectors as rows.

m <- rbind(x, y)

# The nrow () and ncol () functions show you how many rows and columns the
# matrix contains.

nrow(m)

ncol(m)

#### Data frames####
# Data frames are used to store tabular data in R. They are probably the most
# important type of object that we will use throughout the course. The fifth
# session will be specially dedicated to working with data frames - importing
# them, creating them from scratch, tidying them, and finally visualizing them.
# We will mostly be relying on the tidyverse collection on packages to do so,
# but we'll get back to that in a couple of weeks.

# Data frames can be thought of as lists with a dimension attribute. Look at
# the d1d2_df. The main differences are that every element of the list has to have
# the same length. Each element of the list can be thought of as a column
# and the length of each element of the list is the number of rows.

# Unlike matrices, data frames can store different classes of objects in each
# column. Matrices must have every element be the same class (e.g. all integers
# or all numeric).

# Data frames are usually created by reading in a dataset. You can load in a
# dataframe (we'll mostly be using .csv files in the course) using the import
# dataset shortcut in the environment panel, or by using the read.table() or
# read.csv() functions. Data frames can also be created explicitly with the
# data.frame() function or they can be coerced from other types of objects like
# lists.

# Just like the built-in constant mentioned on line 6, R has some ready-made
# data frames as well. One of the most commonly used ones is the iris dataframe.

iris

# We need to store it in our environment first if we'd like to manipulate it in
# any way.
iris_df <- iris

# You can find two different ways of constructing data frames on lines 60 and 157.

# The following is the third and imo the cleanest way of explicitly creating
# dataframes.

example_df <- data.frame(foo = 1:4, bar = c(T, T, F, F))
example_df

# What follows is a quick rundown of the most common data frame related functions.

# The following two functions are generic functions, which can be extended to
# other classes
# The first, head () gives you the first parts of the object (the first six
# rows of the data frame in this case).

head(iris_df)

# The tail () function shows you the last 6 rows.
tail(iris_df)

# The following three functions were used in the matrices section as well. Try
# them out.

dim(iris_df)

nrow(iris_df)

ncol(iris_df)

# The str () function, short for structure, is a very handy way of looking at
# the structure of an object. Most commonly used for data frames as the most
# complex data structure.

str(iris_df)

#### Factors####
# Factors are used to represent categorical data. Peng suggests looking at them
# as integer vectors, where each integer has a label. Factors are very useful
# for visualization purposes in data frames where the observations (rows) can be
# broadly divided in several groups. These can be visualized as different box
# plots, or as different colors on a scatterplot.

countrynames_f <- factor(c("Czech Republic", "Slovakia", "Austria", "Hungary"))

countrynames_f

#### Package of the week####
# This week's package of the week will be styler, a package specially designed
# to reformat your code according to the generally accepted tidyverse style
# guide.The style guide and the styler documentation are posted on ELF.
install.packages("styler")
library(styler)

# You can take a look at the documentation of the package in R itself.
# The good old ? operator works for packages as well!
?styler


# computing likelihood intervals at certain alpha levels
li<- function(th,like,alpha=0.15){
  that <- mean(th[like==max(like)])
  lowth <- th[th < that]
  lowlik <- like[th < that]
  if (length(lowth)<2) {lowval <- min(th) }
  if (length(lowth)>1)
      {  lowval <- approx(lowlik,lowth,xout=alpha)$y}

  upth <- th[th > that]
    if (length(upth)<2 ) {return(c(lowval,max(th))) }
   if (length(upth)> 1){
    uplik <- like[th > that]
    upval <- approx(uplik,upth,xout=alpha)$y
    return(c(lowval,upval))
  }
  }


source("meta.r")
source("calculate/norms.r")
source("calculate/distance.r")

# Returns data.frame of positions for given words after MDS
get_mds_positions_for_words <- function(words, distance_type, max_words = Inf) {

  if (length(words) < 3) { return(NULL) }
  if (length(words) > max_words) { words = words[1:max_words] }

  data_matrix <- matrix_for_words(words)
  d <- distance_matrix(data_matrix, data_matrix, distance_type)

  if (distance_type %in% c("euclidean", "minkowski3")) {
    # Use metric MDS
    points <- cmdscale(d)
  }
  else if (distance_type %in% c("cosine", "correlation")) {
    # In case the distances are very far from metric, `isoMDS` and `sammon` may
    # crash or produce degenerate solutions due to its use of cmdscale to
    # produce the initial configuration.
    # Therefore we provide a random initial configuration.
    # First we set the random seed to make the output reproducible
    set.seed(0)
    initial_positions <- matrix(runif(length(words) * 2), nrow=length(words))
    # isoMDS has a tendency to produce degenerate solutions, so we prefer sammon
    fit <- sammon(d, y = initial_positions, k = 2)
    points <- fit$points
  }
  else { stop("Unsupported distance function.")}

  positions <- data.frame(points)
  positions <- cbind(words, positions)
  names(positions) <- c("Word", "x", "y")

  return(positions)
}

# Returns a plot for a data.frame of mds positions,
# with or without connecting lines
mds_plot <- function(mds_positions, with_lines) {

  if (is.null(mds_positions)) {
    return(NULL)
  }

  axis <- list(
    title = "",
    showgrid = FALSE,
    showticklabels = FALSE,
    zeroline = FALSE,
    fixedrange = TRUE)

  nodes <- plot_ly(mds_positions) %>%
    config(
      toImageButtonOptions = list(
        format = "svg",
        filename = "mds-plot",
        width = 1000,
        height = 1000
      )
    ) %>%
    add_trace(x = ~x, y = ~y, type = 'scatter', mode="markers+text", text = ~Word, textposition='bottom')

  if (with_lines) {
    fig <- layout(
      nodes,
      shapes= get_mds_line_segments(mds_positions),
      xaxis = axis, yaxis = axis
    )
  }
  else {
    fig <- layout(
      nodes,
      xaxis = axis, yaxis = axis
    )
  }

  return(fig)
}

# Helper function to get all line segments between points
get_mds_line_segments <- function(mds_positions) {
  segments = list()
  for (i in 1:nrow(mds_positions)) {
    for (j in 1:nrow(mds_positions)) {
      if(i == j) { next }
      segments[[length(segments)+1]] <- list(
        type = "line",
        line = list(color = 'lightblue', width = 0.5),
        x0 = mds_positions[i, "x"],
        y0 = mds_positions[i, "y"],
        x1 = mds_positions[j, "x"],
        y1 = mds_positions[j, "y"]
      )
    }
  }
  return(segments)
}

# Get (load) a data.frame of t-sne positions for all the norms
get_tsne_positions <- function(distance_type, dims) {
  infile <- paste0(data_dir, "t-SNE_", dims, "_", distance_name(distance_type), "_cache.bin")
  con <- file(infile, "rb")
  dim <- readBin(con, "integer", 2)
  Mat <- matrix( readBin(con, "numeric", prod(dim)), dim[1], dim[2])
  close(con)

  ret <- data.frame(Mat)
  ret <- cbind(all_words, ret)
  if (dims == 3) {
    names(ret) <- c("Word", "x", "y", "z")
  }
  else if (dims == 2) {
    names(ret) <- c("Word", "x", "y")
  }
  else { stop("Only supports 2- or 3-dimensional plotting!") }

  return(ret)
}

# A plotly plot for t-sne exploration
tsne_plot <- function(tsne_positions, dominance, dims) {

  # Dominance colouring
  if (dominance == "sensorimotor") {
    tsne_positions["Dominance"] = norms[dominance_column_sensorimotor]
  }
  else if (dominance == "perceptual") {
    tsne_positions["Dominance"] = norms[dominance_column_perceptual]
  }
  else if (dominance == "action") {
    tsne_positions["Dominance"] = norms[dominance_column_action]
  }
  else { stop("Invalid dominance selection.") }

  # Set up figure
  if (dims == 3) {
    fig <- plot_ly(tsne_positions) %>%
      config(
        toImageButtonOptions = list(
          format = "svg",
          filename = "tsne-plot",
          width = 600,
          height = 700
        )
      ) %>%
      add_trace(type="scatter3d",
                mode="markers",
                marker=list(
                  size=2,
                  opacity=0.7
                ),
                x=~x, y=~y, z=~z,
                hoverinfo='text', text=~Word,
                color=~Dominance, colors="Set3")
  }
  else if (dims == 2) {
    fig <- plot_ly(tsne_positions) %>%
      config(
        toImageButtonOptions = list(
          format = "svg",
          filename = "tsne-plot",
          width = 600,
          height = 700
        )
      ) %>%
      add_trace(type="scatter",
                mode="markers",
                marker=list(
                  size=2,
                  opacity=0.7
                ),
                x=~x, y=~y,
                hoverinfo='text', text=~Word,
                color=~Dominance, colors="Set3")
  }
  else { stop("Only supports 2- or 3-dimensional plotting!") }

  fig <- fig %>%
    layout(
      scene=list(
        xaxis=list(
          showspikes=FALSE,
          visible=FALSE),
        yaxis=list(
          showspikes=FALSE,
          visible=FALSE),
        zaxis=list(
          showspikes=FALSE,
          visible=FALSE)
      ),
      legend=list(
        x=0, y=1,
        title=list(text='Click to turn on/off'),
        itemsizing="constant"))

  return(fig)
}


# Day 17: Trick Shot

get_day17_input_path <- function() {
    paste(getwd(), "/2021/Day 17/Day17_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day17_input_path())

    area <- unlist(strsplit(readings[1], ": "))[2]
    axes <- unlist(strsplit(area, ", "))

    x_range <- parse_points(axes[1])
    y_range <- parse_points(axes[2])

    # Optimal velocity should be the number that reaches velocity of 0
    # closest to the left border of the target zone
    min_x <- min(x_range)

    opt_velocity <- 1
    while (sum(1:opt_velocity) < min_x) {
        opt_velocity <- opt_velocity + 1
    }

    # Optimal height angle should be the number where the next gravity addition
    # lands closest to the bottom border of the target zone
    min_y <- min(y_range)

    opt_angle <- abs(min_y) - 1
    target_y <- - (opt_angle + 1)

    cat("Optimal input:", opt_velocity, ",", opt_angle, "\n")
    cat("Lands at:", sum(1:opt_velocity), ",", target_y, "\n")
    cat("Heighest point:", sum(1:opt_angle), "\n")
}

part2 <- function() {
    readings <- readLines(get_day17_input_path())

    area <- unlist(strsplit(readings[1], ": "))[2]
    axes <- unlist(strsplit(area, ", "))

    x_range <- parse_points(axes[1])
    y_range <- parse_points(axes[2])

    safe_initial_velocities <- 0

    angle_lo_bound <- min(y_range)
    angle_hi_bound <- abs(min(y_range))

    # Determined from Part 1
    velocity_lo_bound <- 17
    velocity_hi_bound <- max(x_range)

    for (x in velocity_lo_bound:velocity_hi_bound) {
        for (y in angle_lo_bound:angle_hi_bound) {
            cur_x <- x
            cur_y <- y
            velocity <- x
            gravity <- 1
            while (!passed_target_area(cur_x, cur_y, x_range, y_range)) {
                if (in_target_area(cur_x, cur_y, x_range, y_range)) {
                    safe_initial_velocities <- safe_initial_velocities + 1
                    break
                }
                if (velocity > 0) {
                    velocity <- velocity - 1
                    cur_x <- cur_x + velocity
                }
                cur_y <- cur_y + (y - gravity)
                gravity <- gravity + 1
            }
        }
    }

    cat("Safe Velocities:", safe_initial_velocities, "\n")
}

parse_points <- function(axis) {
    range <- unlist(strsplit(axis, "="))
    points <- as.numeric(unlist(strsplit(range[2], "\\..")))
    points[1]:points[2]
}

passed_target_area <- function(x, y, x_range, y_range) {
    x > max(x_range) || y < min(y_range)
}

in_target_area <- function(x, y, x_range, y_range) {
    x %in% x_range && y %in% y_range
}

part1()
part2()


# ==============================
# Analysis of simulation bias (population and strata level)
# Nuno Prista, SLU Aqua, 2019 @ KustMonitoring project
# ==============================

rm(list=ls()); graphics.off()

library(data.table)

# select site
	site<-"Norrbyn" # sites in c("Asköfjärden", "Galtfjärden","Gaviksfjärden","Holmön","Kinnbäcksfjärden","Kvädöfjärden_Warm","Lagnö","Långvindsfjärden","Norrbyn", "Råneå","Torhamn")

# select scenario
	scenario <- "AllocOrigin" # "AllocScenarioWhitefishN" # "AllocScenarioHerringN", "AllocOrigin"

# loads original data
	dir_inputs<-"001_Inputs/prepared_main/"
	load(file=paste("001_Inputs/prepared_main/",site,".Rdata",sep=""))

# loads simulated data (prepared)
	dir_sim_outputs <- paste("002_Sim_Outputs/",scenario,"/prepared/",sep="")
	load(file=paste(dir_sim_outputs, site, "_", scenario,"_5000sims_res_pop_prep.rdata", sep=""))
	load(file=paste(dir_sim_outputs, site, "_", scenario,"_5000sims_res_strata_prep.rdata", sep=""))

# ====================
# Analysis of bias
# ====================

	# ===================
	# Population level
	# ===================

		# mean
		tapply(boot_res_pop$boot_mean_bias_perc, boot_res_pop$SampSize, function(x) {mean(x, na.rm=TRUE)})
		do.call("rbind", tapply(boot_res_pop$boot_mean_bias_perc, boot_res_pop$SampSize, function(x) {quantile(x, na.rm=TRUE)}))
		do.call("rbind", tapply(boot_res_pop$boot_mean_bias_perc, paste(boot_res_pop$SampSize, boot_res_pop$variable), function(x) {quantile(x, na.rm=TRUE)}))

		# variance
		tapply(boot_res_pop$boot_var_bias_perc, boot_res_pop$SampSize, function(x) {mean(x, na.rm=TRUE)})
		do.call("rbind", tapply(boot_res_pop$boot_var_bias_perc, boot_res_pop$SampSize, function(x) {quantile(x, na.rm=TRUE)}))
		do.call("rbind", tapply(boot_res_pop$boot_var_bias_perc, paste(boot_res_pop$SampSize, boot_res_pop$variable), function(x) {quantile(x, na.rm=TRUE)}))

		# variance of the mean [variance of the bootstrap means]
		tapply(boot_res_pop$boot_var_mean_bias_perc, boot_res_pop$SampSize, function(x) {mean(x, na.rm=TRUE)})
		do.call("rbind", tapply(boot_res_pop$boot_var_mean_bias_perc, boot_res_pop$SampSize, function(x) {quantile(x, na.rm=TRUE)}))
		do.call("rbind", tapply(boot_res_pop$boot_var_mean_bias_perc, paste(boot_res_pop$SampSize, boot_res_pop$variable), function(x) {quantile(x, na.rm=TRUE)}))

	# ===================
	# Strata level
	# ===================

		# mean
		tapply(boot_res_strata$boot_mean_bias_perc, boot_res_strata$SampSize, function(x) {mean(x, na.rm=TRUE)})
		do.call("rbind", tapply(boot_res_strata$boot_mean_bias_perc, boot_res_strata$SampSize, function(x) {quantile(x, na.rm=TRUE)}))
		do.call("rbind", tapply(boot_res_strata$boot_mean_bias_perc, paste(boot_res_strata$SampSize, boot_res_strata$variable), function(x) {quantile(x, na.rm=TRUE)}))

		# variance  [mean of the bootstrap variances]
		tapply(boot_res_strata$boot_var_bias_perc, boot_res_strata$SampSize, function(x) {mean(x, na.rm=TRUE)})
		do.call("rbind", tapply(boot_res_strata$boot_var_bias_perc, boot_res_strata$SampSize, function(x) {quantile(x, na.rm=TRUE)}))
		do.call("rbind", tapply(boot_res_strata$boot_var_bias_perc, paste(boot_res_strata$SampSize, boot_res_strata$variable), function(x) {quantile(x, na.rm=TRUE)}))

		# variance of the mean  [variance of the bootstrap means]
		tapply(boot_res_strata$boot_var_mean_bias_perc, boot_res_strata$SampSize, function(x) {mean(x, na.rm=TRUE)})
		do.call("rbind", tapply(boot_res_strata$boot_var_mean_bias_perc, boot_res_strata$SampSize, function(x) {quantile(x, na.rm=TRUE)}))
		do.call("rbind", tapply(boot_res_strata$boot_var_mean_bias_perc, paste(boot_res_strata$SampSize, boot_res_strata$variable), function(x) {quantile(x, na.rm=TRUE)}))


n = 10
fade = 'darkgray'
pdf("k-q-plot.pdf", width=2.5, height=2.2, pointsize=8, family='serif')

par(mar=c(3.,3,1,1))

q.to.k = function(q,compression) {
    compression * (asin(2*q-1)/pi/2)
}

k.to.q = function(k,compression) {
    sin(k/compression*pi - pi/2)/2 + 0.5
}

q = seq(0,1,by=0.001)

plot(q, q.to.k(q, compression=n), type='l', lwd=2, xlab=NA, ylab=NA, xaxt='n', yaxt='n')
axis(side=1, at=(0:5)/5, mgp=c(1,0.5,0))
title(xlab=expression(italic(q)), line=1.3, cex.lab=1.5)
axis(side=2, at=seq(-5,5,by=1), mgp=c(1,0.6,0))
title(ylab=expression(italic(k)), line=1.5, cex.lab=1.5)

for (i in 0:n) {
    abline(h=i-5, col=fade)
    abline(v=k.to.q(i, compression=n), col=fade)
}
lines(q, q.to.k(q, compression=n), type='l', lwd=2)
dev.off()


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

par(mai=c(0.25,0,0,0),omi=c(0.4,0.2,0.5,0.2),pin=c(4,4),family="Lato Light",las=1)
library(Hmisc)
library(ineq)

# Read data and prepare chart

myData<-spss.get("myData/AEQU+.por",use.value.labels=T)
x2008<-subset(myData$EQINCOM1,myData$EQINCOM1 > 0 & myData$V2 == "STUDIEN-NR. 4600")
Lc.Eplus2008<-Lc(x2008)
x1988<-subset(myData$EQINCOM1,myData$EQINCOM1 > 0 & myData$V2 == "STUDIEN-NR. 1670")
x1988<-x1988[1:length(x2008)]
Lc.Eplus1988<-Lc(x1988)
x1<-Lc.Eplus1988$p
y1<-Lc.Eplus1988$L
x2<-Lc.Eplus2008$p
y2<-Lc.Eplus2008$L

# Define chart and other elements

plot(x1,y1,type="n",axes=F,xlab="cumulative percentage of population",ylab="cumulative percentage of income")
lines(x1,y1)
lines(x2,y2)
xx<-c(x1,rev(x1))
yy1<-c(y1,rev(y2))
yy2<-c(y1,rev(x1))
polygon(xx,yy1,col=rgb(191,239,255,80,maxColorValue=255),border=F)
polygon(xx,yy2,col=rgb(191,239,255,120,maxColorValue=255),border=F)
x<-array(c(0,1,0,1),dim=c(2,2))
lines(x,lwd=2,col="black")
text(0.08,0.585,"Uniform Distribution",adj=c(0,0))
text(0.82,0.29,"1988",adj=c(0,0))
text(0.92,0.435,"2008",adj=c(0,0))
arrows(0.4,0.3,0.8,0.3,length=0.10,angle=10,code=1,lwd=2,col="black")
arrows(0.65,0.45,0.9,0.45,length=0.10,angle=10,code=1,lwd=2,col="black")
arrows(0.49,0.6,0.6,0.6,length=0.10,angle=10,code=2,lwd=2,col="black")
source("scripts/inc_axes_with_lines_lorenz.r")

# Titling

mtext("Lorenz Curve of Income Distribution in 1988 and 2008",side=3,line=0.25,cex=1.45,family="Lato Black",outer=T,adj=0)
mtext("German General Social Survey",3,line=-2,adj=0,outer=T,cex=1.05,font=3)
mtext("Source: GESIS ZA 4600, ZA 1670",1,line=0.6,adj=1,outer=T,cex=0.85,font=3)
dev.off()


###########################################################################
#
# Mark Cembrowski, Janelia Research Campus, Nov 5 2016
#
# This script plots the single cell molecule count values for a given
# gene or set of genes.
#
###########################################################################

singleCellBarplot <- function(theGenes,rMax=-1,quiet=F){
	subMat <- scCa1[theGenes,]

	if(!quiet){
		# Print maximum values for genes.
		print('Maximum vals across all cells:')
		maxes <- apply(subMat,1,max)
		names(maxes) <- theGenes
		print(maxes)
	}

	stats <- cbind(
		apply(subMat,1,mean),
		apply(subMat,1,sd),
		apply(subMat,1,mean)-apply(subMat,1,sd),
		apply(subMat,1,mean)+apply(subMat,1,sd) )
	colnames(stats) <- c('mean','sd','lo','hi')
	stats <- as.data.frame(stats)
	stats[,'gene'] <- rownames(stats)

	# Set x limits for plotting; this will prevent any genes that are
	# not present in the Ziesel data from being labeled NA.
	theLimits <- theGenes

	gg <- ggplot(stats,aes(x=gene,y=mean))
	gg <- gg + geom_bar(stat='identity',colour='black',fill='white')
	gg <- gg + geom_errorbar(aes(ymin=lo,ymax=hi),width=0.5)
	gg <- gg + theme_bw()
	if(rMax>-1){
		gg <- gg + scale_y_continuous(lim=c(min(stats$lo),rMax))
	}
	gg <- gg + scale_x_discrete(limits=theLimits)
	gg <- gg + xlab('Gene') + ylab('Mean expression across CA1 PCs')

	print(gg)
}


#' Used to quickly output LaTeX code for a matrix in R.
#'
#' @param mat $A$, a matrix in R
#' @param in_mm Boolean for whether or not include an entering and exiting of
#'    math mode
#'
#' @return Latex code for the matrix $A$
#'
#' @export

latex.matrix = function(mat, in_mm = TRUE) {
  n = nrow(mat)
  m = ncol(mat)
  body = lapply(1:n, FUN = function(i) {
    if(i != n) {
      paste(paste(mat[i,], collapse = " & "), "\\\\\n")
    } else {
      paste(mat[i,], collapse = " & ")
    }
  })
  body = do.call(paste, body)
  if (in_mm) {
    cat("\\left[\\begin{array}{",rep("c", m),"}\n",
        body,
        "\n\\end{array}\\right]", sep = "")
  } else {
    cat("\\[\\left[\\begin{array}{",rep("c", m),"}\n",
        body,
        "\n\\end{array}\\right]\\]", sep = "")
  }
}


context("lambda")

test_that("simple mult", {
    fx = function(x) x*2
    x = array(1:10)

    re = lambda(~ fx(x), along=c(x=1))
    expect_equal(re, c(x*2))
})

test_that("matrix mult", {
    dot =  function(x, y) sum(x * y)
    a = matrix(1:6, ncol=2)
    b = t(a)

    re = lambda(~ dot(a, b), along=c(a=1, b=2))
    dimnames(re) = NULL #FIXME:
    expect_equal(re, a %*% b)
})


#Find factors

print_factors = function(n) {
print(paste("The factors of",n,"are:"))
for(i in 1:n) {
if((n %% i) == 0) {
print(i)
}
}
}
print_factors(4)
print_factors(7)
print_factors(12)


#Dati

omega1 <- 8.34
omega2 <- 11.22
denominatore <- 8.2944

domanda1 <- 10.646
domanda2_a <- 9.93
domanda2_b <- 10.61
domanda3 <- 11.09

#Svolgimento

EPSILON <- 0.001

f <- function(x) {
  ifelse(x < omega1, 0,
    ifelse(x >= omega1 && x < omega2, (x - omega1)^2/denominatore,
      ifelse(x >= omega2, 1, NaN)))
}

f_calc <- function(x) {
  (x - omega1)^2/denominatore
}

par(bg = "black", fg = "White")
plot.new()
par(new = TRUE)
plot(Vectorize(f), xlab = "x", from = omega1-1, to = omega2+1,
     type = "l", ylab = "F(x)", col = "Yellow2",
     col.axis = "white", col.lab = "white", lwd = 2)

#for(i in 2:(length(regions)-1)) { # Generazione di linee e punti del grafico
  # abline(v = regions[i], lty="dotted", col = "Gray")
  # abline(h = f_values[i], lty="dashed", col = "azure2") <- se qualcuno volesse le linee verticali
  # points(regions[i], f_values[i], col = "Blue4", bg = "Blue4", pch = 21, cex = 0.8)
  # points(regions[i], f_values[i-1], col = "Blue4", pch = 21, cex = 0.8)
#}
# for(i in floor(omega1-1):floor(omega2+2)) {
#   abline(v = i, lty="dotted", col = "Gray")
# }

for(i in seq(0, 1, 0.5)) {
  abline(h = i, lty="dotted", col = "Gray")
}

for(i in seq(6, 31, 0.5)) {
  abline(v = i, lty="dotted", col = "Gray")
}

print(f(domanda1), digits=22)
print(f(domanda2_b)-f(domanda2_a), digits=22)
print(f(domanda3)-f(-domanda3), digits=22)


library(tidyverse)
library(dslabs)
data(heights)

# compute average and standard deviation for males
s <- heights %>%
    filter(sex == "Male") %>%
    summarize(average = mean(height), standard_deviation = sd(height))

# access average and standard deviation from summary table
s$average
s$standard_deviation

# compute median, min and max
heights %>%
    filter(sex == "Male") %>%
    summarize(median = median(height),
                       minimum = min(height),
                       maximum = max(height))

# alternative way to get min, median, max in base R
quantile(heights$height, c(0, 0.5, 1))

# generates an error: summarize can only take functions that return a single value
heights %>%
    filter(sex == "Male") %>%
    summarize(range = quantile(height, c(0, 0.5, 1)))

#Demonstrate the use of dot placeholder
murders <- murders %>% mutate(murder_rate = total/population*100000)
summarize(murders, mean(murder_rate))

# calculate US murder rate, generating a data frame
us_murder_rate <- murders %>%
    summarize(rate = sum(total) / sum(population) * 100000)
us_murder_rate

# extract the numeric US murder rate with the dot operator
us_murder_rate %>% .$rate


#HISTOGRAMS
par(mfrows=c(2,2))
hist(mtcars$mpg)

hist(mtcars$mpg, breaks=12, col='red', xlab='Miles per Gallon', main='Colored histogram with 12 bins')

hist(mtcars$mpg, breaks=12,col='red', xlab='Miles per Gallon', main='Histogram, rug plot, density curve')
rug(jitter(mtcars$mpg))
lines(density(mtcars$mpg), col='blue', lwd=2)

x<-mtcars$mpg
h<- hist(x, breaks=12, col='red', xlab='Miles per Gallon', main='Histogram with normal curve and box')
xfit<-seq(min(x), max(x), length=40)
yfit<-dnorm(xfit, mean=mean(x), sd=sd(x))
yfit<-yfit*diff(h$mids[1:2])*length(x)
lines(xfit, yfit, col='blue', lwd=2)
box(x)


library(e1071)
plot(iris)
plot(iris$Sepal.Length, iris$Sepal.Width,col=iris$Species)
plot(iris$Petal.Length, iris$Petal.Width,col=iris$Species)
s<-sample(150,100)
s
col<-c("Petal.Length","Petal.Width","Species")
iris_train<-iris[s,col]
iris_test<-iris[-s,col]
svmfit<-svm(Species~.,data = iris_train,kernel="linear",cost=.1,scale = FALSE)
print(svmfit)
plot(svmfit,iris_train[,col])
#tuned<-tune(svm, Species~.,data=iris_train, kernel="linear", ranges = list(cost=c(0.001,0.01,.1,1,10,100)))
#summary(tuned)
p<-predict(svmfit, iris_test[,col],type="class")
plot(p)
table(p,iris_test[,20])
mean(p==iris_test[,20])


# [Membaca data dengan fungsi read.csv](https://academy.dqlab.id/main/livecode/7/14/50)
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan
pelanggan[c("Nama.Pelanggan","Profesi")]
pelanggan[c("Jenis.Kelamin", "Umur", "Profesi", "Tipe.Residen")]

# [Vector untuk Menyimpan Nama Field](https://academy.dqlab.id/main/livecode/7/14/62)
# Membaca data csv dan dimasukkan ke variable pelanggan
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
# Buat variable field_yang_digunakan dengan isi berupa vector "Jenis.Kelamin", "Umur" dan "Profesi"
field_yang_digunakan <- c("Jenis.Kelamin", "Umur", "Profesi")
# Tampilan data pelanggan dengan nama kolom sesuai isi vector field_yang_digunakan
pelanggan[field_yang_digunakan]

# [Konversi Data dengan data.matrix](https://academy.dqlab.id/main/livecode/7/14/63)
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
# [Menggabungkan Hasil Konversi](https://academy.dqlab.id/main/livecode/7/14/64)
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt",sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
# Penggabungan data
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
# Tampilkan kembali data hasil penggabungan
pelanggan

# [Menormalisasikan Nilai Belanja](https://academy.dqlab.id/main/livecode/7/14/65)
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
# Normalisasi Nilai
pelanggan$NilaiBelanjaSetahun <- pelanggan$NilaiBelanjaSetahun / 1000000

# [Membuat Data Master](https://academy.dqlab.id/main/livecode/7/14/66)
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Residen <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])

# [Fungsi kmeans](https://academy.dqlab.id/main/livecode/7/15/52)
# Bagian Data Preparation
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Profesi <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
pelanggan$NilaiBelanjaSetahun <- pelanggan$NilaiBelanjaSetahun/1000000
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
# Bagian K-Means
set.seed(100)
# fungsi kmeans untuk membentuk 5 cluster dengan 25 skenario random dan simpan ke dalam variable segmentasi
segmentasi <- kmeans(x=pelanggan[field_yang_digunakan], centers=5, nstart=25)
# tampilkan hasil k-means
segmentasi

# [Analisa Hasil Clustering Vector](https://academy.dqlab.id/main/livecode/7/15/53)
# Bagian Data Preparation
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Profesi <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
pelanggan$NilaiBelanjaSetahun <- pelanggan$NilaiBelanjaSetahun/1000000
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
# Bagian K-Means
set.seed(100)
segmentasi <- kmeans(x=pelanggan[field_yang_digunakan], centers=5, nstart=25)
# Penggabungan hasil cluster
segmentasi$cluster
pelanggan$cluster <- segmentasi$cluster
str(pelanggan)

# [Analisa Hasil Cluster Size](https://academy.dqlab.id/main/livecode/7/15/54)
length(which(pelanggan$cluster == 2))

# [Melihat Data pada Cluster ke-N](https://academy.dqlab.id/main/livecode/7/15/68)
pelanggan[which(pelanggan$cluster == 3),]
pelanggan[which(pelanggan$cluster == 4),]
pelanggan[which(pelanggan$cluster == 5),]

# [Analisa Hasil Cluster Means](https://academy.dqlab.id/main/livecode/7/15/57)
segmentasi$centers

# [Analisa Hasil Sum of Squares](https://academy.dqlab.id/main/livecode/7/15/69)
# Bagian Data Preparation
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Profesi <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
pelanggan$NilaiBelanjaSetahun <- pelanggan$NilaiBelanjaSetahun/1000000
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
# Membandingkan dengan 2 cluster kmeans, masing-masing 2 dan 5
set.seed(100)
kmeans(x=pelanggan[field_yang_digunakan], centers=2, nstart=25)

set.seed(100)
kmeans(x=pelanggan[field_yang_digunakan], centers=5, nstart=25)

# [Available Components](https://academy.dqlab.id/main/livecode/7/15/71)
# Bagian Data Preparation
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Profesi <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
pelanggan$NilaiBelanjaSetahun <- pelanggan$NilaiBelanjaSetahun/1000000
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
# Bagian K-Means
set.seed(100)
segmentasi <- kmeans(x=pelanggan[field_yang_digunakan], centers=5, nstart=25)
segmentasi$withinss
segmentasi$cluster
segmentasi$tot.withinss

# [Simulasi Jumlah Cluster dan SS](https://academy.dqlab.id/main/livecode/7/16/76)
# Bagian Data Preparation
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Profesi <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
pelanggan$NilaiBelanjaSetahun <-pelanggan$NilaiBelanjaSetahun/1000000
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
# Bagian K-Means
set.seed(100)
sse <- sapply(1:10, function(param_k) {kmeans(pelanggan[field_yang_digunakan], param_k, nstart=25)$tot.withinss})
sse

# [Grafik Elbow Effect](https://academy.dqlab.id/main/livecode/7/16/77)
library(ggplot2)
# Bagian Data Preparation
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Profesi <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
pelanggan$NilaiBelanjaSetahun <- pelanggan$NilaiBelanjaSetahun/1000000
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
# Bagian K-Means
set.seed(100)
sse <- sapply(1:10, function(param_k){kmeans(pelanggan[field_yang_digunakan], param_k, nstart=25)$tot.withinss})
jumlah_cluster_max <- 10
ssdata = data.frame(cluster=c(1:jumlah_cluster_max),sse)
ggplot(ssdata, aes(x=cluster,y=sse)) +
  geom_line(color="red") + geom_point() +
  ylab("Within Cluster Sum of Squares") + xlab("Jumlah Cluster") +
  geom_text(aes(label=format(round(sse, 2), nsmall = 2)),hjust=-0.2, vjust=-0.5) +
  scale_x_discrete(limits=c(1:jumlah_cluster_max))

# [Menamakan Segmen](https://academy.dqlab.id/main/livecode/7/17/80)
# Lengkapi dengan dua vector bernama cluster dan Nama.Segmen
Segmen.Pelanggan <- data.frame(cluster = c(1,2,3,4,5),
                               Nama.Segmen = c("Silver Youth Gals", "Diamond Senior Member",
                                               "Gold Young Professional", "Diamond Professional",
                                               "Silver Mid Professional"))

# [Menggabungkan Referensi](https://academy.dqlab.id/main/livecode/7/17/81)
# Membaca data csv dan dimasukkan ke variable pelanggan
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
pelanggan$NilaiBelanjaSetahun = pelanggan$NilaiBelanjaSetahun/1000000
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Residen <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
# Bagian K-Means
set.seed(100)
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
segmentasi <- kmeans(x=pelanggan[field_yang_digunakan], centers=5, nstart=25)
Segmen.Pelanggan <- data.frame(cluster=c(1,2,3,4,5),
                               Nama.Segmen=c("Silver Youth Gals", "Diamond Senior Member",
                                             "Gold Young Professional", "Diamond Professional",
                                             "Silver Mid Professional"))
# Menggabungkan seluruh aset ke dalam variable Identitas.Cluster
Identitas.Cluster <- list(Profesi=Profesi,
                          Jenis.Kelamin=Jenis.Kelamin,
                          Tipe.Residen=Tipe.Residen,
                          Segmentasi=segmentasi,
                          Segmen.Pelanggan=Segmen.Pelanggan,
                          field_yang_digunakan=field_yang_digunakan)

# [Menyimpan Objek dalam Bentuk File](https://academy.dqlab.id/main/livecode/7/17/82)
# Membaca data csv dan dimasukkan ke variable pelanggan
pelanggan <- read.csv("https://academy.dqlab.id/dataset/customer_segments.txt", sep="\t")
pelanggan_matrix <- data.matrix(pelanggan[c("Jenis.Kelamin", "Profesi", "Tipe.Residen")])
pelanggan <- data.frame(pelanggan, pelanggan_matrix)
pelanggan$NilaiBelanjaSetahun = pelanggan$NilaiBelanjaSetahun/1000000
Profesi <- unique(pelanggan[c("Profesi","Profesi.1")])
Jenis.Kelamin <- unique(pelanggan[c("Jenis.Kelamin","Jenis.Kelamin.1")])
Tipe.Residen <- unique(pelanggan[c("Tipe.Residen","Tipe.Residen.1")])
# Bagian K-Means
set.seed(100)
field_yang_digunakan = c("Jenis.Kelamin.1", "Umur", "Profesi.1", "Tipe.Residen.1","NilaiBelanjaSetahun")
segmentasi <- kmeans(x=pelanggan[field_yang_digunakan], centers=5, nstart=25)
Segmen.Pelanggan <- data.frame(cluster=c(1,2,3,4,5),
                               Nama.Segmen=c("Silver Youth Gals", "Diamond Senior Member",
                                             "Gold Young Professional", "Diamond Professional",
                                             "Silver Mid Professional"))

Identitas.Cluster <- list(Profesi=Profesi,
                          Jenis.Kelamin=Jenis.Kelamin,
                          Tipe.Residen=Tipe.Residen,
                          Segmentasi=segmentasi,
                          Segmen.Pelanggan=Segmen.Pelanggan,
                          field_yang_digunakan=field_yang_digunakan)
saveRDS(Identitas.Cluster, "cluster.rds")

# [Data Baru](https://academy.dqlab.id/main/livecode/7/18/86)
databaru <- data.frame(Customer_ID="CUST-100",
                       Nama.Pelanggan="Rudi Wilamar",
                       Umur=20,
                       Jenis.Kelamin="Wanita",
                       Profesi="Pelajar",
                       Tipe.Residen="Cluster",
                       NilaiBelanjaSetahun=3.5)
databaru

# [Memuat Objek Clustering dari File](https://academy.dqlab.id/main/livecode/7/18/87)
Identitas.Cluster <- readRDS(file="cluster.rds")
Identitas.Cluster

# [Merge dengan Data Referensi](https://academy.dqlab.id/main/livecode/7/18/88)
databaru <- data.frame(Customer_ID="CUST-100",
                       Nama.Pelanggan="Rudi Wilamar",
                       Jenis.Kelamin="Wanita",
                       Profesi="Pelajar",
                       Tipe.Residen="Cluster",
                       NilaiBelanjaSetahun=3.5)
Identitas.Cluster <- readRDS(file="cluster.rds")
# Masukkan perintah untuk penggabungan data
databaru <- merge(databaru, Identitas.Cluster$Profesi)
databaru <- merge(databaru, Identitas.Cluster$Jenis.Kelamin)
databaru <- merge(databaru, Identitas.Cluster$Tipe.Residen)
databaru

# [Menentukan Cluster](https://academy.dqlab.id/main/livecode/7/18/89)
# membuat data baru
databaru <- data.frame(Customer_ID="CUST-100",
                       Nama.Pelanggan="Rudi Wilamar",
                       Umur=32,
                       Jenis.Kelamin="Wanita",
                       Profesi="Pelajar",
                       Tipe.Residen="Cluster",
                       NilaiBelanjaSetahun=3.5)

Identitas.Cluster <- readRDS(file="cluster.rds")

databaru <- merge(databaru, Identitas.Cluster$Profesi)
databaru <- merge(databaru, Identitas.Cluster$Jenis.Kelamin)
databaru <- merge(databaru, Identitas.Cluster$Tipe.Residen)
# menentukan data baru di cluster mana
which.min(sapply(1:5,
                 function(x)
                   sum((databaru[Identitas.Cluster$field_yang_digunakan] -
                          Identitas.Cluster$Segmentasi$centers[x,])^2)))

Identitas.Cluster$Segmen.Pelanggan[which.min(sapply(1:5,
                                                    function(x)
                                                      sum((databaru[Identitas.Cluster$field_yang_digunakan] -
                                                             Identitas.Cluster$Segmentasi$centers[x,])^2))),]

R/Kelas Penerapan/Data Science in Marketing Customer Segmentation/Data Science in Marketing Customer Segmentation.r


n <- 7

for (i in 1:n){
  print(i)
}

for (i in 1:n){
  print(i / 2)
}

# for loop on indexes
values <- rep(NA, 7)

for (i in 1:n){
  values[i] <- i / 2
}

values

for (v in values){
  print(v)
}

q <- 10  # same thing but using variable instead of retyping digit
values <- rep(NA, q)

for (i in 1:q){
  values[i] <- i / 2
}

values

for (v in values){
  print(v)
}


#This script will compute the bulk modulus from a plot of pressure vs volumetric strain.
#
#License information:
#
#MIT License
#
#Copyright (c) 2019 Will Pisani
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

if (Sys.info()['sysname']=="Linux"){
  setwd("/path/to/directory/on/linux")
} else {
# Paths in Windows in R require \\ instead of \
 setwd("C:\\path\\to\\directory\\on\\Windows")

}

#Read in csv file
bkfile <-"your_file_name_here_BK_RData.csv"
bkdat <- read.csv(bkfile)
bkfilename <- strsplit(bkfile,"\\.")[[1]]

#create vectors for pressure and volumetric strain
bkpress <- bkdat[,1] *1.01325*10^5/1000000 # Converting atm to MPa
bkvolstrain <- bkdat[,2]
bkendpoint <- length(bkpress)
bkpress <- bkpress[1:bkendpoint]
bkvolstrain <- bkvolstrain[1:bkendpoint]

#fit a regular linear model to data, this is for the segmented command
lin.mod <- lm(bkpress ~ bkvolstrain)

#use segmented package to calculated breakpoint (bk)
segmented.mod <- segmented::segmented(lin.mod, seg.Z = ~bkvolstrain, psi=-0.05)
#Define moving average function
#mav <- function(x,n=1000){filter(x,rep(1/n,n),sides=2)}

#bkdens_ma <- mav(bkdens,1500)

# Get point at bk_value
# Get slope of first line
bk_modulus <- summary(segmented.mod)$coefficients[2,1]/1000 # Going from MPa to GPa
bk_modulus <- abs(round(bk_modulus,2)) # Round to 2 decimal places
bk_value <- segmented.mod$psi[2]
bk_value_stderror <- segmented.mod$psi[3]
bk_y_value <- segmented.mod$coefficients[2]*bk_value+segmented.mod$coefficients[1]

# Save regular plot to pdf
pdf(paste(bkfilename[1],"pdf",sep="."))
plot(bkvolstrain,bkpress,col="blue",xlim=c(0,min(bkvolstrain)),ylim=c(-2000,3500),main = paste("Bulk Modulus=",bk_modulus,"GPa"),xlab = 'Volumetric strain',ylab = 'Pressure (MPa)')
#plot(bktemp,bkdens)
par(new = TRUE)
plot(segmented.mod,col="red",xlim=c(0,min(bkvolstrain)),ylim=c(-2000,3500),xlab = '',ylab = '',rug=FALSE)
par(new = TRUE)
plot(bk_value,bk_y_value,pch=24,col="white",bg="white",xlim=c(0,min(bkvolstrain)),ylim=c(-2000,3500),xlab = '',ylab = '')
dev.off()


# code

library(ggplot2)
library(GGally)
install.packages('matrixStats')
library('matrixStats')
install.packages("corrplot")
library(corrplot)#, method="ellipse")

setwd('~/Developer/stat/PracticalStatisticsForDataScientists/01/')
dir_data = '~/Developer/stat/PracticalStatisticsForDataScientists/data/'

state <- read.csv(file = file.path(dir_data, 'state.csv'))
View(state)

dat_state = data.frame(Population = state$Population, MurderRate=state$Murder.Rate, row.names = state$State)
View(dat_state)
p = ggpairs(dat_state)
p = ggplot(state, aes(Population)) + geom_histogram()

# 01.03.
mean(state[["Population"]])
mean(state$Population)
mean(state$Population, trim = .1)
median(state$Population)
weighted.mean(state$Murder.Rate, w = state$Population)

weightedMedian(state$Murder.Rate, w = state$Population)

# 01.04.
sd(state$Population)
IQR(state$Population)
mad(state$Population)

# 01.05.
quantile(state$Murder.Rate, p=c(.05, .25, .5, .75, .95))

boxplot(state$Population/1000000, ylab='Population (millions)')

p <- ggplot(state, aes(Population))
p <- p + geom_boxplot(aes(ymin=min(state$Population), lower=quantile(state$Population, .25), middle=median(state$Population), upper=quantile(state$Population, .75), ymax=max(state$Population)), stat='identity')
p

breaks <- seq(from=min(state$Population), to=max(state$Population), length=11)
pop_freq <- cut(state$Population, breaks=breaks, right=TRUE, include.lowest=TRUE)
table(pop_freq)

hist(state$Population, breaks=breaks, xlab='Population (millions)', main='Population')

hist(state$Murder.Rate, freq=FALSE, main='Murder Rate', xlab='Murder Rate')
lines(density(state$Murder.Rate), lwd=3, col='blue')

# 01.06.
dfw = read.csv(file.path(dir_data, 'dfw_airline.csv'))
View(dfw)
# cause = c('Carrier', 'ATC', 'Weather', 'Security', 'Inbound')
# delay = c(23.02, 30.40, 4.03, 0.12, 42.43)
# dfw = data.frame(cause=cause, delay=delay)

barplot(dfw)
p <- ggplot(dfw) + geom_col(aes(cause, delay))
p

# 01.07.
sp500_px = read.csv(file.path(dir_data, 'sp500_px.csv'), row.names = 1)
sp500_sym = read.csv(file.path(dir_data, 'sp500_sym.csv'))
View(sp500_px)
View(sp500_sym)

etfs = sp500_px[row.names(sp500_px) > "2012-07-01",
                sp500_sym[sp500_sym$sector=="etf", 'symbol']]
View(etfs)

corrplot(cor(etfs))
p <- ggcorr(etfs, palette='Viridis') + scale_colour_viridis_c()
p

p <- ggplot(sp500_px, aes(T, VZ)) + geom_point(alpha=.5)
p

# 01.08.
house0 <- read.csv(file.path(dir_data, 'kc_tax.csv'))
View(house0)

p <- ggplot(house0, aes(SqFtTotLiving, TaxAssessedValue)) + stat_binhex(colour='white')
p <- p + theme_bw() + scale_fill_gradient(limits=c(0, 9000), low = 'white', high = 'blue')# + labs(x=)
p

airline_stats = read.csv(file.path(dir_data, 'airline_stats.csv'))
airline_stats$pct_delay = airline_stats$pct_atc_delay + airline_stats$pct_carrier_delay + airline_stats$pct_weather_delay
View(airline_stats)
boxplot(pct_carrier_delay ~ airline, data=airline_stats, ylim=c(0, 30), ylab='Percent of airline delays by carrier', title='Percent of airline delays by carrier')

p <- ggplot(airline_stats, aes(airline, pct_carrier_delay)) +
  geom_violin(draw_quantiles = c(.25, .5, .75), fill='lightblue') +
  # geom_boxplot(alpha=.2) +
  # geom_jitter(height = 0, width = .1, alpha=.1)
  ylim(0, 30) +
  ylab('Percent Delayed')
p


library(tidyverse)
library(data.table)
# library(bit64)
library(scales)
library(readxl)
# Extracted revenue and expenditure data is found here:
# https://bythenumbers.sco.ca.gov/Finance-Application/City-Revenues/rrtv-rsj9
# https://bythenumbers.sco.ca.gov/Finance-Application/City-Expenditures/ju3w-4gxp

setwd('~/../Downloads')

pop_by_city = read_excel('SUB-IP-EST2019-ANNRNK.xlsx', 'pop_raw') %>%
  pivot_longer(
    cols = matches('[0-9]{4}')
  ) %>%
  rename(
    Entity_Name_Orig = `Geographic Area`,
    Fiscal_Year = name,
    popluation = value
  ) %>%
  mutate(
    Fiscal_Year = as.numeric(Fiscal_Year),
    state = str_extract(Entity_Name_Orig, ', .+') %>% str_remove(', ') %>% str_trim(),
    Entity_Name = str_remove(Entity_Name_Orig, ' city.+') %>% str_trim() %>% str_remove('\\(.+')
  ) %>%
  filter(
    state == 'California'
  )

View(pop_by_city)

City_Revenues = read_csv('City_Revenues.csv')
names(City_Revenues) = names(City_Revenues) %>% str_replace_all('[ ]+', '_')

City_Revenues = mutate(City_Revenues,
                       Estimated_Population_int = as.integer(Estimated_Population),
                           value_per_capita = Value / Estimated_Population_int) %>%
  data.table()

total_revenues_by_fiscal_year = City_Revenues[, {
  list(
    category_total = sum(Value, na.rm = T)
  )
}, by = list(Entity_Name, Fiscal_Year, Category)] %>%
  group_by(Entity_Name, Fiscal_Year) %>%
  summarize(
    total_revenues = sum(category_total, na.rm=T)
  ) %>%
  ungroup()

City_Expenditures = read_csv('City_Expenditures.csv')
names(City_Expenditures) = names(City_Expenditures) %>% str_replace_all('[ ]+', '_')

City_Expenditures = mutate(City_Expenditures,
                           value_per_capita = Value / Estimated_Population) %>%
  data.table()

total_expenditures_by_fiscal_year = City_Expenditures[, {
  list(
    category_total = sum(Value, na.rm = T)
  )
}, by = list(Entity_Name, Fiscal_Year, Category)] %>%
  group_by(Entity_Name, Fiscal_Year) %>%
  summarize(
    total_expenditures = sum(category_total, na.rm=T)
  ) %>%
  ungroup()

police_current_expenditures = filter(City_Expenditures,
                                     Field_Name  %in% c('EXP_POLICE_PUB', 'CURR_EXP_POLICE')) %>%
  arrange(
    Entity_Name, -Fiscal_Year
  )

total_exp_rev_police =
  left_join(
    pop_by_city ,
    total_expenditures_by_fiscal_year
  ) %>%
  left_join(
    total_revenues_by_fiscal_year
  ) %>%
  left_join(
    police_current_expenditures %>% select(Entity_Name, Fiscal_Year, current_police_exp = Value)
  ) %>%
  filter(Fiscal_Year %in% unique(total_expenditures_by_fiscal_year$Fiscal_Year)) %>%
  arrange(
    Entity_Name, Fiscal_Year
  )

total_exp_rev_police$rev_per_capita = total_exp_rev_police$total_revenues / total_exp_rev_police$popluation
total_exp_rev_police$police_exp_per_capita = total_exp_rev_police$current_police_exp / total_exp_rev_police$popluation
total_exp_rev_police$police_pct_revenue = total_exp_rev_police$current_police_exp / total_exp_rev_police$total_revenues

ggplot(total_exp_rev_police, aes(rev_per_capita, police_exp_per_capita)) +
  geom_point(alpha = 0.3) +
  geom_point(
    data = filter(total_exp_rev_police, Entity_Name %in% c('Santa Monica')),
    aes(colour = Entity_Name)
  ) +
  scale_colour_brewer(name='', palette = "Set1") +
  # scale_color_viridis_d(option = 'D') +
  stat_smooth(method = 'lm', se = F) +
  scale_x_continuous(labels = dollar) +
  scale_y_continuous(labels = dollar) +
  labs(
    x = 'Revenue Per Capita', y = 'Police Expenditure Per Capita',
    title = 'Overall City Revenues vs. Police Expenditures',
    subtitle = 'California Cities, 2010-2018',
    caption = 'Data: CA State Controller, Census'
  ) +
  theme_bw() +
  theme(
    plot.caption = element_text(face = 'italic', hjust = 0),
    plot.subtitle = element_text(face = 'italic')
  )

setwd("C:/Users/Owner/Dropbox/Politics")
ggsave('city_rev_vs_police_exp_ca.png', height = 8, width = 10, units = 'in', dpi = 800)

mean_police_exp = group_by(total_exp_rev_police, Entity_Name) %>%
  summarize(
    mean_police_per_cap = mean(police_exp_per_capita)
  ) %>%
  arrange(-mean_police_per_cap) %>%
  head(20) %>%
  mutate(
    Entity_Name_Factor = factor(Entity_Name, levels = rev(Entity_Name))
  )

ggplot(mean_police_exp, aes(Entity_Name_Factor, mean_police_per_cap)) +
  geom_bar(stat = 'identity', fill = 'steelblue') +
  geom_text(aes(label = dollar(mean_police_per_cap)), hjust = 1, size = 3) +
  coord_flip() +
  theme_bw() +
  labs(y = 'Average Per-Capita Police Expenditure', x = '',
       title = 'Top 20 CA Cities by Average Police Expenditure Per Capita',
       subtitle = '2010-2018',
       caption = 'Data: CA State Controller, Census'
       ) +
  theme(
    plot.caption = element_text(face = 'italic', hjust = 0),
    plot.subtitle = element_text(face = 'italic')
  )
ggsave('top_20_cities_exp.png', height = 8, width = 8, units = 'in', dpi = 800)
View(total_exp_rev_police)

Projects/Local government elections, finance/scripts/analyze_ca_city_revenue_expenditure_data.r


#' Rotate global coordinates in a data frame to model coordinates.
#'
#' This function reads in a data frame that contains
#' X and Y coordinates and converts those coordinates to a model coordinate system (i.e., zero rotation and X_off = Y_off = 0).
#' @param df This is the data frame containing the X and Y coordinates
#' @param X_off This is the global X coordinate offset
#' @param Y_off This is the global Y coordinate offset
#' @param ROT This is the rotation angle in units of degrees
#' @param Xin This is the dataframe column containing the X coordinate location
#' @param Yin This is the dataframe column containing the Y coordinate location
#' @export
#' @examples
#' obk_demo
#' # A tibble: 19 x 6
#'       ID     LITHO    K_cms           K       X       Y
#'    <chr>     <chr>    <dbl>       <dbl>   <dbl>   <dbl>
#'  1 MW-07      <NA> 5.88e-04  1.66677165 2980417 1927119
#'  2 MW-09        SW 2.58e-03  7.31338583 2980038 1927879
#'  3 MW-10      <NA> 2.51e-03  7.11496063 2980659 1927796
#'  4 MW-13      <NA> 2.22e-03  6.29291339 2980753 1927708
#'  5 MW-15        GM 2.00e-02 56.69291339 2980915 1927664
#'  6 MW-16        SW 6.07e-03 17.20629921 2981707 1928835
#'  7 MW-18        GM 3.91e-03 11.08346457 2981401 1929334
#'  8 MW-21        GM 9.10e-04  2.57952756 2981287 1928896
#'  9 MW-25        GM 1.25e-03  3.54330709 2981012 1928750
#' 10 MW-26     ML/GM 2.55e-03  7.22834646 2981059 1928830
#' 11 MW-27        GM 1.60e-03  4.53543307 2980973 1929291
#' 12 MW-29        GM 1.75e-04  0.49606299 2980824 1928950
#' 13 MW-30 sandstone 6.55e-04  1.85669291 2980486 1929689
#' 14 MW-31        ML 1.04e-05  0.02948031 2980409 1929362
#' 15 MW-32        ML 1.03e-02 29.19685039 2979395 1928257
#' 16 PZ-04     SP/ML 9.41e-06  0.02667402 2980207 1927028
#' 17 PZ-05     SP/GM 2.80e-04  0.79370079 2981367 1928068
#' 18 PZ-06        SW 3.06e-04  0.86740157 2981831 1927966
#'
#' X_off <- 2970450
#' Y_off <- 1926010
#' rot   <- -45
#' obk_demo %>% rot2mod(X_off = X_off, Y_off = Y_off, ROT = -45)
#' # A tibble: 19 x 8
#'       ID     LITHO    K_cms           K       X       Y     Xout      Yout
#'    <chr>     <chr>    <dbl>       <dbl>   <dbl>   <dbl>    <dbl>     <dbl>
#'  1 MW-07      <NA> 5.88e-04  1.66677165 2980417 1927119 6263.672  7831.879
#'  2 MW-09        SW 2.58e-03  7.31338583 2980038 1927879 5458.256  8100.912
#'  3 MW-10      <NA> 2.51e-03  7.11496063 2980659 1927796 5955.897  8481.173
#'  4 MW-13      <NA> 2.22e-03  6.29291339 2980753 1927708 6085.184  8486.123
#'  5 MW-15        GM 2.00e-02 56.69291339 2980915 1927664 6230.735  8569.561
#'  6 MW-16        SW 6.07e-03 17.20629921 2981707 1928835 5962.466  9957.563
#'  7 MW-18        GM 3.91e-03 11.08346457 2981401 1929334 5393.075 10093.737
#'  8 MW-21        GM 9.10e-04  2.57952756 2981287 1928896 5621.676  9703.563
#'  9 MW-25        GM 1.25e-03  3.54330709 2981012 1928750 5530.678  9405.567
#' 10 MW-26     ML/GM 2.55e-03  7.22834646 2981059 1928830 5507.973  9495.461
#' 11 MW-27        GM 1.60e-03  4.53543307 2980973 1929291 5120.889  9760.895
#' 12 MW-29        GM 1.75e-04  0.49606299 2980824 1928950 5256.879  9413.974
#' 13 MW-30 sandstone 6.55e-04  1.85669291 2980486 1929689 4495.396  9698.061
#' 14 MW-31        ML 1.04e-05  0.02948031 2980409 1929362 4671.784  9412.086
#' 15 MW-32        ML 1.03e-02 29.19685039 2979395 1928257 4736.611  7913.883
#' 16 PZ-04     SP/ML 9.41e-06  0.02667402 2980207 1927028 6179.576  7619.259
#' 17 PZ-05     SP/GM 2.80e-04  0.79370079 2981367 1928068 6264.471  9174.908
#' 18 PZ-06        SW 3.06e-04  0.86740157 2981831 1927966 6664.969  9430.704

rot2mod <- function(df,
                X_off = 0,
                Y_off = 0,
                ROT = 0,
                Xin = X,
                Yin = Y){

                Xin <- enquo(Xin)
                Yin <- enquo(Yin)
                RAD <- -ROT * pi / 180
                mutate(df,
                       Xout = ((!!Xin) - X_off) * cos(RAD) - ((!!Yin) - Y_off) * sin(RAD),
                       Yout = ((!!Xin) - X_off) * sin(RAD) + ((!!Yin) - Y_off) * cos(RAD)
                       )
                }


LISP Interpreter Run

[[[[[

 Proof that the halting problem is unsolvable by using
 it to construct a LISP expression that halts iff it doesn't.

]]]]]

define (turing x)
[Insert supposed halting algorithm here.]
let (halts? S-exp) false [<=============]
[Form ('x)]
let y [be] cons "' cons x nil [in]
[Form (('x)('x))]
let z [be] display cons y cons y nil [in]
[If (('x)('x)) has a value, then loop forever, otherwise halt]
if (halts? z) [then] eval z [loop forever]
              [else] nil [halt]

define      turing
value       (lambda (x) ((' (lambda (halts?) ((' (lambda (y) (
            (' (lambda (z) (if (halts? z) (eval z) nil))) (dis
            play (cons y (cons y nil)))))) (cons ' (cons x nil
            ))))) (' (lambda (S-exp) false))))

[
 (turing turing) decides whether it itself has a value,
 then does the opposite!

 Here we suppose it doesn't have a value,
 so it turns out that it does:
]

(turing turing)

expression  (turing turing)
display     ((' (lambda (x) ((' (lambda (halts?) ((' (lambda (
            y) ((' (lambda (z) (if (halts? z) (eval z) nil)))
            (display (cons y (cons y nil)))))) (cons ' (cons x
             nil))))) (' (lambda (S-exp) false))))) (' (lambda
             (x) ((' (lambda (halts?) ((' (lambda (y) ((' (lam
            bda (z) (if (halts? z) (eval z) nil))) (display (c
            ons y (cons y nil)))))) (cons ' (cons x nil))))) (
            ' (lambda (S-exp) false))))))
value       ()

define (turing x)
[Insert supposed halting algorithm here.]
let (halts? S-exp) true [<==============]
[Form ('x)]
let y [be] cons "' cons x nil [in]
[Form (('x)('x))]
let z [be] [[[[display]]]] cons y cons y nil [in]
[If (('x)('x)) has a value, then loop forever, otherwise halt]
if (halts? z) [then] eval z [loop forever]
              [else] nil [halt]

define      turing
value       (lambda (x) ((' (lambda (halts?) ((' (lambda (y) (
            (' (lambda (z) (if (halts? z) (eval z) nil))) (con
            s y (cons y nil))))) (cons ' (cons x nil))))) (' (
            lambda (S-exp) true))))

[
 And here we suppose it does have a value,
 so it turns out that it doesn't.

 It loops forever evaluating itself again and again!
]

(turing turing)

expression  (turing turing)
Storage overflow!


# ************************************************
### simon munzert
### time series
# ************************************************

source("packages.r")
source("functions.r")

## CRAN Task View on time series analysis
browseURL("https://cran.r-project.org/web/views/TimeSeries.html")

# ************************************************
# Working with times using the lubridate package -

library(lubridate)

# create a year-month-day variable
dates_char <- c("2017-09-01", "2017-08-31", "2017-08-30")
#dates_char <- c("20170901", "20170831", "20170830")
#dates_char <- c("2017/09/01", "2017/08/31", "2017/08/30")
class(dates_char)
plot(dates_char)
dates <- ymd(dates_char) # ymd() function to deal with year-month-day input
dates
plot(dates)

# other formats work, too
mdy("09-24-2017")
dmy("24.09.2017")

# there are many other things you can do with the package, for instance
  # work with time zones
  # compute time intervals
  # do arithmetic with date times (durations, periods)

# check out the following vignette for more info!
browseURL("https://cran.r-project.org/web/packages/lubridate/vignettes/lubridate.html")

# ************************************************
# Managing time series data with the xts package -

library(xts) # also loads zoo package

# import fertility data from Wooldridge
?fertil3
names(fertil3)
View(fertil3)
dat <- fertil3

# plot time series
plot(dat$gfr)

# create xts time series object
dat_ts <- ts(dat, frequency = 1, start = 1913) # creat time-series object: provide time of the first observation and frequency
dat_xts <- as.xts(dat_ts)

# dat_xts <- xts(dat, yearmon(dat$year)) # alternative assignment of time scheme with yearmon() function from the zoo package
plot(dat_xts$gfr)

# create lag variables
dat$gfr
lag(dat$gfr, 1)
lag(dat$gfr, 2)
lead(dat$gfr, 1)

# ************************************************
# Exercise: The Efficient Markets Hypothesis -----

data(nyse)
?nyse

# plot time series
plot(nyse$price, type = "l")
plot(nyse$return, type = "l")

# do past returns help explain future returns?
summary(lm(return ~ lag(return), data = nyse))

# Augmented Dickey-Fuller test
plot(nyse$t, nyse$return, type = "l")
adf.test(nyse$return[-1])

# How does the Dickey-Fuller test work?
  # tests the predictive power of an autoregressive process on the integrated time series
  # the null hypothesis for the test is that the time-series has a unit root (i.e. is not stationary).
  # the more negative it is, the stronger the rejection of the hypothesis that there is a unit root at some level of confidence
x <- rnorm(1000)  # no unit-root = stationary
adf.test(x)
y <- diffinv(x)   # contains a unit-root = non-stationary
adf.test(y)

# assess autocorrelation
acf(nyse$return, na.action = na.pass)
acf(nyse$price, na.action = na.pass, lag.max = 200)

# assess autocorrelation in disturbances using the Durbin-Watson test for autocorrelation
model <- lm(price ~ lag(price), data = nyse)
summary(model)
dwtest(model) # be careful; in LDV models, the DW test statistic uses to underestimate autocorrelation

# ************************************************
# Finite distributed lag (FDL) models ------------

# scatterplot
plot(dat$pe, dat$gfr)

# parallel time series
par(mfrow = c(2, 1))
plot(dat_xts$gfr)
plot(dat_xts$pe)

# OLS
model_out <- lm(gfr ~ pe, data = dat) # static model; only impact propensity assessed
summary(model_out)
model_out <- lm(gfr ~ pe + lag(pe, 1) + lag(pe, 2), data = dat) # assess long-run propensity with two lags
summary(model_out)

# ************************************************
# Lag dependent variable (LDV) models ------------

# check for autocorrelation
acf(dat$gfr, na.action = na.pass)
cor(dat$gfr, lag(dat$gfr), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 2), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 3), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 4), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 10), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 11), use = "pairwise.complete")
cor(dat$gfr, lag(dat$gfr, 12), use = "pairwise.complete")

# build simple LDV model
summary(lm(gfr ~ lag(gfr, 1) + lag(gfr, 2), data = dat))

# ************************************************
# Seasonal adjustment ----------------------------

unemp <- read_csv("../data/unemployment-ger-monthly.csv")
head(unemp)
names(unemp) <- c("month", "total")

unemp_ts <- ts(unemp$total, start=c(1948,1), frequency = 12)
plot(unemp_ts)
unemp_stl <- stl(unemp_ts, s.window = "periodic")
plot(unemp_stl)

summary(unemp_stl)
unemp_stl_df <- unemp_stl$time.series

# ************************************************
# Modeling linear trends; de-trending ------------

model_out <- lm(gfr ~ pe + ww2 + pill + t + I(t^2), data = dat) # static model
summary(model_out)

# add linear trend!
# fertility increasing or decreasing in sample period?
# add quadratic trend!
# replicate results via de-trending
# test for lagged effect of personal exemption


#' Density of a graph
#' @param x A graph.
#' @export
gdensity <- function(x) UseMethod("gdensity")

#' @export
#' @rdname gdensity
gdensity.igraph <- function(x) {
  n <- igraph::vcount(x)
  e <- igraph::ecount(x)

  e/n/n
}


v <- (1:3)^2
sv <- as.set(v)
2^sv