# note to self: use the regexp ```\{r.*\}\s([\s\S]+?)``` to extract only the r-code
# from the complete rmd tutorial file

# first we need to install the ggplot and some supporting libraries
# (skip this step if the library is already loaded)
install.packages("ggplot2")

# we will require the ggplot2 package for our graphics
# note: there are some additional useful packages such as plyr,
#  reshape2 and scales which you may find useful
require("ggplot2")

# prices of 50'000 sparkly round cut diamonds
head(diamonds)

# motor trend car road tests
head(mtcars)

# vapor pressure of mercury at certain temperatures
head(pressure)

# histogram with qplot
qplot(clarity, data=diamonds, fill=cut, geom="bar")

# histogram with ggplot -> same output
ggplot(diamonds, aes(clarity, fill=cut)) + geom_bar()

# quickly create a scatterplot of our data
qplot(wt, mpg, data=mtcars)

# data can be transformed with functions
qplot(log(wt), mpg-10, data=mtcars)

# plots can be further refined by using additional parameters
# note: we are mapping the variable «qsec» to a color
qplot(wt, mpg, data=mtcars, color=qsec)

# color and colour will work for most cases
qplot(wt, mpg, data=mtcars, color=qsec)
qplot(wt, mpg, data=mtcars, colour=qsec)

# note: in this example ggplot is trying to map the size of a point
#  to a scale of [10] (which is probably not as intended)
qplot(wt, mpg, data=mtcars, color=qsec, size=10)

# use the I() function «as is» to set aesthetics instead of mapping
qplot(wt, mpg, data=mtcars, color=qsec, size=I(10))
# side note: it is possible to use alpha-blending for overlapping elements
qplot(wt, mpg, data=mtcars, color=qsec, size=I(10), alpha=qsec)

# note: alpha-opacity is set between 0 (transparent) and 1 (opaque)
qplot(wt, mpg, data=mtcars, color=qsec, size=I(10), alpha=I(0.5))

# we take a closer look at the variable cyl from the dataset mtcars
# note: the variable is stored as a continuous number not as a factor
head(mtcars)
summary(mtcars$cyl)
table(mtcars$cyl)

# regular mapping will be displayed on a continuous scale
qplot(wt, mpg, data=mtcars, color=cyl)

# factored variables will be displayed with a discrete scale
qplot(wt, mpg, data=mtcars, color=factor(cyl))

# ggplot will try to guess the «correct» plot for your data
qplot(wt, mpg, data=mtcars)
qplot(factor(cyl), data=mtcars)

# a specific type of plot can be set with the attribute geom=«type»
qplot(wt, mpg, data=mtcars, geom="point")
qplot(wt, mpg, data=mtcars, geom="line")

# plot-types can be combined
qplot(wt, mpg, data=mtcars, geom=c("line", "point"))

# note: problem if only size of points should be increased
qplot(wt, mpg, data=mtcars, geom=c("line", "point"), size=I(2))

# pro-tipp: resort to ggplot syntax (more on that later)
qplot(wt, mpg, data=mtcars) + geom_line() + geom_point(size=4)

# a plot can be flipped by 90°
# note: coord_flip() will rotate the plot after calculation of
#  any summary statistics (i.e. smoothers or alike)
qplot(factor(cyl), data=mtcars)
qplot(factor(cyl), data=mtcars) + coord_flip()

# difference between fill/color bars
qplot(factor(cyl), data=mtcars, fill=factor(cyl))
qplot(factor(cyl), data=mtcars, color=factor(cyl))

# use different position properties for bars (stacked, dodged, fill, identity)
head(diamonds)
qplot(clarity, data=diamonds, geom="bar", fill=cut, position="stack")
qplot(clarity, data=diamonds, geom="bar", fill=cut, position="dodge")
qplot(clarity, data=diamonds, geom="bar", fill=cut, position="fill")
qplot(clarity, data=diamonds, geom="bar", fill=cut, position="identity")

# we are going to use some pressure data
head(pressure)

# nothing happens if we only define our data
ggplot(pressure)

# but we can quickly add a representation
# note: the aes() function is used for variable mapping
ggplot(pressure) + geom_point(aes(x=temperature, y=pressure))

# as x and y are used so often, we can leave it of
# note: for later maintenance it is usually better to specify it
ggplot(pressure) + geom_point(aes(temperature, pressure))

# note: you can access the previously created plot with «last_plot()»
last_plot()

# specify a value allocation outside of the aes() function
# if an aestetic should be set to a specific value
ggplot(pressure) + geom_point(aes(temperature, pressure), size=4)

# aesthetics can also be defined separately
ggplot(pressure) + aes(temperature, pressure) + geom_point(size=4)

# create some normal distributed test data
tmp <- data.frame(x=rnorm(4000), y=rnorm(4000))
p.myplot <- ggplot(tmp, aes(x,y))

# default plotting
p.myplot + geom_point(color="red")

# plotting using hollow circles
p.myplot + geom_point(shape=1, color="red")

# plotting using pixels
p.myplot + geom_point(shape=".", color="red")

# plotting using alpha transparency
# note: requires the scales package (included with ggplot2)
p.myplot + geom_point(color=scales::alpha("red", 1/2))
p.myplot + geom_point(color=scales::alpha("red", 1/6))

# ggplot will actually return an object that can be modified
# note: the object can also be saved for later use with save()
#   saving a plot or layer definitions will also include the plot data
p.myplot <- ggplot(pressure)

# summary information about the plot
summary(p.myplot)

# adding some additional layers
p.myplot <- p.myplot + aes(temperature, pressure) + geom_point(size=4)
summary(p.myplot)

# the plot can be printed by just calling the object or using print()
p.myplot
print(p.myplot)

# the underlying data is saved within the ggplot-object. modifications of
# the data will not alter the plot if the plot-code is not rerun.
# there is however a special syntax to run the plot with updated data
pressure2 <- data.frame(
	"temperature"=pressure$temperature, "pressure"=log(pressure$pressure))

# print the plot with updated data
p.myplot %+% pressure2

# a plot can be exported using ggsave
# note: the respective rendering device needs to be installed
ggsave(file="testplot.pdf", plot=p.myplot, width=10, height=5)
ggsave(file="testplot.svg", plot=p.myplot, width=10, height=5)
ggsave(file="testplot.png", plot=p.myplot, dpi=72, width=10, height=5)

# let's define a base plot and aesthetic-mapping
p.myplot <- ggplot(pressure) + aes(x=temperature, y=pressure)

# using multiple layers
p.myplot +
	geom_point(color="purple3", size=6) +
	geom_line(color="steelblue2", size=2)

# the order of the layers does mather
# (each new layer is drawn on top of the previous)
p.myplot +
	geom_line(color="steelblue", size=2) +
	geom_point(color="purple3", size=6)

# aesthetics defined in the base layer will be used for all layers
# note: setting attributes to a value will not apply it to other layers
ggplot(pressure, aes(x=temperature, y=pressure), color="red") +
	geom_line(size=4, alpha=0.3) +
	geom_point(size=4)

# the actual arguments to map variables is mapping=«aes()» and
# geom_params=«list()» to set variables respectively
ggplot(pressure) +
	geom_point(
		mapping=aes(x=temperature, y=pressure, color=factor(temperature)),
		geom_params=list(size=4, shape=18)
	)

# it is possible to mix qplot and ggplot
qplot(temperature, pressure, data=pressure, geom="line", lty=I("dashed")) +
	geom_point(size=4)

# there is also a different syntax with layer()
ggplot(pressure, aes(temperature, pressure)) +
	layer(geom="line", mapping=aes(color=temperature), size=4) +
	layer(geom="point", size=4, color="purple3")

# let's use some additional data in the plot
# note: the scales of the different datasets are unified
ggplot(pressure) +
	aes(x=temperature, y=pressure) +
	layer(geom="line", mapping=aes(color=temperature), size=4) +
	geom_point(data=mtcars, aes(hp, disp), color="purple3", size=3)

# setup our plot with default scales
p.myplot <- ggplot(pressure) +
	aes(temperature, pressure, color=factor(temperature)) +
	geom_point(size=4)

# scales can be limited to a certain range
p.myplot
p.myplot + scale_x_continuous("Temperature", limits=c(200, 400))

# scales that are used as axes will take the name as axis label
p.myplot +
	scale_color_discrete(name="Temperature \nin C°") +
	scale_y_continuous(name="Air pressure at sea level")

# legends can also be removed (if not important to understand the plot)
p.myplot + scale_color_discrete(guide="none")

# setup a different plot
p.myplot <- ggplot(diamonds, aes(cut, fill=color)) + geom_bar()
p.myplot

# the axis can be renamed using two different methods
p.myplot + xlab("Diamond Cut")
p.myplot + scale_x_discrete(name="Diamond Cut Description")
p.myplot + scale_y_continuous(name="Number of Diamonds")

# names of legends can also be set
p.myplot + scale_fill_discrete(name="Diamond Color")

# using some custom colors
# note: brewer colors were created for good readable maps and often provide
#  a good alternative to the standard colors. to see all available brewer
#  palettes use «RColorBrewer::display.brewer.all()»
p.myplot + scale_fill_grey()
p.myplot + scale_fill_hue()
p.myplot + scale_fill_brewer()
p.myplot + scale_fill_brewer(type="seq", palette="3")
p.myplot + scale_fill_brewer(palette="Paired")

# using a custom color palette with specified order
# note: color values should be specified as hex or color names
p.myplot + aes(fill=cut) + scale_fill_manual(
	values = c("#7fc6bc","#083642","#b1df01",
						 "#cdef9c","#466b5d", "#744db5", "#ccb2e8"))

# using predefinded colors for specific values
# note: values that are not present in the data will not be shown
p.myplot + aes(fill=cut) + scale_fill_manual(
	values = c("Fair"="#083642", "Good"="#466b5d",
						 "Very Good"="#7fc6bc","Premium"="#cdef9c",
						 "Ideal"="#b1df01", "Not specified"="#ffffff"))

# removing values from the legend and custom labelling of values
# note: you must specify colors for all existing values
p.myplot + scale_fill_manual(
	name="Colors",
	values = c("D"="#083642", "E"="#466b5d", "F"="#7fc6bc","G"="#cdef9c",
						 "H"="#b1df01", "I"="#ababab", "J"="#ececec"),
	breaks = c("D", "E", "F"),
	labels = c("E"="Dark Green", "D"="Esmerald", "F"="Wood"))

# legends can also be styled using guides
# note: guides can be defined once and be easily applied to multiple plots
p.mylegend <- guide_legend(
		title="Color of the \nDiamond",
		title.position="top",
		direction="horizontal",
		label.position="top",
		label.hjust=0.5,
		label.vjust=0.5,
		ncol=2,
		byrow=TRUE,
	)

# apply some styling to the legend
p.myplot + guides(fill = p.mylegend)
p.myplot + scale_fill_discrete(guide=p.mylegend)

# handling problems with alpha transparency
p.myplot + aes(alpha=color)

# remove the alpha transparency for the legend
p.myplot + aes(alpha=color) +
	guides(fill = guide_legend( override.aes=list(alpha=1) ))

# limiting scales will remove all points that are outside of the scale
# note: be careful, this is not the same as just focusing on a graph region
p.myplot + scale_y_continuous(limits=c(0,15000))

# to focus on a specific region, the coord_cartesian() function
#  should be used with the specified limits
p.myplot + coord_cartesian(ylim=c(0,15000))

# histograms will use stat_bin to calculate number of items per bin
ggplot(mtcars) + aes(qsec) + geom_histogram(binwidth=0.5)
ggplot(mtcars) + aes(qsec) + geom_histogram(binwidth=1)

# define a base plot to illustrate smoothed lines
p.myplot <- ggplot(mtcars) + aes(x=disp, y=mpg) + geom_point(size=4)
p.myplot

# draw a smooth line (local regression function) through the points
# note: the default smoothing function is loess
p.myplot + geom_line(stat="smooth")

# using the smooth geom with standard deviation
p.myplot + geom_smooth()

# fit the regression closer to the data with span=«0-1»
p.myplot + geom_smooth(span=0.4)
p.myplot + geom_smooth(span=1)

# turning off the confidence interval
# note: the attribute level can be used to set ci-level
p.myplot + geom_smooth(se=FALSE)

# using a different method for smoothing (i.e. linear modelling)
p.myplot + geom_smooth(method="lm")

# using a cutom formular for fitting
library(splines)
p.myplot + geom_smooth(method="lm", formula = y ~ ns(x,5))

# be careful when flippling a plot
# note: details on transformations on the following slide
p.myplot + geom_smooth()
p.myplot + geom_smooth() + coord_flip()
p.myplot + aes(x=mpg, y=disp) + geom_smooth()

# define a base plot to illustrate transformation
p.myplot <- ggplot(mtcars) + aes(x=disp, y=mpg) + geom_point(size=4) +
	geom_smooth(method="lm", se=FALSE)

# take a look at linear regression plot
p.myplot

# apply a logarhithmic transformation
p.myplot + scale_x_continuous(trans="log", name="log(disp)")

# apply a log-transformation on the y-axis, add a linear regression and
# transform the display of the scale back with exponentation
p.myplot + scale_x_continuous(trans="log") +
	coord_trans(x="exp") +
	xlab("exp(log(disp)) = disp")

# adjust the y-scale breaks to match our original non transformed plot
p.myplot + scale_x_continuous(trans="log", breaks=seq(100,400,100)) +
	coord_trans(x="exp") +
	xlab("exp(log(disp)) = disp")

# split data to create frequency polygon for each subgroup
qplot(clarity, data=diamonds, geom="bar", fill=cut, position="dodge")
qplot(clarity, data=diamonds, geom="freqpoly", group=cut, color=cut, position="identity")

