# ----------------------------------------
#  App Title: Chaos Game -- 3 Dimensions
#     Author: Jimmy Doi
# ----------------------------------------

###################################################################
# Tetrahedron
###################################################################

tetra.gen <- function(wt){
    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=4,nrow=4)

		loci[1,] <- c(1,1,0,-1/sqrt(2))
		loci[2,] <- c(2,-1,0,-1/sqrt(2))
		loci[3,] <- c(3,0,1,1/sqrt(2))
  	loci[4,] <- c(4,0,-1,1/sqrt(2))

    # vertices contains all random vertex points
    vertices <- runif(len)
    vertices[which(vertices>3/4)]<- 4
    vertices[which(2/4<vertices & vertices<=3/4)]<- 3
    vertices[which(1/4<vertices & vertices<=2/4)]<- 2
    vertices[which(vertices<=1/4)]<- 1

    coords <- matrix(NA,ncol=4,nrow=(len+1))

    coords[1,] <- c(runif(1),runif(1)*sqrt(3)/2,runif(1)*sqrt(6)/3,0)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      z <- loci[spot,4]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
      z.new <- weight*z + (1-weight)*coords[i,3]
	    coords[row,]<-c(x.new,y.new,z.new,0)
		}

    for (i in 1:(len+1)){
      d1 <- sqrt((coords[i,1]-loci[1,2])**2 + (coords[i,2]-loci[1,3])**2 + (coords[i,3]-loci[1,4])**2)
      d2 <- sqrt((coords[i,1]-loci[2,2])**2 + (coords[i,2]-loci[2,3])**2 + (coords[i,3]-loci[2,4])**2)
      d3 <- sqrt((coords[i,1]-loci[3,2])**2 + (coords[i,2]-loci[3,3])**2 + (coords[i,3]-loci[3,4])**2)
      d4 <- sqrt((coords[i,1]-loci[4,2])**2 + (coords[i,2]-loci[4,3])**2 + (coords[i,3]-loci[4,4])**2)
      if (min(d1,d2,d3,d4)==d1) coords[i,4]<-1
      if (min(d1,d2,d3,d4)==d2) coords[i,4]<-2
      if (min(d1,d2,d3,d4)==d3) coords[i,4]<-3
      if (min(d1,d2,d3,d4)==d4) coords[i,4]<-4
    }

    return(list(loci,vertices,coords))
}

###################################################################
# Cube
###################################################################

cube.gen <- function(wt){
    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=4,nrow=20)

		loci[1,]  <-  c(1,0,0,0)
		loci[2,]  <-  c(2,.5,0,0)
		loci[3,]  <-  c(3,1,0,0)
  	loci[4,]  <-  c(4,1,.5,0)
    loci[5,]  <-  c(5,1,1,0)
    loci[6,]  <-  c(6,.5,1,0)
    loci[7,]  <-  c(7,0,1,0)
    loci[8,]  <-  c(8,0,.5,0)
    loci[9,]  <-  c(9,1,0,.5)
    loci[10,] <- c(10,0,0,.5)
    loci[11,] <- c(11,0,1,.5)
    loci[12,] <- c(12,1,1,.5)
  	loci[13,] <- c(13,0,0,1)
		loci[14,] <- c(14,.5,0,1)
		loci[15,] <- c(15,1,0,1)
  	loci[16,] <- c(16,1,.5,1)
    loci[17,] <- c(17,1,1,1)
    loci[18,] <- c(18,.5,1,1)
    loci[19,] <- c(19,0,1,1)
    loci[20,] <- c(20,0,.5,1)

    # vertices contains all random vertex points
    vertices <- runif(len)
    vertices[which(vertices>19/20)]<- 20
    vertices[which(18/20<vertices & vertices<=19/20)]<- 19
    vertices[which(17/20<vertices & vertices<=18/20)]<- 18
    vertices[which(16/20<vertices & vertices<=17/20)]<- 17
    vertices[which(15/20<vertices & vertices<=16/20)]<- 16
    vertices[which(14/20<vertices & vertices<=15/20)]<- 15
    vertices[which(13/20<vertices & vertices<=14/20)]<- 14
    vertices[which(12/20<vertices & vertices<=13/20)]<- 13
    vertices[which(11/20<vertices & vertices<=12/20)]<- 12
    vertices[which(10/20<vertices & vertices<=11/20)]<- 11
    vertices[which(9/20<vertices & vertices<= 10/20)]<- 10
    vertices[which(8/20<vertices & vertices<= 9/20)]<- 9
    vertices[which(7/20<vertices & vertices<= 8/20)]<- 8
    vertices[which(6/20<vertices & vertices<= 7/20)]<- 7
    vertices[which(5/20<vertices & vertices<= 6/20)]<- 6
    vertices[which(4/20<vertices & vertices<= 5/20)]<- 5
    vertices[which(3/20<vertices & vertices<= 4/20)]<- 4
    vertices[which(2/20<vertices & vertices<= 3/20)]<- 3
    vertices[which(1/20<vertices & vertices<= 2/20)]<- 2
    vertices[which(vertices<=1/20)]<- 1

    coords <- matrix(NA,ncol=4,nrow=(len+1))

    coords[1,] <- c(runif(1),runif(1),runif(1),0)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      z <- loci[spot,4]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
      z.new <- weight*z + (1-weight)*coords[i,3]
	    coords[row,]<-c(x.new,y.new,z.new,0)
		}

    for (i in 1:(len+1)){
      d1 <- sqrt((coords[i,1]-loci[1,2])**2 + (coords[i,2]- loci[1,3])**2 + (coords[i,3]- loci[1,4])**2)
      d2 <- sqrt((coords[i,1]-loci[2,2])**2 + (coords[i,2]- loci[2,3])**2 + (coords[i,3]- loci[2,4])**2)
      d3 <- sqrt((coords[i,1]-loci[3,2])**2 + (coords[i,2]- loci[3,3])**2 + (coords[i,3]- loci[3,4])**2)
      d4 <- sqrt((coords[i,1]-loci[4,2])**2 + (coords[i,2]- loci[4,3])**2 + (coords[i,3]- loci[4,4])**2)
      d5 <- sqrt((coords[i,1]-loci[5,2])**2 + (coords[i,2]- loci[5,3])**2 + (coords[i,3]- loci[5,4])**2)
      d6 <- sqrt((coords[i,1]-loci[6,2])**2 + (coords[i,2]- loci[6,3])**2 + (coords[i,3]- loci[6,4])**2)
      d7 <- sqrt((coords[i,1]-loci[7,2])**2 + (coords[i,2]- loci[7,3])**2 + (coords[i,3]- loci[7,4])**2)
      d8 <- sqrt((coords[i,1]-loci[8,2])**2 + (coords[i,2]- loci[8,3])**2 + (coords[i,3]- loci[8,4])**2)
      d9 <- sqrt((coords[i,1]-loci[9,2])**2 + (coords[i,2]- loci[9,3])**2 + (coords[i,3]- loci[9,4])**2)
      d10<- sqrt((coords[i,1]-loci[10,2])**2 + (coords[i,2]-loci[10,3])**2 + (coords[i,3]-loci[10,4])**2)
      d11<- sqrt((coords[i,1]-loci[11,2])**2 + (coords[i,2]-loci[11,3])**2 + (coords[i,3]-loci[11,4])**2)
      d12<- sqrt((coords[i,1]-loci[12,2])**2 + (coords[i,2]-loci[12,3])**2 + (coords[i,3]-loci[12,4])**2)
      d13<- sqrt((coords[i,1]-loci[13,2])**2 + (coords[i,2]-loci[13,3])**2 + (coords[i,3]-loci[13,4])**2)
      d14<- sqrt((coords[i,1]-loci[14,2])**2 + (coords[i,2]-loci[14,3])**2 + (coords[i,3]-loci[14,4])**2)
      d15<- sqrt((coords[i,1]-loci[15,2])**2 + (coords[i,2]-loci[15,3])**2 + (coords[i,3]-loci[15,4])**2)
      d16<- sqrt((coords[i,1]-loci[16,2])**2 + (coords[i,2]-loci[16,3])**2 + (coords[i,3]-loci[16,4])**2)
      d17<- sqrt((coords[i,1]-loci[17,2])**2 + (coords[i,2]-loci[17,3])**2 + (coords[i,3]-loci[17,4])**2)
      d18<- sqrt((coords[i,1]-loci[18,2])**2 + (coords[i,2]-loci[18,3])**2 + (coords[i,3]-loci[18,4])**2)
      d19<- sqrt((coords[i,1]-loci[19,2])**2 + (coords[i,2]-loci[19,3])**2 + (coords[i,3]-loci[19,4])**2)
      d20<- sqrt((coords[i,1]-loci[20,2])**2 + (coords[i,2]-loci[20,3])**2 + (coords[i,3]-loci[20,4])**2)
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d1) coords[i,4]<-1
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d2) coords[i,4]<-2
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d3) coords[i,4]<-3
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d4) coords[i,4]<-4
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d5) coords[i,4]<-5
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d6) coords[i,4]<-6
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d7) coords[i,4]<-7
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d8) coords[i,4]<-8
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d9) coords[i,4]<-9
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d10) coords[i,4]<-10
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d11) coords[i,4]<-11
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d12) coords[i,4]<-12
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d13) coords[i,4]<-13
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d14) coords[i,4]<-14
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d15) coords[i,4]<-15
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d16) coords[i,4]<-16
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d17) coords[i,4]<-17
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d18) coords[i,4]<-18
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d19) coords[i,4]<-19
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d20) coords[i,4]<-20
    }

    return(list(loci,vertices,coords))
}

###################################################################
# Dodecahedron
###################################################################

dodec.gen <- function(wt){
    weight <- wt

    len <- 50000

    # loci matrix to contain all endpoints
		loci <- matrix(NA,ncol=4,nrow=20)

    psi <- (1+sqrt(5))/2

		loci[1,]  <-   c(1,1,-1,1)
		loci[2,]  <-   c(2,1,1,-1)
		loci[3,]  <-   c(3,psi,0,-1/psi)
  	loci[4,]  <-   c(4,1,1,1)
    loci[5,]  <-   c(5,-1,1,1)
    loci[6,]  <-   c(6,-1,1,-1)
    loci[7,]  <-   c(7,1/psi,psi,0)
    loci[8,]  <-   c(8,0,1/psi,psi)
    loci[9,]  <-   c(9,-psi,0,-1/psi)
    loci[10,] <-  c(10,0,-1/psi,-psi)
    loci[11,] <-  c(11,0,-1/psi,psi)
    loci[12,] <-  c(12,0,1/psi,-psi)
  	loci[13,] <-  c(13,-1/psi,psi,0)
		loci[14,] <-  c(14,-psi,0,1/psi)
		loci[15,] <-  c(15,-1,-1,1)
  	loci[16,] <-  c(16,-1/psi,-psi,0)
    loci[17,] <-  c(17,psi,0,1/psi)
    loci[18,] <-  c(18,1,-1,-1)
    loci[19,] <-  c(19,1/psi,-psi,0)
    loci[20,] <-  c(20,-1,-1,-1)

    # vertices contains all random vertex points
    vertices <- runif(len)
    vertices[which(vertices>19/20)]<- 20
    vertices[which(18/20<vertices & vertices<=19/20)]<- 19
    vertices[which(17/20<vertices & vertices<=18/20)]<- 18
    vertices[which(16/20<vertices & vertices<=17/20)]<- 17
    vertices[which(15/20<vertices & vertices<=16/20)]<- 16
    vertices[which(14/20<vertices & vertices<=15/20)]<- 15
    vertices[which(13/20<vertices & vertices<=14/20)]<- 14
    vertices[which(12/20<vertices & vertices<=13/20)]<- 13
    vertices[which(11/20<vertices & vertices<=12/20)]<- 12
    vertices[which(10/20<vertices & vertices<=11/20)]<- 11
    vertices[which(9/20<vertices & vertices<= 10/20)]<- 10
    vertices[which(8/20<vertices & vertices<= 9/20)]<- 9
    vertices[which(7/20<vertices & vertices<= 8/20)]<- 8
    vertices[which(6/20<vertices & vertices<= 7/20)]<- 7
    vertices[which(5/20<vertices & vertices<= 6/20)]<- 6
    vertices[which(4/20<vertices & vertices<= 5/20)]<- 5
    vertices[which(3/20<vertices & vertices<= 4/20)]<- 4
    vertices[which(2/20<vertices & vertices<= 3/20)]<- 3
    vertices[which(1/20<vertices & vertices<= 2/20)]<- 2
    vertices[which(vertices<=1/20)]<- 1

    coords <- matrix(NA,ncol=4,nrow=(len+1))

    coords[1,] <- c(runif(1),runif(1),runif(1),0)

		for (i in 1:len){
		  row <- i+1
      spot <- which(loci[,1]==vertices[i])
      x <- loci[spot,2]
      y <- loci[spot,3]
      z <- loci[spot,4]
      x.new <- weight*x + (1-weight)*coords[i,1]
      y.new <- weight*y + (1-weight)*coords[i,2]
      z.new <- weight*z + (1-weight)*coords[i,3]
	    coords[row,]<-c(x.new,y.new,z.new,0)
		}

        for (i in 1:(len+1)){
      d1 <- sqrt((coords[i,1]-loci[1,2])**2 + (coords[i,2]- loci[1,3])**2 + (coords[i,3]- loci[1,4])**2)
      d2 <- sqrt((coords[i,1]-loci[2,2])**2 + (coords[i,2]- loci[2,3])**2 + (coords[i,3]- loci[2,4])**2)
      d3 <- sqrt((coords[i,1]-loci[3,2])**2 + (coords[i,2]- loci[3,3])**2 + (coords[i,3]- loci[3,4])**2)
      d4 <- sqrt((coords[i,1]-loci[4,2])**2 + (coords[i,2]- loci[4,3])**2 + (coords[i,3]- loci[4,4])**2)
      d5 <- sqrt((coords[i,1]-loci[5,2])**2 + (coords[i,2]- loci[5,3])**2 + (coords[i,3]- loci[5,4])**2)
      d6 <- sqrt((coords[i,1]-loci[6,2])**2 + (coords[i,2]- loci[6,3])**2 + (coords[i,3]- loci[6,4])**2)
      d7 <- sqrt((coords[i,1]-loci[7,2])**2 + (coords[i,2]- loci[7,3])**2 + (coords[i,3]- loci[7,4])**2)
      d8 <- sqrt((coords[i,1]-loci[8,2])**2 + (coords[i,2]- loci[8,3])**2 + (coords[i,3]- loci[8,4])**2)
      d9 <- sqrt((coords[i,1]-loci[9,2])**2 + (coords[i,2]- loci[9,3])**2 + (coords[i,3]- loci[9,4])**2)
      d10<- sqrt((coords[i,1]-loci[10,2])**2 + (coords[i,2]-loci[10,3])**2 + (coords[i,3]-loci[10,4])**2)
      d11<- sqrt((coords[i,1]-loci[11,2])**2 + (coords[i,2]-loci[11,3])**2 + (coords[i,3]-loci[11,4])**2)
      d12<- sqrt((coords[i,1]-loci[12,2])**2 + (coords[i,2]-loci[12,3])**2 + (coords[i,3]-loci[12,4])**2)
      d13<- sqrt((coords[i,1]-loci[13,2])**2 + (coords[i,2]-loci[13,3])**2 + (coords[i,3]-loci[13,4])**2)
      d14<- sqrt((coords[i,1]-loci[14,2])**2 + (coords[i,2]-loci[14,3])**2 + (coords[i,3]-loci[14,4])**2)
      d15<- sqrt((coords[i,1]-loci[15,2])**2 + (coords[i,2]-loci[15,3])**2 + (coords[i,3]-loci[15,4])**2)
      d16<- sqrt((coords[i,1]-loci[16,2])**2 + (coords[i,2]-loci[16,3])**2 + (coords[i,3]-loci[16,4])**2)
      d17<- sqrt((coords[i,1]-loci[17,2])**2 + (coords[i,2]-loci[17,3])**2 + (coords[i,3]-loci[17,4])**2)
      d18<- sqrt((coords[i,1]-loci[18,2])**2 + (coords[i,2]-loci[18,3])**2 + (coords[i,3]-loci[18,4])**2)
      d19<- sqrt((coords[i,1]-loci[19,2])**2 + (coords[i,2]-loci[19,3])**2 + (coords[i,3]-loci[19,4])**2)
      d20<- sqrt((coords[i,1]-loci[20,2])**2 + (coords[i,2]-loci[20,3])**2 + (coords[i,3]-loci[20,4])**2)
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d1) coords[i,4]<-1
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d2) coords[i,4]<-2
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d3) coords[i,4]<-3
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d4) coords[i,4]<-4
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d5) coords[i,4]<-5
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d6) coords[i,4]<-6
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d7) coords[i,4]<-7
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d8) coords[i,4]<-8
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d9) coords[i,4]<-9
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d10) coords[i,4]<-10
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d11) coords[i,4]<-11
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d12) coords[i,4]<-12
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d13) coords[i,4]<-13
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d14) coords[i,4]<-14
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d15) coords[i,4]<-15
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d16) coords[i,4]<-16
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d17) coords[i,4]<-17
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d18) coords[i,4]<-18
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d19) coords[i,4]<-19
      if (min(d1,d2,d3,d4,d5,d6,d7,d8,d9,d10,d11,d12,d13,d14,d15,d16,d17,d18,d19,d20)==d20) coords[i,4]<-20
    }

    return(list(loci,vertices,coords))
}

