library("coda")

# posterior distribution of converged chain
set.seed(61)
post0 = mh(n=n, ybar=ybar, n_iter=10e3, mu_init=0.0, cand_sd=0.9)
traceplot(as.mcmc(post0$mu[-c(1:500)]))

# posterior distribution of wondering chain
post1 = mh(n=n, ybar=ybar, n_iter=1e3, mu_init=0.0, cand_sd=0.04)
traceplot(as.mcmc(post1$mu[-c(1:500)]))

# posterior distribution wondering chain converged
post2 = mh(n=n, ybar=ybar, n_iter=100e3, mu_init=0.0, cand_sd=0.04)
traceplot(as.mcmc(post2$mu))

# effective sample size - number of independent MC samples (more = greater information)

# effective sample size how many indipendent sampe needed to get the same information

# want chain with low auto correaltion - good converging properties - good chain

# need to check the effective sample size - relyable estimates need a high number of effective sample size

# a chain with high auto correaltion will lead to more sampling to get a good (significant) effective sample

# lesson - drawing from a population who are correlated will take longer to understand the entire distribution

autocorr.plot(as.mcmc(post0$mu))
autocorr.diag(as.mcmc(post0$mu))

autocorr.plot(as.mcmc(post1$mu))
autocorr.diag(as.mcmc(post1$mu))

str(post2)

effectiveSize(as.mcmc(post2$mu))

autocorr.plot(as.mcmc(post2$mu), lag.max=500)

thin_interval = 400 # how far apart the iterations are for autocorrelation to be essentially 0.
thin_indx = seq(from=thin_interval, to=length(post2$mu), by=thin_interval)
head(thin_indx)

post2mu_thin = post2$mu[thin_indx]
traceplot(as.mcmc(post2$mu))

traceplot(as.mcmc(post2mu_thin))

autocorr.plot(as.mcmc(post2mu_thin), lag.max=10)

effectiveSize(as.mcmc(post0$mu))

?effectiveSize

raftery.diag(as.mcmc(post0$mu))

raftery.diag(as.mcmc(post0$mu), q=0.005, r=0.001, s=0.95)


## 2. Useful Qualities of Probability Distributions ##

are_uniforms <- FALSE
most_probable_A <- 1
total_probability_B <- 0.2 + 0.2 + 0.2 + 0.2 + 0.3
is_B_valid <- FALSE

## 4. Example: Sum of Two Dice Rolls ##

prob_2 <- 1/36
prob_4 <- 3/36
prob_7 <- 6/36
prob_10 <- prob_4

## 5. Cumulative Probability ##

prob_leq_6 <- 1/36 + 2/36 + 3/36 + 4/36 + 5/36
prob_gt_9 <- 6/36
prob_btwn_6_and_8 <- 5/36 + 6/36 + 5/36

## 8. Probability Distribution Function for the Normal ##

prob_norm_0 <- dnorm(0)
prob_norm_5 <- dnorm(5, 5, 5)
prob_norm_1 <- dnorm(-1, 1, 2)

Data Analyst in R/Step 5 - Probability and Statistics/5. Hypothesis Testing in R/1. Probability Distributions.r


n = 600851475143

i = 2
while (n != 1) {
    if (n %% i == 0) {
        n = n / i
    } else {
        i = i + 1
    }
}

cat(i, "\n")


primes <- c(2, 3, 5, 7, 11, 13)
isPrime <- function(a) {
  i <- 1
  while (a %% primes[i] > 0) {
    if (primes[i] * primes[i] > a) {
      primes <<- append(primes, a)
      return(TRUE)
    }
    i <- i + 1
  }
  FALSE
}

primeSeq <- function() {
  p0 <- 1
  i <- 0
  return(function() {
    if (p0 <= length(primes)) {
      i <<- primes[p0]
      p0 <<- p0 + 1
      return(i)
    }
    i <<- i + 2
    while (!isPrime(i)) {
      i <<- i + 2
    }
    p0 <<- p0 + 1
    return(i)
  })
}

primeless <- function(n) {
  r <- c()
  nextPrime <- primeSeq()
  i <- nextPrime()
  while (i < n) {
    r <- append(r, i)
    i <- nextPrime()
  }
  paste(r, collapse=",")
}

for (line in readLines(tail(commandArgs(), n=1))) {
  cat(sapply(as.integer(line), primeless), sep="\n")
}


# take input from the user
nterms = as.integer(readline(prompt="How many terms? "))
# first two terms
n1 = 0
n2 = 1
count = 2
# check if the number of terms is valid
if(nterms <= 0) {
print("Plese enter a positive integer")
} else {
if(nterms == 1) {
print("Fibonacci sequence:")
print(n1)
} else {
print("Fibonacci sequence:")
print(n1)
print(n2)
while(count < nterms) {
nth = n1 + n2
print(nth)
# update values
n1 = n2
n2 = nth
count = count + 1
}
}
}


require(adehabitat)
require(CircStats)

"simm.crw2" <- function(date=1:100, h = 1, r = 0, R=57.5,
                        x0=c(0,0), id="A1", burst=id,
                        typeII=TRUE)
 {
     if (!require(CircStats))
         stop("package CircStats required")
     if (typeII)
         class(date) <- c("POSIX","POSIXct")
     n <- length(date)
     dt <- c(diff(unclass(date)))
     if (all(dt-dt[1]>1e-7))
         stop("the time lag between relocations should be constant")

         if (h>0) {
            v=sqrt(dt)*rchi(n-1) * h
          } else {
            v=dt/dt*(-h)

          }
		ang<-rwrpnorm(n-2,0,r)
         ang=cumsum(c(runif(1,0,2*pi),ang))
x=c(1:n)
y=x
x[1]= x0[1]
y[1] =x0[2]
for (i in c(2: n)){
		x[i]= x[i-1]+v[i-1]*cos(ang[i-1])
		y[i]= y[i-1]+v[i-1]*sin(ang[i-1])
		RR=(x[i]^2+y[i]^2)
		if ((RR> R^2) && (i< (n-1)) ){

			x[i]= R*x[i]/sqrt(RR)
			y[i]= R*y[i]/sqrt(RR)
			ang2<-rwrpnorm(n-2-i,0,r)
			ang2=cumsum(c(runif(1,0,2*pi),ang2))
			j=c(1:(n-i-1))
			ang[i+j]=ang2[j]

			}
		}

    res <- as.ltraj(data.frame(x,y),date, id, burst,
                     typeII=typeII)
     return(res)
 }

#
#
#  now levy walks!

 simm.levy2 <- function (date = 1:500, mu = 2, l0 = 1, x0 = c(0, 0), id = "A1", R=57.5,

    burst = id, typeII = TRUE)
 {
    if (typeII)
        class(date) <- c("POSIX", "POSIXct")
    n <- length(date)
    dt <- c(diff(unclass(date)))
    if (all(dt - dt[1] > 1e-07))
        stop("the time lag between relocations should be constant")
    ang <- runif(n - 2, -pi, pi)
    v = dt * (l0 * (runif(n - 1)^(1/(1 - mu))))
        ang = cumsum(c(runif(1, 0, 2 * pi), ang))
#    newcode
    x=c(1:n)
    y=x
    x[1]= x0[1]
    y[1] =x0[2]
    for (i in c(2: n)){
      	x[i]= x[i-1]+v[i-1]*cos(ang[i-1])
    		y[i]= y[i-1]+v[i-1]*sin(ang[i-1])
    		RR=(x[i]^2+y[i]^2)
    		if ((RR> R^2) && (i< (n-1)) ){

    			x[i]= R*x[i]/sqrt(RR)
    			y[i]= R*y[i]/sqrt(RR)
    			ang2<-rwrpnorm(n-2-i,0,r)
    			ang2=cumsum(c(runif(1,0,2*pi),ang2))
    			j=c(1:(n-i-1))
    			ang[i+j]=ang2[j]

    			}
    		}
    res <- as.ltraj(data.frame(co, si), date, id, burst, typeII = typeII)
    return(res)
 }

  simm.levycorr <- function (date = 1:500, mu = 2, l0 = 1, x0 = c(0, 0), id = "A1", R=57.5,r=0.6,

     burst = id, typeII = TRUE)
  {
     if (typeII)
         class(date) <- c("POSIX", "POSIXct")
     n <- length(date)
     dt <- c(diff(unclass(date)))
     if (all(dt - dt[1] > 1e-07))
         stop("the time lag between relocations should be constant")
    ang<-rwrpnorm(n-2,0,r)
    ang=cumsum(c(runif(1,0,2*pi),ang))
     v = dt * (l0 * (runif(n - 1)^(1/(1 - mu))))

 #    newcode
     x=c(1:n)
     y=x
     x[1]= x0[1]
     y[1] =x0[2]
     for (i in c(2: n)){
         x[i]= x[i-1]+v[i-1]*cos(ang[i-1])
     		y[i]= y[i-1]+v[i-1]*sin(ang[i-1])
     		RR=(x[i]^2+y[i]^2)
     		if ((RR> R^2) && (i< (n-1)) ){

     			x[i]= R*x[i]/sqrt(RR)
     			y[i]= R*y[i]/sqrt(RR)
     			ang2<-rwrpnorm(n-2-i,0,r)
           ang2=cumsum(c(runif(1,0,2*pi),ang2))
     			j=c(1:(n-i-1))
     			ang[i+j]=ang2[j]

     			}
     		}
     res <- as.ltraj(data.frame(co, si), date, id, burst, typeII = typeII)
     return(res)
  }

  "simm.crw2pauses" <- function(date=1:100, h = 1, r = 0, R=57.5,
                          x0=c(0,0), id="A1", burst=id,
                          typeII=TRUE,act =0.5)
   {
       if (!require(CircStats))
           stop("package CircStats required")
       if (typeII)
           class(date) <- c("POSIX","POSIXct")
       n <- length(date)
       dt <- c(diff(unclass(date)))
       if (all(dt-dt[1]>1e-7))
           stop("the time lag between relocations should be constant")
     #activity of probability 1-ttt
   t= runif(n - 1,0,1)
   t
   t=ifelse(t>act,1,0)
   t

           if (h>0) {
              v=sqrt(dt)*rchi(n-1) * h*t
            } else {
              v=dt/dt*(-h)*t

            }
  		ang<-rwrpnorm(n-2,0,r)
           ang=cumsum(c(runif(1,0,2*pi),ang))
  x=c(1:n)
  y=x
  x[1]= x0[1]
  y[1] =x0[2]
  for (i in c(2: n)){
  		x[i]= x[i-1]+v[i-1]*cos(ang[i-1])
  		y[i]= y[i-1]+v[i-1]*sin(ang[i-1])
  		RR=(x[i]^2+y[i]^2)
  		if ((RR> R^2) && (i< (n-1)) ){

  			x[i]= R*x[i]/sqrt(RR)
  			y[i]= R*y[i]/sqrt(RR)
  			ang2<-rwrpnorm(n-2-i,0,r)
  			ang2=cumsum(c(runif(1,0,2*pi),ang2))
  			j=c(1:(n-i-1))
  			ang[i+j]=ang2[j]

  			}
  		}

      res <- as.ltraj(data.frame(x,y),date, id, burst,
                       typeII=typeII)
       return(res)
   }

   simm.levycorrpauses <- function (date = 1:500, mu = 2, l0 = 1, x0 = c(0, 0), id = "A1", R=57.5,r=0.6,act=0.5,

      burst = id, typeII = TRUE)
   {
      if (typeII)
          class(date) <- c("POSIX", "POSIXct")
      n <- length(date)
      dt <- c(diff(unclass(date)))
      if (all(dt - dt[1] > 1e-07))
          stop("the time lag between relocations should be constant")
     ang<-rwrpnorm(n-2,0,r)
     ang=cumsum(c(runif(1,0,2*pi),ang))
     #activity of probability 1-ttt
     t= runif(n - 1,0,1)
     t
     t=ifelse(t>act,1,0)
     t
      v = t*dt * (l0 * (runif(n - 1)^(1/(1 - mu))))

  #    newcode
      x=c(1:n)
      y=x
      x[1]= x0[1]
      y[1] =x0[2]
      for (i in c(2: n)){
          x[i]= x[i-1]+v[i-1]*cos(ang[i-1])
        	y[i]= y[i-1]+v[i-1]*sin(ang[i-1])
      		RR=(x[i]^2+y[i]^2)
      		if ((RR> R^2) && (i< (n-1)) ){

      			x[i]= R*x[i]/sqrt(RR)
      			y[i]= R*y[i]/sqrt(RR)
      			ang2<-rwrpnorm(n-2-i,0,r)
            ang2=cumsum(c(runif(1,0,2*pi),ang2))
      			j=c(1:(n-i-1))
      			ang[i+j]=ang2[j]

      			}
      		}
      res <- as.ltraj(data.frame(x, y), date, id, burst, typeII = typeII)
      return(res)
   }