# split the data by a variable and calculate a regression for each group
ggplot(mtcars, aes(x=disp, y=mpg, color=factor(am))) + geom_point(size=4) +
	geom_smooth(aes(group=factor(am)), method="lm", se=FALSE, lty="dashed")

# use facets to split the data
p.myplot <- ggplot(mtcars) +
	aes(x=disp, y=mpg, color=factor(am)) +
	geom_point(size=4) +
	geom_smooth(method="lm", se=FALSE, lty="dashed")

# facet_wrap will wrap the specified panels
p.myplot + facet_wrap(~ am, nrow=1)
p.myplot + facet_wrap(~ am, ncol=1)

# per default the scales of the different panels will match
# it is however possible to use adaptive panes
# note: more options can be found in the documentation
p.myplot + facet_wrap(~ am, nrow=1, scales="free")

# facet_grid can be used to split by two variables
p.myplot + facet_grid(cyl ~ am)

# it is even possible to add margin calculations
p.myplot + facet_grid(cyl ~ am, margins=TRUE)

# setup plot to illustrate annotations
p.myplot = ggplot(mtcars, aes(x = wt, y = mpg))

# plot without annotations
p.myplot + geom_point(size=4, color="purple3")

# a plot with some simple annotations
p.myplot +
	annotate("rect",
					 fill="lightsteelblue", alpha=0.4,
					 xmin=3, xmax=4, ymin=12, ymax=20.5) +
	annotate("segment",
					 size = 1, color="steelblue",
					 arrow = grid::arrow(length=grid::unit(1, "char")),
					 x=4.73, y=30.5, xend=3.8, yend=21) +
	annotate("text", label="A custom region",
					 x=4.32, y=31.2, hjust=0, vjust=0, color="steelblue", size=8) +
	geom_point(size=4, color="purple3")

# we create a function, that will calculate the coordinates for stripes that
# are contained to the given rect coordinates
# note: this involves some trigonometry and is outside
#   the scoope of this tutorial
stripesInRect <- function(angle=45, distance=0.5, xmin=0, xmax=10, ymin=0, ymax=10) {
	# this function will calculate a data.frame of vectors for a
	# stripped background in a rectangular area

	# convert angle from degree to radians
	radians <- (pi / 180) * angle

	# calculate the tangens
	tangens <- tan(radians)

	# calculate height und width of the clippling box
	height <- ymax - ymin
	width <- xmax - xmin

	# calculate the horizontal distance of the lines
	horizontalDistance = distance / tangens

	# calculate the difference of start-y to end-y for full width
	verticalDifference <- tangens * width

	# steps for the height and width
	stepsHeight = seq(from = ymin, to = ymax, by = distance)
	stepsWidth = seq(from = xmin, to = xmax, by = horizontalDistance)

	# initialize a data frame of coordinates
	# note: distance is used for distance of lines when cutting
	#   through the side of the box
	# note: we have to remove the first step from the widthsteps
	#  to avoid a duplicated start line
	data <- data.frame(
		"x1" = c(rep(xmin, times = length(stepsHeight)), stepsWidth[-1]),
		"y1" = c(stepsHeight, rep(ymin, length(stepsWidth))[-1] ))

	# define a function to calculate the endpoints
	calculateEndpoint <- function(x1, y1) {

		# calculate the maximal available width for the x range
		availableWidthRange <- xmax - x1

		if (availableWidthRange >= width) {
			# calculation of lines that start from the left side

			# calculate the maximal available height for the y range
			availableHeightRange <- ymax - y1

			# we are done if the vertical-side fits into the rect
			if (availableHeightRange >= verticalDifference) {
				return(c(
					"x2" = xmax,
					"y2" = y1 + verticalDifference))
			}

			# otherwise we have to adapt to the available height
			horizontalDifference <- availableHeightRange / tangens

			return(c(
				"x2" = x1 + horizontalDifference,
				"y2" = ymax))

		} else {
			# calculation of lines that start from the bottom side

			# calculate the vertical difference
			verticalDifference <- availableWidthRange * tangens

			return(c(
				"x2" = xmax,
				"y2" = y1 + verticalDifference
				))

		}

	}

	# calculate the endpoints
	endpoints <- mapply(calculateEndpoint, data$x1, data$y1)

	# extract the endpoint coordinates
	data$x2 <- endpoints[1,]
	data$y2 <- endpoints[2,]

	return(data)
}

# calculate the pattern coordinates for our plot
pattern <- stripesInRect(angle=80, distance=0.25,
												 xmin=3, xmax=4, ymin=12, ymax=20.5)

# create the plot with a striped background for the annotation
# note: annotation aesthetics are not mapped but will be processed as vectors
p.myplot +
	annotate("segment",
					 size = 0.5, color="deeppink", alpha=0.25,
					 x=pattern$x1, y = pattern$y1,
					 xend = pattern$x2, yend = pattern$y2) +
	annotate("segment",
					 size = 1, color="deeppink",
					 arrow = grid::arrow(length=grid::unit(1, "char")),
					 x=4.73, y=30.5, xend=3.8, yend=21) +
	annotate("text", label="A custom region",
					 x=4.32, y=31.2, hjust=0, vjust=0, color="deeppink", size=8) +
	geom_point(size=4, color="purple3")

# define our plot to illustrate theming
p.myplot <- ggplot(pressure) +
	aes(temperature, pressure, color=factor(temperature)) +
	geom_point(size=4)

# plotting using the default theme
p.myplot

# plotting using a black & white theme
# note: the theme does not change the aesthetics controlled by data
p.myplot + theme_bw()

# modifiying specific elements of a theme
# note: more options can be found in the documentation
#  theme modifications may require some understanding of the grid-package
p.myplot + theme(
	legend.position="top",
	legend.margin=grid::unit(1, "cm"))

# legends usually need some further specific adjustments
p.myplot + theme(
	legend.position="bottom",
	legend.margin=grid::unit(1, "cm")) +
 guides(
 	color=guide_legend("Temperature", nrow=2,
 										 title.position="top", byrow=TRUE))

# use combination of geoms and specific stat for bin calculation
# note: values from stat-calculations can be accessed via ..«parameter»..
ggplot(mtcars) + aes(x=factor(gear)) +
	layer(
		stat = "bin",
		geom = "linerange",
		geom_params = list(ymin=0, size=0.5, color="blue"),
		mapping = aes(ymax=..count..)) +
	layer(
		stat = "bin",
		geom = "point",
		geom_params = list(size=3, color="blue")) +
	layer(
		stat = "bin",
		geom = "text",
		geom_params = list(vjust=-0.8, color="blue"),
		mapping = aes(label=..count..)) +
	coord_flip() + theme_bw()

# we can also define the configuration in a custom function
latticebars <- function(color = "blue") {
	layer1 <- layer(
		geom = "linerange", stat = "bin",
		mapping = aes(ymax=..count..),
		geom_params = list(ymin=0, size=0.5, color=color))

	layer2 <- layer(
		geom = "point", stat = "bin",
		geom_params = list(size=3, color=color))

	layer3 <- layer(
		 geom = "text", stat = "bin",
		mapping = aes(label=..count..),
		geom_params = list(vjust=-0.8, color=color))

	# note: ggplot2 elements can also be combined by creating
	#  a list of the separate components. +-symbol might
	#  throw an error if used inside of a function
	return(list(layer1,layer2,layer3, coord_flip(), theme_bw()))
}

# create a lattice like barplot with default color
ggplot(mtcars) + aes(x=factor(gear)) +
	latticebars()

# easily change the color of the plot
ggplot(mtcars) + aes(x=factor(gear)) +
	latticebars("red") +
	xlab("Type of Gear\n") + ylab("\nNumber of Items")

# we are going to need the grid package
require("grid")

# convenience function to create multi-plot setup (nrow, ncol)
vp.setup <- function(x,y){
	# create a new layout with grid
	grid.newpage()

	# define viewports and assign it to grid layout
	pushViewport(viewport(layout = grid.layout(x,y)))
}

# convenience function to easily access layout (row, col)
vp.layout <- function(x,y){
	viewport(layout.pos.row=x, layout.pos.col=y)
}

# define three plots to be displayed together
p.a <- qplot(mpg, wt, data=mtcars, geom="point") + theme_bw()
p.b <- qplot(mpg, wt, data=mtcars, geom="bar", stat="identity")
p.c <- qplot(mpg, wt, data=mtcars, geom="step")

# setup amulti plot layout with grid (2x2 fields)
vp.setup(2,2)

# plot all graphics into our layout
print(p.a, vp=vp.layout(1, 1:2))
print(p.b, vp=vp.layout(2, 1))
print(p.c, vp=vp.layout(2, 2))


# Goal: To make latex tabular out of an R matrix

# Setup a nice R object:
m <- matrix(rnorm(8), nrow=2)
rownames(m) <- c("Age", "Weight")
colnames(m) <- c("Person1", "Person2", "Person3", "Person4")
m

# Translate it into a latex tabular:
library(xtable)
xtable(m, digits=rep(3,5))

# Production latex code that goes into a paper or a book --
print(xtable(m,
             caption="String",
             label="t:"),
             type="latex",
             file="blah.gen",
             table.placement="tp",
             latex.environments=c("center", "footnotesize"))
# Now you do \input{blah.gen} in your latex file.

# You're lazy, and want to use R to generate latex tables for you?
data <- cbind(
              c(7,9,11,2),
              c(2,4,19,21)
              )
colnames(data) <- c("a","b")
rownames(data) <- c("x","y","z","a")
xtable(data)

# or you could do
data <- rbind(
              c(7,2),
              c(9,4),
              c(11,19),
              c(2,21)
              )
# and the rest goes through identically.

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


require(Hmisc)
set.seed(1)
p <- data.frame(x=1:10, y=1:10 + runif(10))
d <- data.frame(x=rnorm(1000, 5, 1), y=sample(1:10, 1000, TRUE))
g <- ggplot(p, aes(x=x, y=y)) + geom_line()
g + histSpikeg(y ~ x, p, d)
g + histSpikeg(y ~ x, data=d, side=1)
g + geom_point() + histSpikeg(y ~ x, data=d, lowess=TRUE)

p <- expand.grid(sex=c('male','female'), region=c('a','b','c'), x=1:10)
p$y <- with(p, x + runif(60) + 2*runif(60)*(sex=='female') + 3*(region=='c'))
g <- ggplot(p, aes(x=x, y=y, color=sex)) + facet_wrap(~ region)
g + geom_line()
d <- expand.grid(sex=c('male', 'female'), region=c('a','b','c'), reps=1:300)
d$x <- rnorm(nrow(d), 5, 2)
d$x[d$sex == 'male'] <- rnorm(sum(d$sex == 'male'), 7, .4)
d$x[d$region == 'b'] <- rnorm(sum(d$region == 'b'), 2, 1)
g + geom_line() +
  histSpikeg(y ~ x + sex + region, p, d)
d$y <- with(d, x + runif(1800) + 2*runif(1800)*(sex=='female') +
              3*(region=='c'))
g + histSpikeg(y ~ x + sex + region, data=d, lowess=TRUE)
g + geom_line() + histSpikeg(y ~ x + sex + region, data=d, lowess=TRUE)
h <- histSpikeg(y ~ x + sex + region, data=d, lowess=TRUE)
g + h
g + h$hist + h$lowess   # equivalent; ggplot2 uses both elements of h list


collatz <- function(n)
{
    c <- 0
    while (n != 1)
    {
        if (n %% 2 == 0)
        {
            n = n / 2
        }
        else
        {
            n = n * 3 + 1
        }
        c  = c + 1
    }
    return(c)
}

main <- function()
{
    f <- 0

    for (j in 0:100)
    {
        for (i in 1:100000)
        {
            f = f + collatz(i)
        }
    }

    print(f)
}

main()


