#  James Rekow

cohortCreator = function(M, N, iStrength = 1, univ = 1, sigmaMax = 0.1){

  #  ARGS: M - Number of samples
  #        N - Number of species per sample
  #        iStrength - Multiplier controlling strength of interactions between
  #                              species within a sample in the GLV model
  #        univ - Controls how different the gr's and imat's of samples are
  #                       within a cohort (higher univ => less different)
  #
  #  RETURNS: chrt - A list of M samples (which are lists of length 3). Each sample is of
  #                  the form list(abundance, growth rate, interaction matrix)

  #  generate the attributes of the base GLV model
  #  GR = growth rate, IME = interaction matrix elements
  baseGR = runif(N, min = 0, max = 1)
  baseIME = rnorm(N ^ 2, mean = 0, sd = iStrength * sigmaMax)

  sampleCreator = function(x = NULL){

    #  ARGS: none
    #
    #  RETURNS: a sample (a list of the form list(abd, gr, imat))

    #  create abundance vector
    abd = numeric(N)
    numKept = round(N * runif(1, min = 0.2, max = 1))
    initAbd = runif(numKept, min = 0, max = 1)
    initPresent = sample(1:N, numKept)
    abd[initPresent] = initAbd

    #  create growth rate vector
    grMultVec = runif(N, min = univ, max = (2 - univ))
    gr = grMultVec * baseGR

    #  create interaction matrix
    imatMultVec = runif(N ^ 2, min = univ, max = (2 - univ))
    imat = matrix(imatMultVec * baseIME, nrow = N, ncol = N)
    diag(imat) = -1

    return(list(abd, gr, imat))
  } #  end sampleCreator function

  #  create cohort
  chrt = lapply(as.list(1:M), sampleCreator)

  return(chrt)

} #  end cohortCreator function


context("Quantile regression")

test_that("quantile regression and prediction", {
  n = 400
  ntest = 200
  p = 4
  x = matrix(runif(n*p), n, p)
  f = function(x) (x[,1]>0.5) + 0.8*(x[,2]>0.6) + 0.5*(x[,3]>0.4)
  y = as.numeric(f(x))

  xtest = matrix(runif(ntest*p), ntest, p)
  ytest = f(xtest)

  ## learning extra trees:
  et = extraTrees(x, y, mtry=p, quantile=T, ntree=100)
  expect_is   ( et, "extraTrees")
  expect_false( et$factor )
  expect_false( et$multitask )
  expect_true(  et$quantile  )
  expect_equal( 100, et$ntree )

  yhat0.5 = predict(et, xtest, quantile = 0.5)
  yhat0.8 = predict(et, xtest, quantile = 0.8)
  expect_equal(length(yhat0.5), nrow(xtest))
  expect_true(all(yhat0.5 <= yhat0.8))
})


library(MASS)

General_Euler_Multi_D <- function(num_of_paths, num_of_steps, mu, sigma, cov_matrix, Texp=1, X0=0, convert_y_to_x_func=function(y) y){
    # Simulate a 1-dimensional process using Monte Carlo with the standard Euler scheme.
    # This can be used to simulate the payoff of an option and calculate the implied volatility smile.
    #
    # Args:
    #     num_of_paths (int): The number of Monte Carlo paths
    #     num_of_steps (int): The number of steps in each Monte Carlo path
    #     mu (vector of functions): A vector of the drift coefficient functions, a function of t (float) and X (array-like) returning a scalar
    #     sigma (vector of functions): A vector of the diffusion coefficient, a function of t (float) and X (array-like) returning a scalar
    #     cov_matrix (matrix of floats): A covariance matrix of the diffusion
    #     Texp (Optional[float]): Time, in years, to simulate process. Defaults to 1.
    #     X0 (vector of floats): Initial values for each of the process, Xhat. Defaults to 0.
    #     convert_y_to_x (function): A function to convert Y_t to X_t. Defaults to X_t <- Y_t
    # Returns:
    #     (list of function): A list with a single entry - the run_monte_carlo function stored in the key run_monte_carlo

    # Check that the inputs are correct dimensions
    if (!is.vector(mu)) stop('mu must be a vector')
    if (!is.vector(sigma)) stop('sigma must be a vector')
    num_dim <- length(mu)
    if (num_dim != length(sigma)) stop('mu and sigma must be the same length')
    if (nrow(cov_matrix) != num_dim) stop('cov_matrix must be the same size as mu and sigma')

    dt <- Texp / num_of_steps

    run_monte_carlo <- function(g_maker, strikes, num_paths_to_plot=FALSE){
        # Runs the Monte Carlo simulation to calculate E[g(X_T)] for different strikes.
        #
        # Args:
        #     g_maker (function): A function that returns a function f(x) <- g(x,K)
        #     strikes (array-like): An array of strikes to pass in to g_maker
        #     num_paths_to_plot (Optional[integer or logical]): How many paths should be plotted. Defaults to FALSE.  If TRUE, defaults to 100. (NOT USED)
        # Returns:
        #     (array-like): A array of E[g(X_T)] for the range of strikes

        # Simulates the process X across time.
        # X is a 3-dimensional array-like:
        #     -The first dimension represents the dimensions of the process
        #     -The second dimension represents the timesteps.
        #     -The third dimension represents the paths. Each "sheet" is a path.

        # Generate dW and put it into the correct 3-dimensional form described above
        dW <- mvrnorm(n=num_of_paths*num_of_steps, mu=rep(0, num_dim), Sigma=dt*cov_matrix)
        dW <- t(dW) # Transposed so that time goes across cols instead of rows
        dim(dW) <- c(num_dim, num_of_steps, num_of_paths)

        # Generate X
        X <- array(rep(NA, num_dim*(num_of_steps+1)*num_of_paths), c(num_dim, num_of_steps+1, num_of_paths))
        X[,1,] <- X0
        for (t in 1:num_of_steps)
            #for (d in 1:num_dim)
            #    X[d,t+1,] <- X[d,t,] + mu[[d]]((t-1)*dt, X[,t,]) * dt + sigma[[d]]((t-1)*dt, X[,t,]) * dW[d,t,]

            # Hard code for Section 5.2
            X[,t+1,] <- X[,t,]*exp(0.5*dW[,t,] + (0.1*(sqrt(X[,t,])-1) - 1/8)*dt)

        #X_Ts <- sapply(X[,ncol(X),], convert_y_to_x_func)
        X_Ts <- X[,ncol(X),]

        return(vapply(strikes, function(K) mean(g_maker(K)(X_Ts)), FUN.VALUE=1))
    }
    return(list(run_monte_carlo=run_monte_carlo)) # Return a list holding the function so we can call it oop style
}


# http://editerna.free.fr/wp/?p=76

library(maps)
library(maptools)
library(ggplot2)
library(grid)

##########################################################################################################################################
#                                           A function to get the scale bar coordinates                                                  #
#                                                                                #
# Result #                                                                                #
#--------#                                                                                #
# Return a list whose elements are :                                                                                #
# 	- rectangle : a data.frame containing the coordinates to draw the first rectangle ;                                                  #
# 	- rectangle2 : a data.frame containing the coordinates to draw the second rectangle ;                                                #
# 	- legend : a data.frame containing the coordinates of the legend texts, and the texts as well.                                       #
#                                                                                #
# Arguments :                                                                                #
# lon, lat : longitude and latitude of the bottom left point of the first rectangle to draw ;                                            #
# distanceLon : length of each rectangle ;                                                                                #
# distanceLat : width of each rectangle ;                                                                                #
# distanceLegend : distance between rectangles and legend texts ;                                                                        #
# dist.units :                                                                                #
# model: choice of ellipsoid model ("WGS84", "GRS80", "Airy", "International", "Clarke", "GRS67")                                        #
##########################################################################################################################################

createScaleBar <- function(lon, lat, distanceLon, distanceLat, distanceLegend, dist.units = "km", model = "WGS84", round_scale = 1){
  # First rectangle
  bottomRight <- gcDestination(lon = lon, lat = lat, bearing = 90, dist = distanceLon, dist.units = dist.units, model = model)

  topLeft <- gcDestination(lon = lon, lat = lat, bearing = 0, dist = distanceLat, dist.units = dist.units, model = model)
  rectangle <- cbind(lon=c(lon, lon, bottomRight[1,"long"], bottomRight[1,"long"], lon),
                     lat = c(lat, topLeft[1,"lat"], topLeft[1,"lat"],lat, lat))
  rectangle <- data.frame(rectangle, stringsAsFactors = FALSE)

  # Second rectangle t right of the first rectangle
  bottomRight2 <- gcDestination(lon = lon, lat = lat, bearing = 90, dist = distanceLon*2, dist.units = dist.units, model = model)
  rectangle2 <- cbind(lon = c(bottomRight[1,"long"], bottomRight[1,"long"], bottomRight2[1,"long"], bottomRight2[1,"long"], bottomRight[1,"long"]),
                      lat=c(lat, topLeft[1,"lat"], topLeft[1,"lat"], lat, lat))
  rectangle2 <- data.frame(rectangle2, stringsAsFactors = FALSE)

  # Now let's deal with the text
  onTop <- gcDestination(lon = lon, lat = lat, bearing = 0, dist = distanceLegend, dist.units = dist.units, model = model)
  onTop2 <- onTop3 <- onTop
  onTop2[1,"long"] <- bottomRight[1,"long"]
  onTop3[1,"long"] <- bottomRight2[1,"long"]

  legend <- rbind(onTop, onTop2, onTop3)
  legend <- data.frame(cbind(legend, text = c(0, round(distanceLon, digits = round_scale), round(distanceLon*2,digits = round_scale))), stringsAsFactors = FALSE, row.names = NULL)
  return(list(rectangle = rectangle, rectangle2 = rectangle2, legend = legend))
}

##########################################################################################################################################
#                                 A function to obtain the coordinates of the North arrow                                                #
#
# Result #
#--------#
# Returns a list containing :
#	- res : coordinates to draw an arrow ;
#	- coordinates of the middle of the arrow (where the "N" will be plotted).
#
# Arguments : #
#-------------#
# scaleBar : result of createScaleBar() ;
# length : desired length of the arrow ;
# distance : distance between legend rectangles and the bottom of the arrow ;
# dist.units : units of distance "km" (kilometers) (default), "nm" (nautical miles), "mi" (statute miles).
##########################################################################################################################################

createOrientationArrow <- function(scaleBar, length, distance = 1, dist.units = "km", model = "WGS84"){
  lon <- scaleBar$rectangle2[1,1]
  lat <- scaleBar$rectangle2[1,2]

  # Bottom point of the arrow
  begPoint <- gcDestination(lon = lon, lat = lat, bearing = 0, dist = distance, dist.units = dist.units, model = model)
  lon <- begPoint[1,"long"]
  lat <- begPoint[1,"lat"]

  # Let us create the endpoint
  onTop <- gcDestination(lon = lon, lat = lat, bearing = 0, dist = length, dist.units = dist.units, model = model)

  leftArrow <- gcDestination(lon = onTop[1,"long"], lat = onTop[1,"lat"], bearing = 225, dist = length/5, dist.units = dist.units, model = model)

  rightArrow <- gcDestination(lon = onTop[1,"long"], lat = onTop[1,"lat"], bearing = 135, dist = length/5, dist.units = dist.units, model = model)

  res <- rbind(
    cbind(x = lon, y = lat, xend = onTop[1,"long"], yend = onTop[1,"lat"]),
    cbind(x = leftArrow[1,"long"], y = leftArrow[1,"lat"], xend = onTop[1,"long"], yend = onTop[1,"lat"]),
    cbind(x = rightArrow[1,"long"], y = rightArrow[1,"lat"], xend = onTop[1,"long"], yend = onTop[1,"lat"]))

  res <- as.data.frame(res, stringsAsFactors = FALSE)

  # Coordinates from which "N" will be plotted
  coordsN <- cbind(x = lon, y = (lat + onTop[1,"lat"])/2)

  return(list(res = res, coordsN = coordsN))
}