#############
############
#########
# i=1
# rrr=0.9
# ttt=0.4
# u <- simm.crw2pauses(1:9000, r = rrr, h=0.75, act=ttt,burst =paste(rrr,ttt,i))
# trajdyn(u)
# plut (sliwinltr(u)
###########
###########
###########
# setwd("d:/dokumente/My Dropbox/buridan/buridan_v2.3/simulated_data/simulated_all")
#
# for (rrr in c(0.8,0.6)) {
# group =ifelse(rrr==0.8,"corrw_r0.8","corrw_r0.6")
#   for (hhh in c(0.75,1)) {
#   group2 =ifelse(hhh==0.75,"_h0.75","_h1")
#     for (i in 0:9){
#       set.seed(872+i)
#
#       u <- simm.crw2(1:9000, r = rrr, h=hhh, burst =paste(rrr,hhh,i))
#
#
#       data=data.frame(c(1:9000),100*c(1:9000),u[[1]]$x,u[[1]]$y,0)
#       names(data)=c("frame","time","x","y", "burst")
#
#       write.table(data,file=paste(group,group2,"_",i,".txt",sep="",collapse = NULL),append = FALSE,sep = "\t", quote= FALSE, row.names= FALSE
#       )
#     }
#   }
# }
#
# for rrr in c(0,0.8)) {
# group =ifelse(rrr==0.8,"levycorrelated08","uncorrelated")
#
#  #for (hhh in c(0.75,1)) {
#  # group2 =ifelse(hhh==0.75,"_h0.75","_h1")
#     for (i in 0:9){
#       set.seed(872+i)
#
#       u <- simm.levycorr(1:9000, r = rrr, mu=3,l0 = 1, burst =paste(rrr,i))
#
#
#       data=data.frame(c(1:9000),100*c(1:9000),u[[1]]$x,u[[1]]$y,0)
#       names(data)=c("frame","time","x","y", "burst")
#
#       write.table(data,file=paste(group,group2,"_",i,".txt",sep="",collapse = NULL),append = FALSE,sep = "\t", quote= FALSE, row.names= FALSE
#       )
#    # }
#   }
# }
# ######with activity
#
# setwd("D:/dokumente/data/buridan/simulated_data/new")
# for (rrr in c(0.985,0.983)) {
# group =ifelse(rrr==0.985,"A","B")
#
#  for (ttt in c(0.4,0.3)) {
#  group2 =ifelse(ttt==0.3,"C","D")
#     for (i in 0:19){
#       set.seed(899+i)
#
#       u <- simm.levycorrpauses(1:9000, r = rrr, mu=3,l0 = 1, burst =paste(rrr,i), act=ttt)
#
#
#       data=data.frame(c(1:9000),100*c(1:9000),u[[1]]$x,u[[1]]$y,0)
#       names(data)=c("frame","time","x","y", "burst")
#
#       write.table(data,file=paste(group,group2,"_",i,".txt",sep="",collapse = NULL),append = FALSE,sep = "\t", quote= FALSE, row.names= FALSE
#       )
#    }
#   }
# }
#
# for (rrr in c(0.95,0.9)) {
# group =ifelse(rrr==0.9,"corrw_r0.8","corrw_r0.6")
#   for (ttt in c(0.66,0.8)) {
#   group2 =ifelse(ttt==0.8,"_h0.75","_h1")
#     for (i in 0:9){
#       set.seed(872+i)
#
#       u <- simm.crw2pauses(1:9000, r = rrr, h=0.75, act=ttt,burst =paste(rrr,ttt,i))
#
#
#       data=data.frame(c(1:9000),100*c(1:9000),u[[1]]$x,u[[1]]$y,0)
#       names(data)=c("frame","time","x","y", "burst")
#
#       write.table(data,file=paste(group,group2,"_",i,".txt",sep="",collapse = NULL),append = FALSE,sep = "\t", quote= FALSE, row.names= FALSE
#       )
#     }
#   }
# }

# traj=data
# newtraj= mindistkeep3(traj,0.6,35)
# traj=new_traj
# #####get env ???
# i=c(1:length(traj))
# env$ = env[1]
#
# g_outputdir= "D:/dokumente/data"
# rgghome="D:/dokumente/My Dropbox/buridan/buridan_v2.2/analysis"
# ###
#
# bla = paste(c(outputfile,"t",g_treshold,"Pt",g_duration_slider,".pdf"),collapse="")
# pdf(bla)
# setwd(rgghome)
# source ("scripts/general.r")
# source ("scripts/straightness.r")
# source ("scripts/occupancy.r")
# source ("scripts/thigmotaxis.r")
# source ("scripts/angledev.r")
# source ("scripts/activity_martin.r")
# g = dev.off()
# source ("scripts/saveworkspace2.r")
#
#

setwd("D:/dokumente/data/buridan/simulated_data/totestagainstcs_rrr=0.985_ttt=0.3")
#########
########## make 20 correlated walks

K=1.5*c(-4:4,-1:1,-3:3,0)
K[1]=2.5
K[2]=-0.5
K[13]=1
J= sample(K,20)
L= sample(K,20)
#for (rrr in c(0.9963)) {  #levy
for (rrr in c(0.9965)) {  #corrwalk
group ="A"

 for (ttt in c(0.85)) { #corr
  # for (ttt in c(0.875)) {  #levy
 group2 ="C"
    for (i in 0:19){
      set.seed(920+i)
      k= 0.7+ K[i+1]/10

#       u <- simm.levycorrpauses(1:9000, r = rrr, mu=3,l0 = 1, burst =paste(rrr,i), act=ttt)
#       u[[1]]$dist[u[[1]]$dist == 0]=NA
#       median(u[[1]]$dist, na.rm=TRUE)
    # u <- simm.levycorrpauses(1:9000, r = rrr+ J[i+1]/1000000, mu=2.6,l0 = 0.8+ K[i+1]/10, burst =paste(rrr,i), act=ttt)
     u <- simm.crw2pauses(1:9000, r = rrr, h=k, act=ttt,burst =paste(rrr,ttt,i))
      #print(median(u[[1]]$dist, na.rm=TRUE))

      data=data.frame(c(1:9000),100*c(1:9000),u[[1]]$x,u[[1]]$y,0)
      names(data)=c("frame","time","x","y", "burst")

      write.table(data,file=paste(group,group2,"_",i,".txt",sep="",collapse = NULL),append = FALSE,sep = "\t", quote= FALSE, row.names= FALSE
      )
   }
  }
}
#########
########## make 20 levy walks

K=1.5*c(-4:4,-1:1,-3:3,0)
K[1]=2.5
K[2]=-0.5
K[13]=1
J= sample(K,20)
L= sample(K,20)
for (rrr in c(0.9963)) {  #levy
#for (rrr in c(0.9965)) {  #corrwalk
group ="B"

 #for (ttt in c(0.85)) { #corr
   for (ttt in c(0.875)) {  #levy
 group2 ="D"
    for (i in 0:19){
      set.seed(920+i)
      k= 0.7+ K[i+1]/10

#       u <- simm.levycorrpauses(1:9000, r = rrr, mu=3,l0 = 1, burst =paste(rrr,i), act=ttt)
#       u[[1]]$dist[u[[1]]$dist == 0]=NA
#       median(u[[1]]$dist, na.rm=TRUE)
     u <- simm.levycorrpauses(1:9000, r = rrr+ J[i+1]/1000000, mu=2.6,l0 = 0.8+ K[i+1]/10, burst =paste(rrr,i), act=ttt)
    # u <- simm.crw2pauses(1:9000, r = rrr, h=k, act=ttt,burst =paste(rrr,ttt,i))
      #print(median(u[[1]]$dist, na.rm=TRUE))

      data=data.frame(c(1:9000),100*c(1:9000),u[[1]]$x,u[[1]]$y,0)
      names(data)=c("frame","time","x","y", "burst")

      write.table(data,file=paste(group,group2,"_",i,".txt",sep="",collapse = NULL),append = FALSE,sep = "\t", quote= FALSE, row.names= FALSE
      )
   }
  }
}

##### other tests

ttt= 0.88

rrr=0.9962
u <- simm.crw2pauses(1:9000, r = rrr, h=0.6, act=ttt,burst =paste(rrr,ttt,i))
v <- simm.levycorrpauses(1:9000, r = rrr, mu=2.6,l0 = 1, burst =paste(rrr,i), act=0.85)
new_traj <- v
    new_traj2 <- mindistkeep3(new_traj, thresholdmin = g_treshold/10,
        thresholdmax = 35)
u= new_traj2
v= new_traj2
median (abs(u[[1]]$rel.angle), na.rm=TRUE)/pi*180
X=c.activity(u,min_pause_length = 10)
Y=c.activity(v,min_pause_length = 10)
#head(X)
sum(X$act[X$act>0])
sum(Y$act[Y$act>0])
speeds = c.speeds(u)$speed_det
speeds2 = c.speeds(v)$speed_det
speeds = speeds[speeds>0]
speeds2 = speeds2[speeds2>0]
B= c(0:12, 2000)
B=B/2
B
hist(speeds, main="correlated", xlim=c(0,5), breaks = B)
hist(speeds2, main="levy", xlim=c(0,5), breaks = B)
length(speeds[speeds>0])
length(speeds2[speeds2>0])

speeds = speeds[speeds>0]
  speeds = speeds[!speeds>50]

median(speeds, na.rm=TRUE)


#' Compute transitions of a given order
#'
#' @param seq  a vector containing observations from an stochastic process.
#' @param order the order of the transitions to be computed (an integer).
#'
#' @return an array with the transitions in the format n_{ijk}, where i, j, k are in states(seq).
#' @export get_contingency_array
#'
#' @examples
#' X <- rbinom(n = 1E5, size = 1, prob = 0.8)
#' get_contingency_array(X, order = 3)
get_contingency_array <- function(seq, order){
  ## Many thanks to https://stackoverflow.com/users/3358272/r2evans
  ## https://stackoverflow.com/questions/67004206/speeding-up-r-code-to-compute-higher-order-transitions-in-a-markov-chain
  N <- length(seq)
  states <- sort(unique(seq))
  nstates <- length(states)
  inds <- seq_along(states)
  K <- order + 1
  out <- array(0, dim = rep(nstates, K))
  for (z in K:N){
    pos <- matrix(match(seq[(z - K + 1):z], states), nrow = 1)
    out[pos] <- out[pos] + 1
  }
  return(out)
}
#' Compute the likelihood ratio statistic comparing a second-order to a first-order Markov chain model for \code{seq}
#'
#' @param seq a vector containing observations from an stochastic process.
#'
#' @return the likelihood ratio statistic (G^2) comparing a second-order model to a first-order one.
#' @export compute_Gsquared
#' @details  Under the null, G^2 has a chi-square(2) distribution.
#' @examples
#' X <- rbinom(n = 1E5, size = 1, prob = 0.8)
#' compute_Gsquared(X)
compute_Gsquared <- function(seq){
  states <- sort(unique(seq))
  nstates <- length(states)
  dt <-  get_contingency_array(seq, 2)
  stats <- c()
  for(k in 1:nstates){
    for( i in 1:nstates){
      for(j in 1:nstates){
        nijk <-  dt[i , j, k] + 1E-17
        nijp <- sum(dt[i, j, ]) + 1E-17
        npjk <- sum(dt[, j, k]) + 1E-17
        npjp <- sum(dt[, j, ]) + 1E-17
        s <- nijk * log((nijk/nijp)/(npjk/npjp))
        stats <- c(stats, s)
      }
    }
  }
  out <- 2*sum(stats)
  return(out)
}
#' Compute the Bayes factor comparing a second-order Markov model to a first-order one.
#'
#' @param seq a vector containing observations from an stochastic process.
#'
#' @return the approximate Bayes factor comparing a second- to a first-order Markov chain model for \code{seq}.
#' @export compute_BF
#'
#' @examples
#' X <- rbinom(n = 1E5, size = 1, prob = 0.8)
#' compute_BF(X)
compute_BF <- function(seq){
  n <- length(seq)
  m <- length(unique(seq))
  Gsq <- compute_Gsquared(seq)
  BF <- (Gsq - 2*log(n))/2
  return(BF)
}
#' Thin a sample until the first-order Markov model is preferred.
#'
#' @param seq a vector containing observations from an stochastic process.
#' @param max_k maximum thinning to be tried.
#'
#' @return a list containing the selected \code{k}, the achieved Bayes factor (\code{BF})
#'  and whether one could indeed find a \code{k} less than \code{max_k}
#'   such that the first-order model is preferred.
#' @export find_k
#' @details This is the same approach as Raftery & Lewis (1992) "How many iterations in the Gibbs sampler?"
#' @examples
#' library(markovchain)
#' M <- 1E4
#' p <-  runif(1)
#' ( maxA <- min(p/(1-p), 1) ) ## maximum alpha
#' a <- runif(1, 0, maxA)
#' b <- exp(log(a)  + log(1-p) - log(p))
#' mat <- matrix(c(1-a, a, b, 1-b), ncol = 2, nrow = 2, byrow = TRUE)
#' MC.binary <- new("markovchain",
#'  states = c("0", "1"),
#'   transitionMatrix = mat, name = "Binary")
#' out1 <- markovchainSequence(n = M, markovchain = MC.binary, t0 = "0")
#' X1 <- as.numeric(out1)
#'
#' rs <- runif(4^2)
#' mat2 <- structure(c(0.264985809735216, 0.598430024309721, 0.140708602965477,
#' 0.0566167324620894, 0.278728488803952, 0.0427599923571986, 0.453529988769559,
#' 0.604004074666218, 0.116827824413052, 0.0358869202453851, 0.181735130309576,
#' 0.266807259734723, 0.33945787704778, 0.322923063087696, 0.224026277955388,
#' 0.0725719331369693), .Dim = c(4L, 4L))
#'  MC.binary2nd <- new("markovchain",
#'   states = c("00", "01", "10", "11"),
#'    transitionMatrix = mat2, name = "Binary2nd")
#' out2 <- markovchainSequence(n = M/2, markovchain = MC.binary2nd, t0 = "01")
#' X2 <- as.numeric(strsplit(paste(out2, collapse = ""), "")[[1]])
#' find_k(X1)
#' find_k(X2)
find_k <- function(seq, max_k = 10){
  k <- 1
  BF <- compute_BF(seq)
  while(BF > 0){
    k <- k + 1
    inds <- seq.int(1L, length(seq), k)
    BF <- compute_BF(seq = seq[inds])
    if(k >= max_k) break
  }
  return(
    list(
      k = k,
      BF = BF,
      success = (BF < 0)
    )
  )
}


euclidean <- function(a, b) {
  return (sqrt(sum((a - b) ^ 2)))
}

fast_cvloo_knn <- function(dset) {
  maxK <- length(dset[,1]) - 1
  classes = unique(dset$class)

  ans <- rep(x = 0, times = maxK)
  for (i in 1:length(dset[,1])) {
    # for (i in 1:10) {
    cat("\r", "Processing sample ", i, " of ", length(dset[,1]))
    dataset <- dset[-i,]
    # print(dataset)
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 1:2], dset[i, 1:2])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- rep(x = 0, times = length(classes))
    names(classesCount) = classes
    for (j in 1:maxK) {
      classesCount[sortedDataset$class[j]] <- classesCount[sortedDataset$class[j]] + 1

      classForCurrentK = names(which.max(classesCount))[1]
      if (classForCurrentK == dset$class[i]) {
        ans[j] = ans[j] + 1
      }
    }

  }
  cat("\n")
  for (i in 1:length(ans)) {

    ans[i] = ans[i] / length(dset[,1] - 1)
  }

  return (ans)
}