DF <- read.table(text="Rank F1     F2     F3
1    500    250    50
2    400    100    30
3    300    155    100
4    200    90     10
5    300    100     20", header=TRUE)

print(DF)

library(reshape2)
DF1 <- melt(DF, id.var="Rank")

print(DF1)

library(ggplot2)
ggplot(DF1, aes(x = Rank, y = value, fill = variable)) +
        geom_bar(stat = "identity", alpha=0.9, position="dodge")

  ggsave("test1.png",width=5, height=4)


#' Function to calculate ancestral values at particular snapshots in evolutionary time
#'
#' This function calculates ancestral values at a particular snapshot in evolutionare time
#' @param X ieObject
#' @return dataframe with rates for all branches and ancestral states for all nodes in the tree up to the indicated epoch
#' @export
MorphoSpaceEpoch<-function(X,Mya){

#Mya<-90

#Which branches fall onto the Mya line?
value_epoch_all<-c()
MorphoSpace_epoch<-X[which((X$time_node_anc>Mya)&((X$time_node_anc-X$BL)<=(Mya+.00000000001))),]
data_epoch<-split(MorphoSpace_epoch,1:nrow(MorphoSpace_epoch))

#Calculate ancestral state at the Mya line
for (i in 1:length(data_epoch)){

changePerUnit<-(data_epoch[[i]]$value_desc-data_epoch[[i]]$value_anc)/data_epoch[[i]]$BL
timeleft<-data_epoch[[i]]$BL-(Mya-(data_epoch[[i]]$time_node_anc-data_epoch[[i]]$BL))
value_epoch<-data_epoch[[i]]$value_anc+(changePerUnit*timeleft)
value_epoch_all<-rbind(value_epoch_all,value_epoch)

                                }
MorphoSpace_epoch<-cbind(MorphoSpace_epoch,value_epoch_all)
            X_temp<-X
            X_temp$value_desc[which(rownames(X_temp)%in%rownames(MorphoSpace_epoch))]<-value_epoch_all

      #Take only those branches that are <=Mya
            if(length(which(X_temp$time_node_anc<=Mya))>1){X_temp<-X_temp[-which(X_temp$time_node_anc<=Mya),]}
            return(X_temp)

                                }


 DPFTRS Example Program Results

 Solution(s)
             1          2
 1      1.0000     4.0000
 2     -1.0000     3.0000
 3      2.0000     2.0000
 4     -3.0000     1.0000


# movies is already pre-loaded

# Create a histogram for rating
hist(movies$rating)

# Create a histogram for rating, with 6 bins
hist(movies$rating, breaks=6)


#  we obtain a random permutation of the numbers 1 to 16.
x=sample(1:16)
# We thus obtain the assignment of paints to the highway sections
values=c("P1","P1","P1","P1","P2","P2","P2","P2","P3","P3","P3","P3","P4","P4","P4","P4")
cbind(x,values)


library(dplyr)
data <- read.csv('/Users/glmarschmann/.julia/dev/DEBTrait/files/BatchC/manova_r_BGE_select.csv')

data$concentration<-factor(data$concentration, levels = c(1e-7, 1e-5, 1e-3, 1e-1), labels = c("CBT", "BT", "NT", "HT"))
str(data)

dataMelt <- melt(data, id=c('concentration'), measured=c('BGE', 'r'))

names(dataMelt) <- c('Concentration', 'Response', 'Frequency')

ocdBoxplot <- ggplot(dataMelt, aes(Concentration, Frequency, color = Response))
ocdBoxplot + geom_boxplot() + labs(x='Concentration', y='', color='Response') + scale_y_log10()

outcome <- cbind(data$BGE, data$r)
ocdModel <- manova(outcome ~ concentration, data=data)
summary(ocdModel, intercept=TRUE)


# Jinliang Yang
# purpose: calculate the GCA and SCA
# updated: 3.7.2012

#Row        Barcode KRN Note.x         Pedigree   Genotype  Note.y
#3133  8757  11-8757-23 OP  16        10g-1028-21/2048 Tzi8 x P39 Diallel
# input data=d should contain trait and Genotype (Tzi x P39)

getca2 <- function(data=d, trait="KRN", square=FALSE){
  ### check the required cols
  if (!("Genotype" %in% names(data) & trait %in% names(data) ))
    stop(paste("Make sure your data frame contains columns Genotype and ", trait, sep=""));
  data$Genotype <- as.character(data$Genotype)
  ### remove the self genotype
  idx <- grep("@", data$Genotype);
  if(sum(idx)>0) data <- data[-idx,];

  ### get the p1, p2 and reciprocal col
  if(!("p1" %in% names(data) & "p2" %in% names(data) & "reciprocal" %in% names(data) )){
    data$p1 <- NA;
    data$p2 <- NA;
    data$reciprocal <- NA;
    data$Genotype <- as.character(data$Genotype);
    for(i in 1:nrow(data)){
      tem <- unlist(strsplit(data$Genotype[i], split="x"));
      tem <- sort(tem)
      data$p1[i] <- tem[1];
      data$p2[i] <- tem[2];
      data$reciprocal[i] <- paste(tem[1], tem[2], sep="_")
    }
  }

  ### start the calculation according to Method 4, Model I
  uhat <- mean(data[,trait], na.rm=T);
  inbred <- sort(unique(c(data$p1, data$p2)));

  ### General Combining Ability
  gca <- data.frame(Genotype=inbred, GCA=NA);
  for(j in 1:length(inbred)){
      inbredj = inbred[j];
      ghat <- mean(subset(data, p1==inbredj | p2==inbredj)[, trait], na.rm=T)-uhat;
      gca[gca$Genotype==inbredj,]$GCA <- ghat;
  }

  ### Specific Combining Ability
  sca <- matrix(NA, nrow=length(inbred), ncol=length(inbred)+1);
  sca <- as.data.frame(sca)
  names(sca) <- c(trait, inbred)
  sca[,1] <- inbred

  specific <- unique(data$reciprocal);

  scatable <- data.frame()
  for(k in 1:length(specific)){
      tem2 <- unlist(strsplit(specific[k], split="_"));
      myp1 <- tem2[1];
      myp2 <- tem2[2];

      pheno <- subset(data, (p1==myp1 & p2==myp2) | (p1==myp2 & p2==myp1));
      shat <- mean(pheno[, trait], na.rm=T) - subset(gca, Genotype==myp1)$GCA - subset(gca, Genotype==myp2)$GCA - uhat;
    if(square){
      sca[sca[,1]==myp1, myp2] <- shat;
    } else {
      temid <- paste(myp1, myp2, sep="x");
      temsca <- data.frame(Genotype=temid, SCA=shat)
      scatable <- rbind(scatable, temsca)
    }

  }

  outputlist <- list();
  outputlist[[1]] <- gca;
  if(square){
    outputlist[[2]] <- sca;
  } else{
    outputlist[[2]] <- scatable;
  }

  return(outputlist)
}
###############################################
mydata <- read.csv("pheno_diallel_master_BLUE.csv")
krnca <- getca2(data=mydata, trait="KRN", square=FALSE)

#################################################################################
# make the design matrix
#####################################################################################################################################################
design <- read.table("/Users/yangjl/Documents/Heterosis_GWAS/SNP/diallel_4impute.txt", header=TRUE)

dm <- matrix(0, nrow=378, ncol=28+378)
dm <- as.data.frame(dm)
p <- as.character(unique(design$p1));
names(dm) <- c("Geno", p, as.character(design$geno))
dm$Geno <- as.character(design$geno);

for(i in 1:nrow(dm)){
  tem <- unlist(strsplit(dm$Geno[i], split="x"));
  p1 <- tem[1];
  p2 <- tem[2];
  dm[i, p1] <- 1;
  dm[i, p2] <- 1;
  dm[i, dm$Geno[i]] <- 1;
}

#################
trait <- read.csv("pheno_diallel_master_raw_040612.csv")
trait$Curtiss <- 0; # Only B73
trait$Dairy <- 0;
trait$Johnson <- 0;
trait$zumwalt <- 0;

for (i in 1:nrow(trait)){
  farm <- as.character(trait$Farm[i]);
  trait[i, farm] <- 1;
}

#############################
#FUNCTION to GCA and SCA
trait$u <- 1
getca1 <- function(traitnm="KRN"){
  tem <- merge(trait[, c("Genotype2", traitnm,"u", "Dairy", "Johnson", "zumwalt")], dm, by.x="Genotype2", by.y="Geno")
  tem <- tem[!is.na(tem[,2]),]
  yield <- tem[,2]
  dmatrix1 <- as.matrix(tem[, 3:5]);

  dmatrix1 <- apply(dmatrix1,2, as.factor)

  dmatrix1 <- as.matrix(tem[, 6:410]);
  fit2 <- lm(yield ~ dmatrix1)
  ped.hat1 <- fit1$coef
  ped.hat1 <- ped.hat1[!is.na(ped.hat1)]

  names(ped.hat1) <- gsub("dmatrix1", "", names(ped.hat1));
  names(ped.hat1)[1] <- "yhat"

  output <- list(gca=ped.hat1[1:29], sca=ped.hat1[30:227])
  return(output)
}

#############
krn1 <- getca1("KRN")
kc <- getca("KC")
akw <- getca("AKW")
tkw <- getca("TKW")
cd <- getca("CD")
cw <- getca("CW")
cl <- getca("CL")

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

getca(data=sample, trait="Yield")
#########################################################################################################################
x1 <- c(rep("P1",8), rep("P2",7), rep("P3",6), rep("P4",5), rep("P5",4), rep("P6",3), rep("P7",2), rep("P8",1));
x2 <- c(paste("P",2:9,sep=""), paste("P",3:9,sep=""), paste("P",4:9,sep=""), paste("P",5:9,sep=""), paste("P",6:9,sep=""),
        paste("P",7:9,sep=""), paste("P",8:9,sep=""), paste("P",9,sep=""))
yield <- c(240, 260, 230.4, 257, 241.5, 266.9, 240.1, 300.4,
               209, 217.3, 233.1, 229.5, 266.9, 216.3, 214.2,
                    183.7, 253.7, 250.1, 268.8, 222.3, 252.1,
                           233.8, 213.7, 255.7, 197.4, 281,
                                  206.8, 272.2, 242.9, 260.8,
                                         261.8, 270.3, 283.9,
                                                273.2, 302.2,
                                                       259.8)
cw <- c(31.8, 34.7, 32.3, 45, 39, 35.1, 35.7, 40.1,
              27.9, 30.8, 39.6, 33.1, 30.9, 30.9, 28.5,
                    25.2, 41.4, 35.5, 34.9, 32.1, 32.4,
                          42.6, 35.7, 35.6, 32.7, 41.3,
                                40.1, 43.6, 41.8, 44.2,
                                      39.1, 43.5, 41.5,
                                            38.3, 41.1,
                                                  35.2)
scw <- c(208.2, 225.3, 198.1, 212, 202.5, 231.8, 204.4, 260.3,
                181.1, 186.5, 193.5, 196.4, 236, 185.4, 185.7,
                       158.5, 212.3, 214.6, 233.9, 190.2, 219.7,
                              191.2, 178, 220.1, 164.7, 239.7,
                                     166.7, 228.6, 201.1, 216.6,
                                            222.7, 226.8, 242.4,
                                                   234.9, 261.1,
                                                          224.6)

sample <- data.frame(P1=x1, P2=x2, Yield=yield, CW=cw, SCW=scw)
sample$Genotype <- paste(sample$P1, sample$P2, sep=" x ")

#####################################################################################################################################################
design <- read.table("/Users/yangjl/Documents/Heterosis_GWAS/SNP/diallel_4impute.txt", header=TRUE)

dm <- matrix(0, nrow=378, ncol=28+378)
dm <- as.data.frame(dm)
p <- as.character(unique(design$p1));
names(dm) <- c("Geno", p, as.character(design$geno))
dm$Geno <- as.character(design$geno);

for(i in 1:nrow(dm)){
  tem <- unlist(strsplit(dm$Geno[i], split="x"));
  p1 <- tem[1];
  p2 <- tem[2];
  dm[i, p1] <- 1;
  dm[i, p2] <- 1;
  dm[i, dm$Geno[i]] <- 1;
}

#################
data1 <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/LL_KN_AKW_test.csv");

###########################################################
### Delete duplicated input and missing data
file1 <- read.csv("LL_KRN_test.csv")
dim(file1)
#8678 8

diallel <- subset(file1, Note.y=="Diallel" | Note.y=="NAM Filler");
dim(diallel)
#[1] 2850    8
#summary(diallel)

###########################################################
### Delete duplicated input and missing data
# Get ride of 4 duplicated records
dup <- which(duplicated(diallel$Barcode))
diallel <- diallel[!duplicated(diallel$Barcode),]

# Get ride of the missing records
### checking for outlyers
diallel$KRN <- as.numeric(as.character(diallel$KRN));
diallel[is.na(diallel$KRN),]
diallel <- diallel[!is.na(diallel$KRN),]
hist(diallel$KRN, breaks=10)
dim(diallel)
#[1] 2837    8

data2 <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/LL_KRN_test.csv");
data3 <- read.csv("~/Documents/Heterosis_GWAS/pheno2011/LL_cob.test.csv");

data1 <- subset(data1, )

dm2 <- merge(sample, dm, by.x="Genotype", by.y="Geno")

yield <- dm2$Yield
dmatrix <- as.matrix(dm2[, 7:52]);

fit <- lm(yield ~ dmatrix)


# Necessary libraries:
library(plyr)
library(dplyr)
library(tibble)
library(tidyr)
library(ggplot2)
library(lme4)
library(e1071)
library(anytime)
theme_set(theme_bw())

# This file contains several examples of typical statistical analysis functions,
# can be used as a template for other R scripts.
#
# Assumes that the dataset contains the following:
#
# depvar => dependent variable (assume ratio scaled here)
# bin-indvar => binary independent variable: categorial, bin-indvar-1 = True, bin-indvar-0 = False
# cont-indvar-A => continuous independent variable A: ratio scale
# cont-indvar-B => continuous independent variable B: ratio scale
#
# Also assume that there are zero values/NAs for the dependent variable

setwd("") # Insert path to working directory
d = read.csv(file="") # Insert csv filename for data
summary(d)
head(d)

# Create dataframe with depvar NAs as zero
d$depvar[is.na(d$depvar)] <- 0

# Return number of rows
nrow(d)

# Make table of all rows excluding zero depvar
d_no_zero <- d %>%
  filter(depvar != 0)
nrow(d_no_zero)

# Make table of all rows only zero depvar
d_only_zero <- d %>%
  filter(depvar == 0)
nrow(d_only_zero)

# Make table consisting only of bin-indvar-1 rows
bin-indvar-1-table <- d %>%
  filter(bin-indvar-1 == 1)
bin-indvar-1-table$depvar[is.na(bin-indvar-1-table$depvar)] <- 0 # Change NAs in depvar column to 0
nrow(bin-indvar-1-table)

# Make table of bin-indvar-1 excluding zeros
bin-indvar-1-no-zero <- bin-indvar-1-table %>%
  filter(depvar != 0)
nrow(bin-indvar-1-no-zero)

# Make table of bin-indvar-1 only zeros
bin-indvar-1-only-zero <- bin-indvar-1-table %>%
  filter(depvar == 0)
nrow(bin-indvar-1-only-zero)

# Make table consisting only of bin-indvar-0 rows
bin-indvar-0-table <- d %>%
  filter(bin-indvar-1 == 0)
bin-indvar-0-table$depvar[is.na(bin-indvar-0-table$depvar)] <- 0 # Change NAs in depvar column to 0
nrow(bin-indvar-0-table)

# Make table of bin-indvar-0 excluding zeros
bin-indvar-0-no-zero <- bin-indvar-0-table %>%
  filter(depvar != 0)
nrow(bin-indvar-0-no-zero)

# Make table of bin-indvar-0 only zeros
bin-indvar-0-only-zero <- bin-indvar-0-table %>%
  filter(depvar == 0)
nrow(bin-indvar-0-only-zero)

# Get max, min, mean and median depvar from each subset:
summary(d_no_zero)
summary(bin-indvar-1-no-zero)
summary(bin-indvar-0-no-zero)

# Get st. dev. and IQR for depvar of each subset:
sd(d_no_zero$depvar)
sd(bin-indvar-1-no-zero$depvar)
sd(bin-indvar-0-no-zero$depvar)
IQR(d_no_zero$depvar)
IQR(bin-indvar-1-no-zero$depvar)
IQR(bin-indvar-0-no-zero$depvar)

# Make density plot of depvar for each subset:
limit <- 1 # change this for data
d_depvar_dens_plot <- ggplot(d_no_zero, aes(x=depvar)) +
  geom_density() +
  scale_x_continuous(limits = c(0, limit)) +
  geom_vline(aes(xintercept=mean(depvar)), color="red", linetype="dashed", size=1) +
  geom_vline(aes(xintercept=median(depvar)), color="blue", linetype="dashed", size=1) +
  labs(x="depvar", y = "Density") +
  theme(plot.title = element_text(hjust = 0.5, size=24), axis.text=element_text(size=22),
        axis.title=element_text(size=22,face="bold"))
d_depvar_dens_plot

bin-indvar-1-depvar-dens-plot <- ggplot(bin-indvar-1-no-zero, aes(x=depvar)) +
  geom_density() +
  scale_x_continuous(limits = c(0, limit))  +
  geom_vline(aes(xintercept=mean(depvar)), color="red", linetype="dashed", size=1) +
  geom_vline(aes(xintercept=median(depvar)), color="blue", linetype="dashed", size=1) +
  labs(x="depvar", y = "Density") +
  theme(plot.title = element_text(hjust = 0.5, size=24), axis.text=element_text(size=22),
        axis.title=element_text(size=22,face="bold"))
bin-indvar-1-depvar-dens-plot

bin-indvar-0-depvar-dens-plot <- ggplot(bin-indvar-0-no-zero, aes(x=depvar)) +
  geom_density() +
  scale_x_continuous(limits = c(0, limit))  +
  geom_vline(aes(xintercept=mean(depvar)), color="red", linetype="dashed", size=1) +
  geom_vline(aes(xintercept=median(depvar)), color="blue", linetype="dashed", size=1) +
  labs(x="depvar", y = "Density") +
  theme(plot.title = element_text(hjust = 0.5, size=24), axis.text=element_text(size=22),
        axis.title=element_text(size=22,face="bold"))
bin-indvar-0-depvar-dens-plot

# Compute skewness of each subset
skewness(d_no_zero$depvar)
skewness(bin-indvar-1-no-zero$depvar)
skewness(bin-indvar-0-no-zero$depvar)

# t-test for difference in depvar between bin-indvar-1 and bin-indvar-0
d_no_zero$log_depvar <- log(d_no_zero$depvar) # create log transform column of depvar
bin-indvar-1-no-zero$log_depvar <- log(bin-indvar-1-no-zero$depvar)
bin-indvar-0-no-zero$log_depvar <- log(bin-indvar-0-no-zero$depvar)

t.test(bin-indvar-1-no-zero$log_depvar, bin-indvar-0-no-zero$log_depvar, alternative = "greater")

# Create scatterplots of cont-indvar-A vs. log_depvar
cont-indvar-A_scatter_bin-indvar-1 <- ggplot(bin-indvar-1-no-zero, aes(x=cont-indvar-A, y=log_depvar)) +
  geom_point(shape = 20, size = 1) +
  stat_smooth(method = lm) +
  labs(x="cont-indvar-A", y = "Log of depvar") +
  theme(axis.text=element_text(size=22),
        axis.title=element_text(size=22,face="bold"))
cont-indvar-A_scatter_bin-indvar-1

cont-indvar-A_scatter_bin-indvar-0 <- ggplot(bin-indvar-0-no-zero, aes(x=cont-indvar-A, y=log_depvar)) +
  geom_point(shape = 20, size = 1) +
  stat_smooth(method = lm) +
  labs(x="cont-indvar-A", y = "Log of depvar") +
  theme(axis.text=element_text(size=22),
        axis.title=element_text(size=22,face="bold"))
cont-indvar-A_scatter_bin-indvar-0

# If distribution is long-tailed and there are several outliers:
# Create bin-indvar-1 set excluding outliers
outlier_threshold_upper <- 20 # change according to data
outlier_threshold_lower <- 12 # change according to data
bin-indvar-1-exclude-outliers <- bin-indvar-1-no-zero[bin-indvar-1-no-zero$log_depvar<outlier_threshold_upper & bin-indvar-1-no-zero$log_depvar>outlier_threshold_lower,]

# Test correlation of cont-indvar-A and depvar in bin-indvar-1 set
cor(bin-indvar-1-no-zero$cont-indvar-A, bin-indvar-1-no-zero$log_depvar)
cor(bin-indvar-1-exclude-outliers$cont-indvar-A, bin-indvar-1-exclude-outliers$log_depvar)

# Simple density plots for cont-indvar-B variable in each subset:
plot(density(d_no_zero$cont-indvar-B), main=NA, xlab="cont-indvar-B", cex.lab=2, cex.axis=2)
plot(density(bin-indvar-1-no-zero$cont-indvar-B), main=NA, xlab="cont-indvar-B", cex.lab=2, cex.axis=2)
plot(density(bin-indvar-0-no-zero$cont-indvar-B), main=NA, xlab="cont-indvar-B", cex.lab=2, cex.axis=2)

# Get modes for cont-indvar-B and depvar in split of bin-indvar-0 set:
cont-indvar-B_threshold <- 75 # change according to data
bin-indvar-0-longer <- bin-indvar-0-no-zero[bin-indvar-0-no-zero$cont-indvar-B>=cont-indvar-B_threshold,]
get.mode(bin-indvar-0-longer$cont-indvar-B)
get.mode(bin-indvar-0-longer$depvar)
# Get modes for cont-indvar-B and depvar, longer-time bin-indvar-1 set:
bin-indvar-1-longer <- bin-indvar-1-no-zero[bin-indvar-1-no-zero$cont-indvar-B>=cont-indvar-B_threshold,]
get.mode(bin-indvar-1-longer$cont-indvar-B)
get.mode(bin-indvar-1-longer$depvar)
# Get modal depvar increase:
modal_increase <- (get.mode(bin-indvar-1-longer$depvar) / get.mode(bin-indvar-1-longer$cont-indvar-B)) - (get.mode(bin-indvar-0-longer$depvar) / get.mode(bin-indvar-0-longer$cont-indvar-B))
modal_increase
# Get medians:
median(bin-indvar-0-longer$cont-indvar-B)
median(bin-indvar-0-longer$depvar)
median(bin-indvar-1-longer$cont-indvar-B)
median(bin-indvar-1-longer$depvar)
# Get median depvar increase:
median_increase <- (median(bin-indvar-1-longer$depvar) / median(bin-indvar-1-longer$cont-indvar-B)) - (median(bin-indvar-0-longer$depvar) / median(bin-indvar-0-longer$cont-indvar-B))
median_increase

# If a linear regression is appropriate:
# Build linear regression model: depvar as a function of fixed effects
model <- lm(log_depvar ~ cont-indvar-A * bin-indvar-1 * cont-indvar-B, data=d_no_zero)
summary(model)
# Q-Q plot of residuals:
plot(model,which=2,cex.lab=2, cex.axis=2)

# If residuals are not normally distributed, and polynomial model is appropriate:
# Polynomial model:
poly_model <- lm(log_depvar ~ bin-indvar-1 + polym(cont-indvar-A, degree=3) + polym(cont-indvar-B, degree=3), data = d_no_zero)
summary(poly_model)
plot(poly_model,which=2,cex.lab=2, cex.axis=2)

# Histogram of log of depvar
hist(log(d_no_zero$depvar), main=NA, xlab="Log of depvar", freq=F,cex.lab=2, cex.axis=2)
legend("topright", c("Normal curve", "Empirical curve"), col=c("black", "red"), lwd=1)
lines(seq(10, 40, by=.5),
      dnorm(seq(10, 40, by=.5), mean(log(d_no_zero$depvar)), sd(log(d_no_zero$depvar))))
lines(density(log(d_no_zero$depvar)),col="red")

# If histogram of log of depvar itself is still not normally distributed with heavy tails:
# Histogram excluding tails:
log_depvar_threshold_upper <- 19 # change according to data
log_depvar_threshold_lower <- 14 # change according to data
no_tails <- d_no_zero[d_no_zero$log_depvar >= log_depvar_threshold_lower & d_no_zero$log_depvar <= log_depvar_threshold_upper,]
hist(log(no_tails$depvar), main=NA, xlab="Log of depvar", freq=F,cex.lab=2, cex.axis=2)
lines(seq(10, 40, by=.5),
      dnorm(seq(10, 40, by=.5), mean(log(no_tails$depvar)), sd(log(no_tails$depvar))))
legend("topright", c("Normal curve", "Empirical curve"), col=c("black", "red"), lwd=1)
lines(density(log(no_tails$depvar)),col="red")

# Linear model excluding tails:
no_tails_model <- lm(log_depvar ~ cont-indvar-A * bin-indvar-1 * cont-indvar-B, data=no_tails)
summary(no_tails_model)
no_tails_model_raw <- lm(depvar ~ cont-indvar-A * bin-indvar-1 * cont-indvar-B, data=no_tails)
summary(no_tails_model_raw)
plot(no_tails_model,which=2,cex.lab=2, cex.axis=2)

# Generate correlation matrices:
cor(bin-indvar-1-no-zero$cont-indvar-A, bin-indvar-1-no-zero$cont-indvar-B)
plot(bin-indvar-1-no-zero$cont-indvar-A, bin-indvar-1-no-zero$cont-indvar-B)

# Investigating subset of data with only NAs for depvar:
# Histogram for only zeros
hist(bin-indvar-1-only-zero$cont-indvar-A, freq=F, main=NA, xlab="cont-indvar-A", cex.lab=2, cex.axis=2, xlim=c(-1.5,20), ylim=c(0,15)) # change lims according to data
lines(density(bin-indvar-1-only-zero$cont-indvar-A), col="red")
hist(bin-indvar-1-no-zero$cont-indvar-A, freq=F, main=NA, xlab="cont-indvar-A", cex.lab=2, cex.axis=2, xlim=c(-1.5,20), ylim=c(0,15)) # change lims according to data
lines(density(bin-indvar-1-no-zero$cont-indvar-A), col="red")

# Polynomial regression incl zeros
model_incl_zeros <-lm(depvar ~ bin-indvar-1 + polym(cont-indvar-A, degree=3) + polym(cont-indvar-B, degree=3), data = d)
summary(model_incl_zeros)


programStart = Sys.time()

#required package for text mining
if(!require("tm"))
  install.packages("tm",repos = "http://cran.us.r-project.org")

#required package for SVM
if(!require("e1071"))
  install.packages("e1071",repos = "http://cran.us.r-project.org")

#required package for Adaboost
if(!require("ada"))
  install.packages("ada",repos = "http://cran.us.r-project.org")

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

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

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

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

library(tm)
library(e1071)
library(ada)
library(rbenchmark)

library(gclus)
library(MASS)
library(class)

#Initialize random generator
set.seed(1245)

############### Method definitions for the learning process ####################

#This function makes vector (Vector Space Model) from text message using highly repeated words
getVectorSpaceModel<-function(message,highlyrepeatedwords){

  tokenizedmessage<-strsplit(message, "\\s+")[[1]]

  #making vector
  v<-rep(0, length(highlyrepeatedwords))

  for(i in 1:length(highlyrepeatedwords)){
    for(j in 1:length(tokenizedmessage)){
      if(highlyrepeatedwords[i]==tokenizedmessage[j]){
        v[i]<-v[i]+1
      }
    }
  }
  return (v)
}

svmLinearAnalysis <- function(vtrdata,vtedata) {

  print("Linear Kernel")
  svmlinmodel <- svm(x=vtrdata[,2:length(vtrdata[1,])],y=vtrdata[,1],type='C', kernel='linear');
  summary(svmlinmodel)
  predictionlin <- predict(svmlinmodel, vtedata[,2:length(vtedata[1,])])
  tablinear <- table(pred = predictionlin , true = vtedata[,1]); tablinear
  precisionlin<-sum(diag(tablinear))/sum(tablinear);

  cat(sprintf("General Error using Linear SVM is (in percent): %f",((1-precisionlin)*100)))

  cat(sprintf("Ham Error using Linear SVM is (in percent): %f",((tablinear[1,2]/sum(tablinear[,2]))*100)))

  cat(sprintf("Spam Error using Linear SVM is (in percent): %f",((tablinear[2,1]/sum(tablinear[,1]))*100)))

  svmLinearAccuracy <- calculateAccuracy(tablinear)

  cat("Test vectors:", dim(vtedata), ", Accuracy =", svmLinearAccuracy, "%\n")
}

convert_count <- function(x) {
  y <- ifelse(x > 0, 1,0)
  y <- factor(y, levels=c(0,1), labels=c("No", "Yes"))
  y
}

svmPolynomialAnalysis <- function(vtrdata,vtedata) {

  svmpolymodel <- svm(x=vtrdata[,2:length(vtrdata[1,])],y=vtrdata[,1], kernel='polynomial', probability=FALSE)
  summary(svmpolymodel)

  predictionpoly <- predict(svmpolymodel, vtedata[,2:length(vtedata[1,])])

   for(i in 1:length(predictionpoly)) {

    if(predictionpoly[i] > 0.6)
      predictionpoly[i] = 1
    else
      predictionpoly[i] = 0
   }

  print("tabpoly data:")
  tabpoly <- table(pred = predictionpoly , true = vtedata[,1]);tabpoly
  print(tabpoly)

  svmPolynomialAccuracy <- calculateAccuracy(tabpoly)
  cat("Test vectors:", dim(vtedata), ", Accuracy =", svmPolynomialAccuracy, "%\n")

}

calculateAccuracy <- function(confusionMatrix) {

  accuracy = 0
  for (i in 1 : nrow(confusionMatrix)) {
    for (j in 1 : ncol(confusionMatrix)) {
      if (i == j) {
        accuracy = accuracy + confusionMatrix[i, i]
      }
    }
  }
  accuracy = (accuracy / sum(confusionMatrix)) * 100

  return(accuracy)
}

svmRadialAnalysis <- function(vtrdata,vtedata) {

  svmradmodel <- svm(x=vtrdata[,2:length(vtrdata[1,])],y=vtrdata[,1], kernel = "radial", gamma = 0.09, cost = 1, probability=FALSE)
  summary(svmradmodel)
  predictionrad <- predict(svmradmodel, vtedata[,2:length(vtedata[1,])])

  for(i in 1:length(predictionrad)) {

    if(predictionrad[i] > 0.6)
      predictionrad[i] = 1
    else
      predictionrad[i] = 0
  }

  tabrad <- table(pred = predictionrad, true = vtedata[,1]); tabrad

  svmRadialAccuracy <- calculateAccuracy(tabrad)

  cat("Test vectors:", dim(vtedata), ", Accuracy =", svmRadialAccuracy, "%\n")
}

kNearestNeighbourAnalysis <- function(vtrdata,vtedata) {

  data<-data.frame(sms=vtrdata[,2:length(vtrdata[1,])],type=vtrdata[,1])
  classifier <- IBk(data, control = Weka_control(K = 20, X = TRUE))
  summary(classifier)
  evaluate_Weka_classifier(classifier, newdata = data.frame(sms=vtedata[,2:length(vtedata[1,])],type=vtedata[,1]))
  predict_res <- predict(classifier, newdata = data.frame(sms=vtedata[,2:length(vtedata[1,])], type = vtedata[,1]), type = )

}

naiveBayesAnalysis <-  function(vtrdata,vtedata) {
#---------------------Naive Bayes----------------------------#

sms_train <- apply(vtrdata[,2:length(vtrdata[1,])], 2, convert_count)
sms_test <- apply(vtedata[,2:length(vtedata[1,])], 2, convert_count)
sms_classifier <- naiveBayes(sms_train, factor(vtrdata[,1]))
class(sms_classifier)
sms_test_pred <- predict(sms_classifier, newdata=sms_test)

tab_bayes <- table(sms_test_pred, vtedata[,1])

naiveBayesAccuracy <- calculateAccuracy(tab_bayes)

cat("Test vectors:", dim(vtedata), ", Accuracy =", naiveBayesAccuracy, "%\n")
}

adaBoostAnalysis <-  function(vtrdata,vtedata) {

  adaptiveboost<-ada(x=vtrdata[,2:length(vtrdata[1,])],y=vtrdata[,1],test.x=vtedata[,2:length(vtedata[1,])], test.y=vtedata[,1], loss="logistic", type="gentle", iter=100)
  summary(adaptiveboost)
  varplot(adaptiveboost)
}

vectorizeTrainingAndTestData <- function(data, highlyrepeatedwords) {

  vectoredData = NULL;

  for(i in 1:length(data[,2])){
    if(data[i,1]=="ham"){
      vectoredData=rbind(vectoredData,c(1,getVectorSpaceModel(data[i,2],highlyrepeatedwords)))
    }
    else{
      vectoredData=rbind(vectoredData,c(0,getVectorSpaceModel(data[i,2],highlyrepeatedwords)))
    }
  }

  return (vectoredData)
}

############### End - Method definitions for the learning process ####################
ca = c('SMSSpamCollection.txt','SMSSpamCollection1.txt','SMSSpamCollection2.txt')
cb = c("benchmark_comparisions.png","benchmark_comparisions1.png","benchmark_comparisions2.png")
#for (kk in 1:3) #Unsafe editing
#{  		#Unsafe editing
  #loading data. Original data is from http://archive.ics.uci.edu/ml/datasets/SMS+Spam+Collection
  print("Uploading SMS Spam dataset")
  smstable<-read.csv(ca[1], header = FALSE, quote = "", sep = "\t", colClasses=c('character','character'))

  n = nrow(smstable);
  mysample = sample(1:nrow(smstable),n/2)  # dividing the training and testing set

  training_data = smstable[mysample,]
  testing_data = smstable[-mysample,]

  #smstabletmp<-smstable
  smstabletmp<-training_data

  print("Extracting Ham and Spam Basic Statistics!")

  smstabletmp$type[smstabletmp$V1=="ham"] <- 1
  smstabletmp$type[smstabletmp$V1=="spam"] <- 0

  #Convert character data ismstanto numeric
  tmp<-as.numeric(smstabletmp$type)

  #Basic Statisctics like mean and variance of spam and hams
  hamavg<-mean(tmp)
  print("Average Ham is :");hamavg

  hamvariance<-var(tmp)
  print("Var of Ham is :");hamvariance

  print("Extract average token of Hams and Spams!")

  nohamtokens<-0
  noham<-0
  nospamtokens<-0
  nospam<-0

  for(i in 1:length(smstabletmp$type)){
    if(smstabletmp[i,1]=="ham"){
      nohamtokens<-length(strsplit(smstabletmp[i,2], "\\s+")[[1]])+nohamtokens
      noham<-noham+1
    }else{
      nospamtokens<-length(strsplit(smstabletmp[i,2], "\\s+")[[1]])+nospamtokens
      nospam<-nospam+1
    }
  }

  totaltokens<-nospamtokens+nohamtokens;
  print("total number of tokens is:")
  print(totaltokens)

  avgtokenperham<-nohamtokens/noham
  print("Avarage number of tokens per ham message")
  print(avgtokenperham)

  avgtokenperspam<-nospamtokens/nospam
  print("Avarage number of tokens per spam message")
  print(avgtokenperspam)

  print(" Make two different sets, training data and test data!")

  #select the percent of data that you want to use as training set
  trdatapercent<-0.3

  #training data set

  trdata=NULL

  #test data set
  tedata=NULL

  for(i in 1:length(smstabletmp$type)){
    if(runif(1)<trdatapercent){
      trdata=rbind(trdata,c(smstabletmp[i,1],tolower(smstabletmp[i,2])))
    }
    else {
      tedata=rbind(tedata,c(smstabletmp[i,1],tolower(smstabletmp[i,2])))
    }
  }

  print("Training data size is!")
  dim(trdata)

  print("Test data size is!")
  dim(tedata)

  # Text feature extraction using tm package

  trsmses<-Corpus(VectorSource(trdata[,2]))
  trsmses<-tm_map(trsmses, stripWhitespace)
  trsmses<-tm_map(trsmses, tolower)
  trsmses<-tm_map(trsmses, removeWords, stopwords("english"))

  dtm <- DocumentTermMatrix(trsmses)

  highlyrepeatedwords<-findFreqTerms(dtm, 80)

  #These highly used words are used as an index to make VSM
  #(vector space model) for trained data and test data

  #vectorized training data set
  vtrdata = vectorizeTrainingAndTestData(trdata, highlyrepeatedwords);

  #vectorized test data set
  vtedata = vectorizeTrainingAndTestData(tedata, highlyrepeatedwords);

  #Naive Bayes to be added

  # Run different classification algorithms
  # differnet SVMs with different Kernels
  print("----------------------------------SVM-----------------------------------------")
  svmLinearStart = Sys.time()
  svmLinearAnalysis(vtrdata,vtedata);
  svmLinearEnd = Sys.time()
  cat(sprintf("Time taken by SvmLinearKernel : %f ",(svmLinearEnd - svmLinearStart)))

  print("Polynomial Kernel")
  svmPolynomialStart = Sys.time()
  svmPolynomialAnalysis(vtrdata,vtedata);
  svmPolynomialEnd = Sys.time()
  cat(sprintf("Time taken by SvmPolynomialKernel : %f ",(svmPolynomialEnd - svmPolynomialStart)))

  print("Radial Kernel")
  svmRadialStart = Sys.time()
  svmRadialAnalysis(vtrdata,vtedata);
  svmRadialEnd = Sys.time()
  cat(sprintf("Time taken by SvmRadialKernel : %f ",(svmRadialEnd - svmRadialStart)))

  #print("----------------------------------AdaBoost-----------------------------------")
  adaBoostStart = Sys.time()
  adaBoostAnalysis(vtrdata,vtedata);
  adaBoostEnd = Sys.time()
  cat(sprintf("Time taken by AdaBoost : %f ",(adaBoostEnd - adaBoostStart)))

  #print("----------------------------------NaiveBayes-----------------------------------")
  naiveBayesStart = Sys.time()
  naiveBayesAnalysis(vtrdata,vtedata)
  naiveBayesEnd = Sys.time()
  cat(sprintf("Time taken by NaiveBayes : %f ",(naiveBayesEnd - naiveBayesStart)))

  programEnd = Sys.time()
  cat(sprintf("Time taken by the entire application : %f ",(programEnd - programStart)))


# Syntax
# ifelse (expression, condition1, condition2)

# Here "expression" is an object which can be coerced to logical mode.
# Condition1 is returned for elements that satisfy the expression (return TRUE)
# Condition2 is returned for elements that do not satisfy the expression (return False)

# ! The output of ifelse() function is always a vector! Each element of the
# ...output vector tells whether the test (expression) passed for that element
# ...of the input vector.

x <- c(-5, 5, -2)
# if the expression is satisfied return condition1 else return condition2
ifelse(x > 0, "positive", "negative")


# drSevByShp
# Drought Severity by shapefile zone
# basically a zonal statistics wrapper to
# calculate zonal stats
# Inputs:
#	shp		SpatialPolygonsDataFrame
#	raster  raster of interest
#	aORc	string, agency or chapter
#	progress object for shiny

drSevByShp <- function(shp, raster, aORc, progress=NULL) {
	if(!require(rgdal)) stop("install rgdal package")
	if(!require(raster)) stop("install raster package")
	# if(!require(reshape2)) stop("install reshape2 package")
	# filelist <- list.files(dir, full.names=TRUE)
	# if(length(filelist) == 0) stop("empty directory")
	# s <- shapefile(shp)

	# prep the shapefile, leave out <null> attr instances, rasterize

	# Note: this is needed because readOGR ESRI shapefile driver
	# shaves off attribute field names to 10 characters, so need to
	# do the same here to match it.
	# attrib <- substr(attrib, 1, 10)
	# if(!(attrib %in% names(s@data))) stop("Attribute given not found in shapefile")

	# s <- shapefile(shp)
	shpDF <- shp@data
	tempRaster <- raster
	r <- raster
	# --- okay --- get zones
	zones <- rasterize(shp, tempRaster, field="OBJECTID")
	# --- prep classes ---
	r[r <= -2.0] <- -3            #extremely dry
	r[r > -2.0 & r <= -1.5] <- -2 #severely dry
	r[r > -1.5 & r <= -1.0] <- -1 #moderate dry
	r[r > -1.0 & r <= 1.0] <- 0   #near normal
	r[r > 1.0 & r <= 1.5] <- 1    #moderate wet
	r[r > 1.5 & r <= 2.0] <- 2    #severely wet
	r[r > 2.0] <- 3               #extremely wet

	fillname <- shpDF$OBJECTID
	if(aORc == "agency") {
		shpDF$Agency_Nam <- as.character(shpDF$Agency_Nam)
		names(fillname) <- shpDF$Agency_Nam
		rem <- which(is.na(shpDF$Agency_Nam))
	} else if(aORc == "chapter") {
		shpDF$Chapter_NA <- as.character(shpDF$Chapter_Na)
		names(fillname) <- shpDF$Chapter_Na
		rem <- which(is.na(shpDF$Chapter_Na))
	} else if(aORc == "eco3") {
	  shpDF$US_L3NAME <- as.character(shpDF$US_L3NAME)
	  names(fillname) <- shpDF$US_L3NAME
	  rem <- which(is.na(shpDF$US_L3NAME))
	} else if(aORc == "eco4") {
	  shpDF$US_L4NAME <- as.character(shpDF$US_L4NAME)
	  names(fillname) <- shpDF$US_L4NAME
	  rem <- which(is.na(shpDF$US_L4NAME))
	} else if(aORc == "water_sheds") {
	  shpDF$NAME <- as.character(shpDF$NAME)
	  names(fillname) <- shpDF$NAME
	  rem <- which(is.na(shpDF$NAME))
	}

	if(length(rem) != 0)
  		zones[zones==rem] <- NA
	ct <- crosstab(r, zones)

	# remove NA in var1 and var2
	result <- ct[!is.na(ct$Var1) & !is.na(ct$Var2),]

	# get freq to form totals
	shpFREQ <- freq(zones)
	shpFREQ <- as.data.frame(shpFREQ)
	shpFREQ <- shpFREQ[!is.na(shpFREQ$value) & !is.na(shpFREQ$count),]

	#totals
	result$total <- NA
	filltotal <- shpFREQ$count
	names(filltotal) <- shpFREQ$value

	# fill in total pixels for each agency
	for(i in seq(nrow(shpFREQ)))
	  result$total[result$Var2 == as.numeric(names(filltotal)[i])] <- filltotal[i]

	result$frac <- result$Freq/result$total
	result$perc <- round(result$frac * 100, digits=1)
	result$perclab <- paste0(as.character(result$perc), "%")

	result$class <- NA
	result$class[result$Var1 == -3] <- "extremely dry"
	result$class[result$Var1 == -2] <- "severely dry"
	result$class[result$Var1 == -1] <- "moderately dry"
	result$class[result$Var1 == 0]  <- "near normal"
	result$class[result$Var1 == 1]  <- "moderately wet"
	result$class[result$Var1 == 2]  <- "severely wet"
	result$class[result$Var1 == 3]  <- "extremely wet"

	result$name <- NA
	for(i in seq(length(fillname)))
	  result$name[result$Var2 == fillname[i]] <- names(fillname)[i]

	return(result)

	# n <- 10
	# progress$inc(2/n, detail = paste("Loading shapefile ... "))

	# # entries <-  c(t(s@data[attrib]))
	# # entriesRmNA <- entries[!is.na(entries)]
	# # nullAttr <- which(is.na(entries))
	# # if(length(nullAttr) > 0)
	# # 	cat(paste("Removing attribute indices: ", nullAttr, "\n"))
	# # tempRaster <- raster(filelist[1])
	# # zones <- rasterize(s, tempRaster)
	# # zones[zones %in% nullAttr] <- NA

	# progress$inc(1/n, detail = paste("Loading rasters ... "))

	# #------------------------------------------
	# # zone baby zone. NA values in the raster is removed.
	# # spiStack <- stack(filelist)
	# # spiBrick <- brick(spiStack)

	# progress$inc(1/n, detail = paste("Calculating statistics ... "))

	# # make initial df for count and then fill in rest of statistics
	# # z <- zonal(spiBrick, zones, "count", na.rm=TRUE)
	# # zdf <- as.data.frame(z)
	# # zdf$name <- entriesRmNA
	# # df <- melt(zdf, id=c('name', 'zone'),
	# # 				variable.name='rasters',
	# # 				value.name="count")

	# progress$inc(4/n, detail = paste("Calculating statistics ... "))

	# # funcs <- c('mean', 'min', 'max', 'range', 'sd')
	# # l <- lapply(funcs, function(f) {
	# # 	z <- zonal(spiBrick, zones, f, na.rm=TRUE)
	# # 	zdf <- as.data.frame(z)
	# # 	tmpdf <- melt(zdf, id='zone')
	# # 	df[f] <<- tmpdf$value #assigning to global variable df
	# # })

	# progress$inc(2/n, detail = paste("Finished!"))
	# return(df)
}


part1 <- function(xs) {
    sum(diff(xs) > 0)
}

# no need for convolution: just ignore overlapping regions
# i    i+3
# |     |
# A A A |
#   B B B
part2 <- function(xs, window_size=3) {
    count <- 0
    for (i in seq_len(length(xs) - window_size)) {
        if (xs[i + window_size] > xs[i]) {
            count <- count + 1
        }
    }
    count
}

args <- commandArgs(trailingOnly = TRUE)
xs <- scan(args[2])

sprintf("Part 1: %d", part1(xs))
sprintf("Part 2: %d", part2(xs))


cat(sapply(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " "), as.integer), function(s) {
  n <- s[1]
  s <- sort.int(s[-1])
  u <- s[n/2 + 1]
  toString(Reduce(function(a,b) {a + abs(b - u)}, s, 0))
}), sep="\n")