###########################################################################################################################################
#                                       A function that enables the user to draw the elements                                             #
#
# Result #
#--------#
# This function enables to draw a scale bar on a ggplot object, and optionally an orientation arrow #
# Arguments : #
#-------------#
# lon, lat : longitude and latitude of the bottom left point of the first rectangle to draw ;
# distanceLon : length of each rectangle ;
# distanceLat : width of each rectangle ;
# distanceLegend : distance between rectangles and legend texts ;
# dist.units : units of distance "km" (kilometers) (by default), "nm" (nautical miles), "mi" (statute miles) ;
# rec.fill, rec2.fill : filling colour of the rectangles (default to white, and black, resp.);
# rec.colour, rec2.colour : colour of the rectangles (default to black for both);
# legend.colour : legend colour (default to black);
# legend.size : legend size (default to 3);
# orientation : (boolean) if TRUE (default), adds an orientation arrow to the plot ;
# arrow.length : length of the arrow (default to 500 km) ;
# arrow.distance : distance between the scale bar and the bottom of the arrow (default to 300 km) ;
# arrow.North.size : size of the "N" letter (default to 6).
###########################################################################################################################################
scaleBar <- function(lon, lat, distanceLon, distanceLat, distanceLegend, dist.unit = "km", rec.fill = "white", rec.colour = "black",
                     rec2.fill = "black", rec2.colour = "black", legend.colour = "black", legend.size = 3, orientation = TRUE,
                     arrow.length = 500, arrow.distance = 300, arrow.North.size = 6, round_scale = 2){
  laScaleBar <- createScaleBar(lon = lon, lat = lat, distanceLon = distanceLon, distanceLat = distanceLat, distanceLegend = distanceLegend, dist.unit = dist.unit)
  # First rectangle
  rectangle1 <- geom_polygon(data = laScaleBar$rectangle, aes(x = lon, y = lat), fill = rec.fill, colour = rec.colour)

  # Second rectangle
  rectangle2 <- geom_polygon(data = laScaleBar$rectangle2, aes(x = lon, y = lat), fill = rec2.fill, colour = rec2.colour)

  # Legend
  scaleBarLegend <- annotate("text", label = paste(round(laScaleBar$legend$text, round_scale), dist.unit, sep=""), x = laScaleBar$legend[,"long"], y = laScaleBar$legend[,"lat"], size = legend.size, colour = legend.colour)

  res <- list(rectangle1, rectangle2, scaleBarLegend)

  if(orientation){# Add an arrow pointing North
    coordsArrow <- createOrientationArrow(scaleBar = laScaleBar, length = arrow.length, distance = arrow.distance, dist.unit = dist.unit)
    arrow <- list(geom_segment(data = coordsArrow$res, aes(x = x, y = y, xend = xend, yend = yend)), annotate("text", label = "N", x = coordsArrow$coordsN[1,"x"], y = coordsArrow$coordsN[1,"y"], size = arrow.North.size, colour = "black"))
    res <- c(res, arrow)
  }
  return(res)
}

##############################################################################################################################################
#                                                                  Examples                                                                  #
##############################################################################################################################################
# 1. United States map
# usa.map <- map_data("state")
# P <- ggplot() + geom_polygon(data = usa.map, aes(x = long, y = lat, group = group)) + coord_map()

# 2. Add the scale bar only:
# P + scaleBar(lon = -130, lat = 26, distanceLon = 500, distanceLat = 100, distanceLegend = 200, dist.unit = "km", orientation = FALSE)

# 3. if we want the scale bar and the North arrow:
# P <- P + scaleBar(lon = -130, lat = 26, distanceLon = 500, distanceLat = 100, distanceLegend = 200, dist.unit = "km")

# 4. To make it look more like a map:
# P + theme(panel.grid.minor = element_line(colour = NA), panel.grid.minor = element_line(colour = NA),
#           panel.background = element_rect(fill = NA, colour = NA), axis.text.x = element_blank(),
#           axis.text.y = element_blank(), axis.ticks.x = element_blank(),
#           axis.ticks.y = element_blank(), axis.title = element_blank(),
#           rect = element_blank(),
#           plot.margin = unit(0 * c(-1.5, -1.5, -1.5, -1.5), "lines"))


##############################################################################################
# 1. Importing original data set of Stack Overflow 2018 Developer Survey

original_data <- read.csv("Stack_Overflow_2018_Developer_Public_Survey.csv")

# 1.1. Randomly choosing 1000 rows from the original data (*default seed)

random_sample <- original_data[sample(1:nrow(original_data), 1000),]

##############################################################################################
# 2. Performing basic descriptive statistics on the random sample

sink('random_sample_summary.txt')
summary(random_sample)
sink()

##############################################################################################
# 3. Data visualization of all the yearly salaries in the random sample

hist(random_sample$Yearly.Salary.in.USD, main = "Salary Distribution Amongst Stock Overflow Developer Survey Respondents", ylab = "Number of Respondents", xlab = "Yearly Salary ($)")

##############################################################################################
# 4. Analysis of the shared variability between "Open Source" and "Yearly Salary in USD"

developer_opinion <- plot(random_sample$Open.Source, random_sample$Yearly.Salary.in.USD, main = "Stock Overflow Developer Survey: Respondent Yearly Salary ($) vs Stance on Open Source Software", ylab = "Yearly Salary ($)", xlab = "Stance on open source software", col=7:6)

developer_opinion_no <- developer_opinion$stats[,1]
developer_opinion_yes <- developer_opinion$stats[,2]

sink('final_analysis.txt')
print('    Min. Lower Qu. Median Upper Qu. Max')
print(developer_opinion_no)
print(developer_opinion_yes)
sink()


library(corrplot)

message("start PCA")
#f_table= f_table_ori

f_table_new = f_table
f_table2 =f_table_new
#colnames(f_table_new)
#
##firstpaperorder
# colnames(f_table2)=c ("AA_id","AB_group","H_speeds","N_distance_traveled","D_turning_angle","E_meander",
                       # "O_activitytime_ST",
                     # "K_act_bouts_ST","C_pause_length_ST","I_#pauses_ST","P_activitytime_timeT",
                     # "L_act_bouts_DtimeT","B_pause_length_timeT","J_#pauses_timeT", "F_thigmotaxis_moving", "G_thigmotasix_pause","M_#walks","AC_stripe_deviation")

if (MINCOL==2){
	colnames(f_table2)= c("AA_id","AB_group","H_speeds","N_distance_traveled","D_turning_angle","E_meander","XA_activitytime_ST","XB_act_bouts_ST","XC_pause_length_ST","XD_#pauses_ST","P_activitytime_timeT","L_act_bouts_DtimeT","B_pause_length_timeT","J_#pauses_timeT","F_thigmotaxis_moving", "G_thigmotasix_pause","M_#walks","AC_stripe_deviation")
}

if (MINCOL==8){
	colnames(f_table2)= c("AA_id","AB_group","ZA_genotype",  "ZB_treatment", "ZC_machine","ZD_other", "ZE_date","ZF_timeofday","H_speeds","N_distance_traveled","D_turning_angle","E_meander","XA_activitytime_ST","XB_act_bouts_ST","XC_pause_length_ST","XD_#pauses_ST","P_activitytime_timeT","L_act_bouts_DtimeT","B_pause_length_timeT","J_#pauses_timeT","F_thigmotaxis_moving", "G_thigmotasix_pause","M_#walks","AC_stripe_deviation")
}
###add this to make the pca over the genotype group only

# if (MINCOL==8){
	# colnames(f_table2)= c("AA_id","ZA_group2","AB_group",  "ZB_treatment", "ZC_machine","ZD_other", "ZE_date","ZF_timeofday","H_speeds","N_distance_traveled","D_turning_angle","E_meander","XA_activitytime_ST","XB_act_bouts_ST","XC_pause_length_ST","XD_#pauses_ST","P_activitytime_timeT","L_act_bouts_DtimeT","B_pause_length_timeT","J_#pauses_timeT","F_thigmotaxis_moving", "G_thigmotasix_pause","M_#walks","AC_stripe_deviation")
# }

data.frame(names(f_table),names(f_table2))
## get linearity score out
#f_table2=f_table2[,-16]

## reorder variables following the free walk analysis
f_table2= f_table2[,order(colnames(f_table2))]

### gives output if not all calculation are made
#if(length(f_table_new) != 19)  f_table2=f_table_new

#### ENTER HERE MANUALLY A NEW DATA AS ENTRY FOR THE PCA ANALYSIS
# f_table2= f_table

i_table =na.omit(f_table2)
h_table<-f_table2[,c(3:(length(f_table2)-MINCOL+2-4))] #+2 from group and id, -4 to take ST out
rownames (h_table) = paste (c(1:length(f_table2[,1])),f_table2[,2])
#h_table<-f_table2[,c(3:13,16:length(f_table2))]
g_table <- na.omit(h_table)
 head(g_table)
mydata.pca <- prcomp(g_table, retx= TRUE, center= TRUE, scale.=TRUE)

sd <- mydata.pca$sdev
loadings <- mydata.pca$rotation
rownames(loadings) <- colnames(g_table)
scores <- mydata.pca$x

t=mydata.pca$sdev^2 / sum(mydata.pca$sdev^2)
t2= cumsum(t)
plot(t2*10, main= "variance explained cumulative")

PCA_res= data.frame(scores)
PCA_res$group = as.factor(id_table$genotype)

#PCA_res$group = i_table[,19]

#Plot PC1 and 2 info on one graph
PCA1to3 = data.frame(PCA_res$PC1,PCA_res$PC2,PCA_res$PC3,PCA_res$group)

Mean_PCA = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),1:2)
Mean_PCA2 = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),c(1,3))
#################################################
###################################################
##################################################
setwd(outputpath)
scalingfact=7
scalingaxis=1

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

abc= c(1:8, rgb(202,100,20,maxColorValue = 255),rgb(100,0,200,maxColorValue = 255))

 plot(scores[,1], scores[,2], xlab="PCA 1", ylab="PCA 2",
   type="n", main="distance biplot",xlim=c(-max(scores[,1:2]*scalingaxis), max(scores[,1:2]*scalingaxis)),
   ylim=c(-max(scores[,1:2]*scalingaxis), max(scores[,1:2]*scalingaxis)))

for (i in 1:length(levels(PCA_res$group))){
  X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	points(X$PC2~ X$PC1, col=abc[i])
	#legend(list(x=-6,y=-i/2+5), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,  cex=0.7)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= abc[i], bty="n", inset = c(0,i/30))

   x=Mean_PCA$means$PCA_res.PC1[i]
y=Mean_PCA$means$PCA_res.PC2[i]
x2=Mean_PCA$ses$PCA_res.PC1[i]
y2=Mean_PCA$ses$PCA_res.PC2[i]
segments (x-x2,y,x+x2,y, col=abc[i])
segments (x,y-y2,x,y+y2, col=abc[i])
	}
	abline (v=0, h=0)

 plot(scores[,1], scores[,3], xlab="PCA 1", ylab="PCA 3",
   type="n", main="distance biplot",xlim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)),
   ylim=c(-max(scores[,1:3]*scalingaxis), max(scores[,1:3]*scalingaxis)))

for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	points(X$PC3~ X$PC1, col=abc[i])
	#legend(list(x=-6,y=-i/2+5), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,  cex=0.7)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= abc[i], bty="n", inset = c(0,i/30))

   x=Mean_PCA2$means$PCA_res.PC1[i]
y=Mean_PCA2$means$PCA_res.PC3[i]
x2=Mean_PCA2$ses$PCA_res.PC1[i]
y2=Mean_PCA2$ses$PCA_res.PC3[i]
segments (x-x2,y,x+x2,y, col=abc[i])
segments (x,y-y2,x,y+y2, col=abc[i])
	}
	abline (v=0, h=0)

##########################################
## plot data pc1 and 2 / 1 and 3 without points
M=max(Mean_PCA$means)+max(Mean_PCA$ses)*1.1
 plot(scores[,1], scores[,2], xlab="PCA 1", ylab="PCA 2",
   type="n", main="distance biplot",xlim=c(-M, M),
   ylim=c(-M, M))

#plot(PCA_res$PC2~PCA_res$PC1, type= "n", add=TRUE)
for (i in 1:length(levels(PCA_res$group))){
  X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	#points(X$PC2~ X$PC1, col=i, pch= i+10)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= abc[i], bty="n", inset = c(0,i/30))
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,
#   cex=0.7)
   x=Mean_PCA$means$PCA_res.PC1[i]
y=Mean_PCA$means$PCA_res.PC2[i]
x2=Mean_PCA$ses$PCA_res.PC1[i]
y2=Mean_PCA$ses$PCA_res.PC2[i]
segments (x-x2,y,x+x2,y, col=abc[i])
segments (x,y-y2,x,y+y2, col=abc[i])
	}
	abline (v=0, h=0)