##############################################################################
# Shiny Server Contents
##############################################################################

shinyServer(function(input, output, session) {

  updateButton(session, "gen", style = "primary", size = "default", disabled = FALSE)

  all.list <- reactive({
        withProgress(message = 'Generating Coordinates', style = 'notification', value = 1, {
    if (input$shape == "tetra") {
      return(tetra.gen(input$dist.tetra*(input$gen>-1)))
      }
    if (input$shape == "cube") {
      return(cube.gen(input$dist.cube*(input$gen>-1)))
      }
    if (input$shape == "dodec") {
      return(dodec.gen(input$dist.dodec*(input$gen>-1)))
      }
    }) #CLOSE withProgress

  })

  output$sctPlot <- renderRglwidget({
    withProgress(message = 'Please wait up to 15 seconds', style = 'notification', value = 1, {
    try(rgl.close())
    withProgress(message = 'Generating Plot', style = 'notification', value = 1, {
    loci      <- all.list()[[1]]
    vertices  <- all.list()[[2]]
    coords    <- all.list()[[3]]

    if (max(coords[,4]==4)) {
    set1 <- coords[coords[,4]==1,1:3]
    set2 <- coords[coords[,4]==2,1:3]
    set3 <- coords[coords[,4]==3,1:3]
    set4 <- coords[coords[,4]==4,1:3]

    col1 <- brewer.pal(n = 12, name = "Paired")[2]
    col2 <- brewer.pal(n = 12, name = "Paired")[4]
    col3 <- brewer.pal(n = 12, name = "Paired")[8]
    col4 <- brewer.pal(n = 12, name = "Paired")[10]

    points3d(set1[1:round(nrow(set1)*(input$pts/100),0),1],
             set1[1:round(nrow(set1)*(input$pts/100),0),2],
             set1[1:round(nrow(set1)*(input$pts/100),0),3],
             size = 1.25,col=col1)

    points3d(set2[1:round(nrow(set2)*(input$pts/100),0),1],
             set2[1:round(nrow(set2)*(input$pts/100),0),2],
             set2[1:round(nrow(set2)*(input$pts/100),0),3],
             size = 1.25,col=col2)

    points3d(set3[1:round(nrow(set3)*(input$pts/100),0),1],
             set3[1:round(nrow(set3)*(input$pts/100),0),2],
             set3[1:round(nrow(set3)*(input$pts/100),0),3],
             size = 1.25,col=col3)

    points3d(set4[1:round(nrow(set4)*(input$pts/100),0),1],
             set4[1:round(nrow(set4)*(input$pts/100),0),2],
             set4[1:round(nrow(set4)*(input$pts/100),0),3],
             size = 1.25,col=col4)
    }

    if (max(coords[,4]==20)) {
    set1 <- coords[coords[,4]==1,1:3]
    set2 <- coords[coords[,4]==2,1:3]
    set3 <- coords[coords[,4]==3,1:3]
    set4 <- coords[coords[,4]==4,1:3]
    set5 <- coords[coords[,4]==5,1:3]
    set6 <- coords[coords[,4]==6,1:3]
    set7 <- coords[coords[,4]==7,1:3]
    set8 <- coords[coords[,4]==8,1:3]
    set9 <- coords[coords[,4]==9,1:3]
    set10<- coords[coords[,4]==10,1:3]
    set11<- coords[coords[,4]==11,1:3]
    set12<- coords[coords[,4]==12,1:3]
    set13<- coords[coords[,4]==13,1:3]
    set14<- coords[coords[,4]==14,1:3]
    set15<- coords[coords[,4]==15,1:3]
    set16<- coords[coords[,4]==16,1:3]
    set17<- coords[coords[,4]==17,1:3]
    set18<- coords[coords[,4]==18,1:3]
    set19<- coords[coords[,4]==19,1:3]
    set20<- coords[coords[,4]==20,1:3]

    col1 <- brewer.pal(n = 12, name = "Paired")[2]  #dark blue
    col2 <- brewer.pal(n = 12, name = "Paired")[4]  #dark green
    col3 <- brewer.pal(n = 12, name = "Paired")[6]  #red
    col4 <- brewer.pal(n = 12, name = "Paired")[8]  #orange
    col5 <- brewer.pal(n = 11, name = "RdBu")[11]   #DarkBl
    col6 <- brewer.pal(n = 12, name = "Paired")[12] #brown
    col7 <- brewer.pal(n = 8, name = "Dark2")[8]    #grey
    col8 <- brewer.pal(n = 8, name = "Accent")[6]   #dark pink
    col20 <- col8
    col19 <- col7
    col18 <- col6
    col17 <- col5
    col16 <- col4
    col15 <- col3
    col14 <- col2
    col13 <- col1
    col12 <- brewer.pal(n = 11, name = "BrBG")[9]   #SoftBl
    col9  <- brewer.pal(n = 11, name = "RdBu")[11]  #DarkBl
    col11 <- brewer.pal(n = 11, name = "PiYG")[1]   #Maroon
    col10 <- brewer.pal(n = 11, name = "PiYG")[11]  #DarkGrn

    points3d(set1[1:round(nrow(set1)*(input$pts/100),0),1],
             set1[1:round(nrow(set1)*(input$pts/100),0),2],
             set1[1:round(nrow(set1)*(input$pts/100),0),3],
             size = 1.25,col=col1)

    points3d(set2[1:round(nrow(set2)*(input$pts/100),0),1],
             set2[1:round(nrow(set2)*(input$pts/100),0),2],
             set2[1:round(nrow(set2)*(input$pts/100),0),3],
             size = 1.25,col=col2)

    points3d(set3[1:round(nrow(set3)*(input$pts/100),0),1],
             set3[1:round(nrow(set3)*(input$pts/100),0),2],
             set3[1:round(nrow(set3)*(input$pts/100),0),3],
             size = 1.25,col=col3)

    points3d(set4[1:round(nrow(set4)*(input$pts/100),0),1],
             set4[1:round(nrow(set4)*(input$pts/100),0),2],
             set4[1:round(nrow(set4)*(input$pts/100),0),3],
             size = 1.25,col=col4)

    points3d(set5[1:round(nrow(set5)*(input$pts/100),0),1],
             set5[1:round(nrow(set5)*(input$pts/100),0),2],
             set5[1:round(nrow(set5)*(input$pts/100),0),3],
             size = 1.25,col=col5)

    points3d(set6[1:round(nrow(set6)*(input$pts/100),0),1],
             set6[1:round(nrow(set6)*(input$pts/100),0),2],
             set6[1:round(nrow(set6)*(input$pts/100),0),3],
             size = 1.25,col=col6)

    points3d(set7[1:round(nrow(set7)*(input$pts/100),0),1],
             set7[1:round(nrow(set7)*(input$pts/100),0),2],
             set7[1:round(nrow(set7)*(input$pts/100),0),3],
             size = 1.25,col=col7)

    points3d(set8[1:round(nrow(set8)*(input$pts/100),0),1],
             set8[1:round(nrow(set8)*(input$pts/100),0),2],
             set8[1:round(nrow(set8)*(input$pts/100),0),3],
             size = 1.25,col=col8)

    points3d(set9[1:round(nrow(set9)*(input$pts/100),0),1],
             set9[1:round(nrow(set9)*(input$pts/100),0),2],
             set9[1:round(nrow(set9)*(input$pts/100),0),3],
             size = 1.25,col=col9)

    points3d(set10[1:round(nrow(set10)*(input$pts/100),0),1],
             set10[1:round(nrow(set10)*(input$pts/100),0),2],
             set10[1:round(nrow(set10)*(input$pts/100),0),3],
             size = 1.25,col=col10)

    points3d(set11[1:round(nrow(set11)*(input$pts/100),0),1],
             set11[1:round(nrow(set11)*(input$pts/100),0),2],
             set11[1:round(nrow(set11)*(input$pts/100),0),3],
             size = 1.25,col=col11)

    points3d(set12[1:round(nrow(set12)*(input$pts/100),0),1],
             set12[1:round(nrow(set12)*(input$pts/100),0),2],
             set12[1:round(nrow(set12)*(input$pts/100),0),3],
             size = 1.25,col=col12)

    points3d(set13[1:round(nrow(set13)*(input$pts/100),0),1],
             set13[1:round(nrow(set13)*(input$pts/100),0),2],
             set13[1:round(nrow(set13)*(input$pts/100),0),3],
             size = 1.25,col=col13)

    points3d(set14[1:round(nrow(set14)*(input$pts/100),0),1],
             set14[1:round(nrow(set14)*(input$pts/100),0),2],
             set14[1:round(nrow(set14)*(input$pts/100),0),3],
             size = 1.25,col=col14)

    points3d(set15[1:round(nrow(set15)*(input$pts/100),0),1],
             set15[1:round(nrow(set15)*(input$pts/100),0),2],
             set15[1:round(nrow(set15)*(input$pts/100),0),3],
             size = 1.25,col=col15)

    points3d(set16[1:round(nrow(set16)*(input$pts/100),0),1],
             set16[1:round(nrow(set16)*(input$pts/100),0),2],
             set16[1:round(nrow(set16)*(input$pts/100),0),3],
             size = 1.25,col=col16)

    points3d(set17[1:round(nrow(set17)*(input$pts/100),0),1],
             set17[1:round(nrow(set17)*(input$pts/100),0),2],
             set17[1:round(nrow(set17)*(input$pts/100),0),3],
             size = 1.25,col=col17)

    points3d(set18[1:round(nrow(set18)*(input$pts/100),0),1],
             set18[1:round(nrow(set18)*(input$pts/100),0),2],
             set18[1:round(nrow(set18)*(input$pts/100),0),3],
             size = 1.25,col=col18)

    points3d(set19[1:round(nrow(set19)*(input$pts/100),0),1],
             set19[1:round(nrow(set19)*(input$pts/100),0),2],
             set19[1:round(nrow(set19)*(input$pts/100),0),3],
             size = 1.25,col=col19)

    points3d(set20[1:round(nrow(set20)*(input$pts/100),0),1],
             set20[1:round(nrow(set20)*(input$pts/100),0),2],
             set20[1:round(nrow(set20)*(input$pts/100),0),3],
             size = 1.25,col=col20)
    }
    points3d(loci[,2],loci[,3],loci[,4], size=6,col="red")
    rglwidget()
    }) #Close withProgress
    }) #Close withProgress
    })
})


