data <- read.csv(file="UrbanaData.csv",header = TRUE)
depot <- c(40.117844, -88.199203)

data$LAT <- (data$LAT-depot[1])*111.7
data$LON <- (data$LON-depot[2])*111.7*cos(40.1/360*2*pi)

plot(data$LON, data$LAT)
points(0, 0, col = "red")
n <- length(data$LON)
x <- cbind(data$LON, data$LAT)
d <- matrix(0, nrow = n, ncol = n)
for (i in 1:n)
  for (j in 1:n)
  {
    d[i, j] = abs(x[i,1]-x[j,1])+abs(x[i,2]-x[j,2])
  }

r <- abs(data$LON)+abs(data$LAT)
alpha <- atan(data$LAT/data$LON)
alpha <- ifelse(data$LAT<0 & data$LON<0, alpha-pi, alpha)
alpha <- ifelse(data$LAT>0 & data$LON<0, alpha+pi, alpha)
dmdori = data$Pop*4.4*7
dmd = qnorm(0.95, mean = data$Pop*4.4*7, sd = data$Pop*4.4*7*0.1)

p <- as.data.frame(cbind(data$BID, x, r, alpha, dmd))
colnames(p) <- c("id","lon","lat","r","alpha","demand")
plot(p$r, p$demand)
plot(data$LON, data$LAT, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 17)
high <- which(p$demand>=10000)
mid <- which(p$demand>=5000 & p$demand<10000)
points(p$lon[high], p$lat[high], col = "green")
points(p$lon[mid], p$lat[mid], col = "blue")

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

searchnode <- function(x, conn, node, N)
{
  for (j in 1:N)
    if (conn[x, j]==1)
    {
      if (node[j]==FALSE) return(j)
    }
  return(0)
}

renode <- function(x, dist, node)
{
  l <- order(dist[x, ], decreasing = FALSE)
  for (j in l)
    if (node[j]==FALSE) return(j)
}

getsolu <- function(ppp, mark)
{
  print(mark)
  x <- c(0, ppp$lon)
  y <- c(0, ppp$lat)
  N <- length(x)
  dot <- cbind(x, y)
  #creating dist matrix for dist(i,j)
  dist <- matrix(0, nrow = N, ncol = N)
  for (i in 1:N)
    for (j in 1:N)
    {
      dist[i, j] = abs(x[i]-x[j])+abs(y[i]-y[j])
    }

  # use prim algorithm to find MST, set point 1 as the start point
  conn <- matrix(0, nrow = N, ncol = N) # if city i & j are connected
  cost <- dist[1,] #distance from the tree to other nodes
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  father <- c(NA, rep(1, N-1))

  for (i in 1:(N-1))
  {
    newdist <- Inf
    for (j in 1:N)
    {
      #find a new node to join
      if (node[j]==FALSE & cost[j]<newdist)
      {
        newnode <- j
        newdist <- cost[j]
      }
    }
    node[newnode] <- TRUE
    conn[father[newnode], newnode] <- 1
    conn[newnode, father[newnode]] <- 1
    #update the cost and father using node j
    for (k in 1:N)
    {
      if (node[k]==FALSE & dist[newnode, k]<cost[k])
      {
        cost[k] = dist[newnode, k]
        father[k] = newnode
      }
    }
  }

  lstt <- c()
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  front <- 1
  totd <- 0
  for (i in 1:(N-1))
  {
    tail<- searchnode(front, conn, node, N)
    if (tail==0) {tail <- renode(front, dist, node)}
    lstt <- c(lstt, mark[tail-1])
    node[tail] <- TRUE
    if (i!=1)
    {segments(x[front], y[front], x[tail], y[tail], col = 2, lwd = "1")}
    totd <- totd+dist[front, tail]
    front <- tail
  }
  totd <- totd+dist[1, tail]
  print(lstt)
  #segments(x[1], y[1], x[tail], y[tail], col = "red", lwd = "1")
  return(c(totd, lstt))
}

########################3333
plot(data$LON, data$LAT, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 17)

ctg <- rep(0, n)
flag <- 1
tmp <- 0
pp <- p[order(p$alpha, decreasing = TRUE),]
#create data in the form suitable for Simulated Anealing
write.csv(pp, file="SA.csv")
lstt <- c()
for (i in 1:n)
{
  #i <- i+1
  if (tmp+pp$demand[i]>60000)
  {
    if (flag==1)
    {
      sol <- getsolu(pp[which(ctg==flag),], which(ctg==flag))
      solu <- sol[1]
      lstt <- sol[2:length(sol)]
    } else {
      sol <- c(getsolu(pp[which(ctg==flag),], which(ctg==flag)))
      solu <- c(solu, sol[1])
      lstt <- c(lstt, sol[2:length(sol)])
    }
    lstt <- c(lstt, flag+n)
    lines(c(0, pp$lon[i-1]*10), c(0, pp$lat[i-1]*10))
    flag <- flag+1
    tmp <- pp$demand[i]
    lines(c(0, pp$lon[i-1]*10), c(0, pp$lat[i-1]*10))

  } else {
    tmp <- tmp+pp$demand[i]
  }
  ctg[i] <- flag
}
lines(c(0, pp$lon[n]*10), c(0, pp$lat[n]*10))
sol <- c(getsolu(pp[which(ctg==flag),], which(ctg==flag)))
solu <- c(solu, sol[1])
lstt <- c(lstt, sol[2:length(sol)])
solu <- solu*0.621371

final <- data.frame(
  routelength = solu,
  demandpoint = sapply(1:flag, function(i) length(which(ctg==i))),
  totaldemand = sapply(1:flag, function(i) sum(pp$demand[which(ctg==i)]))
)
sum(final$routelength)

#####Cost Computation ##############33

cost <- (sum(solu)/25+sum(dmd)/5000/6)*15+
1.86*sum(solu)+0.1*sum(solu)+sum(solu*final$totaldemand*0.1/5000/2)+
0.2*(n+20)

cc <- rep(1,n)
cc <- ifelse(dmd>5000 & dmd<=10000, 5, cc)
cc <- ifelse(dmd>10000, 25, cc)
print(sum(cc*dmd)/5000)
print(sum(cc*p$demand)/5000+cost)

#provide initial solution for Simulated Anealing
write.table(t(as.matrix(lstt)), "ini2.txt")


# Modeling numbers of workers earning less than $15 per hour
## Survey object set-up
library(foreign)
dat <- read.dta("morg1214.dta")
library(survey)
tot.svy <- svydesign(ids = ~1, data = dat, weights = ~aweight)
earn.svy <- svydesign(ids = ~1, data = dat, weights = ~aearn_wt)

## National analysis
geography = "National"
t_employed <- as.integer(as.data.frame(svyby(~employed, ~ntl, tot.svy, svytotal, na.rm = TRUE))[3])
p_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages>0)))/(sum(subset(dat$aearn_wt, dat$awages >0))), 4)
t_u15 <- as.integer(t_employed*p_u15)

### by gender
t_female <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, sex == "f"), svytotal, na.rm = TRUE))[3]
p_female_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$sex == 'f')))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$sex == 'f'))), 4)
t_female_u15 <- as.integer(t_female*p_female_u15)

### Latinx
t_latinx <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, race_ethnicity == "Latinx"), svytotal, na.rm = TRUE))[3]
p_latinx_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$race_ethnicity == "Latinx")))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$race_ethnicity == "Latinx"))), 4)
t_latinx_u15 <- as.integer(t_latinx*p_latinx_u15)

### Black
t_black <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, race_ethnicity == "Black"), svytotal, na.rm = TRUE))[3]
p_black_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$race_ethnicity == "Black")))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$race_ethnicity == "Black"))), 4)
t_black_u15 <- as.integer(t_black*p_black_u15)

### millenials
t_youth <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, age <= 35), svytotal, na.rm = TRUE))[3]
p_youth_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$age <= 35)))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$age <= 35))), 4)
t_youth_u15 <- as.integer(t_youth*p_youth_u15)

ntlresults <- cbind(geography, t_employed, p_u15, t_u15, t_female, p_female_u15, t_female_u15, t_latinx, p_latinx_u15, t_latinx_u15, t_black, p_black_u15, t_black_u15, t_youth, p_youth_u15, t_youth_u15)

#total
t_employed <- as.integer(as.data.frame(svyby(~employed, ~ntl, tot.svy, svytotal, na.rm = TRUE))[3])
p_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages>0)))/(sum(subset(dat$aearn_wt, dat$awages >0))), 4)
t_u15 <- as.integer(t_employed*p_u15)

# by gender
t_female <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, sex == "f"), svytotal, na.rm = TRUE))[3]
p_female_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$sex == 'f')))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$sex == 'f'))), 4)
t_female_u15 <- as.integer(t_female*p_female_u15)

# Latinx
t_latinx <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, race_ethnicity == "Latinx"), svytotal, na.rm = TRUE))[3]
p_latinx_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$race_ethnicity == "Latinx")))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$race_ethnicity == "Latinx"))), 4)
t_latinx_u15 <- as.integer(t_latinx*p_latinx_u15)

# Latinx women
t_flatinx <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, race_ethnicity == "Latinx" &  sex == "f"), svytotal, na.rm = TRUE))[3]
p_flatinx_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$race_ethnicity == "Latinx" & dat$sex == "f")))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$race_ethnicity == "Latinx" & dat$sex == "f"))), 4)
t_flatinx_u15 <- as.integer(t_latinx*p_latinx_u15)

# Black
t_black <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, race_ethnicity == "Black"), svytotal, na.rm = TRUE))[3]
p_black_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$race_ethnicity == "Black")))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$race_ethnicity == "Black"))), 4)
t_black_u15 <- as.integer(t_black*p_black_u15)

# Black women
t_fblack <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, race_ethnicity == "Black" &  sex == "f"), svytotal, na.rm = TRUE))[3]
p_fblack_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$race_ethnicity == "Black" & dat$sex == "f")))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$race_ethnicity == "Black" & dat$sex == "f"))), 4)
t_fblack_u15 <- as.integer(t_black*p_black_u15)

# millenials
t_youth <- as.integer(svyby(~employed, ~ntl, subset(tot.svy, age <= 35), svytotal, na.rm = TRUE))[3]
p_youth_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages >0 & dat$age <= 35)))/(sum(subset(dat$aearn_wt, dat$awages >=0 & dat$age <= 35))), 4)
t_youth_u15 <- as.integer(t_youth*p_youth_u15)

geography = "national"

ntlresults <- cbind(geography, t_employed, p_u15, t_u15, t_female, p_female_u15, t_female_u15, t_latinx, p_latinx_u15, t_latinx_u15, t_black, p_black_u15, t_black_u15, t_youth, p_youth_u15, t_youth_u15)

ntlresults_expanded <- cbind(geography, t_employed, p_u15, t_u15, t_female, p_female_u15, t_female_u15, t_latinx, p_latinx_u15, t_latinx_u15, t_female_u15, t_flatinx, p_flatinx_u15, t_flatinx_u15, t_black, p_black_u15, t_black_u15, t_fblack, p_fblack_u15, t_fblack_u15, t_youth, p_youth_u15, t_youth_u15)

### State analysis
state <- c(levels(dat$stfips))
stresults <- data.frame()
for(i in 1:51){
  # Total
  st <- as.character(state[i])
  t_employed <- as.integer(as.data.frame(svyby(~employed, ~ntl, subset(tot.svy, stfips == st), svytotal, na.rm = TRUE))[3])
  p_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages > 0 & dat$stfips == st ))) / (sum(subset(dat$aearn_wt, dat$awages > 0 & dat$stfips == st))), 4)
  t_u15 <- as.integer(t_employed*p_u15)

  # Women
  t_female <- as.integer(as.data.frame(svyby(~employed, ~ntl, subset(tot.svy, stfips == st & sex == 'f'), svytotal, na.rm = TRUE))[3])
  p_female_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages > 0 & dat$stfips == st & dat$sex == 'f' ))) / (sum(subset(dat$aearn_wt, dat$awages > 0 & dat$stfips == st & dat$sex == 'f'))), 4)
  t_female_u15 <- as.integer(t_female*p_female_u15)

  # Latinx
  t_latinx <- as.integer(as.data.frame(svyby(~employed, ~ntl, subset(tot.svy, stfips == st & race_ethnicity == 'Latinx'), svytotal, na.rm = TRUE))[3])
  p_latinx_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages > 0 & dat$stfips == st & dat$race_ethnicity == 'Latinx' ))) / (sum(subset(dat$aearn_wt, dat$awages > 0 & dat$stfips == st & dat$race_ethnicity == 'Latinx'))), 4)
  t_latinx_u15 <- as.integer(t_latinx*p_latinx_u15)

  # Black
  t_black <- as.integer(as.data.frame(svyby(~employed, ~ntl, subset(tot.svy, stfips == st & race_ethnicity == 'Black'), svytotal, na.rm = TRUE))[3])
  p_black_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages > 0 & dat$stfips == st & dat$race_ethnicity == 'Black' ))) / (sum(subset(dat$aearn_wt, dat$awages > 0 & dat$stfips == st & dat$race_ethnicity == 'Black'))), 4)
  t_black_u15 <- as.integer(t_black*p_black_u15)

  # Millenials
  t_youth <- as.integer(as.data.frame(svyby(~employed, ~ntl, subset(tot.svy, stfips == st & age <= 35), svytotal, na.rm = TRUE))[3])
  p_youth_u15 <- round((sum(subset(dat$aearn_wt, dat$awages <=15 & dat$awages > 0 & dat$stfips == st & dat$age <= 35 ))) / (sum(subset(dat$aearn_wt, dat$awages > 0 & dat$stfips == st & dat$age <= 35))), 4)
  t_youth_u15 <- as.integer(t_youth*p_youth_u15)

  # Results
  tmpresults <- cbind(st, t_employed, p_u15, t_u15, t_female, p_female_u15, t_female_u15, t_latinx, p_latinx_u15, t_latinx_u15, t_black, p_black_u15, t_black_u15, t_youth, p_youth_u15, t_youth_u15)
  stresults <- rbind(stresults, tmpresults)

}