#######
######################################################
#plot all
require (rgl)
load("/Users/choupi/Desktop/pca3d.rdata")

setwd(outputpath)
pdf("samplesize_color_forpca.pdf")
par(mai= c(1.5,1.5,1.5,1.5))
plot(PCA_res$group, type="n", main="samplesize", ylim=c(0,30))
for (i in 1:length(levels(PCA_res$group))){

  plot(PCA_res$group[PCA_res$group == levels(PCA_res$group)[i]], col=abc[i], add=TRUE)
  }

dev.off()
par(mai= c(1,1,1,1))

LEV=0.4
scalingfact=1

plot3d(c(0,PCA_res$PC1)*scalingfact,c(0,PCA_res$PC3)*scalingfact,c(0,PCA_res$PC2)*scalingfact,
       type = "n",box =FALSE,axes=TRUE,xlab="PC1",ylab="PC3",zlab="PC2")

  for (i in 1:length(levels(PCA_res$group))){
  #add points:
  #X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
  points= data.frame(X$PC1, X$PC3,X$PC2)
  #plot3d(points, col=i,type= "p",add=TRUE)

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

    plot3d(ellipse3d(cov(points), centre = c(x,y,z), level=LEV), col=i, alpha=0.3 , add=TRUE)
  }

#PCA_res$group= as.factor(id_table$genotype)


## use "source( 'extremesBoxPlot.r' )"  from R prompt or "R -f extremesBoxPlot.r" from command line.
tab1 <- read.csv(file="ch14ExtremesR.csv",head=TRUE,sep=",")

## or X11(type="Xlib")
jpeg('median_precip.jpg')
par(fig=c(0.01, 0.95, 0.2, 0.95) )
par(mgp = c(4.2, .8, 0))
boxplot(pr~Scenario*Season, data=tab1, notch=FALSE,
   subset = Year == "2100" & stat == "median",
   col=(c("gold","blue","darkgreen")),
   main="Precipitation\n(percentage change: median of multimodel ensemble)",
   xlab="Scenario (rcp26: gold, rcp45: blue, rcp85: green)\nand Season (left to right: Annual, Boreal Summer [April to September],\n Boreal Winter [October to March])")

dev.off()


x<-c(40,50,60,70,80,10,20)
y<-c(1,2,3,4,5,6,7)
op<-lm(x ~ y)
a<-data.frame(y=9)
b<-predict(op,a)
print(b)
oq<-lm(y ~ x)
c<-data.frame(x=100)
d<-predict(oq,c)
print(d)
pie(x,y)
pie(x,y,main="uid&marks")
barplot(x,y)
barplot(x,y,main="uid&marks")
boxplot(x,y)
boxplot(x,y,horizontal = "TRUE")
boxplot(x,y,xlab="uid",ylab="marks")
print(getwd())
setwd("E:/code/R")
p<-read.csv("world-happiness-report-2019.csv")
print(p)
head(p)
scatter.smooth(x=p$Positive.affect,y=p$Negative.affect,main="output")
scatter.smooth(x=p$Freedom,y=p$Corruption,main="output")
scatter.smooth(x=p$Positive.affect,y=p$Negative.affect,main="output",type="l")
scatter.smooth(x=p$Positive.affect,y=p$Negative.affect,main="output",type="s")
scatter.smooth(x=p$Positive.affect,y=p$Negative.affect,main="output",type="p")
scatter.smooth(x=p$Positive.affect,y=p$Negative.affect,main="output",type="p",col="red")
scatter.smooth(x=p$Positive.affect,y=p$Negative.affect,main="output",type="h",col="red")


suppressMessages(library(float))
suppressMessages(library(dimrgame))

if (comm.size() > 1)
  comm.stop("run with 1 rank")

x = matrix(1:30, 10)
# x = matrix(rnorm(30), 10)
s = fl(x)

ds = shaq(s)

truth = svd(s)$d
test = svd_game(ds)$d
truth
test

finalize()


 ZGEQPF Example Program Results

 Least squares solution
                    1                 2
 1  ( 0.0000, 0.0000) ( 0.0000, 0.0000)
 2  ( 2.6925, 8.0446) (-2.0563,-2.9759)
 3  ( 2.7602, 2.5455) ( 1.0588, 1.4635)
 4  ( 2.7383, 0.5123) (-1.4150, 0.2982)


library(igraph)
start_time <- Sys.time()
table <- read.table("cit-Patents.txt")
newg<- graph.data.frame(table, directed=TRUE)

end_time <- Sys.time()
end_time - start_time
print("cit-Patents.txt")

print("number of vx:")
vcount(newg)
print("number of edge:")
ecount(newg)

# Remove self-loops for consistency
newg <- invisible(simplify(newg, remove.loops = TRUE))

# k-core
start_time <- Sys.time()
invisible(core <-coreness(newg, mode = "all"))
invisible(verticeHavingthreeCoreness <- which(core == 3))
invisible(threecore <- induced.subgraph(graph=newg,vids=verticeHavingthreeCoreness))
end_time <- Sys.time()
end_time - start_time

# page rank
start_time <- Sys.time()
invisible(page_rank_old(newg, niter = 10, eps = 0.0001))
end_time <- Sys.time()
end_time - start_time

# WCC
start_time <- Sys.time()
invisible(components(newg, mode = "weak"))
end_time <- Sys.time()
end_time - start_time

#clustering coeff
start_time <- Sys.time()
transitivity(newg)
end_time <- Sys.time()
end_time - start_time

#test edge existence
start_time <- Sys.time()
a<-sample(1:vcount(newg),2)
i<-1

are.connected(newg, a[i], a[i+1])

end_time <- Sys.time()
end_time - start_time


# spare linear regression using stan
library(distbayesianmc)

if(T){
  setwd("~/R_programming/distbayesianmc")
  source("~/R_programming/distbayesianmc/params_simulation/params_sparse_median.R")
  stan_code <- readChar(fileName, file.info(fileName)$size)

  mod <- rstan::stan_model(model_code = stan_code, auto_write = T)
  setwd("/scratch/alexander/distbayesianmc_sparselinear_median/")
  library(doParallel)
  registerDoParallel(cores=6)
  for(dataset in vec_datasets){
    for(ssplits in vec_splits){
      foreach(i_iter = 1:iters) %dopar% {
        #for(i_iter in 1:20){

        dataset_loaded <- f_dataset_loader(dataset, highcorr = highcorr, nobs = nobs)
        splitted_data <- f_pack_split_data(dataset_loaded$X, dataset_loaded$y, Pparams = Pparams, ssplits=ssplits, iseed=i_iter, typesplit=typesplit)
        splitted_data <- f_prep_prior_median(splitted_data, scale = scale)
        f_stan_sampling_splitted_data_median(mod, splitted_data, dataset = dataset, i_seed = i_iter, iter = i_iter, typesplit = typesplit, nchain = nchain, typeprior=typeprior)

      }
    }
  }
}

df <- f_combine_const_data_in_frame(vec_splits, vec_datasets, vec_types_splits, 6, type_sim = "stan_median_")
#f_plot_res_data_frame(df)
f_plot_res_data_frame(df, vec_datasets = vec_datasets)
save(df, file="res_sparselinear_ultrasmall_median.Rda")
df %<>% mutate(medianlogsubpost = as.numeric(medianlogsubpost))

p1 <- ggplot(df, aes_string(x="splits", y="medianlogsubpost", fill="dataset")) +
  geom_boxplot() + scale_x_discrete(limits=as.character(sort(as.numeric(levels(df$splits))))) + theme_minimal()


## 1. Importing and Modifying Data ##

reviews_2 <- read_csv("movie_reviews_2.csv")

reviews_2 <- reviews_2 %>%
  select(FILM, RT_user_norm, Metacritic_user_nom, IMDB_norm, Fandango_Ratingvalue) %>%
  rename(Rotten_Tomatoes = RT_user_norm, Metacritic = Metacritic_user_nom, IMDB = IMDB_norm, Fandango = Fandango_Ratingvalue)

## 2. Understanding Relationships Between Variables ##

library(ggplot2)
ggplot(data = reviews_2,
  aes(x = Fandango, y = Rotten_Tomatoes)) +
  geom_point()

## 3. Creating Informative Scatter Plots ##

# ggplot(data = reviews_2,
#   aes(x = Fandango, y = Rotten_Tomatoes)) +
#   geom_point()
ggplot(data = reviews_2,
  aes(x = Fandango, y = Rotten_Tomatoes)) +
  geom_point(alpha = 0.3) +
  xlim(1,5) +
  ylim(1,5) +
  theme(panel.background = element_rect(fill = "white"))

## 4. Creating Multiple Scatter Plots ##

# ggplot(data = reviews_2,
#   aes(x = Fandango, y = Rotten_Tomatoes)) +
#   geom_point(alpha = 0.3) +
#   xlim(1,5) +
#   ylim(1,5) +
#   theme(panel.background = element_rect(fill = "white"))
ggplot(data = reviews_2,
  aes(x = Fandango, y = IMDB)) +
  geom_point(alpha = 0.3) +
  xlim(1,5) +
  ylim(1,5) +
  theme(panel.background = element_rect(fill = "white"))

ggplot(data = reviews_2,
  aes(x = Fandango, y = Metacritic)) +
  geom_point(alpha = 0.3) +
  xlim(1,5) +
  ylim(1,5) +
  theme(panel.background = element_rect(fill = "white"))

## 5. Write a Function to Create Multiple Scatter Plots ##

# ggplot(data = reviews_2,
#     aes(x = x, y = y)) +
#     geom_point(alpha = 0.3) +
#     xlim(1,5) +
#     ylim(1,5) +
#     theme(panel.background = element_rect(fill = "white"))
create_scatter <- function(x, y) {
  ggplot(data = reviews_2) +
    aes_string(x = x, y = y) +
    geom_point(alpha = 0.3) +
    xlim(1,5) +
    ylim(1,5) +
    theme(panel.background = element_rect(fill = "white"))
}

x_var <- names(reviews_2)[5]
y_var <- names(reviews_2)[2:4]

map2(x_var, y_var, create_scatter)

Data Analyst in R/Step 2 - Data Visualization in R/Data Visualization in R/4. Scatter Plots for Exploratory Analysis.r