###########################
###logestic regression ####
###########################

glm.fit=glm(income~age+education+capitalGain+capitalLoss+hoursPerWeek+sex
            +race+workclass+maritalStatus+relationship+occupation,data=adult.data,family= binomial)

glm.probs=predict(glm.fit,type="response")
glm.probs[1:10]

glm.pred=rep(0,length(income))
glm.pred[glm.probs> .39]=1
incomeDirection =  rep(0, length(income))
incomeDirection[income == " >50K"] = 1
incomeDirection[1:60]
table(glm.pred,incomeDirection)
mean(glm.pred!=incomeDirection)

summary(glm.fit)
coef(glm.fit)
summary(glm.fit)$coef
summary(glm.fit)$coef[,4]


linearcbf <- function(train, test, features, lr = 0.05, reg = 0.02, miter = 10) {
	nusers = max(c(train[,1], test[,1]))
	nitems = max(c(train[,2], test[,2]))
	nfeatures = ncol(features)

	features = as.matrix(cbind(features, 1))
	profiles = matrix(rnorm(nusers * (nfeatures + 1), mean=0, sd=0.1), nusers, nfeatures+1)

	for(l in 1:miter) {
		for(j in 1:nrow(train)) {
			u = train[j, 1]
			i = train[j, 2]
			r_ui = train[j, 3]
			pred = profiles[u,] %*% features[i,]
			e_ui = pred - r_ui

			for(k in 1:nfeatures) {
				profiles[u, k] = profiles[u, k] - lr * (e_ui * features[i, k] + reg * profiles[u, k])
			}
			k = nfeatures + 1
			profiles[u, k] = profiles[u, k] - lr * (e_ui * features[i, k])
		}
	}

	model = list()
	model$profiles = profiles

	return(model)
}

predict <- function(model, user, item, features) {
	features = as.matrix(cbind(features, 1))
	return(model$profiles[user,] %*% features[item,])
}


M <- 1
F <- 4

M_tot <- 4
F_tot <- 6

Es1 <- choose(M_tot, M) * choose(F_tot, F)
Es2 <- choose(M_tot, M) * choose(F_tot - 1, F - 1)
Es3 <- choose(M_tot - 2, M) * choose(F_tot, F)
print(Es1)
print(Es2)
print(Es3)


#Helpful equations for ET calculations according to FAO methodology (Allen et al. 1998, FAO Irr Drain Paper 56)

#saturated vapor pressure for a given temperature
e0=function(temp) 0.6108*exp(17.27*temp/(temp+237.3))

#this is how FAO suggests one do it for daily esat b/c of nonlinearity of e0 function
esat=function(tmax,tmin) (e0(tmax)+e0(tmin))/2

#slope of saturation curve
s=function(temp) 4098*(0.6108*exp(17.27*temp/(temp+237.3)))/(temp+237.3)^2

#extraterrestrial (MJ / m^2 / day)
Ra=function(doy,lat){   #lat in decimal degrees       #p79 FAO
  psi=(pi/180)*lat
  delta=0.409*sin((2*pi*doy/365)-1.39)
  ws=acos(-tan(psi)*tan(delta))
  dr=1+0.033*cos(2*pi*doy/365)
  Ra=(24*60/pi)*0.082*dr*(ws*sin(psi)*sin(delta)+cos(psi)*cos(delta)*sin(ws))
  Ra
}

#psychrometric constant [kPa C-1]
psychro=function(elev){             #elev in m
  press=101.3*((293-0.0065*elev)/293)^5.26
  0.665e-3*press
}

#daylength (returns # hours in the day with sunlight. only for areas between 65N-6)
daylength=function(lat,doy){
  psi=(pi/180)*lat
  delta=0.409*sin((2*pi*doy/365)-1.39)
  ws=acos(-tan(psi)*tan(delta))
  d=24*ws/pi
  d
}

#net surface radiation
Rn=function(lat,elev,doy,dew,tmax,tmin,Rs){
  ea=e0(dew)
  Ra=Ra(doy,lat)
  Rso=(0.75+(2e-5)*elev)*Ra          #p85
  Rnl=4.903e-9*(((tmax+273)^4+(tmin+273)^4)/2)*(0.34-0.14*sqrt(ea))*(1.35*(Rs/Rso)-0.35)  #p86
  Rn=(1-0.23)*Rs-Rnl             #(Rns=(1-0.23)Rs) ; Rn=Rns-Rnl p87
  Rn
}