require(Hmisc)
n <- 500
set.seed(1)
d <- data.frame(
  race         = sample(c('Asian', 'Black/AA', 'White'), n, TRUE),
  sex          = sample(c('Female', 'Male'), n, TRUE),
  treat        = sample(c('A', 'B'), n, TRUE),
  smoking      = sample(c('Smoker', 'Non-smoker'), n, TRUE),
  hypertension = sample(c('Hypertensive', 'Non-Hypertensive'), n, TRUE),
  region       = sample(c('North America','Europe','South America',
                          'Europe', 'Asia', 'Central America'), n, TRUE))

d <- upData(d, labels=c(race='Race', sex='Sex'))

dm <- addMarginal(d, region)
s <- summaryP(race + sex + smoking + hypertension ~
              region + treat,  data=dm)

## add exclude1=FALSE to include female category
ggplot(s, groups='treat', exclude1=TRUE, abblen=12)
ggplot(s, groups='region')

## plotly graphic
source('~/R/Hmisc/R/summaryP.s');source('~/R/Hmisc/R/dotchartpl.s')
options(grType='plotly')
plot(s, groups='treat', marginVal='All', marginLabel='All Regions',
     xlim=c(0,1))

## Make sure plotly graphic works with simpler cases

s <- summaryP(race + sex + smoking + hypertension ~
                treat,  data=dm)