#' @title data_dredge_regression
#'
#' @description data dredge a \code{\link[base]{data.frame}} using \code{\link[stats]{lm}}
#'
#' @importFrom magrittr "%>%"
#' @importFrom stats lm
#' @importFrom stats as.formula
#' @importFrom utils combn
#' @export
#'
#' @param data a \code{\link[base]{data.frame}} to operate over
#' @param max_columns the maximum columns that can go into \code{\link[stats]{lm}} formula
#' @param min_pvalue the maximum the pvalue from \code{\link[stats]{lm}} can be before the result is filtered out. this generaly is an issue only in overfitted models
#' @param max_pvalue the maximum the pvalue from \code{\link[stats]{lm}} can be before the result is filtered out
#' @param ... addtional parameters to pass to \code{\link[stats]{lm}}
#' @return
#'
#' @author Mark Newman, \email{mark@trinetteandmark.com}
#' @keywords macros
#' @family data_dredging
#'
#' @examples
#'   \dontshow{
#'     library(mndredge)}
#'   set.seed(0)
#'
data_dredge_regression <- function(data, max_columns = 4, min_pvalue = 1e-10, max_pvalue = 0.05, ...) {

  stopifnot(data %>% is.data.frame())
  stopifnot(max_columns %>% is.numeric())
  stopifnot(max_columns > 0)
  stopifnot(max_pvalue %>% is.numeric())
  stopifnot(max_pvalue < 1)
  stopifnot(max_pvalue > 0)
  stopifnot((data %>% nrow()) >= 3)

  adjusted_data <- data %>% prepare_for_regression()

  prediction_columns <- adjusted_data %>% select_regression_prediction_columns()
  prediction_column_count <- prediction_columns %>% length()
  response_columns <- adjusted_data %>% select_regression_response_columns()
  response_column_count <- response_columns %>% length()

  stopifnot(prediction_column_count >= 1)
  stopifnot(response_column_count >= 1)

  max_columns <- min(max_columns, prediction_column_count)
  # this formula needs tuning. this seems to be the ceiling
  result_count <-
    choose(prediction_column_count, 1:max_columns) %>% sum() *
    response_column_count

  formula <- character(length = result_count)
  best_pvalue <- numeric(length = result_count)
  adjusted_r_squared <- numeric(length = result_count)

  safe_lm_summary <- function(data, formula, ...) {
    tryCatch(
      expr = { lm(formula = formula, data = data, ...) %>% summary() },
      warning = function(x) {} ) }

  indx = 1
  for(i in 1:max_columns) {

    all_prediction_options <- combn(prediction_columns, i) %>% t()
    all_prediction_options_count <- all_prediction_options %>% nrow()

    for(j in 1:all_prediction_options_count) {

      prediction <-
        all_prediction_options[j,] %>%
        paste(collapse = "*")

      for(k in 1:response_column_count) {

        response <- response_columns[k]

        if(!(response %in% all_prediction_options[j,])) {
          f1 <- sprintf("%s ~ %s", response, prediction)
          model_summary <-
            adjusted_data %>%
            safe_lm_summary(f1 %>% as.formula(), ...)

          if(!(model_summary %>% is.null())) {

            arv <- model_summary$adj.r.squared
            if(!(arv %>% is.nan())) {

              model_coefficients <-
                model_summary$coefficients %>%
                as.data.frame()
              model_coefficients <-
                model_coefficients[2:(model_summary$coefficients %>% nrow()),]
              mp <- min(model_coefficients$`Pr(>|t|)`)

              if(min_pvalue < mp & mp < max_pvalue) {
                formula[indx] <- f1
                best_pvalue[indx] <- mp
                adjusted_r_squared[indx] <- model_summary$adj.r.squared
                indx <- indx + 1
              }}}}}}}

  result_count_filterout <- formula != ""
  formula <- formula[result_count_filterout]
  best_pvalue <- best_pvalue[result_count_filterout]
  adjusted_r_squared <- adjusted_r_squared[result_count_filterout]

  data.frame(
    formula,
    best_pvalue,
    adjusted_r_squared,
    stringsAsFactors = F)
}


install.packages("dplyr")
# library(ggplot2)
library(dplyr)

dataframe <- read.csv(file="fsa_dataset" ,head=TRUE,sep="\t")

## group
initial_deployment <- tbl_df(dataframe) %>%
  group_by(scenario) %>%
  summarise(init_depl_avg_time = mean((dam_updated + deployment_change_planned)/1000000),  init_depl_std=sd((dam_updated + deployment_change_planned)/1000000),
            update_1_avg_time = mean((dam_updated.1 + deployment_change_planned.1)/1000000),  update_1_std=sd((dam_updated.1 + deployment_change_planned.1)/1000000),
            update_2_avg_time = mean((dam_updated.2 + deployment_change_planned.2)/1000000),  update_2_std=sd((dam_updated.2 + deployment_change_planned.2)/1000000),
            update_3_avg_time = mean((dam_updated.3 + deployment_change_planned.3)/1000000),  update_3_std=sd((dam_updated.3 + deployment_change_planned.3)/1000000),
            update_4_avg_time = mean((dam_updated.4 + deployment_change_planned.4)/1000000),  update_4_std=sd((dam_updated.4 + deployment_change_planned.4)/1000000)
            )

pdf("fsa.pdf")
boxplot(init_depl_avg_time~scenario,data=initial_deployment, xlab="Size", ylab="Time(ms)")
dev.off()

initial_deployment
write.table(initial_deployment, "initial_deployment.txt", sep="\t")

update_deployment <- tbl_df(dataframe) %>%
  group_by(scenario, operation, exec_index) %>%
  filter(row_number() > 1) %>% # only the first, the initial plan
  group_by(scenario, operation ) %>%
  summarise(avg_time = mean(time/1000000),  std=sd(time/1000000))

update_deployment

write.table(update_deployment, "update_deployment.txt", sep="\t")


require(dtw)
require(RColorBrewer)

# Data
a = c(rep(0, 1000), 10*sin(seq(1, 10*pi, length.out=500)) + 2*rnorm(500), rep(0, 1500)) +
  arima.sim(n=3000, model=list(1,0,0))
# Pattern
b = 100*cos(seq(0, 2*pi, length.out=100))

# Number of sliding windows
winnum = 100
overlap = 10

# calculate window size
winsize = 0
winsize = ifelse (length(a) / winnum < length(b), length(b), length(a) / winnum)
print(paste("Window size ", winsize + overlap))
n = seq(winnum)

distances = rep(0, winnum)
n1s = rep(0, winnum)
n2s = rep(0, winnum)

last = 1
# Perform dtw fitting for each sliding window
for (ctr in n) {
  n1 = last
  n2 = last + winsize + overlap
  last = last + (length(a) / winnum)
  c = a[n1:n2]

  d = dtw(x=b, y=c,
    keep=TRUE,
    open.end=TRUE,
    open.begin=TRUE,
    step=asymmetric,
    window.type = "sakoechiba",
    window.size=winsize+overlap)

  # Store dtw distances for each window
  distances[ctr] = d$distance
  n1s[ctr] = n1
  n2s[ctr] = n2
}

distances=data.frame(dist=distances, n1=n1s, n2=n2s)

distances.sub = subset(distances, dist>0)
distances.sorted = distances.sub[with(distances.sub, order(dist, decreasing=FALSE)),]

distances.mean = mean(distances.sorted$dist)
distances.min = subset(distances.sorted, dist < distances.mean)

matches = as.numeric(rownames(distances.min))
a.max = max(a)
a.min = min(a)

matches.unique = rep(TRUE, length(matches))

# Filter out overlapping solutions and keep ones with lowest distance
for (match in matches[matches.unique]) {
  d = distances[match,]
  d.int = sapply(matches, function(x) {
    d2 = distances[x,]
    n = length(intersect( seq(d$n2, d$n1), seq(d2$n2, d2$n1) ))
    ifelse(n > (winsize+overlap)/2 && d$dist < d2$dist, FALSE, TRUE)
  })
  matches.unique = matches.unique & d.int
}
matches.unique = matches[matches.unique]
print(paste("Found ", length(matches.unique), " matches"))

ctr = 1
colors = rainbow(length(matches.unique))

par(mfrow=c(2,1), mai = c(0.5, 0.5, 0.5, 0.5))

# Plot the given signal
plot.ts(a,
  ylim=c(a.min, a.max + 10))

for (match in matches.unique) {
  d = distances[match,]

  # Highlight the matched parts of the signal
  lines(y=a[d$n1 : d$n2],
   x=d$n1 : d$n2, col=colors[ctr])

  # Indicate a bar depciting the range of match
  points(y=rep(a.max + 5, d$n2-d$n1+1),
    x=d$n1 : d$n2, col=colors[ctr], pch="-")
  ctr = ctr + 1
}

plot.ts(distances$dist)


#!/usr/bin/Rscript
library(data.table)
library(ggplot2)

# Read data from stdin to use this script in a command line pipeline.
data <- read.csv(file("stdin"))
# Convert the time from milliseconds to seconds.
data$timestamp=round(data$timestamp/1000)

# Do a loess fit and prediction over the whole range of seconds between the
# first and last measured value.
lo <- loess(data$value~data$timestamp, span=0.25)
minTime=min(data$timestamp)
maxTime=max(data$timestamp)
smoothedTime=seq(minTime, maxTime, 1)
smoothedValues=predict(lo, smoothedTime)

# Add boundary at 0.
smoothedValues[smoothedValues<0]=0

# Convert to date
data$timestamp <- as.POSIXct(data$timestamp, origin="1970-01-01")
smoothedTimestamp=as.POSIXct(smoothedTime, origin="1970-01-01")

# Merge the predicted and measured values. This results in a data table,
# in which each second has a measured (if available) and predicted value.
# There is one row FOR EACH second between the first and last measurement.
dt1=data.table(data)
setkey(dt1, timestamp)
dt2=data.table(timestamp=smoothedTimestamp, valueSmoothed=smoothedValues)
setkey(dt2, timestamp)
# Take the predicted values in case no measured ones are available.
merged<-dt1[dt2,]
analysed<-merged[,list(
    timestamp=timestamp,
    value=ifelse(is.na(value), valueSmoothed, value)
)]

# Make an image of the merged data.
png("analysed.png")
qplot(analysed$timestamp, analysed$value)+xlab("Date")+ylab("Power [kW]")
dev.off()
# write the merged data to file.
write.csv(analysed, "analysed.csv")


=begin
  # sample-geometry03.rb

  #incenter
  puts "too heavy ... skip (#{$0})"
  exit
  require 'algebra'

  R = MPolynomial(Rational)
  x,y,a1,a2,b1,b2,c1,c2 = R.vars('xya1a2b1b2c1c2')
  Q = LocalizedRing(R)
  x0,y0,a10,a20,b10,b20,c10,c20 = R.vars.map{|v| Q[v]}
  V = Vector(R, 2)
  W = Vector(Q, 2)
  X, A, B, C = V[x,y], V[a1,a2], V[b1,b2], V[c1,c2]

  def bisector(p1, p2, p3)
    p1,p2,p3 = [p1,p2,p3].map{|v| v.convert_to(W)}
    k1 = (p1.inner_product(p2))**2/p2.norm2
    k2 = (p1.inner_product(p3))**2/p3.norm2
    (k1-k2).numerator
  end

  def line(p1, p2, p3)
    SquareMatrix.det([[1, *p1], [1, *p2], [1, *p3]])
  end

  l1 = bisector(X-A, B-A, C-A)
  p l1
  l2 = bisector(X-B, C-B, A-B)
  p l2
  l3 = bisector(X-C, A-C, B-C)
  p l3

  s = line(A, B, C)

  g = Groebner.basis [l1, l2, l3, s-1] #s-1 means non degeneracy

  g.each do |f|
    p f
  end

  #p g.size > 1
((<_|CONTENTS>))
=end


softmax <- function(par){
  n.par <- length(par)
  par1 <- sort(par, decreasing = TRUE)
  Lk <- par1[1]
  for (k in 1:(n.par-1)) {
    Lk <- max(par1[k+1], Lk) + log1p(exp(-abs(par1[k+1] - Lk)))
  }
  val <- exp(par - Lk)
  return(val)
}
# data must have x1, which is the lagged value. It uses this to estimate the cohorts.
# The model matrix can be whatever, but it must have authoritarianism, scaled 0 to 1

#### Incorporate this block into my code below. Align the distributions
######################################################################
# This block can just go in the plotting part, add a place for
# Pass "mod formula" -- or dissect from other mod formula ###
# The rest can be dumped into that function. Main by authoritarianism
# generates the probability of each category

################################################################################################################
####################### Main Effects Estimates: Probability of cat 1-5, each time point #######################
################################################################################################################

main_by_authoritarianism = function(mod_formula = MOD1, data = tmp_data, ....){
      y.var <- all.vars(mod_formula)[1]
      x.var <- data[, nlme::Names(mod_formula, data)[-1]]
      models = list()
      tmp = nnet::multinom(mod_formula,
                        data = data)
      models <- rbind(0, coef(tmp) )
      ## Generate linear predictions ###
      low_auth =  x.var %>%  mutate(latent =0)
      low_auth = data.frame(1, low_auth)
      high_auth =  x.var %>% mutate(latent =1)
      high_auth = data.frame(1, high_auth)
      # Construct the transition matrix for the ith value of the IV....
      linear_effect1 <- c()
      linear_effect2 <- c()
      for(i in 1:nrow(models)){
          linear_effect1 <- rbind(linear_effect1,  models[i,] %*% t(low_auth) %>% t() %>%  mean())
          linear_effect2 <- rbind(linear_effect2,  models[i,] %*% t(high_auth) %>% t() %>% mean())
        }
      out1 = linear_effect1  %>% t %>% softmax()
      out2 = linear_effect2  %>% t %>% softmax()
        return(list(low_auth = out1, high_auth = out2))
}

################################################################################################################
####################### Transition Estimates                                             #######################
################################################################################################################