#' @title calcCf
#'
#' @description  Calculates the frictional resistance coefficient (\code{Cf})
#' (dimensionless).
#'
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param lwl Waterline length (vector of numericals, m) (see
#' \code{\link{calclwl}})
#' @param seawaterTemp Sea water temperature. Default = 15 (degrees Celsius).
#' Can supply either a vector of numericals, a single number, or rely on the
#' default
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @details
#' Calculates frictional resistance coefficient using the International Tank
#' Towing Committee (ITTC) 1957 method where:
#' \deqn{Cf = \frac{0.075}{(log(V*Lwl/visc)-2)^2}}{Cf = 0.075/((log(V*Lwl/visc)-2)^2)}
#'
#' @return \code{Cf} (vector of numericals, dimensionless)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calclwl}}
#'}
#'
#' @family Resistance Calculations
#'
#' @examples
#' calcCf(seq(1,5,1), 218.75, 15, 1.025)
#'
#' @export

calcCf <- function(shipSpeed, lwl, seawaterTemp=15, seawaterDensity=1.025){

  Cf<-0.075/((log10(
    (shipSpeed*lwl)/
                      (((43.4233-31.38*seawaterDensity)*
                          ((seawaterTemp+20)^(1.72*seawaterDensity-2.202))+
                          4.7478-5.779*seawaterDensity)*(10^(-6)))

    )
    -2)^(2))

 return(Cf)
}


############# Preamble ##########
#
# A simplified script that produces the final model. This runs the edx-supplied
# code so as to provide the required data objects `validation` and `edx`.

########### Sample code from EdX ##########

#############################################################
# Create edx set, validation set, and submission file
#############################################################

# Note: this process could take a couple of minutes

if(!require(tidyverse)) install.packages("tidyverse", repos = "http://cran.us.r-project.org")
if(!require(caret)) install.packages("caret", repos = "http://cran.us.r-project.org")

# MovieLens 10M dataset:
# https://grouplens.org/datasets/movielens/10m/
# http://files.grouplens.org/datasets/movielens/ml-10m.zip

dl <- tempfile()
download.file("http://files.grouplens.org/datasets/movielens/ml-10m.zip", dl)

ratings <- read.table(text = gsub("::", "\t", readLines(unzip(dl, "ml-10M100K/ratings.dat"))),
                      col.names = c("userId", "movieId", "rating", "timestamp"))

movies <- str_split_fixed(readLines(unzip(dl, "ml-10M100K/movies.dat")), "\\::", 3)
colnames(movies) <- c("movieId", "title", "genres")
movies <- as.data.frame(movies) %>% mutate(movieId = as.numeric(levels(movieId))[movieId],
                                           title = as.character(title),
                                           genres = as.character(genres))

movielens <- left_join(ratings, movies, by = "movieId")

# Validation set will be 10% of MovieLens data

set.seed(1)
test_index <- createDataPartition(y = movielens$rating, times = 1, p = 0.1, list = FALSE)
edx <- movielens[-test_index,]
temp <- movielens[test_index,]

# Make sure userId and movieId in validation set are also in edx set

validation <- temp %>%
  semi_join(edx, by = "movieId") %>%
  semi_join(edx, by = "userId")

# Add rows removed from validation set back into edx set

removed <- anti_join(temp, validation)
edx <- rbind(edx, removed)

rm(dl, ratings, movies, test_index, temp, movielens, removed)

########### Beginning of own code ############

#Load Professor Irizarry's RMSE function:
RMSE <- function(true_ratings, predicted_ratings){
  sqrt(mean((true_ratings - predicted_ratings)^2))
}

#Compute population mean mu (for training set).
mu <- mean(edx$rating)

#Compute possible values of lambda, stored as `lambdas`:
lambdas <- seq(0, 10, 0.25)

#  Select value of lambda from object `lambdas`, based on Chapter 34 of
# Irizarry (2019)
rmses_movie_User <- sapply(lambdas, function(l){

  # Comptes movie bias effects for each value of `l` (lambda)
  b_i <- edx %>%
    group_by(movieId) %>%
    summarize(b_i = sum(rating - mu)/(n()+l))

  #Compute user bias effects for each value of `l` (lambda)
  b_u <- edx %>%
    left_join(b_i, by="movieId") %>%
    group_by(userId) %>%
    summarize(b_u = sum(rating - b_i - mu)/(n()+l))

  #Compute predictions for each value of `l` (lambda)
  predicted_ratings <-
    validation %>%
    left_join(b_i, by = "movieId") %>%
    left_join(b_u, by = "userId") %>%
    mutate(pred = mu + b_i + b_u) %>%
    pull(pred)

  #Determine and return RMSE for given value of Lambda.
  return(RMSE(validation$rating,predicted_ratings))
})

#Plot RMSEs for various values of lambda
qplot(lambdas,rmses_movie_User)

#Save value of lambda that produces lowest RMSE and print to console.
lambda_movie_user <- lambdas[which.min(rmses_movie_User)]
lambda_movie_user

#Create objects for model

#  Compute the movie biases. This retains additional information that may be
# used by downstream filtering systems.
b_i <- edx %>%
  group_by(movieId,title,genres) %>%
  summarize(b_i_reg = sum(rating - mu)/(n()+lambda_movie_user),n_movie = n()) %>%
  ungroup()
# The purpose of the above line is to ease downstream use.

#Compute the user biases
b_u <- edx %>%
  left_join(b_i, by="movieId") %>%
  group_by(userId) %>%
  summarize(b_u_reg = sum(rating - b_i_reg - mu)/(n()+lambda_movie_user))

#Apply to test set. Save predicted values in memory as `predicted_ratings`.
predicted_ratings <-
  validation %>%
  left_join(b_i, by = "movieId") %>%
  left_join(b_u, by = "userId") %>%
  mutate(pred = mu + b_i_reg + b_u_reg) %>%
  pull(pred)

#Determine final RMSE and print to console, saving to memory as `final_rmse`.
final_rmse <- RMSE(validation$rating,predicted_ratings)
final_rmse


##### Chapter 11: Improving Model Performance -------------------

# load the credit dataset
credit <- read.csv("credit.csv", stringsAsFactors = TRUE)
library(caret)

## Creating a simple tuned model ----
# automated parameter tuning of C5.0 decision tree
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
m <- train(default ~ ., data = credit, method = "C5.0")

# summary of tuning results
m

# apply the best C5.0 candidate model to make predictions
p <- predict(m, credit)
table(p, credit$default)

# obtain predicted classes
head(predict(m, credit, type = "raw"))

# obtain predicted probabilities
head(predict(m, credit, type = "prob"))

## Customizing the tuning process ----
# use trainControl() to alter resampling strategy
ctrl <- trainControl(method = "cv", number = 10,
                     selectionFunction = "oneSE")

# use expand.grid() to create grid of tuning parameters
grid <- expand.grid(model = "tree",
                    trials = c(1, 5, 10, 15, 20, 25, 30, 35),
                    winnow = FALSE)

# look at the result of expand.grid()
grid

# customize train() with the control list and grid of parameters
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
m <- train(default ~ ., data = credit, method = "C5.0",
           metric = "Kappa",
           trControl = ctrl,
           tuneGrid = grid)
m

## Bagging ----
# Using the ipred bagged decision trees
library(ipred)
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
mybag <- bagging(default ~ ., data = credit, nbagg = 25)
credit_pred <- predict(mybag, credit)
table(credit_pred, credit$default)

# estimate performance of ipred bagged trees
library(caret)
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
ctrl <- trainControl(method = "cv", number = 10)
train(default ~ ., data = credit, method = "treebag",
      trControl = ctrl)

## Boosting ----

## Using C5.0 Decision Tree (not shown in book)
library(C50)
m_c50_bst <- C5.0(default ~ ., data = credit, trials = 100)

## Using AdaBoost.M1
library(adabag)

# create a Adaboost.M1 model
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
m_adaboost <- boosting(default ~ ., data = credit)
p_adaboost <- predict(m_adaboost, credit)
head(p_adaboost$class)
p_adaboost$confusion

# create and evaluate an Adaboost.M1 model using 10-fold-CV
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
adaboost_cv <- boosting.cv(default ~ ., data = credit)
adaboost_cv$confusion

# calculate kappa
library(vcd)
Kappa(adaboost_cv$confusion)

## Random Forests ----
# random forest with default settings
library(randomForest)
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
rf <- randomForest(default ~ ., data = credit)
rf

# calculate kappa on the out-of-bag estimate
library(vcd)
Kappa(rf$confusion[1:2,1:2])

## Simulate a data mining competition
library(caret)
ctrl <- trainControl(method = "repeatedcv",
                     number = 10, repeats = 10,
                     selectionFunction = "best",
                     savePredictions = TRUE,
                     classProbs = TRUE,
                     summaryFunction = twoClassSummary)

# auto-tune a random forest
grid_rf <- expand.grid(mtry = c(2, 4, 8, 16))

# test a random forest with the above settings
# note: this may take a long time to run (~10 minutes)
RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
m_rf <- train(default ~ ., data = credit, method = "rf",
              metric = "ROC", trControl = ctrl,
              tuneGrid = grid_rf)
m_rf

# auto-tune a boosted C5.0 decision tree
grid_c50 <- expand.grid(model = "tree",
                        trials = c(10, 25, 50, 100),
                        winnow = FALSE)

RNGversion("3.5.2") # use an older random number generator to match the book
set.seed(300)
m_c50 <- train(default ~ ., data = credit, method = "C5.0",
               metric = "ROC", trControl = ctrl,
               tuneGrid = grid_c50)
m_c50

# compare their ROC curves
library(pROC)
roc_rf <- roc(m_rf$pred$obs, m_rf$pred$yes)
roc_c50 <- roc(m_c50$pred$obs, m_c50$pred$yes)

plot(roc_rf, col = "red", legacy.axes = TRUE)
plot(roc_c50, col = "blue", add = TRUE)


# Reproducible Research
# Project 02

# Assumes you have downloaded the bz2 file to your working directory

StormData <- read.csv(bzfile("repdata-data-StormData.csv.bz2"))
columns <- c("BGN_DATE","BGN_TIME","STATE","EVTYPE","FATALITIES","INJURIES","PROPDMG","PROPDMGEXP")
StormData2 <- StormData[,columns]

# Clean PROPDMGEXP
# Get rid of NA values
StormData2 <- subset(StormData2, StormData2$PROPDMGEXP!='+' &
                       StormData2$PROPDMGEXP!='-' &
                       StormData2$PROPDMGEXP!='?')

StormData2$PROPDMGEXP <- toupper(StormData2$PROPDMGEXP)

# PROPDMGEXP gives the 'exponent' value of the property damage
old_vals <- c('0', '1', '2', '3', '4', '5', '6', '7', '8', 'H', 'K', 'M', 'B', '')
new_vals <- c(1, 0.1*10^3, 0.2*10^3, 0.3*10^3, 0.4*10^3, 0.5*10^3, 0.6*10^3, 0.7*10^3, 0.8*10^3,
              10^2, 10^3, 10^6, 10^9, 1)

for(idx in 1:length(old_vals)){StormData2[StormData2$PROPDMGEXP == old_vals[idx], ]$PROPDMGEXP <- new_vals[idx]}
# Add in new column with real property damage value
StormData2$Damage <- as.numeric(StormData2$PROPDMG) * as.numeric(StormData2$PROPDMGEXP)

Totals.Injuries <- aggregate(formula = INJURIES ~ EVTYPE,
                             data = StormData2,
                             FUN = sum)
# Sort by most injuries
Totals.Injuries <- Totals.Injuries[order(x = Totals.Injuries$INJURIES,
                                         decreasing = TRUE), ]
# Now for fatalities
Totals.Fatalities <- aggregate(formula = FATALITIES ~ EVTYPE,
                             data = StormData2,
                             FUN = sum)
# Sort by most fatalities
Totals.Fatalities <- Totals.Fatalities[order(x = Totals.Fatalities$FATALITIES,
                                         decreasing = TRUE), ]
# And now for property damage
Totals.Damage <- aggregate(formula = Damage ~ EVTYPE,
                           data = StormData2,
                           FUN = sum)
# Sort by most damage
Totals.Damage <- Totals.Damage[order(x = Totals.Damage$Damage,
                                         decreasing = TRUE), ]
# Plots of the top 10 for each category

barplot(height = Totals.Injuries$INJURIES[1:10],
        names.arg = Totals.Injuries$EVTYPE[1:10],
        main = "Top 10 Storm Sources of Injuries",
        xlab = "Source of Injuries")


library(radolc)

fr <- function(x) {   ## Rosenbrock Banana function
    x1 <- x[[1]]
    x2 <- x[[2]]
    y <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
    y }

tag <- 1
trace_on(tag)
x <- c(adouble(1.0),adouble(2.0))
badouble_declareIndependent(x)
y <- fr(x)

badouble_declareDependent(y)
trace_off()
#gradient(tag,n,x,g)
# tag: integer, tape identification
# n  : integer, number of independents n and m = 1
# x[n]: independent vector x
# g[n] :resulting gradient \gradF(x)

x=c(1,2)
g <- c(0.0,0.0)
gradient(1,2,x,g)

#Always detach the package
detach(package:radolc, unload=TRUE)


library('fastDummies')
library('pmml')
library('missForest')

data <- read.csv('C://Users/ludepa/OneDrive - SAS/Apresentacoes/Datasets/hmeq.csv', header=T, na.string=c(""), sep = ";")

data <- raw[1:13]

data <- data.frame( CLAGE = as.numeric(data$CLAGE),
                 CLNO = as.numeric(data$CLNO),
                 DEBTINC = as.numeric(data$DEBTINC),
                 DELINQ = as.numeric(data$DELINQ),
                 DEROG = as.numeric(data$DEROG),
                 LOAN = as.numeric(data$LOAN),
                 MORTDUE = as.numeric(data$MORTDUE),
                 NINQ = as.numeric(data$NINQ),
                 VALUE = as.numeric(data$VALUE),
                 YOJ = as.numeric(data$YOJ),
                 JOB = as.factor(data$JOB),
                 REASON = as.factor(data$REASON),
                 BAD = as.factor(data$BAD),
                 stringsAsFactors = FALSE)

imp <- missForest(data, maxiter = 2, ntree = 10)

imp$OOBerror

imp_f <- imp$ximp

data_dummies <- dummy_cols(imp_f)

head(data_dummies)

final_df <- within(data_dummies, rm("JOB", "REASON", "BAD_1", "BAD_0"))
final_df$BAD = data_dummies$BAD

head(final_df)

model <- glm(formula = BAD ~ ., family = binomial(link = "logit"), data = final_df)

s <- summary(model)

print(s)

saveXML(pmml(model, model.name="General_Regression_Model",
             app.name="Rattle/PMML",
             description="Generalized Linear Regression Model"), "R_HMEQ.xml")

write.csv(final_df, './hmeq_dummies.csv', row.names=FALSE)


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

data <- read.csv('../../results/delay/data_all.csv', sep = ';')
data_none <- data[which(data$combination=='combination_0' | data$combination=='combination_1' | data$combination=='combination_2' | data$combination=='combination_3'),]
data_triple <- data[which(data$combination=='combination_4' | data$combination=='combination_5' | data$combination=='combination_6' | data$combination=='combination_7'),]
data_bgp <- data[which(data$combination=='combination_8' | data$combination=='combination_9' | data$combination=='combination_10' | data$combination=='combination_11'),]

# Means
aggregate(data$time, list(data$combination), median)
#  combination_0 1516.5
#  combination_1 1196.0
#  combination_2  957.0
#  combination_3  935.0
#  combination_4 1479.0
#  combination_5 1193.0
#  combination_6  986.5
#  combination_7  977.5
#  combination_8 1241.0
#  combination_9  679.0
#  combination_10  422.5
#  combination_11  400.5

median(data_none$time)
median(data_triple$time)
median(data_bgp$time)
# None: 1054
# Triple: 1055.5
# BGP: 556.5

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: None == Triple
kruskal.test(time ~ combination, data = data_none)
kruskal.test(time ~ combination, data = data_triple)
kruskal.test(time ~ combination, data = data_bgp)
# p: 0.2905, 0.2306, 0.002891
# => Accept H0, equal means => None == Triple


##################################################################
#     Calculate Great Circle Distance in m based upon spherical
#     trig.
##################################################################

great.circle.distance = function (loc1, loc2, R) {

  names(loc1) = c("lon", "lat")
  names(loc2) = c("lon", "lat")

  if (is.null(R)) R = 6367.436  # radius of earth (geometric mean) km
    # if R=1 then distances in radians
    if (missing(loc2)) loc2 <- loc1
    pi180 = pi/180
    coslat1 = cos(loc1$lat * pi180)
    sinlat1 = sin(loc1$lat * pi180)
    coslon1 = cos(loc1$lon * pi180)
    sinlon1 = sin(loc1$lon * pi180)
    coslat2 = cos(loc2$lat * pi180)
    sinlat2 = sin(loc2$lat * pi180)
    coslon2 = cos(loc2$lon * pi180)
    sinlon2 = sin(loc2$lon * pi180)
    pp =   cbind(coslat1 * coslon1, coslat1 * sinlon1, sinlat1) %*%
         t(cbind(coslat2 * coslon2, coslat2 * sinlon2, sinlat2))

    d = R * acos(ifelse(pp > 1, 1, pp))

    return(d)
}


physics.gravity.calculate.acceleration <- function(mass, radius) {
    return(physics.constants.G * mass / radius^2)
}


halve <- function(a) floor(a/2)
double <- function(a) a*2
iseven <- function(a) (a%%2)==0

ethiopicmult<-function(x,y){
	res<-ifelse(iseven(y),0,x)
	while(!y==1){
		x<-double(x)
		y<-halve(y)
		if(!iseven(y)) res<-res+x
	}
	return(res)
}

print(ethiopicmult(17,34))


#!/usr/bin/env Rscript
# Author: Cody Lewis
# Description:
# Web based GUI interface showing how the reputation equation works

library(shiny)

source("ReputationQR.r")

NORMAL_FLAG = 0
BAD_MOUTH_FLAG = 1
GOOD_MOUTH_FLAG = 2

# The GUI instantiation
ui <- fluidPage(
    titlePanel("Reputation Impacts in a Trust Model"),
    sidebarLayout(
        sidebarPanel(
            sliderInput(
                inputId="s_target",
                label="Service Target:",
                min=1,
                max=100,
                value=50
            ),
            sliderInput(
                inputId="c_target",
                label="Capability Target:",
                min=1,
                max=100,
                value=50
            ),
            sliderInput(
                inputId="s_j",
                label="Reported Service of the Node:",
                min=1,
                max=100,
                value=50
            ),
            sliderInput(
                inputId="c_j",
                label="Reported Capability of the Node:",
                min=1,
                max=100,
                value=50
            ),
            radioButtons(
                inputId="reporter_attack_type",
                label="Note Taking Type of Reporting Nodes:",
                choices=list(
                    "Normal"=NORMAL_FLAG,
                    "Bad Mouth"=BAD_MOUTH_FLAG,
                    "Good Mouth"=GOOD_MOUTH_FLAG
                ),
                selected=NORMAL_FLAG
            ),
            sliderInput(
                inputId="time_decay",
                label="Time Decay of Reports:",
                min=0,
                max=10,
                value=0
            ),
            sliderInput(
                inputId="reporter_qr_range",
                label="Range of QRs of the reporters:",
                min=0,
                max=1,
                value=c(0, 1)
            ),
            sliderInput(
                inputId="theta",
                label="θ:",
                min=0,
                max=1,
                value=0.7
            ),
            sliderInput(
                inputId="lambda",
                label="λ:",
                min=0,
                max=1,
                value=0.7
            ),
            sliderInput(
                inputId="eta",
                label="η:",
                min=0,
                max=20,
                value=1
            ),
            sliderInput(
                inputId="transactions",
                label="Transactions:",
                min=1,
                max=1000,
                value=300
            )
        ),
        mainPanel(
            id="main",
            plotOutput("reputation"),
            textOutput("context_attack_impact")
        )
    )
)

# Backend logic
server <- function(input, output) {
    # Plot the effects of the attack on reputation
    output$reputation <- renderPlot({
        # initialize for the transactions
        reputations = rep(1, each=(input$transactions + 1))
        node_qrs = c(1)
        node_qr_times = c(1)
        time = 1
        client_qrs = runif(
            input$transactions,
            min=input$reporter_qr_range[[1]],
            max=input$reporter_qr_range[[2]]
        )
        if(input$reporter_attack_type == NORMAL_FLAG) {
            client_notes = take_notes(input$c_j, input$c_target,
                                      input$s_j, input$s_target,
                                      client_qrs)
        } else if(input$reporter_attack_type == BAD_MOUTH_FLAG) {
            client_notes = rep(-1, each=length(client_qrs))
        } else {
            client_notes = rep(1, each=length(client_qrs))
        }
        node_note = 1
        # Perform the transactions
        for(transaction in 1:input$transactions) {
            if((transaction %% 30) == 0) {
                time = time + 1
            }
            d = report_dist(
                input$c_j, input$s_j, input$c_target,
                input$s_target, input$eta, node_note,
                find_dist(input$s_target, S_MAX)**2,
                find_dist(input$c_target, C_MAX)**2,
                S_MAX, C_MAX
            )
            w = find_weight(input$lambda, input$theta, node_note,
                            (time - input$time_decay), d, time)
            qr = find_qr(
                w, client_notes[[transaction]], input$theta, time,
                node_note, client_qrs[[transaction]], node_qrs, node_qr_times
            )
            node_qrs = c(qr, node_qrs)
            node_qr_times = c(time, node_qr_times)
            reputations[[transaction + 1]] = calculate_reputation(
                input$theta, client_notes, client_qrs, transaction,
                time, node_qr_times
            )
        }
        plot_reputation(reputations)
    })
    # State whether the attack will have an impact on QR of the client
    output$context_attack_impact <- renderText({
        time = 1
        node_note = 1
        dS_max_sq = find_dist(input$s_target, S_MAX)**2
        dC_max_sq = find_dist(input$c_target, C_MAX)**2
        d = report_dist(
            input$c_j, input$s_j, input$c_target,
            input$s_target, input$eta, node_note,
            dS_max_sq, dC_max_sq, S_MAX, C_MAX
        )
        if(d >= sqrt(dS_max_sq + dC_max_sq)) {
            return("Reports produced in the transaction phase of this attack will have no impact on the client's QR as the distance of the report is out of bounds")
        } else {
            w = find_weight(input$lambda, input$theta, node_note,
                            (time - input$time_decay), d, time)
            return(
                sprintf("Reports produced in the transaction phase of this attack will have a weight of %f", w)
            )
        }
    })
}

options(shiny.port=8100)
shinyApp(ui=ui, server=server)


################
#---PACKAGES---#
################
require(ggplot2)
require(reshape2)

###########################
#---POISSON SAMPLE PATH---#
###########################
# 4 x 12
paths = 1
N = 50

rate = 0.1

colorBeta <- rgb(252, 141, 98, maxColorValue = 255, alpha = 255)
colorAlpha <- rgb(141, 160, 203, maxColorValue = 255, alpha = 255)

theList <- list()
for(j in 1 : paths) {

  data = data.frame(
    x = rep(NA, 2 * N + 1),
    xend = rep(NA, 2 * N + 1 ),
    y = rep(NA, 2 * N + 1),
    yend = rep(NA, 2 * N + 1),
    path = rep(NA, 2 * N + 1)
  )

  data$x[1] = 0
  data$xend[1] = rexp(1, rate = rate)

  data$y[1] = sample(c("A", "C", "G", "T"), size = 1)
  data$yend = data$y

  ids = seq( from = 1, to = (2 * N - 1), by = 2 )

  for(i in ids) {

    char = sample(c("A", "C", "G", "T"), size = 1)
    time = rexp(1, rate = rate)

    data$x[i + 1] = data$xend[i]
    data$xend[i + 1] = data$x[i + 1]

    data$y[i + 1] = data$yend[i]
    data$yend[i + 1] = char

    data$x[i + 2] = data$xend[i + 1]
    data$xend[i + 2] = data$x[i + 2] + time

    data$y[i + 2] = data$yend[i + 1]
    data$yend[i + 2] = data$y[i + 2]

    data$path[i] <- data$path[i + 1] <- data$path[i + 2] <- j

  } # END: i

  theList[[j]] = data
} # END: j

data_melt <- do.call("rbind", theList)
data_melt$path <- as.factor(data_melt$path)

p <- ggplot(data_melt)
p <- p + geom_segment(aes(x = x, y = y, xend = xend, yend = yend, linetype = path), colour = colorAlpha, size = 1)
# p <- p + geom_point(aes(x = x, y = y), colour = colorAlpha, fill = colorAlpha, shape = 21, size = 2)

theme1 <- theme(
  axis.line = element_line(colour = "black"),
  axis.text = element_text(colour = "black"),
  axis.ticks = element_line(colour = "black"),
  legend.position = "none",
  panel.background = element_rect(size = 1, fill = "white", colour = NA),
  panel.border = element_blank(),
  panel.grid.major = element_blank(),
  panel.grid.minor = element_blank()
)

nth = 2
ticks <- unique(round(data_melt$x, 1))
ticks <- ticks[seq(1, length(ticks), nth)]
p <- p + scale_x_continuous(
  breaks = ticks
  )

p <- p + theme1
p <- p + xlab("Time") + ylab("")
print(p)

#########################
#---JC69 CTMC EXAMPLE---#
#########################
JC69 <- function (theta, t) {
  p0 = 1/4 + 3/4 * exp(-4*theta*t)
  p1 = 1/4 - 1/4 * exp(-4*theta*t)

  trans_prob = matrix(c(p0, p1, p1, p1,
                        p1, p0, p1, p1,
                        p1, p1, p0, p1,
                        p1, p1, p1, p0
  ), nrow = 4, ncol = 4, byrow = T)

  colnames(trans_prob) <- rownames(trans_prob) <- c("T", "C", "A", "G")
  return(trans_prob)
}

N = 50
times = seq(0, 0.1, length.out = N)
data <- data.frame(
    T = rep(NA, N),
    C = rep(NA, N),
    A = rep(NA, N),
    G = rep(NA, N)
    )

# set.seed(123)
r    <- runif(4)
vect <- r / sum(r)

data[1, ] <- vect
theta    <- 2

for (i in 2 : N) {
   probs = as.matrix(data[i - 1, ], nrow = 1, ncol = 4)
   data[i, ] <- probs %*% JC69(theta, t = times[i])
}

data_melt <- melt(cbind(t = times, data), id.vars = "t")

p <- ggplot(data_melt)
p <- p + geom_line(aes(x = t, y = value, color = variable))
p <- p + xlab("Time") + ylab("Probability")
theme <- theme(
  axis.title = element_text(colour = "black"),
  axis.text = element_text(colour = "black"),
  axis.line = element_line(colour = "black"),
  axis.ticks = element_line(colour = "black"),
  panel.background = element_rect(size = 1, fill = "white", colour = NA),
  plot.background = element_rect(colour = NA),
  panel.border = element_blank(),
  panel.grid.major = element_blank(),
  panel.grid.minor = element_blank()
)
p <- p + theme
print(p)

###################################
#---BINOMIAL LIKELIHOOD EXAMPLE---#
###################################
myBlue = rgb(r = 86, g = 110, b = 126, maxColorValue = 250)

like <- function(theta, k = 8, n = 10) {
  return(dbinom(k, n, theta))
}

# 900 x 600
theta <- seq(from = 0, to = 1, by = 0.01)
plot(theta, like(theta), type = "l", col = myBlue, lwd = 3)

points(0.8, like(0.8), pch = 19, col = myBlue, cex = 1.5)

######################
#---NEWTON RAPHSON---#
######################
myBlue = rgb(r = 86, g = 110, b = 126, maxColorValue = 250)

f <- function(x) {
  f = exp(x)/(1 + exp(x))^2
  fx = exp(x)/(1 + exp(x))^2 - 2*exp(2*x)/(1 + exp(x))^3
  fxx = 6 * exp(x)/(1 + exp(x))^4 - 6*exp(2*x)/(1 + exp(x))^3 + exp(x)/(1+exp(x))^2
  return( data.frame(f = f, fx = fx, fxx = fxx ) )
}

x = seq(-10, 10, length.out = 100)
plot(x, f(x)[,1], type = "l", col = myBlue, lwd = 3)

newtonRaphson <- function(f, x0, tol = 1/10^9, maxIter = 100) {

  x  = x0
  fx = f(x)
  i  = 0

  cat(paste(c("i", "x", "f(x)", "\n"), sep = "\t"))
  while ( (abs(fx[, 2]) > tol) ) {

    if(i < maxIter) {

      x  = x - fx[, 2] / fx[, 3]
      fx = f(x)

      points(x, fx[,1], pch = 19, col = myBlue, cex = 1.5)
      cat(paste(c(i, x, fx[,1], "\n"), sep = "\t"))
      Sys.sleep(0.5)

      i  = i + 1

    } else {
      break;
    }#END: maxIter check
  }#END: tolerance loop

  return(x)
}

x.star <- newtonRaphson(f, 5)


#' norm
#'
#' Compute matrix norm.
#'
#' @param x
#' A float vector/matrix.
#' @param type
#' "O"-ne, "I"-nfinity, "F"-robenius, "M"-ax modulus, and "2" norms.
#'
#' @return
#' A single float.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' norm(s, type="O")
#'
#' @useDynLib float R_norm_spm
#' @name norm
#' @rdname norm
NULL

norm_float32 = function(x, type=c("O", "I", "F", "M", "2"))
{
  type = toupper(match.arg(type))

  if (type == "2")
    La.svd_float32(x, nu=0, nv=0)$d[1L]
  else
  {
    ret = .Call(R_norm_spm, DATA(x), type)
    float32(ret)
  }
}

#' @rdname norm
#' @export
setMethod("norm", signature(x="float32", type="ANY"), norm_float32)


install.packages('nycflights13')
library(tidyverse)

library(nycflights13)
head(flights)

# filter：按值筛选观测
# select: 按名称选取变量
# arrange: 对行进行重新排序
# mutate: 使用现有变量创建新的变量
# summarize: 将多个值总结为一个摘要统计量

(jan1 <- filter(flights,month==1,day==1))

# 11月或12月出发的航班
filter(flights,month==11 | month==12)
filter(flights,month %in% c(11,12) )

df <- tibble(x=c(1,NA,3))

# P38

# (1)
## a.
filter(flights,arr_delay>=120)

## b.
filter(flights,dest %in% c('IAH','HOU'))

## c.
filter(flights,carrier %in% c('UA','US','DL') )

## d.
filter(flights,month %in% c(7,8,9) )

## e.
# filter(flights,arr_delay>=120 & )

## f.
# filter(flights,)

## g.
# filter(flights,)

# (2)
# between(x,left,right)函数表示x >= left & x <= right

# (3)
nrow(filter(flights,is.na(dep_time)))
# [1] 8255

arrange(flights,year,month,day)

# desc()降序排序

arrange(flights,desc(month),desc(day))

# P40

# (1)
df <- tibble(x=c(5,2,NA))
arrange(df,x)
arrange(df,desc(x))

arrange(df,desc(is.na(x)))

# (2)
# arrange(flights,desc())

# (3)

# (4)

select(flights,year,month,day)

select(flights,year:day)

# 去掉
select(flights,-(year:day))

rename(flights,tail_num=tailnum)

select(flights,time_hour,air_time,everything())

flights_sml <- select(flights,year:day,ends_with("delay"),distance,air_time)
mutate(flights_sml,
       gain = arr_delay - dep_delay,
       speed = distance / air_time * 60)

mutate(flights_sml,
       gain = arr_delay - dep_delay,
       hours = air_time / 60,
       gain_per_hour = gain / hours)

# 指标来新生成的变量
transmute(flights,
          gain= arr_delay - dep_delay,
          hours = air_time / 60,
          gain_per_hour = gain / hours)

summarize(flights,delay=mean(dep_delay,na.rm=TRUE))

by_day <- group_by(flights,year,month,day)
summarize(by_day,delay=mean(dep_delay,na.rm=TRUE))

by_dest <- group_by(flights,dest)
delay <- summarize(by_dest,
          count=n(),
          dist=mean(distance,na.rm=TRUE),
          delay=mean(arr_delay,na.rm=TRUE))

delay <- filter(delay,count>20,dest != "HNL")

ggplot(data=delay,mapping=aes(x=dest,y=delay)) +
  geom_point(aes(size=count),alpha=1/3) +
  geom_smooth()

delays <- flights %>%
  group_by(dest) %>%
  summarise(
    count=n(),
    dist=mean(distance,na.rm=TRUE),
    delay=mean(arr_delay,na.rm=TRUE)
  ) %>%
  filter(count>20,dest != "HNL")

flights %>%
  group_by(year,month,day) %>%
  summarise(mean=mean(dep_delay,na.rm=TRUE))

flights %>%
  filter(!is.na(dep_delay)) %>%
  group_by(year,month,day) %>%
  summarise(mean=mean(dep_delay))

flights %>%
  filter(!is.na(dep_delay), !is.na(arr_delay)) %>%
  group_by(tailnum) %>%
  summarise(delay=mean(arr_delay)) %>%
  ggplot(.,mapping = aes(x=delay)) +
  geom_freqpoly(binwidth=10)


Data_<-structure(list(item = c("Panacea", "Ichor", "Gold"), value = c(3000,
1800, 2500), weight = c(3, 2, 20), volume = c(25, 15, 2)), .Names = c("item",
"value", "weight", "volume"), row.names = c(NA, 3L), class = "data.frame")

knapsack_volume<-function(Data, W, Volume, full_K)
{

	# Data must have the colums with names: item, value, weight and volume.
	K<-list() # hightest values
	K_item<-list() # itens that reach the hightest value
	K<-rep(0,W+1) # The position '0'
	K_item<-rep('',W+1) # The position '0'
	for(w in 1:W)
	{
		temp_w<-0
		temp_item<-''
		temp_value<-0
		for(i in 1:dim(Data)[1]) # each row
		{
			wi<-Data$weight[i] # item i
			vi<- Data$value[i]
			item<-Data$item[i]
			volume_i<-Data$volume[i]
			if(wi<=w & volume_i <= Volume)
			{
				back<- full_K[[Volume-volume_i+1]][w-wi+1]
				temp_wi<-vi + back

				if(temp_w < temp_wi)
				{
					temp_value<-temp_wi
					temp_w<-temp_wi
					temp_item <- item
				}
			}
		}
	K[[w+1]]<-temp_value
	K_item[[w+1]]<-temp_item
	}
return(list(K=K,Item=K_item))
}

Un_knapsack<-function(Data,W,V)
{
	K<-list();K_item<-list()
	K[[1]]<-rep(0,W+1) #the line 0
	K_item[[1]]<-rep('', W+1) #the line 0
	for(v in 1:V)
	{
		best_volum_v<-knapsack_volume(Data, W, v, K)
		K[[v+1]]<-best_volum_v$K
		K_item[[v+1]]<-best_volum_v$Item
	}

return(list(K=data.frame(K),Item=data.frame(K_item,stringsAsFactors=F)))
}

retrieve_info<-function(knapsack, Data)
{
	W<-dim(knapsack$K)[1]
	itens<-c()
	col<-dim(knapsack$K)[2]
	selected_item<-knapsack$Item[W,col]
	while(selected_item!='')
	{
		selected_item<-knapsack$Item[W,col]
		if(selected_item!='')
		{
			selected_item_value<-Data[Data$item == selected_item,]
			W <- W - selected_item_value$weight
			itens<-c(itens,selected_item)
			col <- col - selected_item_value$volume
		}
	}
return(itens)
}

main_knapsack<-function(Data, W, Volume)
{
	knapsack_result<-Un_knapsack(Data,W,Volume)
	items<-table(retrieve_info(knapsack_result, Data))
	K<-knapsack_result$K[W+1, Volume+1]
	cat(paste('The Total profit is: ', K, '\n'))
	cat(paste('You must carry:', names(items), '(x',items, ') \n'))
}

main_knapsack(Data_, 250, 250)


library(repr) ; options(repr.plot.width=7, repr.plot.height= 6) # Change plot sizes (in cm) - this bit of code is only relevant if you are using a juyter notebook - ignore otherwise

setwd("../code/")

MyData <- as.matrix(read.csv("../data/PoundHillData.csv",header = FALSE))
class(MyData)

MyMetaData <- read.csv("../data/PoundHillMetaData.csv",header = TRUE,  sep=";")
class(MyMetaData)

head(MyData)

MyMetaData

MyData[MyData == ""] = 0

MyData <- t(MyData)
head(MyData)

colnames(MyData)

TempData <- as.data.frame(MyData[-1,],stringsAsFactors = F)
head(TempData)

colnames(TempData) <- MyData[1,] # assign column names from original data
head(TempData)

rownames(TempData) <- NULL
head(TempData)

require(reshape2)# load the reshape2 package

MyWrangledData <- melt(TempData, id=c("Cultivation", "Block", "Plot", "Quadrat"), variable.name = "Species", value.name = "Count")
head(MyWrangledData); tail(MyWrangledData)

MyWrangledData[, "Cultivation"] <- as.factor(MyWrangledData[, "Cultivation"])
MyWrangledData[, "Block"] <- as.factor(MyWrangledData[, "Block"])
MyWrangledData[, "Plot"] <- as.factor(MyWrangledData[, "Plot"])
MyWrangledData[, "Quadrat"] <- as.factor(MyWrangledData[, "Quadrat"])
MyWrangledData[, "Count"] <- as.integer(MyWrangledData[, "Count"])
str(MyWrangledData)

require(tidyverse)

tidyverse_packages(include_self = TRUE) # the include_self = TRUE means list "tidyverse" as well

tibble::as_tibble(MyWrangledData)

dplyr::glimpse(MyWrangledData) #like str(), but nicer!

dplyr::filter(MyWrangledData, Count>100) #like subset(), but nicer!

dplyr::slice(MyWrangledData, 10:15) # Look at an arbitrary set of data rows

MyDF <- read.csv("../data/EcolArchives-E089-51-D1.csv")
dim(MyDF) #check the size of the data frame you loaded

str(MyDF)

head(MyDF)

require(tidyverse)
dplyr::glimpse(MyDF)

MyDF$Type.of.feeding.interaction <- as.factor(MyDF$Type.of.feeding.interaction)
MyDF$Location <- as.factor(MyDF$Location)
str(MyDF)

plot(MyDF$Predator.mass,MyDF$Prey.mass)

plot(log(MyDF$Predator.mass),log(MyDF$Prey.mass))

plot(log10(MyDF$Predator.mass),log10(MyDF$Prey.mass))

plot(log10(MyDF$Predator.mass),log10(MyDF$Prey.mass),pch=20) # Change marker

plot(log10(MyDF$Predator.mass),log10(MyDF$Prey.mass),pch=20, xlab = "Predator Mass (g)", ylab = "Prey Mass (g)") # Add labels

hist(MyDF$Predator.mass)

hist(log10(MyDF$Predator.mass), xlab = "log10(Predator Mass (g))", ylab = "Count") # include labels

hist(log10(MyDF$Predator.mass),xlab="log10(Predator Mass (g))",ylab="Count",
    col = "lightblue", border = "pink") # Change bar and borders colors

par(mfcol=c(2,1)) #initialize multi-paneled plot
par(mfg = c(1,1)) # specify which sub-plot to use first
hist(log10(MyDF$Predator.mass),
    xlab = "log10(Predator Mass (g))", ylab = "Count", col = "lightblue", border = "pink",
    main = 'Predator') # Add title
par(mfg = c(2,1)) # Second sub-plot
hist(log10(MyDF$Prey.mass), xlab="log10(Prey Mass (g))",ylab="Count", col = "lightgreen", border = "pink", main = 'prey')

hist(log10(MyDF$Predator.mass), # Predator histogram
    xlab="log10(Body Mass (g))", ylab="Count",
    col = rgb(1, 0, 0, 0.5), # Note 'rgb', fourth value is transparency
    main = "Predator-prey size Overlap")
hist(log10(MyDF$Prey.mass), col = rgb(0, 0, 1, 0.5), add = T) # Plot prey
legend('topleft',c('Predators','Prey'),   # Add legend
    fill=c(rgb(1, 0, 0, 0.5), rgb(0, 0, 1, 0.5))) # Define legend colors

boxplot(log10(MyDF$Predator.mass), xlab = "Location", ylab = "log10(Predator Mass)", main = "Predator mass")

boxplot(log(MyDF$Predator.mass) ~ MyDF$Location, # Why the tilde?
    xlab = "Location", ylab = "Predator Mass",
    main = "Predator mass by location")

boxplot(log(MyDF$Predator.mass) ~ MyDF$Type.of.feeding.interaction,
    xlab = "Location", ylab = "Predator Mass",
    main = "Predator mass by feeding interaction type")

 par(fig=c(0,0.8,0,0.8)) # specify figure size as proportion
 plot(log(MyDF$Predator.mass),log(MyDF$Prey.mass), xlab = "Predator Mass (g)", ylab = "Prey Mass (g)") # Add labels
 par(fig=c(0,0.8,0.4,1), new=TRUE)
 boxplot(log(MyDF$Predator.mass), horizontal=TRUE, axes=FALSE)
 par(fig=c(0.55,1,0,0.8),new=TRUE)
 boxplot(log(MyDF$Prey.mass), axes=FALSE)
 mtext("Fancy Predator-prey scatterplot", side=3, outer=TRUE, line=-3)

pdf("../results/Pred_Prey_Overlay.pdf", # Open blank pdf page using a relative path
    11.7, 8.3) # These numbers are page dimensions in inches
hist(log(MyDF$Predator.mass), # Plot predator histogram (note 'rgb')
    xlab="Body Mass (g)", ylab="Count", col = rgb(1, 0, 0, 0.5), main = "Predator-Prey Size Overlap")
hist(log(MyDF$Prey.mass), # Plot prey weights
    col = rgb(0, 0, 1, 0.5),
    add = T)  # Add to same plot = TRUE
legend('topleft',c('Predators','Prey'), # Add legend
    fill=c(rgb(1, 0, 0, 0.5), rgb(0, 0, 1, 0.5)))
graphics.off(); #you can also use dev.off()

require(ggplot2)

qplot(Prey.mass, Predator.mass, data = MyDF)

qplot(log(Prey.mass), log(Predator.mass), data = MyDF)

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, colour = Type.of.feeding.interaction)

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, colour = Type.of.feeding.interaction, asp = 1)

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, shape = Type.of.feeding.interaction, asp = 1)

