#> -------------------------------------------------------------------------------------------------------------------------
#> grph.getBinomialCIRadius(data, format = 'AbsOverTotal', alpha = .05)
#>
#> Calculates a binomial confidence interval based on the normal approximation to the binomial distribution, as described in
#> http://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval
#>
#> data is matrix(ncol==2)
#> format is 'AbsOverTotal', 'AbsFreqs', or 'RateOverTotal'.
#> format=='AbsOverTotal' means mydata[,1] is an absolute number of 'Yes', and mydata[,2] is the total (i.e., 'Yes'+'No')
#> format=='AbsFreqs' means mydata[,1] is an absolute number of 'Yes', and mydata[,2] is an absolute number of 'No'
#> format=='RateOverTotal' means 0<=mydata[,1]<=1, and mydata[,2] is the total (i.e., 'Yes'+'No')
#> -------------------------------------------------------------------------------------------------------------------------
grph.getBinomialCIRadius = function(mydata, format='AbsOverTotal', alpha=.05) {
	#> Preconditions
	if (ncol(mydata)!=2)
		stop(paste('grph.getBinomialCIRadius(arg1) expects arg1[N,2]: arg1 has [', nrow(arg1), ',', ncol(arg1), ']', sep=''))
	if (alpha<.0001 | alpha>.5)
		warning('provided alpha was less than .0001 or more than .5')
	if (!is.numeric(mydata))
		stop('grph.getBinomialCIRadius(arg1) expects that arg1 is numeric. It is not.')

	if (format=='AbsOverTotal') {
		mydata[,1] = abs(mydata[,1]/mydata[,2])
	} else if (format=='AbsFreqs') {
		mydata[,2] = mydata[,1] + mydata[,2]
		mydata[,1] = abs(mydata[,1]/mydata[,2])
	} else if (format=='RateOverTotal') {
		if (sum(mydata[,1]>1)>0)
			stop("grph.getBinomialCIRadius with format='RateOverTotal' expects 0<mydata[,1]<1")
		mydata[,1] = abs(mydata[,1])
	} else {
		stop("grph.getBinomialCIRadius expects format==('AbsFreqs' | 'AbsOverTotal' | 'RateOverTotal')")
	}
	return(qnorm(1-alpha/2) * sqrt(abs(mydata[,1]) * (1-abs(mydata[,1])) / mydata[,2]))
}

#> -------------------------------------------------------------------------------------------------------------------------
#> grph.drawConfIntervals(data, coord, deltaless, deltaplus = deltaless, horizontal = TRUE)
#>
#> Given an open plot, it draws confidence intervals on it. It does not invoke grph.getBinomialCIRadius() to calculate the
#> width of the confidence intervals (you should provide the limits of the interval through deltaless and deltaplus).
#>
#> data should be an array or list such that 0<=data[i]<=1 for all i.
#> coord should be the coordinates of the other dimension (e.g.,if horizontal bars, then the yc coordinates).
#> deltaless should be the left (or bottom) limit of the interval.
#> deltaplus should be the right (or top) limit of the interval.
#> horizontal is TRUE if the bars are horizontal.
#> -------------------------------------------------------------------------------------------------------------------------
grph.drawConfIntervals = function(mydata, coord, deltaless, deltaplus = deltaless, horizontal = TRUE) {
	if (horizontal)
		arrows(mydata + deltaplus, coord, mydata - deltaless, coord, angle = 90, code = 3, length = 0.02)
	else
		arrows(coord, mydata + deltaplus, coord, mydata - deltaless, angle = 90, code = 3, length = 0.02)
}

grph.createOutputDevice = function(name, width = NULL, height = NULL) {
	if (is.null(name))
		return(NULL)
	endswith = function(name, suffix) { return(substr(name, nchar(name)-nchar(suffix), nchar(name))==paste('.',suffix,sep='')) }

	if (endswith(name, 'pdf')) {
		pdf(file = name, width = width, height = height)
		return('scalable')
	}

	if (endswith(name, 'eps')) {
		postscript(file = name, width = width, height = height, horizontal = FALSE, onefile = FALSE, paper = 'special')
		return('scalable')
	}

	if (endswith(name, 'bmp')) {
		bmp(filename = name, width = width, height = height, units = 'px')
		return('bitmap')
	}

	if (endswith(name, 'jpeg') | endswith(name, 'jpg')) {
		jpeg(filename = name, width = width, height = height, units = 'px', quality = 80)
		return('bitmap')
	}

	if (endswith(name, 'png')) {
		png(filename = name, width = width, height = height, units = 'px')
		return('bitmap')
	}

	if (endswith(name, 'tif') | endswith(name, 'tiff')) {
		tiff(filename = name, width = width, height = height, units = 'px', compression = 'zip')
		return('bitmap')
	}
	return(NULL)
}

#> -------------------------------------------------------------------------------------------------------------------------
#> -------------------------------------------------------------------------------------------------------------------------
grph.drawAxes = function(sides, cex=1.0) {
	for (i in sides) {
		axis(i, at=0:5/5, labels=paste(0:5*20, '%', sep=''), cex.axis=cex)
	}
}

#> -------------------------------------------------------------------------------------------------------------------------
#> grph.drawGrid(horizontal = TRUE, vertical = TRUE, diagonal = TRUE, xlim = c(0,1,.2), ylim = c(0,1,.2)
#>
#> Draws a grid within a plot.
#> horizontal: TRUE if you want horizontal lines drawn.
#> vertical: TRUE if you want vertical lines drawn.
#> diagonal: TRUE if you want a diagonal line (from left-bottom to right-top) drawn.
#> xlim: a set of three values, that could be fed to seq() to determine the anchor points for vertical lines.
#> ylim: a set of three values, that could be fed to seq() to determine the anchor points for horizontal lines.
#> -------------------------------------------------------------------------------------------------------------------------
grph.drawGrid = function(horizontal=TRUE, vertical=TRUE, diagonal=FALSE,
						 xlim=c(0,1,0.1), ylim=c(0,1,0.1)) {
	if (vertical) {
		for (i in seq(xlim[1],xlim[2],xlim[3])) {
			lines(c(i,i), c(ylim[1], ylim[2]), lty=3, col=clio.color('gridcol'))
		}
	}

	if (horizontal) {
		for (i in seq(ylim[1],ylim[2],ylim[3])) {
			lines(c(xlim[1],xlim[2]), c(i,i), lty=3, col=clio.color('gridcol'))
		}
	}

	if (diagonal) {
		lines(c(0,xlim[2]), c(0,ylim[2]), lty=3, col=clio.color('gridcol'))
	}
}

#> -------------------------------------------------------------------------------------------------------------------------
#> grph.drawText(thisdata, yc, thesetexts, cex=.8, cutoff=.05, voffset=0, within=TRUE)
#>
#> Draws text within/over/next to each bar segment in a plot.
#>
#> thisdata: the actual data, as graphed by the plot.
#> yc: the Y coordinates, as returned by the plot() function.
#> thesetexts: the texts to be put within each segment bar.
#> cex: font size.
#> cutoff: the proportion under which a label will not be drawn.
#> voffset: the vertical offset you want to give to the labels. Positive offsets
#>	move the labels upwards, negative offsets do the opposite.
#> within: if TRUE, puts the text within the bar segments; otherwise, it will
#>	put them next to the right of each bar.
#> -------------------------------------------------------------------------------------------------------------------------
grph.drawText = function(thisdata, yc, thesetexts, cex=.8, cutoff=.05, voffset=0, within=TRUE) {
	if (class(thisdata)!='matrix') {
		thisdata = matrix(ncol=1, data=thisdata)
	}

	if (class(thesetexts)!='matrix') {
		thesetexts = matrix(ncol=1, data=thesetexts)
	}

	#> If the texts go within the segment bars, the X position is half way the bar length.
	#> Otherwise, it is equal to the length of bar segments, plus a small horizontal offset.
	if (within) {
		suple = thisdata/2
	} else {
		suple = thisdata + round(max(thisdata)*.01,digits=1)
	}

	#> If there is more than one column, we adjust the horizontal positions.
	if (ncol(thisdata)>1) {
		for (i in 2:ncol(suple)) {
			for (j in 1:(i-1)) {
				suple[,i] = suple[,i] + thisdata[,j]
			}
		}
	}

	#> We remove the labels that do not have enough room to show.
	for (i in 1:nrow(thisdata)) {
		for (j in 1:ncol(thisdata)) {
			if (thisdata[i,j]<cutoff) {
				thesetexts[i,j] = ''
			}
		}
	}

	#> Finally, we put the texts.
	text(suple, yc+voffset, thesetexts, xpd=TRUE, cex=cex, adj=c(if (within) .5 else 0,.5))
}

#> -------------------------------------------------------------------------------------------------------------------------
#> grph.drawProportionWithin(thisdata, yc, digits=1, cutoff=.05, cex=.8)
#>
#> Draws a proportion within each segment bar in a plot.
#>
#> thisdata: the actual data, as graphed by the plot.
#> yc: the Y coordinates, as returned by the plot() function.
#> digits: the number of decimal digits to be fed to cf.asPercentage().
#> cex: font size.
#> cutoff: the proportion under which a label will not be drawn.
#> -------------------------------------------------------------------------------------------------------------------------
grph.drawProportionWithin = function(thisdata, yc, digits=1, cutoff=.05, cex=.9) {
	grph.drawText(thisdata, yc, cf.asPercentage(thisdata, digits=digits), cutoff=cutoff, cex=cex)
}

#> -------------------------------------------------------------------------------------------------------------------------
#> grph.proportionBarplot(data, filename = NULL, thiscolor = NULL,
#>		invert = FALSE, useconfidenceintervals = FALSE, useratiowithin = TRUE, horizontal = TRUE,
#>		width = 4, height = 3, alpha = 0.05, digits = 1, cutoff=.1,
#>		mar = c(1.0,1.0,1.0,1.0), mgp = c(1.0, 0.4, 0.0))
#>
#> Draws a simple proportion barplot.
#>
#> data has to be an Nx1 or Nx2 matrix. If Nx1, this function expect values between 0 and 1. In this case,
#>		useconfidenceintervals cannot be TRUE (if so, it will issue a warning). If Nx2, then [,1]
#>		will be interpreted as numerator and [,2] as denominator of a ratio.
#> thiscolor is a list of colors. length(thiscolor) should be equal to nrow(data), otherwise a warning
#>		will be shown and colors will be reused.
#> invert indicates whether you want to invert the ordering of the rows in data (so it does not appear
#>		from bottom to top).
#> useconfidenceintervals signals that you want to draw confidence intervals on top of each bar.
#> useratiowithin signals that you want to include the ratio within the bar. If data has one column, it
#>		draws the percentage; otherwise, it draws the ratio (that is, 'X/Y')
#> horizontal signals that you want horizontal bars. Horizontal bars are better when you have long labels for each bar.
#> alpha is the usual alpha value, needed if you want confidence intervals.
#> digits is the number of decimal digits in case you want the percentage included within each bar.
#> cutoff is the proportion under which the label will no be drawn. Sometimes some bars are too small to contain a label.
#> -------------------------------------------------------------------------------------------------------------------------
grph.proportionBarplot = function(mydata, filename = NULL, thiscolor = NULL, invert = FALSE,
					    useconfidenceintervals = FALSE, useratiowithin = TRUE, horizontal = TRUE,
					    width = 4, height = 3, alpha = 0.05, digits = 1, cutoff=.1,
					    mar = c(1.0,1.0,1.0,1.0), mgp = c(1.0, 0.4, 0.0), main='') {
	#> Preconditions
	if (!is.numeric(mydata))
		stop('grph.proportionBarplot(arg1) expects arg1 to be numeric. It is not.')
	if (class(mydata)!='matrix' | ncol(mydata)==0 | ncol(mydata)>2)
		stop(paste('grph.ProportionBarplot(arg1) expects arg1[N,1] or arg1[N,2]: arg1 has [', nrow(mydata), ',', ncol(mydata), ']', sep=''))
	if (ncol(mydata)==1 & useconfidenceintervals) {
		warning('grph.ProportionBarplot(useconfidenceintervals=TRUE): Cannot create confidence intervals without knowing the totals.', immediate.=TRUE)
		useconfidenceintervals = FALSE
	}

	#> We copy the data we'll send to graph
	thisdata = if (ncol(mydata)==1) mydata[,1] else mydata[,1]/mydata[,2]
	usingratio = (ncol(mydata)==1)

	#> Preparation of arguments
	if (is.null(thiscolor))
		thiscolor = rainbow(length(thisdata))
	if (length(thiscolor)!=length(thisdata))
		warning('grph.proportionBarplot: number of colors != length(data)')
	thisspace = rep.int(0.2, nrow(mydata))

	#> We invert the data if needed
	if (invert) {
		thisdata = rev(thisdata)
		thiscolor = rev(thiscolor)
		mydata = mydata[nrow(mydata):1,]
	}

	#> We create the device and the main barplot within it.
	tmp = grph.createOutputDevice(filename, width = width, height = height)
	par(mar = mar, mgp = mgp, xpd=T)

	#> We create the barplot
	yc = barplot(
		thisdata,
		xlim = if (horizontal) c(0,1) else NULL,
		ylim = if (horizontal) NULL else c(0,1),
		names.arg = rownames(thisdata),
		col = thiscolor,
		space = thisspace,
		horiz = horizontal,
		las = 1,
		axes = FALSE
	)

	if (main!='') {
		title(main, line=2, cex.main=.9)
	}

	#> Drawing the axes
	if (horizontal) {
		grph.drawAxes(c(1,3))
	} else {
		grph.drawAxes(c(2,4))
	}

	#> We draw the confidence intervals (which in reality are arrows)
	if (useconfidenceintervals)
	{
		grph.drawConfIntervals(thisdata, yc, grph.getBinomialCIRadius(mydata, alpha = alpha), horizontal = horizontal)
	}

	#> We put the labels within the bars
	if (useratiowithin)
	{
		if (usingratio) {
			grph.drawProportionWithin(thisdata, yc, digits=digits, cutoff=cutoff)
		} else {
			grph.drawText(thisdata, yc, paste(mydata[,1], mydata[,2], sep='/'), cutoff=cutoff)
		}
	}

	#> Turn off the device
	if (!is.null(filename)) dev.off()
}