transition_by_authoritarianism_boot = function(data = data, indices,
                                               mod_formula, authoritarianism = 0){
                                              .df = data[indices, ]
                                                y.var <- .df[,  c(1:2)]
                                                x.var <- .df[,  c(3:ncol(.df))]
                                              models = list()
                                              for(i in 1:length(unique(.df$x1))){
                                                tmp = multinom(mod_formula,
                                                              data = subset(.df, x1 ==i))
                                                models[[i]] <- rbind(rep(0, times = (ncol(x.var) + 1)), coef(tmp) )
                                              }
                                              ## Generate linear predictions ###
                                              low_auth =  x.var %>%  mutate(authoritarianism =0)
                                              low_auth = data.frame(int = 1, low_auth)
                                              high_auth =  x.var %>% mutate(authoritarianism =1)
                                              high_auth = data.frame(int = 1, high_auth)
                                              # Construct the trhansition matrix for the ith value of the IV....
                                              linear_effect1 <- c()
                                              linear_effect2 <- c()
                                              for(k in 1:length(models)){
                                                for(i in 1:nrow(models[[k]])){
                                                  linear_effect1 <- rbind(linear_effect1,  models[[k]][i,] %*% t(low_auth) %>%  mean())
                                                  linear_effect2 <- rbind(linear_effect2,  models[[k]][i,] %*% t(high_auth) %>% mean())
                                                }
                                              }

                                              linear_effect1 = linear_effect1 %>% matrix(ncol = 5)
                                              linear_effect2 = linear_effect2 %>% matrix(ncol = 5)
                                              out1 <- matrix(NA, nrow = nrow(linear_effect1), ncol = 5)
                                              out2 <- matrix(NA, nrow = nrow(linear_effect1), ncol = 5)
                                              for(i in 1:nrow(out1)){
                                                out1[i,] <- softmax(linear_effect1[,i])
                                                out2[i,] <- softmax(linear_effect2[,i])
                                              }
                                              me = out2 - out1
                                              if(authoritarianism ==0) return(t(out1))
                                              if(authoritarianism ==1) return(t(out2))
}
# Wrapper to generate effects, need to just pass the ncessary plot parms
# Returns marginal distributions for each variable and the transition plot
draw_transition_effects = function(tran = low,
                                   data = tmp_data,
                                   mod1 = MOD1,
                                   mod2 = MOD2,
                                   auth_score = c("AUTH", "NON"),
                                   CAT_LABELS,
                                   x.label = "2016 Election",
                                   y.label = "2020 Election",
                                   alpha = 0.25,
                                   axis.text.size = 10,
                                   axis.label.size = 10,
                                   vote = 0,
                                   ...
                                   ){
                        t1 = main_by_authoritarianism(mod1, data)
                        t2 = main_by_authoritarianism(mod2, data)
                        marginal_data = data.frame(
                            x                 = rep(c(1:length(t1$low_auth)), times = 4),
                            y                 = c(unlist(t1), unlist(t1)),
                            authoritarianism  = rep(c(0,1), each = length(t1$low_auth)),
                            period            = rep(c(1,2), each = length(t1$low_auth)*2)
                        )

                       if(auth_score == "NON"){
                        tempdat1 = subset(marginal_data, period == 1 & authoritarianism == 0)
                        tempdat2 = subset(marginal_data, period == 2 & authoritarianism == 0)
                        mplot = ggplot(mapping = aes(x=x, y=y)) +
                          geom_bar(data = tempdat1, stat="identity", width = 0.8, fill = "#746c6c", alpha = 0.4) +
                          coord_flip() +
                          scale_x_discrete("", limits = factor(c(1:5))) +
                          scale_fill_grey() +
                          theme(panel.border = element_blank()) +
                          theme(panel.background = element_blank()) +
                          theme(axis.text = element_blank(),
                                axis.ticks = element_blank(),
                                axis.title = element_blank())
                       }
                      if(auth_score == "AUTH"){
                        tempdat1 = subset(marginal_data, period == 1 & authoritarianism == 1)
                        tempdat2 = subset(marginal_data, period == 2 & authoritarianism == 1)
                        mplot = ggplot(mapping = aes(x=x, y=y)) +
                          geom_bar(data = tempdat1, stat="identity", width = 0.8, fill = "#746c6c", alpha = 0.4) +
                          coord_flip() +
                          scale_x_discrete("", limits = factor(c(1:5))) +
                          scale_fill_grey() +
                          theme(panel.border = element_blank()) +
                          theme(panel.background = element_blank()) +
                          theme(axis.text = element_blank(),
                                axis.ticks = element_blank(),
                                axis.title = element_blank())
                       }
        plot_dat = data.frame(
            score =  c(tran),
            t1    = rep(CAT_LABELS, times = length(c(low))),
            t2    = rep(CAT_LABELS, each =  length(CAT_LABELS))
            )
            plot_dat$gridx = car::recode(plot_dat$t1,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; "))
            plot_dat$gridy = car::recode(plot_dat$t2,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; "))
            plot_dat$sizes = tempdat1$y * plot_dat$score
            plot_dat$lab =   as.character(round(plot_dat$score, 3))
            #plot_dat$mean * plot_dat$x1 * plot_dat$x2
            if(vote == 0){
            plot_dat$colour = rep(c("#3355FF", "#33C7FF", "#9F33FF", "#EC747D", "#D0000F"),
                              each = nrow(plot_dat)/5)
            }
            else{
            plot_dat$colour = rep(c("#3355FF", "#D0000F"),
                              each = nrow(plot_dat)/2)
            }
if(vote == 0){
   label.x =c("1" = "Democrat", "2" = "Lean Democrat",
                               "3" = "Independent",
                               "4" = "Lean Republican", "5" = "Republican")
    label.y =c("1" = "Dem", "2" = "Lean Dem",
                               "3" = "Ind",
                                "4" = "Lean Rep", "5" = "Rep")
}

if(vote == 1){
   label.x =c("1" = "Vote Democrat", "2" = "Vote Republican")
   label.y =c("1" = "Democrat", "2" = "Republican")
}

  a = ggplot(plot_dat,
                 aes(y = as.factor(gridy), x = as.factor(gridx))) +
    geom_point(alpha = .0001) +
    scale_size(range = c(4,9), name="Cell Sizes") +
    theme(panel.background=element_rect(fill="white")) +
    scale_x_discrete(x.label,
                     labels =label.x) +
    scale_y_discrete(y.label,
                     labels = label.y, position = "right") +
    geom_text(aes(label = lab, size = sizes))  + coord_flip()  +
    theme(legend.position = "none",
           axis.text=element_text(size=axis.text.size),
           axis.title=element_text(size=axis.label.size))

    return(list (a, mplot))
}
pid.r<-function(x){
  return(car::recode(x, "1:2=1; 3=2; 4=3; 5=4; 6:7=5"))
}

latent_model =  function(formula = FORMULA,  ordered = ORDERED,
                        data = DATA){
                data$identifier = seq(1:nrow(data))
                model = cfa(formula, ordered=ordered, data=data)
                a= lavPredict(model, append.data = TRUE,  assemble = TRUE) %>%  as.data.frame()
                a$identifier = seq(1:nrow(a))
                a$latent = a$latent %>% zero.one()
                temp =  merge(data, a, "identifier", all.x = T)
                return(temp)
                        }

msm_fit = function(data = data_long,
         starts =  twoway2.q,
         covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college"),
         time = 1,
         fixed_values = list(authoritarianism = 0, sex = 0),
         category_labels = CAT_LABELS){
         model<-msm(state~time, covariates = as.formula(paste0("~", paste0(covariates, collapse = "+"))),
           subject=id, data=data_long,
           qmatrix= twoway2.q,, obstype=1,
           method="BFGS",
           control=list(trace=1,
           REPORT=1,fnscale=10, maxit=10000))
        tran <- pmatrix.msm(model, t=time, ci="none", covariates = fixed_values) %>% c() %>% matrix(ncol = length(category_labels))
        rownames(tran) <- colnames(tran)  <- CAT_LABELS
        return(tran)
}
twoway2.q<-rbind(c(0,0.20),
                 c(0.2, 0))

education_effects = function(data_long = data_long,
                             timer = 1,
                             x.label = "2000 Election",
                             y.label = "2004 Election",
                             label.x =c("1" = "Vote Democrat", "2" = "Vote Republican") ,
                             label.y =c("1" = "Democrat", "2" = "Republican")
    ){
                                                plot_dat = data.frame(
                                                    score = c(
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 1),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c(),
                                                        msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 1),
                                                        time = timer,
                                                        category_labels = CAT_LABELS) %>% c()),
                                                    education = rep(c("No College", "College"), each = 4),
                                                    authoritarianism = rep(c("Non-Authoritarian", "Authoritarian"), each = 4*2),
                                                    t1    = rep(CAT_LABELS),
                                                    t2    = rep(CAT_LABELS, each =  length(CAT_LABELS))
                                                    )
                                                    plot_dat$gridx = car::recode(plot_dat$t1,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$gridy = car::recode(plot_dat$t2,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$lab =   as.character(round(plot_dat$score, 3))

                                                    p =  ggplot(plot_dat,
                                                                    aes(y = as.factor(gridy), x = as.factor(gridx))) +
                                                                    facet_wrap(~authoritarianism + education) +
                                                        geom_point(alpha = .0001) +
                                                        scale_size(range = c(4,9), name="Cell Sizes") +
                                                        theme(panel.background=element_rect(fill="white")) +
                                                        geom_text(aes(label = lab))  + coord_flip() +
                                                        scale_x_discrete(x.label,
                                                                        labels =label.x) +
                                                        scale_y_discrete(y.label,
                                                                        labels = label.y, position = "left")
                                                return(p)

}

education_effects_interaction = function(data_long = data_long,
                             timer = 1,
                             x.label = "2000 Election",
                             y.label = "2004 Election",
                             label.x =c("1" = "Vote Democrat", "2" = "Vote Republican") ,
                             label.y =c("1" = "Democrat", "2" = "Republican")
    ){
                                                plot_dat = data.frame(
                                                    score = c(
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 0, authXcollege =0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                       covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 0, college = 1,  authXcollege =0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                        covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 0,  authXcollege =0),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                        covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c(),
                                                    msm_fit(data = data_long,
                                                        starts = twoway2.q,
                                                        fixed_values = list(authoritarianism = 1, college = 1, authXcollege =1),
                                                        time = timer,
                                                        category_labels = CAT_LABELS,
                                                        covariates = c("authoritarianism", "sex", "income", "age", "jewish", "catholic", "other", "college", "authXcollege")) %>% c()),
                                                    education = rep(c("No College", "College"), each = 4),
                                                    authoritarianism = rep(c("Non-Authoritarian", "Authoritarian"), each = 4*2),
                                                    t1    = rep(CAT_LABELS),
                                                    t2    = rep(CAT_LABELS, each =  length(CAT_LABELS))
                                                    )
                                                    plot_dat$gridx = car::recode(plot_dat$t1,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$gridy = car::recode(plot_dat$t2,   paste0("'",CAT_LABELS,"'", "=", c(1:length(CAT_LABELS)), collapse = "; ")) %>% as.numeric
                                                    plot_dat$lab =   as.character(round(plot_dat$score, 3))

                                                    p =  ggplot(plot_dat,
                                                                    aes(y = as.factor(gridy), x = as.factor(gridx))) +
                                                                    facet_wrap(~authoritarianism + education) +
                                                        geom_point(alpha = .0001) +
                                                        scale_size(range = c(4,9), name="Cell Sizes") +
                                                        theme(panel.background=element_rect(fill="white")) +
                                                        geom_text(aes(label = lab))  + coord_flip() +
                                                        scale_x_discrete(x.label,
                                                                        labels =label.x) +
                                                        scale_y_discrete(y.label,
                                                                        labels = label.y, position = "left")
                                                return(p)

}


# source: https://www.ceremade.dauphine.fr/~xian/basudo.R
# Too easy one
s=matrix(0,ncol=9,nrow=9)
s[1,c(6,8)]=c(6,4)
#s[2,c(1:3,8)]=c(2,7,9,5)
s[3,c(2,4,9)]=c(5,8,2)
s[4,3:4]=c(2,6)
s[6,c(3,5,7:9)]=c(1,9,6,7,3)
s[7,c(1,3:4,7)]=c(8,5,2,4)
s[8,c(1,8:9)]=c(3,8,5)
s[9,c(1,7,9)]=c(6,9,1)


fizzbuzz_nums = 1:100
output <- vector()

for (i in fizzbuzz_nums) {
  if (i %% 3 == 0 && i %% 5 == 0) {
    output[i] <- "FizzBuzz"
  } else if (i %% 3 == 0) {
    output[i] <- "Fizz"
  } else if (i %% 5 == 0) {
    output[i] <- "Buzz"
  } else {
    output[i] <- i
  }
}

print(output)


insertion_sort <- function(x) {
  for (j in 2:length(x)) {
    key <- x[j]
    bp <- which.max(x[1:j] > key)
    # 'bp' stands for breakpoint
    if (bp == 1) {
      if (key < ar[1]){
          x <- c(key, ar[-j])
      }
    }
    else {
      x <- x[-j]
      x <- c(ar[1:bp - 1], key, x[bp : (s-1)])
    }
  return(x)
  }
}


require(raster)
require(reshape2)
require(maps)
require(mapdata)
require(RColorBrewer)

##############################
# Read in UDel ascii files
##############################

library(reshape2)

# find files
files <- list.files('data_dl/udel/air_temp_2014')

# extract years
m <- regexpr('[[:digit:]]{4}', files)
years <- as.numeric(regmatches(files, m))

# extract the data
tempsarray = array(data=NA, dim=c(360, 720, length(files)*12)) # giant array stack of all temperature data (lat, lon, year-month)
	dimnames(tempsarray)[[1]] = seq(-89.75, 89.75, by=0.5)
	dimnames(tempsarray)[[2]] = seq(-179.75, 179.75, by=0.5)
	dimnames(tempsarray)[[3]] = paste(rep(years, rep(12, length(years))), rep(1:12, length(years)), sep='_')

tmpl <- expand.grid(lat=seq(-89.75, 89.75, by=0.5), lon=seq(-179.75, 179.75, by=0.5)) # template with all lats and lons

for(i in 1:length(files)){ # for each file
	print(files[i])
	x <- read.table(paste('data/udel/air_temp_2014/', files[i], sep=''), header=FALSE)
	names(x) <- c('lon', 'lat', 'jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec')
	x2 <- merge(tmpl, x, all.x=TRUE) # add missing lat/lons

	x3 <- melt(x2, id.vars=c('lat', 'lon'), measure.vars=c('jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', 'sep', 'oct', 'nov', 'dec')) # easy with reshape2!
	x4 <- acast(x3, lat ~ lon ~ variable) # easy with reshape2!

	moinds <- (12*i-11):(12*i)
	tempsarray[,,moinds] = x4
}

	# quick look
	dim(tempsarray)
	image(t(tempsarray[,,120])) # looks great!
	tempsarray['0.25','-61.25',120] # tropics
	tempsarray['-89.75','-98.25',120] # antarctic
	tempsarray['89.75','-98.25',120] # arctic: missing
	tempsarray['65.25','-120.25',120] # northern canada
		dimnames(tempsarray)[[3]][120] # December 1995

	range(tempsarray['-89.75','-98.25',]) # antarctic: always cold
	range(tempsarray['65.25','-120.25',]) # northern canada
	range(tempsarray['0.25','-61.25',]) # tropics: warm

# Write out
save(tempsarray, file=paste('temp/udel', years[1], '_', max(years), '.rdata', sep=''))

###########################
# Interpolate to 0.25
###########################
# Read in
load('temp/udel1986_2005.rdata') # tempsarray lat (360) x lon (720) x time (240 mo)

# make a raster brick
udelb <- brick(tempsarray, xmn=-180, xmx=180, ymn=-90, ymx=90, crs='+proj=longlat +datum=WGS84')

	plot(udelb[[1]])

# create new grid
narray <- array(NA, dim=c(720, 1440, 240))
ngrd <- brick(narray, xmn=-180, xmx=180, ymn=-90, ymx=90, crs='+proj=longlat +datum=WGS84')

# interpolate: raster resample approach
udel025rast <- resample(udelb, ngrd, method='bilinear')

# examine
udel025rast
plot(udel025rast[[1]]) # it's upside down
plot(udel025rast[[240]])

# make array
udel025 <- as.array(udel025rast)
	dim(udel025)
dimnames(udel025) <- list(seq(-89.875, 89.875, by=0.25), lon=seq(-179.875, 179.875, by=0.25), time=1:240)

	image(x=as.numeric(dimnames(udel025)[[1]]), y=as.numeric(dimnames(udel025)[[2]]), z=udel025[,,1])

# rotate so columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
lons <- as.numeric(colnames(udel025))
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(rownames(udel025))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

udel025_2 <- udel025[newlatord, newlonord,]
colnames(udel025_2) <- newcolnms

	image(udel025_2[,,1])

# rename
udel025 <- udel025_2

# save out
save(udel025, file='temp/udel1986_2005_0.25.rdata') #265MB

##################################
# Calculate annual climatology on 0.25x0.25
##################################
# Read in
load('temp/udel1986_2005_0.25.rdata') # udel025 lat (720) x lon (1400) x time (240 mo)

# Average
lstclim <- apply(udel025, MARGIN=c(1,2), FUN=mean)
	dim(lstclim) # 720 x 1440

# save
save(lstclim, file='temp/lstclimatology.rdata')

# Plot climatologies
	image(lstclim)

# Nice plot of lstclim
	lonrng <- round(range(as.numeric(colnames(lstclim))))
	latrng <- round(range(as.numeric(rownames(lstclim))))

	quartz(width=5, height=3)
	# png(width=5, height=3, filename='figures/climatology_map_UDel.png', units='in', res=300)
	par(mai=c(0.7, 0.7, 0.1, 0.2), mgp=c(2, 0.5, 0), las=1, tcl=-0.3)
	image(t(lstclim), xlab='Longitude (°E)', ylab='Latitude (°N)', xaxt='n', yaxt='n', col=rev(heat.colors(20)))
	axis(1, at=seq(0,1, length.out=9), labels=seq(lonrng[1], lonrng[2], length.out=9), cex=0.8)
	axis(2, at=seq(0,1, length.out=7), labels=seq(latrng[1], latrng[2], length.out=7), cex=0.8)

	dev.off()

# Nice plot of lstclim and sstclim (if latter loaded)
	lons <- as.numeric(colnames(lstclim))
	lats <- as.numeric(rownames(lstclim))
	lonrng <- round(range(lons))
	latrng <- round(range(lats))
#	cols1 <- rev(heat.colors(20))
	colfun1 <- colorRampPalette(brewer.pal(9, 'PuRd'))
	cols1 <- colfun1(20)

	lons2 <- as.numeric(colnames(sstclim))
	lats2 <- as.numeric(rownames(sstclim))
#	colfun2 <- colorRampPalette(brewer.pal(9, 'OrRd'))
	colfun2 <- colorRampPalette(brewer.pal(9, 'YlGnBu'))
	cols2 <- colfun2(20)

	quartz(width=5, height=3)
	# png(width=5, height=3, filename='figures/climatology_map_UDel&OISST.png', units='in', res=300)
	par(mai=c(0.7, 0.7, 0.1, 0.2), mgp=c(2, 0.5, 0), las=1, tcl=-0.3)
	image(t(lstclim), x=lons, y=lats, xlab='Longitude (°E)', ylab='Latitude (°N)', col=cols1)

	image(t(sstclim), add=TRUE, x=lons2, y=lats2, col=cols2)
	image(t(sstclim), add=TRUE, x=lons2-360, y=lats2, col=cols2)

	dev.off()

#################################################
# Calculate annual climatology on CMIP5 grid
#################################################
# need lstclim from previous section

# create new grid
	ngrd <- expand.grid(lat=seq(-88.75,88.75,by=2.5), lon=seq(-178.75,178.75,by=2.5)) # the grid to interpolate for land (2.5)

# interpolate
	# raster query approach with points
	ngrd.sp1 <- ngrd[,c('lon', 'lat')]
	coordinates(ngrd.sp1) <- ~lon + lat
	proj4string(ngrd.sp1) <- '+proj=longlat +datum=WGS84'

	lstclimr <- raster(lstclim[nrow(lstclim):1,], xmn=-180, xmx=180, ymn=-90, ymx=90, crs='+proj=longlat +datum=WGS84') # make a raster object from lstclim data
	newvalsl <- extract(lstclimr, ngrd.sp1, method='bilinear')
	lstngrdr <- rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalsl))