kNN <- function(dataset, points, k, dist = euclidean) {
  answer <- array(dim=c(length(points[,1])))

  for (i in 1:length(points[,1])) {
    distance <- array(dim=dim(dataset)[1])
    for (j in 1:dim(dataset)[1]) {
      distance[j] <- dist(dataset[j, 1:2], points[i,])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- c(0, 0, 0)
    names(classesCount) = unique(dataset$class)
    for (j in 1:k) {
      classesCount[sortedDataset$class[j]] <- classesCount[sortedDataset$class[j]] + 1
    }
    answer[i] = names(which.max(classesCount))[1]
  }

  return (answer)
}

df = data.frame(x = double(), y = double(), class = character())

df <- rbind(df, data.frame(x = 122, y = 2208, class = "class-1"))
df <- rbind(df, data.frame(x = 148, y = 1136, class = "class-2"))
df <- rbind(df, data.frame(x = 270, y = 2186, class = "class-1"))
df <- rbind(df, data.frame(x = 271, y = 2016, class = "class-1"))
df <- rbind(df, data.frame(x = 306, y = 1023, class = "class-2"))
df <- rbind(df, data.frame(x = 413, y = 1153, class = "class-2"))
df <- rbind(df, data.frame(x = 503, y = 2013, class = "class-1"))
df <- rbind(df, data.frame(x = 541, y = 971, class = "class-2"))
df <- rbind(df, data.frame(x = 706, y = 1018, class = "class-2"))
df <- rbind(df, data.frame(x = 837, y = 867, class = "class-2"))
df <- rbind(df, data.frame(x = 875, y = 1011, class = "class-2"))
df <- rbind(df, data.frame(x = 927, y = 1915, class = "class-1"))
df <- rbind(df, data.frame(x = 997, y = 897, class = "class-2"))
df <- rbind(df, data.frame(x = 1005, y = 529, class = "class-2"))
df <- rbind(df, data.frame(x = 1028, y = 1176, class = "class-2"))
df <- rbind(df, data.frame(x = 1050, y = 1429, class = "class-1"))
df <- rbind(df, data.frame(x = 1125, y = 781, class = "class-2"))
df <- rbind(df, data.frame(x = 1144, y = 1061, class = "class-2"))
df <- rbind(df, data.frame(x = 1146, y = 1751, class = "class-1"))
df <- rbind(df, data.frame(x = 1192, y = 1601, class = "class-1"))
df <- rbind(df, data.frame(x = 1264, y = 888, class = "class-2"))
df <- rbind(df, data.frame(x = 1275, y = 1412, class = "class-1"))
df <- rbind(df, data.frame(x = 1329, y = 576, class = "class-2"))
df <- rbind(df, data.frame(x = 1366, y = 1586, class = "class-1"))
df <- rbind(df, data.frame(x = 1405, y = 386, class = "class-2"))
df <- rbind(df, data.frame(x = 1432, y = 1226, class = "class-1"))
df <- rbind(df, data.frame(x = 1597, y = 279, class = "class-2"))
df <- rbind(df, data.frame(x = 1615, y = 1604, class = "class-1"))
df <- rbind(df, data.frame(x = 1631, y = 1200, class = "class-1"))
df <- rbind(df, data.frame(x = 1638, y = 1365, class = "class-1"))
df <- rbind(df, data.frame(x = 1765, y = 1262, class = "class-1"))
df <- rbind(df, data.frame(x = 1806, y = 1444, class = "class-1"))
df <- rbind(df, data.frame(x = 1821, y = 1056, class = "class-1"))
df <- rbind(df, data.frame(x = 1896, y = 877, class = "class-1"))
df <- rbind(df, data.frame(x = 1993, y = 695, class = "class-1"))
df <- rbind(df, data.frame(x = 2027, y = 1415, class = "class-1"))
df <- rbind(df, data.frame(x = 2087, y = 889, class = "class-1"))
df <- rbind(df, data.frame(x = 2189, y = 674, class = "class-1"))

z = array(c(c(1164, 1232)), dim = c(1,2))

par(mfrow=c(1,2), pty="s")
# LOO CV, looking for the best k
stats <- fast_cvloo_knn(df)
plot(1:(length(df[,1]) - 1), stats, type="l", xlab="k", ylab="Accuracy")

maxPoint = which(stats == max(stats))
points((1:(length(df[,1]) - 1))[maxPoint], stats[maxPoint], pch = 19, col = "red")

bestK <- which.max(stats)
cat("Best K =", bestK, "\n")

colors <- c("class-1" = "blue", "class-2" = "red")
plot(df[, 1:2], bg = colors[paste(df$class)], pch=23, asp=1)

result <- kNN(df, z, 5)
points(z[,1], z[,2], bg = colors[result], pch = 22)

1 - Nearest neighbors algorithm/knn-loocv-img-exp.r


## minimum cost network flow model for phase unwrapping

#' @describeIn brcutpuw Network flow algorithm for phase unwrapping
netflowpuw <- function(phase, wts=NULL, details=FALSE, trace=1) {
  nr <- nrow(phase)
  nc <- ncol(phase)
  dx <- zernike::wrap(diff(phase))
  dy <- zernike::wrap(t(diff(t(phase))))
  d2x <- dx[,2:nc] - dx[,1:(nc-1)]
  d2y <- dy[1:(nr-1),] - dy[2:nr,]
  ndx <- sum(!is.na(dx))
  ndy <- sum(!is.na(dy))
  charge <- -round((d2y+d2x)/(2*pi))

  if (sum(abs(charge), na.rm=TRUE) == 0) {
    cat("Phase map is trivial to unwrap, so calling idiffpuw\n")
    return(zernike::idiffpuw(phase, ucall=TRUE))
  }

  ## these weights are too simple, but this seems to work
  ## better than combining weights from each pixel that
  ## went into a given difference.

  if (!is.null(wts)) {
    wts <- wts/max(wts,na.rm=TRUE)
    wx <- wts[-1,]
    wy <- wts[,-1]
    wx <- wx[!is.na(dx)]
    wy <- wy[!is.na(dy)]
    obj <- c(wx, wx, wy, wy)
  } else {
    obj <- rep(1, 2*(ndx+ndy))
  }
  ## the optimal solution will cancel the map's charges

  kx <- dx
  kx[!is.na(kx)] <- 1:ndx
  ky <- dy
  ky[!is.na(ky)] <- 1:ndy

  ## these are the 1d indexes of the pixels that go into each 2 x 2 loop

  k2x1 <- kx[,1:(nc-1)][!is.na(charge)]
  k2x2 <- kx[,2:nc][!is.na(charge)]
  k2y1 <- ky[1:(nr-1),][!is.na(charge)]
  charge <- charge[!is.na(charge)]
  rm(d2x,d2y,kx,ky)

  nrow <- length(charge)
  ncol <- 2*(ndx+ndy)
  row <- c(-1., 1., 1., -1., 1., -1., -1., 1.)
  xvals <- rep(row, nrow)
  i_ind <- rep(1:nrow, each=8)
  j_ind <- as.numeric(rbind(k2x1, k2x2,
                            k2x1+ndx, k2x2+ndx,
                            k2y1+2*ndx, k2y1+2*ndx+1,
                            k2y1+2*ndx+ndy, k2y1+2*ndx+ndy+1)
              )
  if (packageVersion("Matrix") >= "1.3.0") {
    mat <- Matrix::sparseMatrix(i=i_ind, j=j_ind, x=xvals, dims=c(nrow, ncol), repr="T")
  } else {
    mat <- Matrix::sparseMatrix(i=i_ind, j=j_ind, x=xvals, dims=c(nrow, ncol), giveCsparse=FALSE)
  }

  lpout <- rcbc::cbc_solve(obj=obj, mat=mat,
                           row_ub=charge,
                           row_lb=charge,
                           col_lb=rep(0, ncol),
                           col_ub=rep(1, ncol),
                           cbc_args = list(log=trace, verbose=trace)
                 )
  if (rcbc::solution_status(lpout) != "optimal") {
    warning("non-convergence detected")
    return(lpout)
  }

  dx <- rbind(dx, rep(NA, nc))
  dy <- cbind(dy, rep(NA, nr))
  soln <- lpout$column_solution
  ex <- soln[1:ndx]-soln[(ndx+1):(2*ndx)]
  ey <- soln[(2*ndx+1):(2*ndx+ndy)]-soln[(2*ndx+ndy+1):(2*ndx+2*ndy)]
  ex.m <- dx
  ey.m <- dy
  ex.m[!is.na(dx)] <- ex
  ey.m[!is.na(dy)] <- ey
  puw <- zernike::idiffpuw(phase=phase, dx=dx+2*pi*ex.m, dy=dy+2*pi*ey.m)
  if (details) {
    ex.m[ex.m==0] <- NA
    ey.m[ey.m==0] <- NA
    list(puw=puw, ex=ex.m, ey=ey.m, lpout=lpout)
  } else {
    puw
  }

}


library(signal)

a0 <- 0.35875
a1 <- 0.48829
a2 <- 0.14128
a3 <- 0.01168
x <- seq(0.0, 1.0, by=1/40)
h <- a0 - a1 * cos(2 * pi * x) + a2 * cos(4 * pi * x) - a3 * cos(6 * pi * x)
h <- B/sum(B)

# Print filter coefficients
paste(sprintf("%.10e", h), collapse=", ")

fh <- freqz(h)

op <- par(mfrow = c(1, 2))

plot(fh$f / pi, abs(fh$h), type = "l", ylab = "magnitude", xlab = "Frequency", xlim = c(0, 0.2))

plot(fh$f / pi, 20*log10(abs(fh$h)+1e-5), type = "l", ylab = "dB", xlab = "Frequency", xlim = c(0, 0.2))

par(op)


a <- as.hexmode(35)
b <- as.hexmode(42)
as.integer(a & b)      # 34
as.integer(a | b)      # 43
as.integer(xor(a, b))  # 9


install.packages('data.table')
install.packages('MASS')
install.packages('VGAM')
install.packages("ggplot2")
install.packages("ggrepel")
install.packages('ggpubr')
install.packages('ggExtra')
install.packages('stargazer')
install.packages('corrplot')
install.packages('olsrr')
install.packages('eply')

library(data.table)
library(MASS)
library(car)
library(ggplot2)
library(ggrepel)
library(ggpubr)
library(ggExtra)
library(stargazer)
library(nlme)
library(corrplot)
library(Matrix)
library(olsrr)
library(eply)
setwd("C:/Users/Han/Desktop/Box Sync/Stat 501/Final Project")

dt_1 = fread('final project dataset 1.txt')
dt_2 = fread('final project dataset 2.txt')

dt = merge(dt_1,dt_2,by = 'State')

#[1] 0
## No NA value

#### 1.	Find an appropriate linear regression model with M as the dependent variables.
#### Among the independent variables include MA, D, PL, S, B, HT, UR, CR, HS, INC, PL, VT, and UR.
#### Add and subtract variables as you think fit.
#### Notice that you may need to detect influential points, multicollineaity, also do necessary transformation if needed.

dt1 = dt[,c('State','M','MA','D','PL','S','B','HT','UR','CR','HS','INC','VT')]
dt1[,2:13] = dt1[,2:13][,lapply(.SD,as.numeric)]
# standardize all X
dt1[,3:13] = dt1[,3:13][,lapply(.SD,scale)]

# orignal EDA
temp <- ggplot(dt1, aes(x=MA, y=M)) + geom_point() + theme_classic() + geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x11 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=D, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x12 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=PL, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x13 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=S, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x14 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=B, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x15 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=HT, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x16 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=UR, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x17 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=CR, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x18 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=HS, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x19 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=INC, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x110 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1, aes(x=VT, y=M)) + geom_point() + theme_classic()+ geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
x111 = ggMarginal(temp,type = 'histogram', fill = "cyan")
temp <- ggplot(dt1[-33,], aes(x=MA, y=M)) + geom_point() + theme_classic() + geom_smooth(method = 'lm')+ theme(text = element_text(size=18, face = 'bold'))+
        labs(x = 'influential pt temporarily removed MA')
x112 = ggMarginal(temp,type = 'histogram', fill = "cyan")
ggarrange(x11,x112,x12,x13,x14,x15,x16,x17,x18,x19,x110,x111,ncol = 4,nrow = 3)

tr <- function (m)
{
   total_sum <- 0
   if(is.matrix(m))
   {
      row_count <- nrow(m)
      col_count <- ncol(m)
      if(row_count == col_count)
      {
         total_sum <-sum(diag(m))
         total_sum
      }
      else
      {
         message ('Matrix is not square')
      }
   }
   else
   {
      message( 'Object is not a matrix')

   }
}
Near.Neighbor.Approach = function(x){
   x = as.data.frame(x)
   rns = x[,1]
   x = x[,-1]
   rownames(x) = rns
   x = as.matrix(x)

   n = nrow(x) ; k = ncol(x)
   y = x[,1]
   z = matrix(1,n,1)
   x[,1] = z

   prx = diag(n) - x %*% ginv(t(x)%*%x) %*% t(x)
   E = prx %*% y
   V = matrix(0,n,n)
   for (i in 1:(n-1)){
      for (j in (i+1):n){
         d = t(x[i,]-x[j,]) %*% (x[i,]-x[j,])
         if (d > 0) {
            V[i,j] = -2/d
            V[j,i] = -2/d
         }
      }
   }

   for (i in 1:n){
      V[i,i] = - sum(V[i,])
   }

   B = prx %*% V %*% prx

   NUM = t(E) %*% V %*% E
   DEN = t(E) %*% E/(n-k)
   STAT = NUM/DEN
   MEAN = tr(B)
   VAR = 2*((n-k)*tr(B %*% B)-(tr(B))^2)/(n-1)
   STAT = (STAT -MEAN)/sqrt(VAR)
   STAT = as.numeric(STAT)
   return(STAT)
}

t.1 = Near.Neighbor.Approach(dt1)
n = 50; k = 11
p_value = 2* pt(t.1,n-k+2)

# temporaliy elimate outliers/influential points
# temporaliy do proper transfer on X

# Variable selection

model1 = lm(M ~., data = dt1[,2:13])
k1 = ols_best_subset(model1)
plot(k1)
k1
plot(ols_stepaic_both(model1))

ols_stepwise(model1)
# choose the 9th model based on adj r^2, C(p) and AIC
dt1.a = dt1[,-c(1,6,8)]
# multicollinearity
model1.a = lm(M ~., data = dt1.a)
ols_coll_diag(model1.a)
X.corr.a = cor(dt1.a[,2:10])
corrplot(X.corr.a,method = 'circle',addCoef.col  = 'black')
# lets see if we further delete HS from dt1, how things will chagne
dt1.b = dt1[,-c(1,6,8,11)]
# multicollinearity
model1.b = lm(M ~., data = dt1.b)
ols_coll_diag(model1.b)
X.corr.b = cor(dt1.b[,2:9])
corrplot(X.corr.b,method = 'circle',addCoef.col  = 'black')
# lets see if we further delete HS from dt1, how things will chagne
dt1.c = dt1[,-c(1,3,6,7,8,10)]
# multicollinearity
model1.c = lm(M ~., data = dt1.c)
ols_coll_diag(model1.c)
X.corr.c = cor(dt1.c[,2:7])
corrplot(X.corr.c,method = 'circle',addCoef.col  = 'black')
# lets see if we further delete HS from dt1, how things will chagne
dt1.d = dt1[,-c(1,4,6,8,9)]
# multicollinearity
model1.d = lm(M ~., data = dt1.d)
ols_coll_diag(model1.d)
X.corr.d = cor(dt1.d[,2:7])
corrplot(X.corr.d,method = 'circle',addCoef.col  = 'black')