grph.simpleBarplot = function(mydata, xlim = NULL,
							  stacked = FALSE, invert = FALSE, usenumberwithin = TRUE, cutoff = 0, legendposition = NULL,
							  thiscolor = NULL, width = 4, height = 3, mar = c(1.0, 1.0, 1.0, 1.0), mgp = c(1.0, 0.4, 0.0), fontfactor = 0.8,
							  main = '', filename = NULL) {

	#> Preconditions
	if (!is.numeric(mydata) | class(mydata)!='matrix')
		stop('grph.stackedProportionBarplot(arg1) expects arg1 to be a matrix of numeric values. It is not.')
	if (is.null(thiscolor))
		thiscolor = rainbow(ncol(mydata))
	if (length(thiscolor)!=ncol(mydata))
		warning(paste('grph.stackedProportionBarplot(arg1, ..., thiscolor=arg2) expects length(arg2)==ncol(arg1); it is not.'))

	#> We manipulate the data a little bit.
	thisdata = mydata
	if (stacked) {
		for (i in ncol(thisdata):2)
			thisdata[,i] = thisdata[,i] - thisdata[,i-1]
	}

	#> We invert the data if asked to
	if (invert) {
		thisdata = thisdata[nrow(thisdata):1,]
	}

	#> We draw the graph
	grph.createOutputDevice(filename, width = width, height = height)
	par(mar = mar, mgp = mgp, xpd = TRUE)
	yc = barplot(t(thisdata),
				 xlim = xlim,
				 horiz = TRUE,
				 width = 0.2,
				 las = 1,
				 cex.names = fontfactor,
				 col = thiscolor,
				 axes = TRUE,
				 main = main,
				 cex.main = fontfactor
	)

	#> We put the numbers
	if (usenumberwithin) {
		grph.drawText(thisdata, yc, thisdata, cutoff = cutoff, cex = thisfontfactor)
	}

	#> Legend
	if (!is.null(legendposition))
		legend(legendposition, colnames(thisdata), fill = thiscolor, cex = fontfactor, xpd = TRUE)

	#> We finish.
	if (!is.null(filename)) dev.off()
}

#> -------------------------------------------------------------------------------------------------------------------------
#> grph.stackedProportionBarplot(data, filename = NULL, thiscolor = NULL,
#>		useratiowithin = FALSE, uselegend = TRUE, invert = FALSE, stacked = FALSE, horizontal = TRUE,
#>		width = 4, height = 3, digits = 0,
#>		mar = c(1.0,1.0,1.0,1.0), mgp = c(1.0, 0.4, 0.0), legendoffset = 0.2)
#>
#> Draws a stacked proportion barplot; that is, M bars where each bar has N categories that do not add up to 100%. The graph
#> may include the percentages within each bar segment, and by default includes a legend. This type of graph with stacked=TRUE
#> is confusing, as it presents several bars on top of each other. Use with moderation :)
#>
#> data has to be a matrix of MxN, where 0<matrix[i,j]<1 for all i,j.
#> thiscolor is a list of colors. length(thiscolor) should be equal to nrow(data), otherwise a warning will be shown and colors
#>		will be reused.
#> useratiowithin signals that you want to include the ratio within the bar.
#> horizontal signals that you want horizontal bars. Horizontal bars are better when you have long labels for each bar.
#> -------------------------------------------------------------------------------------------------------------------------
grph.stackedProportionBarplot = function(mydata, filename = NULL, thiscolor = NULL,
						     useratiowithin = FALSE, uselegend = TRUE, invert = FALSE, stacked = FALSE, horizontal = TRUE,
						     width = 4, height = 3, digits = 0, cutoff = .1,
						     mar = c(1.0,1.0,1.0,1.0), mgp = c(1.0, 0.4, 0.0), legendoffset = 0.2, main = '', cex=.9) {

	#> Preconditions
	if (!is.numeric(mydata) | class(mydata)!='matrix')
		stop('grph.stackedProportionBarplot(arg1) expects arg1 to be a matrix of numeric values. It is not.')
	if (is.null(thiscolor))
		thiscolor = rainbow(ncol(mydata))
	if (length(thiscolor)!=ncol(mydata))
		warning(paste('grph.stackedProportionBarplot(arg1, ..., thiscolor=arg2) expects length(arg2)==ncol(arg1); it is not.'))
	if (ncol(mydata)<2)
		stop('grph.stackedProportionBarplot(arg1): arg1 has only one column. Use grph.proportionBarplot() instead.')

	#> We manipulate the data a little bit.
	thisdata = mydata
	if (stacked) {
		for (i in ncol(thisdata):2)
			thisdata[,i] = thisdata[,i] - thisdata[,i-1]
	}

	#> We invert the data if asked to
	if (invert) {
		thisdata = thisdata[nrow(thisdata):1,ncol(thisdata):1]
		mydata = mydata[nrow(mydata):1,ncol(thisdata):1]
	}

	#> We draw the graph
	tmp = grph.createOutputDevice(filename, width = width, height = height)
	par(mar = mar, mgp = mgp, xpd = TRUE)
	yc = barplot(t(thisdata),
			 horiz = horizontal,
			 beside = !stacked,
			 width = 0.2,
			 las = 1,
			 cex.names = 0.8,
			 col = if (invert) rev(thiscolor) else thiscolor,
			 axes = FALSE,
			 main = main
	)

	#> Ratio within each bar segment
	if (useratiowithin) {
		if (stacked) {
			grph.drawProportionWithin(t(thisdata), yc, digits=digits, cutoff=cutoff, horizontal=horizontal, cex=cex)
		} else {
			suple = as.numeric(t(thisdata))/2
			mylabs = paste(round(100*t(thisdata), 0), '%', sep='')
			text(if (horizontal) suple else yc, if (horizontal) yc else suple, mylabs,
				 xpd = TRUE,
				 adj = if (horizontal) c(0.5, NA) else c(NA, 0.5))
		}
	}

	#> Legend
	if (uselegend & !is.null(colnames(thisdata)))
		legend('bottom', if (invert) rev(colnames(thisdata)) else colnames(thisdata),
			 inset = -1*legendoffset,
			 fill = thiscolor,
			 cex = 0.7,
			 xpd = TRUE)

	#> Axes
	if (horizontal) {
		grph.drawAxes(c(1,3))
	} else {
		grph.drawAxes(c(2,4))
	}

	if (!is.null(filename)) dev.off()
}

#> -------------------------------------------------------------------------------------------------------------------------
#> grph.stackedFullProportionBarplot(data, filename = NULL, thiscolor = NULL,
#>		useratiowithin = FALSE, uselegend = TRUE, invert = FALSE, showaxes = TRUE, horizontal = TRUE,
#>		width = 4, height = 3, digits = 0, cutoff = .1,
#>		mar = c(1.0,1.0,1.0,1.0), mgp = c(1.0, 0.4, 0.0), legendoffset = 0.2)
#>
#> Draws a full stacked proportion barplot; that is, M bars where each bar has N categories that all add up to 100%. The graph
#> may include the percentages within each bar segment, and by default includes a legend.
#>
#> data has to be a matrix of MxN. If the sum of the values of the first row add up to 1.0 (with a .001 tolerance),
#> then each value will be interpreted as proportions. Otherwise, rows will be summed up and divided by the total.
#> showaxes signals whether you want the axes drawn or not.
#> The rest of the parameters are similar to the previous functions.
#> -------------------------------------------------------------------------------------------------------------------------
grph.stackedFullProportionBarplot = function(mydata, filename = NULL, thiscolor = NULL,
						     useratiowithin = FALSE, uselegend = TRUE, invert = FALSE,
						     showaxes = TRUE, horizontal = TRUE,
						     width = 4, height = 3, digits = 0, cutoff = .1, cex=c(1,1,1),
						     mar = c(1.0,1.0,1.0,1.0), mgp = c(1.0, 0.4, 0.0), legendoffset = 0.2, main = '') {
	#> Preconditions
	if (is.null(thiscolor))
		thiscolor = rainbow(ncol(mydata))
	if (length(thiscolor)!=ncol(mydata))
		warning(paste('grph.stackedFullProportionBarplot(arg1, ..., thiscolor=arg2) expects length(arg2)==ncol(arg1); it is not.'))

	#> We manipulate the data a little bit.
	if (abs(sum(mydata[1,])-1.0)<=0.001) {
		thisdata = mydata
	} else {
		thisdata = mydata / rowSums(mydata)
	}

	#> We invert the data if asked to
	if (invert) thisdata = thisdata[nrow(thisdata):1,]

	#> We draw the graph
	tmp = grph.createOutputDevice(filename, width = width, height = height)
	par(mar = mar, mgp = mgp, xpd = TRUE)
	yc = barplot(t(thisdata),
			 horiz = horizontal,
			 width = 0.2,
			 las = 1,
			 col = thiscolor,
			 axes = FALSE,
			 cex.names = cex[1]
	)

	#> Axes
	if (showaxes) {
		if (horizontal) {
			grph.drawAxes(c(1,3))
		} else {
			grph.drawAxes(c(2,4))
		}
	}

  #> Title
	if (main!='') {
	  title(main=main, line=2.2, cex.main=0.9)
	}

	#> Ratio within each bar segment
	if (useratiowithin) {
		grph.drawProportionWithin(thisdata, yc, digits=digits, cutoff=cutoff, cex=cex[2])
	}

	#> Legend
	if (uselegend & !is.null(colnames(thisdata)))
		legend('right', colnames(thisdata), inset = -1*legendoffset, fill = thiscolor, cex = cex[3], xpd = TRUE)

	if (!is.null(filename)) dev.off()
}


#############################################
# Part i
n = 200
p = 0.3
rho = -0.3

# subfunction needed to generate data
calcbij = function(rho,i){
  a = ((1-4*rho*rho)^0.5-1)/(2*rho)
  j = i-1
  bi = (a^(1:j) - a^(-(1:j)))/(a^-i - a^(i))
  return(bi)
}

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataPW = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    bi = calcbij(rho,i)
    prob = p + sum(bi*(dat[1:j]-p))
    if(prob < 0) prob = 0.0001
    if(prob > 1) prob = 0.9999
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataPW(n,p,rho)
}
write(t(x),"p.30_pair.neg30_n200_r100.txt",ncol=n) # each row in this file is a different simulated song

#############################################
# Part ii
n = 600
p = 0.3
rho = -0.3

# subfunction needed to generate data
calcbij = function(rho,i){
  a = ((1-4*rho*rho)^0.5-1)/(2*rho)
  j = i-1
  bi = (a^(1:j) - a^(-(1:j)))/(a^-i - a^(i))
  return(bi)
}

# function to generate one dataset
# following Qaqish (2003) algorithm
gendataPW = function(n,p,rho){
  dat = c(rbinom(1,1,p),rep(NA,n-1))
  for(i in 2:n){
    j = i-1
    bi = calcbij(rho,i)
    prob = p + sum(bi*(dat[1:j]-p))
    if(prob < 0) prob = 0.0001
    if(prob > 1) prob = 0.9999
    dat[i] = rbinom(1,1,prob)
  }
  return(dat)
}

# Generate 100 replicates
x = matrix(NA,100,n)
for(r in 1:100){
  x[r,]=gendataPW(n,p,rho)
}
write(t(x),"p.30_pair.neg30_n600_r100.txt",ncol=n)   # each row in this file is a different simulated song


calculate <- function(sequence) {
  if (sequence <= 1) {
    return(1)
  }

  return(calculate(sequence - 1) + calculate(sequence - 2))
}


library(caret)

set.seed(1433)

churn <- get(load("churn.RData"))
colnames(churn)

glm_churn <- churn[1:4000,]
ind <- sapply(glm_churn, is.numeric)
glm_churn[ind] <- lapply(glm_churn[ind], scale)

glm_churn_test <-churn[4001:5000,]
ind <- sapply(glm_churn_test, is.numeric)
glm_churn_test[ind] <- lapply(glm_churn_test[ind], scale)

train_control <- trainControl(method = "repeatedcv", number = 100, repeats = 10)

detach(glm_churn)
attach(glm_churn)

############### CLASSICAL FITTING

# Obvious model
model <- glm(churned ~ state+area_code+account_length+international_plan+voice_mail_plan+number_vmail_messages+
             total_day_minutes+total_day_calls+total_eve_minutes+total_eve_calls+total_night_minutes+total_night_calls+total_intl_minutes+total_intl_calls+
             total_charge+number_customer_service_calls, family=binomial(link=logit))