# examine
	par(mfrow=c(1,2))
	plot(lstclimr)
	plot(lstngrdr)

# convert to matrix: n for new grid
lstclimn <- as.matrix(lstngrdr)
	rownames(lstclimn) <- yFromRow(lstngrdr)
	colnames(lstclimn) <- xFromCol(lstngrdr)

# rotate lst so 0-360
lons <- as.numeric(colnames(lstclimn))
lons[lons<0] <- lons[lons<0]+360
colnames(lstclimn) <- lons
lstclimn <- lstclimn[,order(lons)]

# write out
save(lstclimn, file='temp/lstclimatology_cmip5grid.rdata')

########################################
# Calculate summer climatology on 0.25
########################################

# Read in
load('temp/udel1986_2005_0.25.rdata') # udel025

nms <- dimnames(udel025)
dm <- dim(udel025)
tempsarraybymo <- array(udel025, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=1986:2005)) # reshape so it has a month dimension (3rd dimension)

lstclimbymo <- apply(tempsarraybymo, MARGIN=c(1,2,3), FUN=mean) # climatology for each month
	# image(lstclimbymo[,,1]) # january
	# image(lstclimbymo[,,6]) # june

# Using "summer" months
	lstclimwarm3N <- apply(lstclimbymo[,,6:8], MARGIN=c(1,2), FUN=mean) # temperature of summer 3-month period in each cell for northern hemisphere
	lstclimwarm3S <- apply(lstclimbymo[,,c(1,2,12)], MARGIN=c(1,2), FUN=mean) # temperature of summer 3-month period in each cell for northern hemisphere
	lstclimwarm3 <- rbind(lstclimwarm3N[as.character(seq(89.875,0.125,by=-0.25)),], lstclimwarm3S[as.character(seq(-0.125,-89.875,by=-0.25)),])

		# plot
		par(mfrow=c(3,1))
		image(lstclimwarm3N, main='northern summer')
		image(lstclimwarm3S, main='southern summer')
		image(lstclimwarm3, main='combined summer')

# save
save(lstclimwarm3, file='temp/lstclimatology_warm3.rdata')

#################################################
# Calculate summer climatology on CMIP5 grid
# using "summer"
#################################################
# need sstclimwarm3 from 2 sections previous

require(raster)
require(reshape2)
require(maps)
require(mapdata)

# create new grid
	ngrd <- expand.grid(lat=seq(-88.75,88.75,by=2.5), lon=seq(-178.75,178.75,by=2.5)) # the grid to interpolate for land (2.5)

# interpolate
	# raster query approach with points
	ngrd.sp <- ngrd[,c('lon', 'lat')]
	coordinates(ngrd.sp) <- ~lon + lat
	proj4string(ngrd.sp) <- '+proj=longlat +datum=WGS84'

	lstclimr <- raster(lstclimwarm3, xmn=-180, xmx=180, ymn=-90, ymx=90, crs='+proj=longlat +datum=WGS84') # make a raster from sstclim data
	newvalls <- extract(lstclimr, ngrd.sp, method='bilinear') # interpolated sst from summer
	lstngrdr <- rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalls))

# examine
	par(mfrow=c(2,1))
	plot(lstclimr)
	plot(lstngrdr)

# convert to array: n for new grid
lstclimwarm3n <- as.matrix(lstngrdr)
	rownames(lstclimwarm3n) <- rev(yFromRow(lstngrdr))
	colnames(lstclimwarm3n) <- xFromCol(lstngrdr)

	image(lstclimwarm3n, xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(lstclimwarm3n)), labels=rownames(lstclimwarm3n))
		axis(side=2, at=seq(0,1,length=ncol(lstclimwarm3n)), labels=colnames(lstclimwarm3n))

# rotate lst so 0-360 like CMIP5 model grids
lons <- as.numeric(colnames(lstclimwarm3n))
lons[lons<0] <- lons[lons<0]+360
colnames(lstclimwarm3n) <- lons
lstclimwarm3n <- lstclimwarm3n[,order(lons)]

# flip to match cmip5
lstclimwarm3n <- lstclimwarm3n[nrow(lstclimwarm3n):1,]

	image(lstclimwarm3n, xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(lstclimwarm3n)), labels=rownames(lstclimwarm3n))
		axis(side=2, at=seq(0,1,length=ncol(lstclimwarm3n)), labels=colnames(lstclimwarm3n))