qplot(log(Prey.mass), log(Predator.mass),
    data = MyDF, colour = "red")

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, colour = I("red"))

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, size = 3) #with ggplot size mapping

qplot(log(Prey.mass), log(Predator.mass),  data = MyDF, size = I(3)) #no mapping

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, shape= I(3))

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, colour = Type.of.feeding.interaction, alpha = I(.5))

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, geom = c("point", "smooth"))

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, geom = c("point", "smooth")) + geom_smooth(method = "lm")

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, geom = c("point", "smooth"),
      colour = Type.of.feeding.interaction) + geom_smooth(method = "lm")

qplot(log(Prey.mass), log(Predator.mass), data = MyDF, geom = c("point", "smooth"),
      colour = Type.of.feeding.interaction) + geom_smooth(method = "lm",fullrange = TRUE)

qplot(Type.of.feeding.interaction, log(Prey.mass/Predator.mass), data = MyDF)

qplot(Type.of.feeding.interaction, log(Prey.mass/Predator.mass), data = MyDF, geom = "jitter")

qplot(Type.of.feeding.interaction, log(Prey.mass/Predator.mass), data = MyDF, geom = "boxplot")

qplot(log(Prey.mass/Predator.mass), data = MyDF, geom =  "histogram")

qplot(log(Prey.mass/Predator.mass), data = MyDF, geom =  "histogram",
      fill = Type.of.feeding.interaction)