# regression and residual and influence diagonostic

summary(model1.a)
summary(model1.b)
summary(model1.c)
summary(model1.d)

ols_correlations(model.a)
ols_ovsp_plot(model.a)
http://www.rsquaredacademy.com/olsrr/articles/influence_measures.html
ols_diagnostic_panel(model.a)
ols_norm_test(model.a)
ols_corr_test(model.a)
ols_dfbetas_panel(model.a)
## Run LASSO
# provide an arithmetic series
l1 = seq(from =-7, to =7, by = .001)
# conver to geometric series to use as user provided lambda
l2 = exp(-l1)
set.seed(42)

fit.lasso.cv = cv.glmnet(x = as.matrix(dt1[,2:12]), y =as.matrix(dt1[,1]),type.measure = 'mse', alpha = 1, family = 'gaussian', nfolds=5,  lambda = l2)
fit.ridge.cv = cv.glmnet(x = as.matrix(dt1[,2:12]), y =as.matrix(dt1[,1]),type.measure = 'mse', alpha = 0, family = 'gaussian', nfolds=5,  lambda = l2)
par(mfrow=c(1,3))
plot(fit.lasso.cv)
plot(fit.lasso.cv$glmnet.fit, "norm",   label=TRUE)
plot(fit.lasso.cv$glmnet.fit, "lambda", label=TRUE)
par(mfrow=c(1,1))
plot(fit.ridge.cv)
fit.lasso.cv$lambda.1se

#
dt2 = cbind(dt[,15],dt[,-15])
dt2 = dt2[,c(2,1,3:27)]
dt2[,2:27] = dt2[,2:27][,lapply(.SD,as.numeric)]
# standardize all X
dt2[,3:27] = dt2[,3:27][,lapply(.SD,scale)]

t.2 = Near.Neighbor.Approach(dt2)
n = 50; k = 25
p_value = 2* pt(t.2,n-k+2)

dt2.a = dt2
dt2.a[,2] = 1/dt2.a[,2]

t.2.a = Near.Neighbor.Approach(dt2.a)
n = 50; k = 25
p_value.2a = 2* pt(t.2.a,n-k+2)
colnames(dt2.a)[2] = 'inv_MA'
model2.a = lm(inv_MA ~., data = dt2.a[,2:27])

dt2.b = dt2.a
dt2.b[,6:8] = dt2.b[,6:8][,lapply(.SD,rank)]
dt2.b[,6:8] = dt2.b[,6:8]/50
dt2.c = dt2.b[,c(1:8, 12,14:16, 19:20, 23, 26:27)]
model2.c = lm(inv_MA ~., data = dt2.c[,2:ncol(dt2.c)])

time = proc.time()
k2.c = ols_best_subset(model2.c)
proc.time() - time

ols_norm_test(model2.d)

g8 = list()
for (i in 3:ncol(dt2.a)){
  temp <- ggplot(dt2.a, aes_string(x=colnames(dt2.a)[i], y = colnames(dt2.a)[2])) + labs(y ='1/MA') +
    geom_point() + theme_classic() + geom_smooth(method = 'lm')+ theme(text = element_text(size=26, face = 'bold'))
  g8[[i-2]] <- ggMarginal(temp,type = 'histogram', fill = "cyan")
}
ggarrange(g8[[1]],g8[[2]],g8[[3]],g8[[4]],g8[[5]],g8[[6]],g8[[7]],
          g8[[8]],g8[[9]],g8[[10]],g8[[11]],g8[[12]],g8[[13]],g8[[14]],
          g8[[15]],g8[[16]],g8[[17]],g8[[18]],g8[[19]],g8[[20]],
          g8[[21]],g8[[22]],g8[[23]],g8[[24]],g8[[25]],ncol = 5,nrow = 5)

model2 = lm(MA ~., data = dt2[,2:27])
k2 = ols_best_subset(model2)
plot(k2)
k2
ols_stepaic_both(model2)
ols_stepwise(model2)

Near.Neighbor.Approach(dt2)

http://www.biostat.jhsph.edu/~iruczins/teaching/jf/ch10.pdf
https://stats.stackexchange.com/questions/61217/transforming-variables-for-multiple-regression-in-r
http://nymetro.chapter.informs.org/prac_cor_pubs/01-08%20INFORMS_Jan2008.pdf
http://www.stat.columbia.edu/~martin/W2024/R10.pdf
https://stats.stackexchange.com/questions/214682/stepwise-regression-in-r-how-does-it-work
http://www.columbia.edu/~so33/SusDev/Lecture_6.pdf

## directly do v selection based on R square


#Objetivo:  introducir concepto de curva ROC

#limpio la memoria
rm(list=ls())
gc()

library("data.table")

setwd("E:/UBA/2019-II/DM en Finanzas/Dropbox Prof/datasets")

#cargo los datos
dataset <- fread("201902.txt")

#creo una clase que se 1 cuando es BAJA+2   , y  0 en caso contrario
#esto me simplifica las cuentas
dataset[ , clase01:= as.numeric(clase_ternaria=="BAJA+2") ]

#calculos basicos
universo  <-  nrow(dataset )
pos_total <-  sum(dataset$clase01 )
neg_total <-  universo -  pos_total

#tambien podria hacer
neg_total <-  sum( 1 - dataset$clase01 )

#----------------

#Dibujo la curva ROC del predicado    mcuentas_saldo<= -120000

#positivos del predicado
pos_pred    <- sum(  dataset[ (mcuentas_saldo<= -120000) , clase01] )

#negativos del predicado
neg_pred    <- sum(  dataset[ (mcuentas_saldo<= -120000) , 1 - clase01] )

#Tener en cuenta que los NA's  no se estan contando en este predicado !

#la diagonal de la Curva Roc
azar_neg <- c( 0, neg_total )
azar_pos <- c( 0, pos_total )

#grafico
plot( azar_neg,
      azar_pos,
      type="n",
      main=paste( "ROC Curve", "(mcuentas_saldo<= -120000)" ),
      xlab="neg",
      ylab="pos",
      pch=19)

#dibujo la diagonal
lines( azar_neg, azar_pos,   type="l" , col="black", lwd=2)

#para el predicado creo el vector con los tres puntos
vneg <- c( 0, neg_pred,  neg_total )
vpos <- c( 0, pos_pred,  pos_total )

#dibujo la linea
lines( vneg, vpos,   type="l" , col="green", lwd=2)

#Calculo  AUC  Area Under Curve
triangulo_area <- pos_pred*neg_pred/2
trapecio_area  <- (pos_pred + pos_total)*(neg_total-neg_pred) / 2
AUC            <- (triangulo_area + trapecio_area ) / (pos_total*neg_total)

#----------------------
# Creo una funcion para automatizar

pred_graficar  = function(dataset, pcolumna, pvalor )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  pos_pred <- sum( dataset[ get(pcolumna) <= pvalor , clase01] )
  neg_pred <- sum( 1 - dataset[ get(pcolumna) <= pvalor, clase01] )

  AUC <- (pos_pred*neg_pred + (pos_pred + pos_total)*(neg_total-neg_pred) ) / (2*pos_total*neg_total)

  #la diagonal
  azar_neg <- c( 0, neg_total )
  azar_pos <- c( 0, pos_total )

  #grafico
  plot( azar_neg,
        azar_pos,
        type="n",
        main=paste( "ROC Curve", "(", pcolumna, "<=", pvalor, ")", "AUC=", AUC ),
        xlab="neg",
        ylab="pos",
        pch=19)

  #dibujo la linea del azar
  lines( azar_neg, azar_pos,   type="l" , col="black", lwd=2)

  #creo el vector con los tres puntos
  vneg <- c( 0, neg_pred,  neg_total )
  vpos <- c( 0, pos_pred,  pos_total )

  #dibujo la curva del predicado
  lines( vneg, vpos,   type="l" , col="green", lwd=2)

  return( AUC )
}
#----------------------

#algunos cortes de la variable  mcuentas_saldo
pred_graficar( dataset, "mcuentas_saldo", -120000 )
pred_graficar( dataset, "mcuentas_saldo", 0 )
pred_graficar( dataset, "mcuentas_saldo", 10000 )

#algunos cortes de la variable  Visa_mconsumototal
pred_graficar( dataset, "Visa_mconsumototal", 200000 )

#una variable que no esta correlacionada con la clase
pred_graficar( dataset, "cliente_edad", 40 )

#una vieja conocida variable
pred_graficar( dataset, "Visa_cuenta_estado", 10 )

#por que esta por debajo de la linea de azar ?


MaxHit=function(song){
# song is a vector of 0's and 1's that represents the hits (0) and
# misses (1) of the notes in order

  streak_lengths=diff(c(0,which(song==1),length(song)+1))-1
  max_streak=max(streak_lengths)

  # About these commands:
  # which(song==1) returns a vector indicating which on which notes (indices) a miss occurs
  #                this is important for you because it will indicate the end of a streak
  # c(0,which(song==1),length(song)+1) creates a vector starting with 0 (indicates the beginning of the song),
  #                 then the locations of misses, and then the length of the song + 1 (indicates when the song has ended)

  return(max_streak)
}

# Hypothesis test based on the MaxHit method
MaxHit_test = function(song,B=1000){
    # song is a vector of 0's and 1's that represents the hits (0)
	# and misses (1) of the notes in order
	# B is the number of new samples to generate

	test_stat = MaxHit(song)
	n = length(song)
	tstar_b = numeric(B)
	for(b in 1:B){
		song_tmp = sample(song)  # for permutation test
#		song_tmp = sample(song,replace=T) # for non-parametric bootstrap
#		song_tmp = rbinom(n,1,mean(song)) # for parametric bootstrap
		tstar_b[b] = MaxHit(song_tmp)
	}

	# calculate the two-sided p-value from the sampling distribution
	pval = 2*min(sum(tstar_b >= test_stat),sum(tstar_b <= test_stat))/B
		# calculate a one sided p-value
#	pval = sum(tstar_b >= test_stat)/B
	return(pval)
}

# Examples using Songs A and B from Table 1