# write out
save(lstclimwarm3n, file='temp/lstclimatology_warm3_cmip5grid.rdata')

#####################################
# Calculate monthly climatology on 0.25
#####################################
# Read in
load('temp/udel1986_2005_0.25.rdata') # udel025

# reshape so month is a dimension
nms <- dimnames(udel025)
dm <- dim(udel025)
tempsarraybymo <- array(udel025, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=1986:2005)) # reshape so it has a month dimension (3rd dimension)

# average
lstclimbymo <- apply(tempsarraybymo, MARGIN=c(1,2,3), FUN=mean) # climatology for each month

# visualize
	image(lstclimbymo[,,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(lstclimbymo)), labels=rownames(lstclimbymo), cex.axis=0.4)
		axis(side=2, at=seq(0,1,length=ncol(lstclimbymo)), labels=colnames(lstclimbymo), cex.axis=0.4)

# save
save(lstclimbymo, file='temp/lstclimatology_bymonth.rdata')

#################################################
# Calculate monthly climatology on CMIP5 grid
#################################################
# need lstclimbymo from previous section
load('temp/lstclimatology_bymonth.rdata')

# create new grid
	ngrd <- expand.grid(lat=seq(-88.75,88.75,by=2.5), lon=seq(1.25,358.75,by=2.5)) # the grid to interpolate for land (2.5)

# interpolate
	# raster query approach with points
	ngrd.sp <- ngrd[,c('lon', 'lat')]
	coordinates(ngrd.sp) <- ~lon + lat
	proj4string(ngrd.sp) <- '+proj=longlat +datum=WGS84'

	lstclimr <- brick(lstclimbymo, xmn=0, xmx=360, ymn=-90, ymx=90, crs='+proj=longlat +datum=WGS84') # make a raster brick from sstclim data
		# plot(lstclimr, y=1) # check orientation

	newvalss <- extract(lstclimr, ngrd.sp, method='bilinear') # interpolated sst by month
	lstngrdr <- rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss))

# examine
	par(mfrow=c(2,1))
	plot(subset(lstclimr,1))
	plot(subset(lstngrdr,1))

# convert to array: n for new grid
lstclimbymon <- as.array(lstngrdr)
	dimnames(lstclimbymon)[[1]] <- yFromRow(lstngrdr)
	dimnames(lstclimbymon)[[2]] <- xFromCol(lstngrdr)
	dimnames(lstclimbymon)[[3]] <- 1:12

	image(lstclimbymon[,,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(lstclimbymon)), labels=rownames(lstclimbymon))
		axis(side=2, at=seq(0,1,length=ncol(lstclimbymon)), labels=colnames(lstclimbymon))

# write out
save(lstclimbymon, file='temp/lstclimatology_bymonth_cmip5grid.rdata')

#############################################
# Calculate warmest month on 0.25x0.25
#############################################
# need lstclimbymon from previous section
load('temp/lstclimatology_bymonth.rdata')

lstclimwarmestmo <- apply(lstclimbymo, MARGIN=c(1,2), FUN=max)

	# check orientation: want 0-360 starting at Greenwich
	image(lstclimwarmestmo, xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(lstclimwarmestmo)), labels=rownames(lstclimwarmestmo))
		axis(side=2, at=seq(0,1,length=ncol(lstclimwarmestmo)), labels=colnames(lstclimwarmestmo))

	rownames(lstclimwarmestmo) # should be 90 to -90
	colnames(lstclimwarmestmo) # should be 0 to 360

# write out
save(lstclimwarmestmo, file='temp/lstclimatology_warmestmonth.rdata')

#############################################
# Calculate warmest month on the CMIP5 grid
#############################################
# need lstclimbymon from previous section
load('temp/lstclimatology_bymonth_cmip5grid.rdata')

lstclimwarmestmon <- apply(lstclimbymon, MARGIN=c(1,2), FUN=max)

	image(lstclimwarmestmon, xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(lstclimwarmestmon)), labels=rownames(lstclimwarmestmon))
		axis(side=2, at=seq(0,1,length=ncol(lstclimwarmestmon)), labels=colnames(lstclimwarmestmon))

	rownames(lstclimwarmestmon) # should be 90 to -90
	colnames(lstclimwarmestmon) # should be 0 to 360

# write out
save(lstclimwarmestmon, file='temp/lstclimatology_warmestmonth_cmip5grid.rdata')


library(dplyr)
library(ggplot2)

data(cars)
dist.cars <- dist(cars, method="manhattan")
hc.cars <- hclust(dist.cars)

# クラスタへの分割(クラスタ数=3)
ct.cars <- cutree(hc.cars, k = 3)
# クラスタ番号の結合
cars.hc <- cars %>% mutate(cluster = factor(ct.cars, levels = 1:3))
# 点の色をクラスタ番号とする散布図のプロット
p <- ggplot(
    data = cars.hc,
    aes( x = speed, y = dist, colour = cluster, shape = cluster)
  ) + geom_point(aes(shape = cluster))
print(p)


plot((function(x) dgamma(x, shape = 1, scale=1/50))(seq(0, 1, length.out = 2000)), type="l")

dat <- rgamma(10, 1, 1/50)

f <- function(p, ...) prod(dgamma(dat, p[1], p[2]))
x <- c(1, 1)

# Adaptive kernel
prob <- replicate(1e3, sdml_adaptive_kernel(
  x = c(1,1),
  f = f, alpha=.9
)$h)

plot(log(prob[!is.nan(prob)]), type="l")

# Non adaptive kernel
# normal_prop()


dice7.vec <- function(n=1, checkLength=TRUE)
{
   morethan2n <- 3 * n + 10 + (n %% 2)       #need more than 2*n samples, because some are discarded
   twoDfive <- matrix(dice5(morethan2n), nrow=2)
   total <- colSums(c(5, 1) * twoDfive) - 3
   score <- ifelse(total < 24, total %/% 3, NA)
   score <- score[!is.na(score)]
   #If length is less than n (very unlikely), add some more samples
   if(checkLength)
   {
      while(length(score) < n)
      {
         score <- c(score, dice7(n, FALSE))
      }
      score[1:n]
   } else score
}
system.time(dice7.vec(1e6))   # ~1 sec


# Example of application of the R functions related to the paper:
#
# "A shared-parameter continuous-time hidden Markov and survival model for longitudinal data
#  with informative drop-out"
# by F.Bartolucci and A.Farcomeni (2018)

# Simulation of data (see the function code for the help)

# Normal distribution for the responses
source("simulate_joint_HMcontinuous.r")
out = simulate_joint_HMcontinuous()

# Estimate with complete data
tT = out$tT   # time of any (time-continuous jump)
TT = out$TT   # observation times
tU = out$tU   # latent states
TT = out$TT   # time of observation of any longitudinal outcome
W = out$W     # matrix of baseline covariates
X = out$X     # array of time-varying covariates
Y = out$Y     # array of time-varying covariates
tv = out$tv   # vector of survival times
dev = out$dev # vector of censoring
source("est_comp_joint_HMcontinuous.r")
est = est_comp_joint_HMcontinuous(tT,tU,TT,W,X,Y,tv,dev,k=k0,type="norm")

# Estimate with incomplete data
source("est_incomp_joint_HMcontinuous.r")
est1 = est_incomp_joint_HMcontinuous(Y,TT,X,W,tv,dev,k=k0,type="norm",verbose=TRUE,stderr=TRUE)

# Bernoulli distribution for the responses
out1 = simulate_joint_HMcontinuous(n=500,type="bino")

# Estimate under with complete data
tT = out1$tT   # time of any (time-continuous jump)
TT = out1$TT   # observation times
tU = out1$tU   # latent states
TT = out1$TT   # time of observation of any longitudinal outcome
W = out1$W     # matrix of baseline covariates
X = out1$X     # array of time-varying covariates
Y = out1$Y     # array of time-varying covariates
tv = out1$tv   # vector of survival times
dev = out1$dev # vector of censoring
est2 = est_comp_joint_HMcontinuous(tT,tU,TT,W,X,Y,tv,dev,k=k0,type="bino")

# Estimate with incomplete data
source("est_incomp_joint_HMcontinuous.r")
est3 = est_incomp_joint_HMcontinuous(Y,TT,X,W,tv,dev,k=k0,type="bino",verbose=TRUE,stderr=TRUE)


#Second argument, following "d", is the k variable, or number of clusters; nstart denotes number of starting configurations)
kcluster <- kmeans(d, 2, nstart=100)

#In this instance, plotting the results requires the "cluster" library. This will use principal component analysis to reduce the number of dimensions and render the clusters in two dimensions.
library(cluster)
clusplot(m, kcluster$cluster, color=T, shade=T, labels=2, lines=0)

#For the lines below, where "wss" stands for "within [cluster] sum of squares," the idea is to run through different numbers of k and plot them out, then on the graph to look for a bend which might signal an optimal number of k to work from. The X:Y following the WSS should reflect the number of clusters to check for, 2 being the logical minimum, and the maximum being whatever number of data points are in the dataset.
#wss <- 2:29
#for (i in 2:29) wss[i] <- sum(kmeans(d,centers=i,nstart=25)$withinss)
#plot(2:29, wss[2:29], type=”b”, xlab=”Number of Clusters”,ylab=”Within groups sum of squares”)

write.csv("kcluster.csv")


#Install dependencies
install.packages("reshape2")
install.package("ggplot2")

#Requires
require("reshape2")
require("ggplot2")

#Import the data
teams <- read.csv("./the-blue-alliance-data-master/the-blue-alliance-data-master/teams/teams.csv", header=FALSE)
names(teams) <- c("number", "name", "sponsors", "location", "website", "rookie_year")

#Let's parese the location further down into state
teams <- cbind(teams,colsplit(teams$location, pattern = ",", names = c("city","state","country")))

#Let's take a look ate how many teams join each year
png("new-teams-by-year.png")
years <- data.frame(table(teams$rookie_year))
years[1] <- as.numeric(levels(years[1]))[years[1]]
years[2] <- as.numeric(levels(years[2]))[years[2]]
names(years) <- c("year", "freq")
plot(years$year, years$freq)
reg1 <- lm(years$freq~years$year) #TODO, make this correct
abline(reg1)
abline(-30,20)
#TODO Add a polynomial regression hear
dev.off()

png("new-teams-by-year.2.png")
rookie_hist <- qplot(teams$rookie_year, main="Number of teams per year", xlab="Year")
rookie_hist <- rookie_hist + scale_x_continuous(breaks = seq(1990, 2018, by = 2))
rookie_hist <- rookie_hist + geom_freqpoly(size=2, color = "blue", alpha = .2)
rookie_hist + geom_freqpoly()
#TODO, add a regression line to this
dev.off()

png("new-teams-by-year.3.png")
hist(teams$rookie_year) #This uses the base plotting system
dev.off()

png("new-teams-by-year.4.png")
#TODO qplot(years) + stat_bin(binwidth = 1,  col = "black")
dev.off()

png("team-count-by-state.png")
qplot(teams$state) #TODO sort by most numerous
dev.off()

png("team-count-by-state.2.png")
plot(table(teams$state)) #Uses base plotting system
dev.off()

png("team-count-by-state.3.png")
plot(data.frame(table(teams$state))) #Uses base plotting system
dev.off()


K = 10
w = c(5,2,4,6)
v = c(18,9,12,25)
DataKnap<-data.frame(w,v)

DataKnap$rows_idx <- row(DataKnap)
DataKnap <- DataKnap[DataKnap$w < K,]
DataKnap$VWRatio <- DataKnap$v/DataKnap$w
DescOrder <- order(DataKnap$VWRatio, decreasing = TRUE)
DataKnap <- DataKnap[DescOrder,]

KnapSol <- list(value = 0)
SumWeights <- 0
i <- 1

while (i<=nrow(DataKnap) & SumWeights + DataKnap$w[i]<=K){
    SumWeights <- SumWeights + DataKnap$w[i]
    KnapSol$value <- KnapSol$value + DataKnap$v[i]
    KnapSol$elements[i] <- DataKnap$row[i]
    i <- i + 1
}

print(KnapSol)


# https://r4ds.had.co.nz/tidy-data.html
library(tidyverse)

# tidying when a column names are values of variables

View(table4a)
View(tidy4a)

View(table4a %>% pivot_longer(c(`1999`, `2000`), names_to="year", values_to="cases"))