plot(s)
plot(s, groups='treat')
s <- summaryP(race + sex + smoking + hypertension ~ 1, data=dm)
plot(s)


#' windchill
#'
#' Calculates the NWS Windchill Temperature (WCT) to estimate the perceived temperature with wind in cold environemnt.
#'
#' @param t numeric Air temperature in degC.
#' @param wind numeric Windspeed in meters per second.
#' @return windchill index
#'
#' @references Windchill NOAA calculator \url{https://www.weather.gov/epz/wxcalc_windchill}
#'
#' @author  Istituto per la Bioeconomia Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  windchill index in degC.
#'
#' @export
#'
#'
#'
#'

windchill=function(t,wind) {
                         ct$assign("t", as.array(t))
                         ct$assign("wind", as.array(wind))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=windchill(t[i],wind[i])};")
                         res=ct$get("res")
                         return(res)
}


happy <- function(s) {
  toString(Reduce("+", lapply(strsplit(s, "")[[1]], function(a) as.integer(a)*as.integer(a))))
}

cat(sapply(readLines(tail(commandArgs(), n=1)), function(a) {
  b <- c()
  for (i in 1:127) {
    if (a == "1" || a == "0") {
      return(a)
    }
    a <- happy(a)
    if (a %in% b) {
      return("0")
    }
    b <- append(b, a)
  }
  if (a == "1") {
    "1"
  } else {
    "0"
  }
}), sep="\n")