# According to model, most relevant variables are international_plan, voice_mail_plan, number_vmail_messages, total_intl_calls, number_customer_service_calls

#model <- glm(churned ~ state+area_code+account_length+voice_mail_plan+number_vmail_messages*number_customer_service_calls*total_charge+
#               total_day_minutes*total_day_calls+total_eve_minutes*total_eve_calls+total_night_minutes*total_night_calls+total_intl_minutes*total_intl_calls*international_plan
#             , family=binomial(link=logit))

# Good model 1
model <- glm(churned ~
               voice_mail_plan*number_vmail_messages*international_plan*total_charge+
               number_customer_service_calls*international_plan*total_charge+
               total_intl_minutes*total_intl_calls*international_plan*total_charge
             , family=binomial(link=logit))

# Good model 2
model <- glm(churned ~
               number_vmail_messages*international_plan*total_charge+
               number_customer_service_calls*international_plan*total_charge+
               total_intl_minutes*total_intl_calls*international_plan*total_charge
             , family=binomial(link=logit))

# Good model 3
model <- glm(churned ~
               voice_mail_plan*international_plan*total_charge+
               number_customer_service_calls*international_plan*total_charge+
               total_intl_minutes*total_intl_calls*international_plan*total_charge
             , family=binomial(link=logit))

# Good model 4 BEST SMALL
model <- glm(churned ~
               voice_mail_plan*international_plan*total_charge+
               number_customer_service_calls*international_plan*total_charge+
               total_intl_minutes*total_intl_calls*international_plan
             , family=binomial(link=logit))

# Good model 5 BEST BIG
model <- glm(churned ~
               voice_mail_plan*international_plan*total_charge+
               number_customer_service_calls*total_intl_minutes*total_intl_calls*international_plan*total_charge
             , family=binomial(link=logit))

# Good model 6 BEST MEDIUM
model <- glm(churned ~
               voice_mail_plan*international_plan*total_charge+
               number_customer_service_calls*international_plan*total_charge+
               number_customer_service_calls*international_plan*total_intl_minutes*total_intl_calls
             , family=binomial(link=logit))

# Model 7 MONSTER (spoiler: OVERFITS)
model <- glm(churned ~
               voice_mail_plan*international_plan*total_charge*number_customer_service_calls*total_intl_minutes*total_intl_calls*account_length
             , family=binomial(link=logit))

############### 100-FOLD CV

# Obvious model
(cv_model <- train(churned ~ state+area_code+account_length+international_plan+voice_mail_plan+number_vmail_messages+
               total_day_minutes+total_day_calls+total_eve_minutes+total_eve_calls+total_night_minutes+total_night_calls+total_intl_minutes+total_intl_calls+
               total_charge+number_customer_service_calls,
               data = glm_churn,
               trControl = train_control,
               method = "glm",
               family=binomial(link=logit)))

# Good model 1
(cv_model <- train(churned ~ voice_mail_plan*number_vmail_messages*international_plan*total_charge+
                 number_customer_service_calls*international_plan*total_charge+
                 total_intl_minutes*total_intl_calls*international_plan*total_charge,
               data = glm_churn,
               trControl = train_control,
               method = "glm",
               family=binomial(link=logit)))

# Good model 2
(cv_model <- train(churned ~ number_vmail_messages*international_plan*total_charge+
                  number_customer_service_calls*international_plan*total_charge+
                  total_intl_minutes*total_intl_calls*international_plan*total_charge,
                data = glm_churn,
                trControl = train_control,
                method = "glm",
                family=binomial(link=logit)))

# Good model 3
(cv_model <- train(churned ~ voice_mail_plan*international_plan*total_charge+
                  number_customer_service_calls*international_plan*total_charge+
                  total_intl_minutes*total_intl_calls*international_plan*total_charge,
                data = glm_churn,
                trControl = train_control,
                method = "glm",
                family=binomial(link=logit)))

# Good model 4 BEST SMALL
(cv_model <- train(churned ~ voice_mail_plan*international_plan*total_charge+
                  number_customer_service_calls*international_plan*total_charge+
                  total_intl_minutes*total_intl_calls*international_plan,
                data = glm_churn,
                trControl = train_control,
                method = "glm",
                family=binomial(link=logit)))

# Good model 5 BEST BIG
(cv_model <- train(churned ~ voice_mail_plan*international_plan*total_charge+
                  number_customer_service_calls*total_intl_minutes*total_intl_calls*international_plan*total_charge,
                data = glm_churn,
                trControl = train_control,
                method = "glm",
                family=binomial(link=logit)))

# Good model 6 BEST MEDIUM
(cv_model <- train(churned ~ voice_mail_plan*international_plan*total_charge+
                  number_customer_service_calls*international_plan*total_charge+
                  number_customer_service_calls*international_plan*total_intl_minutes*total_intl_calls,
                data = glm_churn,
                trControl = train_control,
                method = "glm",
                family=binomial(link=logit)))

# Model 7 MONSTER (spoiler: OVERFITS)
(cv_model <- train(churned ~ voice_mail_plan*international_plan*total_charge*number_customer_service_calls*total_intl_minutes*total_intl_calls*account_length,
                data = glm_churn,
                trControl = train_control,
                method = "glm",
                family=binomial(link=logit)))

############### PROPERTIES

summary(model)
coef(model)
length(coef(model))

############### TEST

preds <- predict (model, glm_churn_test,type="response")
preds <- as.factor(round(preds))
levels(preds) = c("no","yes")

(tab <- table(Truth=glm_churn_test$churned, Preds=preds))
sum(tab[row(tab)==col(tab)])/sum(tab)


library("ggplot2")

euclidean <- function(v1,v2) sqrt(sum(v1^2 - v2^2))

approx <- function(actual, learned) {
  err <- numeric(length=nrow(actual))
  for (i in 1:nrow(actual)) {
      err[i] <- euclidean(actual[i,],learned[i,])
  }
  return(err)
}

errByConf <- function(m, conf) {
  d <- m[which(m$Conference==conf),]
  d <- d[order(d$Year),]
  d$Conference <- NULL

  return(approx(d,d))
}

evalByYear <- function(file) {
  d <- data.frame(read.table(file,header=TRUE,sep=",",quote="\""))

  m <- aggregate(d, by=list(d$Year,d$Conference), FUN=mean)

  popl_errs <- errByConf(m, "POPL")
#  pldi_errs = errByConf(m, "PLDI")

#  return(c(popl_errs, pldi_errs))
}

evalByYear("fulltext_lda20.csv")


# Add Libraries
library(ggplot2)
library('ISLR')
library(tidyverse)
attach(College)

ggplot(mapping = aes(x = Top10perc, y = Outstate)) +
    geom_jitter() +
    geom_smooth()

ggplot(mapping = aes(x = Top10perc, y = Outstate,
 color = Private)) +
        geom_jitter() +
        geom_smooth()

ggplot(College, mapping = aes(x = Top10perc, y = Outstate)) +
facet_wrap(~ Private) +
  geom_jitter() +
  geom_smooth()

ggplot(mapping = aes(x = Top10perc, y = Outstate)) +
  geom_jitter() +
  geom_smooth(method = "lm")

x <- Top10perc
y <- Outstate
ggplot(mapping = aes(x = x, y = y)) +
     geom_jitter(color="red") +
     geom_smooth(method=lm, se=FALSE) +
     geom_segment(aes(x=x, xend=x, y=y, yend=lm(y ~ x)$fitted.values))


# load required library
library(class)

#################################################
# PREPROCESSING
#################################################

data <- iris                # create copy of iris dataframe
labels <- data$Species      # store labels
data$Species <- NULL        # remove labels from feature set (note: could
                            # alternatively use neg indices on column index in knn call)

#################################################
# TRAIN/TEST SPLIT
#################################################

set.seed(1)         # initialize random seed for consistency
                    # NOTE -- run for various seeds --> need for CV!

train.pct <- 0.7    # pct of data to use for training set
N <- nrow(data)     # total number of records (150)

train.index <- sample(1:N, train.pct * N)       # random sample of records (training set)

train.data <- data[train.index, ]       # perform train/test split
test.data <- data[-train.index, ]       # note use of neg index...different than Python!

train.labels <- labels[train.index]     # extract training set labels
test.labels <- labels[-train.index]     # extract test set labels

#################################################
# APPLY MODEL
#################################################

err.rates <- data.frame()       # initialize results object

max.k <- 100
for (k in 1:max.k)              # perform fit for various values of k
{
    knn.fit <- knn(train = train.data,          # training set
                    test = test.data,           # test set
                    cl = train.labels,          # true labels
                    k = k                       # number of NN to poll
               )

    cat('\n', 'k = ', k, ', train.pct = ', train.pct, '\n', sep='')     # print params
    print(table(test.labels, knn.fit))          # print confusion matrix

    this.err <- sum(test.labels != knn.fit) / length(test.labels)    # store gzn err
    err.rates <- rbind(err.rates, this.err)     # append err to total results
}

#################################################
# OUTPUT RESULTS
#################################################

results <- data.frame(1:max.k, err.rates)   # create results summary data frame
names(results) <- c('k', 'err.rate')        # label columns of results df

# create title for results plot
title <- paste('knn results (train.pct = ', train.pct, ')', sep='')

# create results plot
results.plot <- ggplot(results, aes(x=k, y=err.rate)) + geom_point() + geom_line()
results.plot <- results.plot + ggtitle(title)

# draw results plot (note need for print stmt inside script to draw ggplot)
print(results.plot)

idx <- sample(nrow(data), nrow(data))
err.rates <- data.frame(k=factor(), err=numeric())
for (k in seq(5, 13)){
  for (i in seq(1, 130, 30)) {
    test.index <- idx[i:(i+29)]
    test.data <- data[test.index,]
    train.data <- data[-test.index,]
    train.labels <- labels[-test.index]
    test.labels <- labels[test.index]
    knn.fit <- knn(train = train.data, test = test.data,
                   cl=train.labels, k = k)
    cat('\n', 'k = ', k, ', train.pct = ', train.pct, '\n', sep='')     # print params
    print(table(test.labels, knn.fit))          # print confusion matrix

    this.err <- sum(test.labels != knn.fit) / length(test.labels)    # store gzn err
    err.rates <- rbind(err.rates, data.frame(k=k, err=this.err))     # append err to total results
  }
}
ggplot(err.rates, aes(k, err)) + geom_smooth()

#################################################
# NOTES
#################################################

# what happens for high values (eg 100) of max.k? have a look at this plot:
# > results.plot <- ggplot(results, aes(x=k, y=err.rate)) + geom_smooth()

# our implementation here is pretty naive, meant to illustrate concepts rather
# than to be maximally efficient...see alt impl in DMwR package (with feature
# scaling):
#
# > install.packages('DMwR')
# > library(DMwR)
# > knn

# ed. note: how not to do it (black box)
# http://en.wikibooks.org/wiki/Data_Mining_Algorithms_In_R/Classification/kNN

# R docs
# http://cran.r-project.org/web/packages/class/class.pdf
# http://cran.r-project.org/web/packages/DMwR/DMwR.pdf