songA = c(1,0,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0)
MaxHit(songA)
MaxHit_test(songA,5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
MaxHit(songB)
MaxHit_test(songB,5000)


=begin
  # sample-groebner02.rb

  require "algebra"

  P = MPolynomial(Rational)
  x, y, z = P.vars "xyz"
  f1 = x**2 + y**2 + z**2 -1
  f2 = x**2 + z**2 - y
  f3 = x - z

  coeff, basis = Groebner.basis_coeff([f1, f2, f3])
  basis.each_with_index do |b, i|
    p [coeff[i].inner_product([f1, f2, f3]), b]
    p coeff[i].inner_product([f1, f2, f3]) == b #=> true
  end
((<_|CONTENTS>))
=end


#' @name getpolar
#' @rdname getpolar
#' @title Calculates the angle of the link between two points to the x-Axis.
#' @description
#' This function calculates the angle of a vector defined by two points
#' in radians. Optionally it can be converted to degrees.
#' For the use of the Operations-Research-Sweep-Algorithm
#' an offset angle can be set.
#' It's als possible return positive values only (2pi will be added).
#' @param n0 an object of class \code{\link{numeric}} with a length of 2 (x/y-coordinates) or a class derived from \code{\link{Node}}. Used as origin.
#' @param n1 an object of class \code{\link{numeric}} with a length of 2 (x/y-coordinates) or a class derived from \code{\link{Node}}.
#' @param ... see \emph{Optional Values}
#' @section Optional Parameters (\code{...}):
#' \subsection{used by getpolar}{
#'    \describe{
#'		\item{\code{nonnegative}}{
#'			 \emph{optional} \code{\link{logical}}. Indicating if 2pi should be added to negative values. \strong{Default} is \code{TRUE}}
#'		\item{\code{deg}}{
#'			 \emph{optional} \code{\link{logical}}. Indicating if the result should be converted to degrees. \strong{Default} is \code{FALSE}}
#'		\item{\code{log}}{
#'			 \emph{optional} \code{\link{logical}}. Indicating if the calculations should be logged. \strong{Default} is \code{FALSE}}
#'		\item{\code{offset}}{
#'			 \emph{optional} \code{\link{numeric}}. Should be when using rotated coordinate systems. \strong{Default} is 0. \strong{Has to be provided in RADIANS!}}
#'    }
#' }
#' \subsection{Forwarded to the follwowing functions}{
#'    \itemize{
#'		\item{\code{...} is currently not forwared.}
#'    }
#' }
#'
#' @keywords radians, polar-angle, polar, coordinates
#' @export
#' @return the angle as a value of class  \code{\link{numeric}}.
#' @author Dipl. Kfm. Felix Lindemann \email{felix.lindemann@@hs-neu-ulm.de}
#'
#' Wissenschaftlicher Mitarbeiter
#' Kompetenzzentrum Logistik
#' Buro ZWEI, 17
#'
#' Hochschule fur angewandte Wissenschaften
#' Fachhochschule Neu-Ulm | Neu-Ulm University
#' Wileystr. 1
#'
#' D-89231 Neu-Ulm
#'
#'
#' Phone   +49(0)731-9762-1437
#' Web      www.hs-neu-ulm.de
#'
#' @references
#'Bronstein 2008 Bronstein, I. N.: Taschenbuch der Mathematik.
#'[CD-ROM-Ausg. der 7., voll. ueberarb. und erg. gedr. Ausg.].
#'Frankfurt:  Harri Deutsch, 2008
setGeneric("getpolar", function(n0,n1,...) standardGeneric("getpolar"))

#' @title distance between two \code{\link{Node}s}
#' @description Calculates the euclidian distance between to nodes. Optional this distance can be multiplied by a  \code{costfactor} in order to convert the distance to cost-related value (such as time, costs, ...).
#' \deqn{ f(x) = \sqrt((x_0-x_1)^2 + (y_0-y_1)^2) \cdot costfactor }{ costfactor * ((x_0-x_1)^2 + (y_0-y_1)^2)^0.5  }
#' @param n0 an object of class \code{\link{numeric}} with a length of 2 (x/y-coordinates) or a class derived from \code{\link{Node}}. Used as origin.
#' @param n1 an object of class \code{\link{numeric}} with a length of 2 (x/y-coordinates) or a class derived from \code{\link{Node}}.
#' @param ... \emph{Optional Parameters} (See Below).
#'
#' @section Optional Parameters (\code{...}):
#' \subsection{used by \code{\link{getDistance}}}{
#'    \describe{
#'     \item{digits}{non negative Integer value for the number of digitis that has to be rounded to.}
#'      \item{costfactor}{ \code{\link{numeric}} Optional Parameter. Used to transform the distance by a factor into costs. Default is \code{1}.}
#'    }
#' }
#' \subsection{Forwarded to the follwowing functions}{
#'    You may want to check these functions for any other optional parameters.
#'    \itemize{
#'      \item{\code{\link{round}} called, if the parameter \code{digits} is provided.}
#'    }
#' }
#' @name getDistance
#' @docType methods
#' @rdname getDistance
#' @author Dipl. Kfm. Felix Lindemann \email{felix.lindemann@@hs-neu-ulm.de}
#'
#' Wissenschaftlicher Mitarbeiter
#' Kompetenzzentrum Logistik
#' Buro ZWEI, 17
#'
#' Hochschule fur angewandte Wissenschaften
#' Fachhochschule Neu-Ulm | Neu-Ulm University
#' Wileystr. 1
#'
#' D-89231 Neu-Ulm
#'
#'
#' Phone   +49(0)731-9762-1437
#' Web      \url{www.hs-neu-ulm.de/felix-lindemann/}
#'          \url{http://felixlindemann.blogspot.de}
setGeneric("getDistance", function(n0,n1,   ...) standardGeneric("getDistance"))


REBOL [
	Title:    "Red/System IEEE-754 library"
	Author:   "Nenad Rakocevic"
	File: 	  %IEEE-754.r
	Tabs:	 4
	Rights:   "Copyright (C) 2000-2011-2015 Eric Long,-2018 Red Foundation. All rights reserved."
	License:  "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt"
	Comment:  {
		64-bit split/to-native functions from http://www.nwlink.com/~ecotope1/reb/decimal.r
		Added 32-bit support, compacted a bit the existing code.
	}
]

IEEE-754: context [

	specials: [
		single [
			#INF	#{7F800000}
			#INF-	#{FF800000}
			#NaN	#{7F200000}							;-- Quiet NaN
			#0-		#{80000000}
		]
		double [
			#INF	#{7FF0000000000000}
			#INF-	#{FFF0000000000000}
			#NaN	#{7FF8000000000000}					;-- Quiet NaN
			#0-		#{8000000000000000}
		]
	]

	split64: func [
		"Returns block containing three components of double floating point value"
		n [number!] /local sign exp frac
	][
		sign: either negative? n [n: negate n 1][0]

		either zero? n [exp: frac: 0][
			either zero? 1024 - exp: to integer! log-2 n [
				exp: 1023
			][
				if positive? (2 ** exp) - n [exp: exp - 1]
			]
			frac: n / (2 ** exp)

			either positive? exp: exp + 1023 [
				frac: frac - 1         					;-- drop the first bit for normals
				frac: frac * (2 ** 52) 					;-- make the remaining fraction an
														;-- "integer"
			][
				frac: 2 ** (51 + exp) * frac  			;-- denormals
				exp: 0
			]
		]
		reduce [sign exp frac]
	]

	to-binary64: func [
		"convert a numerical value into native binary format"
		n  [number! issue!]
		/rev     "reverse binary output"
		/local out sign exp frac
	][
		either issue? n [
			out: copy select specials/double next n
		][
			set [sign exp frac] split64 n
			out: make binary! 8
			loop 6 [
				insert out to char! byte: frac // 256
				frac: frac - byte / 256
			]
			insert out to char! exp // 16 * 16  + frac
			insert out to char! exp / 16 + (128 * sign)
		]
		either rev [copy reverse out][out]
	]

	split32: func [
		"Returns block containing three components of single floating point value"
		n [number!] /local sign exp frac
	][
		sign: either negative? n [n: negate n 1][0]

		either zero? n [exp: frac: 0][
			either zero? 128 - exp: to integer! log-2 n [
				exp: 127
			][
				if positive? (2 ** exp) - n [exp: exp - 1]
			]
			frac: n / (2 ** exp)

			either positive? exp: exp + 127 [
				frac: frac - 1
				frac: frac * (2 ** 23) 					;-- make the remaining fraction an "integer"
			][
				frac: 2 ** (22 + exp) * frac  			;-- denormals
				exp: 0
			]
			frac: to integer! frac + .5
		]
		reduce [sign exp frac]
	]

	to-binary32: func [
		"convert a numerical value into native binary format"
		n  [number! issue!]
		/rev     "reverse binary output"
		/local out sign exp frac
	][
		either issue? n [
			out: copy select specials/single next n
		][
			set [sign exp frac] split32 n
			out: make binary! 4
			loop 2 [
				insert out to char! byte: frac // 256
				frac: frac - byte / 256
			]
			insert out to char! exp * 128 // 256  + frac
			insert out to char! exp / 2 + (128 * sign)
		]
		either rev [copy reverse out][out]
	]
]


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 08

rm(list = ls())

observed <- c(38, 55, 54, 41, 62)

(k <- length(observed))
# 5

(n <- sum(observed))
# 250

(expected <- n * 1 / k )
# 50

(Q <- sum((observed - expected) ^ 2 / expected))
# 8.2

(pvalue <- 1 - pchisq(Q, df = k - 1))
# 0.0845206445489823


# Prediction efficiency in two ways
prediction_accuracy <- function(predicted, empirical) {
    # Parameters:
    #   predicted   matrix of predicted interactions
    #   empirical   matrix of empirical interactions

    #   Output      vector of a, b, c, d, and TSS
    #       a       number of links predicted (1) and observed (1)
    #       b       number predicted (1) but not observed (0)
    #       c       number predicted absent (0) but observed (1)
    #       d       number of predicted absent (0) and observed absent (0)
    #       TSS     TSS = (ad-bc)/[(a+c)(b+d)]
    #                   "[...] quantifies the proportion of prediction success relative to false predictions
    #                   and returns values ranging between 1 (perfect predictions) and 1 (inverted forecast)
    #                   (Allouche, Tsoar & Kadmon 2006)." Gravel et al. 2013
    #       ScoreY1 Fraction of 1 correctly predicted a / (a + c)
    #       ScoreY0 Fraction of 0 correctly predicted d / (b + d)
    #       FSS     FSS = ScoreY1 + ScoreY0 / sum(a, b, c, d)^2

    if(identical(colnames(predicted), colnames(empirical)) == FALSE ||
        identical(rownames(predicted), rownames(empirical)) == FALSE ||
        identical(dim(predicted), dim(empirical)) == FALSE) {
            print('matrices need to have same dimensions and row and column names')
            break
    }

    efficiency <- numeric(8)
    names(efficiency) <- c('a','b','c','d','TSS','ScoreY1','ScoreY0','FSS')

    for(i in 1:ncol(predicted)){
        for(j in 1:nrow(predicted)) {
            if(predicted[i,j] == 1 && empirical[i,j] == 1) {
                efficiency[1] <- efficiency[1] + 1
            } else if(predicted[i,j] == 1 && empirical[i,j] == 0) {
                efficiency[2] <- efficiency[2] + 1
            } else if(predicted[i,j] == 0 && empirical[i,j] == 1) {
                efficiency[3] <- efficiency[3] + 1
            } else if(predicted[i,j] == 0 && empirical[i,j] == 0) {
                efficiency[4] <- efficiency[4] + 1
            }
        }
    }

    a <- efficiency[1]
    b <- efficiency[2]
    c <- efficiency[3]
    d <- efficiency[4]

    efficiency[5] <- ((a * d) - (b * c)) / ((a + c) * (b + d))  # TSS
    efficiency[6] <- a / (a + c)                                # ScoreY1
    efficiency[7] <- d / (b + d)                                # ScoreY0
    efficiency[8] <- (a + d) / sum(a, b, c, d)    # FSS

    return(efficiency)
}


#@reemuru
#data mining
#k-means clustering

#intialize library for kmeans clustering and elbow method
library(NbClust)
library(factoextra)

#set the working directory
setwd("./k-means/")

#reproducible output
set.seed(1234)

#load sensor readings file with headers in the first row
sensors<-read.csv(file = "sensor_readings_24.csv", header = TRUE, sep = ",")

#summary stats
summary(sensors)

#dataset structure
str(sensors)

#Class variable distribution
plot(sensors$Class)

#create correlation matrix with heatmap
cormat <- round(cor(sensors[1:24]),2)
head(cormat)
library(reshape2)
melted_cormat <- melt(cormat)
head(melted_cormat)
library(ggplot2)
ggplot(data = melted_cormat, aes(x=Var1, y=Var2, fill=value)) +
  geom_tile()

#copy the dataset
sensors2<-sensors
#remove the class variable
sensors2$Class<-NULL

#scale the dataset
sensors2[1:24]<-scale(sensors2[1:24])

#store the model with 4 clusters
kc<-kmeans(sensors2, 4, iter.max = 40)

#print the model output
print(kc)

#between sum of squares
kc$betweenss

#compare the model with the classes
table(sensors$Class, kc$cluster)

#model variations
#K-means method with k=2
kc<-kmeans(sensors2, 2, iter.max = 20)
kc
kc$betweenss
#K-means method with k=3
kc<-kmeans(sensors2, 3, iter.max = 30)
kc
kc$betweenss
#K-means method with k=5
kc<-kmeans(sensors2, 5, iter.max = 50)
kc
kc$betweenss

#minimum within cluster sum of squares with 3 clusters

#model refinement
#the object is only moving clockwise therefore slight turns should be removed
#subset for no slight turns and re-factor
modsensors <- subset(sensors, sensors$Class!="Slight-Left-Turn")
modsensors <- subset(modsensors, modsensors$Class!="Slight-Right-Turn")
modsensors$Class<-factor(modsensors$Class)

#verify dataset structure
str(modsensors)

#copy the modified dataset
modsensors2<-modsensors

#remove class from copied dataset
modsensors2$Class<-NULL

#scale the dataset
modsensors2[1:24]<-scale(modsensors2[1:24])

#K-means method with k= 2
kc<-kmeans(modsensors2, 2, iter.max = 20)

#cross-tabulation
table(modsensors$Class, kc$cluster)

#dataviz
#verify cluster selection with the elbow method, within groups sum of squares
fviz_nbclust(modsensors2, kmeans, method = "wss") +
  geom_vline(xintercept = 2, linetype = 2)+
  labs(subtitle = "Elbow method")

clusplot(modsensors2, kc$cluster, color=TRUE, shade=TRUE, labels=2, lines=0)

#higher dimensional plot
#dataviz
library(rgl)
newkc <- data.frame(modsensors2, K=kc$cluster)#Include the number of cluster in the data set
pcdf <- princomp(modsensors2,cor=T,score=T)
summary(pcdf)#Compute the validity of each component/dimension
plot3d(pcdf$scores, col=newkc$K)#Create a 3D plot


return(switch(kernel,
                      gaussian = 1/(2*sqrt(pi)),
                      rectangular = sqrt(3)/6,
                      triangular = sqrt(6)/9,
                      epanechnikov = 3/(5*sqrt(5)),
                      biweight = 5*sqrt(7)/49,
                      cosine = 3/4*sqrt(1/3 - 2/pi^2),
                      optcosine = sqrt(1-8/pi^2)*pi^2/16
                      ))


#  James Rekow

firstDeriv = function(y, deltax = 1){

  #  ARGS:  y - numeric vector of y-values
  #         deltax - mesh width of corresponding x-values
  #
  #  RETURNS:  a numeric vector of the same length as y whose elements are the
  #            centered first derivative of y at each interior point, and one-sided
  #            derivatives of y at the endpoints

  N = length(y)
  return((0.5 / deltax) * c(2 * (y[2] - y[1]), (y[3:N] - y[1:(N - 2)]), 2 * (y[N] - y[N - 1])))

} #  end firstDeriv function


#!/usr/bin/env Rscript

# This implementation uses a custom function on a vector rather than a
# loop which is kinda neat, but can be memory consuming.

numslices <- 100000000

args <- commandArgs(trailingOnly=TRUE)

if (length(args)>0) {
  numslices <- strtoi(args)
}

cat("Calculating PI using:\n")
cat(" ", numslices, "slices\n")
cat("  1 process\n")

start <- Sys.time()

# Define our function
y <- function(x) {
  1/(1+(x^2))
}

# Sum our function applied to the slices.
mypi <- (4 * sum(y((1.0/numslices) * (0.5:numslices-0.5))))/numslices

stop <- Sys.time()
elapsed <- stop - start

cat("Obtained value of PI:", mypi, "\n")
cat("Time taken:", elapsed, "seconds\n")


#!/usr/bin/env Rscript

# Author  : Bhishan Poudel
# Date    : Feb 11, 2016
# Program :

# Setting working directory
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

# Start device driver to save output
#postscript( file = "milkyway.eps", height = 12, width = 8)

# Read magnitudes for Milky Way and M 31 globular clusters
GC1 <- read.table("GlobClus_MWG.dat",
                  header = T)
GC2 <- read.table("GlobClus_M31.dat",
                  header = T)
K1 <- GC1[, 2]
K2 <- GC2[, 2]
cat("summary of K1 \n")
print(summary(K1))
cat("\n summary of K1 \n")
print(summary(K2))

# Three estimates of the distance modulus to M 31
DMmn <- mean(K2) - mean(K1)
print(DMmn)
sigDMmn <- sqrt(var(K1) / length(K1) + var(K2) / length(K2))
print(sigDMmn)
DMmed <- median(K2) - median(K1)
print(DMmed)
sigDMmed <-
    sqrt(mad(K1) ^ 2 / length(K1) + mad(K2) ^ 2 / length(K2))
print(sigDMmed)
wilcox.test(K2, K1, conf.int = T)

# e.d.f., quantile and Q-Q plots for globular cluster magnitudes
plot(
    ecdf(K1),
    cex.points = 0,
    verticals = T,
    xlab = "K (mag)",
    ylab = "e.d.f.",
    main = ""
)
plot(
    ecdf(K2 - 24.90),
    cex.points = 0,
    verticals = T,
    add = T
)
text(-7.5, 0.8, lab = "MWG")
text(-10.5, 0.9, lab = "M 31")
par(mfrow = c(1, 3))
qqplot(
    K1,
    K2 - 24.90,
    pch = 20,
    cex.axis = 1.3,
    cex.lab = 1.3,
    xlab = "MWG",
    ylab = "M31 - 24.90",
    main = ""
)
qqnorm(
    K1,
    pch = 20,
    cex.axis = 1.3,
    cex.lab = 1.3,
    main = ""
)
qqline(K1, lty = 2, lwd = 1.5)
text(-2.5, -6, pos = 4, cex = 1.3,  'MWG normal QQ plot')
qqnorm(
    K2 - 24.90,
    pch = 20,
    cex.axis = 1.3,
    cex.lab = 1.3,
    main = ""
)
qqline(K2 - 24.90, lty = 2, lwd = 1.5)
text(-3, -7.5, pos = 4, cex = 1.3,  'M31 normal QQ plot')
par(mfrow = c(1, 1))

# Plot e.d.f. with confidence bands
#install.packages('sfsmisc')
library('sfsmisc')
ecdf.ksCI(K1, ci.col = 'black')

# Nonparametric tests for normality
#install.packages('nortest')
library(nortest)
print(cvm.test(K1))
print(cvm.test(K2))
print(ad.test(K1))
print(ad.test(K2))

# Turn off device driver
#dev.off()


closest.pairs <- function(x, y=NULL, ...){
      # takes two-column object(x,y-values), or creates such an object from x and y values
       if(!is.null(y))  x <- cbind(x, y)

       distances <- dist(x)
        min.dist <- min(distances)
          point.pair <- combn(1:nrow(x), 2)[, which.min(distances)]

     cat("The closest pair is:\n\t",
      sprintf("Point 1: %.3f, %.3f \n\tPoint 2: %.3f, %.3f \n\tDistance: %.3f.\n",
        x[point.pair[1],1], x[point.pair[1],2],
          x[point.pair[2],1], x[point.pair[2],2],
            min.dist),
            sep=""   )
     c( x1=x[point.pair[1],1],y1=x[point.pair[1],2],
        x2=x[point.pair[2],1],y2=x[point.pair[2],2],
        distance=min.dist)
     }


#' Global empirical relation method for paleoslope inversion
#'
#' \code{trampush_slp} calculates the slope of an ancient river, provided you know the flow depth and the grain size of the bed material. Implemented from Trampush et al. (2014)
#' @param Dbed The median grain size of bedload sediments in meters.
#' @param H The paleoflow depth in meters.
#' @return Returns a vector \code{S}, the dimensionless slope.
#' @export

## Inversion for Paleoslope based on Trampush 2014
## Eric Barefoot
## April 2018

# This function provides functionality for computing paleoslope based on a method described by Sheila Trampush in a 2014 paper.

# describe inputs and other stuff needed

# Trampush et al. use a Bayesian approach for paleohydraulic inversion, meaning that the coefficients that they describe for the empirical fit each have a distribution. They provide percentiles for the distribution in their Table 1.
# In this way, we can ascribe ranges for the coefficients, and potentially provide a range of estimates of paleoslope accordingly. I think this means we can have confidence intervals, but I'm not sure about that.
# Initially, the user is allowed to select a percentile, and that percentile will be chosen for each parameter.

# In the future, users should be allowed to vary each parameter individually.

trampush_slp = function(Dbed, H, perc = 50) {

  a0sp = smooth.spline(y = c(-2.14, -2.10, -2.08, -2.05, -2.01), x = c(2.5,25,50,75,97.5))
  a1sp = smooth.spline(y = c(0.222, 0.244, 0.254, 0.266, 0.287), x = c(2.5,25,50,75,97.5))
  a2sp = smooth.spline(y = c(-1.18, -1.12, -1.09, -1.06, -1.00), x = c(2.5,25,50,75,97.5))

  logS = predict(a0sp, x = perc)$y + predict(a1sp, perc)$y * log10(Dbed) + predict(a2sp, perc)$y * log10(H)

  return(S = 10^logS)

}


library(tidyverse)

nobs <- 256^3
table_id_only <- tibble(id = 1:nobs)
table_rgb_full <- mutate(table_id_only,
       red = (id-1)%/%(256^2),
       green = ((id-1)%%(256^2))%/%256,
       blue = ((id-1)%%(256^2))%%256,
       # For the formula below, see https://www.w3.org/TR/WCAG20-TECHS/G17.html
       red_srgb = red / 255,
       green_srgb = green / 255,
       blue_srgb = blue / 255,
       r = ifelse(red_srgb > 0.03928,
                      ((red_srgb + 0.055)/1.055)^2.4,
                      red_srgb / 12.92),
       g = ifelse(green_srgb > 0.03928,
                        ((green_srgb + 0.055)/1.055)^2.4,
                        green_srgb / 12.92),
       b = ifelse(blue_srgb > 0.03928,
                       ((blue_srgb + 0.055)/1.055)^2.4,
                       blue_srgb / 12.92),
       luminance = 0.2126*r + 0.7152*g + 0.0722*b,
       contrast_ratio = round((luminance + 0.05)/0.05, digits = 2),
       # https://en.wikipedia.org/wiki/Hue#Defining_hue_in_terms_of_RGB
       max = ifelse( red >= green & red >= blue, red,
               ifelse( green > red & green >= blue, green, blue)
             ),
       min = ifelse( red <= green & red <= blue, red,
               ifelse( green < red & green <= blue, green, blue)
             ),
       chroma = max - min,
       hue = round(ifelse( chroma == 0, NA,
               ifelse( max == red & min == blue, 60*(green-min)/chroma,
                 ifelse( max == green & min == blue, 60*(2-(red-min)/chroma),
                   ifelse( max == green & min == red, 60*(2+(blue-min)/chroma),
                     ifelse( max == blue & min == red, 60*(4-(green-min)/chroma),
                       ifelse( max == blue & min == green, 60*(4+(red-min)/chroma), 60*(6-(blue-min)/chroma))
                     )
                   )
                 )
               )
             ))
)

table_rgb <- select(table_rgb_full, id, red, green, blue, contrast_ratio, hue, chroma)
write_csv(table_rgb, "rgbColorCodes.csv")


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 07

rm(list = ls())

observed <- c(20, 30, 20, 25, 15, 10)

(k <- length(observed))
# 6

(n <- sum(observed))
# 120

(expected <- n * 1 / k )
# 20

(Q <- sum((observed - expected) ^ 2 / expected))
# 12.5

(pvalue <- 1 - pchisq(Q, df = k - 1))
# 0.0285431233261675


# https://www.hackerrank.com/challenges/s10-normal-distribution-1/problem
library("magrittr")
xbar <- 20
stdx <- 2

q1 <- 19.5
q2lower <- 20
q2upper <- 22

a1 <- pnorm(q1, mean = xbar, sd = stdx)
hour20 <- pnorm(q2lower, mean = xbar, sd = stdx)
hour22 <- pnorm(q2upper, mean = xbar, sd = stdx)
a2 <- hour22 - hour20

hour18 <- pnorm(18, mean = xbar, sd = stdx)

sixeight <- hour22 - hour18 #should be about 68% since it's mean +- 1 sd
round(a1, digits = 3) %>% cat("\n")
round(a2, digits = 3) %>% cat()


# This function samples k indices from 1:n starting with very dense sampling
# (every value) and then getting more and more sparse

#' Sampling for qq plots
#'
#' Returns k indices between 1:max.idx (x) such that -log(x/n) is uniformly
#' distributed. This is useful to reduce overplotting when plotting
#' log-transformed uniform data (such as p-values in a qq plot).
#'
#' @examples
#' n <- 1e5
#' x <- sort(runif(n))
#' thin.idx <- thin(n, 500)
#' par(mfcol=c(1, 2))
#' plot(-log10(1:n/n), -log10(x), ann=FALSE)
#' plot(-log10(thin.idx/n), -log10(x[thin.idx]), ann=FALSE)
#'
#' @export
thin <- function(n, k=2000, max.idx=n) {

  if ( max.idx > n ) max.idx <- n
  if ( max.idx <= k ) return (1:max.idx)

  # Generate k samples between 1 and max.idx
  # such that -log10(x/n) is uniformly distributed
  x <- round(max.idx*exp(-(k:1)/k*log(n)))

  # Ensure each x is unique (Equivalently, diff(x) != 0)
  prev <- 0
  offset <- 0

  for ( i in 1:k ) {
    if ( x[i] + offset == prev ) {
      offset <- offset + 1
    } else if ( x[i] + offset > prev + 1 && offset > 0 ) {
      if ( x[i] > prev ) {
        offset <- 0
      } else {
        offset <- prev + 1 - x[i]
      }
    }
    prev <- x[i] <- x[i] + offset
  }

  x
}

#' Fast QQ plots
#'
#' QQ plots with lots of points can be slow. Since most of the points overlap
#' we don't actually have to plot all of them (and in most cases the output
#' will be identical.)
#'
#' This function will take a value k (default 2000) and sample that many
#' pvalues in an intelligent way such that we don't lose information, then
#' plot the log observed vs expected pvals in a nice way.
#'
#' The optimal value of k depends on the resolution/size of the plot. Very high
#' resolution or very large plots may need larger k to look correct.
#'
#' Additional arguments in ... are passed to plot().
#'
#' @export
fastqq <- function(pvals, k=2000, ...) {

  np <- length(pvals)
  thin.idx <- thin(np, k)

  thin.cint.95 <- qbeta(0.95, thin.idx, np - thin.idx + 1)
  thin.cint.05 <- qbeta(0.05, thin.idx, np - thin.idx + 1)

  thin.logp.exp <- -log10(thin.idx/np)
  thin.logp.obs <- -log10(pvals[order(pvals)[thin.idx]])

  plot(thin.logp.exp, thin.logp.obs, xlab=expression(-log[10](p[expected])), ylab=expression(-log[10](p[observed])), ...)
  abline(0, 1, col='gray', lty=2)
  lines(thin.logp.exp, -log10(thin.cint.95), lty=2, col='red')
  lines(thin.logp.exp, -log10(thin.cint.05), lty=2, col='red')
}

#' @export
thin.qqplot <- function(pvals, thin.idx=NULL, k=2000, ...) {
  warning('This function is deprecated, use fastqq')
  fastqq(pvals, k, ...)
}


garage1=c(17.6,20.2,19.5,11.3,13.0,16.3,15.3,16.2,12.2,14.8,21.3,22.1,16.9,17.6,18.4)
garage2=c(17.3,19.1,18.4,11.5,12.7,15.8,14.9,15.3,12.0,14.2,21.0,21.0,16.1,16.7,17.5)
t.test(garage1,garage2,paired = TRUE)
tvalue=qt(1-0.05,14)
# t>tvale we  reject H0 and conclude that  mean repair estimate for garage I is greater than that for garage II


#' rexp
#'
#' Generate from a exponential distribution using a gpu.
#'
#' @details
#' We use the cuRAND uniform generator together with the fact that if
#' \eqn{X \sim U(0, 1)} then \eqn{Y = -\lambda^{-1}\log(X) \sim Exp(\lambda)}.
#'
#' @param n
#' The number of values to generate
#' @param rate
#' Parameter for exponential random variables.
#' @param seed
#' Seed for the random number generation.
#' @param type
#' 'double' or 'float'
#'
#' @references
#' Casella, G. and Berger, R.L., 2002. Statistical inference (Vol. 2). Pacific
#' Grove, CA: Duxbury.
#'
#' Rizzo, M.L., 2007. Statistical computing with R. Chapman and Hall/CRC.
#'
#' @useDynLib curand R_curand_rexp
#' @export
rexp = function(n, rate=1, seed=getseed(), type="double")
{
  type = match.arg(tolower(type), c("double", "float"))
  type = ifelse(type == "double", TYPE_DOUBLE, TYPE_FLOAT)

  if (n < 0)
    stop("invalid arguments")
  else if (n == 0)
  {
    if (type == TYPE_DOUBLE)
      return(numeric(0))
    else
      return(float(0))
  }

  n1 = floor(sqrt(n))
  n2 = n - n1*n1

  if (rate < 0 || is.badval(rate))
  {
    warning("NAs produced")
    ret = setnan(n1, n2, type)
  }
  else
    ret = .Call(R_curand_rexp, as.integer(n1), as.integer(n2), as.double(rate), as.integer(seed), type)

  if (type == TYPE_DOUBLE)
    ret
  else
    float32(ret)
}


#
#  SimpMCMCJpeg.r
#
#  modified from SimpMCMC.r, but output is now jpeg files....
#  -------------------
#
#  SimplMCMC.r
#  January 24,2011
#  This file will generate an MCMC sample of normal data
#   and produce a series of plots for this data
#
#  NOTE: all plot files are saved to directory:
#     "c:/mike workstation/bayescourse9/plots."
#  You may want to change this....
#

# prior
mu0<-66; theta<-4; alp<-1; bet<-25

# data
x<-c(64, 73, 64, 63, 69, 71)
xbar<-mean(x)
n<-length(x)

# starting values
muStart<-20;tauStart<-0.0025;

#  MCMC parameters
nbig<-50000;
set.seed(333); # The purpose of set.seed is to get the same random values

if(T){        # set to true to rerun the MCMC
# Initialize chain
mu<-rep(nbig, 0)
tau<-rep(nbig,0)

mu[1]<-muStart; tau[1]<-tauStart

mu0p<- (theta*mu0+n*xbar)/(theta+n)  # does not change in loop
alpp<-alp+(0.5)*(n+1)                # does not change in loop

tau0p<-rep(nbig,0)
betp<-rep(nbig,0)

for(i in 2:nbig){
	# sample mu
	tau0p[i]<-tau[i-1]*(n+theta)
	mu[i]<-rnorm(1,mean=mu0p,sd=1/sqrt(tau0p[i]))

	# sample tau
	betp[i]<- bet+ 0.5*( sum( (x-mu[i])^2) + theta*(mu[i]-mu0p)^2)
	tau[i]<-rgamma(1,alpp,betp[i])
}
}
#  the following command will give the first 20 values:
 cbind(mu,tau)[1:20,]

# The next group of plots will plot the values as the get sampled in time.
#
# Please note, that the below command write the plots to a JPEG  file
# to the directory: ``\verb+c:/mike workstation/bayescourse9/plots+''. If you
# don't have such a directory, then you need to create it or better yet, change
# the directory name in the below commands.

#
#  plots the values as they get sampled in time
#
jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Sd.jpg")

iind1<-seq(1:60)

plot(mu[iind1],tau[iind1],type="n", xlab="mu", ylab="tau")
lines(mu[1:60],tau[1:60],type="b", cex=2)
title(main="First 60 values")

dev.off()
##################################

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7S2c.jpg")

plot(mu[2:60],tau[2:60],type="p", xlab="mu", ylab="tau",
cex=1.5, xlim=c(55,75), ylim=c(0,.2),
main="First 60 values, dropped first value")

dev.off()

# The next set of commands compares the sampled joint distribution from the
# MCMC method versus sampling the joint distribution using the know joint
# distribution given in the second lecture.  Note, the below code uses the
# function \verb+kde2d(...)+ which requires that the package "MASS" is loaded
# in R.

library(MASS)

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7S2e.jpg")

contour(kde2d(mu[2:nbig],tau[2:nbig]),
xlab="mu", ylab="tau",
cex=1.5, xlim=c(55,75), ylim=c(0,.2),nlevels=19,
main="Joint Distribution: MCMC")

dev.off()

#####
xa1<-4;xb1<-71.797
xmu0<-66.80; xthep<-10
xn<-50000
xgam<-rgamma(xn,xa1,xb1)
xmu<-rnorm(xn,mean=xmu0, sd=1/sqrt(xthep*xgam))
#####

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7S2f.jpg")

contour(kde2d(xmu,xgam),
xlab="mu", ylab="tau",
cex=1.5, xlim=c(55,75), ylim=c(0,.2),nlevels=19,
main="Joint Distribution: IID sample")

dev.off()

# The next group of plots are for the trace plots.  These plots are a simple
# time plot of one of the parameters which is sampled with the MCMC algorithm.
# That is, for a parameter $\theta$, let the m-th step sampled value be
# $\theta^{(m)}$. Then, the plot is simply $m$ versus $\theta^{(m)}$.

##########################################
#
#  trace plots
#
##########################################

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Ta.jpg")

iind2<-seq(1,200)
plot(iind2,mu[iind2],type="l", xlab="Iteration number", ylab="mu",
cex=1.5,
main="Trace plot for mu")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Tb.jpg")

iind2<-seq(1,200)
iind2a<-seq(6,200)

plot(iind2a,mu[iind2a],type="l", xlab="Iteration number", ylab="mu",
cex=1.5, main="Trace plot for mu, dropping first 5 obs")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Td.jpg")

iind2<-seq(1,200)
iind2a<-seq(6,200)

plot(iind2a,tau[iind2a],type="l", xlab="Iteration number", ylab="tau",
cex=1.5,
main="Trace plot for tau, dropping first 5 obs")

dev.off()

# The following sequence of plots show the estimated density of $\mu$
# calculated from a sample from a MCMC chain, from a sample of the
# independent distribution, and a plot of the true posterior marginal
# distribution.

##########################################
#
#  density plots
#
##########################################

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Dma.jpg")

plot(density(mu[-(1:5)]),type="l", xlab="mu", ylab=" ",
cex=1.5, xlim=c(55,75), main="Estimate mu by MCMC")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Dmb.jpg")

plot(density(mu[-(1:5)]),type="l", xlab="mu", ylab=" ",
cex=1.5, xlim=c(55,75), main="Estimate mu by Independent Sampling")
lines(density(xmu),type="l")

dev.off()

jpeg(file="c:/mike workstation/bayescourse9/plots/lec2Ex7Dmc.jpg")

plot((dd<-density(mu[-(1:5)])),type="l", xlab="mu", ylab=" ",
cex=1.5, xlim=c(55,75),
main="True density of mu", col=1)

lines(density(xmu),type="l", col=2)
xx<-dd$x
c2<-1/sqrt( xb1/xa1/xthep)
tt<-(xx-xmu0)*c2
ddt<-dt(tt,2*xa1)*c2
lines(xx,ddt,type="l",col=3)

dev.off()

hw2bayes2019/Comp Code Files/Comp Code Files/SimpMCMCJpeg.r


=begin
  # sample-gaussian-elimination01.rb

  require "algebra"
  M = MatrixAlgebra(Rational, 5, 4)
  a = M.matrix{|i, j| i + j}
  a.display #=>
    #[0, 1, 2, 3]
    #[1, 2, 3, 4]
    #[2, 3, 4, 5]
    #[3, 4, 5, 6]
    #[4, 5, 6, 7]
  a.kernel_basis.each do |v|
    puts "a * #{v} = #{a * v}"
    #=> a * [1, -2, 1, 0] = [0, 0, 0, 0, 0]
    #=> a * [2, -3, 0, 1] = [0, 0, 0, 0, 0]
  end
((<_|CONTENTS>))
=end


"%gcd%" <- function(u, v) {ifelse(u %% v != 0, v %gcd% (u%%v), v)}

"%lcm%" <- function(u, v) { abs(u*v)/(u %gcd% v)}

print (50 %lcm% 75)


=begin
[((<index|URL:index.html>))]
= AlgebraicExtensionField
((*(Algebraic Extension Field)*))

A class represents the algebraic extension field.

== File Name:
* ((|algebraic-Extension-feild.rb|))

== SuperClass:

* ((|ResidueClassRing|))

== Included Module

(none)

== Associated Methods:

--- Algebra.AlgebraicExtensionField(field, obj){|x| ... }
    Same as ((<::create>)).

== Class Method

--- ::create(k, obj){|x| ... }
    Returns the extension field ((|k[x]/(p(x))|))
    of the field ((|k|)) by
    the polynomial ((|p(x)|)) of the variable ((|x|)),
    where ((|obj|)) represents the ((|x|)).

    The class methods ((<::var>)), ((<::def_polys>)) and ((<::env_ring>))
    are defined for the return value.

    Example: Create the field ((|F|)) extended by (({x**2 + x + 1 == 0}))
    from ((|Rational|)).
      require "rational"
      require "polynomial"
      require "residue-class-ring"
      F  = Algebra.AlgebraicExtensionField(Rational, "x") {|x| x**2 + x + 1}
      x = F.var
      p( (x-1)** 3 / (x**2 - 1) ) #=> -3x - 3

--- ::to_ary
    Returns (({[self, var]})).

    Example: Define AlgebraicExtensionField and variables simulteniously
      require "rational"
      require "algebraic-extension-field"
      F, a = Algebra.AlgebraicExtensionField(Rational, "a") {|a| a**2 + a + 1}

--- ::var
    Returns the residue class of ((|x|)).
    This method is defined for the residue class ring, ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

--- ::modulus
    Returns the element ((|p(x)|)) of ((|k[x]|)) .
    This method is defined for the residue class ring, ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

--- ::def_polys
    Returns the array of ((<::modulus>))'s of size ((|n|)).
    Where ((|self|)) is defined recursively as the
    ((|AlgebraicExtensionField|))
    of height ((|n|)) and base field ((|k0|)).
    This method is defined for the residue class ring ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

    Example: Make the extension field of cubic roots of 2, 3, 5 over Rational.
      require "algebra"
      # K0 == Rational
      K1 = AlgebraicExtensionField(Rational, "x1") { |x|
        x ** 3 - 2
      }
      K2 = AlgebraicExtensionField(K1, "x2") { |y|
        y ** 3 - 3
      }
      K3 = AlgebraicExtensionField(K2, "x3") { |z|
        z ** 3 - 5
      }

      p K3.def_polys #=> [x1^3 - 2, x2^3 - 3, x3^3 - 5]

      x1, x2, x3 = K1.var, K2.var, K3.var
      f = x1**2 + 2*x2**2 + 3*x3**2
      f0 = f.abs_lift

      p f0.type     #=> (Polynomial/(Polynomial/(Polynomial/Rational)))
      p f0.type == K3.env_ring #=> true

      p f #=> 3x3^2 + 2x2^2 + x1^2
      p f0.evaluate(x3.abs_lift, x2.abs_lift, x1.abs_lift)
          #=> x3^2 + 2x2^2 + 3x3^2

--- ::env_ring
    Returns the multi-variate polynomial ring ((|k0[x1, x2,.., xn]|)).
    Where ((|self|)) is defined recursively as the
    ((|AlgebraicExtensionField|))
    of height ((|n|)) and base field ((|k0|)).
    This method is defined for the residue class ring ((|k[x]/(p(x))|))
    which is the return value of ((<::create>)).

--- ::ground
    Return the polnomial ring ((|k[x]|)) which is the ground ring of
    the residue class ring.

== Methods
--- abs_lift
    Returns the lift of self in ((<::env_ring>)).
    ( = ((|k0[x1, x2,.., xn] |)) ).

--- [](n)
    Returns the coeffcient of degree ((<n>)). Same as (({lift[n]})).

    Example: Fibonacci Series
      require "algebra"
      t = AlgebraicExtensionField(Integral, "t"){|x| x**2-x-1}.var
      (0..10).each do |n|
        p( (t**n)[1] ) #=> 0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55
      end

=end


N <- 10000

ts1 <- 1:N
ts2 <- 1:N

experiment <- function () {
	t <- 0
	repeat {
		outcome <- sample(2, 1, prob=c(1/4, 3/4))
		if (outcome == 1) {
			break
		} else {
			t <- t + 1
		}
	}
	t
}

for (i in 1:N) {
	ts1[i] <- experiment()
	ts2[i] <- ts1[i] + experiment()
}

# exercise (i)
print(summary(ts1))
barplot(table(ts1)/N)
# exercise (ii)
barplot(table(ts2)/N)


# Calculates the Mandelbrot set (https://en.wikipedia.org/wiki/Mandelbrot_set)
# through the first 20 iterations of the equation z = z^2 + c plotted for
# different complex constants c.

install.packages("caTools")
library(caTools)  # for write.gif
jet.colors <- colorRampPalette(c("green", "blue", "red", "cyan", "#7FFF7F",
                                 "yellow", "#FF7F00", "red", "#7F0000"))
m <- 1000  # define size
C <- complex(real=rep(seq(-1.8,0.6, length.out=m), each=m),
             imag=rep(seq(-1.2,1.2, length.out=m), m))
C <- matrix(C,m,m)  # reshape as square matrix of complex numbers
Z <- 0
X <- array(0, c(m,m,20))  # initialize output 3D array
for (k in 1:20) {
  Z <- Z^2+C  # the central difference equation
  X[,,k] <- exp(-abs(Z))  # capture results
}
write.gif(X, "Mandelbrot.gif", col=jet.colors, delay=900)


fitDistToX <- function (x, dist) {
  tx <- dist$x; ty <- dist$y
  y <- numeric(length(x))
  for (i in seq(x)) {
    j <- bsearchtools::lb(tx, x[i])
    if (j <= 1) {
      y[1:i] <- ty[1]
      next
    }
    if (j > length(tx)) {
      y[i:length(x)] <- ty[length(ty)]
      break
    }
    y[i] <- (ty[j] - ty[j-1]) / (tx[j] - tx[j-1]) * (x[i] - tx[j]) + ty[j]
  }
  return(list(x=x,y=y))
}

sampleFromPopDist <- function (n, popDist, seed=1234) {
  set.seed(seed)
  return (sample(popDist$x, n, prob = (popDist$y) / sum(popDist$y), replace = TRUE))
}

KLdistance <- function(sampleDist, popDist) {
  x <- popDist$x
  modifSampleDist <- fitDistToX(x, sampleDist)
  lp <- -log(modifSampleDist$y)
  lq <- -log(popDist$y)
  dx <- diff(modifSampleDist$x)
  dx <- c(dx, dx[length(dx)])
  kl <- (modifSampleDist$y * lp / lq) * dx
  kl[is.na(kl)] <- 0
  return (sum(kl))
}

L2distance <- function (sampleDist, popDist) {
  x <- popDist$x
  modifSampleDist <- fitDistToX(x, sampleDist)
  dx <- diff(modifSampleDist$x)
  dx <- c(dx, dx[length(dx)])
  l2 <- sum((modifSampleDist$y - popDist$y)^2 * dx)
  return (l2)
}

addRandomNoise <- function (vec, noise) {
  newVec <- numeric(length(vec))
  for (i in seq(vec)) {
    newVec[i] <- vec[i] + rnorm (1,0,noise)
  }
  return (newVec)
}


# Goal: Given two vectors of data,
#       superpose their CDFs
#       and show the results of the two-sample Kolmogorov-Smirnoff test

# The function consumes two vectors x1 and x2.
# You have to provide a pair of labels as `legendstrings'.
# If you supply an xlab, it's used
# If you specify log - e.g. log="x" - this is passed on to plot.
# The remaining args that you specify are sent on into ks.test()
two.cdfs.plot <- function(x1, x2, legendstrings, xlab="", log="", ...) {
  stopifnot(length(x1)>0,
            length(x2)>0,
            length(legendstrings)==2)
  hilo <- range(c(x1,x2))

  par(mai=c(.8,.8,.2,.2))
  plot(ecdf(x1), xlim=hilo, verticals=TRUE, cex=0,
       xlab=xlab, log=log, ylab="Cum. distribution", main="")
  grid()
  plot(ecdf(x2), add=TRUE, verticals=TRUE, cex=0, lwd=3)
  legend(x="bottomright", lwd=c(1,3), lty=1, bty="n",
         legend=legendstrings)

  k <- ks.test(x1,x2, ...)
  text(x=hilo[1], y=c(.9,.85), pos=4, cex=.8,
     labels=c(
       paste("KS test statistic: ", sprintf("%.3g", k$statistic)),
       paste("Prob value: ", sprintf("%.3g", k$p.value))
       )
     )
  k
}

x1 <- rnorm(100, mean=7, sd=1)
x2 <- rnorm(100, mean=9, sd=1)

# Check error detection --
two.cdfs.plot(x1,x2)

# Typical use --
two.cdfs.plot(x1, x2, c("X1","X2"), xlab="Height (metres)", log="x")

# Send args into ks.test() --
two.cdfs.plot(x1, x2, c("X1","X2"), alternative="less")

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/p10.r


# Example : 1    Chapter  :  2.3   page no  :  57
#Matrix multiplication as dotproduct of row and column
A<-matrix(c(3,4,5,6),nrow=2,ncol=2,byrow=T)
x<-c(2,1)
B<-A%*%x
B
Ax<-c()
for(i in 1:2){
  Ax<-c(Ax,sum(A[i,]*x))
}
Ax<-matrix(Ax,ncol=1)
Ax


next.perm <- function(p) {
  n <- length(p)
  i <- n - 1
  r = T
  for (i in seq(n - 1, 1)) {
    if (p[i] < p[i + 1]) {
      r = F
      break
    }
  }

  j <- i + 1
  k <- n
  while (j < k) {
    x <- p[j]
    p[j] <- p[k]
    p[k] <- x
    j <- j + 1
    k <- k - 1
  }

  if(r) return(NULL)

  j <- n
  while (p[j] > p[i]) j <- j - 1
  j <- j + 1

  x <- p[i]
  p[i] <- p[j]
  p[j] <- x
  return(p)
}

print.perms <- function(n) {
  p <- 1:n
  while (!is.null(p)) {
    cat(p, "\n")
    p <- next.perm(p)
  }
}

print.perms(3)
# 1 2 3
# 1 3 2
# 2 1 3
# 2 3 1
# 3 1 2
# 3 2 1


# #This will be a different path if in the lab or at home
# dird="E:\\OneDrive\\MATH4753\\DATAxls\\" # 2017
#
# #my function to read data
# myread=function(csv){
#   fl=paste(dird,csv,sep="")
#   read.table(fl,header=TRUE,sep=",")
# }
# #EASY WAY TO READ IN FILES

#spruce.df=myread("SPRUCE.csv")#MS pg478

spruce.df = read.csv("SPRUCE.csv")

#with(spruce.df, dput(list(D=BHDiameter,H=Height),
                     #file="spruce.dat"))
# Or use
#spruce.df=read.table(file.choose(),header=TRUE,sep=",")

#get wd
getwd()

#Top six lines
tail(spruce.df)

#Plot the points
windows()

plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

library(ggplot2)
windows()
g = ggplot(spruce.df,mapping = aes(x = BHDiameter, y = Height)) +
  geom_point()
print(g)

g = g+ geom_smooth(formula = y~ log(x), method = "lm", col = "steelblue")
g = g + geom_smooth(formula = y ~ x, method = "lm", col = "Black")
g = g + geom_smooth(formula = y~ x+ I(x^2), method ="lm", col = "Red")
print(g)

g = g + geom_smooth(formula = y~ poly(x,3), method ="lm", col = "green3")
g

#load s20x library and make lowess smoother
library(s20x)

trendscatter(Height~BHDiameter,f=0.5,data=spruce.df)
# Now make the linear model
spruce.lm=lm(Height~BHDiameter,data=spruce.df)
summary(spruce.lm)
#residuals  created from the linear model object
height.res=residuals(spruce.lm)

#fitted values made from the linear model object
height.fit=fitted(spruce.lm)

windows()
#Make the plot using the plot function
plot(height.fit,height.res)

# Put a lowess smoother through res vs fitted
trendscatter( height.fit,height.res)

# Quick way to make a residual plot
plot(spruce.lm, which =1)

# Two plots testing normality
windows()
normcheck(spruce.lm,shapiro.wilk = TRUE)

## Quadratic object using the linear model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(quad.lm)
add1(spruce.lm,.~.+I(BHDiameter^2))
anova(spruce.lm)
anova(quad.lm)
anova(spruce.lm,quad.lm)
cubic.lm=lm(Height~BHDiameter + I(BHDiameter^2)+I(BHDiameter^3),data=spruce.df)
anova(cubic.lm)
add1(quad.lm,.~.+I(BHDiameter^3))
#add to the scatter plot
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

coef(quad.lm)
names(quad.lm)
quad.lm$coef[2]

myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

 #Or more general method
myplot=function(x){
 quad.lm$coef[1] +quad.lm$coef[2]*x  + quad.lm$coef[3]*x^2
 }

curve(myplot, lwd=2, col="steelblue",add=TRUE)

plot(quad.lm, which=1)

plot(spruce.lm,which=1)
normcheck(quad.lm,shapiro.wilk = TRUE)

summary(quad.lm)

predict(quad.lm, data.frame(BHDiameter=c(3,6,8)))

ciReg(quad.lm)

predict(quad.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm,quad.lm)

data = 15:24
predict20x(quad.lm,data.frame(BHDiameter = data, `I(BhDiameter)^2`=data^2))

anova(quad.lm)
anova(spruce.lm)

height.qfit=fitted(quad.lm)

RSS=with(spruce.df, sum((Height-height.qfit)^2))
RSS
MSS = with(spruce.df, sum((height.qfit-mean(Height))^2))
MSS

TSS = with(spruce.df, sum((Height-mean(Height))^2))
TSS

MSS/TSS

cooks20x(quad.lm)

#Now remove the 24th datum and reanalyze data

quad2.lm=lm(Height~BHDiameter + I(BHDiameter^2) , data=spruce.df[-24,])
summary(quad2.lm)
summary(quad.lm)

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

#some other code you might need
#The following code plots residuals
windows()
#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#Make a quadratic model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)

# Find the coefficients
coef(quad.lm)

#Make a function that produces heights for inputs "x"
myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

# add the quadratic to the points
curve(myplot, lwd=2, col="steelblue",add=TRUE)

#Place segments (residuals) on the plot (except for the 3 largest cooks distances. 18, 21, 24)
with(spruce.df[-c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[-c(18,21,24)]) )
with(spruce.df[c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[c(18,21,24)], col="Red", lwd=3) )
with( spruce.df, arrows(5,Height[24], BHDiameter[24], Height[24],lwd=2,col="Blue"))
with(spruce.df,text(2,Height[24], paste("Highest Cook's","\n", "distance",sep=" ")))
with(spruce.df, text(BHDiameter,Height, 1:36,cex=0.5,pos=4))
 #########################################################################

layout(matrix(1:4,nr=2,nc=2,byrow=TRUE))

#Lets look at where the plots will go
layout.show(4)

#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)
# add the line
abline(spruce.lm)

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

abline(spruce.lm)

#make yhat the estimates of E[Height | BHDiameter]
yhat=with(spruce.df,predict(spruce.lm,data.frame(BHDiameter)))
yhat=fitted(spruce.lm)
# Draw in segments making the residuals (regression errors)
with(spruce.df,{
segments(BHDiameter,Height,BHDiameter,yhat)
})

RSS=with(spruce.df,sum((Height-yhat)^2))

RSS

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#make nieve model
with(spruce.df, abline(h=mean(Height)))
abline(spruce.lm)

#make the explained errors (explained by the model)
with(spruce.df, segments(BHDiameter,mean(Height),BHDiameter,yhat,col="Red"))
MSS=with(spruce.df,sum((yhat-mean(Height))^2))
MSS

# Total  error
#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

with(spruce.df,abline(h=mean(Height)))
with(spruce.df, segments(BHDiameter,Height,BHDiameter,mean(Height),col="Green"))
TSS=with(spruce.df,sum((Height-mean(Height))^2))
TSS
RSS + MSS
MSS/TSS

summary(spruce.lm)

#obtain coefft values
coef(spruce.lm)

#Calculate new y values given x
predict(spruce.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm)

spruce2.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(spruce2.lm)

### More on the problem
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
     ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
     main="Spruce height prediction",data=spruce.df)