# https://rstudio.github.io/leaflet/
#
# Interactive panning/zooming
# Compose maps using arbitrary combinations of:
# Map tiles
# Markers
# Polygons
# Lines
# Popups
# GeoJSON
# Create maps right from the R console or RStudio
# Embed maps in knitr/R Markdown documents and Shiny apps
# Easily render spatial objects from the sp or sf packages, or data frames with latitude/longitude columns
# Use map bounds and mouse events to drive Shiny logic
# Display maps in non spherical mercator projections
# Augment map features using chosen plugins from leaflet plugins repository

#==============================================================================
# Required Packages
#==============================================================================
library(leaflet)
library(maps)
library(rgdal)

#==============================================================================
# Map Basics
#==============================================================================

m <- leaflet()
m <- addTiles(m)
m <- addMarkers(m, lng = 174.768, lat = -36.852, popup = "The birthplace of R")
m

mapStates = map("state", fill = TRUE, plot = FALSE)
leaflet(data = mapStates) %>% addTiles() %>%
  addPolygons(fillColor = topo.colors(10, alpha = NULL), stroke = FALSE)

m = leaflet() %>% addTiles()
df = data.frame(
  lat = rnorm(100),
  lng = rnorm(100),
  size = runif(100, 5, 20),
  color = sample(colors(), 100)
)
m = leaflet(df) %>% addTiles()
m %>% addCircleMarkers(radius = ~size, color = ~color, fill = FALSE)
m %>% addCircleMarkers(radius = runif(100, 4, 10), color = c('red'))

#==============================================================================
# Coloring
#==============================================================================

#------------------------------------------------------------------------------
# Coloring continuous data
#------------------------------------------------------------------------------

# From http://data.okfn.org/data/datasets/geo-boundaries-world-110m
countries <- readOGR("json/countries.geojson", "OGRGeoJSON")
map <- leaflet(countries)

par(mar = c(5,5,0,0), cex = 0.8)
hist(countries$gdp_md_est, breaks = 20, main = "")

# Create a continuous palette function
pal <- colorNumeric(
  palette = "Blues",
  domain = countries$gdp_md_est)

# Apply the function to provide RGB colors to addPolygons
map %>%
  addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
    color = ~pal(gdp_md_est))

binpal <- colorBin("Blues", countries$gdp_md_est, 6, pretty = FALSE)

map %>%
  addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
    color = ~binpal(gdp_md_est))

qpal <- colorQuantile("Blues", countries$gdp_md_est, n = 7)
map %>%
  addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
    color = ~qpal(gdp_md_est))

#------------------------------------------------------------------------------
# Coloring categorical data
#------------------------------------------------------------------------------

# Make up some random levels. (TODO: Better example)
countries$category <- factor(sample.int(5L, nrow(countries), TRUE))

factpal <- colorFactor(topo.colors(5), countries$category)

leaflet(countries) %>%
  addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
    color = ~factpal(category))

#==============================================================================
# Legends
#==============================================================================

# From http://data.okfn.org/data/datasets/geo-boundaries-world-110m
countries <- readOGR("json/countries.geojson", "OGRGeoJSON")
## OGR data source with driver: GeoJSON
## Source: "json/countries.geojson", layer: "OGRGeoJSON"
## with 177 features
## It has 2 fields
map <- leaflet(countries) %>% addTiles()
pal <- colorNumeric(
  palette = "YlGnBu",
  domain = countries$gdp_md_est
)
map %>%
  addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
    color = ~pal(gdp_md_est)
  ) %>%
  addLegend("bottomright", pal = pal, values = ~gdp_md_est,
    title = "Est. GDP (2010)",
    labFormat = labelFormat(prefix = "$"),
    opacity = 1
  )

qpal <- colorQuantile("RdYlBu", countries$gdp_md_est, n = 5)
map %>%
  addPolygons(stroke = FALSE, smoothFactor = 0.2, fillOpacity = 1,
    color = ~qpal(gdp_md_est)
  ) %>%
  addLegend(pal = qpal, values = ~gdp_md_est, opacity = 1)


#Series temporais e analises preditivas - Fernando Amaral
library(ggplot2)

#graficos do R core
plot(sunspots)
hist(sunspots)
boxplot(sunspots)

#ggplot
autoplot(AirPassengers)

#explorando parte da serie
sun2 = window(sunspots,1749,c(1763,12))
plot(sun2)
hist(sun2)
boxplot(sun2)

#agregar valores
plot(aggregate(AirPassengers, FUN=mean))

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/3.2.Graficos basicos plot, hist. Etc.r