qplot(log(Prey.mass/Predator.mass), data = MyDF, geom =  "histogram",
      fill = Type.of.feeding.interaction, binwidth = 1)

qplot(log(Prey.mass/Predator.mass), data = MyDF, geom =  "density",
      fill = Type.of.feeding.interaction)

qplot(log(Prey.mass/Predator.mass), data = MyDF, geom =  "density",
      fill = Type.of.feeding.interaction,
      alpha = I(0.5))

qplot(log(Prey.mass/Predator.mass), data = MyDF, geom =  "density",
      colour = Type.of.feeding.interaction)

qplot(log(Prey.mass/Predator.mass), facets = Type.of.feeding.interaction ~., data = MyDF, geom =  "density")

qplot(log(Prey.mass/Predator.mass), facets =  .~ Type.of.feeding.interaction, data = MyDF, geom =  "density")

qplot(Prey.mass, Predator.mass, data = MyDF, log="xy")

qplot(Prey.mass, Predator.mass, data = MyDF, log="xy",
    main = "Relation between predator and prey mass",
    xlab = "log(Prey mass) (g)",
    ylab = "log(Predator mass) (g)")

qplot(Prey.mass, Predator.mass, data = MyDF, log="xy",
    main = "Relation between predator and prey mass",
    xlab = "Prey mass (g)",
    ylab = "Predator mass (g)") + theme_bw()

pdf("../results/MyFirst-ggplot2-Figure.pdf")
print(qplot(Prey.mass, Predator.mass, data = MyDF,log="xy",
    main = "Relation between predator and prey mass",
    xlab = "log(Prey mass) (g)",
    ylab = "log(Predator mass) (g)") + theme_bw())
dev.off()

# load the data
MyDF <- as.data.frame(read.csv("../data/EcolArchives-E089-51-D1.csv"))

# barplot
qplot(Predator.lifestage, data = MyDF, geom = "bar")

# boxplot
qplot(Predator.lifestage, log(Prey.mass), data = MyDF, geom = "boxplot")

# violin plot
qplot(Predator.lifestage, log(Prey.mass), data = MyDF, geom = "violin")

# density
qplot(log(Predator.mass), data = MyDF, geom = "density")

# histogram
qplot(log(Predator.mass), data = MyDF, geom = "histogram")

# scatterplot
qplot(log(Predator.mass), log(Prey.mass), data = MyDF, geom = "point")

# smooth
qplot(log(Predator.mass), log(Prey.mass), data = MyDF, geom = "smooth")

qplot(log(Predator.mass), log(Prey.mass), data = MyDF, geom = "smooth", method = "lm")

p <- ggplot(MyDF, aes(x = log(Predator.mass),
                y = log(Prey.mass),
                colour = Type.of.feeding.interaction))

p

p + geom_point()

p <- ggplot(MyDF, aes(x = log(Predator.mass), y = log(Prey.mass), colour = Type.of.feeding.interaction ))
q <- p +
geom_point(size=I(2), shape=I(10)) +
theme_bw() + # make the background white
theme(aspect.ratio=1) # make the plot square
q

q + theme(legend.position = "none") + theme(aspect.ratio=1)

p <- ggplot(MyDF, aes(x = log(Prey.mass/Predator.mass), fill = Type.of.feeding.interaction )) + geom_density()
p

p <- ggplot(MyDF, aes(x = log(Prey.mass/Predator.mass), fill = Type.of.feeding.interaction)) + geom_density(alpha=0.5)
p

options(repr.plot.width=12, repr.plot.height= 8) # Change plot size (in cm)

p <- ggplot(MyDF, aes(x = log(Prey.mass/Predator.mass), fill = Type.of.feeding.interaction )) +  geom_density() + facet_wrap( .~ Type.of.feeding.interaction)
p

p <- ggplot(MyDF, aes(x = log(Prey.mass/Predator.mass), fill = Type.of.feeding.interaction )) +  geom_density() + facet_wrap( .~ Type.of.feeding.interaction, scales = "free")
p

options(repr.plot.width=10, repr.plot.height= 12) # Change plot size (in cm)

p <- ggplot(MyDF, aes(x = log(Prey.mass/Predator.mass))) +  geom_density() + facet_wrap( .~ Location, scales = "free")
p

p <- ggplot(MyDF, aes(x = log(Prey.mass), y = log(Predator.mass))) +  geom_point() + facet_wrap( .~ Location, scales = "free")
p

options(repr.plot.width=12, repr.plot.height= 14) # Change plot size (in cm)

p <- ggplot(MyDF, aes(x = log(Prey.mass), y = log(Predator.mass))) +  geom_point() + facet_wrap( .~ Location + Type.of.feeding.interaction, scales = "free")
p

p <- ggplot(MyDF, aes(x = log(Prey.mass), y = log(Predator.mass))) +  geom_point() + facet_wrap( .~ Type.of.feeding.interaction + Location, scales = "free")
p

options(repr.plot.width=7, repr.plot.height= 6) # Change plot size (in cm)

require(reshape2)

GenerateMatrix <- function(N){
    M <- matrix(runif(N * N), N, N)
    return(M)
}

M <- GenerateMatrix(10)
Melt <- melt(M)

p <- ggplot(Melt, aes(Var1, Var2, fill = value)) + geom_tile() + theme(aspect.ratio = 1)
p

p + geom_tile(colour = "black") + theme(aspect.ratio = 1)

p + theme(legend.position = "none") + theme(aspect.ratio = 1)

p + theme(legend.position = "none",
     panel.background = element_blank(),
     axis.ticks = element_blank(),
     panel.grid.major = element_blank(),
     panel.grid.minor = element_blank(),
     axis.text.x = element_blank(),
     axis.title.x = element_blank(),
     axis.text.y = element_blank(),
     axis.title.y = element_blank())

p + scale_fill_continuous(low = "yellow", high = "darkgreen")

p + scale_fill_gradient2()

p + scale_fill_gradientn(colours = grey.colors(10))