"
Написать формулу получения 10 случайных целых чисел из диапазона (min = -7, max = 28
с помощью функции runif(),
не используя при ее вызове задания минимального и максимального значений.
"
{
checker <- function(n,min,max){
  return(floor((runif(n) * ((max - min) + 1)) + min))
}

n <- 10
min <- -7
max <- 28
print(checker(n,min,max))

}


#  Bubblesort implementation in R

bubbleSort <- function(x){
  i = 1
  while(i < length(x)){
    j = i
    while(j <= length(x)){
      if(x[i] > x[j]){
        tmp = x[i]
        x[i] = x[j]
        x[j] = tmp
      }
      j = j+1
    }
    i = i+1
  }

  return(x)
}

x <- c(7,19,3,15,22,4,9,100, 6)

print(x)
print(bubbleSort(x))


#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Full Investment Constraints
cset.sum <- function(returns, sum=1){
  p = ncol(returns)
  constaint.sum <- rep(1,p)
  A = cbind(constaint.sum) # Constraint matrix
  colnames(A) <- "c.sum"
  b = sum                  # Constraint bound
  meq = 1
  # cset.lo = constraints(A,b,meq)
  return(list(A=A,b=b,meq=meq,cname="cset.sum"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Long-Only Constraints
cset.lo <- function(returns){
p = ncol(returns)
A = diag(rep(1,p)) # Constraint matrix
colnames(A) <- paste("c.long.only",1:ncol(A),sep="")
b = c(rep(0,p))                   # Constraint bound
meq = 0
# cset.lo = constraints(A,b,meq)
return(list(A=A,b=b,meq=meq,cname="cset.lo"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Box Constraints
cset.box <- function(returns,upper,lower){
p = ncol(returns)

if(length(upper)==1)
  upper <- rep(upper, p)

if(length(lower)==1)
  lower <- rep(lower, p)

constraint.box <-cbind(diag(rep(1,p)),diag(rep(-1,p)))
A = cbind(constraint.box)
colnames(A) <- paste("c.box",
                     c(paste(".low",rep(1:(ncol(constraint.box)/2)),sep=""),
                     paste(".up",rep(1:(ncol(constraint.box)/2)),sep="")),sep="")
b = c(lower,-upper)
meq = 0
# cset.box = constraints(A,b,meq)
return(list(A=A,b=b,meq=meq,cname="cset.box"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Group Constraints
cset.groups <- function(returns=returns8,
                        group=c(1,1,1,2,3,3,4,4),
                        upper.group=rep(0.2,4),
                        lower.group=rep(-0.2,4)){
p = ncol(returns)

if(length(upper.group)==1)
  upper.group <- rep(upper.group, length(unique(group)))

if(length(lower.group)==1)
  lower.group <- rep(lower.group, length(unique(group)))

if(!all(length(group)==p,length(upper.group)==length(unique(group)), length(lower.group)==length(unique(group))))
  stop("any of the length of group/upper/lower bounds is not equal to the number of assets")

if(length(upper.group)==1)
  rep(upper.group, length(group))

if(length(lower.group)==1)
  rep(lower.group, length(group))

gnum <- length(unique(group))
glist <- lapply(unique(group),function(x) which(x == group))
names(glist) <- unique(group)
Ag <- t(sapply(glist, function(x) {
  re <- rep(0,p)
  re[x] <- 1
  re}))
Atp = rbind(Ag,-Ag)
constraint.groups = t(Atp)
A <- cbind(constraint.groups)
colnames(A) <-  paste("c.groups",
                      c(paste(".low",rep(1:(ncol(constraint.groups)/2)),sep=""),
                      paste(".up",rep(1:(ncol(constraint.groups)/2)),sep="")),sep="")
bglo = c(lower.group)
bgup = c(upper.group)
b = c(bglo,-bgup)
meq = 0
# cset.groups = constraints(A,b,meq)
return(list(A=A,b=b,meq=meq,cname="cset.groups"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Turnover Constraints

cset.turnover <- function(returns,toc,w.initial){
	p = ncol(returns)
	constraint.turnover <- c(rep(0,p),rep(-1,p),rep(1,p))
#	constraint.weights.initial <- rbind(diag(p),matrix(0,ncol=p,nrow=p*2))
#	constraint.weights.finalsum <- c(rep(1,p),rep(0,2*p))
	constraint.weights.initial <- rbind(diag(1,p),diag(-1,p),diag(-1,p))
	constraint.weights.positive <-
			rbind(matrix(0,ncol=2*p,nrow=p),diag(2*p))
	temp.index <- (p*3-p+1):(p*3)
	#need to flip sign for w_sell
	constraint.weights.positive[temp.index,]<-
			constraint.weights.positive[temp.index,]*-1

	A <- cbind(constraint.weights.initial,
			constraint.turnover, constraint.weights.positive)
	colnames(A) <- c(paste("c.winit",1:p,sep=""),
			"c.turnover",
			paste("c.wpos",1:ncol(constraint.weights.positive),sep=""))
	b <- c(w.initial,-toc,rep(0,2*p))
	meq <- p+1
	return(list(A=A,b=b,meq=meq,cname="cset.turnover"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Turnover Constraints made by hobbs
cset.turnover.hobbs <- function(returns,toc,w.initial){
	p = ncol(returns)
	constraint.turnover <- c(rep(0,p),rep(-1,p),rep(1,p))
	constraint.weights.initial <- rbind(diag(p),matrix(0,ncol=p,nrow=p*2))
	constraint.weights.positive <-
			rbind(matrix(0,ncol=2*p,nrow=p),diag(2*p))
	temp.index <- (p*3-p+1):(p*3)
	#need to flip sign for w_sell
	constraint.weights.positive[temp.index,]<-
			constraint.weights.positive[temp.index,]*-1

	A <- cbind(constraint.weights.initial,
			constraint.turnover, constraint.weights.positive)
	colnames(A) <- c( paste("c.winit",1:ncol(constraint.weights.initial),sep=""),
			"c.turnover",
			paste("c.wpos",1:ncol(constraint.weights.positive),sep=""))
	b <- c(w.initial,-toc,rep(0,2*p))
	meq <- p

	return(list(A=A,b=b,meq=meq,cname="cset.turnover"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

#Proportional Cost Constraints
cset.propcost<- function(returns, ptc,w.initial){
  p = ncol(returns)
  dvec <- rep(0,p*3) #no linear part in this problem
  #left hand side of constraints
  if(length(ptc)==1){
    ptc = rep(ptc,p)
  }
  if(length(ptc)!=p){
    stop("ptc must either be a single value, or the same length as the number of assets")
  }

  constraint.sum.prop <- c(rep(1,p),1+ptc,(1-ptc))
  constraint.weights.initial <- rbind(diag(p),matrix(0,ncol=p,nrow=p*2))
  constraint.weights.positive <-
    rbind(matrix(0,ncol=2*p,nrow=p),diag(2*p))
  temp.index <- (p*3-p+1):(p*3)
  #need to flip sign for w_sell
  constraint.weights.positive[temp.index,]<-
  constraint.weights.positive[temp.index,]*-1
  #put left hand side of constraints into constraint matrix
  A <- cbind(constraint.sum.prop, constraint.weights.initial,
             constraint.weights.positive)
  colnames(A) <- c("c.sum.prop",
                   paste("c.winit",1:ncol(constraint.weights.initial),sep=""),
                   paste("c.wpos",1:ncol(constraint.weights.positive),sep=""))
  #right hand side of constraints in this vector
  b <- c(1, w.initial,rep(0,2*p))
  n.eq = 1+ p
  return(list(A=A,b=b,meq=n.eq,cname="cset.propcost"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Target MU Constraints
cset.mu.target <- function(returns, mu.target){
  p = ncol(returns)
  mu = apply(returns,2, mean)
  A = cbind(mu)
  colnames(A) <- "c.mu.target"
  b = mu.target
  meq = 1
  return(list(A=A,b=b,meq=meq,cname="cset.mu.target"))
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

cset.fixed <- function(returns, fixed.cost, wmax, wmin){

  # TBA
}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Modify constaints when turnover kicks in
turnover.hobbs.modify <- function(cset=cset.i){
  switch(cset$cname,
          "cset.sum" = {
            cset.new <- cset
            cset.new$A <- rbind(cset$A,cset$A,cset$A)
            colnames(cset.new$A) <- colnames(cset$A)
            cset.new$b <- cset$b
            cset.new$meq <- cset$meq
            cset.new
          },

         "cset.lo" = { #may not be needed
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.box" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.groups" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

        "cset.mu.target" = {
          cset.new <- cset
          cset.new$A <- rbind(cset$A,cset$A,cset$A)
          colnames(cset.new$A) <- colnames(cset$A)
          cset.new$b <- cset$b
          cset.new$meq <- cset$meq
          cset.new
        }
      )

}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Modify constaints when turnover kicks in
turnover.modify <- function(cset=cset.i){

	makenullmat <- function(A){matrix(0,nrow=nrow(A),ncol=ncol(A))}

	switch(cset$cname,
			"cset.sum" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.lo" = { #may not be needed
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.box" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.groups" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			},

			"cset.mu.target" = {
				cset.new <- cset
				cset.new$A <- rbind(cset$A,
						makenullmat(cset$A),makenullmat(cset$A))
				colnames(cset.new$A) <- colnames(cset$A)
				cset.new$b <- cset$b
				cset.new$meq <- cset$meq
				cset.new
			}
	)

}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export

# Modify constaints when propcost kicks in
propcost.modify <- function(cset=cset.i){
  switch(cset$cname,
         "cset.sum" = {
           stop("sum constraint are not combinable with propcost constraint")
         },

         "cset.lo" = { #may not be needed
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.box" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.groups" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b
           cset.new$meq <- cset$meq
           cset.new
         },

         "cset.mu.target" = {
           cset.new <- cset
           cset.new$A <- rbind(cset$A,cset$A,cset$A)+1
           colnames(cset.new$A) <- colnames(cset$A)
           cset.new$b <- cset$b+1
           cset.new$meq <- cset$meq
           cset.new
         }
  )

}

#' Constraint specifications
#' @param NULL
#' @details
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @keywords constraint
#' @family constraints
#' @examples
#' @export
# Combine multiple constraints
combine.cset <- function(clist=c(  "sum",
                                   "lo",
                                   "box",
                                   "groups",
                                   "mu.target",
                                   "turnover.hobbs",
								   								 "turnover",
                                   "propcost"),
                         returns=returns,
                         list.arg=
                           list(sum=NULL,
                                mu.target=NULL,
                                w.initial=NULL,
                                toc=NULL,
                                upper=NULL,
                                lower=NULL,
                                group=NULL,
                                upper.group=NULL,
                                lower.group=NULL,
                                ptc=NULL),
						verbose=T
                                ){

  clist <- unique(clist)

  if("turnover.hobbs" %in% clist)
    is.turnover.hobbs <- TRUE else is.turnover.hobbs <- FALSE
  if("propcost" %in% clist)
    is.propcost <- TRUE else is.propcost <- FALSE
  if("turnover" %in% clist)
	is.turnover <- TRUE else is.turnover <- FALSE

  clist.names <- clist
  arg.sum.list <- list.arg
  arg.sum.list$returns <- returns
  cset <- list(NA)

	if(!any(c("sum","propcost")%in% clist.names )){
		clist.names <- c("sum",clist.names)
		arg.sum.list$sum = 1
	}

  # loop through each constraint
  for ( i in 1:length(clist.names)){
	if(verbose)
    cat(clist.names[i],"\n")
    clist.names.i <- paste("cset.",clist.names[i],sep="")
    args.names <- names(formals(clist.names.i))

    # loop through each argument
    for (ii in 1:length(args.names))    {
      if(is.null(eval(parse(text=paste("arg.sum.list$",args.names[ii],sep="")))))
        stop(paste("you need to specify argument ",args.names[ii]," in order to use constraint ",clist.names[i],sep="" ))
    }

    cset.i <- do.call(clist.names.i,arg.sum.list[args.names])

	# these three constraints cannot be together
    if (is.turnover.hobbs & !(clist.names.i %in% c("cset.turnover.hobbs","cset.turnover","cset.propcost"))){
     cset[[i]] <- turnover.hobbs.modify (cset.i)
    }
	else if(is.turnover & !(clist.names.i %in% c("cset.turnover.hobbs","cset.turnover","cset.propcost")))
	cset[[i]] <- turnover.modify (cset.i)
	else if(is.propcost & !(clist.names.i %in% c("cset.turnover.hobbs","cset.turnover","cset.propcost")))
    {
     cset[[i]] <- propcost.modify(cset.i)
    } else
    cset[[i]] <- cset.i
  }

  # remove warning case
  index.rem <- which(sapply(cset, length)!=4)
  if(length(index.rem))
  cset[[index.rem]] <- NULL

  #   dimnames(Amat) <- NULL
  A.all <- do.call(cbind,lapply(cset,function(x)x$A))
  colnames(A.all) <- unlist(lapply(cset,function(x)colnames(x$A)))
  b.all <- do.call(c,lapply(cset,function(x)x$b))
  names(b.all) <- colnames(A.all)
  meq.all <- do.call(c,lapply(cset,function(x)x$meq))

  if(sum(meq.all)!=meq.all[1]){
  # shift meq in front
  meq.pos <- sapply(cset,function(x)ncol(x$A))
  a <- NULL
  a[1] <- 1
  for (k in 2:length(meq.pos))
  a[k] <- a[k-1]+meq.pos[k-1]
  sequ <- NULL
  for (kk in 1:length(meq.pos)){
    if(meq.all[kk]!=0)
      sequ <- c(sequ, a[kk]:(a[kk]+meq.all[kk]-1))
  }

  A.temp <- A.all
  b.temp <- b.all
  A.all <- cbind(A.temp[,c(sequ)],A.temp[,-c(sequ)])
  b.all <- c(b.temp[c(sequ)],b.temp[-c(sequ)])

  # delete duplicated constraints not implemented
  INDEX <- NULL
  for (i in 1:ncol(A.all)){
  index <- which(apply(A.all, 2, function(x)all.equal(x,A.all[,i]))=="TRUE")
  if(length(index)>1){
  index <- index[-which(index==i)]
  INDEX <- c(INDEX,index[index>i])
  }
  }
  if(length(INDEX)){
  A.all <- A.all[,-INDEX]
  b.all <- b.all[-INDEX]}
  meq.all <- sum(meq.all)} else{
    meq.all <- sum(meq.all)
  }

  return(list(A=A.all,
              b=b.all,
              meq=meq.all,
              clist.names= clist.names))
}


#  Binary search in R

binarySearch <- function(x, input, start, end){
  if(end < start){
    return(NULL)
  }

  else{
    middle <- start + floor((end - start) / 2)

    if(x[middle] > input) return(binarySearch(x, input, start, middle - 1))
    else if(x[middle] < input) return(binarySearch(x, input, middle + 1, end))
    else return(middle)
  }
}

x <- c(-1, 1, 2, 3, 4, 5, 6)

print(binarySearch(x, -1, 1, length(x)))
print(binarySearch(x, 6, 1, length(x)))
print(binarySearch(x, 7, 1, length(x)))


# Team Rython, Dainius Masiliunas and Tim Weerman
# Date: 11 January, 2016
# Apache License 2.0

# Calculate the Root Mean Squared Error
RMSE = function(truth, prediction)
{
    return(sqrt(mean((truth-prediction)^2, na.rm=TRUE)))
}

# Calculate partial RMSE for different zones by generating squared difference rasters.
GetDifferenceRaster = function(former, latter, filename=paste("data/", names(latter), ".grd", sep=""), force=FALSE)
{
    # Figure out a reasonable output name
    if (filename == "data/layer.grd")
        warning("Please pass filename or assign meaningful names to input rasters! Else the loaded data may not match expectations.")

    # Create one or load one
    if (!file.exists(filename) || force)
    {
        return(overlay(former, latter, fun=function(truth, prediction){(truth-prediction)^2},
            filename=filename))
    }
    else
        return(raster(filename))
}

# Calculate RMSE per zone
StratifiedRMSE = function(truth, prediction, zones, zonenames = "", ...)
{
    # Unfortunately, zonal() just passes a vector of numbers, not a matrix.
    # So we have to calclate RMSE manually from a difference raster.
    differenceRaster = GetDifferenceRaster(truth, prediction, ...)

    # Get a mean from the zones in the difference raster
    zonestats = zonal(differenceRaster, zones, fun="mean")
    zonestats[,2] = sqrt(zonestats[,2])

    # Add nice labels, if we have them
    if (length(zonenames) > 1)
        rownames(zonestats) = zonenames

    return(zonestats)
}


rm(list=ls(all=TRUE)) # removes all previous material from R's memory

df = as.data.frame(read.table("data/Tab3_from_Stolen_and_Barlow_2003_A_MODEL_LIFE_TABLE _FOR_BOTTLENOSE_dolphin3.csv", sep=",", header=T, na.string="-9.99"))
tail(df)

# compute survivorship
df$px <- df$nx/df$nx[1]
age <- 1:nrow(df)

plot(age, df$px, type = 'l', ylim = c(0,1.1))

# mean life expectancy
(e0 <- 1/2 + sum(df$px[-1]))

(e5 <- 1/2 + sum(df$px[-(1:5)]/df$px[5]))

mlex <- function(x)  {

  ex <- 1/2 + sum(df$px[- (1:(x+1))]/df$px[(x+1)])
  return(ex)
}

mlex(2)

# apply the function to each age

mle <- sapply(age, mlex)

plot(age, mle, type = 'l')

# compute the rep[roductive number
#

(Ro <- sum(0.5 * df$px * df$fecx ))

LHS_ELeq <- function(lambda) {sum(0.5 * df$fecx * df$px * lambda^-df$x) }

DTELf <- function(lambda) { LHS_ELeq(lambda)-1 }

# find the root and return it as output of the function
# By default, a function returns the output of its last line.
# Use 'return()' to be more explicit
uniroot(DTELf, c(0.1,2))[1]  # return the root


# Chapter 2 Lab: Introduction to R

# Basic Commands

x <- c(1,3,2,5)
x
x = c(1,6,2)
x
y = c(1,4,3)
length(x)
length(y)
x+y
ls()
rm(x,y)
ls()
rm(list=ls())
?matrix
x=matrix(data=c(1,2,3,4), nrow=2, ncol=2)
x
x=matrix(c(1,2,3,4),2,2)
matrix(c(1,2,3,4),2,2,byrow=TRUE)
sqrt(x)
x^2
x=rnorm(50)
y=x+rnorm(50,mean=50,sd=.1)
cor(x,y)
set.seed(1303)
rnorm(50)
set.seed(3)
y=rnorm(100)
mean(y)
var(y)
sqrt(var(y))
sd(y)

# Graphics

x=rnorm(100)
y=rnorm(100)
plot(x,y)
plot(x,y,xlab="this is the x-axis",ylab="this is the y-axis",main="Plot of X vs Y")
pdf("Figure.pdf")
plot(x,y,col="green")
dev.off()
x=seq(1,10)
x
x=1:10
x
x=seq(-pi,pi,length=50)
y=x
f=outer(x,y,function(x,y)cos(y)/(1+x^2))
contour(x,y,f)
contour(x,y,f,nlevels=45,add=T)
fa=(f-t(f))/2
contour(x,y,fa,nlevels=15)
image(x,y,fa)
persp(x,y,fa)
persp(x,y,fa,theta=30)
persp(x,y,fa,theta=30,phi=20)
persp(x,y,fa,theta=30,phi=70)
persp(x,y,fa,theta=30,phi=40)

# Indexing Data

A=matrix(1:16,4,4)
A
A[2,3]
A[c(1,3),c(2,4)]
A[1:3,2:4]
A[1:2,]
A[,1:2]
A[1,]
A[-c(1,3),]
A[-c(1,3),-c(1,3,4)]
dim(A)

# Loading Data

Auto=read.table("Auto.data")
fix(Auto)
Auto=read.table("Auto.data",header=T,na.strings="?")
fix(Auto)
Auto=read.csv("Auto.csv",header=T,na.strings="?")
fix(Auto)
dim(Auto)
Auto[1:4,]
Auto=na.omit(Auto)
dim(Auto)
names(Auto)

# Additional Graphical and Numerical Summaries

plot(cylinders, mpg)
plot(Auto$cylinders, Auto$mpg)
attach(Auto)
plot(cylinders, mpg)
cylinders=as.factor(cylinders)
plot(cylinders, mpg)
plot(cylinders, mpg, col="red")
plot(cylinders, mpg, col="red", varwidth=T)
plot(cylinders, mpg, col="red", varwidth=T,horizontal=T)
plot(cylinders, mpg, col="red", varwidth=T, xlab="cylinders", ylab="MPG")
hist(mpg)
hist(mpg,col=2)
hist(mpg,col=2,breaks=15)
pairs(Auto)
pairs(~ mpg + displacement + horsepower + weight + acceleration, Auto)
plot(horsepower,mpg)
identify(horsepower,mpg,name)
summary(Auto)
summary(mpg)


prob = c(aleph=1/5, beth=1/6, gimel=1/7, daleth=1/8, he=1/9, waw=1/10, zayin=1/11, heth=1759/27720)
  # Note that R doesn't actually require the weights
  # vector for rmultinom to sum to 1.
hebrew = c(rmultinom(1, 1e6, prob))
d = data.frame(
    Requested = prob,
    Obtained = hebrew/sum(hebrew))
print(d)


randN = function(N) sample.int(N, 1) == 1

unbiased = function(f)
   {while ((x <- f()) == f()) {}
    x}

samples = 10000
print(t(round(d = 2, sapply(3:6, function(N) c(
    N = N,
    biased = mean(replicate(samples, randN(N))),
    unbiased = mean(replicate(samples, unbiased(function() randN(N)))))))))


# Read datasets Cleveland_hd.csv into hd_data
hd_data <- read.csv("datasets/Cleveland_hd.csv")

# take a look at the first 5 rows of hd_data
head(hd_data,5)

# load the tidyverse package
library(tidyverse)

# Use the 'mutate' function from dplyr to recode our data
hd_data %>% mutate(hd = ifelse(class > 0, 1, 0))-> hd_data

# recode sex using mutate function and save as hd_data
hd_data %>% mutate(sex = factor(sex, levels = c("0","1"), labels = c("Female", "Male")))-> hd_data

# Does sex have an effect? Sex is a binary variable in this dataset,
# so the appropriate test is chi-squared test
hd_sex <- chisq.test(hd_data$sex, hd_data$hd)

# Does age have an effect? Age is continuous, so we use a t-test
hd_age <- t.test(hd_data$age ~ hd_data$hd)

# What about thalach? Thalach is continuous, so we use a t-test
hd_heartrate <- t.test(hd_data$thalach ~ hd_data$hd)

# Print the results to see if p<0.05.
print(hd_sex)
print(hd_age)
print(hd_heartrate)

# Recode hd to be labelled
hd_data%>%mutate(hd_labelled = ifelse(hd == 0, "No Disease", "Disease")) -> hd_data

# age vs hd
ggplot(data = hd_data, aes(x = hd_labelled,y = age)) + geom_boxplot()

p <- last_plot()
hd_data_correct <- mutate(hd_data, hd_labelled = ifelse(hd==0, "No disease", "Disease"))

# sex vs hd
ggplot(data = hd_data, aes(hd_labelled, fill = sex)) + geom_bar(position = "fill") + ylab("Sex %")

p <- last_plot()

# max heart rate vs hd
ggplot(data = hd_data,aes(x = hd_labelled, y = thalach)) + geom_boxplot()

p <- last_plot()

# use glm function from base R and specify the family argument as binomial
model <- glm(data = hd_data, hd ~ age + sex + thalach, family = "binomial")

# extract the model summary
summary(model)

# load the broom package
library(broom)

# tidy up the coefficient table
tidy_m <- tidy(model)
tidy_m

# calculate OR
tidy_m$OR <- exp(tidy_m$estimate)

# calculate 95% CI and save as lower CI and upper CI
tidy_m$lower_CI <- exp(tidy_m$estimate - 1.96 * tidy_m$std.error)
tidy_m$upper_CI <- exp(tidy_m$estimate + 1.96 * tidy_m$std.error)

# display the updated coefficient table
tidy_m

# get the predicted probability in our dataset using the predict() function
pred_prob <- predict(model,hd_data, type = "response")

# create a decision rule using probability 0.5 as cutoff and save the predicted decision into the main data frame
hd_data$pred_hd <- ifelse(pred_prob >= 0.5, 1, 0)

# create a newdata data frame to save a new case information
newdata <- data.frame(age = 45, sex = "Female", thalach = 150)

# predict probability for this new case and print out the predicted value
p_new <- predict(model,newdata, type = "response")
p_new

pred_prob_correct <- predict(model, hd_data, type="response")
hd_data$pred_hd_correct <- ifelse(pred_prob_correct >= 0.5, 1, 0)
p_new_correct <- predict(model, newdata, type="response")

# load Metrics package
library(Metrics)

head(hd_data)

# calculate auc, accuracy, clasification error
auc <- auc(hd_data$hd, hd_data$pred_hd)
accuracy <- accuracy(hd_data$hd, hd_data$pred_hd)
classification_error <- ce(hd_data$hd, hd_data$pred_hd)

# print out the metrics on to screen
print(paste("AUC=", auc))
print(paste("Accuracy=", accuracy))
print(paste("Classification Error=", classification_error))

# confusion matrix
table(hd_data$hd,hd_data$pred_hd, dnn=c("True Status","Predicted Status")) # confusion matrix

08. What Your Heart Rate Is Telling You.r


pcaCharts <- function(x,y,z,t) {
  x.var <- x$sdev ^ 2
  x.pvar <- x.var/sum(x.var)

  y.var <- y$sdev ^ 2
  y.pvar <- y.var/sum(y.var)

  z.var <- z$sdev ^ 2
  z.pvar <- z.var/sum(z.var)

  t.var <- t$sdev ^ 2
  t.pvar <- t.var/sum(t.var)

  #print("proportions of variance:")
  #print(x.pvar)

  par(mfrow=c(1,1))
  plot(cumsum(x.pvar),xlab="Principal Component", ylab="Accumulative Variance", ylim=c(0,1), type='l', col="blue")
  #plot(cumsum(y.pvar),xlab="Principal Component", ylab="Accumulative Variance", ylim=c(0,1), type='l', col="red")
  #plot(cumsum(z.pvar),xlab="Principal Component", ylab="Accumulative Variance", ylim=c(0,1), type='l', col="green")
  #plot(cumsum(t.pvar),xlab="Principal Component", ylab="Accumulative Variance", ylim=c(0,1), type='l', col="black")
}

data1<-read.csv("E:/New Conference Paper/New/Data/GSE6919_GPL8300/GSE6919_GPL8300_SelectedFeatures.csv",row.names = 1)
data1<-t(data1)
data2<-read.csv("E:/New Conference Paper/New/Data/GSE6919_GPL92/GSE6919_GPL92_SelectedFeatures.csv",row.names = 1)
data2<-t(data2)
data3<-read.csv("E:/New Conference Paper/New/Data/GSE6919_GPL93/GSE6919_GPL93_SelectedFeatures.csv",row.names = 1)
data3<-t(data3)
data4<-read.csv("E:/New Conference Paper/New/Data/GSE5325/GSE5325_SelectedFeatures.csv",row.names = 1)
data4<-t(data4)

pca1 <- prcomp(scale(data1),center = TRUE)
pca2 <- prcomp(scale(data2),center = TRUE)
pca3 <- prcomp(scale(data3),center = TRUE)
pca4 <- prcomp(scale(data4),center = TRUE)

pcaCharts(pca1, pca2, pca3, pca4)


####### SECTION 2 ####
####################
CD4.data <- read.table("Data/cd4.data",
                       col.names=c("Time","CD4","Age","Packs",
                         "Drugs","Sex","Cesd","ID")) #READ IN DATA
attach(CD4.data) ##attach data frame, now you can use just the names

###Figure 1
postscript("Plots/plot-02-01.ps")
par(mfrow=c(1,1)) ##makes a 1,1 grid for the figure
plot(Time,CD4,pch=".",main="CD4 counts vs Time",xlab="Time since zeroconversion",ylab="CD4")##plots CD4 vs. Time
dev.off()

###Figures 2
postscript("Plots/plot-02-02.ps",horizontal=T)
plot(Time,CD4,main="Regression Lines",pch=".")
abline(lm(CD4~Time))
o <- order(Time)
lines(Time[o],lm(CD4~poly(Time,2))$fitted[o],lty=2)
lines(Time[o],lm(CD4~poly(Time,3))$fitted[o],lty=4)
legend(3.75,3000,legend=c("line","parabola","cubic poly"),lty=c(1,2,4))
dev.off()

###Figure 3
###BIN SMOOTHER
postscript("Plots/plot-02-03.ps",horizontal=T)
cs <- c(-Inf,quantile(Time,probs=c(1/5,2/5,3/5,4/5)),Inf)
R <- cut(Time,cs)
plot(Time,CD4,main="Bin Smoother",pch=".")
lines(Time[o],lm(CD4~R)$fitted[o])
dev.off()
###Figure 4
###Running-mean and running-line
library("modreg") ##this library contains the function ksmooth
postscript("Plots/plot-02-04.ps",horizontal=T)
o <- sample(1:length(Time),400) ##to make it fast for example look at only 400
 plot(Time[o],CD4[o],pch=".",main="Running Mean")
b <- c(-2,1,3) - 0.5
e <- b + 1
for(i in 1:length(b)){
  abline(v=c(b[i],e[i]),pch=2)
  oo <- o[Time[o]>=b[i] & Time[o]<=e[i]]
sapply(oo,function(i) points(Time[oo],CD4[oo],pch=1))
lines(range(Time[oo]),rep(mean(CD4[oo]),2))
}
aux <- ksmooth(Time[o],CD4[o],kernel="box",bandwidth=1,x.points=unique(Time[o])) ##box is default!
lines(aux$x,aux$y)
dev.off()
###Figures 5
##kernel smoother
postscript("Plots/plot-02-05.ps",horizontal=T)
plot(Time[o],CD4[o],main="Kernel Smoother",pch=".")
aux <- ksmooth(Time[o],CD4[o],kernel="normal",bandwidth=1,x.points=unique(Time[o]))
lines(aux$x,aux$y)
dev.off()

###Figure 6
postscript("Plots/plot-02-06.ps",horizontal=T)
o <- sample(1:length(Time),400) ##to make it fast for example look at only 400
xx <- sort(Time[o])
aux11 <- ksmooth(xx,c(1,rep(0,length(o)-1)),kernel="normal",bandwidth=1,x.points=unique(xx))
plot(aux11$x,aux11$y,type="l",xlab="Time",ylab="Weights",main="Kernels",col=2)
rug(xx)
oo<- aux11$y>6.030458e-06
points(aux11$x[oo],aux11$y[oo],lty=2,pch="x",cex=0.5)
aux12 <- ksmooth(xx,c(1,rep(0,length(o)-1)),kernel="box",bandwidth=1,x.points=unique(xx))
lines(aux12$x,aux12$y,lty=2,col=2)
oo <- aux12$y>6.030458e-06
points(aux12$x[oo],aux12$y[oo],lty=2,pch="x",cex=0.5)
##
aux21 <- ksmooth(xx,c(rep(0,round(length(o)/2)),1,rep(0,length(o)-round(length(o)/2)-1)),kernel="normal",bandwidth=1,x.points=unique(xx))
lines(aux21$x,aux21$y,type="l",col=3)
oo<- aux21$y>6.030458e-06
points(aux21$x[oo],aux21$y[oo],lty=2,pch="x",cex=0.5)
aux22 <- ksmooth(xx,c(rep(0,round(length(o)/2)),1,rep(0,length(o)-round(length(o)/2)-1)),kernel="box",bandwidth=1,x.points=unique(xx))
lines(aux22$x,aux22$y,lty=2,col=3)
oo<- aux22$y>6.030458e-06
points(aux22$x[oo],aux22$y[oo],lty=2,pch="x",cex=0.5)
##
aux31 <- ksmooth(xx,c(rep(0,round(length(o)*.9)),1,rep(0,length(o)-round(length(o)*.9)-1)),kernel="normal",bandwidth=1,x.points=unique(xx))
lines(aux31$x,aux31$y,type="l",col=4)
oo<- aux31$y>6.030458e-06
points(aux31$x[oo],aux31$y[oo],lty=2,pch="x",cex=0.5)
aux32 <- ksmooth(xx,c(rep(0,round(length(o)*.9)),1,rep(0,length(o)-round(length(o)*.9)-1)),kernel="box",bandwidth=1,x.points=unique(xx))
lines(aux32$x,aux32$y,lty=2,col=4)
oo<- aux32$y>6.030458e-06
points(aux32$x[oo],aux32$y[oo],lty=2,pch="x",cex=0.5)
dev.off()

detach("CD4.data")


library(Sleuth3)
library(ggplot2)

head(case0701)
qplot(Velocity,Distance,data=case0701)
is.numeric(case0701$Velocity)

case0701.lm<-lm(Distance~Velocity,data=case0701)

summary(case0701.lm)

case0701.lm$coefficients
qplot(Velocity,Distance,data=case0701) + geom_abline(slope=.00137,intercept=.4)

ggplot(case0701, aes(x=Velocity, y=Distance)) +
  geom_point() +
  geom_smooth(method=lm,se=FALSE)

ggplot(case0701, aes(x=Velocity, y=Distance)) +
  geom_point() +
  geom_smooth(method=lm)

pred.intervals<-data.frame(predict(case0701.lm,interval="prediction"))
head(pred.intervals)
case0701.df2 <- cbind(case0701, pred.intervals)
head(case0701.df2)

ggplot(case0701.df2, aes(x=Velocity, y=Distance)) +
  geom_point() +
  geom_line(aes(y=lwr), color = "blue", linetype = "dashed") +
  geom_line(aes(y=upr), color = "blue", linetype = "dashed") +
  geom_smooth(method=lm)

head(case0701.lm$residuals)

plot(case0701.lm,which=1)


## Default libs
library(tidyverse)
library(stringr)
## Extra Themes
library(ggthemes)
library(ggsci)
## A dataset
library(nycflights13)

ggplot(data = mpg) +
    geom_jitter(mapping = aes(x = displ, y = hwy, color = class)) +
    theme_fivethirtyeight() + scale_color_jama()

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")

ggplot(data = delays, mapping = aes(x = dist, y = delay)) +
    geom_point(aes(size = count), alpha = 1/3) +
    geom_smooth(se = FALSE) +
    theme_tufte() + scale_color_jama()

stocks <- tibble(
    year   = c(2015, 2015, 2015, 2015, 2016, 2016, 2016),
    qtr    = c(   1,    2,    3,    4,    2,    3,    4),
    return = c(1.88, 0.59, 0.35,   NA, 0.92, 0.17, 2.66)
)

stocks %>%
    complete(year, qtr)

who %>% gather(code, value, new_sp_m014:newrel_f65, na.rm = TRUE) %>%
    mutate(code = stringr::str_replace(code, "newrel", "new_rel")) %>%
    separate(code, c("new", "var", "sexage")) %>%
    select(-new, -iso2, -iso3) %>%
    separate(sexage, c("sex", "age"), sep = 1)


# Reference: "Robust Principal Component Analysis?" https://arxiv.org/pdf/0912.3599.pdf

# sum(abs(X))
one_norm = function(X)
{
  if (is.ddmatrix(X))
  {
    ret = .Call(R_one_norm, X@Data)
    allreduce(ret)
  }
  else
    .Call(R_one_norm, X)
}

## \mathcal{S} from the paper - sign(X) * pmax(abs(X) - tau, 0)
shrink_op = function(X, tau)
{
  # NOTE: this modifies the memory in place, which is potentially very dangerous
  if (is.ddmatrix(X))
    .Call(R_shrink_op, X@Data, tau)
  else
    .Call(R_shrink_op, X, tau)
}

## \mathcal{D} from the paper
sv_thresh = function(X, tau)
{
  decomp = La.svd(X)

  sigma = decomp$d
  shrink_op(sigma, tau)
  U = decomp$u
  Vt = decomp$vt

  U %*% (sigma * Vt)
}

#' robpca
#'
#' Implementation of the robust pca algorithm.
#'
#' @description
#' The optimization problem is solved by an alternating directions technique.
#'
#' @param M
#' The input data, stored as a numeric matrix or ddmatrix.
#' @param delta
#' Numeric termination criteria. A smaller (closer to 0) value will require more
#' iterations. See the summary following the Algorithm 1 listing in the
#' referenced paper for details.
#' @param maxiter
#' Maximum number of iterations. Should at least be a few hundred.
#'
#' @references
#' Candes, E.J., Li, X., Ma, Y. and Wright, J., 2011. Robust principal component
#' analysis?. Journal of the ACM (JACM), 58(3), p.11.
#'
#' @examples
#' \dontrun{
#' m = 10
#' n = 3
#' M = matrix(rnorm(m*n), m)
#' robsvd(M)
#' }
#'
#' @author
#' Drew Schmidt
#'
#' @export
robpca = function(M, delta=1e-7, maxiter=1000)
{
  ### I love dynamic typing
  assert.type(delta, "numeric")
  assert.posint(maxiter)

  if (class(M) != "ddmatrix")
  {
    M <- as.matrix(M)

    if (!is.double(M))
      storage.mode(M) <- "double"
  }

  ### the actual work
  n1 = nrow(M)
  n2 = ncol(M)

  lambda = 1/sqrt(max(n1, n2))

  mu = 0.25 * n1*n2 / one_norm(M)

  if (is.ddmatrix(M))
  {
    ictxt = ICTXT(M)
    S = pbdDMAT::ddmatrix(0, n1, n2, ICTXT=ictxt)
    Y = pbdDMAT::ddmatrix(0, n1, n2, ICTXT=ictxt)
  }
  else
  {
    S = matrix(0, n1, n2)
    Y = matrix(0, n1, n2)
  }

  conv = FALSE
  iter = 0L

  ub = delta * norm(M, "F")

  while (!conv && iter < maxiter)
  {
    if (iter == 0)
      L = sv_thresh(M, 1/mu)
    else
      L = sv_thresh(M - S + Y, 1/mu)

    tmp = M - L
    S = tmp + Y
    shrink_op(S, lambda/mu)

    tmp = tmp - S
    Y = Y + tmp

    term = norm(tmp, "F")
    conv = (term <= ub)
    iter = iter + 1L
  }

  info = list(iterations=iter, converged=iter<maxiter, term=term)
  list(L=L, S=S, info=info)
}


library(ggplot2)

# change these parameters if you want
alpha <- 5
beta <- 15
nSamples <- 1000

# generate samples for U and V according to gamma distributions with shape alpha and beta
u <- rgamma(1000, shape = alpha)
v <- rgamma(1000, shape = beta)

# transform the variables to x and y
x <- u / (u + v)
y <- u + v

# data for pdf of the beta function with shapes alpha and beta
xBeta <- seq(min(x), max(x), length = 100)
yBeta <- dbeta(xBeta, shape1 = alpha, shape2 = beta)

# plot the density of x versus the pdf of the beta distribution
myPlot <- ggplot() +
    geom_histogram(aes(x, y = ..density..),
                   binwidth = 0.05,
                   color = "white",
                   fill = "#E69F00") +
    geom_line(aes(x = xBeta, y = yBeta), color = "#56B4E9") +
    theme(axis.title.x = element_blank()) +
    theme(axis.title.y = element_blank())

# ...profit!
plot(myPlot)


library(daewr)
data(COdata)
COdata
help(COdata)

model1 = aov(CO ~ Eth * Ratio, data = COdata)
summary(model1)

model2 = aov(CO ~ Eth + Ratio + Eth:Ratio, data = COdata)
summary(model2)

model3 = aov(CO ~ Eth + Ratio, data = COdata)
summary(model3)

# can be used to compute means for each factor level for each factor
model.tables(model1, type = 'means', se = T)

# we can also take the effects
model.tables(model1, type = 'effects', se = T)

library(gmodels)

interaction.plot(COdata$Eth, COdata$Ratio, COdata$CO, type = 'b')
plot.design(COdata)

tukey = TukeyHSD(model1, "Eth")
tukey

plot(tukey)

# provides estimates of the contrasts of the model
coef(model1)

fullnormal(coef(model1)[-1], alpha = 0.025)


digits <- read.csv("optdigits.csv", header = F)
colnames(digits)[ncol(digits)] <- "number"
digits$number <- as.factor(digits$number)
n <- dim(digits)[1]
set.seed(12345)
id <- sample(1:n, floor(n*0.5))
train <- digits[id,]
id1 <- setdiff(1:n, id)
set.seed(12345)
id2 <- sample(id1, floor(n*0.25))
validation <- digits[id2,]
id3 <- setdiff(id1,id2)
test <- digits[id3,]

head(digits)

#install.packages('kknn')
library(kknn)

knn_train <- kknn(number ~., train, train, k = 30, kernel = "rectangular")
knn_test <- kknn(number ~., train, test, k = 30, kernel = "rectangular")
pred_train<- fitted(knn_train)
confusion_train <- table(train$number, pred_train)
pred_test <- fitted(knn_test)
confusion_test <- table(test$number, pred_test)

print(confusion_train)

print(confusion_test)

print(diag(confusion_train)/rowSums(confusion_train))
print(diag(confusion_test)/rowSums(confusion_test))

missclass <- function(X,X1) {
  n = length(X)
  return(1-sum(diag(table(X,X1)))/n)
}
mismatch_rate_train <- missclass(train$number, pred_train)
mismatch_rate_test <- missclass(test$number, pred_test)
cat("The mismatch rate for train data is:", mismatch_rate_train,
    "\nThe mismatch rate for test data is:", mismatch_rate_test)

train_eight <- train[which(train$number==8),]
train_eight$prob <- knn_train$prob[which(train$number==8), "8"]
sortedResult <- sort(train_eight[, "prob"], index.return = T)
#sortedResult$x[1:3] #0.1000000 0.1333333 0.1666667
hard_ids <- sortedResult$ix[1:3] #50  43 136
#tail(sortedResult$x, n=c(2)) #1 1
easy_ids <- tail(sortedResult$ix, n=c(2)) #179 183
plotHeatmap <- function(index){
  heatmap(matrix(as.numeric(train_eight[index, 1:64]), 8, 8, byrow = T), Colv = NA, Rowv = NA)
}

 for (i in c(hard_ids)) {
   plotHeatmap(i)
 }

for (i in c( easy_ids)) {
  plotHeatmap(i)
}

e_t <- 0
e_v <- 0
for (k in 1:30) {
  kt <- kknn(number ~., train, train, k = k, kernel = "rectangular")
  e_t[k] <- missclass(train$number, kt$fitted.values)
  kv <- kknn(number ~., train, validation, k = k, kernel = "rectangular")
  e_v[k] <- missclass(validation$number, kv$fitted.values)
}
plot(1:30, e_v, type = "l", col = "red", xlab = "K", ylab = "miss-classification error rate")
lines(1:30, e_t, col = "blue")
#legend(2, 0.06, legend=c("validation", "train"),
      # col=c("red", "blue"), lty=1:1, cex=0.8)

k_test_optik <- kknn(number ~., train, test, k = 3, kernel = "rectangular")
cat("Test mis-classification rate when k=3 is:", missclass(test$number, fitted(k_test_optik)))
cat("Train mis-classification rate when k=3 is:", e_t[3])
cat("Validation mis-classification rate when k=3 is:", e_v[3])

max(e_v)

#install.packages("reshape")
#install.packages("data.table", type="source", dependencies=TRUE)
library(data.table)
library(reshape)
cross_entropy_train <- c()
cross_entropy_val <- c()
num_classes <- length(unique(train$number))
num_train_examples <- nrow(train)
num_val_examples <- nrow(validation)
one_hot_y_train <- t(sapply(as.numeric(train$number),
                            function(x) {c(rep(0, x - 1), 1, rep(0, num_classes - x))}))
one_hot_y_val <- t(sapply(as.numeric(validation$number),
                          function(x) {c(rep(0, x - 1), 1, rep(0, num_classes - x))}))

for (k_choice in 1:30) {

  # fit model
  train_model <- kknn(formula = number ~., kernel = "rectangular", train = train, test = train, k = k_choice)
  val_model <- kknn(formula = number ~., kernel = "rectangular", train = train, test = validation, k = k_choice)

  # cross-entropy
  cross_entropy_train <- c(cross_entropy_train, sum(one_hot_y_train * -log(train_model$prob + 10^-15))/num_train_examples)
  cross_entropy_val <- c(cross_entropy_val, sum(one_hot_y_val * -log(val_model$prob + 10^-15))/num_val_examples)

}

cross_entropy <- melt(data.table(k = 1:30, Training = cross_entropy_train, Validation = cross_entropy_val),
                      "k", variable.name = "Legend")

plot(1:30, cross_entropy_val, type = "l", xlab = "K", ylab = "cross entropy",col='blue',lty=1)
lines(1:30, cross_entropy_train, type = "l", xlab = "K", ylab = "cross entropy",col='red',lty=2)
legend(x='topright', legend=c("valid" , 'train'), col=c('blue','red'),lty=1:2)

k-nearest neighbors algorithm/Assignment 1. Handwritten digit recognition with K-means.r


# http://elevanth.org/blog/2017/11/28/build-a-better-markov-chain/
y = sum(rpois(20, 2))
n = 1e4
p = rep(1, n)
for (i in 2:n) {
    r = p[i-1]
    q = exp(log(r) + rnorm(1)/9)
    p[i] = ifelse(runif(1) < q^y * r^(-y) * exp(-20*(q-r)), q, r)
}

# These algorithms take samples from a target distribution by first (1) making a random proposal for
# new parameter values and then (2) accepting or rejecting the proposal. If both steps are done right,
# then the accepted parameter values will comprise samples from the target distribution.


next.perm <- function(a) {
  n <- length(a)
  i <- n
  while (i > 1 && a[i - 1] >= a[i]) i <- i - 1
  if (i == 1) {
    NULL
  } else {
    j <- i
    k <- n
    while (j < k) {
      s <- a[j]
      a[j] <- a[k]
      a[k] <- s
      j <- j + 1
      k <- k - 1
    }
    s <- a[i - 1]
    j <- i
    while (a[j] <= s) j <- j + 1
    a[i - 1] <- a[j]
    a[j] <- s
    a
  }
}

perm <- function(n) {
  e <- NULL
  a <- 1:n
  repeat {
    e <- cbind(e, a)
    a <- next.perm(a)
    if (is.null(a)) break
  }
  unname(e)
}


#' Calculation of theortical quantile (Quantile-Quantile Plot)
#'
#' @param y data sample
#' @export
#' @return Part of the qqnorm generic function
#' @examples
#' set.seed(123)
#' test=lm(rnorm(100)~rnorm(100)+100)
#' qq.function(test$residuals)

qq.function=function(y){
  n=length(y)
  r=order(order(y))
  if(n>10){p=(r-1/2)/n}else{p=(r-3/8)/(n+1/4)}
  qqnorm.val=qnorm(p)
  return(qqnorm.val)
}


curve(expr = dnorm(x, mean= 0,sd = 1), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')
curve(expr = dt(x, df = 1), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')

#a mixture
myvar = 1
curve(expr = 0.25*dnorm(x, mean= 0,sd = sqrt(0.01*myvar)), ylim=c(0,1.8),from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')
curve(expr = 0.25*dnorm(x, mean= 0,sd = sqrt(0.1*myvar)), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n',add=TRUE)
curve(expr = 0.25*dnorm(x, mean= 0,sd = myvar), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n',add=TRUE)
curve(1+x*4000, from = 0.0, to = 0.01, xname = "x", col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n',add=TRUE)

library(nimble)
curve(expr = ddexp(x), from = -4, to = 4, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')

library(EnvStats)
curve(expr =   dnormMix(x, mean1 = 0, sd1 = 10, mean2 = 0, sd2 = 1, p.mix = 0.5), from = -4, to = 20, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')

curve(expr =   dnormMix(x, mean1 = 0, sd1 = 10, mean2 = 0, sd2 = 1, mean3 = 0, sd3 = 1, p.mix = 0.5), from = -4, to = 20, col = "red", lwd = 3.5,ylab="",xlab="",xaxt='n',yaxt='n')


################################################################################
#
#'
#' Function to calculate the design effect of a stepped wedge cluster randomised
#' study.
#'
#' @param k Number of steps in the stepped wedge study
#' @param b Number of baseline measurements
#' @param t Number of measurements after each step
#' @param icc Intracluster correlation coefficient (\code{ICC})
#' @param size cluster size
#'
#' @return A numeric value of the design effect of a stepped wedge cluster
#'     ranomised study
#'
#' @examples
#'
#'   get_deff_swedge(k = 2, b = 1, t = 1, icc = 0.034, size = 192)
#'
#' @export
#'
#
################################################################################

get_deff_swedge <- function(k, b, t, icc, size) {

  deff <- ((1 + icc * (k * t * size + b * size - 1)) / (1 + icc * (0.5 * (k * t * size) + b * size - 1))) * ((3 * (1 - icc)) / ((2 * t) * (k - 1 / k)))

  return(deff)
}

################################################################################
#
#'
#' Function to calculate sample size requirements for a stepped wedge cluster
#' randomised study.
#'
#' @param z1 The z-score indicating level of significance (confidence interval).
#'     Default at 1.96 for 95\% confidence interval.
#' @param z2 desired power. Default at 0.84 for 80\% power.
#' @param p1 Expected proportion for control group.
#' @param p2 Expected proportion for intervention group
#' @param deff Design effect of a stepped wedge cluster randomised study
#'
#' @return A numeric value of sample size needed for a stepped wedge cluster
#'     ranomised study
#'
#' @examples
#'
#'  get_ss_swedge(z1 = 1.96, z2 = 0.84,
#'                p1 = 0.2, p2 = 0.15,
#'                deff = get_deff_swedge(k = 2, b = 1, t = 1,
#'                                       icc = 0.034, size = 192))
#'
#' @export
#'
#
################################################################################

get_ss_swedge <- function(z1 = 1.96, z2 = 0.84, p1, p2, deff) {

  n1 <- ((z1 + z2) ^ 2) * ((p1 * (1 - p1)) + (p2 * (1 - p2))) / (p1 - p2) ^ 2

  n <- n1 * 2 * deff

  return(n)
}


R version 3.0.0 (2013-04-03) -- "Masked Marvel"
Copyright (C) 2013 The R Foundation for Statistical Computing
Platform: i386-w64-mingw32/i386 (32-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.

#formulas, equations and notation from http://homeweb2.unifr.ch/hungerbu/pub/sonnenuhr/sundial.ps
# and by the paper of C. Blatter (http://dz-srv1.sub.uni-goettingen.de/sub/digbib/loader?did=D241775)

epsilon=23.45*2*pi/360
alpha  =78.5 *2*pi/360
kappa  =0.016722

mu<-function(t,epsilon,alpha,kappa) {
zaehl= -sin(delta(t,kappa))+tan(epsilon/2)^2*sin(2*(t-alpha)+delta(t,kappa))
nenn =  cos(delta(t,kappa))+tan(epsilon/2)^2*cos(2*(t-alpha)+delta(t,kappa))
return( atan(zaehl/nenn) )
}

# approximation by Blatter
psi<-function(t) {
   return(t+delta(t))
 }

 delta<-function(t,kappa) {
   return( 2*sin(t)*kappa+5/4*sin(2*t)*kappa^2 )
 }

 png(filename="Equation of time.jpg", width=1024, height=768, pointsize=12)
 par(bg="whitesmoke")
 time=seq(-0.6,2*pi+0.4,length=365+(0.6+0.4)/(2*pi)*365)
 da<-paste("1.",as.character(seq(1,12,by=2)),".07",sep="")
 da<-as.Date(c(da,"1.1.08"),"%d.%m.%y")
 #umrechungsfaktor: 24h=2*pi
 plot(time,mu(time,epsilon,alpha,kappa)*24*60/(2*pi),type="l",col="red",xlab="Tag",ylab="Time in Minutes",main="Equation of time: true solar time  -  mean solar time",cex.main=1.5,lwd=3,xaxt="n",xaxs="i",xlim=range(time))
 lines(time,mu(time,epsilon=0,alpha,kappa)*24*60/(2*pi),lwd=2,col="navy",lty="dotdash")
 lines(time,mu(time,epsilon,alpha,kappa=0)*24*60/(2*pi),lwd=2,col="purple",lty="dashed")
 #grid
 abline(h=c(-15,-10,-5,5,10,15),lty="dotted",col="grey")
 abline(h=0,lty="solid",col="grey33")
 tage=cumsum(c(0,31,28,31,30,31,30,31,31,30,31,30,31))/365-3/365
 abline(v=tage*2*pi,lty="dotted",col="grey")
 axis(1,at=seq(0,2*pi,length=7)-3*2*pi/365,labels=as.character(da,"1. %b"))
 legend(x=5.5,y=-10.9,legend=c("Equation of time","Ecliptic","Earth Orbit"),col=c("red","navy","purple"),lwd=c(3,2,2),lty=c("solid","dotdash","dashed"))
 dev.off()


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

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

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

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

  return (answer)
}

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

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

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

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

  }
  cat("\n")
  # for (i in 1:length(ans)) {
  #
  #   ans[i] = ans[i] / length(iris[,1] - 1)
  # }

  return (ans)
}

fast_cvloo_kwnn <- function() {
  maxK <- 149
  classes = unique(iris$Species)
  qs <- seq(from = 0.0, to = 1.0, by = 0.05)

  ans <- array(0L, dim = c(maxK, length(qs)))
  for (i in 1:length(iris[,1])) { # samples
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 1:4], iris[i, 1:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    classesCount <- array(0L, dim = c(length(classes), length(qs)))
    dimnames(classesCount) = list(classes)
    for (j in 1:maxK) { # k's
      index <- 1
      for (q in qs) {
        classesCount[sortedDataset$Species[j],index] <- classesCount[sortedDataset$Species[j],index] + (q ^ j)
        classForCurrentK = names(which.max(classesCount[,index]))[1]

        if (classForCurrentK == paste(iris$Species[i])) {
          ans[j,index] = ans[j,index] + 1
        }
        index <- index + 1
      }
    }
    index <- index + 1
  }
  cat("\n")

  # for (i in 1:length(ans)) {
  #
  #   ans[i] = ans[i] / (length(iris[,1]) - 1)
  # }

  return (ans)
}

knn_accuracy = fast_cvloo_knn()
kwnn_accuracy = fast_cvloo_kwnn()

cat("Best accuracy for knn: ", max(knn_accuracy) / length(iris[,1]), ";\nBest accuracy for weighted knn:", max(kwnn_accuracy) / length(iris[,1]))

1 - Nearest neighbors algorithm/knn-vs-kwnn.r


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.
library(MASS)
library(xts)
library(quantmod)
library(Quandl)
library(PortfolioAnalytics)
library(ROI)
library(ROI.plugin.glpk)
library(ROI.plugin.quadprog)

## risk-free rate (for example purposes)
rf <- 0.01

etf.symbols <- c("SPY", "IWM", "AGG", "FEZ", "ACWI", "IYR")
adj.close <- 6  # 6th field is adjusted close
etf.prices <- getSymbols(etf.symbols[1], source="yahoo",
                         auto.assign=FALSE, return.class="xts")[,adj.close]
for (i in 2:length(etf.symbols)) {
    etf.tmp <- getSymbols(etf.symbols[i], source="yahoo",
                          auto.assign=FALSE, return.class="xts")[,adj.close]
    etf.prices <- cbind(etf.prices, etf.tmp)
}
colnames(etf.prices) <- etf.symbols
etf.rets <- diff(log(etf.prices))["2012/"]

commodity.symbols <- c("WTI", "Natgas", "AU", "CU", "Corn")
settle <- "Settle"  # settle field is labeled
commodity.tickers <- c("CHRIS/CME_CL1", "CHRIS/CME_NG1", "CHRIS/CME_GC1",
                       "CHRIS/CME_HG1", "CHRIS/CME_C1")
commodity.prices <- Quandl(commodity.tickers[1], type="xts")[,settle]
for (i in 2:length(commodity.symbols)) {
    commodity.tmp <- Quandl(commodity.tickers[i], type="xts")[,settle]
    commodity.prices <- cbind(commodity.prices, commodity.tmp)
}
colnames(commodity.prices) <- commodity.symbols

all.returns.tmp <- diff(log(cbind(etf.prices,commodity.prices)))["2012/"]
all.returns <- na.omit(all.returns.tmp)

## set up portfolio with objective and constraints
n.assets <- length(colnames(all.returns))
port.spec <- portfolio.spec(assets = colnames(all.returns))
port.spec <- add.objective(portfolio=port.spec, type="risk", name="StdDev")
port.spec <- add.objective(portfolio=port.spec, type="return", name="mean")
port.spec <- add.constraint(portfolio=port.spec, type="full_investment")
port.spec <- add.constraint(portfolio=port.spec, type="box", min=-1, max=1)

## map out the efficient frontier (for variance risk)
eff.frontier <- create.EfficientFrontier(R=all.returns, portfolio=port.spec,
                                         n.portfolios=100, type="mean-StdDev")

## daily Sharpe ratio
sharpe.ratios <- (eff.frontier$frontier[,"mean"]-rf/250)/eff.frontier$frontier[,"StdDev"]
max.sharpe.ratio <- sharpe.ratios[sharpe.ratios == max(sharpe.ratios)]
optimal.port.name <- names(max.sharpe.ratio)
optimal.mean <- eff.frontier$frontier[optimal.port.name,"mean"]
optimal.sd <- eff.frontier$frontier[optimal.port.name,"StdDev"]

n.trading.days.per.year <- 252
print(sprintf("Optimal Sharpe Ratio: %f", max.sharpe.ratio*sqrt(n.trading.days.per.year)))
print(sprintf("Optimal E(port return): %f", optimal.mean*n.trading.days.per.year))
print(sprintf("Optimal sd(port return): %f", optimal.sd*sqrt(n.trading.days.per.year)))
print("Optimal weights")
print(eff.frontier$frontier[optimal.port.name,(1:n.assets)+3])


library(quantmod)

rm(list=ls())

par(mfrow=c(1,3))

BB_PERIOD <- 20 # [B]ollinger [B]and [PERIOD]
M_START <- BB_PERIOD + 1

# Transaction commission fee is 0.1425%.
# Seller must also pay 0.3% government tax.
long <- function(price) {
    return(price * (1 + 0.001425))
}

short <- function(price) {
    return(price * (1 - 0.001425 - 0.003))
}

# Prepare data.
stock <- na.omit(get(getSymbols('2395.TW')))
opp <- Op(stock) # [op]en [p]rices
clp <- Cl(stock) # [cl]ose [p]rices
cl_bb <- BBands(clp, n=BB_PERIOD) # [cl]ose price [b]ollinger [b]and
yesterday <- nrow(stock) - 1

# Execute the strategy. buy first.
pl <- setNames( rep( 0, length(clp) ), time(stock) )
is_bought <- FALSE
for (m in M_START:yesterday) {
    if (!is_bought && clp[m] <= cl_bb[m, 1]) { # touch bollinger band down
        bought <- long( as.numeric( opp[m+1] ) )
        is_bought <- TRUE
    }
    else if (is_bought && clp[m] >= cl_bb[m, 3]) { # touch bollinger band up
        pl[m] <- short( as.numeric( opp[m+1] ) ) - bought
        is_bought <- FALSE
    }
}

# Assess the strategy.
win_rate <- length( pl[pl > 0] ) / length( pl[pl != 0] )
gain_rate <- mean( pl[pl > 0] ) / abs( mean( pl[pl < 0] ) )
profit_factor <- sum( pl[pl > 0] ) / abs( sum( pl[pl < 0] ) )
cum_pl <- cumsum(pl)
dd <- cum_pl - cummax(cum_pl) # [d]raw[d]own
mdd <- mean(dd)
max_ddd <- max( diff( which(dd==0) ) ) # [max]imum [d]raw[d]own [d]uration
View( cbind(win_rate, gain_rate, profit_factor, mdd, max_ddd) )

# Plot the strategy.
y_range <- range(dd, cum_pl)
plot(dd, type='h', col='#91d18b', ylim=y_range)
par(new=T)
plot(cum_pl, type='h', col='#e11d74', lwd=2, ylim=y_range)
points( which(dd == 0), cummax(cum_pl)[ which(dd == 0) ], pch=4, col='#440047' )

# Execute the strategy. borrow & sell first.
pl <- setNames( rep( 0, length(clp) ), time(stock) )
is_sold <- FALSE
for (m in M_START:yesterday) {
    if (!is_sold && clp[m] >= cl_bb[m, 3]) { # touch bollinger band up
        sold <- short( as.numeric( opp[m+1] ) )
        is_sold <- TRUE
    }
    else if (is_sold && clp[m] <= cl_bb[m, 1]) { # touch bollinger band down
        pl[m] <- sold - long( as.numeric( opp[m+1] ) )
        is_sold <- FALSE
    }
}

# Assess the strategy.
win_rate <- length( pl[pl > 0] ) / length( pl[pl != 0] )
gain_rate <- mean( pl[pl > 0] ) / abs( mean( pl[pl < 0] ) )
profit_factor <- sum( pl[pl > 0] ) / abs( sum( pl[pl < 0] ) )
cum_pl <- cumsum(pl)
dd <- cum_pl - cummax(cum_pl) # [d]raw[d]own
mdd <- mean(dd)
max_ddd <- max( diff( which(dd==0) ) ) # [max]imum [d]raw[d]own [d]uration
View( cbind(win_rate, gain_rate, profit_factor, mdd, max_ddd) )

# Plot the strategy.
y_range <- range(dd, cum_pl)
plot(dd, type='h', col='#91d18b', ylim=y_range)
par(new=T)
plot(cum_pl, type='h', col='#e11d74', lwd=2, ylim=y_range)
points( which(dd == 0), cummax(cum_pl)[ which(dd == 0) ], pch=4, col='#440047' )

# Execute both strategies.
pl <- setNames( rep( 0, length(clp) ), time(stock) )
is_bought <- FALSE
is_sold <- FALSE
for (m in M_START:yesterday) {
    if (!is_bought && clp[m] <= cl_bb[m, 1]) { # touch bollinger band down
        bought <- long( as.numeric( opp[m+1] ) )
        is_bought <- TRUE
    }
    else if (is_bought && clp[m] >= cl_bb[m, 3]) { # touch bollinger band up
        pl[m] <- short( as.numeric( opp[m+1] ) ) - bought
        is_bought <- FALSE
    }

    if (!is_sold && clp[m] >= cl_bb[m, 3]) { # touch bollinger band up
        sold <- short( as.numeric( opp[m+1] ) )
        is_sold <- TRUE
    }
    else if (is_sold && clp[m] <= cl_bb[m, 1]) { # touch bollinger band down
        pl[m] <- sold - long( as.numeric( opp[m+1] ) )
        is_sold <- FALSE
    }
}

# Assess the strategy.
win_rate <- length( pl[pl > 0] ) / length( pl[pl != 0] )
gain_rate <- mean( pl[pl > 0] ) / abs( mean( pl[pl < 0] ) )
profit_factor <- sum( pl[pl > 0] ) / abs( sum( pl[pl < 0] ) )
cum_pl <- cumsum(pl)
dd <- cum_pl - cummax(cum_pl) # [d]raw[d]own
mdd <- mean(dd)
max_ddd <- max( diff( which(dd==0) ) ) # [max]imum [d]raw[d]own [d]uration
View( cbind(win_rate, gain_rate, profit_factor, mdd, max_ddd) )

# Plot the strategy.
y_range <- range(dd, cum_pl)
plot(dd, type='h', col='#91d18b', ylim=y_range)
par(new=T)
plot(cum_pl, type='h', col='#e11d74', lwd=2, ylim=y_range)
points( which(dd == 0), cummax(cum_pl)[ which(dd == 0) ], pch=4, col='#440047' )


framingham <- read.csv("framingham.csv")
str(framingham)
summary(framingham)

#Splitting the dataset
library(caTools)
set.seed(1000)
split <- sample.split(framingham$TenYearCHD, SplitRatio = 0.65)
train <- subset(framingham, split == TRUE)
train2 <- na.omit(train)
test <- subset(framingham, split == FALSE)
test2 <- na.omit(test)

# Timet to build our log regression
framinghamLog <- glm(TenYearCHD ~ ., data = train2, family = binomial)
summary(framinghamLog)

# predicting
predictTest <- predict(framinghamLog, type = 'response', newdata = test2)
#building confusion matrix
table(test2$TenYearCHD, predictTest > 0.5)
# total accuracy
(1069+11)/ (1069+11+6+187)
(sens3 <- 11/(11+187))
(spec3 <- 1069/(1069+6))

library(ROCR)
# Finding area under curve
# problem solved: if NA is there in the dataset, please omit it so we can use functions from the ROCR, auc package
ROCRpred <- prediction(predictTest, test2$TenYearCHD)
as.numeric(performance(ROCRpred, "auc")@y.values)


#load cart library for cross validation, read data, drop density.
require(caret)
mydata <- read.csv('Bodyfatproject.csv.')
mydata$Density <- NULL

#Using predictors Age, Weight and Height:
model <- train(bodyfat~Age + Weight + Height, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE))
plot(model$resample$RMSE^2)

#Using predictors Neck, Chest, Abdomen:
model <- train(bodyfat~Neck + Chest + Abdomen, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE))
plot(model$resample$RMSE^2)

#Using predictors Hip, Thigh, Knee:
model <- train(bodyfat~Hip + Thigh + Knee, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE))
plot(model$resample$RMSE^2)

#Using predictors Ankle, Biceps, Forearm, Wrist:
model <- train(bodyfat~Ankle + Biceps + Forearm + Wrist, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE))
plot(model$resample$RMSE^2)

#Using predictors Weight, Height, Neck, Chest, Abdomen:
model <- train(bodyfat~Weight + Height + Neck + Chest + Abdomen, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE))
plot(model$resample$RMSE^2)

#Using predictors Age, Weight, Height, Neck, Chest and Abdomen:
model <- train(bodyfat~Age + Weight + Height + Neck + Chest + Abdomen, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE))
plot(model$resample$RMSE^2)

#Using predictors Weight, Height, Neck, Abdomen, Hip and Thigh:
model <- train(bodyfat~Weight + Height + Neck + Abdomen + Hip + Thigh, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE))
plot(model$resample$RMSE^2)

#Using predictors Weight, Height, Neck, Chest, Abdomen, Hip, Thigh:
model <- train(bodyfat~Weight + Height + Neck + Chest + Abdomen + Hip + Thigh, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE) )
plot(model$resample$RMSE^2)

#Using predictors Weight, Height, Neck, Chest, Abdomen, Hip, Thigh, Biceps, Forearm, Wrist:
model <- train(bodyfat~Weight + Height + Neck + Chest + Abdomen + Hip + Thigh + Biceps + Forearm + Wrist, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE) )
plot(model$resample$RMSE^2)

#Using predictors Weight, Neck, Chest, Abdomen, Hip, Thigh, Biceps, Forearm, Wrist
#This was my best model:
model <- train(bodyfat~Weight + Neck + Chest + Abdomen + Hip + Thigh + Biceps + Forearm + Wrist, mydata, method = "lm", trControl = trainControl(method = "cv", number = 10, verboseIter = TRUE) )
plot(model$resample$RMSE^2)
bestmodel<-lm(bodyfat~Weight + Neck + Chest + Abdomen + Hip + Thigh + Biceps + Forearm + Wrist, data=mydata)
bestmodel$coefficients