colnames(stresults)[1] <- "geography"
total <- as.data.frame(rbind(ntlresults, stresults))
write.csv(total, "workers_under15.csv")


### kClass: Generates k-class estimators (point est, se, p-value, and confint)
###         Must run ivmodel before you run this code
### INPUT: ivmodel, an object from ivmodel() function
###        k, a vector (or scalar) of k values for estimation
###        beta0, a vector (or scalar) of null values for testing and p-values
###        alpha, significance level for confidence intervals
###        heteroSE, use heteroscedastic robust standard errors?
###        clusterID, if cluster-robust standard errors are desired, please provide a vector of
###                   length that's identical to the sample size.
###                   For example, if n = 6 and clusterID = c(1,1,1,2,2,2),
###                   there would be two clusters where the first cluster
###                   is formed by the first three observations and the
###                   second cluster is formed by the last three observations
###                   clusterID can be numeric, character, or factor.
### OUTPUT: a list of point estimate, standard error, test statistic, and p-value
KClass = function(ivmodel,
                  beta0=0,alpha=0.05,k=c(0,1),
                  manyweakSE=FALSE,heteroSE=FALSE,clusterID=NULL) {
  # Error checking
  if(class(ivmodel) != "ivmodel") {
    print("You must supply an ivmodel class. Run ivmodel() and see ivmodel() function for details")
    return(NULL)
  }
  if(missing(k)) {
    print("You must specify a value for k")
    return(NULL)
  }

  # Extract objects from ivmodel
  Yadj = ivmodel$Yadj; Dadj =ivmodel$Dadj; Zadj = ivmodel$Zadj; ZadjQR = ivmodel$ZadjQR
  degF = ivmodel$n - ivmodel$p - 1 # this looks strange, but it's from Wooldridge and Stock (2002)

  # Compute k-class estimator
  denom = (sum(Dadj^2) - k * sum(qr.resid(ZadjQR,Dadj)^2))
  kPointEst = (sum(Yadj * Dadj) - k * sum(Yadj * qr.resid(ZadjQR,Dadj))) / denom

  # Compute std error, testStat, and confidence intervals
  kVarPointEst = rep(0,length(k))
  kCI = matrix(0,length(k),2)
  for(i in 1:length(k)) {
    if(denom[i] <= 0) { #k exceeds the maximum possible value
	  kVarPointEst[i] = NA; kCI[i,] = c(NA,NA)
    } else {
        if (manyweakSE && k[i] != 0) { ## From Hansen et al. (2008)
            alpha <- - (1 - k[i])/k[i]
            H <- sum((Dadj - qr.resid(ZadjQR,Dadj))^2) - alpha * sum(Dadj^2)
            u <- Yadj - Dadj * kPointEst[i]
            D.tilde <- Dadj - u * sum(u  * Dadj) / sum(u^2)
            sigmaB <- sum(u^2) / degF * ( (1 - alpha)^2 * (sum(D.tilde^2) - sum(qr.resid(ZadjQR, D.tilde)^2)) + alpha^2 * sum(qr.resid(ZadjQR, D.tilde)^2) )
            Q <- qr.Q(ZadjQR)[, 1:ivmodel$L]
            P.diag <- apply(Q * Q, 1, sum)
            Dfitted <- Dadj - qr.resid(ZadjQR, Dadj)
            kappa <- sum(P.diag^2)/ivmodel$L
            tau <- ivmodel$L/ivmodel$n
            A <- sum((P.diag - tau) * Dfitted) * mean(u^2 * qr.resid(ZadjQR, D.tilde))
            B <- ivmodel$L * (kappa - tau) * sum((u^2 - sum(u^2) / degF) * qr.resid(ZadjQR, D.tilde)^2) / (ivmodel$n * (1 - 2 * tau + kappa * tau))
            kVarPointEst[i] = (sigmaB + 2 * A + B) / H^2
        } else if (heteroSE || (manyweakSE &&k[i] == 0)) {
	    kVarPointEst[i] = ivmodel$n/degF * sum( (Yadj - Dadj * kPointEst[i])^2 * (Dadj - k[i]*qr.resid(ZadjQR,Dadj))^2 ) / (denom[i])^2
	  } else if(!is.null(clusterID)){
	  	if(length(clusterID) != ivmodel$n) {
	  		### Missing problem here needs to be taken care of ###
	  		print("Cluster ID vector is not the same length as the sample size")
	  		return(NULL)
	  	}
	  	if(!is.character(clusterID) && !is.factor(clusterID) && !is.numeric(clusterID)) {
	  		print("Cluster ID must be either a character vector, a factor vector, or a numeric vector")
	  		return(NULL)
	  	}
	  	clusterID = as.factor(clusterID)
	  	clusterID = as.numeric(clusterID)
	  	nCluster <- length(unique(clusterID))
        dfc <- nCluster/(nCluster-1)*(ivmodel$n-1)/degF
        residFit = Yadj - Dadj * kPointEst[i]
        umat = tapply(residFit*(Dadj - k[i]*qr.resid(ZadjQR,Dadj)),clusterID, sum)
        kVarPointEst[i] = dfc * t(umat) %*% umat / denom[i]^2
	  }
	  else {
        kVarPointEst[i] = 1/(degF) *sum((Yadj - Dadj * kPointEst[i])^2) / denom[i]
	  }
	  # Note that R's AER package uses the z-scores instead of the t distribution. They are basically the same as n gets large.
	  kCI[i,] =  c(kPointEst[i] - qt(1-alpha/2,degF) * sqrt(kVarPointEst[i]),
	               kPointEst[i] + qt(1-alpha/2,degF) * sqrt(kVarPointEst[i]))
    }
  }

  # Compute test statistics
  # This operation takes a vector of k estimates (pointEst, k*1 dim) and
  # another vector of null values (beta0,1 * length(beta0))
  # and subtracts pointEst from a vector of null values.
  # The last operation of dividing by sqrt() is done column-wise
  # E.g. [1,2,3 ; 2,3,4] / (2,3,4) --> [0.5,2/3,0.75;1,1,1]
  kTestStat = outer(kPointEst,beta0,FUN="-") / sqrt(kVarPointEst)

  # Compute p-value
  kPValue = 2*(1 - pt(abs(kTestStat),degF))

  # Package output
  kPointEst = matrix(kPointEst,length(k),1)
  kVarPointEst = matrix(sqrt(kVarPointEst),length(k),1)
  rownames(kPointEst) = rownames(kVarPointEst) = rownames(kCI) = rownames(kPValue) = rownames(kTestStat) = k
  colnames(kPValue) = colnames(kTestStat) = beta0
  colnames(kPointEst) = "Estimate"
  colnames(kVarPointEst) = "Std. Error"
  colnames(kCI) = c(paste(as.character(round(alpha/2 * 100,1)),"%"),paste(as.character( round((1-alpha/2) * 100,1)),"%"))

  return(list(point.est = kPointEst,std.err = kVarPointEst,test.stat = kTestStat,p.value = kPValue,ci = kCI))
}


library("ggplot2")
library("tidyr")
data <- read.csv("perm_data/index_inner_join.csv")
df_index <- subset(data, type=="index")
df_index <- df_index[c("num_rows", "time")]
constant <- mean(df_index$time/(df_index$num_rows * log(df_index$num_rows)))
df_index$fitted <- constant * df_index$num_rows  * log(df_index$num_rows)
colnames(df_index) <- c("num_rows", "actual", "fitted")
df_tidy <- gather(df_index, type, time, -num_rows)
print(df_tidy)
ggplot(data = df_tidy, aes(x=num_rows, y= time, color = type)) +
	geom_line() +
	ggtitle("Index") +
	ylab("time in seconds") +
	scale_x_continuous(name="number rows", labels = scales::comma)
ggsave("data_out/index.png")


prcomp_test<-function(filename){
	# readin table
	taxon.table <-read.csv(filename)

	# process
	rownames(taxon.table) <- taxon.table[,1]
	taxon.table <- taxon.table[,-1]
	taxon.table[taxon.table==0] <- NA
	taxon.table <-log10(taxon.table)
	cluster.result <-prcomp(t(na.omit(taxon.table)), scale = TRUE)$x

	# get values, and return, task finished!
	x <- cluster.result[,1]
	y <- cluster.result[,2]
	sample.name <- rownames(cluster.result)

	write.table(cluster.result,"value_cluster.txt",sep="\t",row.names = TRUE, col.names = NA)
	write.table(x,"value_x.txt",sep="\t",row.names = TRUE,col.names = NA)
	write.table(y,"value_y.txt",sep="\t",row.names = TRUE,col.names = NA)

	png("plot.png")
	myplot<-plot(x, y)
	myplot<-myplot+text(x,y, labels=sample.name, cex= 0.7, pos=3)
	print(myplot)
	dev.off()

	return(list(sample.name, x, y))
}


###############################################
# 1. select 25% states with the least murder  #
# By: Row position changed                    #
# By: Row position unchanged                  #
###############################################

# Import dataset
u <- USArrests

# sorterar USArrests i collumn 1 (murders) i ascending

# newu <- u[order(u[,1]),]
# newu[1:round(nrow(u) * 0.25), ]

# Shorthand of the one above
u[order(u[,1]),][1:round(nrow(u) * 0.25),]

###############################################
# Gives a procentage of the murder rates
quantile(u[,1])[2]
# Gives the murder rates under 4
u[which(u[,1] < quantile(u[,1])[2]),]


#' cq_plot
#' Plot continuous quantile curves
#'
#' @param taus  vectors of specified conditional probability
#' @param con_quan an continuous quantile object includes
#'        \item{y}: vector of y
#'        \item{x}: vector of x
#'        \item{v_k0}:  vector of internal knots for covariates
#'        \item{v_m}:  vector of orders for covariates
#'        \item{m_sigma}:   matrix $\Sigma$
#'        \item{n1}:  design matrix of first covariate
#'        \item{til_beta}:  coefficient $\tilde{\beta}$
#'        \item{iter}   number of iteration
#'        \item{loss} Error or loss estimated
#'        \item{alpha}  accepted decrease in loss
#'        \item{bet}    shrinkage rate $\bet$, within $(0, 1)$.
#'
#' @keywords quantiles
#' @export
cq_plot <- function(taus, con_quan, ...) {
    #Extract values
    y <- con_quan$y; x <- con_quan$x; s_center <- con_quan$center
    s_sd <- con_quan$sd
    #transfer back
    x <- x * s_sd + s_center
    # Draw data
    plot(x, y, ...,
        type = "p", pch = 16, cex = 0.8, col = "grey",
        xlim = grDevices::extendrange(x, f = .1),
        ylim = grDevices::extendrange(y, f = .1),
        xlab = "", ylab = ""
    )
    # Calculate predictions
    v_pred <- cq_prediction(taus, con_quan)
    for (i in seq_along(taus)) {
        lines(x, v_pred[, i], col = i + 1)
    }
}

#' cq_prediction
#' prediction quantiles for orginal dataset given any conditional probability
#'
#' @param taus  vectors of specified conditional probability
#' @param con_quan an continuous quantile object includes
#'        \item{y}: vector of y
#'        \item{x}: vector of x
#'        \item{v_k0}:  vector of internal knots for covariates
#'        \item{v_m}:  vector of orders for covariates
#'        \item{m_sigma}:   matrix $\Sigma$
#'        \item{n1}:  design matrix of first covariate
#'        \item{til_beta}:  coefficient $\tilde{\beta}$
#'        \item{iter}   number of iteration
#'        \item{loss} Error or loss estimated
#'        \item{alpha}  accepted decrease in loss
#'        \item{bet}    shrinkage rate $\bet$, within $(0, 1)$.
#'
#' @param newdata a new dataset of first covariate
#'
#' @keywords quantiles
#' @export
cq_prediction <- function(taus, con_quan, newdata = NULL) {
    #Define dimensions
    k1 <- con_quan$v_k0[2]; ktau <- con_quan$v_k0[1]
    m1 <- con_quan$v_m[2]; mtau <- con_quan$v_m[1]
    #Extract values
    y <- con_quan$y; x <- con_quan$x
    m_sigma <- con_quan$m_sigma; til_beta <- con_quan$til_beta;
    s_center <- con_quan$center; s_sd <- con_quan$sd

    #Whether use newdata
    if (is.null(newdata)) {
        n1 <- con_quan$n1
        s_n <- length(y)
    } else {
        if (max(newdata) > max(x) || min(newdata) < min(x)) {
            stop("Can only prodict in original range.")
        }
        newdata <- (newdata - s_center) / s_sd
        n1 <- f_n1(scale(newdata), k1, m1)
        s_n <- length(newdata)
    }

    #Form design matrix
    m_n <- kronecker(spline_basis(taus, ktau, mtau, c(1, 0)), n1)

    # Calculate predictions
    v_pred <- c(m_n %*% m_sigma %*% til_beta)

    # Rearrange the orders
    m_pred <- matrix(v_pred, nrow = length(y), ncol = length(taus))

    return(m_pred)
}


R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 Mathtest = read.table("d:/math test.txt",header=T)
 dist.items <- dist(Mathtest[,-1], method='euclidean')^2
 dist.items

 dist.items.2 <- dist(Mathtest[,-1], method='binary')
 dist.items.2

 dist.items.3 <- dist(1 - Mathtest[,-1], method='binary')
 dist.items.3

 items.complete.link <- hclust(dist.items, method='complete')
 items.complete.link

 plot(items.complete.link, labels=Mathtest[,1], ylab="Distance")

 items.sing.link <- hclust(dist.items, method='single')
 items.sing.link

 plot(items.sing.link, labels=Mathtest[,1], ylab="Distance")

 library(cluster)
 my.k.choices <- 2:8

 avg.sil.width <- rep(0, times=length(my.k.choices))
 for (ii in (1:length(my.k.choices)) ){
     avg.sil.width[ii] <- pam(dist.items, k=my.k.choices[ii])$silinfo$avg.width
 }
 print( cbind(my.k.choices, avg.sil.width) )

 items.kmed.2 <- pam(dist.items, k=2, diss=T)
 items.kmed.2

 items.2.clust <- lapply(1:2, function(nc) Mathtest[,1][items.kmed.2$clustering==nc])
 items.2.clust

 items.kmed.3 <- pam(dist.items, k=3, diss=T)
 items.kmed.3

 items.3.clust <- lapply(1:3, function(nc) Mathtest[,1][items.kmed.3$clustering==nc])
 items.3.clust