p + scale_fill_gradientn(colours = rainbow(10))

p + scale_fill_gradientn(colours = c("red", "white", "blue"))

build_ellipse <- function(hradius, vradius){ # function that returns an ellipse
  npoints = 250
  a <- seq(0, 2 * pi, length = npoints + 1)
  x <- hradius * cos(a)
  y <- vradius * sin(a)
  return(data.frame(x = x, y = y))
}

N <- 250 # Assign size of the matrix

M <- matrix(rnorm(N * N), N, N) # Build the matrix

eigvals <- eigen(M)$values # Find the eigenvalues

eigDF <- data.frame("Real" = Re(eigvals), "Imaginary" = Im(eigvals)) # Build a dataframe

my_radius <- sqrt(N) # The radius of the circle is sqrt(N)

ellDF <- build_ellipse(my_radius, my_radius) # Dataframe to plot the ellipse

names(ellDF) <- c("Real", "Imaginary") # rename the columns

# plot the eigenvalues
p <- ggplot(eigDF, aes(x = Real, y = Imaginary))
p <- p +
  geom_point(shape = I(3)) +
  theme(legend.position = "none")

# now add the vertical and horizontal line
p <- p + geom_hline(aes(yintercept = 0))
p <- p + geom_vline(aes(xintercept = 0))

# finally, add the ellipse
p <- p + geom_polygon(data = ellDF, aes(x = Real, y = Imaginary, alpha = 1/20, fill = "red"))
p

a <- read.table("../data/Results.txt", header = TRUE)

head(a)

a$ymin <- rep(0, dim(a)[1]) # append a column of zeros

# Print the first linerange
p <- ggplot(a)
p <- p + geom_linerange(data = a, aes(
                          x = x,
                          ymin = ymin,
                          ymax = y1,
                          size = (0.5)
                          ),
                        colour = "#E69F00",
                        alpha = 1/2, show.legend = FALSE)

# Print the second linerange
p <- p + geom_linerange(data = a, aes(
                          x = x,
                          ymin = ymin,
                          ymax = y2,
                          size = (0.5)
                          ),
                        colour = "#56B4E9",
                        alpha = 1/2, show.legend = FALSE)

# Print the third linerange:
p <- p + geom_linerange(data = a, aes(
                          x = x,
                          ymin = ymin,
                          ymax = y3,
                          size = (0.5)
                          ),
                        colour = "#D55E00",
                        alpha = 1/2, show.legend = FALSE)

# Annotate the plot with labels:
p <- p + geom_text(data = a, aes(x = x, y = -500, label = Label))

# now set the axis labels, remove the legend, and prepare for bw printing
p <- p + scale_x_continuous("My x axis",
                            breaks = seq(3, 5, by = 0.05)) +
                            scale_y_continuous("My y axis") +
                            theme_bw() +
                            theme(legend.position = "none")
p

x <- seq(0, 100, by = 0.1)
y <- -4. + 0.25 * x +
  rnorm(length(x), mean = 0., sd = 2.5)

# and put them in a dataframe
my_data <- data.frame(x = x, y = y)

# perform a linear regression
my_lm <- summary(lm(y ~ x, data = my_data))

# plot the data
p <-  ggplot(my_data, aes(x = x, y = y,
                          colour = abs(my_lm$residual))
             ) +
  geom_point() +
  scale_colour_gradient(low = "black", high = "red") +
  theme(legend.position = "none") +
  scale_x_continuous(
    expression(alpha^2 * pi / beta * sqrt(Theta)))

# add the regression line
p <- p + geom_abline(
  intercept = my_lm$coefficients[1][1],
  slope = my_lm$coefficients[2][1],
  colour = "red")
# throw some math on the plot
p <- p + geom_text(aes(x = 60, y = 0,
                       label = "sqrt(alpha) * 2* pi"),
                       parse = TRUE, size = 6,
                       colour = "blue")

p

library(ggthemes)

p <- ggplot(MyDF, aes(x = log(Predator.mass), y = log(Prey.mass),
                colour = Type.of.feeding.interaction )) +
                geom_point(size=I(2), shape=I(10)) + theme_bw()

p + geom_rangeframe() + # now fine tune the geom to Tufte's range frame
        theme_tufte() # and theme to Tufte's minimal ink theme


## Libraries
library(tidyverse)
library(broom)

## Data
data <- read.csv("data//78_lakes_ts_minimal.csv", stringsAsFactors = F)

### Check dates
convertDate <- function(x){
  dates <- as.Date(x, "%Y-%m-%d") ## YYYY/mm/dd
  return(dates)
}

## Convert dates to date values
dateCol <- names(data)[11:22]
for(i in dateCol){
  data[,i] <- convertDate(data[,i])
}

## Compare ice on to ice off dates
ggplot(data %>% filter(lake == "suwa") %>% filter(!is.na(ice_off_1)), aes(x=ice_on_1, y=ice_off_1))  + geom_point()

m1 <- lm(as.numeric(ice_off_1) ~ as.numeric(ice_on_1), data= data %>% filter(lake == "suwa") %>% filter(!is.na(ice_off_1)))
summary(m1)

## calculate regressions for each lake
fits <- data %>% filter(!is.na(ice_off_1))%>% filter(!is.na(ice_on_1)) %>%   ## Drop NAs
  group_by(lake) %>%  ## group by each lake
  do(glance(lm(as.numeric(ice_off_1) ~ as.numeric(ice_on_1), data=.))) ## run linear models on each
sort(fits$adj.r.squared)

## Repeat for second ice off
fits <- data %>% filter(!is.na(ice_off_2))%>% filter(!is.na(ice_on_2)) %>%   ## Drop NAs
  group_by(lake) %>%  ## group byh each lake
  do(glance(lm(as.numeric(ice_off_1) ~ as.numeric(ice_on_1), data=.))) ## run linear models on each
sort(fits$adj.r.squared)

## Repeat for third ice off
fits <- data %>% filter(!is.na(ice_off_3))%>% filter(!is.na(ice_on_3)) %>%   ## Drop NAs
  group_by(lakecode) %>%  ## group byh each lake
  do(glance(lm(as.numeric(ice_off_1) ~ as.numeric(ice_on_1), data=.))) ## run linear models on each
sort(fits$adj.r.squared)

### Check min and max date to next closest date
nextMin <- function(x){
  nextMinDate <- min(x, na.rm=T) - min(x[x != min(x, na.rm=T)], na.rm=T)
  nextYear <- abs(as.numeric(nextMinDate)/365) ## returns in # days, needs to be converted to years
  return(round(nextYear,0))
}

nextMax <- function(x){
  nextMaxDate <- max(x, na.rm=T) - max(x[x != max(x, na.rm=T)], na.rm=T)
  nextYear <- abs(as.numeric(nextMaxDate)/365) ## returns in # days, needs to be converted to years
  return(round(nextYear,0))
}

## Examine for each lake
data %>% group_by(lakecode) %>% summarize(min2iceOn = nextMin(ice_on_1), max2iceOn = nextMax(ice_on_1),
                                          min2iceOff = nextMin(ice_off_1), max2iceOff = nextMax(ice_off_1)) %>%   data.frame()

### Check the characters associated with each lake

## Convert multiple freeze dates to long format
data["ID"] <- row.names(data)

### convert each metric into long format
freezeYN <- data %>% select(ID, lakecode:froze_6, orig_duration:other_lakenames) %>%  ## select columns to gather
            gather(freezeEvent, froze, froze_1:froze_6)
iceOnwide <- data %>% select(ID, froze_1 = ice_on_1, froze_2 = ice_on_2,froze_3 = ice_on_3,froze_4 = ice_on_4,froze_5 = ice_on_5,froze_6 = ice_on_6 ) %>%  ## select columns to gather
  gather(freezeEvent, iceOn, froze_1:froze_6)
iceOffwide <- data %>% select(ID, froze_1 = ice_off_1, froze_2 = ice_off_2,froze_3 = ice_off_3, froze_4 = ice_off_4,froze_5 = ice_off_5,froze_6 = ice_off_6) %>%  ## select columns to gather
  gather(freezeEvent, iceOff, froze_1:froze_6)

## Join together datasets
longData <- plyr::join(freezeYN, iceOnwide)
longData <- plyr::join(longData, iceOffwide)

## Replace blanks with NA
longData$froze <- ifelse(longData$froze == "", NA,longData$froze )

simplified <- longData[!apply(longData[,c("froze","iceOn","iceOff")], 1 ,FUN= function(x) sum(is.na(x)))==3,]

write.csv(simplified[,-1], "data/PhenologyData.csv", row.names=FALSE)

### Extract the number of observations for the tables in manuscript
lengthNA <- function(x) { length(x[!is.na(x)])}
summaryOut <- simplified %>% summarize_all(lengthNA)/nrow(simplified)*100 %>% round(., 2)

# write.csv(summaryOut, "Table2.csv", row.names=F)


#!/usr/bin/env R
#!-*- coding: utf-8 -*-

d = read.csv('./data/10group-100n.csv')

lmm <- function(formula, data, niter = 1000) {
    require(data.table)
    # convert the data to data.table as well
    data = data.table(data)

    # process the formula
    f.terms = terms(formula)
    f.vars = attr(f.terms, "variables")
    if (attr(f.terms, "response") == 1) {
        outcome = as.character(f.vars[[2]])
    }
    intercept = attr(f.terms, "intercept")
    fixed = grep("[|]", attr(f.terms, "term.labels"), value=T, invert=T)

    # create the results matrix for storing samples
    samples = as.data.table(
        matrix(0,
               nrow = niter,
               ncol = intercept + length(fixed))
    )
    if (intercept == 1) {
        fixed = c('Intercept', fixed)
        data[, Intercept := 1]
    }
    setnames(samples, 1:ncol(samples), fixed)
    samples[, "sigma2" := 1]
    samples[1, x1 := 0.25]

    for (i in 2:niter) {
        inferFixedBeta(samples, data, i, fixed.vars = fixed, outcome = outcome)
        inferSigma2(samples, data, i, fixed.vars = fixed, outcome = outcome)
    }
    samples
}

inferFixedBetaMH <- function(samples, data, iter, fixed.vars, outcome, proposal.sd = 0.05) {
    sigma2 = as.numeric(samples[iter-1, 'sigma2', with=F])
    outcome.obs = data[, outcome, with=F]
    X = as.matrix(data[, fixed.vars, with=F])
    Beta = samples[iter-1, fixed.vars, with=F]
    logrand = log(runif(n = length(fixed.vars)))
    for (vi in 1:length(fixed.vars)) {
        v = fixed.vars[vi]
        old.beta = as.numeric(Beta[,v,with=F])
        new.beta = rnorm(1, mean = old.beta, sd = proposal.sd)

        # calculate the old loglikelihood
        log.g.old = - (1 / (2 * sigma2)) *
            sum((outcome.obs - X %*% t(Beta)) ** 2)

        # modify the beta value and calculate the new loglikelihood
        Beta[, eval(v):= new.beta]
        log.g.new = - (1 / (2 * sigma2)) *
            sum((outcome.obs - X %*% t(Beta)) ** 2)

        # compute candidate densities q for old and new beta
        # since the proposal distribution is normal this step is not needed
        log.q.old = 0
        log.q.new = 0

        # compute the moving probability
        moving.logprob = (log.g.new + log.q.old) - (log.g.old + log.q.new)
        samples[iter, eval(v) := ifelse(logrand[vi] < moving.logprob, new.beta, old.beta)]
    }
}

inferFixedBeta <- function(samples, data, iter, fixed.vars, outcome, proposal.sd = 0.05) {
    sigma2 = as.numeric(samples[iter-1, 'sigma2', with=F])
    outcome.obs = as.matrix(data[, outcome, with=F])
    X = as.matrix(data[, fixed.vars, with=F])
    Beta = samples[iter-1, fixed.vars, with=F]

    Mu = solve(t(X) %*% X) %*% t(X) %*% outcome.obs
    Sigma = sigma2 * solve(t(X) %*% X)
    require(MASS)
    samples[iter, eval(fixed.vars) := as.list(mvrnorm(1, Mu, Sigma))]

}

inferSigma2 <- function(samples, data, iter, fixed.vars, outcome) {
    alpha_0 = 1
    beta_0 = 1
    alpha_n = alpha_0 + nrow(data) / 2
    outcome.obs = as.matrix(data[, outcome, with=F])
    X = as.matrix(data[, fixed.vars, with=F])
    Beta = as.matrix(samples[iter-1, fixed.vars, with=F])
    beta_n = beta_0 + 0.5 * sum((outcome.obs - X %*% t(Beta)) ** 2)
    samples[iter, 'sigma2' := 1 / rgamma(1, shape = alpha_n, scale = 1 / beta_n)]
}


## Install and Load the Quandl Package for R
install.packages('Quandl')
library('Quandl')

# Load the [sense library](https://github.com/SensePlatform/sense-r-module) includes
# a number of helper functions you can use from within R dashboards.
library('sense')

## Load the Quandl Data
### [United States Unemployment Data](https://www.quandl.com/data/ODA/USA_LUR-United-States-Unemployment-Rate-of-Total-Labor-Force)
### The dataset identifier can be found on Qunadl.com
dataset = Quandl('ODA/USA_LUR')

### Once the data is loaded, it can be explored and analyzed
str(dataset)
summary(dataset)

plot(dataset$Date, dataset$Value,
    main='US Unemployment Over The Years',
    xlab='Year',
    ylab='Unemployment Rate',
    ylim=c(3,11),
    type='l',
    lwd=4,
    col='steelblue')

# It is clear to see the unemployment goes
# in cycles.  It rises quickly, then slowly falls,
# and then repeats.


## Dexter Barrows
## dbarrows.github.io
## McMaster University
## 2016