tidy4a <- table4a %>%
  pivot_longer(c(`1999`, `2000`), names_to = "year", values_to = "cases")
tidy4a

View(table4b %>% pivot_longer(c(`1999`, `2000`), names_to="year", values_to="population"))

tidy4b <- table4b %>%
  pivot_longer(c(`1999`, `2000`), names_to = "year", values_to = "population")
tidy4b

left_join(tidy4a, tidy4b)

# tidying when observations are accross multiple rows

table2
View(table2)
table2 %>% pivot_wider(names_from=type, values_from=count)
?pivot_wider  # check after seeing

# tidying when multiple variables in the same row

table3
table3 %>% separate(rate, into=c("cases", "population"), sep="/")
?separate


#######################################################################
#######################################################################
#######################################################################
######                                                           ######
######          Testing routines for simulating high-            ######
######      dimensional multivariate normal distributions        ######
######                                                           ######
#######################################################################
#######################################################################
#######################################################################
source("BigMVNgen.r")
#
# Generate some sampling locations uniformly distributed on the sphere
# NB to achieve this, latitudes must be sampled from a density
# proportional to cos(lat) with latitude in radians, otherwise points
# will be denser at the poles. Not that it really matters for
# illustrative purposes.
#
set.seed(2000)
Nsites <- 28000
site.coords <- matrix(ncol=2,nrow=Nsites)
site.coords[,1] <- 180*(asin(2*runif(Nsites)-1)/pi)
site.coords[,2] <- 360*runif(Nsites)-180
#
#   Split latitude and longitude ranges into 20 bins each - so 400 groups in
#   total, which means about 75 sites in each group on average if there
#   are 30000 sites in total (although the equatorial grid cells have more
#   more sites, obviously, because they're bigger)
#
N.grid <- 13
group.id <- 1 + (N.grid*floor(N.grid*(site.coords[,1]+90)/180)) +
                        floor(N.grid*(site.coords[,2]+180)/360)
cat("NUMBERS OF SITES PER GROUP:\n")
print(table(group.id))
#
#   Now define the "neighbourhoods" of each grid cell. This could be
#   done on a distance basis; but this would require that we compute
#   all pairwise distances (which kind of defeats the purpose of
#   trying to get everything done in something like linear
#   computational time). The cunning plan is to calculate the
#   distances fromthe grid cell centres to each site, and to
#   define the neighbourhoods of each site to be all sites that
#   are within an appropriate distance of the corresponding grid
#   cell centre. For "appropriate distance", it seems reasonable
#   to take, say, the maximum distance between adjacent
#   grid cell centres (this means we're guaranteed to include
#   anything half-way into the next cell)
#
cell.centres <- cbind(rep(-90 + (((1:N.grid)-0.5)*180/N.grid),each=N.grid),
                     rep(-180 + (((1:N.grid)-0.5)*360/N.grid),N.grid))
sites.to.cells <- howfar(cell.centres,site.coords)
cells.to.cells <- howfar(cell.centres,cell.centres)
max.dist <- max(cells.to.cells[row(sites.to.cells)-col(sites.to.cells) == 1])
neighbours <- vector("list",N.grid^2)
for (i in 1:(N.grid^2)) {
  wanted.sites <- (group.id != i) & (sites.to.cells[i,] < max.dist)
  neighbours[[i]] <- (1:Nsites)[wanted.sites]
}
#
#   Function to define an exponential covariance structure. The
#   covariance between sites separated by a distance of d km is
#   sigma^2 * exp(-phi*d). The vector theta below contains
#   two elements: (sigma^2,phi). coords is a two-column
#   matrix of latitudes and longitudes
# KW: This substitutes a real covariance structure by assuming that
# covariances decay exponentially with distance from 1 at 0 km to
# 1/e(ish 0.37) at 1000km to 0.0 at 5000km
#
exp.corr <- function(theta,coords) {
  d <- howfar(coords,coords)
  z <- theta[1] * exp(-theta[2]*d)
}
#
#   sites.to.cells is VERY big, so remove it and do garbage collection
#
rm(sites.to.cells); gc()
theta <- c(1,0.001)
#
#   For this test script, could just pass the correlation function
#   through to rbigmvn.setup(). However, for illustrative
#   purposes the next fewlines demonstrate how to prepare a
#   list of covariance matrices that can be passed over instead.
#   In practice, the call to exp.corr() below would be replaced
#   by code that calculates the appropriate empirical covariance
#   matrices, but hopefully the general idea is clear. As it stands,
#   the code is a bit inefficient because some pairs of sites
#   will appear in more than one group and the code doesn't
#   "remember" the pairs that it has already done. Worse things
#   happen at sea.
#
#   NB the "wanted.sites" command below is critical: as supplied,
#   it ensures that the sites are extracted in *exactly* the same
#   order that they appear in the full site list, which is
#   necessary to avoid generating nonsense!
#
M <- N.grid^2
Sigmalist <- vector("list",M)
for (i in 1:M) {
  cat(paste("Calculating covariances: group",i,"of",M,"...\r"))
  wanted.sites <- ((1:Nsites) %in% neighbours[[i]]) | (group.id == i)
  Sigmalist[[i]] <- exp.corr(theta,site.coords[wanted.sites,])
}
cat("\n")
#
#   Now do all the preliminary calculations for the sampling
#
cat("Setting up neighbourhoods and covariance structures ...\n")
test.setup <- rbigmvn.setup(mu=1:Nsites,coords=site.coords,
                            groups=group.id,neighbours=neighbours,
                            coord.type="geographical",method="factorize",
                            Sigmalist=Sigmalist)
#
#   And generate 10000 realisations at those 30000 sites (the graphics
#   window is for the trace plot)
# KW: Do we need 10000 now that we don't need to thin (using Factorise)
# If not then perhaps only 600 (50 years of data) or 1200 (100 years of data)
#
if (dev.cur()==1) x11(width=8,height=6)
par(lwd=2,ask=TRUE,mar=c(3,3,2,2),mgp=c(2,0.75,0),oma=c(1,1,1,1),mfrow=c(1,1))
cat("Simulating ...\n")
test <- rbigmvnorm(600,setup=test.setup,nburnin=100,monitor=FALSE)
#
# Check the properties for, say, the first 10 sites
#
cat("PROPERTIES OF FIRST 12 SITES:\n")
cat("Sample means: "); print(round(colMeans(test[,1:10]),3))
cat("Theoretical means: "); print(round(1:10,3))
cat("Sample covariance matrix:\n")
print(round(cov(test[,1:10]),2))
cat("Theoretical covariance matrix:\n")
print(round(exp.corr(theta,site.coords[1:10,]),2))
par(mfrow=c(3,4),oma=c(1,1,3,1))
for (i in 1:12) {
  qqnorm(test[,i],main=paste("Site",i))
}
mtext("Normal Q-Q plots for first 12 sites",outer=TRUE,line=1)
#
# That looks OK, but the sites are obviously well separated and hence
# effectively independent. What about sites that are close together -
# and in different groups? Take sites within 10 degrees (lat,long) of
# (18,36) which is a boundary between two grid cells.
#
wanted.sites <- (abs(site.coords[,1]-18) < 10) & (abs(site.coords[,2]-36) < 10)
cat("PROPERTIES OF SITES WITHIN 10 DEGREES OF (18,36):\n")
cat("Site numbers and groups:\n")
print(rbind((1:Nsites)[wanted.sites],group.id[wanted.sites]))
cat("Sample means: "); print(round(colMeans(test[,wanted.sites]),3))
cat("Theoretical means: "); print(round((1:Nsites)[wanted.sites],3))
cat("Sample covariance matrix:\n")
print(round(cov(test[,wanted.sites]),2))
cat("Theoretical covariance matrix:\n")
print(round(exp.corr(theta,site.coords[wanted.sites,]),2))
par(mfrow=c(2,4))
for (i in (1:Nsites)[wanted.sites]) {
  qqnorm(test[,i],main=paste("Site",i))
}
mtext("Normal Q-Q plots for sites within 10 degrees of (18,36)",outer=TRUE,line=1)
#
# Finally, check results for sites around +/-180 longitude, to ensure
# that wrapping is handled correctly (NB the latitude range from -13.5
# to +13.5 is merely to ensure that there are 12 sites in total, which
# allows a 3*4 array of plots)
#
wanted.sites <- (abs(site.coords[,1]) < 13.5) & (abs(site.coords[,2]) > 170)
cat("PROPERTIES OF SITES AROUND (0,180):\n")
cat("Site numbers and groups:\n")
print(rbind((1:Nsites)[wanted.sites],group.id[wanted.sites]))
cat("Sample means: "); print(round(colMeans(test[,wanted.sites]),3))
cat("Theoretical means: "); print(round((1:Nsites)[wanted.sites],3))
cat("Sample covariance matrix:\n")
print(round(cov(test[,wanted.sites]),2))
cat("Theoretical covariance matrix:\n")
print(round(exp.corr(theta,site.coords[wanted.sites,]),2))
par(mfrow=c(3,4))
for (i in (1:Nsites)[wanted.sites]) {
  qqnorm(test[,i],main=paste("Site",i))
}
mtext("Normal Q-Q plots for sites around (0,180)",outer=TRUE,line=1)
stop()

#
#   Just out of interest, here's a demonstration of how one might
#   fit a VAR model to those data using least squares. Consider
#   the rows of the matrix we've just generated to be "time points",
#   and the columns to be "variables" (which they are). Exploit
#   the fact that if the response variable in a call to lm() is
#   a matrix, a separate regression model will be fitted for
#   each column; and the coefficients themselves will be stored
#   in columns (this doubtless exploits the fact that the design
#   matrix is the same for all of the regressions, so that
#   things like (X'X)^-1 have to be calculated only once). The
#   estimate of Phi is then just the transpose of the returned
#   coefficient matrix. Neat!
#
#   NB the "-1" in the model formula is to exclude the intercept
#   in order to fit a VAR model with zero mean.
#
cat("\nFitting VAR(1) model to output ...\n")
VAR.fit <- lm(test[-1,] ~ test[-nrow(test),] - 1)
Phi <- t(coef(VAR.fit))
par(mfrow=c(1,1))
plot(density(diag(Phi)),
     main="Diagonal coefficients of Phi matrix in VAR(1) model for simulated sequence")
rug(diag(Phi))

stop()

#
#   All looking good. Now: just out of interest, how long will it take to
#   do the setup for 100,000 sites (which is the order of magnitude for
#   the ISTI project)? Probably split into something like a 30*30 grid
#   here, so that there are ~100 sites per block and 900 blocks. Storage
#   could be an issue given that i've just stored a 10000*1000 matrix, so
#   get rid of it.
#
rm(test.setup); rm(test); gc()
cat("Generating 100000 new site locations ...\n")
Nsites <- 100000
site.coords <- matrix(ncol=2,nrow=Nsites)
site.coords[,1] <- 180*(asin(2*runif(Nsites)-1)/pi)
site.coords[,2] <- 360*runif(Nsites)-180
N.grid <- 30
group.id <- 1 + (N.grid*floor(N.grid*(site.coords[,1]+90)/180)) +
  floor(N.grid*(site.coords[,2]+180)/360)
cell.centres <- cbind(rep(-90 + (((1:N.grid)-0.5)*180/N.grid),each=N.grid),
                      rep(-180 + (((1:N.grid)-0.5)*360/N.grid),N.grid))
sites.to.cells <- howfar(cell.centres,site.coords)
cells.to.cells <- howfar(cell.centres,cell.centres)
max.dist <- max(cells.to.cells[row(sites.to.cells)-col(sites.to.cells) == 1])
neighbours <- vector("list",N.grid^2)
for (i in 1:(N.grid^2)) {
  wanted.sites <- (group.id != i) & (sites.to.cells[i,] < max.dist)
  neighbours[[i]] <- (1:Nsites)[wanted.sites]
}
#
#   sites.to.cells is VERY big, so remove it and do garbage collection
#
rm(sites.to.cells); gc()
theta <- c(1,0.001)
cat("Setting up neighbourhoods and covariance structures ...\n")
test.setup <- rbigmvn.setup(mu=1:Nsites,covfunc=exp.corr,covpars=theta,
                            coords=site.coords,groups=group.id,neighbours=neighbours,
                            coord.type="geographical")
test <- rbigmvnorm(1,setup=test.setup)