\name{Newman}
\alias{Newman}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Corrected Newman's method for estimating the preferential attachment function
}
\description{
This function implements a correction proposed in [1] of the original Newman's method in [2] to estimate the preferential attachment function.
}
\usage{
  Newman(net_object                              ,
         net_stat    = get_statistics(net_object),
         start       = 1                         ,
         interpolate = FALSE)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
 \item{net_object}{
    an object of class \code{PAFit_net} that contains the network.
}
  \item{net_stat}{
    An object of class \code{PAFit_data} which contains summerized statistics needed in estimation. This object is created by the function \code{\link{get_statistics}}. Default value is \code{ get_statistics(net_object)}.
  }
  \item{start}{Positive integer. The starting time from which the method is applied. Default value is \eqn{1}.}
  \item{interpolate}{
    Logical. If \code{TRUE} then all the gaps in the estimated PA function are interpolated by linear interpolating in logarithm scale. Default value is \code{FALSE}.
  }
}
\value{
  Outputs an \code{PA_result} object which contains the estimated attachment function. In particular, it contains the following field:
   \itemize{
    \item \code{k} and \code{A}: a degree vector and the estimated PA function.

    \item \code{center_k} and \code{theta}: when we perform binning, these are the centers of the bins and the estimated PA values for those bins.
    \item \code{g}: the number of bins used.
    \item \code{alpha} and \code{ci}: \code{alpha} is the estimated attachment exponenet \eqn{\alpha} (when assume \eqn{A_k = k^\alpha}), while \code{ci} is the mean plus/minus two-standard-deviation interval.
    \item \code{loglinear_fit}: this is the fitting result when we estimate \eqn{\alpha}.
}
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. Pham, T., Sheridan, P. & Shimodaira, H. (2015). PAFit: A Statistical Method for Measuring Preferential Attachment in Temporal Complex Networks. PLoS ONE 10(9): e0137796. doi:10.1371/journal.pone.0137796 (\url{http://dx.doi.org/10.1371/journal.pone.0137796}).

  2. Newman, M.. Clustering and preferential attachment in growing networks. Physical Review E. 2001;64(2):025102 (\url{https://journals.aps.org/pre/abstract/10.1103/PhysRevE.64.025102}).
}
\seealso{

See \code{\link{get_statistics}} for how to create summerized statistics needed in this function.

See \code{\link{Jeong}}, \code{\link{only_A_estimate}} for other methods to estimate the attachment function in isolation.
}
\examples{
  library("PAFit")
  net        <- generate_net(N = 1000 , m = 1 , mode = 1 , alpha = 1 , s = 0)
  net_stats  <- get_statistics(net)
  result     <- Newman(net, net_stats)
  summary(result)
  # true function
  true_A     <- result$center_k
  #plot the estimated attachment function
  plot(result , net_stats)
  lines(result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")
}

\concept{preferential attachment}
\concept{attachment function}


S2.mainstem = function( pt, s.inriver,s2.fac=1){
	s2 = (pt*0.98 + (1.0-pt)*s.inriver)
	s2 = s2.fac*s2 # potential hydro improvements
	s2
}

s3.fxn<-function(pt,sarI,sarT,b3=b3,b4=b4,So=So){
  a1=b3
  a2=(1-b3)*b4*So
  a3=(1-b3)*(1-b4)*So*So
  SAR=pt*sarT + (1-pt)*sarI
  s3=SAR/(a1+a2+a3)
  x<-list(s3=s3,sarI=sarI,sarT=sarT,sar=SAR)
  return(x)
}


# Simulation of the mixed distribution, Figure S2

library(viridis)

COL1 = viridis(10, alpha=0.7)
COL2 = viridis(10, alpha=0.7)

x <- seq(5,15,0.01)
subs1 <-  seq(9.5,10.5, length.out=5) # rnorm(5,10,.25)
subs2 <-  seq(8.66359,11.33641, length.out=5)

msubs1 <- mean(subs1)
msubs2 <- mean(subs2)
vsubs1 <- var(subs1)
vsubs2 <- var(subs2)

dsubs1 <- lapply(subs1, function(z) dnorm(x, z, .2 ) )
dsubs1_2 <- lapply(subs1, function(z) dnorm(x, z, 1 ) )
dsubs2 <- lapply(subs2, function(z) dnorm(x, z, .2 ) )

ind1 <- dnorm(x, msubs1, sqrt(vsubs1+.2^2) )
ind1_2 <- dnorm(x, msubs1, sqrt(vsubs1+1^2) )
ind2 <- dnorm(x, msubs2, sqrt(vsubs2+.2^2) )

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")

pdf("FigureS2.pdf", paper="a4r", width=9, height=6)

par(mfrow=c(2,3))
plot(x, dsubs1[[1]], type="l", col=COL2[3], lwd=2, las=1, xlab="log2 expression (gene ensemble)", ylab="density", las=1)
for(i in 2:length(subs1)) { lines(x, dsubs1[[i]], col=COL2[i+2], lwd=2) }
segments(x0 = subs1, y0=1/(.2*sqrt(2*pi)), x1=subs1, y1= 1/(.2*sqrt(2*pi)) + .07,  col=COL2[3:10], lwd=1)
plot(x, dsubs1_2[[1]], type="l", col=COL2[3], lwd=2, las=1, xlab="log2 expression (gene ensemble)", ylab="density", las=1)
for(i in 2:length(subs1)) { lines(x, dsubs1_2[[i]], col=COL2[i+2], lwd=2) }
segments(x0 = subs1, y0=1/(1*sqrt(2*pi)), x1=subs1, y1=1/(1*sqrt(2*pi))+.03,  col=COL2[3:10], lwd=1)
plot(x, dsubs2[[1]], type="l", col=COL2[3], lwd=2, las=1, xlab="log2 expression (gene ensemble)", ylab="density", las=1)
for(i in 2:length(subs2)) { lines(x, dsubs2[[i]], col=COL2[i+2], lwd=2) }
segments(x0 = subs2, y0=1/(.2*sqrt(2*pi)), x1=subs2, y1= 1/(.2*sqrt(2*pi))+.07,  col=COL2[3:10], lwd=1)

plot(x, ind1, col=COL2[1], lwd=2, type="l", ylim=c(0,0.9), xlab="log2 expression (compound)", ylab="density", las=1)
plot(x, ind1_2, col=COL2[1], lwd=2, type="l", ylim=c(0,0.9), xlab="log2 expression", ylab="density", las=1)
plot(x, ind2, col=COL2[1], lwd=2, type="l", ylim=c(0,0.9), xlab="log2 expression", ylab="density", las=1)

dev.off()


E04NKJ Example Program Results

	Variable     Istate     Value     Lagr Mult

	...X1...	0	0.00000	        2361
	...X2...	3	349.399	  -3.657e-12
	...X3...	2	648.853	  -5.924e-12
	...X4...	2	172.847	   1.949e-12
	...X5...	3	407.521	       0.000
	...X6...	3	271.356	  -3.280e-12
	...X7...	3	150.023	  -1.413e-12

	Constrnt     Istate     Value		  Lagr Mult

	..ROW1..	0	2000.00		  -1.290e+04
	..ROW2..	3	49.2316		       0.000
	..ROW3..	1	100.000		       -2325
	..ROW4..	3	32.0719		       0.000
	..ROW5..	3	14.5572		       0.000
	..ROW6..	0	1500.00		   1.445e+04
	..ROW7..	0	250.000		   1.458e+04
	..COST..	3	-2.98869e+06	      -1.000

Final objetive value =        -1847785


# package h2o does work! need to see if we can structure network differently to make
# it even better!

library(h2o);

set.seed(12345);

rssqe<-function(predictions,te_y) { (sum((as.matrix(predictions)-te_y)^2)/length(te_y))^0.5;}

h2o.init();
tr_set<-tr_dat[1:(nr-te_sz),1:nc]; # after running setup.r
sampl_set<-tr_set;

tr_set_std<-tr_set;
te_set_std<-te_set;
oos_set_std<-oos_set;

dset.hex<-as.h2o(tr_set);
tset.hex<-as.h2o(te_set);
oos.hex<-as.h2o(oos_set);

for (i in 117:130)
{ tr_set_std[,i]<-(tr_set[,i]-mean(tr_set[,i]))/sd(tr_set[,i]);
  te_set_std[,i]<-(te_set[,i]-mean(te_set[,i]))/sd(te_set[,i]);
  oos_set_std[,i]<-(oos_set[,i]-mean(oos_set[,i]))/sd(oos_set[,i]);
}

dset_std.hex<-as.h2o(tr_set_std);
tset_std.hex<-as.h2o(te_set_std);
oos_std.hex<-as.h2o(oos_set_std);

writepred<-function(pred,mname)
 { write.csv(pred,file=paste(mname,".csv",collapse=NULL),row.names=FALSE);}

ann_pred<-function(model,modelstr)
{ predictions<-h2o.predict(model,tset.hex);
  x<-cbind(as.matrix(predictions),te_y);
  str<-sprintf("ann model %s rms_error: %5.3f",modelstr,rssqe(predictions,te_y));
  print(str);
  predictions<-h2o.predict(model,oos.hex);
  predictions<-as.matrix(predictions);
  writepred(predictions,modelstr);
}

ann1<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,seed=12345);
std_ann1<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,seed=12345);
ann2<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=c(60,40),stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
std_ann2<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,hidden=c(60,40),stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann3<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=c(60,40,10),stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
std_ann3<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,hidden=c(60,40,10),stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann4<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=c(60,40,20,10),stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
std_ann4<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,hidden=c(60,40,20,10),stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann5<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=c(60,40,20,10,3,10),activation="Tanh",stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
std_ann5<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,hidden=c(60,40,20,10,3,10),activation="Tanh",stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann6<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=c(60,40,20,10,3,10,20),activation="Tanh",stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
std_ann6<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,hidden=c(60,40,20,10,3,10,20),activation="Tanh",stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann7<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=c(60,40,20,10,3,10,20),activation="TanhWithDropout",input_dropout_ratio=0.2,hidden_dropout_ratios=c(0.2,0.2,0.2,0.2,0.2,0.2,0.2),stopping_metric="MSE",nfolds=10,seed=12345,epochs=10,standardize=TRUE);
std_ann7<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,hidden=c(60,40,20,10,3,10,20),activation="TanhWithDropout",input_dropout_ratio=0.2,hidden_dropout_ratios=c(0.2,0.2,0.2,0.2,0.2,0.2,0.2),stopping_metric="MSE",nfolds=10,seed=12345,epochs=10,standardize=TRUE);
ann8<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=c(60,40,20,10,3,10),activation="Tanh",stopping_metric="AUTO",nfolds=10,seed=12345,standardize=TRUE);
std_ann8<-h2o.deeplearning(x=1:130,y=131,training_frame=dset_std.hex,hidden=c(60,40,20,10,3,10),activation="Tanh",stopping_metric="AUTO",nfolds=10,seed=12345,standardize=TRUE);

ann_pred(ann1,"ann1");
ann_pred(std_ann1,"std_ann1");

ann_pred(ann2,"ann2");
ann_pred(std_ann2,"std_ann2");

ann_pred(ann3,"ann3");
ann_pred(std_ann3,"std_ann3");

ann_pred(ann4,"ann4");
ann_pred(std_ann4,"std_ann4");

ann_pred(ann5,"ann5");
ann_pred(std_ann5,"std_ann5");

ann_pred(ann6,"ann6");
ann_pred(std_ann6,"std_ann6");

ann_pred(ann7,"ann7");
ann_pred(std_ann7,"std_ann7");

ann_pred(ann8,"ann8");
ann_pred(std_ann8,"std_ann7");

ann_R1<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=143,stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann_pred(ann_R1,"ann_R1");

ann_R2<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=88,stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann_pred(ann_R2,"ann_R2");

ann_R3<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=66,stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann_pred(ann_R3,"ann_R3");

ann_R4<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=50,stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann_pred(ann_R4,"ann_R4");

"ann model ann_R1 rms_error: 1930.488"
"ann model ann_R2 rms_error: 1954.363"
"ann model ann_R3 rms_error: 1921.604"
"ann model ann_R4 rms_error: 1946.394"

ann_R5<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=66,activation="TanhWithDropout",input_dropout_ratio=0.2,hidden_dropout_ratios=0.2,stopping_metric="MSE",nfolds=10,seed=12345,epochs=10,standardize=TRUE);
ann_pred(ann_R5,"ann_R5");

"ann model ann_R5 rms_error: 2028.656"

ann_R6<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=66,input_dropout_ratio=0.2,stopping_metric="AUTO",nfolds=10,seed=12345,epochs=10,standardize=TRUE);
ann_pred(ann_R6,"ann_R6");
ann_R7<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=66,input_dropout_ratio=0.4,stopping_metric="MSE",nfolds=10,seed=12345,epochs=10,standardize=TRUE);
ann_pred(ann_R7,"ann_R7");

ann_R8<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=66,stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann_pred(ann_R8,"ann_R8");

ann_R9<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=30,stopping_metric="MSE",nfolds=10,seed=12345,standardize=TRUE);
ann_pred(ann_R9,"ann_R9");

ann_RA<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=30,stopping_metric="AUTO",nfolds=10,seed=12345,standardize=TRUE);
ann_pred(ann_RA,"ann_RA");

build_ann<-function(nsampl=75000,nhid=66,smetric="AUTO",nfld=10,modlstr)
{ #tr_set2<-tr_dat[sample(nrow(sampl_set),nsampl,replace=TRUE),];
  tr_set2<-tr_dat[sample(nrow(sampl_set),nsampl),];
  dset.hex<-as.h2o(tr_set2);
  ann_Rx<-h2o.deeplearning(x=1:130,y=131,training_frame=dset.hex,hidden=nhid,stopping_metric=smetric,nfolds=nfld,seed=12345,standardize=TRUE);
  ann_pred(ann_Rx,modlstr);
}

x<-sample(40:80,20);
for (i in x)
 { modlstr<-paste0("ann_R3_",i);
   ssz<-sample(90000:110000,1);
   print(sprintf("modlstr: %s, nhid: %5.3f sampl: %5.3f",modlstr,i,ssz));
   build_ann(nsampl=ssz,nhid=i,smetric="AUTO",nfld=10,modlstr);
 }


# /* !/usr/bin/Rscript */

#' ## Model fitting
#' Given problem is of a classification nature, various ML algos apply.
#' Start with a basic CART model to view the major splits of a decision
#' tree which will hint at important variables, then use Caret to train
#' and iterate upon a number of different models. Caret's unified
#' interface is especially a time-saver in this regard.
#'
#' One important note: The SEED is set before every model so that it is
#' consistent when models are run out of order during development of the
#' analysis.

# /*
writeLines("\n-------------");
writeLines("Modelling: Glm logistic, CART, Boosting and Ensembles")
# */

#' ### Define `caret` training parameters
#' Mitigate overfitting (high variance) by resampling the training
#' samples to cross-validate fitted model's performance on future data.
#' This is applied as a K-fold CV where K=10 repeated 3 times.
#'
#' The comparison performance metric of choice is ROC (AUC). To retain
#' the necessary output in the models the `twoClassSummary()` fn (from
#' `caret`) is specified as the summary function in order to to compute
#' the sensitivity, specificity and AUC.
#'
#' The training control function is also configured to compute the
#' class probabilities for held-out samples during the resample for
#' the performance comparison.
fitControl <- trainControl(
  method = "repeatedcv",
  number = 10,
  repeats = 3,
  summaryFunction = twoClassSummary,
  classProbs = TRUE
)

#' ### Basic CART model
#' Fit a classification tree to view important splits.
set.seed(SEED)

treeFit = tree(Fate ~ .,
  data=tr
)
plot(treeFit)
text(treeFit)
summary(treeFit)

#' ### Logistic regression models
#' To start the modelling proper, iterate through a number of logistic
#' regression model trained with caret (as Generalised Linear Models -
#' GLM).
#'
#' Initially all features are added, then removed or combined as
#' interactive covariates, with interesting interactions captured in
#' binary features via class compression.
#'
#' The impact in changes to the input formula were measured by each
#' model's deviance (a measure of lack of fit between model and data).
#' For this metric larger is worse. This said, lower deviance is also
#' indicative to an overfitted model (high bias).
#'
#' It was noted that this method raised "rank-deficient" errors, likely
#' due to the low number of observations in the dataset. A GLM with all
#' features in the training set scored 0.74163 on Kaggle.
#'
#' #### GLM all features
set.seed(SEED)

glmFit1 <- train(Fate ~ .,
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)

#' #### Basic GLM
#' Try a model with the selected variables in inferred order of
#' importance.
set.seed(SEED)

glmFit2 <- train(Fate ~ Sex + Class + Age + FamilyCount + Embarked +
  FareLog + BoatPriority,
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)

# /*
# Model: Logistic Regression with interaction variables
set.seed(SEED)

glmFit3 <- train(Fate ~ Sex + Class + Title + Sex*Class +
  Sex*Class*Title,
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)
# */

#' #### GLM with interaction variables
#' Used to discern key interactions for potential class compression.
#' In the following model the interaction between
#' *ClassLower:PcSurvived* was deemed significant.
#' `tr[tr$PcSurvived == 1, c("Fate", "Class")]` reveals that most
#' people travelling in lower class with a Parent/child who
#' survived, also survived (in the training set).
set.seed(SEED)