yhatt=with(spruce.df,fitted(spruce2.lm))
with(spruce.df,plot(BHDiameter,yhatt,col="Red")
)

sum(residuals(spruce2.lm)^2)
plot(yhatt~BHDiameter,data=spruce.df,type="p")
summary(spruce2.lm)
anova(spruce2.lm)
anova(spruce.lm,spruce2.lm)
MSS
RSS

## piecewise linear model in R
## Model y = b0 + b1x + b2(x-xk)*(x>xk)
## You will need to change the code appropriately
sp2.df=within(spruce.df, X<-(BHDiameter-20)*(BHDiameter>20)) # this makes a new variable and places it within the same df
sp2.df

lmp=lm(Height~BHDiameter + X,data=sp2.df)
tmp=summary(lmp)
names(tmp)
myf = function(x,coef){
  coef[1]+coef[2]*(x) + coef[3]*(x-18)*(x-18>0)
}
plot(spruce.df,main="Piecewise regression")
myf(0, coef=tmp$coefficients[,"Estimate"])
curve(myf(x,coef=tmp$coefficients[,"Estimate"] ),add=TRUE, lwd=2,col="Blue")
abline(v=18)
text(18,16,paste("R sq.=",round(tmp$r.squared,4) ))


General_Euler <- function(num_of_paths, num_of_steps, mu, sigma, Texp=1, X0=0, convert_y_to_x=function(y) y, convert_x_to_y=function(x) x){
    # 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 (integer): The number of Monte Carlo paths
    #     num_of_steps (integer): The number of steps in each Monte Carlo path
    #     mu (function): The drift coefficient, a function of t (numeric) and X (array-like) returning a scalar
    #     sigma (function): The diffusion coefficient, a function of t (numeric) and X (array-like) returning a scalar
    #     Texp (Optional[numeric]): Time, in years, to simulate process.  Defaults to 1.
    #     X0 (Optional[numeric]): Initial value for the estimator process, X. Defaults to 0.
    #     convert_y_to_x (Optional[function]): A function to convert Y_t to X_t. Defaults to X_t <- Y_t
    #     convert_x_to_y (Optional[function]): A function to convert X_t to Y_t. Defaults to Y_t <- X_t
    # Raises:
    #     Error: If mu is not a function.
    #     Error: If sigma is not a function.
    # Returns:
    #     (list of function(s)):  Currently returns a list holding a function which runs a simulation
    if (!is.function(mu)) stop('mu must be a function')
    if (!is.function(sigma)) stop('sigma must be a function')

    dt <- Texp / num_of_steps
    Y0 <- convert_x_to_y(X0)

    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 (no plot). If TRUE, defaults to 100.
        # Returns:
        #     (array-like): A array of E[g(X_T)] for the range of strikes

        # Simulates the process X_t across time.
        # X is a 2-dimensional matrix with each row representing a path and each entry within it a single timestep.

        dW <- matrix(rnorm(num_of_paths*num_of_steps,sd=sqrt(dt)), nrow=num_of_paths, ncol=num_of_steps)

        # Generate the process Y using the Lamperti transform version of the process X

        # Initialize Y0. More efficient to just initialize all values as Y0
        Y <- matrix(Y0, nrow=num_of_paths, ncol=num_of_steps+1)

        # Step through time
        for (i in 1:num_of_steps){
            t <- (i-1)*dt
            Y[,i+1] <- Y[,i] + mu(t, Y[,i]) * dt + sigma(t, Y[,i]) * dW[,i]
        }

        # Plotting
        if (num_paths_to_plot != FALSE){ # Plots the first num_paths_to_plot paths.
            if (num_paths_to_plot == TRUE) num_paths_to_plot <- 100 # Default value
            num_paths_to_plot <- min(num_paths_to_plot, num_of_paths)
            #matplot plots columns so we transpose
            matplot(seq(0, Texp, Texp/num_of_steps), t(convert_y_to_x(Y[1:num_paths_to_plot,])), main=sprintf('Generated paths (first %i paths) - Euler scheme',num_paths_to_plot), xlab='t', ylab='X_t', type='l', lty=1)
        }

        # Final prices for each path (Undo the Lamperti transform)
        X_Ts <- convert_y_to_x(Y[,ncol(Y)])

        # Returns the mean of psi across all paths for each strike
        # return(vapply(strikes, function(K) mean(g_maker(K)(X_Ts)), FUN.VALUE=1))

        # Calculates prices for each path by row, each strike by column
        price_matrix <- vapply(strikes, function(K) g_maker(K)(X_Ts), FUN.VALUE=numeric(num_of_paths))
        print(data.frame(K=strikes, Variance=diag(var(price_matrix)))) # Diagonals of cov mtx are column variances
        return(colMeans(price_matrix))
    }

    # Return a list holding the function so we can call it object oriented style
    return(list(run_monte_carlo=run_monte_carlo))
}