Chapter 03/4Binary Clustering - Math test.r


data=read.csv("PRSA_data_2010.1.1-2014.12.31.csv",header=T);
x=na.omit(data)$No/24/365.25*2*pi;
y=na.omit(data)$pm2.5;
plot(x,y,pch=20);
z=cbind(sin(x),cos(x),sin(4*x),cos(4*x),sin(12*x),cos(12*x),sin(52.2*x),cos(52.2*x));
model=lm(y~z);
summary(model);
yhat=predict(model,as.data.frame(z));
plot(x,y,pch=20);
points(x,yhat,col=2,type='l');


#install.packages("ggplot2")

require("ggplot2")
library(zoo)
par(mfrow=c(1,1))

custom.col <- c("#FFDB6D", "#C4961A", "#F4EDCA",
                "#D16103", "#C3D7A4", "#52854C", "#4E84C4", "#293352")

setwd("C:/Code/climData/glaser2019")

pt1 <- read.csv("csv/p_1000_2018.csv", sep=",", na = "NA")
pt1$m <- NULL
spi <- read.csv("https://raw.githubusercontent.com/climdata/dwdSPI/master/csv/spi_de.csv", sep=",", na = "NA")
spi <- subset(spi, spi$time>(0.05+max(pt1$time)))
names(spi)[names(spi) == 'spi1'] <- 'precipitation'
spi <- spi[,c("year", "month","time","precipitation")]
pt1 <- rbind(pt1, spi)

hhi <- read.csv("csv/hhi_1500_2019.csv", sep=",", na = "NA")
pt1 <- subset(pt1, pt1$year>1499)

hist(10*hhi$hhi)

filterMonth <- 12*5
pt1 <- merge(pt1,hhi[,c("year", "month","hhi")], by=c("year", "month"))
hhim <- rollapply(pt1$hhi, width=filterMonth, by=1, FUN=sum)
pt1$hhim <- pt1$hhi
pt1$hhim[filterMonth:length(pt1$hhim)] <- hhim/filterMonth

pt1 <- pt1[order(pt1$time),]

pic <- pt1$precipitation
len <- length(pic)
## mirror pic
pic <- append(pic, pic)
for(i in 1:len) {
  pic[i+len] <- pic[1+len-i]
}

frq <- fft(pic, inverse = FALSE)
frq0 <- frq
frq1 <- frq
frq5 <- frq

filterYears = 1.0   #filter 1y
start = round(len/(12*filterYears))
stop  = round(2*len-start)
frq1[start:stop] <- 0.0

filterYears = 5.0   #filter 5y
start = round(len/(12*filterYears))
stop  = round(2*len-start)
frq5[start:stop] <- 0.0

#pt1$prec1 <- pt8$precipitation
pic1 <- Re(fft(frq1, inverse = TRUE)/length(frq1))
pic1 <- pic1[1:len]
pt1$prec1 <- pic1
pic5 <- Re(fft(frq5, inverse = TRUE)/length(frq5))
#pic5 <- rollapply(pic5, width=24, by=1, FUN=mean)
pic5 <- pic5[1:len]
pt1$prec5 <- pic5

amp <- cbind(0:(length(frq)-1), Mod(frq))
plot(amp, t="h", lwd=2, main="",
     xlab="Frequency", ylab="Ampl",
     xlim=c(0,length(amp)/2), ylim=c(0,max(Mod(frq))))

plot(amp, t="h", lwd=2, main="",
     xlab="Frequency", ylab="Ampl",
     xlim=c(0,start), ylim=c(0,max(Mod(frq))))

#df <- data.frame(freq = 0:99, amp = Mod(frq)[1:100])
#df$freq <- length(frq)/(12*df$freq)
#ggplot(aes(), data=df) +
#  geom_line(aes(y=df$amp, x=df$freq)) +
#  scale_x_log10() + scale_x_reverse()

mp <- ggplot(pt1, aes())
mp + geom_raster(aes(year,month, fill=precipitation))+
  geom_raster(aes(year,-1, fill=4*prec5))+
  geom_raster(aes(year,-2, fill=2*prec1))+
  #theme_classic(base_size=80) +
  theme_classic() +
  scale_y_continuous(breaks=c(-2,-1,1,6,12), lab=c("1y","5y","1","6","12"))+
  scale_x_continuous(limits=c(1500,2020)) +
  scale_fill_gradient2(low="#AA6010", mid="#FCF0C2", high="#23AB30") +
  theme( legend.key.width = unit(2,"cm")) +
  guides(fill=guide_legend(title="HHI", reverse = TRUE)) +
  geom_hline(aes(yintercept = 6+0)) +
  geom_line(aes(y=6+4.0*pt1$prec5, x=pt1$time, color="Filtered")) +
  scale_color_manual("Filtered", values=c("black"), labels=c("5y"))
  #geom_line(aes(y=10+0.5*pt1$hhim, x=pt1$time))


install.packages("neuralnet")
TK<-c(20,10,30,20,80,30)
CK<-c(90,20,40,50,50,80)
placement<-c(1,0,0,0,1,1)
df<-data.frame(TK,CK,placement)
require(neuralnet)
nn=neuralnet(placement~TK+CK,data=df,hidden=3,act.fct = "logistic",linear.output=FALSE )
plot(nn)
TK<-c(30,40,85)
CK<-c(85,50,40)
test<-data.frame(TK,CK)
predict=compute(nn,test)
predict$net.result
p<-predict$net.result
p<-ifelse(p>0.5,1,0)
p
install.packages("randomForest")
setwd("E:/code/R")
a<-read.csv("Social_Network_Ads.csv")
require(randomForest)
summary(a)
rf=randomForest(Age~EstimatedSalary+Purchased,data=a)
plot(rf)


# grepl selects variables matching:  characters excluded, all variables.  The
# collapse option connects.  The names to draw from is names(dovars0)
covars <-
    covars0[, !grepl(paste(exclude.vars, collapse = "|"), names(covars0))]
# scaled vars
covars.scale <- scale(covars)
# count vars
nn <- ncol(covars)

# foward selection
# exp.covar defines the data frame with the outcome
exp.covar <- data.frame(y, covars.scale)
#which var has the highest corr w/ y
v1 <- names(which.max(abs(cor(exp.covar))["y", -1]))
# the first variable with the highest cor
v <- v1
for (J in 1:nn) {
    # exclude the var with the highest corr w/ y and selected
    # SUN:  271 sites
    vr <-
        names(exp.covar)[!(names(exp.covar) %in% c(v, "y"))]
    # (k in vr) is the number of names in vector vr
    for (k in vr) {
        # regression formula in fn
        fn <-
            formula(paste("y ~", paste(c(v, k), collapse = "+")))
        # extract the F statistic
        f11 <-
            anova(lm(fn, data = exp.covar))[(J + 1), "F value"]
        if (k == vr[1])
            f12 <- f11
        else
            f12 <- c(f12, f11)
    }
    # choose the variable with the highest F statistic
    v2 <- vr[which.max(f12)]
    # SUN: 2nd var with the highest partial f-test stat in the model with 1st var
    # v is the final list of variables
    v <- c(v, v2)
}
fvar <- v
nvar <-
    c(3, 5, 7, 10, 13, 16, 20, 25, 30, seq(60, length(fvar), 30), length(fvar))


context("Test Ship Power Calculation for propeller law")

test_that("calcPropPwr works for shipSpeed == serviceSpeed",{
  expect_equal( calcPropPwr(shipSpeed=10, refSpeed=10, totalInstalledPwr=100, n=3, serviceMargin=0),
                100*0.94^3
              )

})

test_that("calcPropPwr works for shipSpeed == maxSpeed",{
  expect_equal( calcPropPwr(shipSpeed=10, refSpeed=10, totalInstalledPwr=100, n=3, serviceMargin=0, refSpeedType="maxSpeed"),
                100
  )

})

test_that("serviceMargin has the intended effect",{
  expect_equal( calcPropPwr(shipSpeed=9, refSpeed=10, totalInstalledPwr=100, n=3, serviceMargin=15, refSpeedType="maxSpeed"),
                100*(0.9^3)*1.15
  )

})

test_that("maximum power output is 100% load",{
  expect_equal( calcPropPwr(shipSpeed=20, refSpeed=10, totalInstalledPwr=100, n=3, serviceMargin=15),
                100
              )

})

test_that("minimum non-zero power is 2% load",{
  expect_equal( calcPropPwr(shipSpeed=0.2, refSpeed=10, totalInstalledPwr=100, n=3, serviceMargin=0),
                2
              )

})

test_that("changing speed generates the correct power",{
  shipSpeed <- 5
  refSpeed  <- 10
  totalInstalledPwr <- 100
  n <- 3
  serviceMargin <- 0

  expect_equal( calcPropPwr(totalInstalledPwr, shipSpeed, refSpeed, serviceMargin, n),
                totalInstalledPwr*(0.94*shipSpeed/refSpeed)^n
              )

})


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

setwd("/Users/gregory/Documents/2018/corpus/")

setwd("F:/2018/sta_foundations/Images")

images <- read.csv(file= "data.csv", header=TRUE, sep=",")

images$mark  <- as.factor(images$mark)

# decide response variable and define his levels

levels(images$mark) <- c(1,2,3,4,5,6,7,8,9,10)

cov(images)

cor(images)

eigen(cor(images))

head(images)

str(images)

psych::describe(images)

table(images$mark)
hist(images$mark)
boxplot(images$correlation)
boxplot(images$intersection)
boxplot(images$chisquare)
boxplot(images$bhattacharyya)

data_selected <- as.data.frame( select(images, -id, -mark))

pr = prcomp(data_selected)
summary(pr)

biplot(pr)

data_selected <- as.data.frame( select(images, -id))
ggpairs(data_selected)

reg = lm(mark ~ ., data = data_selected )
summary(reg)

# descicion three
library(rpart)

fit <- rpart(mark ~ correlation + intersection + chisquare + bhattacharyya, method="class", data=images)

printcp(fit) # display the results
plotcp(fit) # visualize cross-validation results
summary(fit) # detailed summary of splits

plot(fit, uniform=TRUE)
text(fit, use.n=TRUE, all=TRUE, cex=.8)

install.packages("caret")
require(caret)

classes <- images[, "mark"]
predictors <- images[, -match(c("id", "mark"), colnames(images))]

train_set <- createDataPartition(classes, p = 0.8, list = FALSE)
str(train_set)

train_predictors <- predictors[train_set, ]
train_classes <- classes[train_set]
test_predictors <- predictors[-train_set, ]
test_classes <- classes[-train_set]

index = unlist(cv_splits[1])
train_predictors <- predictors[ index , ]
train_classes <- classes[index]
train = cbind(train_predictors, train_classes)
test_predictors = predictors[ -index, ]
test_classes = classes[-index]
test = cbind(test_predictors, test_classes)

fit <- rpart(train_classes ~ correlation + intersection + chisquare + bhattacharyya, method="class", data=train)

pred = predict(fit, newdata =  test_predictors, type = "class")

factor(pred)

levels(pred) <- levels(test_classes)
d <- pred
d[names(pred)] <- test_classes
levels(d)

table( pred, d )
confusionMatrix( pred, test_classes)

install.packages("C50")
library(C50)

summary(info)
plot(info)

acc <- matrix(NA,nrow=1,ncol=10)
folds <- createFolds(classes, k = 10, returnTrain = TRUE)

for(i in 1:10){
  index = unlist(folds[i])
  train_predictors <- predictors[index, ]
  train_classes <- classes[index]
  train = cbind(train_predictors, train_classes)
  test_predictors = predictors[ -index, ]
  test_classes = classes[-index]
  test = cbind(test_predictors, test_classes)

  # fit <- rpart(train_classes ~ correlation + intersection + chisquare + bhattacharyya, method="class", data=train)

  fit  = C5.0(train_classes ~ correlation + intersection + chisquare + bhattacharyya, data = train, trials=3)

  pred = predict(fit, newdata =  test_predictors, type = "class")
  con = confusionMatrix( pred, test_classes)
  acc[1, i] = con$overall['Accuracy']
}

psych::describe( as.numeric(acc))
boxplot( as.numeric(acc))
rowMeans(acc)


set1=c("some","random","number")
set3=c("some","random","some")
set2=c("some","random","is","writtern")
union(set1,set2)

intersect(set1,set2)

setdiff(set1,set2)
setequal(set1,set3)
identical(set1,set2)

elem1="some"
elem2="how"

is.element(elem1,set1)
is.element(elem2,set1)

elem1%in%set1
elem2%in%set1


data <- read.csv(file="UrbanaData.csv",header = TRUE)
depot <- c(40.117844, -88.199203)

data$LAT <- (data$LAT-depot[1])*111.7
data$LON <- (data$LON-depot[2])*111.7*cos(40.1/360*2*pi)

plot(data$LON, data$LAT)
points(0, 0, col = "red")
n1 <- length(data$LON)
n2 <- length(data$LON)

r <- abs(data$LON)+abs(data$LAT)
alpha <- atan(data$LAT/data$LON)
alpha <- ifelse(data$LAT<0 & data$LON<0, alpha-pi, alpha)
alpha <- ifelse(data$LAT>0 & data$LON<0, alpha+pi, alpha)
dmdori = data$Pop*4.4*7
dmd = qnorm(0.95, mean = data$Pop*4.4*7, sd = data$Pop*4.4*7*0.1)