glmFit4 <- train(Fate ~ Class + Sex + Title + Sex*Embarked +
  Class*PcSurvived*SbSurvived,
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)

# /*
# Model: Logistic Regression with class compression
set.seed(SEED)

glmFit5 <- train(Fate ~ Sex + Class + Title +
  I(Title=="Mr"&Class=="Lower"),
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)

# Model: Logistic Regression with class compression
set.seed(SEED)

glmFit6 <- train(Fate ~ Sex + Class + Title +
  I(Title=="Mr"&Class=="Lower") +
  I(Class=="Middle"&Title=="Master") +
  I(Sex=="female"&Embarked=="S") +
  I(Class=="Lower"&PcSurvived==1),
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)

# Model: Logistic Regression adding PcSurvived and SbSurvived
set.seed(SEED)

glmFit7 <- train(Fate ~ Sex + Class + Title + PcSurvived + SbSurvived +
  I(Title=="Mr"&Class=="Lower") +
  I(Class=="Middle"&Title=="Master") +
  I(Sex=="female"&Embarked=="S") +
  I(Class=="Lower"&PcSurvived==1),
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)
# */

#' #### GLM with class compression
#' In this model a number of important features have been added as
#' covariates alongside some engineered features capturing various
#' important interactions identified previously. This submission
#' scored 0.79904
set.seed(SEED)

glmFit8 <- train(Fate ~ Sex + Class + Title + PcSurvived + SbSurvived +
  FareLog + FamilyCount +
  I(Title=="Mr"&Class=="Lower") +
  I(Class=="Middle"&Title=="Master") +
  I(Sex=="female"&Embarked=="S") +
  I(Class=="Lower"&PcSurvived==1),
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)

# /*
# Model: Logistic Regression with selected variables
#   - Submission scored 0.79904
set.seed(SEED)

glmFit9 <- train(Fate ~ Class + Sex + Title + Age + Embarked + FamilyCount + PcSurvived + SbSurvived + Side,
  data = tr,
  method = "glm",
  metric = "ROC",
  trControl = fitControl
)
# */

#' ### Tree Models
#' After training increasingly complex GLM models next comes a very
#' popular type of model for classification problems - tree-based
#' models. Although the first CART model didn't yield any great
#' insight, other tree-based methods are far more sophisticated in
#' nature, able to run thousands of permutations and combine them to
#' create a highly optimised and complex models.
#'
#' To keep it fair between different model types (not too mention
#' simple!) the same formula was used to fit each model:
#' `Fate ~ Class + Sex + Title + Age + Embarked + FamilyCount + PcSurvived + SbSurvived + FareLog'`
#'
#' The features listed as co-variates were derived from the best of
#' the GLM models. Those excluded were deemed superfluous due to
#' their lack of effect on the deviance change in the models they
#' were included.
#'
#' Finally, in all cases the same training control function used to
#' train the GLM logistic regression models was re-purposed.
#'
#' ---
#' NOTE: These models can take a while to train, hang in there...
#'
#' #### Ada boosted tree model
#' Boosting constitutes an ensemble model as an iterative algo that
#' combines simple classification rules with 'mediocre' performance
#' in terms of misclassification error rate to produce highly
#' accurate classification rule.
#'
#' Ada is statistical boosting based on additive logistic regression.
#' Here classification trees are generated via rpart and the caret
#' package constitute the base classifiers.
#'
#' For this model a tuning grid configured for varying iterations
#' (25 & 50), maxdepth (4 & 6), and nu shrinkage parameter (0.1 & 1)
#' was created. All permutations were exercised.
#'
#' One can also visualise feature variance with `varplot()` from the
#' ada package. The model reported an accuracy of 0.84, and scored
#' 0.80383 on Kaggle's leaderboard.
set.seed(SEED)

adaGrid <- expand.grid(
  .iter = c(25, 50),
  .maxdepth = c(4, 6),
  .nu = c(0.1, 1)
)

adaFit <- train(Fate ~ Class + Sex + Title + Age + Embarked +
  FamilyCount + PcSurvived + SbSurvived + FareLog,
  data = tr,
  method = "ada",
  metric = "ROC",
  tuneGrid = adaGrid,
  trControl = fitControl
)

varplot(adaFit$finalModel)
print(adaFit)

#' #### Random forest
#' The (in)famous rf model. This is an ensemble method similar to
#' bagged trees (performed with boostrap aggregation), whereby
#' observations are resampled and predictions are recalculated, with
#' majority vote dictating the best model.
#'
#' Random forests also bootstrap the variables at each split in the
#' tree and use the Out-of-Bag Error rate to evaluate strength of
#' model, correlation between models, and variable importance.
#'
#' For this model a tuning grid with mtry set to 3 (as per Strobl et al
#' advice that this value should equate to the sq.root of number of
#' covariates - 9) was created. Variable importance was determined
#' using the `importance()` fn from the random forest package. They
#' are ranked by the Gini purity metric. This model scored 0.81340
set.seed(SEED)

rfGrid <- expand.grid(.mtry = c(3))

rfFit <- train(Fate ~ Class + Sex + Title + Age + Embarked + FamilyCount + PcSurvived + SbSurvived + FareLog,
  data = tr,
  method = "rf",
  metric = "ROC",
  tuneGrid = rfGrid,
  trControl = fitControl
)

importance(rfFit$finalModel)
varImpPlot(rfFit$finalModel)
print(rfFit)

#' #### Conditional forest
#' An alternative to random forests which handle factor co-variates
#' with many levels better than their better known brethren. A tuning
#' grid with the same tuning grid as the random forest was created,
#' and the same variables used to discern important variables.
#'
#' Ultimately it scored 0.80861, lower than the random forest model.
set.seed(SEED)

cfGrid <- expand.grid(.mtry = c(3))

cfFit <- train(Fate ~ Class + Sex + Title + Age + Embarked + FamilyCount + PcSurvived + SbSurvived + FareLog,
  data = tr,
  method = "cforest",
  metric = "ROC",
  tuneGrid = cfGrid,
  trControl = fitControl
)

print(cfFit)

#' ### Support vector machine
#'
#' SVM build a model that assigns observations into one category or the other
#' based on a kernel method (comparator function). It is an example of a
#' non-probabilistic binary linear classifier.
#'
#' For this model it was specified that the data should be pre-processed by
#' centering and scaling it, as SVM is sensitive, especially when using a
#' Gaussian kernel.
#'
#' Furthermore, the `tuneLength` which determines the number of levels for
#' each tuning parameters generated by train() was set to 9. This produces a
#' tuning grid of c(0.25, 0.5, 1, 2, 4, 8, 16, 32, 64), which corresponds to
#' the value passed in for the `C` parameter of the kernel method. In turn,
#' this controls the "penalty" for misclassified training examples.
#'
#' In this case the Sigma value determined by Caret. The submission scored a
#' lowly 0.78469.
set.seed(SEED)

svmFit <- train(Fate ~ Class + Sex + Title + Age + Embarked + FamilyCount + PcSurvived + SbSurvived + Side + FareLog + BoatPriority,
  data = tr,
  method = "svmRadial",
  metric = "ROC",
  tuneLength = 9,
  preProcess = c("center", "scale"),
  trControl = fitControl
)

print(svmFit)

#' Meta-ensemble model
#' This type of model combines models of different types (or the same even)
#' in the same vein as ensemble models such as random forest, with majority
#' vote scoring (hence the number of models should be odd).
#'
#' Although this could be done crudely by simply running a prediction for
#' the desired records and comparing the results to generate the mode for
#' each, using `caretEnsemble` means a uses a glm is used instead to create
#' a simple linear blend of models with the same re-sampling parameters.
#' Ideally the methods used produce models with low correlation in an effort
#' to cover more of the variance within a given dataset.
#'
#' To use `caretEnsemble` another training control function needs to be
#' created, which closely mirrors that used to construct the independent
#' models above, but which also specifies the resample index callback. This
#' ensures they are the same across all models.
#'
#' Equally, the same tuning grids are used to re-train ada, rf, and cf
#' models, as well as the same formula. This ensemble scored 0.80383, which
#' just goes to show more complex models don't always beat simple ones.
fitEnsembleControl <- trainControl(
  method          = "repeatedcv",
  number          = 10,
  repeats         = 3,
  savePredictions = TRUE,
  classProbs      = TRUE,
  index           = createResample(tr$Fate, 10),
  summaryFunction = twoClassSummary
)

set.seed(SEED)
ensembleList <- caretList(Fate ~ Class + Sex + Title + Age + Embarked + FamilyCount + PcSurvived + SbSurvived + FareLog,
  data       = tr,
  metric     = "ROC",
  trControl  = fitEnsembleControl,
  methodList=c("glm", "svmRadial"),
  tuneList   = list(
    ada = caretModelSpec(method="ada", tuneGrid=adaGrid),
    rf  = caretModelSpec(method="rf", tuneGrid=rfGrid),
    cf  = caretModelSpec(method="cforest", tuneGrid=cfGrid)
  )
)

ensembleFit  <- caretEnsemble(ensembleList)

# /*
writeLines("\n-------------")
writeLines("Modelling: DONE")
# */


#' Create a summary table with results of a glm model
#'
#' @param data a data frame
#' @param formula specify dependent and independent variables for glm formula
#'
#' @return summaries of the results of various model fitting functions.
#' @export
#'
#' @examples summary_finalmodel(data = gtsummary::trial, (substitute(response ~ age + factor(death))))
summary_finalmodel <- function(data, formula) {
  final.model <- stats::glm(formula, data, family = stats::binomial(logit))
  model_summary <- summary(final.model)
  return(model_summary)
}


#' Function that propagates measurement uncertainty through model results
#'
#' Function to propagate combined errors on \code{x} (= \code{Dsam}) and
#' \code{y} (= \code{Osam}) on the modeled X (= \code{D}) and Y
#' (= \code{d18Oc}) values by means of projection of uncertainties
#' through the modeled \code{X-Y} relationship
#'
#' Note: projection leads to large uncertainties on shallow parts of the
#' \code{X–Y} curve
#' @param x Vector of \code{x} values of input data
#' @param x_err Vector of uncertainties on \code{x} values
#' @param y Vector of \code{y} values of input data
#' @param y_err Vector of uncertainties on \code{y} values
#' @param X Vector of modeled \code{X} values on which the uncertainty is
#' to be projected
#' @param Y Matrix of modeled x and \code{Y} values
#' @param MC Number of Monte Carlo simulations to apply for error propagation
#' Default = 1000
#' @return A vector listing the standard deviations of propagated errors
#' propagated on all \code{X} values.
#' @examples
#' # Create dummy data for input
#' x <-  seq(1, 40, 1)
#' x_err <- rep(0.1, 40)
#' y <- sin((2 * pi * (seq(1, 40, 1) - 8 + 30 / 4)) / 30)
#' y_err <- rep(0.1, 40)
#' X <- seq(1.5, 39.5, 1)
#' Y <- cbind(seq(1, 39, 1), 0.9 * sin((2 * pi * (seq(1, 39, 1) - 9 +
#'     25 / 4)) / 25))
#' # Run function
#' result <- mc_err_form(x, x_err, y, y_err, X, Y, 1000)
#' @export
mc_err_form <- function(x,
    x_err,
    y,
    y_err,
    X,
    Y,
    MC = 1000){

    xmat <- matrix(rnorm(MC * length(x)), nrow = length(x)) * x_err + matrix(rep(x, MC), nrow = length(x)) # Create matrix of simulated X values
    Xpos <- apply(abs(outer(xmat, X, FUN = "-")), c(1,2), which.min) # find closest position in X vector (day) for each simulated X value
    Xpos_stat <- cbind(rowMeans(Xpos), apply(Xpos, 1, sd)) # Find mean and standard deviation of positions in X vector (day) for each sample

    ymat <- matrix(rnorm(MC * length(y)), nrow = length(y)) * y_err + matrix(rep(Y[Xpos_stat[, 1], 2], MC), nrow = length(y)) # Create matrix of Monte Carlo simulated Y values projected on the X-Y curve
    Xpos_mat <- outer(round(Xpos_stat[, 1]), seq(-20, 20, 1), "+")  %% length(D) + 1 # Create matrix of D positions around the mean position for each sample to match with simulated Y values. Window is +/- 20 positions
    Xpos_matO <- matrix(Y[Xpos_mat, 2], nrow = length(x)) # Find Y values for each position in Xpos_mat
    Xpos_matO2 <- apply(outer(Xpos_matO, ymat, FUN = "-"), c(2,4), diag) # Match and subtract each simulated Y value with the local environment of Y values in the X-Y curve
    Ypos <- apply(abs(Xpos_matO2), c(1, 3), which.min) + Xpos_stat[, 1] # Find the position of the closest Y value in the Y window (Xpos_matO) for each Y simulation
    Ypos_stat <- cbind(rowMeans(Ypos), apply(Ypos, 1, sd)) # Find mean and standard deviation of positions in X vector (day) for each sample
    Ypos_stat[which(Ypos_stat[, 2] == 0), 2] <- sd(seq(-20, 20, 1)) # If SD of Y falls outside the window of +/- 20 positions SD is assumed to be equal to that of the uniform distribution

    pos_err_comb <- sqrt(Ypos_stat[, 2] ^ 2 + Xpos_stat[, 2] ^ 2) # Find combined error on position (day)
    Xpos_minmax <- cbind(Xpos_stat[, 1] - pos_err_comb, Xpos_stat[, 1] + pos_err_comb) %% length(D) # Find min and max position values
    Xminmax <- matrix(approx(x = X, xout = Xpos_minmax, rule = 2)$y, ncol = 2) # Find associated D values (linear interpolation)
    x_err_comb <- 0.5 * ((Xminmax[,2] - Xminmax[,1]) %% X[length(X)]) # Find combined SD in D domain
    return(x_err_comb)
}