#' convert quantile to normal with mean 0.5 and variance such that ci% are found within the range (0,1)

quantile_to_normal = function( x, mean =0.5, ci=0.999 ) {

  xmin = min( x[ which(x>0) ], na.rm=T )
  xmax = max( x[ which(x<1) ], na.rm=T )

  pr = {1 - ci} / 2  # one-tailed prob in normal approximation desired
  zsd = 2 * abs( qnorm( pr, mean=0, sd=1) )  # range in x required to have ci% of the population, two tailed
  rsd = 1 / zsd # sd required for population to fit in (0,1)

  zscore = qnorm( x, mean=mean, sd=rsd )

  xx = which( x>=1 | zscore > 1)
  if (length(xx) > 0 ) zscore[ xx ] = 1

  nn = which( x<=0 | zscore < 0)
  if (length(nn) > 0 ) zscore[ nn ] = 0

  return (zscore)
}


#install.packages("GA")
library(GA)

# Funkcja przykładowa z dokumentacji
# f <- function(x) (x^2+x)*cos(x) # Badana funkcja
# lbound <- -10 # Dolne ograniczenie funkcji
# rbound <- 10 # Górne ogranicznie funkcji

f <- function(x) x*sin(10*pi*x)+1
lbound <- -1
rbound <- 2