library(deSolve)
library(ggplot2)
library(reshape2)
library(gridExtra)
library(Rcpp)

SIR <- function(Time, State, Pars) {

    with(as.list(c(State, Pars)), {

        B   <- R0*r/N
        BSI <- B*S*I
        rI  <- r*I

        dS = -BSI
        dI = BSI - rI
        dR = rI

        return(list(c(dS, dI, dR)))

    })

}

T 		<- 100
N 		<- 500
sigma 	<- 10
i_infec <- 5

## Generate true trajecory and synthetic data
##

true_init_cond <- c(S = N - i_infec,
                    I = i_infec,
                    R = 0)

true_pars <- c(R0 = 3.0,
               r = 0.1,
               N = 500.0)

odeout <- ode(true_init_cond, 0:T, SIR, true_pars)
trueTraj <- odeout[,3]

set.seed(1001)

infec_counts_raw <- odeout[,3] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

g <- qplot(0:T, odeout[,3], geom = "line", xlab = "Time (weeks)", ylab = "Infection Count") +
		geom_point(aes(y = infec_counts)) +
		theme_bw()

print(g)
ggsave(g, filename="dataplot.pdf", height=4, width=6.5)

## Rcpp stuff
##

sourceCpp(paste(getwd(),"d_if2.cpp",sep="/"))

paramdata <- data.frame(if2(infec_counts, T+1, N))
colnames(paramdata) <- c("R0", "r", "sigma", "Sinit", "Iinit", "Rinit")

## Parameter density kernels
##

R0points <- paramdata$R0
R0kernel <- qplot(R0points, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
				geom_vline(aes(xintercept=true_pars[["R0"]]), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(R0kernel)
ggsave(R0kernel, filename="kernelR0.pdf", height=3, width=3.25)

rpoints <- paramdata$r
rkernel <- qplot(rpoints, geom = "density", xlab = "r", ylab = "frequency") +
				geom_vline(aes(xintercept=true_pars[["r"]]), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(rkernel)
ggsave(rkernel, filename="kernelr.pdf", height=3, width=3.25)

sigmapoints <- paramdata$sigma
sigmakernel <- qplot(sigmapoints, geom = "density", xlab = expression(sigma), ylab = "frequency") +
				geom_vline(aes(xintercept=sigma), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(sigmakernel)
ggsave(sigmakernel, filename="kernelsigma.pdf", height=3, width=3.25)

infecpoints <- paramdata$Iinit
infeckernel <- qplot(infecpoints, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
				geom_vline(aes(xintercept=true_init_cond[['I']]), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(infeckernel)
ggsave(infeckernel, filename="kernelinfec.pdf", height=3, width=3.25)

# show grid
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, ncol = 2, nrow = 2)

pdf("if2kernels.pdf", height = 6.5, width = 6.5)
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, ncol = 2, nrow = 2)
dev.off()


library(pracma)

for (idx in c(1,2*0:30)) {
  b <- bernoulli(idx)
  d <- as.character(denominator(b))
  n <- as.character(numerator(b))
  cat("B(",idx,") = ",n,"/",d,"\n", sep = "")
}


library(merkhet)
suppressMessages(library(float))
suppressMessages(library(fmlr))

m = 100000
n = 250
seed = 1234
type = "float"

# ------------------------------------------------------------------------------
b = bench(sprintf("svd - %dx%d (%s) type=%s", m, n, as.character(howbig(m, n, type=type)), type))

tol = ifelse(type=="double", 1e-8, 1e-4)

x = cpumat(m, n, type)
x$fill_rnorm(seed)
x_r = x$to_robj()

b$time(La.svd(x_r), name="R")

b$time({
  s = cpuvec(type=type)
  u = cpumat(type=type)
  vt = cpumat(type=type)

  ret_cpu = linalg_svd(x=x, s, u, vt)
}, name="fmlr - CPU")

if (fml_gpu())
{
  c = card()
  x_g = gpumat(c, type=type)
  cpu2gpu(x, x_g)

  b$time({
    s_g = gpuvec(c, type=type)
    u_g = gpumat(c, type=type)
    vt_g = gpumat(c, type=type)

    ret_gpu = linalg_svd(x=x_g, s_g, u_g, vt_g)
    c$synch()
  }, name="fmlr - GPU")
}

b$print()


require(Hmisc)
set.seed(1)
x <- seq(0, 1, by=0.01)
y1 <- x + x^2
y2 <- x - 2*x^3 + 1
png('/tmp/z.png')
plot(x, y1, type='l')
lines(x, y2)
xs <- rnorm(1000, .3, .3)
xs2 <- rnorm(1000, .7, .3)
histSpike(xs, curve=list(x=x, y=y1), add=TRUE)
histSpike(xs2, curve=list(x=x, y=y2), add=TRUE)
dev.off()


library(shiny)
library(shinythemes)
options(scipen = 999999999)
ui <- fluidPage(theme=shinytheme("flatly"),
  titlePanel("Likelihood Ratio for Mixed Results"),
  sidebarLayout(
    sidebarPanel(numericInput("n", "Number of studies :", 3, min = 1, max = 100),
                 numericInput("x", "Number of successes:", 2, min = 0, max = 100),
                 sliderInput("H0", "Type 1 error rate:", min = 0, max = 1, value = 0.05, step= 0.01),
                 sliderInput("H1", "Assumed Power:", min = 0, max = 1, value = 0.8, step= 0.01)
                 ),
    mainPanel(plotOutput("coolplot"),br(),
              h4("Shiny app accompanying: Lakens, D., & Etz, A. J. (2017). Too true to be bad: When sets of studies with significant and non-significant findings are probably true. Social Psychological and Personality Science. https://osf.io/preprints/psyarxiv/nnkg9"),br(),
              h4(textOutput("text1")), br(),
              h4(textOutput("text2")),br(),
              h4("When the observed results are equally likely under H0 and H1, the likelihood ratio is 1. Benchmarks to interpret Likelihood Ratios suggest that when 1<LR<8 there is weak evidence, when 8<LR<32 there is moderate evidence, and when LR>32, there is strong evidence."),br(),
              h4(textOutput("text3")), br(),
              dataTableOutput("table")
    )
  )
)
server <- function(input, output) {
  output$coolplot <- renderPlot({
    n<-input$n
    x<-input$x
    H0<-input$H0
    H1<-input$H1
    LR<-round(max(dbinom(x,n,H0)/dbinom(x,n,H1),dbinom(x,n,H1)/dbinom(x,n,H0)),digits=2) #Calculate LR (H1 over H0 and H0 over H1, pick max)
    H0H1<-ifelse(dbinom(x,n,H0)>dbinom(x,n,H1),"The data are more likely under the null hypothesis than the alternative hypothesis","The data are more likely under the alternative hypothesis than the null hypothesis")
    theta<- seq(0,1,len=1000)
    like <- dbinom(x,n,theta)
    plot(theta,like,type='l',xlab=expression(theta), ylab='Likelihood', lwd=2)
    points(H0,dbinom(x,n,H0), lwd=2)
    points(H1,dbinom(x,n,H1), lwd=2)
    segments(H0, dbinom(x,n,H0), x/n, dbinom(x,n,H0), lty=2, lwd=2)
    segments(H1, dbinom(x,n,H1), x/n, dbinom(x,n,H1), lty=2, lwd=2)
    segments(x/n, dbinom(x,n,H0), x/n, dbinom(x,n,H1), lwd=2)
    abline(v=H0, col="gray40", lty=3, lwd=2)
    abline(v=H1, col="gray40", lty=3, lwd=2)
    title(paste('Likelihood Ratio:',LR))

    #create Table
    studies<-c(0:n)
    ProbH0<-dbinom(studies,n,H0)
    ProbH1<-dbinom(studies,n,H1)
    table<-cbind(studies,ProbH0,ProbH1)
    colnames(table) <- c("Number of significant studies", "Probability of observing x out of n significant studies when H0 is true","Probability of observing x out of n significant studies when H1 is true")

    output$text1 <- renderText({
      paste("When H1 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given" ,H1, "power, is:", dbinom(x,n,H1),". If all studies examine true effects with",100*H1,"% power,",100*round(dbinom(x,n,H1),digits=4),"% of published articles with",n,"studies should observe",x,"significant results. When power is less than",100*round(0.5^(1/n), digits=4),"% observing",n,"out of",n,"significant results is less likely (i.e., occurs less than 50% of the time) than observing mixed results.")
    })
    output$text2 <- renderText({
      paste("When H0 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given a" ,H0, "Type 1 error rate, is:", round(dbinom(x,n,H0),digits=10),". When all studies examine null-effects with a",100*H0,"% Type 1 error rate,",100*round(dbinom(x,n,H0),digits=4),"% of published articles with",n,"studies should observe",x,"significant results.")
    })
    output$text3 <- renderText({
      paste(H0H1, "with a likelihood ratio of",LR,".")
    })
    output$table = renderDataTable(
      table,
      options = list(paging = FALSE, searching = FALSE)
    )
  })
}
shinyApp(ui = ui, server = server)


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

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

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

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

[Workspace loaded from ~/.RData]

 wbclust=read.csv("d:/WBClust2013.csv",header=T)
 head(wbclust)

 wbnorm<-scale(wbclust[,2:13])
 wbnorm

 rownames(wbnorm)=wbclust[,1]
 rownames(wbnorm)

 dist1<-dist(wbnorm, method="euclidean")

 clust1<-hclust(dist1,method="ward.D")
 clust1

 plot(clust1,labels= wbclust$Country, cex=0.7, xlab="",ylab="Distance",main="Clustering for 80 Most Populous Countries")

 rect.hclust(clust1,k=5)

 cuts=cutree(clust1,k=5)

 cuts
               China                India        United States            Indonesia
                   1                    2                    1                    2
              Brazil             Pakistan              Nigeria           Bangladesh
                   2                    3                    4                    3
  Russian Federation                Japan               Mexico          Philippines
                   1                    1                    2                    2
            Ethiopia              Vietnam     Egypt, Arab Rep.              Germany
                   4                    5                    2                    5
              Turkey             Thailand               France       United Kingdom
                   1                    5                    1                    1
               Italy         South Africa          Korea, Rep.             Tanzania
                   1                    1                    5                    4
            Colombia                Spain              Ukraine                Kenya
                   2                    1                    5                    4
             Algeria                Sudan               Canada                 Iraq
                   2                    3                    1                    2
             Morocco                 Peru           Uzbekistan             Malaysia
                   2                    2                    2                    5
        Saudi Arabia                Nepal                Ghana           Mozambique
                   1                    3                    3                    4
           Australia             Cameroon               Angola            Sri Lanka
                   1                    4                    4                    3
       Cote d'Ivoire                Chile           Kazakhstan          Netherlands
                   4                    1                    1                    5
             Ecuador            Guatemala             Cambodia               Zambia
                   2                    2                    3                    4
            Zimbabwe              Senegal              Belgium               Greece
                   3                    3                    5                    1
             Tunisia              Bolivia       Czech Republic             Portugal
                   5                    2                    5                    1
  Dominican Republic                Benin                Haiti              Hungary
                   2                    3                    3                    5
              Sweden              Belarus           Azerbaijan United Arab Emirates
                   5                    5                    2                    5
             Austria           Tajikistan             Honduras          Switzerland
                   5                    3                    3                    5
              Israel             Bulgaria               Serbia                 Togo
                   1                    5                    1                    4
            Paraguay               Jordan          El Salvador            Nicaragua
                   3                    5                    2                    3

 for (i in 1:5){
     print(paste("Countries in Cluster ",i))
     print(wbclust$Country[cuts==i])
     print (" ")
 }
[1] "Countries in Cluster  1"
 [1] China              United States      Russian Federation Japan
 [5] Turkey             France             United Kingdom     Italy
 [9] South Africa       Spain              Canada             Saudi Arabia
[13] Australia          Chile              Kazakhstan         Greece
[17] Portugal           Israel             Serbia
80 Levels: Algeria Angola Australia Austria Azerbaijan Bangladesh Belarus ... Zimbabwe
[1] " "
[1] "Countries in Cluster  2"
 [1] India              Indonesia          Brazil             Mexico
 [5] Philippines        Egypt, Arab Rep.   Colombia           Algeria
 [9] Iraq               Morocco            Peru               Uzbekistan
[13] Ecuador            Guatemala          Bolivia            Dominican Republic
[17] Azerbaijan         El Salvador
80 Levels: Algeria Angola Australia Austria Azerbaijan Bangladesh Belarus ... Zimbabwe
[1] " "
[1] "Countries in Cluster  3"
 [1] Pakistan   Bangladesh Sudan      Nepal      Ghana      Sri Lanka  Cambodia
 [8] Zimbabwe   Senegal    Benin      Haiti      Tajikistan Honduras   Paraguay
[15] Nicaragua
80 Levels: Algeria Angola Australia Austria Azerbaijan Bangladesh Belarus ... Zimbabwe
[1] " "
[1] "Countries in Cluster  4"
 [1] Nigeria       Ethiopia      Tanzania      Kenya         Mozambique
 [6] Cameroon      Angola        Cote d'Ivoire Zambia        Togo
80 Levels: Algeria Angola Australia Austria Azerbaijan Bangladesh Belarus ... Zimbabwe
[1] " "
[1] "Countries in Cluster  5"
 [1] Vietnam              Germany              Thailand
 [4] Korea, Rep.          Ukraine              Malaysia
 [7] Netherlands          Belgium              Tunisia
[10] Czech Republic       Hungary              Sweden
[13] Belarus              United Arab Emirates Austria
[16] Switzerland          Bulgaria             Jordan
80 Levels: Algeria Angola Australia Austria Azerbaijan Bangladesh Belarus ... Zimbabwe
[1] " "

Chapter 03/1Hierarchical Clustering - World Bank.r