p <- as.data.frame(cbind(data$BID, x, r, alpha, dmd))
colnames(p) <- c("id","lon","lat","r","alpha","demand")
p$id <- rep(1:n1)
p$newid <- rep(1:n1)
p$spec <- rep(0,n1)
plot(p$r, p$demand, xlab = "Distance", ylab = "Demand")

plot(data$LON, data$LAT, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 17)
high <- which(p$demand>=10000)
mid <- which(p$demand>=5000 & p$demand<10000)
points(p$lon[high], p$lat[high], col = "green", pch = 16)
points(p$lon[mid], p$lat[mid], col = "blue", pch = 16)
req <- matrix(0, nrow = n2, ncol = 5)

#############split points###################
for (i in high)
{
  req[i, 5] <- 1
  p$demand[i] <- p$demand[i]/5
  p$spec[i] <- 1
  newp <- p[i, ]
  newp$id[1] <- i
  for (j in 1:4)
  {
    n2 <- n2+1
    req <- rbind(req, rep(0, 5))
    req[n2, j] <- 1
    newp$newid[1] <- n2
    p <- rbind(p, newp)
  }
}

for (i in mid)
{
  req[i,] <- c(0, 1, 0, 0, 0)
  p$demand[i] <- p$demand[i]/2
  p$spec[i]<- 1
  newp <- p[i, ]
  newp$id[1] <- i

  n2 <- n2+1
  req <- rbind(req, rep(0, 5))
  req[n2, 4] <- 1
  newp$newid[1] <- n2
  p <- rbind(p, newp)
}

#data input for SA
write.table(p, "V2.csv")

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

searchnode <- function(x, conn, node, N)
{
  for (j in 1:N)
    if (conn[x, j]==1)
    {
      if (node[j]==FALSE) return(j)
    }
  return(0)
}

renode <- function(x, dist, node)
{
  l <- order(dist[x, ], decreasing = FALSE)
  for (j in l)
    if (node[j]==FALSE) return(j)
}

getsolu <- function(ppp, mark)
{
  #print(mark)
  x <- c(0, ppp$lon)
  y <- c(0, ppp$lat)
  N <- length(x)
  dot <- cbind(x, y)
  #creating dist matrix for dist(i,j)
  dist <- matrix(0, nrow = N, ncol = N)
  for (i in 1:N)
    for (j in 1:N)
    {
      dist[i, j] = abs(x[i]-x[j])+abs(y[i]-y[j])
    }

  # use prim algorithm to find MST, set point 1 as the start point
  conn <- matrix(0, nrow = N, ncol = N) # if city i & j are connected
  cost <- dist[1,] #distance from the tree to other nodes
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  father <- c(NA, rep(1, N-1))

  for (i in 1:(N-1))
  {
    newdist <- Inf
    for (j in 1:N)
    {
      #find a new node to join
      if (node[j]==FALSE & cost[j]<newdist)
      {
        newnode <- j
        newdist <- cost[j]
      }
    }
    node[newnode] <- TRUE
    conn[father[newnode], newnode] <- 1
    conn[newnode, father[newnode]] <- 1
    #update the cost and father using node j
    for (k in 1:N)
    {
      if (node[k]==FALSE & dist[newnode, k]<cost[k])
      {
        cost[k] = dist[newnode, k]
        father[k] = newnode
      }
    }
  }

  lstt <- c()
  node <- c(TRUE, rep(FALSE, N-1)) #whether node is in the set
  front <- 1
  totd <- 0
  for (i in 1:(N-1))
  {
    tail<- searchnode(front, conn, node, N)
    if (tail==0) {tail <- renode(front, dist, node)}
    lstt <- c(lstt, mark[tail-1])
    node[tail] <- TRUE
    if (i!=1)
    {segments(x[front], y[front], x[tail], y[tail], col = 2, lwd = "1")}
    totd <- totd+dist[front, tail]
    front <- tail
  }
  totd <- totd+dist[1, tail]
  #segments(x[1], y[1], x[tail], y[tail], col = "red", lwd = "1")
  print(totd)
  return(c(totd, lstt))
}
#################################
rangemust <- function(case, p)
{
  if (case==1)
  {
    tmp <- p$newid[which(p$alpha>=-pi & p$alpha<=-3*pi/4)]
    return(tmp)
  }
  if (case==2)
  {
    tmp <- p$newid[which(p$alpha>=-3*pi/4 & p$alpha<=-pi/4)]
    return(tmp)
  }
  if (case==3)
  {
    tmp <- p$newid[which(p$alpha>=-pi/4 & p$alpha<=pi/4)]
    return(tmp)
  }
  if (case==4)
  {
    tmp <- p$newid[which(p$alpha>=pi/4 & p$alpha<=pi)]
    return(tmp)
  }
}

rarange <- function(case, p)
{
  pp <- p
  if (case==1)
  {
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
  if (case==2)
  {
    tmp <- which(pp$alpha>=-pi & pp$alpha<=-pi/2)
    pp$alpha[tmp] <- pp$alpha[tmp]+2*pi
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
  if (case==3)
  {
    tmp <- which(pp$alpha>=-pi & pp$alpha<=0)
    pp$alpha[tmp] <- pp$alpha[tmp]+2*pi
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
  if (case==4)
  {
    tmp <- which(pp$alpha>=-pi & pp$alpha<=pi/2)
    pp$alpha[tmp] <- pp$alpha[tmp]+2*pi
    pp <- pp[order(pp$alpha, decreasing = FALSE),]
    return(pp)
  }
}

################# sweep ################
plot(p$lon, p$lat, xlab = "X", ylab = "Y")
points(0, 0, col = "red", pch = 16)

ctg <- rep(0, n2)
solu <- c()
lstt <- c()

rr<-0
newid <-c()
for (i in 1:5) #sweep for days
{
  for (j in 1:4) #sweep for tours in a day
  {
    flag <- (i-1)*4+j
    print("flag")
    print(flag)

    rg <- rangemust(j, p)
    must <- which((req[,i]==1) & (p$newid %in% rg))
    #points required to visit this tour, specified by newid
    ctg[must] <- flag
    newid <- c(newid, must)
    points(p$lon[must], p$lat[must], col = flag, pch = 16)
    pp <- rarange(j, p)
    tmp <- sum(p$demand[must])
    if (tmp>60000) {print("xxxxxx")}

    for (k in 1:n2)
    {
      if (ctg[pp$newid[k]]==0 & pp$spec[k]==0)
      {
        if (tmp+pp$demand[k]<=60000)
        {
          ctg[pp$newid[k]] <- flag
          tmp <- tmp+pp$demand[k]
          points(p$lon[pp$newid[k]], p$lat[pp$newid[k]], col = flag, pch = 16)
          newid <- c(newid, pp$newid[k])
        } else{
          break
        }
      }
    }
    rr <- rr+tmp
    sol <- getsolu(p[which(ctg==flag),], which(ctg==flag))
    solu <- c(solu, sol[1])
    lstt <- c(lstt, sol[2:length(sol)], flag+n2)
  }
}

solu <- solu*0.621371

final <- data.frame(
  routelength = solu,
  demandpoint = sapply(1:flag, function(i) length(which(ctg==i))),
  totaldemand = sapply(1:flag, function(i) sum(p$demand[which(ctg==i)]))
)
sum(final$routelength)

(sum(solu)/25+sum(p$demand)/5000/6)*15
1.86*sum(solu)+0.1*sum(solu)+sum(solu*final$totaldemand*0.1/5000/2)
0.2*(n2+20)

cost <- (sum(solu)/25+sum(dmd)/5000/6)*15+
  1.86*sum(solu)+0.1*sum(solu)+sum(solu*final$totaldemand*0.1/5000/2)+
  0.2*(n2+20)
#compute penalty
cc <- rep(1,n2)
cc <- ifelse(p$demand>5000 & p$demand<=10000, 5, cc)
cc <- ifelse(p$demand>10000, 25, cc)
print(sum(cc*p$demand)/5000)
print(sum(cc*p$demand)/5000+cost)

#initial solution for SA
write.table(t(as.matrix(lstt)), "sol2.txt")


#' Calculate nonparametric effect size vector
#'
#' \code{distE.effect} calculates the effect vector of two distributions
#' @param x A vector of numbers for the first distribution
#' @param y A vector of numbers for the second distribution
#' @param mid Toggles whether to give the distribution or the median
#' @export distE.effect
#' @import stats

# returns a vector of standardized effect sizes
# recycles if x,y are different sizes
distE.effect <- function(x,y, mid=TRUE){
  if(mid == TRUE){
    return(median (distE.diff(x,y)/distE.mmad(x,y) ) )
 } else {
    return( distE.diff(x,y)/distE.mmad(x,y) )
  }
}


#' Thanks John Quilty for providing this R script

#' Example R script to show the shift-invariancy and sensitivity to adding additional data points
#' when using VMD for to proivde inputs for operational forecasting tasks.
#' Note: run this script line by line instead of executing it in its entirety (as only the last plot
#' will be displayed in the latter case).
set.seed(123)
install.packages("EMD",repos = "http://cran.us.r-project.org")
install.packages("vmd",repos = "http://cran.us.r-project.org")
library(EMD) # this is so that we can use the sunspot series as a test case
library(vmd)
data("sunspot")
x <- sunspot$sunspot
###############################################################################################
#' CHECK 1: Is VMD shift-invariant?
#' If yes, any shifted copy of an IMF from a VMD decomposition, similar to a shifted copy of the
#' original time series, should be maintained.
#'
#' For example, given the sunspot time series x (of length 386) we can generate a 1-step
#' advanced copy of the original time series as follows:
#'
#' x0 = x[1:385]
#' x1 = x[2:386] # this is a 1-step advanced version of x0
#'
#' Obviously, shift-invariancy is preserved between x0 and x1 since x0[2:385] = x1[1:384]
#'
#'
#' For shift-invariancy to be preserved for VMD, we should observe, for example, that the
#' VMD IMF1 components for x0 (x0.IMF1) and x1 (x1.IMF1) should be exact copies of one another,
#' advanced by a single step.
#'
#' I.e., x0.IMF1[2:385] should equal x1.IMF1[1:384] if shift-invariancy is
#' preserved. However, this is not the case for VMD as shown below. Interestingly, we see
#' a high level of error at the boundaries of the time series, of high importance in
#' operational forecasting tasks.
###############################################################################################
# lag/advance sunspot data by 1-step
x0 = x[1:385]
x1 = x[2:386]
# perform VMD on both original and advanced time series
x0.vmd = vmd(x0)$getResult()$u # default settings
x1.vmd = vmd(x1)$getResult()$u # default settings
# plot IMF1 for x0.vmd and x1.vmd
plot(x0.vmd[2:385,1],type='l')
lines(x1.vmd[1:384,1],col='red')
# plot error (which should be a straight line of 0s if shift-invariancy was preserved)
err = x0.vmd[2:385] - x1.vmd[1:384]
plot(err)
# check the level of error (as measured by the mean square error) between the IMF components
mse = mean(err^2)
###############################################################################################
#' CHECK 2: The impact of appending data points to a time series then performing VMD, analogous
#' to the case in operational forecasting when new data becomes available and an updated forecast
#' is made using the newly arrived data.
#'
#' Ideally, for forecasting situations, when new data is appended to a time series an some pre-
#' processing is performed, it should not have an impact on previous measurements of the pre-
#' processed time series.
#'
#' For example, if IMF1_1:N represents the IMF1, which has N total measurements and was derived
#' by applying VMD to x_1:N then we would expect that when we perform VMD when x is appended with
#' another measurement, i.e., x_1:N+1, resulting in IMF1_1:N+1 that the first 1:N measurements in
#' IMF1_1:N+1 are equal to IMF1_1:N. In other words, IMF_1:N+1[1:N] = IMF1_1:N[1:N].
#'
#' Again, we see that this is not the case. Appending an additional observation to the time series
#' results in the updated VMD components to be entirely different then the original (as of yet
#' updated) VMD components. Interestingly, we see a high level of error at the boundaries of the
#' time series, of high importance in operational forecasting tasks.
###############################################################################################
# extend x with an additional measurement
x_1_385 = x[1:385]
x_1_386 = x[1:386]
# perform VMD on original and extended time series
x_1_385.vmd = vmd(x_1_385)$getResult()$u # default settings
x_1_386.vmd = vmd(x_1_386)$getResult()$u # default settings
# plot IMF1 for x_1_385.vmd and x_1_386.vmd
plot(1:386, x_1_386.vmd[1:386,1],type='l')
lines(1:385, x_1_385.vmd[1:385,1],col='red')
#' plot error (which should be a straight line of 0s if appending an additional observation has
#' no impact on VMD)
err.append = x_1_385.vmd[1:385] - x_1_386.vmd[1:385]
plot(err.append)
# check the level of error (as measured by the mean square error) between the IMF components
mse.append = mean(err.append^2)
# the problem gets exasperated if it is not a single time point that is updated, but several
x_1_300 = x[1:300]
# perform VMD on original and extended time series
x_1_300.vmd = vmd(x_1_300)$getResult()$u # default settings
# plot IMF1 for x_1_385.vmd and x_1_386.vmd
plot(1:386, x_1_386.vmd[1:386,1],type='l')
lines(1:300, x_1_300.vmd[1:300,1],col='red')
#' plot error (which should be a straight line of 0s if appending an additional observation has
#' no impact on VMD)
err.append.ext = x_1_300.vmd[1:300] - x_1_386.vmd[1:300]
plot(err.append.ext)
# check the level of error (as measured by the mean square error) between the IMF components
mse.append.ext = mean(err.append.ext^2)
# EOF


library(MASS)

computeWeightsWithStochasticGradient <- function(dset, classes, lossFunction, updateRule) {
  dsetLength <- dim(dset)[1]
  featuresCount <- dim(dset)[2]

  w <- runif(featuresCount, -1 / (2 * featuresCount), 1 / (2 * featuresCount))
  lambda <- 1 / dsetLength

  currentLoss <- 0
  for (i in 1:dsetLength) {
    margin <- sum(w * dset[i, ]) * classes[i]
    currentLoss <- currentLoss + lossFunction(margin)
  }
  prevLoss <- currentLoss

  step <- 1
  repeat {
    margins <- array(0, dim = dsetLength)
    for (i in 1:dsetLength) {
      margins[i] <- sum(w * dset[i, ]) * classes[i]
    }
    errorIndices <- which(margins <= 0)

    if (length(errorIndices) == 0) break

    randomErrorSampleIndex <- sample(errorIndices, 1)
    x <- dset[randomErrorSampleIndex, ]
    class <- classes[randomErrorSampleIndex]

    margin <- sum(w * x) * class
    loss <- lossFunction(margin)

    learningRate <- 1 / step
    w <- updateRule(w, learningRate, x, class)

    currentLoss <- (1 - lambda) * currentLoss + lambda * loss

    if (abs(prevLoss - currentLoss) / abs(max(prevLoss, currentLoss)) < 1e-5) break

    if (step > 25000) break

    prevLoss <- currentLoss
    step <- step + 1

    if (step == 10 || step == 50 || step == 100 || step == 500) {
      png(sprintf("sgd/astep-%03d.png", step), width = 700, height = 700, unit = "px", pointsize = 20)
      # cat("Kernel:", kernelName, index, "of", length(kernels), "\n")
      #index <- index + 1

      #loo <- parzen_loo(iris[3:4], iris$Species, kernel, hs)
      #plot(hs, loo, type="l", xlab="h", ylab="LOO")
      #points(hs[which.min(loo)], loo[which.min(loo)], pch = 19, col = "red")
      #text(hs[which.min(loo)], loo[which.min(loo)] + 0.05, paste("best:", hs[which.min(loo)]))

      plot(dset[ ,1], dset[ ,2], pch=21, bg=c("1" = "green","-1" = "blue")[paste(gdset[ ,3])])
      drawLine(w, "darkgreen")
      #cat("\rDone.                      \n")
      dev.off()
    }
  }
  gsteps <<- gsteps+step
  # print(step)
  # Thanks, T. Orlova!
  return(w)
}

adalineLossFunction <- function(margin) (margin - 1) ^ 2

adalineUpdateRule <- function(w, learningRate, sample, class) w - learningRate * (sum(w * sample) - class) * sample

hebbLossFunction <- function(margin) max(-margin, 0)

hebbUpdateRule <- function(w, learningRate, sample, class) w + learningRate * sample * class

drawLine = function(w, color) {
  abline(a = w[3] / w[2], b = -w[1] / w[2], lwd = 2, col = color)
}

iterationsCount <- 100

gsteps <- 0
errorsCount <- 0

for (iter in 1:iterationsCount) {
  cat("\rIteration: ", iter)
  mu1 <- c(0, 0)
  mu2 <- c(4, 4)
  sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
  sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
  dset1 <- mvrnorm(250, mu1, sig1)
  dset2 <- mvrnorm(250, mu2, sig2)
  dset <- rbind(cbind(dset1, 1),cbind(dset2, -1))
  dset <- cbind(dset, -1)
  gdset <- dset

  w1 = computeWeightsWithStochasticGradient(dset[, c(1, 2, 4)], dset[, 3], adalineLossFunction, adalineUpdateRule)

  for (i in 1:dim(dset)[1]) {
    if (sum(c(dset[i, 1:2], -1) * w1) * dset[i, 3] < 0) {
      errorsCount <- errorsCount + 1
    }
  }
  # print(errorsCount)

  plot(dset[ ,1], dset[ ,2], pch=21, bg=c("1" = "green","-1" = "blue")[paste(dset[ ,3])])

  drawLine(w1, "darkgreen")
}

print(errorsCount / iterationsCount)
print(gsteps / iterationsCount)

# > w1
# [1] -1.0600585 -0.2050553 -3.6053360
# > w[3]  / w[2]
# Error: object 'w' not found
# > w1[3]  / w1[2]
# [1] 17.58226
# > ?abline
# > -w1[1] / w1[2]
# [1] -5.169623
# > 17.58226 -5.169623
# [1] 12.41264
# > 17.58226 -2*5.169623
# [1] 7.243014
# > c(2, 7.243, 0) * w1
# [1] -2.120117 -1.485215  0.000000
# > c(-1, 2, 7.243) * w1
# [1]   1.0600585  -0.4101105 -26.1134488
# > c(2, 7.243, -1) * w1
# [1] -2.120117 -1.485215  3.605336
# > sum(c(2, 7.243, -1) * w1)
# [1] 3.612683e-06
# > paste(sum(c(2, 7.243, -1) * w1))
# [1] "3.61268315218766e-06"


# 4. faza: Napredna analiza podatkov

JSC = data.frame(naselje = c("Jesenice"),
                 nmv = c(585),
                 lat = c(46.4327),
                 lon = c(14.0534)
                 )

podatki = tabela3

#===========TEMPERATURE NAPOVEDUJE ZA JSC
g_A_1 <- ggplot(podatki, aes(x=lat, y=avg_t)) + geom_point() + stat_smooth(method = lm)
#print(g_A_1)

g_A_2 = ggplot(tabela3) + aes(x=nmv , y = avg_t)+
  geom_point() + stat_smooth(method = lm)  +
  labs(
    x = "Nadmorska višina[m]",
    y = "Povprečje povprečnih mesečnih temperatur[°C]",
    title = "Analiza povezave nadmorske višine in temperature"
  )
#print(g_A_2)
#Iz grafa 7 opazimo zelo lepo povezavo med avg_t in nmv
m_za_temp = avg_t ~ nmv + lat

lin.model1 = lm(m_za_temp, data = podatki)
#print(lin.model1)

tem_JSC = lm.napovedi1 = predict(lin.model1 , newdata = JSC)
JSC$avg_t = tem_JSC

#============= PADAVINE
g_A_3 = ggplot(podatki, aes(x = lat,y=avg_p))+geom_point() + stat_smooth(method = lm)
#print(g_A_3)
#iz grafa opazimo nikakršne povezave
g_A_4 = ggplot(podatki, aes(x = nmv,y=avg_p))+geom_point() + stat_smooth(method = lm)+
  labs(
    x = "Nadmorska višina[m]",
    y = "Povprečje povprečnih mesečnih padavin za leto[mm/m^2]",
    title = "Analiza povezave nadmorske višine in padavin"
  )
#print(g_A_4)

#Opazim da bi bilo tu mogoče bolje uporabiti kaj drugega in zanemariti Kredarico

podatki1 = podatki%>% filter(naselje != "Kredarica")

g_A_5 = ggplot(podatki1, aes(x = nmv,y=avg_p))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2) + I(x^3))
#print(g_A_5)
g_A_6 = ggplot(podatki1, aes(x = nmv,y=avg_p))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2)) +
  labs(
    x = "Nadmorska višina[m]",
    y = "Povprečje povprečnih mesečnih padavin za leto[mm/m^2]",
    title = "Analiza povezave nadmorske višine in padavin"
  )