fA <- function(x) -f(x) # Funkcja odwrotna do badanej, ponieważ minimalizujemy funkcję

# Genetic algorithm
GA <- ga(
   type = "real-valued",
   fitness = fA,
   lower = c(th = lbound), upper = rbound,
   popSize = 50, maxiter = 1000, run = 100
)
summary(GA)
plot(GA)

curve(f, from = lbound, to = rbound, 1000) # rysowanie wykresy funkcji
#points(GA@solution, GA@fitnessValue, col = 2, pch = 19) # ozaczanie punktu na wykresie / tutaj szukanego ekstremum w zakresie
points(GA@solution, f(GA@solution), col = 2, pch = 19) # Musimy uzyskać wartość z funkcji wyjściowej, gdyż badamy funkcje odwrotną


point_in_polygon <- function(polygon, p) {
  count <- 0
  for(side in polygon) {
    if ( ray_intersect_segment(p, side) ) {
      count <- count + 1
    }
  }
  if ( count %% 2 == 1 )
    "INSIDE"
  else
    "OUTSIDE"
}

ray_intersect_segment <- function(p, side) {
  eps <- 0.0001
  a <- side$A
  b <- side$B
  if ( a$y > b$y ) {
    a <- side$B
    b <- side$A
  }
  if ( (p$y == a$y) || (p$y == b$y) ) {
    p$y <- p$y + eps
  }
  if ( (p$y < a$y) || (p$y > b$y) )
    return(FALSE)
  else if ( p$x > max(a$x, b$x) )
    return(FALSE)
  else {
    if ( p$x < min(a$x, b$x) )
      return(TRUE)
    else {
      if ( a$x != b$x )
        m_red <- (b$y - a$y) / (b$x - a$x)
      else
        m_red <- Inf
      if ( a$x != p$x )
        m_blue <- (p$y - a$y) / (p$x - a$x)
      else
        m_blue <- Inf
      return( m_blue >= m_red )
    }
  }
}


StandardizeFeatures<-function(training.set,test.set=NULL,stddev=FALSE) {
	# Subtracts away mean feature vector in each column, given a dataset
	# (assumes no subject.id column); can also divide by std deviation
	#
	# Args:
	#	training.set: dataset of training variables
	#	test.set: dataset of test variables
	#	- if NULL, training set is standardized with training variables
	#	- if given, test set is standardized with training variables
	#	sd: switch for whether standard deviations are divided
	#
	# Returns:
	#	  a dataset standardized columns

  	# Calculate mean and sd vector
	mean<-apply(training.set,2,mean,na.rm=TRUE)
	sd<-apply(training.set,2,sd,na.rm=TRUE)

 	if (is.null(test.set)) {
  		training.set<-sweep(training.set,2,mean,"-")
  		if (!stddev) {
  			return(training.set)
  		}
  		else {
  			return(sweep(training.set,2,sd,"/"))
  		}
	}
	else {
		test.set<-sweep(test.set,2,mean,"-")
		if (!stddev) {
			return(test.set)
		}
		else {
			 return(sweep(test.set,2,sd,"/"))
		}
	}
}

#mean slope: -5.325687e-01
#sd slope: 1.076365e+00