#print(g_A_6)
#Stvar iz g_A_6 se mi zdi lepša saj z nmv naj bi se dvigovale padavine

m_za_padavine = avg_p ~nmv + I(nmv^2) + lat
lin.model2 = lm(m_za_padavine,data = podatki1)
lm.napovedi2 = predict(lin.model2,newdata = JSC)
#print(lm.napovedi2)
pad_JSC = lm.napovedi2
JSC$avg_p = pad_JSC

#===========PREBIVALSTVO
g_A_7= ggplot(podatki, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_7)
#Opazim,da Kredarica ni najbl fajn
g_A_8 = ggplot(podatki1, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_8)
g_A_9 = ggplot(podatki1, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2))
#print(g_A_9)
g_A_10 = ggplot(podatki1, aes(x=nmv,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2)+I(x^3))
#print(g_A_10)
#nekak se zdi najbolj logično 8

g_A_11= ggplot(podatki1, aes(x=avg_p,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_11)

g_A_12 = ggplot(podatki1, aes(x=avg_p,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2) )
#print(g_A_12)
#12 se zdi bols

g_A_13 = ggplot(podatki1, aes(x=avg_t,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x )
#print(g_A_13)
g_A_14 = ggplot(podatki1, aes(x=avg_t,y=avg_preb))+geom_point() +
  geom_smooth(method="lm", formula = y ~ x + I(x^2))
#print(g_A_14)
#oboje vredu

m_za_preb = avg_preb ~ nmv + avg_t + avg_p
lin.model3 = lm(m_za_preb,data = podatki1)
lm.napovedi3 = predict(lin.model3,newdata = JSC)
#print(lm.napovedi3)
preb_JSC = lm.napovedi3
JSC$avg_preb = preb_JSC

#print(JSC) #napoved za Jesenice

JSC_zares = gostota_prebivalci%>%filter(naselje == "Jesenice") %>%.[20,]
#Opazim, da se napoved od resnice za gostot prebivalcev razlikuje kar močno
#Mogoče se pa za temperature in padavine ne

SLO <- map_data("world") %>% filter(region=="Slovenia")
data = tabela3 %>%filter(leto=="2010")
data_12 = rbind(data , JSC)
data_12 =data_12[data_12$naselje != "Slap pri Vipavi",]
data_12 = data_12[data_12$naselje != "Brnik",]
data_12 = data_12 %>% filter(naselje != "Kredarica")
g12 = ggplot() +
  geom_polygon(data = SLO, aes(x=long, y = lat, group = group), fill="grey", alpha=0.3) +
  geom_point( data=(data_12), aes(x=lon, y=lat, size=avg_preb,color=nmv)) +
  scale_size_continuous(range=c(1,12)) +
  scale_colour_viridis(trans="identity",option = "C") +
  theme_void() + ylim(45,47) + coord_map()  +
  geom_text(
    data = data_12 %>% filter(naselje != "Jesenice"),
    mapping = aes(x = lon , y = lat+0.07, label = naselje),
    size = 2.5
  ) +
  geom_text(
    data = data_12 %>% filter(naselje == "Jesenice"),
    mapping = aes(x = lon , y = lat+0.07, label = naselje),
    size = 2.5 ,colour = "red"
  ) +
  labs(
    size = "Gostota poseljenosti [prebivalci/km^2]",
    color = "Nadmorska višina[m]"
  )


#!/usr/bin/env Rscript

# Calculates the running average Elo ranking and the standard error of the mean
# as a confidence interval using an Elo tournament output file as a command line
# argument.
#
# Usage: ./average-elo.r --run <data file>
# Be sure to make this file as executable!
#
# Requires packages argparser and ggplot2 in order to run. Using the R REPL, run
#     install.package("argparser")
#     install.package("ggplot2")

### parse command line arguments
library(argparser, quietly=TRUE)
parser <- arg_parser("Average Elo Ranking Plot")
parser <- add_argument(parser, '--run', nargs=1, help="training data files")
args   <- parse_args(parser)

### load and process the melted data
rounds  <- read.csv(unz(args$run, "rounds.csv"))
players <- read.csv(unz(args$run, "players.csv"))
rounds$AVG_RANKING <- ave(rounds$RANKING, rounds$PLAYER, FUN=cumsum) / ave(rounds$RANKING, rounds$PLAYER, FUN=seq_along)
rounds$STD_RANKING <- ave((rounds$RANKING - rounds$AVG_RANKING)^2, rounds$PLAYER, FUN=cumsum) / (ave(rounds$RANKING, rounds$PLAYER, FUN=seq_along) - 1)
rounds$SDE_RANKING <- rounds$STD_RANKING / sqrt(ave(rounds$RANKING, rounds$PLAYER, FUN=seq_along))
rounds$PLAYER <- players$NAME[factor(rounds$PLAYER)]

library(ggplot2)
ggplot(rounds, aes(x=ROUND, y=AVG_RANKING, color=PLAYER, fill=PLAYER)) +
	geom_line() +
	geom_ribbon(aes(ymin=AVG_RANKING-SDE_RANKING, ymax=AVG_RANKING+SDE_RANKING), linetype=0, alpha=0.3) +
	xlab("Rounds") +
	ylab("Average ELO Ranking") +
	labs(color="Player", fill="Player") +
	theme_bw()
ggsave(paste(args$run, "avg-elo", "pdf", sep="."), device="pdf", width=9, height=4.5)


R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree"
Copyright (C) 2015 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[Workspace loaded from ~/.RData]

 protein = read.csv("d:/Europenaprotein.csv",header=T)
  head(protein)

 set.seed(123456789)
 groupMeat <- kmeans(protein[,c("WhiteMeat","RedMeat")], centers=3, nstart=10)

 groupMeat

 o=order(groupMeat$cluster)

 data.frame(protein$Country[o],groupMeat$cluster[o])

 plot(protein$Red, protein$White, type="n", xlim=c(3,19), xlab="Red Meat", ylab="White Meat")
 text(x=protein$Red, y=protein$White, labels=protein$Country,col=groupMeat$cluster+1)

 set.seed(123456789)
 groupProtein <- kmeans(protein[,-1], centers=7, nstart=10)
 o=order(groupProtein$cluster)
 data.frame(protein$Country[o],groupProtein$cluster[o])

 library(cluster)
 clusplot(protein[,-1], groupProtein$cluster, main='2D representation of the Cluster solution', color=TRUE, shade=TRUE, labels=2, lines=0)
 foodagg=agnes(protein,diss=FALSE,metric="euclidian")
 foodagg
 plot(foodagg, main='Dendrogram')

 groups <- cutree(foodagg, k=4)
 rect.hclust(foodagg, k=4, border="red")

Chapter 03/5K-means clustering - European Protein Consumption.r


library(shiny)
library(rsconnect)
library(ggplot2)

#############################################################
# Set the baseline parameters
#############################################################
base_sI <- .2
base_gL <- .01
base_gA <- .02
base_delta <- .05
base_alpha <- .3
base_A <- 1
base_kalstar <- (base_sI/(base_gL+base_gA+base_delta))^(1/(1-base_alpha))
base_K <- base_kalstar*base_A
base_kystar <- base_sI/(base_gL+base_gA+base_delta)

#############################################################
# Define UI ----
#############################################################
ui <- fluidPage(
  withMathJax(),
  titlePanel("Dynamics of K/AL Ratio"),

  mainPanel(

      #hr(),

      h4("Set parameters"),

      fixedRow(
        column(4,
        sliderInput("alt_sI", h6('New capital share of GDP \\(s_I\\)'),
                    min = 0, max = .5, value = base_sI, ticks = FALSE, step=.01),
        sliderInput("alt_gL", h6("Population growth rate \\(g_L\\)"),
                    min = -.05, max = .05, value = base_gL, ticks = FALSE, step=.01),
        sliderInput("alt_gA", h6("Productivity gorwth rate \\(g_A\\)"),
                    min = -.05, max = .1, value = base_gA, ticks = FALSE, step=.01),
        sliderInput("alt_delta", h6("Depreciation rate \\(\\delta\\)"),
                    min = 0, max = .1, value = base_delta, ticks = FALSE, step=.01),
        sliderInput("alt_alpha", h6("Capital elasticity \\(\\alpha\\)"),
                    min = 0, max = 1, value = base_alpha, ticks = FALSE, step=.01),
        br(),
        actionButton("reset", "Reset all to baseline")
        ),
        column(8,
        plotOutput("gkalgraph",width = "100%"),
        )
      ) # end FluidRow
      ) # end main panel
  ) # end ui
#############################################################
# Define server logic ----
#############################################################
server <- function(input, output, session) {

  # Reset parameters
  observeEvent(input$reset, {
    updateSliderInput(session,'alt_sI',value = base_sI)
    updateSliderInput(session,'alt_gL',value = base_gL)
    updateSliderInput(session,'alt_gA',value = base_gA)
    updateSliderInput(session,'alt_delta',value = base_delta)
    updateSliderInput(session,'alt_alpha',value = base_alpha)
  })

  output$gkalgraph <- renderPlot(
    {
      kalstar = (input$alt_sI/(input$alt_gL + input$alt_gA + input$alt_delta))^(1/(1-input$alt_alpha))
      tick <- seq(0,12,.1) # arbitrary kal values
      df <- data.frame(tick) # create dataframe
      df$gk <- input$alt_sI/(df$tick^(1-input$alt_alpha))- input$alt_delta
      reverse = (input$alt_sI/(input$alt_delta+.12))^(1/(1-input$alt_alpha))

      ggplot(df, aes(x=tick)) +
        geom_line(aes(y = gk),size=1) +
        geom_hline(yintercept=input$alt_gA+input$alt_gL, linetype="dashed", color = "black",size=1) +
        geom_vline(xintercept=kalstar, linetype="dotted", color = "black") +
        annotate(geom="text", x=9, y=input$alt_gA+input$alt_gL+.005,
                 label="gA + gL",size=6) +
        annotate(geom="text", x=kalstar+1.6, y=.12,
                 label="K/AL steady state",size=6) +
        annotate(geom="text", x=reverse-.4, y=.12,
                 label="gK",size=6) +
        xlab("K/AL ratio") +
        ylab("Growth rates") +
        theme_light() +
        ylim(-.01,.12)
    }
  ) # end gky graph

} # end server

# Run the app ----
shinyApp(ui = ui, server = server)


# Introduction to Vector

# Create  vector

# Using seq function

# create a vector with number from 1 to 100
a <- seq(1,100)
print(a)

# create a vector with number from 1 to 100 with step size 2 (1,3,5,7,....,99)
b <- seq(1,100,2)
print(b)

# create a vector with rep function (five times 0)
c <- rep(0,5)
print(c)

# print number of elements in vector (lenght function)
l <- length(b)
print('Number of elements in vector b:')
print(l)

# Other data types vectors can also be created
d <- rep(TRUE,5)
print(d)

# Access elements from Vector
# Elements can be accessed by specifying their index number
# e.g., access third element from vector b
e <- b[3]
print(e)

# access elements starting from third to eleventh indices in vector b
f <- b[3:11]
print(f)

# Delete vector a [Just assign NULL]
a <- NULL
print(a)


# Group members (Name, Student ID, E-Mail):
# 1. Baldomero Valdez,  Valenzuela, 2905175, baldmer.w@gmail.com
# 2. Omar Trinidad Gutierrez Mendez, 2850441, omar.vpa@gmail.com
# 3. Shinho Kang, 2890169, wis.shinho.kang@gmail.com

# Exercise 4.2

# install `multtest` package
# source("https://bioconductor.org/biocLite.R")
# biocLite("multtest")

setwd("~/current-lectures/ml_bioinformatics/Ex4/")
library(multtest)
data(golub)

# a) calculate the mean and variance of all pooled expression data
meanGolub = apply(golub, 1, mean)
varGolub = apply(golub, 1, var)
sdGolub = apply(golub, 1, sd)

# b) means and standard deviations of the expression level for every gene for
# the classes ALL and AML

# i. create glb.fac
glb.fac = factor(golub.cl, levels=0:1, labels=c("ALL", "AML"))

meanALL = apply(golub[, glb.fac=="ALL"], 1, mean)
sdALL = apply(golub[, glb.fac=="ALL"], 1, sd)
meanAML = apply(golub[, glb.fac=="AML"], 1, mean)
sdAML = apply(golub[, glb.fac=="AML"], 1, sd)

# ii. 5 genes with the largest mean expression for ALL
largestALL = order(meanALL, decreasing = T)
print("5 genes with the largest mean expression for ALL")
print(golub.gnames[largestALL[1:5], 2])

# ii. 5 genes with the largest mean expression for AML
largestAML = order(meanAML, decreasing = T)
print("5 genes with the largest mean expression for AML")
print(golub.gnames[largestAML[1:5], 2])

# selection of the oncogene
oncogenes = grep('oncogene', golub.gnames[ , 2], ignore.case = T)

# iii. 5 oncogenes with the largest mean expression for ALL
meanOncoALL = apply(golub[oncogenes, glb.fac=="ALL"], 1, mean)
largestOncoALL = order(meanOncoALL, decreasing = T)
loncoALL = oncogenes[largestOncoALL[1:5]]
print("5 oncogenes with the largest mean expression for ALL")
print(golub.gnames[loncoALL, 2])

# iii. 5 oncogenes with the largest mean expression for AML
meanOncoAML = apply(golub[oncogenes, glb.fac=="AML"], 1, mean)
largestOncoAML = order(meanOncoAML, decreasing = T)
loncoAML = oncogenes[largestOncoAML[1:5]]
print("5 oncogenes with the largest mean expression for AML")
print(golub.gnames[loncoAML, 2])

# iv. genes with largest different in expression between the two classes
difference <- order(abs(meanAML-meanALL), decreasing=TRUE)

# print this on a file
names = golub.gnames[difference[1:5], 2]
mean = meanGolub[difference[1:5]]
standard_deviation = sdGolub[difference[1:5]]
data_frame = data.frame(names, mean, standard_deviation)
write.csv(data_frame, file = "Ex4_2b_iv.csv")

# 2c. Select gene 1042
geneCCND3 = split(golub[1042, ], glb.fac)

# i. Boxplot for the expression data
png(filename="boxplot.png")
boxplot(golub[1042,] ~ glb.fac,
        main="Boxplot GeneCCND3",
        xlab="Class",
        ylab="Expression",
        col=c("tomato", "green")
        )
dev.off()

# ii. Q-Q plot with theoretical normal distribution

#
png(filename="qq-plot.png")
par(mfrow=c(1, 2))
qqnorm(geneCCND3$ALL)
qqline(geneCCND3$ALL)
qqnorm(geneCCND3$AML)
qqline(geneCCND3$AML)
dev.off()

# iii. We have to apply the unpaired two-sample t-test (page 94).
# we can see that the size and variance of the two groups are different:
# length(geneCCND3$AML) == length(geneCCND3$ALL)
# var(geneCCND3$AML) == var(geneCCND3$ALL)
# so, we can apply the Welch t-test

ttest = t.test(geneCCND3$AML, geneCCND3$ALL)

# iv. Use a non-parametric test. The Kolmogorov-Smirnov test
kolmogorov = ks.test(geneCCND3$AML, geneCCND3$ALL)

# Shapiro-wilk test
a = shapiro.test(geneCCND3$AML)
b = shapiro.test(geneCCND3$ALL)

# 2d. Perform t-test for all genes comparing the distributions for ALL and AML.

# i. comparison of p-value and alpha
# if p-value < 0.05 we find a significant difference

pvalues <- apply(golub, 1, function(x) t.test(x ~ glb.fac)$p.value)
alpha = 0.05
results = table(pvalues < alpha)
total_i = results[names(results) == T]
print("Genes with significant differences are:")
print(total_i)

# ii. Given that we have more hypothesis, we increase the likelihood of a rare
# event, then we increase the likelihood of incorrectly rejecting a null
# hypothesis.

# iii. Using Bonferroni correction we will redefine the alpha value
# alpha = alpha / number of samples

bonferroni = alpha/nrow(golub)
conf_level = 1 - bonferroni

# modify the alpha value with the parameter conf.level in t.test function
pvalues <- apply(golub, 1, function(x) t.test(x ~ glb.fac, conf.level=conf_level)$p.value)
results = table(pvalues < bonferroni)

total_iii = results[names(results) == T]
print("Genes with significant differences are:")
print(total_iii)


nor_hie <-
  shapiro.test(trees$Height) #shapiro test and storing the value in a variable
if (nor_hie$p.value < 0.05) {
  #checkign if the p value if less than significance value
  print("the tree heights does no follow a normal distribution")
} else {
  print("the tree heights follow a normal distribution")
}

R Community/R Stats_Basics Part 1/Assignment3.r


## ----author info, include=F----------------------------------------------
## Author:  Yanchang Zhao
## Email:   yanchang@RDataMining.com
## Website: http://www.RDataMining.com
## Date:    9 December 2018

## ----download data, eval=F, tidy=F, warning=F----------------------------
## ## download data
## download.file(url="http://www.rdatamining.com/data/titanic.raw.rdata",
##               destfile="./data/titanic.raw.rdata")

## ----load data-----------------------------------------------------------
library(magrittr) ## for pipe operations
## load data, and the name of the R object is titanic.raw
load("./data/titanic.raw.rdata")
## dimensionality
titanic.raw %>% dim()
## structure of data
titanic.raw %>% str()

## ----check data----------------------------------------------------------
## draw a random sample of 5 records
idx <- 1:nrow(titanic.raw) %>% sample(5)
titanic.raw[idx, ]
## a summary of the dataset
titanic.raw %>% summary()

## ----mine association rules----------------------------------------------
library(arules) ## load required library
rules.all <- titanic.raw %>% apriori() ## run the APRIORI algorithm

## ----have a look at rules------------------------------------------------
rules.all %>% length() ## number of rules discovered
rules.all %>% inspect() ## print all rules

## ----mine rules with constraints, tidy=F---------------------------------
## run APRIORI again to find rules with rhs containing "Survived" only
rules.surv <- titanic.raw %>% apriori(
             control = list(verbose=F),
             parameter = list(minlen=2, supp=0.005, conf=0.8),
             appearance = list(rhs=c("Survived=No",
                                     "Survived=Yes"),
                               default="lhs"))
## keep three decimal places
quality(rules.surv) <- rules.surv %>% quality() %>% round(digits=3)
## sort rules by lift
rules.surv.sorted <- rules.surv %>% sort(by="lift")

## ----inspect rules-------------------------------------------------------
rules.surv.sorted %>% inspect() ## print rules

## ----redundant rules-----------------------------------------------------
rules.surv.sorted[1:2] %>% inspect()

## ----find redundant rules------------------------------------------------
## find redundant rules
subset.matrix <- is.subset(rules.surv.sorted, rules.surv.sorted)
subset.matrix[lower.tri(subset.matrix, diag=T)] <- F
redundant <- colSums(subset.matrix) >= 1

## ----remove redundant rules----------------------------------------------
## which rules are redundant
redundant %>% which()

## remove redundant rules
rules.surv.pruned <- rules.surv.sorted[!redundant]

## ----inspect pruned rules - 1--------------------------------------------
rules.surv.pruned %>% inspect() ## print rules

## ----inspect pruned rules - 2--------------------------------------------
rules.surv.pruned[1] %>% inspect() ## print rules

## ----mine rules about class and age group, tidy=F------------------------
rules.age <- titanic.raw %>% apriori(control = list(verbose=F),
     parameter = list(minlen=3, supp=0.002, conf=0.2),
     appearance = list(default="none", rhs=c("Survived=Yes"),
                       lhs=c("Class=1st", "Class=2nd", "Class=3rd",
                             "Age=Child", "Age=Adult")))
rules.age <- sort(rules.age, by="confidence")

## ----inspect age group related rules-------------------------------------
rules.age %>% inspect() ## print rules
## average survival rate
titanic.raw$Survived %>% table() %>% prop.table()

## ----scatter plot, out.height=".8\\textheight", out.width=".8\\textwidth"----
library(arulesViz)
rules.all %>% plot()

## ----grouped rules, out.height=".9\\textheight"--------------------------
rules.surv %>% plot(method="grouped")

## ----graph - 1, tidy=F, out.height=".9\\textheight"----------------------
rules.surv %>% plot(method="graph",
                    control=list(layout=igraph::with_fr()))

## ----graph - 2, tidy=F, out.height=".9\\textheight"----------------------
rules.surv %>% plot(method="graph",
                    control=list(layout=igraph::in_circle()))

## ----parallel coordinates, out.height=".8\\textheight", tidy=F-----------
rules.surv %>% plot(method="paracoord",
                    control=list(reorder=T))

## ----interactive plot, eval=F, tidy=F------------------------------------
## rules.all %>% plot(interactive = T)

## ----reorder rules, eval=F-----------------------------------------------
## rules.surv %>% plot(method="paracoord", control=list(reorder=T))


library(odin)
library(reshape2)
library(ggplot2)

sir_ode <- odin::odin({
  ## Derivatives
  deriv(S) <- -b*S*I
  deriv(I) <- b*S*I-g*I
  deriv(R) <- g*I

  ## Initial conditions
  initial(S) <- 0.99
  initial(I) <- 0.01
  initial(R) <- 0.00

  ## parameters
  b <- 0.1
  g <- 0.05
  config(base) <- "sir"
}, ".")

sir_mod <- sir_ode()
times <- seq(0,200,length.out=2001)
sir_out <- sir_mod$run(times)

sir_out_long <- melt(as.data.frame(sir_out),"t")

# Plot
ggplot(sir_out_long, aes(x=t, y=value, colour=variable, group=variable)) +
  geom_line(lwd=2) + xlab("Time")+ylab("Number")


#corrrlation cofficient
# Cholesterol Reading
y=c(133,137,148,149,152,167,174,179,189,192,201,209,210,211,218,238,245,248,253,257)
#Normal Quantile
x=c(-1.868,-1.403,-1.128,-.919,-.744,-.589,-.448,-.315,-.187,-.062,.062,.187,.315,.448,.589,.744,.919,1.128,1.403,1.868)

# correlation cofficient
 cor(y,x)


#' Evaluate the cumulative distribution function of a density approximation
#'
#' Currently only implemented for Gaussian mixtures.
#' @param fit An mvd.density object obtained from one of the density fitting functions.
#' @param x Matrix or vector of positions at which to evaluate the density function.
#' @param log Boolean which specifies whether to return the cumulative probability in log space.
#' @export
mvd.cdf <- function(fit, x, log = FALSE) {
    stopifnot(class(fit) == "mvd.density")

    if (fit$type == "gmm") {
        if (is.matrix(x)) {
            stopifnot(ncol(x) == ncol(fit$centers))

          p <- matrix(NA, nrow(x), fit$K)
          for (ki in 1:fit$K) {
            if (log) {
              p[, ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
            } else {
              p[, ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
            }
          }

          if (log) {
            return(apply(p, 1, .logsum))
          } else {
            return(apply(p, 1, sum))
          }
        } else {
          stopifnot(length(x) == ncol(fit$centers))

          p <- rep(NA, fit$K)
          for (ki in 1:fit$K) {
            if (log) {
              p[ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = TRUE) + log(fit$proportions[ki])
            } else {
              p[ki] <- mvtnorm::pmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], log = FALSE) * fit$proportions[ki]
            }
          }

          if (log) {
            return(.logsum(p))
          } else {
            return(sum(p))
          }
        }
    } else if (fit$type == "gmm.truncated") {
      if (is.matrix(x)) {
        stopifnot(ncol(x) == ncol(fit$centers))

        p <- matrix(NA, nrow(x), fit$K)
        for (ki in 1:fit$K) {
          if (log) {
            p[, ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
          } else {
            p[, ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
          }
        }

        if (log) {
          return(apply(p, 1, .logsum))
        } else {
          return(apply(p, 1, sum))
        }
      } else {
        stopifnot(length(x) == ncol(fit$centers))

        p <- rep(NA, fit$K)
        for (ki in 1:fit$K) {
          if (log) {
            p[ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = TRUE) + log(fit$proportions[ki])
          } else {
            p[ki] <- tmvtnorm::ptmvnorm(x, fit$centers[ki,], fit$covariances[[ki]], lower = fit$bounds[, 1], upper = fit$bounds[, 2], log = FALSE) * fit$proportions[ki]
          }
        }

        if (log) {
          return(.logsum(p))
        } else {
          return(sum(p))
        }
      }
    } else {
      stop("Unknown type or not implemented")
    }
}


#-- this codes perfomes a PCA + stat on first discriminant
#input : Multi_datainput_m (after get_behav_gp.r)
#ouput : plspca (plot) and PCA_pval (PCA_pval$p.value)

#---------------------1 make the pca on data
input.pca <- prcomp(Multi_datainput_m %>% select (-groupingvar),
                    center = TRUE,
                    scale. = TRUE)

#---------------------2  statistics on pc1:
Moddata = as.data.frame(input.pca$x)
Moddata$groupingvar = as.factor(Multi_datainput_m$groupingvar)

#-- Mann-Whitney test if 2 groups, Kruskal-Wallis rank sum test otherwise
if (length(levels (Moddata$groupingvar)) == 2) {
  PCA_pval = wilcox_test(PC1 ~ groupingvar, data = Moddata)
  PCA_effectsize = wilcox_effsize(data= Moddata, PC1 ~ groupingvar, comparisons = NULL, ref.group = NULL,
                                  paired = FALSE, alternative = "two.sided", mu = 0, ci = FALSE,
                                  conf.level = 0.95, ci.type = "perc", nboot = 1000)

} else {
  PCA_pval = kruskal_test(PC1 ~ groupingvar, data = Moddata)
  PCA_effectsize = kruskal_effsize(Moddata, PC1 ~ groupingvar, ci = FALSE, conf.level = 0.95,
                                            ci.type = "perc", nboot = 1000)
}

#-- effect size calculation

#-- put stat results in a text
PCA_res <- ifelse (
  pvalue(PCA_pval) < .05,
  paste0("p < ", signif(pvalue(PCA_pval), digits = 2), ", effect size is ", PCA_effectsize$magnitude, " (Z/square(N) = ",signif(PCA_effectsize$effsize, digits = 2),
         ")."),
  "no statistically significant difference."
)

#-- plot 2 PC, add stat text in axes legend
plspca = Moddata %>% ggplot (aes (x = PC1, y = PC2, color = groupingvar)) +
  geom_point() +
  labs (title = paste0("PCA results (", groupingby, " variables grouping)")) +
  scale_colour_grey() + theme_bw() +
  labs(x = paste0 ("PC1: ", PCA_res))

#print(plspca)

#-- Plot boxplot of PC1

# calculate sample size
a <-
  aggregate(PC1 ~ groupingvar + groupingvar , Moddata, function(i)
    c(val = length(i), ypos = quantile(i)[2]))

#do boxplot, stat result as text between groups

boxplotPCA1 = Moddata %>% ggplot (aes (x = groupingvar, y = PC1, color = groupingvar)) +
  geom_boxplot(position = position_dodge(width = 0.9)) +
  labs (title = paste0("PCA results (", groupingby, " variables grouping)")) +
  geom_text(x = 1.5,
            y = max(Moddata$PC1) - 1,
            label = PCA_res) +
  geom_text(data = a,
            aes(y = PC1[, 2] + 0.5, label = paste0("n = ", PC1[, 1])),
            position = position_dodge(width = 0.9)) +
  theme_bw() +  theme(legend.position = 'none') +
  labs(x = metadata$group_by[1])


library(doParallel)
library(foreach)

## Exercise 1

guess <- c()
for(i in 1:nchar(word)){

  for(j in 1:52){
    if(substr(word,i,i) == c(letters,LETTERS)[j]) {
      break
    }
  }
  guess <- c(guess,c(letters,LETTERS)[j]) ## output guess letter
  guess <- paste(guess, collapse="")
}
print(paste0(guess, " Number of guesses = ", (i*52)+j))

## set up cluster
cl <- makeCluster(6, type="PSOCK")
registerDoParallel(cl)

## Solution 1
guess <- foreach(i = 1:nchar(word), .combine=paste0)  %dopar% {
  iletter <- substr(word,i,i) ## which word is being selected
  guessletter <- grep(iletter, c(letters,LETTERS), value=T) ## select the matching letter
  guessletter ## output selected letter

}
print(paste0(guess," Number of guesses = ",nchar(word)))

### Exercise 2

head(climate)
head(population)

trees <- c(500,1000,1500,2000)
mtrys <- 1:ncol(climate)

outDF <- data.frame()
for(i in trees){
  for(j in mtrys){

    rf1 <- randomForest(Pop1 ~ MAT + MAP + TMN + TMX, importance=T, ntree=i, data=population)
    RSQ <- rf1$rsq[length(rf1$rsq)] ## extract psuedo rsquared values
    MSE <- rf1$mse[length(rf1$mse)] ## extracted mean square errors
    tempDF <- data.frame(ntrees = i, mtry = j, rsq=RSQ, mse=MSE) ## create dataframe of parameters and outputs
    outDF <- rbind(outDF, tempDF)
  }
}
outDF

### Create cluster

cl <- makeCluster(4, type="PSOCK")
registerDoParallel(cl)

## Load different parameters
trees <- c(500,1000,1500,2000)
mtrys <- 1:ncol(climate)

##
# clusterExport(cl, c("climate", "population", "trees","mtrys")) ## NB you need to specify cluster

outDF <-foreach(i = trees, .combine=rbind, .packages=c("foreach","randomForest")) %:%
  foreach(j = mtrys, .combine=rbind, .packages=c("randomForest")) %dopar% {

    rf1 <- randomForest(Pop1 ~ MAT + MAP + TMN + TMX, importance=T, ntree=i, mtrys=j, data=population)
    RSQ <- rf1$rsq[length(rf1$rsq)] ## extract psuedo rsquared values
    MSE <- rf1$mse[length(rf1$mse)] ## extracted mean square errors
    tempDF <- data.frame(ntrees = i, mtry = j, rsq=RSQ, mse=MSE) ## create dataframe of parameters and outputs
    tempDF
  }
outDF
stopCluster(cl)


#' Expected path costs
#'
#' This function calculates expected path costs as a function of mean link flows under various probability models. Its primary use is when called by the function GSUE. For the product multinomial model, a normal approximation to higher order moments is applied unless the link path incidencde matrix is diagonal.
#'
#' @param x Vector of mean link flows
#' @param ODdemand Vector of origin-destination (OD) travel demands
#' @param ODpair Vector indicating the OD pair serviced by each route (ordered by columns of the path-link incidence matrix, A).
#' @param A Path-link incidence matrix
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @param theta A dispersion parameter. For the logit model, a single value specifying the logit parameter. For the probit model, a vector of standard deviations for the individual link cost errors. Defaults to 1.
#' @param prob.model Route choice probability model. One of "ProductMN" (product multinomial, the default), or "Poisson".
#' @return Vector of expected path costs
#' @keywords expected mean path costs
#' @examples
#' ExpectedPathCost()
#' @export

ExpectedPathCost <- function(x,ODdemand,ODpair,A=diag(length(x)),Alpha,Beta,pow=4,prob.model="ProductMN"){
	Beta[pow==0] <- 1
	if(prob.model=="Poisson"){
		Omega <- A%*%diag(x)%*%t(A)
		omega <- diag(Omega)
		nu <- A%*%x
		ec <- (pow==0)*Alpha + (pow==1)*Alpha*(1 + 0.15*nu/Beta) + (pow==2)*Alpha*(1 + 0.15*((nu/Beta)^2 + omega/Beta^2)) + (pow==4)*Alpha*(1 + 0.15*((nu/Beta)^4 + 6*(nu/Beta)^2*omega/Beta^2 + 3*(omega/Beta^2)^2))
		u <- c(t(A)%*%ec)
	}
	if(prob.model=="ProductMN"){
		if(!is_diag(A)){
			N.routes <- ncol(A)
 			N.OD <- length(ODdemand)
			N.routes.per.OD <- unname(table(ODpair))
			ODdemand.rep <- rep(ODdemand,N.routes.per.OD)
			pp <- x/ODdemand.rep
  			indices <- c(0,cumsum(N.routes.per.OD))
  			Vxx <- matrix(0,ncol=N.routes,nrow=N.routes)
  			for (i in 1:N.OD){
    				indx <- (indices[i]+1):(indices[i+1])
    				Vxx[indx,indx] <- ODdemand[i]*(diag(pp[indx])-pp[indx]%*%t(pp[indx]))
  			}
			Omega <- A%*%Vxx%*%t(A)
			omega <- diag(Omega)
			nu <- A%*%x
			ec <- (pow==0)*Alpha + (pow==1)*Alpha*(1 + 0.15*nu/Beta) + (pow==2)*Alpha*(1 + 0.15*((nu/Beta)^2 + omega/Beta^2)) + (pow==4)*Alpha*(1 + 0.15*((nu/Beta)^4 + 6*(nu/Beta)^2*omega/Beta^2 + 3*(omega/Beta^2)^2))
			u <- c(t(A)%*%ec)
		}
		if(is_diag(A)){
			pp <- x/ODdemand
			nu <- x
			omega2 <- x*(1-pp)
			omega3 <- omega2*(1-2*pp)
			omega4 <- omega2*(1+3*(1-2/ODdemand)*omega2)
			nu2 <- nu^2 + omega2
			nu4 <- nu^4 + 6*omega2*nu^2 + 4*omega3*nu + omega4
    			u <- (pow==0)*Alpha + (pow==1)*Alpha*(1 + 0.15*nu/Beta) + (pow==2)*Alpha*(1 + 0.15*nu2/Beta^2) + (pow==4)*Alpha*(1 + 0.15*nu4/Beta^4)
		}
	}
	u
}


install.packages(c('caret', 'mlbench', 'gbm', 'e1071'))
setwd("~/aws-fargate-with-rstudio-open-source/ml_example")
library(caret)
library(mlbench)

data(BreastCancer)
summary(BreastCancer) #Summary of Dataset

df <- BreastCancer
# convert input values to numeric
for(i in 2:10) {
  df[,i] <- as.numeric(as.character(df[,i]))
}

# split the data into train and test and perform preprocessing
trainIndex <- createDataPartition(df$Class, p = .8,
                                  list = FALSE,
                                  times = 1)
df_train <- df[ trainIndex,]
df_test  <- df[-trainIndex,]
preProcValues <- preProcess(df_train, method = c("center", "scale", "medianImpute"))
df_train_transformed <- predict(preProcValues, df_train)

# train a model on df_train
fitControl <- trainControl(## 10-fold CV
                          method = "repeatedcv",
                          number = 10,
                          ## repeated ten times
                          repeats = 10,
                          ## Estimate class probabilities
                          classProbs = TRUE,
                          ## Evaluate performance using
                          ## the following function
                          summaryFunction = twoClassSummary)

set.seed(825)
gbmFit <- train(Class ~ ., data = df_train_transformed[,2:11],
                 method = "gbm",
                 trControl = fitControl,
                 ## This last option is actually one
                 ## for gbm() that passes through
                 verbose = FALSE,
                 metric = "ROC")
gbmFit

saveRDS(preProcValues, file = './breast-cancer-prediction/preProcessor.rds')
saveRDS(gbmFit, file = './breast-cancer-prediction/gbm_model.rds')
saveRDS(df_test[,1:10], file = './breast-cancer-prediction/breast_cancer_test_data.rds')


library("ggplot2")

t0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2010/master/csv/ti_1500_2xxx_monthly.csv", sep=",", na = "NA")
t1 <- t0[,c("year","month","ti")]
p0 <- read.csv("https://raw.githubusercontent.com/climdata/glaser2019/master/csv/pi_1500_2xxx_monthly.csv", sep=",", na = "NA")
prec0 <- read.csv("https://raw.githubusercontent.com/climdata/dwdTemperature/master/csv/monthly_temperature_de.csv", sep=",", na = "NA")
prec1 <- prec0[, c("year","month","Deutschland")]

tpsFull <- merge(t1,p0, by=c("year","month"))
tpsFull$t1 <- sin((tpsFull$month-1)*pi/6)
tpsFull$t2 <- cos((tpsFull$month-1)*pi/6)
tpsFull$t3 <- sin((tpsFull$month-1)*pi/3)
tpsFull$t4 <- cos((tpsFull$month-1)*pi/3)
tpsFull$t5 <- sin((tpsFull$month-1)*pi/2)
tpsFull$t6 <- cos((tpsFull$month-1)*pi/2)

tpsCal <- merge(tpsFull,prec1, by=c("year","month"))

tpsCal <- tpsCal[order(tpsCal$ts),]
tpsFull <- tpsFull[order(tpsFull$ts),]

mx <- lm(Deutschland ~ (pi+ti)*(t1+t2+t3+t4+t5+t6), tpsCal)
summary(mx)
prCal <- predict(mx, newdata=tpsCal, se.fit=TRUE)
tpsCal$temp <- prCal$fit
tpsCal$temp.se <- prCal$se

p <- ggplot(data = tpsCal, aes(x = Deutschland, y = temp)) +
  geom_point(aes(y = temp), color="#00FF00", alpha=0.5, size=2)
p

prFull <- predict(mx, newdata=tpsFull, se.fit=TRUE)
tpsFull$temperature <- prFull$fit
tpsFull$temperature.se <- prFull$se

#FFT
pic <- tpsFull$temperature
len <- length(pic)
## mirror pic
pic <- append(pic, pic)
for(i in 1:len) {
  pic[i+len] <- pic[1+len-i]
}
frq <- fft(pic, inverse = FALSE)
frq1 <- frq
filterYears = 5.0   #filter 5y
start = round(len/(12*filterYears))
stop  = round(2*len-start)
frq1[start:stop] <- 0.0
pic1 <- Re(fft(frq1, inverse = TRUE)/length(frq1))
pic1 <- pic1[1:len]
tpsFull$temp5 <- pic1

p <- ggplot()
p + geom_line(aes(y=tpsFull$temp5, x=tpsFull$ts), color="blue")

p <- ggplot(data = tpsFull, aes(x = ts, y = temp5)) +
  geom_line(aes(y = temp5), color="#FF0000", size=2)
p

color.temperature <- c("#0000FF", "#00CCCC", "#FFFFFF", "#EEAA33", "#FF5555")

mp <- ggplot(tpsFull, aes(year, month))
mp + geom_raster(aes(fill=temperature))+
  scale_y_continuous(breaks=c(1,6,12))+
  geom_line(aes(y=tpsFull$temp5, x=tpsFull$ts), color="blue") +
  theme_classic(base_size=80) +
  theme(panel.background = element_rect(fill = '#EEEEEE', colour = 'white'), legend.position="right", text=element_text(size=14))+
  scale_fill_gradientn(colours=color.temperature)


balanced <- function(str){
  str <- strsplit(str, "")[[1]]
  str <- ifelse(str=='[', 1, -1)
  all(cumsum(str) >= 0) && sum(str) == 0
}


########################################################################
#                                                                      #
#   finite-set.rb                                                      #
#                                                                      #
########################################################################
=begin
[((<index|URL:index.html>))]
[((<finite-map|URL:finite-map.html>))]
((<Algebra::Set>))
/
((<Enumerable>))

= Algebra::Set
((*Class of Set*))

This is the class of sets. The conclusion relationship is determined by
((|each|)) and ((<member?>)), that is, ((|s|)) is the subset of ((|t|))
if and only if
  s.all?{|x| t.member?(x)}
is true.

== File Name:
* ((|finite-set.rb|))

== SuperClass:
* ((|Object|))

== Included Module:

* ((|Enumerable|))

== Class Methods:

--- ::[]([obj0, [obj1, [obj2, ...]]])
    Creates ((|Set|)) objects from parameters.

    Example: Create {"a", [1, 2], 0}
      require "finite-set"
      p Algebra::Set[0, "a", [1, 2]]
      p Algebra::Set.new(0, "a", [1, 2])
      p Algebra::Set.new_a([0, "a", [1, 2]])
      p Algebra::Set.new_h({0=>true, "a"=>true, [1, 2]=>true})

--- ::new([obj0, [obj1, [obj2, ...]]])
    Creates ((|Set|)) objects from parameters.

--- ::new_a(a)
    Creates ((|Set|)) objects from an array ((|a|)).

--- ::new_h(h)
    Creates ((|Set|)) objects from a hash.

--- ::empty_set
    Returns the empty set.

--- ::phi
--- ::null
    Alias of ((<::empty_set>)).

--- ::singleton(x)
    Creates the set of one element ((|x|)).

== Methods:

--- empty_set
    Returns the empty set.

--- phi
--- null
    Alias of ((<::empty_set>)).

--- empty?
    Returns true if ((|self|)) is the empty set.

--- phi?
--- empty_set?
--- null?
    Alias of ((<empty?>))

--- singleton(x)
    Creates the set of one element ((|x|)).

--- singleton?
    Returns true if ((|self|)) is a singleton set.

--- size
    Returns the size of ((|self|)).

--- each
    Iterates the block with the block parameter of each element.
    The order of iteration is indefinite.

    Example:
      require "finite-set"
      include Algebra
      Set[0, 1, 2].each do |x|
        p x #=> 1, 0, 2
      end

--- separate
    Returns the set of the elements which make the block true.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].separate{|x| x % 2 == 0} #=> {2, 0}

--- select_s
--- find_all_s
    Alias of ((<separate>))

--- map_s
    Return the set of the values of the block.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 1, 2, 3].map_s{|x| x % 2 + 1} #=> {2, 1}

--- pick
    Returns a elements of ((|self|)). The chois is indefinite.

--- shift
    Takes an element from ((<self>)) and returns it.

    Example:
      require "finite-set"
      include Algebra
      s = Set[0, 1, 2, 3]
      p s.shift #=> 2
      p s #=> {0, 1, 3}

--- dup
    Returns the duplication of ((|self|)).

--- append!(x)
    Appends ((|x|)) to ((|self|)) and returns ((|self|)).

--- push
--- <<
    Alias of ((|append!|)).

--- append(x)
    Duplicates and appends ((|x|)) to it and returns it.

--- concat(other)
    Adds the all elements of ((|other|)). This is the destructive
    version of ((<+>)).

--- rehash
    Rehashes the internal ((|Hash|)) object.

--- eql?(other)
    Returns true if ((|self|)) is equal to ((|other|)). This is
    equivalent to (({ self >= other and self <= other})).

--- ==
    Alias of eql?

--- hash
    Returns the hash value of ((|self|)).

--- include?(x)
    Returns true if ((|x|)) is a element of ((|self|)).

--- member?
--- has?
--- contains?
    Alias of ((<include>)).

--- superset?(other)n
    Returns true if ((|self|)) containds ((|other|)).
    This is equivalent to (({other.all{|x| member?(x)}})).

--- >=
--- incl?
    Alias of (({superset?})).

--- subset?(other)
    Returns true if ((|self|)) is a subset of ((|other|)).

--- <=
--- part_of?
    Alias of ((<subset?>)).

--- <(other)
    Returns true if ((|self|)) is a proper subset of ((|other|)).

--- >(other)
    Returns true if ((|other|)) is a proper subset of ((|self|)).

--- union(other = nil)
    Returns the union of ((|self|)) and ((|other|)).
    If ((|other|)) is omitted, returns the union of the
    ((|self|)) the set of sets.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cup Set[1, 3] #=> {0, 1, 2, 3, 4}
      s = Set[*(0...15).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].union #=> {1, 7, 11, 13}

--- |
--- +
--- cup
    Alias of ((<union>)).

--- intersection(other = nil)
    Returns the intersection of ((|self|)) and ((|other|)).
    If ((|other|)) is omitted, returns the intersection of the
    ((|self|)) the set of sets.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 2, 4].cap(Set[4, 2, 0]) #=> {0, 2, 4}
      s = Set[*(0..30).to_a]
      s2 = s.separate{|x| x % 2 == 0}
      s3 = s.separate{|x| x % 3 == 0}
      s5 = s.separate{|x| x % 5 == 0}
      p Set[s2, s3, s5].cap #=> {0, 30}

--- &
--- cap
    Alias of ((<intersection>)).

--- difference(other)
    Returns the set of the elements of ((|self|)) which are not in
    ((|other|)).

--- -
    Alias of ((<difference>)).

--- each_pair
    Iterates with each two different elements of ((|self|)).

    Example:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_pair do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_member(n)
    Iterates with each ((|n|)) different elements of ((|self|)).

    Example:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_member(2) do |x, y|
        s.push [x, y]
      end
      p s == Set[[0, 1], [0, 2], [1, 2]] #=> true

--- each_subset
    Iterates over each subset of ((|self|)).

    Example:
      require "finite-set"
      include Algebra
      s = Set.phi
      Set[0, 1, 2].each_subset do |t|
        s.append! t
      end
      p s.size = 2**3 #=> true

--- each_non_trivial_subset
    Iterates over each non trivial subset of ((|self|))

--- power_set
    Returns the set of subsets.

--- each_product(other)
    Iterates over for each ((|x|)) in ((|self|)) and
    each ((|y|)) in ((|other|))

    Exameple:
      require "finite-set"
      include Algebra
      Set[0, 1].each_prodct(Set[0, 1]) do |x, y|
        p [x, y] #=> [0,0], [0,1], [1,0], [1,1]
      end

--- product(other)
    Returns the product set of ((|self|)) and ((|other|)).
    The elements are the arrays of type (({[x, y]})).
    If the block is given, it returns the set which consists
    of the value of the block.

    Example:
      require "finite-set"
      include Algebra
      p Set[0, 1].product(Set[0, 1]) #=> {[0,0], [0,1], [1,0], [1,1]}
      p Set[0, 1].product(Set[0, 1]){|x, y| x + 2*y} #=> {0, 1, 2, 3]

--- *
    Alias of ((<product>)).

--- equiv_class([equiv])
    Returns the quotient set by the equivalent relation.
    The relation are given as following:

    (1) The evaluation of the block:
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class{|a, b| (a - b) % 3 == 0} #=> {{0, 3}, {1, 4}, {2, 5}}
    (2) The value of the instance method
        ((|call(x, y)|)) of the parameter.
          require "finite-set"
          include Algebra
          o = Object.new
          def o.call(x, y)
            (x - y) % 3 == 0
          end
          s = Set[0, 1, 2, 3, 4, 5]
          p s.equiv_class(o) #=> {{0, 3}, {1, 4}, {2, 5}}
    (3) The value of method indicated ((|Symbol|)).
          require "finite-set"
          include Algebra
          s = Set[0, 1, 2, 3, 4, 5]
          def q(x, y)
            (x - y) % 3 == 0
          end
          p s.equiv_class(:q) #=> {{0, 3}, {1, 4}, {2, 5}}

--- /
    Alias of ((<equiv_class>)).

--- to_a
    Returns the array of elements. The order is indefinite.

--- to_ary
    Alias of ((<to_a>)).

--- sort
    Returns the value of (({to_a.sort})).

--- power(other)
    Returns the all maps from ((|other|)) to ((|self|)).
    The maps are the instances of ((<Map|URL:finite-map.html>)).

    Example:
      require "finite-map"
      include Algebra
      a = Set[0, 1, 2, 3]
      b = Set[0, 1, 2]
      s =
      p( (a ** b).size )      #=> 4 ** 3 = 64
      p b.surjections(a).size #=> S(3, 4) = 36
      p a.injections(b).size  #=> 4P3 = 24

--- ** power
    Alias of ((<power>)).

--- identity_map
    Returns the identity map of ((|self|)).

--- surjections(other)
    Returns all surjections from ((|other|)) to((|self|)).

--- injections(other)
    Returns all injections from ((|other|)) to((|self|)).

--- bijections(other)
    Returns all bijections from ((|other|)) to((|self|)).

#--- monotonic_series #what is this?
#
#    Example:

= Enumerable

== File Name:
* ((|finite-set.rb|))

== Methods:

--- any?
    Returns true when the block is true for some elements.
    This is the alias of ((|Enumerable#find|))
    (built-in method of ruby-1.8).

--- all?
    Returns true when the block is true for all elements.
    This is defined by:

      !any?{|x| !yield(x)}

    (These are built-in methods of ruby-1.8).

=end