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

library('sense')

# [ggplot2](http://ggplot2.org/) is a great way to make pretty graphs.

library('ggplot2')

# Load Data
# ---------
#
# Download and load Boston housing price data.

system('wget -nc https://raw.github.com/vincentarelbundock/Rdatasets/master/csv/MASS/Boston.csv')
boston <- read.csv('Boston.csv')
head(boston)
summary(boston$price)

# Explore
# -------

qplot(boston$medv, main="Boston Median Housing Price")
qplot(boston$crim, boston$medv,
  main="Median Housing Prices vs. Crime",
  xlab="Crime", ylab="Median Housing Price (thousands)")
qplot(boston$age, boston$medv,
    main="Median Housing Prices vs. Building Age",
    xlab="Building Age", ylab="Median Housing Price (thousands)") +
  geom_smooth(method = "loess")

# Model
# -----
#
# Regress median housing value on crime and building age.

fit <- lm(medv ~ crim + age, data=boston)
summary(fit)

# Worker Consoles
# -----------------
#
# Worker consoles run on remote containers and can be networked together
# to run distributed jobs.  Using workers, you can easily scale your analysis
# 100s of cores.  All workers share the same project filesystem, have
# access to a virtual private network, and multiplex their output into
# a single master console for easy debugging.
#
# The following command launches two workers and runs some code remotely:

#workers <- launch.workers(n=2, size=1, code="print('Hello from Sense Worker')")

# You can stop workers with `stop.workers()`.  All workers will automatically
# be cleaned up when you stop the console as well (top-right console drop down).
#
# In most cases you'll want to use a higher-level library to distribute
# your analysis.  See the [documentation](http://help.sense.io) to learn more.
#
# There's lots more to Sense.  If you have any problems, email support@sense.io.


d <- read.table('~/../git/StoreCheckout/StoreCheckout/logs/Analytics.log', sep = ',', header = F)
summary(d)

#get enabled
enabled <- d[d$V3 == " Discount Applied", ]
summary(enabled)

#get disabled and a sample of same length as enabled
disabled <- d[d$V3 == " No Discount", ]
rndDisabled <- disabled[sample(nrow(disabled), length(enabled$V3)), ]
summary(rndDisabled)

#statistical test
wilcox.test(enabled$V4, rndDisabled$V4)

#median difference
median(enabled$V4)/median(rndDisabled$V4)


library(ggplot2)
library(VIM)
library(mice)
library(vcd)
require(car)
library(tabplot)
library(PerformanceAnalytics)
library(MASS)
library(glmnet)

# ===============================================================================================
setwd("../../data")
movies = read.csv("movie_metadata.csv")

# ===============================================================================================
# EDA
summary(movies)
sapply(movies, sd)
hist(movies$num_critic_for_reviews)

# ===============================================================================================
# investigate missingness

length(complete.cases(movies))
aggr(movies, numbers=T, prop=F, sortVars=T, labels=names(movies)) # change 'prop' to T to see ratio

## Matrix plot. Red for missing values, Darker values are high values.
matrixplot(movies, interactive=T, sortby="imdb_score")

## Margin plot. Red dots have at least one missing. No observation with two missing values here.
marginplot(movies[,c("gross", "imdb_score")])

md.pattern(movies) # hard to interpret due to too many variables

# findings
# 'gross' has the most amount of missingness.

# ===============================================================================================
scattmatrixMiss(movies[, 1:5], interactive = F)

hist(movies$imdb_score, breaks=30)
plot(density(movies$imdb_score))
abline(v=mean(movies$imdb_score), lty=2)

hist(movies$title_year)

boxplot(imdb_score ~ title_year, data=movies, col="bisque", las=2)
title("IMDB score vs movie year")

# imdb_score vs country
reordered_country = with(movies, reorder(country, -imdb_score, median))
boxplot(imdb_score ~ reordered_country, data=movies, lwd=0.5, col="bisque", las=2)
#stripchart(imdb_score ~ reordered_country, data=movies, vertical=T, add=T, pch=1, col='grey')
title("IMDB score vs country")

reordered_language = with(movies, reorder(language, -imdb_score, median))
boxplot(imdb_score ~ reordered_language, data=movies, lwd=0.5, col="bisque", las=2)
#stripchart(imdb_score ~ reordered_language, data=movies, vertical=T, add=T, pch=1, col='grey')
title("IMDB score vs language")

# not informative
#boxplot(imdb_score ~ aspect_ratio, data=movies, lwd=0.5, col="bisque", las=2)
#stripchart(imdb_score ~ aspect_ratio, data=movies, vertical=T, add=T, pch=1, col='grey')
#title("IMDB score vs aspect ratio")

boxplot(imdb_score ~ color, data=movies, lwd=0.5, col="bisque", las=2)
stripchart(imdb_score ~ color, data=movies, vertical=T, add=T, pch=1, col='grey')
title("IMDB score vs color")

reordered_content_rating = with(movies, reorder(content_rating, -imdb_score, median))
boxplot(imdb_score ~ reordered_content_rating, data=movies, lwd=0.5, col="bisque", las=2)
stripchart(imdb_score ~ reordered_content_rating, data=movies, vertical=T, add=T, pch=1, col='grey')
title("IMDB score vs content rating")

# ===============================================================================================
# top actors
library(googleVis)
library(dplyr)
m1 = movies %>% select(actor_1_name, actor_1_facebook_likes) %>%
    group_by(actor_1_name) %>% summarize(appear.count=n())

m2 = left_join(movies, m1, by="actor_1_name")
m3 = m2 %>% select(actor_1_name, actor_1_facebook_likes, appear.count) %>%
    distinct %>% arrange(desc(appear.count))

hist(m3$appear.count, breaks=30)

Bubble <- gvisBubbleChart(m3, idvar="actor_1_name",
                          xvar="appear.count", yvar="actor_1_facebook_likes",
                          sizevar="appear.count",
                          #colorvar="title_year",
                          options=list(
                              #hAxis='{minValue:75, maxValue:125}',
                              width=1000, height=800
                          )
                          )
plot(Bubble)

# ===============================================================================================
# pairwise Relationships

# does not work!
#mosaic(movies[, categorical_variables], legend=TRUE)

ms_all_rows = movies[, c("imdb_score",
                "director_facebook_likes",
                "cast_total_facebook_likes",
                #"actor_1_facebook_likes",
                #"actor_2_facebook_likes",
                #"actor_3_facebook_likes",
                #"movie_facebook_likes",
                "facenumber_in_poster",
                "gross",
                "budget")]
ms = na.omit(ms_all_rows)

# ===============================================================================================
# all best movies, their year, actors

# all worst movies, their year, actors

# ===============================================================================================
# do k-means clustering

# ===============================================================================================
# EDA on smaller data
cor(ms)
plot(ms, pch='.')
chart.Correlation(ms)
# very informative! It shows that cast_total_facebook_likes has high correlation with actor_1_facebook_likes

msc = movies[, c("color",
    "duration",
    "content_rating",
    "language",
    "country",
    "aspect_ratio",
    "title_year",
    "imdb_score"
)]

scatterplotMatrix(ms, pch=".")

hist(movies$director_facebook_likes, breaks=30)
plot(density(na.omit(movies$director_facebook_likes)))

# ===============================================================================================
# https://cran.r-project.org/web/packages/tabplot/vignettes/tabplot-vignette.html
tableplot(ms, sortCol="imdb_score") # gives you a sorted image according to class
tableplot(msc, sortCol="country") # gives you a sorted image according to class

# ===============================================================================================
# faces in poster
hist(movies$facenumber_in_poster, breaks=50)

# ===============================================================================================
# build word cloud using plot keywords for best movies and worst movies
# http://datascienceplus.com/building-wordclouds-in-r/

view_model = function(model) {
    par(mfrow=c(2,2)) # Change the panel layout to 2 x 2
    plot(model)
    par(mfrow=c(1,1)) # Change back to 1 x 1
}

# ===============================================================================================
# fit multiple linear regression model
model.saturated = lm(imdb_score ~ ., data = ms)
summary(model.saturated)
view_model(model.saturated)
influencePlot(model.saturated)
vif(model.saturated) #Assessing the variance inflation factors for the variables in our model.
avPlots(model.saturated)

AIC(model.saturated)
BIC(model.saturated)

# ===============================================================================================
#We can use stepwise regression to help automate the variable selection process.
#Here we define the minimal model, the full model, and the scope of the models
#through which to search:
model.empty = lm(imdb_score ~ 1, data = ms) #The model with an intercept ONLY.
model.full = lm(imdb_score ~ ., data = ms) #The model with ALL variables.
scope = list(lower = formula(model.empty), upper = formula(model.full))
forwardAIC = step(model.empty, scope, direction = "forward", k = 2)

summary(forwardAIC)
view_model(forwardAIC)
influencePlot(forwardAIC)
vif(forwardAIC)
avPlots(forwardAIC)
confint(forwardAIC) # note if those intervals contain 0.

# ===============================================================================================
bc = boxCox(forwardAIC)
lambda = bc$x[which(bc$y == max(bc$y))] # Extracting the best lambda value
imdb_score.bc = (ms$imdb_score^lambda - 1)/lambda
model.bc = lm(imdb_score.bc ~ gross + director_facebook_likes + facenumber_in_poster +
                  cast_total_facebook_likes, data=ms)

summary(model.bc)
view_model(model.bc)
influencePlot(model.bc)
vif(model.bc)
avPlots(model.bc)
confint(model.bc) # note if those intervals contain 0.

# boxcox can make model looks better! But I lose many predictors

# ===============================================================================================
# movie prediction
movies_with_good_variables = movies[, c("imdb_score",
                 "director_facebook_likes",
                 "cast_total_facebook_likes",
                 "actor_1_facebook_likes",
                 "actor_2_facebook_likes",
                 "actor_3_facebook_likes",
                 "movie_facebook_likes",
                 "facenumber_in_poster",
                 "gross",
                 "budget")]
mvs = na.omit(movies_with_good_variables)
x = as.matrix(mvs[, -1])
y = mvs[, 1]

##########################
#####Ridge Regression#####
##########################

# Fitting the ridge regression. Alpha = 0 for ridge regression.
grid = 10^seq(5, -2, length = 100)
ridge.models = glmnet(x, y, alpha = 0, lambda = grid)
dim(coef(ridge.models)) #20 different coefficients, estimated 100 times --once each per lambda value.
coef(ridge.models) #Inspecting the various coefficient estimates.

# Visualizing the ridge regression shrinkage.
plot(ridge.models, xvar = "lambda", label = TRUE, main = "Ridge Regression")

# Creating training and testing sets. Here we decide to use a 70-30 split with approximately 70% of our data in the training
# set and 30% of our data in the test set.
set.seed(0)
train = sample(1:nrow(x), 7*nrow(x)/10)
test = (-train)
y.test = y[test]

length(train)/nrow(x)
length(y.test)/nrow(x)

#Instead of arbitrarily choosing random lambda values and calculating the MSE
#manually, it's a better idea to perform cross-validation in order to choose
#the best lambda over a slew of values.

#Running 10-fold cross validation.
set.seed(0)
cv.ridge.out = cv.glmnet(x[train, ], y[train], lambda = grid, alpha = 0, nfolds = 10)
plot(cv.ridge.out, main = "Ridge Regression\n")
bestlambda.ridge = cv.ridge.out$lambda.min
bestlambda.ridge
log(bestlambda.ridge)

#What is the test MSE associated with this best value of lambda?
ridge.bestlambdatrain = predict(ridge.models, s = bestlambda.ridge, newx = x[test, ])
mean((ridge.bestlambdatrain - y.test)^2)

#Refit the ridge regression on the overall dataset using the best lambda value
#from cross validation; inspect the coefficient estimates.
ridge.out = glmnet(x, y, alpha = 0)
predict(ridge.out, type = "coefficients", s = bestlambda.ridge)

#Let's also inspect the MSE of our final ridge model on all our data.
ridge.bestlambda = predict(ridge.out, s = bestlambda.ridge, newx = x)
mean((ridge.bestlambda - y)^2)

##########################
#####Lasso Regression#####
##########################

#Fitting the lasso regression. Alpha = 1 for lasso regression.
lasso.models = glmnet(x, y, alpha = 1, lambda = grid)

dim(coef(lasso.models)) #20 different coefficients, estimated 100 times --
#once each per lambda value.
coef(lasso.models) #Inspecting the various coefficient estimates.

#Instead of arbitrarily choosing random lambda values and calculating the MSE
#manually, it's a better idea to perform cross-validation in order to choose
#the best lambda over a slew of values.

#Running 10-fold cross validation.
set.seed(0)
cv.lasso.out = cv.glmnet(x[train, ], y[train], lambda = grid, alpha = 1, nfolds = 10)
plot(cv.lasso.out, main = "Lasso Regression\n")
bestlambda.lasso = cv.lasso.out$lambda.min
bestlambda.lasso
log(bestlambda.lasso)

#What is the test MSE associated with this best value of lambda?
lasso.bestlambdatrain = predict(lasso.models, s = bestlambda.lasso, newx = x[test, ])
mean((lasso.bestlambdatrain - y.test)^2)

#Here the MSE is much lower at approximately 89,452; a further improvement
#on that which we have seen above.

#Refit the lasso regression on the overall dataset using the best lambda value
#from cross validation; inspect the coefficient estimates.
lasso.out = glmnet(x, y, alpha = 1)
predict(lasso.out, type = "coefficients", s = bestlambda.lasso)

#Let's also inspect the MSE of our final lasso model on all our data.
lasso.bestlambda = predict(lasso.out, s = bestlambda.lasso, newx = x)
mean((lasso.bestlambda - y)^2)


#' 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 direct projection of y–uncertainty
#' on \code{x} and then combine the errors on both in the \code{x} domain
#'
#' Note: projection y_err on x_err leads to large X errors on shallow
#' slopes due to numerical calculation of fist derivative.
#' @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_proj(x, x_err, y, y_err, X, Y, 1000)
#' @export
mc_err_proj <- function(x,
    x_err,
    y,
    y_err,
    X,
    Y,
    MC = 1000){ # Function to propagate combined errors on x and y on the modeled X and Y values by means of local projection of y uncertainty on x and subsequent combination of uncertainties in X domain

    dYdX <- diff(Y[, 2]) / diff(X) # Create first derivative of Y by X
    dYdX[which(abs(dYdX) <= 10 ^ (floor(log(mean(abs(dYdX)), 10)) - 1))] <- sign(dYdX[which(abs(dYdX) <= 10 ^ (floor(log(mean(abs(dYdX)), 10)) - 1))]) * 10 ^ (floor(log(mean(abs(dYdX)), 10)) - 1) # Remove small absolute values (more than one order of magnitude smaller than the mean), preserving their sign
    dYdX <- append(dYdX, dYdX[length(dYdX)]) # repeat last value to increase the length of the vector to match X/Y (366 days)
    localslope <- dYdX[apply(abs(outer(x, X, FUN = "-")), 1, which.min)] # Find the local slope belonging to each sample position
    x_err_proj <- y_err / localslope # Project uncertainty on Y on x domain using slope
    x_err_comb <- sqrt(x_err_proj ^2 + x_err ^2) # Combine uncertainties on x and y in the X domain
    return(x_err_comb)
}


##################################################################
#
#
#                              >>> Geodesy In R <<<
#
#    This file contains a series of geodetic functions to aid in performing
#    spatial analysis across large distances (100s of km). Note: R Trig.
#    functions take arguments in radians. 1 degree = pi/180 radians
#
# original source by Darren Gillis and others
#
#	Various Chart Datum Parameters:
#
#	Name           Major Axis, a (km)   Flattening (f)
#	WGS84          6378.13700	          1/298.257223563
#	GRS80/NAD83    6378.13700	          1/298.257222101
#	WGS66          6378.145             1/298.25
#	GRS67/IAU68    6378.16000           1/298.2472
#	WGS72          6378.135             1/298.26
#	Krasovsky      6378.245             1/298.3
#	Clarke66/NAD27 6378.2064            1/294.9786982138
#
#	Coordinate Systems and Map Projections, D. H. Maling (Pergamon 1992)
#	Summarized by Ed Williams (http://williams.best.vwh.net/index.html)
#
#     Earth Radius as geometric mean of major & minor radia (WGS84)
#     Nautical Miles per degree as 57.29
#
#
#	Note: Radius of minor axis = a - a*f
#
# test data
#      point     = data.frame(lat=-30, lon=150)
#      locations = data.frame(lat=c(-31, -35, -40), lon=c(150, 151, 151))
#      vincenty distances = 110.8609, 562.3759, 1113.1415
#      great circle =       111.1327  563.5021  1115.0260
##################################################################

##################################################################
# vincenty method .. more accurate
# the original fortran code and documentation is copied at the bottom
##################################################################

vincenty = function (loc1, loc2, a, f) {

  ## for history and equations:: see https://github.com/OSGeo/proj.4/wiki/GeodesicCalculations
  warning( "Deprecated. Consider using geosphere::distVincetyEllipsoid " )

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

      eps = 0.5e-13
      pi = 3.1415926535897932384626433832795
      rad = 0.0174532925199432957692369076848861
      r = 1.0-f

#     convert decimal degrees to radians

      rloc1 = rad*loc1
      rloc2 = rad*loc2

      tu1 = r * sin(rloc1$lat) / cos(rloc1$lat)
      tu2 = r * sin(rloc2$lat) / cos(rloc2$lat)

      cu1 = 1. / sqrt(tu1 * tu1 + 1. )
      su1 = cu1 * tu1
      cu2 = 1. / sqrt(tu2 * tu2 + 1. )

      s =   cu1 * cu2
      baz = s * tu2
      faz = baz * tu1
      dlon = (rloc2$lon - rloc1$lon)
      x=dlon

      q = c(1:dim(loc2)[1]) # get it started into the loop

      sx = NULL
      cx = NULL
      tu1 = NULL
      tu2 = NULL
      sy = NULL
      cy = NULL
      y = NULL
      sa = NULL
      c2a = NULL
      cz = NULL
      e = NULL
      c = NULL

  		repeat {
  			sx[q] = sin(x[q])
        cx[q] = cos(x[q])
        tu1[q] = cu2[q] * sx[q]
        tu2[q] = baz[q] - su1 * cu2[q] * cx[q]
        sy[q] = sqrt(tu1[q] * tu1[q] + tu2[q] * tu2[q])
        cy[q] = s[q] * cx[q] + faz[q]
        y[q] = atan2(sy[q], cy[q])
        sa[q] = s[q] * sx[q] / sy[q]
        c2a[q] = - sa[q] * sa[q] + 1.
        nz = intersect(which(c2a != 0), q)
        cz[q] = faz[q] + faz[q]
        cz[nz] = -cz[nz] / c2a[nz] + cy[nz]
        e[q] = cz[q] * cz[q] * 2 - 1
        c[q] = ((-3. * c2a[q] + 4.) * f + 4.) * c2a[q] * f / 16.
        d = x
        x[q] = ((e[q] * cy[q] * c[q] + cz[q]) * sy[q] * c[q] + y[q]) * sa[q]
        x[q] = (1. - c[q]) * x[q] * f + dlon[q]
        q = which(abs(d - x) > eps)
        if (length(q) < 1) break
      }

      #faz = atan2(tu1, tu2)
      #baz = atan2(cu1 * sx, baz * cx - su1 * cu2) + pi
      x = sqrt( (1. / r / r - 1.) * c2a + 1. ) + 1.
      x = (x - 2.) / x
      c = 1. - x
      c = (x * x / 4. + 1.) / c
      d = (0.375 * x * x - 1.) * x
      x = e * cy
      s = 1. - e - e
      s = ((((sy * sy * 4. - 3.) * s * cz * d / 6. - x ) * d / 4. + cz) * sy * d + y) * c * a * r

      s [!is.finite(s)] = 0

      #faz = faz / rad # these are azimuths .. not needed
      #baz = baz / rad

      return(s)

      }

##################################################################
#~ C *** SOLUTION OF THE GEODETIC INVERSE PROBLEM AFTER T.VINCENTY
#~ C *** MODIFIED RAINSFORD'S METHOD WITH HELMERT'S ELLIPTICAL TERMS
#~ C *** EFFECTIVE IN ANY AZIMUTH AND AT ANY DISTANCE SHORT OF ANTIPODAL
#~ C *** STANDPOINT/FOREPOINT MUST NOT BE THE GEOGRAPHIC POLE
#~ C
#~ C *** A IS THE SEMI-MAJOR AXIS OF THE REFERENCE ELLIPSOID
#~ C *** F IS THE FLATTENING (NOT RECIPROCAL) OF THE REFERNECE ELLIPSOID
#~ C *** LATITUDES AND LONGITUDES IN RADIANS POSITIVE NORTH AND EAST
#~ C *** FORWARD AZIMUTHS AT BOTH POINTS RETURNED IN RADIANS FROM NORTH
#~ C
#~ C *** PROGRAMMED FOR CDC-6600 BY LCDR L.PFEIFER NGS ROCKVILLE MD 18FEB75
#~ C *** MODIFIED FOR IBM SYSTEM 360 BY JOHN G GERGEN NGS ROCKVILLE MD 7507
#~ C
#~ C *** Modified for R by D.Gillis Zoology University of Manitoba 16JUN03
#~ C     Replaced common blocks for constants with DATA statements.  Datum
#~ C     parameters moved from common block to subroutine arguements.
#~ C
#~ C *** Input Variables: DLAT1,DLON1 - initial fix (P1) in degrees
#~ C                          (latitude, north +) (longitude east +)
#~ C                      DLAT2,DLON2 - destination fix (P2) in degrees
#~ C
#~ C                      Ellipsoid (spheroid model, eg. WGS84)
#~ C                         A   - radius of major axis in distance units
#~ C                         F   - flattening factor
#~ C
#~ C *** Output Variables: FAZ - azimuth of the geodesic (P1 to P2)
#~ C                       BAZ - azimuth of the geodesic (P2 to P1)
#~ C                       S   - spheroidal distance = length of the geodesic
#~ C                             in distance units
#~ C
#~ C *** After Vincenty,T. 1975. Direct and inverse solutions of geodesics
#~ C           on the ellipsoid with application of nested equations. Survey
#~ C           Review 23(176):88-94.
#~ C
#~ C
#~ C     These routines were compiled in Windows 98 (DOS Window) using the
#~ C     Gnu FORTRAN complier: g77 --share -o geodesy.dll marspat.for
#~ C     creating:             geodesy.dll
#~ C
#~ C
#~ C
#
#  original code ("geodesy.for") is as follows:
#     note the return of azimuths has been turned off
#
      #~ SUBROUTINE INVER1(DLAT1,DLON1,DLAT2,DLON2,A,F,FAZ,BAZ,S)
      #~ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
#~ C     COMMON/CONST/PI,RAD - original code
#~ C     COMMON/ELIPSOID/A,F - original code
      #~ DATA EPS/0.5D-13/
      #~ DATA PI/3.1415926535897932384626433832795D0/
      #~ DATA RAD/0.0174532925199432957692369076848861D0/
      #~ R=1.D0-F
#~ C
#~ C     Convert decimal degrees to radians
#~ C
      #~ GLAT1=DLAT1*RAD
      #~ GLON1=DLON1*RAD
      #~ GLAT2=DLAT2*RAD
      #~ GLON2=DLON2*RAD
#~ C
      #~ TU1=R*DSIN(GLAT1)/DCOS(GLAT1)
      #~ TU2=R*DSIN(GLAT2)/DCOS(GLAT2)
      #~ CU1=1./DSQRT(TU1*TU1+1.)
      #~ SU1=CU1*TU1
      #~ CU2=1./DSQRT(TU2*TU2+1.)
      #~ S=CU1*CU2
      #~ BAZ=S*TU2
      #~ FAZ=BAZ*TU1
      #~ X=GLON2-GLON1
  #~ 100 SX=DSIN(X)
      #~ CX=DCOS(X)
      #~ TU1=CU2*SX
      #~ TU2=BAZ-SU1*CU2*CX
      #~ SY=DSQRT(TU1*TU1+TU2*TU2)
      #~ CY=S*CX+FAZ
      #~ Y=DATAN2(SY,CY)
      #~ SA=S*SX/SY
      #~ C2A=-SA*SA+1.
      #~ CZ=FAZ+FAZ
      #~ IF(C2A.GT.0.)CZ=-CZ/C2A+CY
      #~ E=CZ*CZ*2.-1.
      #~ C=((-3.*C2A+4.)*F+4.)*C2A*F/16.
      #~ D=X
      #~ X=((E*CY*C+CZ)*SY*C+Y)*SA
      #~ X=(1.-C)*X*F+GLON2-GLON1
      #~ IF(DABS(D-X).GT.EPS) GOTO 100
      #~ FAZ=DATAN2(TU1,TU2)
      #~ BAZ=DATAN2(CU1*SX,BAZ*CX-SU1*CU2)+PI
      #~ X=DSQRT((1./R/R-1.)*C2A+1.)+1.
      #~ X=(X-2.)/X
      #~ C=1.-X
      #~ C=(X*X/4.+1.)/C
      #~ D=(0.375*X*X-1.)*X
      #~ X=E*CY
      #~ S=1.-E-E
      #~ S=((((SY*SY*4.-3.)*S*CZ*D/6.-X)*D/4.+CZ)*SY*D+Y)*C*A*R
      #~ FAZ=FAZ/RAD
      #~ BAZ=BAZ/RAD
      #~ END
#
# example method of access to shared library from R
#
#~ dyn.load("~/src/grids/geodesy.lib")
	#~ inver1<- function (Lat1, Lon1, Lat2, Lon2) {
	              #~ a<-6378137.00          # WGS84 major axis
	              #~ f<-1/298.257223563     # WGS84 flattening parameter
                    #~ .Fortran("inver1",as.double(Lat1),as.double(Lon1),
                                      #~ as.double(Lat2),as.double(Lon2),
                                      #~ as.double(a),as.double(f),
                                      #~ as.double(0),as.double(0),
                                      #~ as.double(0)) [[9]]
      #~ }

  #~ GDvincenty <- function (Lat1, Lon1, Lat2, Lon2) {
 		#~ n = length(Lat1)
	  #~ ans = inver1(Lat1,Lon1,Lat2,Lon2)

    #~ if (n>1) {
      #~ for (i in 2:n) {
      	#~ ans<-c(ans, inver1(Lat1[i],Lon1[i],Lat2[i],Lon2[i]))
      #~ }
    #~ }
    #~ ans
	#~ }

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


################# testing
test.mc <- function() {
show(bernoulli(.3))
show(B(2,3))
show(beta(2,3))
show(beta(0.1,0.1))
show(Bin(10,.2))
show(binomial(10,.2))
show(cauchy(10,1))
show(chi(4))
show(chisquared(14))
show(delta(3))
show(dirac(3))
show(discreteuniform(20))
show(exponential(2))
show(F(4,5))
show(f(4,5))
show(frechet(9,1))
show(gamma(2,3))
show(gamma1(5,1))
show(gamma2(3,2))
show(histogram(c(3,4,5,22,32)))
show(inversegamma(4,4))
show(geometric(.3))
show(generalizedpareto(4,3,2))
show(gev(2,4,5))
show(pascal(.3))
show(gumbel(2,3))
show(extremevalue(2,3))
show(laplace(2,3))
show(logistic(2,3))
show(L(5,1) )
show(lognormal(5,1) )
show(negativebinomial(10,.2))
show(N(5,1) )
show(normal(5,1))
show(gaussian(5,1))
show(pareto(5,1))
show(powerfunction(5,1))
show(powerfunction(5,10))
show(poisson(4))
show(rayleigh(4))
show(reciprocal(12))
show(reciprocal())
show(shiftedloglogistic(5,4,6))
if ("package:sn" %in% search()) show(skewnormal(6,1,2))
show(weibull(5,2))
show(U(2,4))
show(uniform(2,4))
show(rectangular(2,4) )
show(loguniform(2,4))
show(triangular(.2, .6, 1.2))
show(logtriangular(.2, .6, 1.2))
show(quantiles(v = c(3, 6, 10, 16, 25, 40), p = c(0, 0.2, 0.4, 0.5, 0.7, 1)))
# show(quantiles(v = c(3, 6, 10, 16, 25, 40), p = c(0.1, 0.2, 0.4, 0.5, 0.7, 0.9)))  # p doesn't start at zero or end at one
show(mc(c(1,1.2,3, 6, 10, 16, 25, 40)))  # default pointlist constructor
show(betapert(20,60,25))
show(MEminmax(2,5))
show(MEminmaxmean(10, 20, 12))
show(MEmeansd(5,1))
show(MEminmean(0,5))
#show(MEmeangeomean(10,5))  #####
show(MEdiscretemean(1:10,2.3))
show(MEquantiles(v = c(3, 6, 10, 16, 25, 40), p = c(0, 0.2, 0.4, 0.5, 0.7, 1)))
show(MEdiscreteminmax(0,10))
show(MEmeanvar(0.2,0.02))
show(MEminmaxmeansd(0,1,0.2,0.02))
show(MEminmaxmeanvar(0,1,0.2,0.02))
return(TRUE)
}

plot(runif(1000))
par(mfrow=c(4,5))
test.mc()

par(mfrow=c(1,1))
a = N(5,1)
b = exp(a)
exp(a)

r = sort(runif(15))
r = c(0.019764379132539, 0.0324148465879261, 0.321962385904044, 0.384120133006945,0.448278494412079, 0.545291637070477, 0.643749186070636, 0.714126582955942, 0.744521557586268, 0.753784047439694, 0.803039125632495, 0.895463747903705, 0.897065195254982, 0.908547935541719, 0.941706892568618)
c = d = mc(r)
if ("package:splines" %in% search()) d = mc(r,interpolation='spline')
plot(c)
lines(d,col='red')
edf(r,new=FALSE)
points(r,0:14/14)

a = N(5,1)
b = U(2,6)
c = conv.mc(a,b)
d = conv.mc(a,b,'*')
cc = a + b
dd = a * b
c;cc
d;dd

a = N(5,1)
b = U(2,6)
a < b       # 0.26 or so

a = N(5,1)
a + 2
2 + a
a + a
a + N(5,1)  # smaller variance

a - 2
2 - a
a - a
a - N(5,1)   # bigger variance

a * 2
2 * a
a * a
a * N(5,1)

a / 2
2 / a
a / a
a / N(5,1)     # bigger variance

a ^ 2
2 ^ a
a ^ a
a ^ N(5,1)

pmin(a,4)
pmin(mc(4),a)
pmin(a,a)
pmin(a,N(5,1))

pmax(a,4)
pmax(mc(4),a)
pmax(a,a)
pmax(a,N(5,1))

a = N(5,1); b = U(9,11); c = histogram(c(23,24,25,33,35))
m = mixture(c(a,b,c))
m

bb = conv.mc(a,a)
cc = perfectconv.mc(a,a)
dd = perfectconv.mc(a,N(5,1))
ee = oppositeconv.mc(a,a)
ff = oppositeconv.mc(a, N(5,1))
bb
cc
dd
ee
ff
bb
lines(cc,col='red')
lines(dd,col='blue')
lines(ee)
lines(ff,col='gray')

a = N(5,1)
b = U(2,3)
ab = perfectconv.mc(a,b)
c = U(2,3,r=a)
ac = a+c
ab
lines(ac,col='blue')

a = N(5,1)
b = U(2,6)
-a
acos(a/10)
alpha(a,4)
and(U(0.1, 0.2), U(0.5,0.6))
asin(a/10)
atan(a)
atan2(a,b)
ceiling(a)
complement(a/10)
cor(a,b)
cut(a, 0.3)
exp(a)
fivenum(a)
fractile(a, 0.3)
iqr(a)
IQR(a)
left(a)
log(a)
log(a,mc(3))
log(a,U(2,3))
max(a)
mean(a)
median(a)
min(a)
mixture(c(a,b),c(2,3))
mult(-2,a)
negate(a)
not(U(0.1, 0.2))
or(U(0.1, 0.2), U(0.5,0.6))
percentile(a, 0.3)
pmax(a,b)
pmin(a,b)
prob(a,4)
random(a)
randomrange(a)
range(a)
reciprocate(a)
rep(a,3)
reps(a)
round(a)
right(a)
samedistribution(a)
specific(a)
sd(a)
shift(-1,a)
sign(a)
sqrt(a)
trunc(a)
truncate(a,3,6)
var(a)
xprob.mc(a,0.3)

# make sure the old functions still work
-4.5
acos(0.45)
asin(0.45)
atan(4.5)
atan2(4,5)
ceiling(4.5)
cor(sort(runif(10)), sort(runif(10)))
exp(4.5)
fivenum(runif(45))
IQR(runif(45))
log(4.5)
log(4.5,3)
max(runif(14))
mean(runif(14))
median(runif(14))
min(runif(45))
pmax(runif(14),runif(14))
pmin(runif(14),runif(14))
range(runif(14))
rep(c(12,11),4)
round(4.5)
sd(runif(14))
sign(runif(14)-0.3)
sqrt(9)
trunc(4.5)
var(runif(14))

par(mfrow=c(1,1))
x1 = poisson(5)
pl(range(x1),range(x1+30))
bla(x1)
red(x1+2)
blu(x1+4)
gre(x1+6)
kha(x1+8)
nav(x1+10)
pur(x1+12)
bro(x1+14)
oli(x1+16)
gra(x1+18)
ora(x1+20)
pin(x1+22)
cya(x1+24)
cha(x1+26)
gol(x1+28)
bri(x1+30)
tan(x1+32)

S = c(
  1.00,  0.83,  0.83,  0.83,
  0.83,  1.00,  0.83,  0.83,
  0.83,  0.83,  1.00,  0.83,
  0.83,  0.83,  0.83,  1.00)

S = c(  # this matrix is not positive definite
  1.00,  0.30,  0.83, -0.20,
  0.30,  1.00,  0.00,  0.25,
  0.83,  0.00,  1.00,  0.25,
 -0.20,  0.25,  0.25,  1.00)

S = c(
  1.00,  0.60, -0.30,  0.40,
  0.60,  1.00, -0.40,  0.90,
 -0.30, -0.40,  1.00, -0.25,
  0.40,  0.90, -0.25,  1.00)

correlations(S)

w = uniform(2,5, r=MC$r[,1])
x = poisson(5,   r=MC$r[,2])
y = gumbel(2,3,  r=MC$r[,3])
z = normal(6,1,  r=MC$r[,4])

# alternatively, you can define a little function:
R = function(i,corrs=MC$r) return(corrs[,i])

W = uniform(2,5, r=R(1))
X = poisson(5,   r=R(2))
Y = gumbel(2,3,  r=R(3))
Z = normal(6,1,  r=R(4))

cor(w,W)
cor(x,X)
cor(y,Y)
cor(z,Z)

plot(x)
plot(x,'Weight')
plot(x,z)

Sigma

cor(w,x)
cor(w,y)
cor(w,z)

plotcorrs(c(w,x,y),names=c('w','x','y'),MC$many)
plotcorrs(c(w,x,y),names=c('w','x','y'),col='red')
plotcorrs(c(w,x,y),names=c('w','x','y'))
plotcorrs(c(w,x,y,z),names=c('w','x','y','z'))
plotcorrs(c(w,x,y,z,z),names=c('w','x','y','z','a'))

S = c(
  1.00,  0.83,
  0.83,  1.00)
correlations(S)
a = mc(MC$r[,1])
b = mc(MC$r[,2])
cor(a,b)
plotcorrs(c(a,b))

S = c(
  1.00,  0.83,  0.83,
  0.83,  1.00,  0.83,
  0.83,  0.83,  1.00)
correlations(S)
a = mc(MC$r[,1])
b = mc(MC$r[,2])
c = mc(MC$r[,3])
plotcorrs(c(a,b,c),c('a','b','c'))

S = c(
  1.00,  0.60, -0.30,  0.40,  0.00,
  0.60,  1.00, -0.40,  0.90,  0.00,
 -0.30, -0.40,  1.00, -0.25,  0.00,
  0.40,  0.90, -0.25,  1.00,  0.00,
  0.00,  0.00,  0.00,  0.00,  1.00)
correlations(S)
a = mc(MC$r[,1])
b = mc(MC$r[,2])
c = mc(MC$r[,3])
d = mc(MC$r[,4])
e = mc(MC$r[,5])
plotcorrs(c(a,b,c,d,e),c('a','b','c','d','e'))

checkMM = function(x, MM) {
  d = MM(x)
  m = mean(x)
  s = sd(x)
  mm = mean(d)
  ss = sd(d)
  cat(signif(m,4),'  ',signif(s,4),'\n')
  cat(signif(mm,4),'  ',signif(ss,4),'\n\n')
  }

some = 1:25
checkMM((runif(some)<0.25)[some],MMbernoulli)
checkMM(beta(2,3)@x[some],MMbeta)
checkMM(binomial(30,0.3)@x[some],MMbinomial)
checkMM(chisquared(5)@x[some],MMchisquared)
checkMM(exponential(4)@x[some],MMexponential)
checkMM(F(12,13)@x[some],MMF )
checkMM(gamma(2,3)@x[some],MMgamma)
checkMM(geometric(0.25,6)@x[some],MMgeometric)
checkMM(gumbel(2,3)@x[some],MMgumbel)
checkMM(lognormal(4,1)@x[some],MMlognormal)
checkMM(laplace(3,2)@x[some],MMlaplace)
checkMM(logistic(2,3)@x[some],MMlogistic)
#checkMM(loguniform(1,100)@x[some],MMloguniform) ##########
checkMM(normal(5,1)@x[some],MMnormal)
checkMM(pareto(2,3)@x[some],MMpareto)
checkMM(poisson(4)@x[some],MMpoisson)
checkMM(powerfunction(2,3)@x[some],MMpowerfunction )
checkMM(student(3)@x[some],MMstudent)
checkMM(uniform(6,18)@x[some],MMuniform)

above(a,5.5)
highest(a,70)

massreassignexamples <- function(a = N(5,1), b = U(4,5), th = 4, ith = c(4,5), pth = 25) {
  splot <- function(s, xlab='', ylab='Cumulative probability', cumulative=MC$cumulative, ...) {
    if (!cumulative) ylab = 'Exceedance probability'
    plot(c(min(s@x),sort(s@x)),updown(cumulative,seq(0,1,length.out=1+length(s@x))),type='s', xlab=xlab,ylab=ylab,...)
    bringToTop(-1) # return focus to R console
    }
  abelow = below(a,th)
  aabove = above(a,th)
  alowest = lowest(a,pth)
  ahighest = highest(a,pth)
  apmin = pmin(a,b)
  apmax = pmax(a,b)
  asmin = smin(a,b)
  asmax = smax(a,b)
  abetween = between(a,left(ith),right(ith))
  abetween2 = between(a, left(cut(a,pth/100)), right(cut(a,1-pth/100)))
  atruncate = truncate(a,left(ith),right(ith))
  arescale = rescale(a,left(ith),right(ith))
  atrunc = trunc(a)
  around = round(a)
  aceiling = ceiling(a)
  old.par <- par(mfrow=c(4,4),mar=c(2,4,3,1))
  splot(a,col='gray',main='lowest');  lines(c(0,10),c(pth,pth)/100,lty='dotted',col='blue'); lines(alowest,lwd=3)
  splot(a,col='gray',main='below');   lines(c(th,th),c(0,1),lty='dotted',col='blue'); lines(abelow,lwd=3)
  splot(a,col='gray',main='above');   lines(c(th,th),c(0,1),lty='dotted',col='blue'); lines(aabove,lwd=3)
  splot(a,col='gray',main='highest'); lines(c(0,10),1-c(pth,pth)/100,lty='dotted',col='blue'); lines(ahighest,lwd=3)
  splot(a,col='gray',main='truncate');lines(atruncate,lwd=3);lines(c(left(ith),right(ith)),c(0,0),col='blue',lty='dotted')
  splot(a,col='gray',main='rescale'); lines(arescale,lwd=3); lines(c(left(ith),right(ith)),c(0,0),col='blue',lty='dotted')
  splot(a,col='gray',main='between(cut,cut)'); lines(abetween2,lwd=3); lines(c(2.5,2.5),c(pth/100,1-pth/100),col='blue',lty='dotted')
  splot(a,col='gray',main='between'); lines(abetween,lwd=3); lines(c(left(ith),right(ith)),c(0,0),col='blue',lty='dotted')
  splot(a,col='gray',main='pmin');    lines(b,col='blue');   lines(apmin,lwd=3)
  splot(a,col='gray',main='pmax');    lines(b,col='blue');   lines(apmax,lwd=3)
  splot(a,col='gray',main='smin');    lines(b,col='blue');   lines(asmin,lwd=3)
  splot(a,col='gray',main='smax');    lines(b,col='blue');   lines(asmax,lwd=3)
  splot(a,col='gray',main='ceiling'); lines(aceiling,lwd=3);
  splot(a,col='gray',main='round');   lines(around,lwd=3);
  splot(a,col='gray',main='trunc');   lines(atrunc,lwd=3);
  par(old.par)
  }

massreassignexamples()


# Reading dataset
library(readr)
library(readxl)
GlassDataset <- read_xlsx("Glass.xlsx")

View(GlassDataset)
str(GlassDataset)

library(dplyr)
library(tidyr)

summary(GlassDataset)
head(GlassDataset)
tail(GlassDataset)
str(GlassDataset)

GlassDataset$Type = GlassDataset$Type %>% factor(labels = sort(unique(GlassDataset$Type)))
View(GlassDataset)

class(GlassDataset)
dim(GlassDataset)

colnames(GlassDataset)

library(dplyr)
glimpse(GlassDataset)

plot(GlassDataset$Id, GlassDataset$Type, main = "Type of Glass", xlab = "Identification Number", ylab = "Type")

#Hypothesis Test

t.test(GlassDataset$RI, GlassDataset$Type)

t.test(GlassDataset$RI, mu = 5, alternative = 'greater')

t.test(GlassDataset$Type, mu = 5, alternative = 'greater')

outlierKD <- function(dt, var) {
+ var_name <- eval(substitute(var),eval(dt))
+ na1 <- sum(is.na(var_name))
+ m1 <- mean(var_name, na.rm = T)
+ par(mfrow=c(2, 2), oma=c(0,0,3,0))
+ boxplot(var_name, main="With outliers")
+ hist(var_name, main="With outliers", xlab=NA, ylab=NA)
+ outlier <- boxplot.stats(var_name)$out
+ mo <- mean(outlier)
+ var_name <- ifelse(var_name %in% outlier, NA, var_name)
+ boxplot(var_name, main="Without outliers")
+ hist(var_name, main="Without outliers", xlab=NA, ylab=NA)
+ title("Outlier Check", outer=TRUE)
+ na2 <- sum(is.na(var_name))
+ cat("Outliers identified:", na2 - na1, "n")
+ cat("Propotion (%) of outliers:", round((na2 - na1) / sum(!is.na(var_name))*100, 1), "n")
+ cat("Mean of the outliers:", round(mo, 2), "n")
+ m2 <- mean(var_name, na.rm = T)
+ cat("Mean without removing outliers:", round(m1, 2), "n")
+ cat("Mean if we remove outliers:", round(m2, 2), "n")
+ response <- readline(prompt="Do you want to remove outliers and to replace with NA? [yes/no]: ")
+ if(response == "y" | response == "yes"){
+ dt[as.character(substitute(var))] <- invisible(var_name)
+ assign(as.character(as.list(match.call())$dt), dt, envir = .GlobalEnv)
+ cat("Outliers successfully removed", "n")
+  return(invisible(dt))
+ } else{
+ cat("Nothing changed", "n")
+ return(invisible(var_name))
+ }}

outlierKD(GlassDataset,RI)

library(outliers)

library(ggplot2)

grubbs.flag <- function(x) {
+     outliers <- NULL
+     test <- x
+     grubbs.result <- grubbs.test(test)
+     pv <- grubbs.result$p.value
+     while(pv < 0.05) {
+         outliers <- c(outliers,as.numeric(strsplit(grubbs.result$alternative," ")[[1]][3]))
+         test <- x[!x %in% outliers]
+         grubbs.result <- grubbs.test(test)
+         pv <- grubbs.result$p.value
+     }
+     return(data.frame(X=x,Outlier=(x %in% outliers)))
+ }

grubbs.flag(GlassDataset$Na)
ggplot(grubbs.flag(GlassDataset$Na),aes(x=GlassDataset$Na,color=Outlier,fill=Outlier))+ geom_histogram(binwidth=diff(range(GlassDataset$Na))/0.3)+ theme_bw()

library(MoEClust)

View(GlassDataset)
Glass_Id<-GlassDataset[,1]
RI<-GlassDataset[,2]
Mg<-GlassDataset[,4]
dim(GlassDataset)

m1    <- MoE_clust(Mg, G=0:2, verbose=FALSE)

m2    <- MoE_clust(Mg, G=2:16, verbose=FALSE)

No covariates
m3    <- MoE_clust(Mg, G=16:30, verbose=FALSE)
comp <- MoE_compare(m1, m2)
(mod <- as.Mclust(comp$optimal))

plot(mod, what="classification")
plot(mod, what="uncertainty")

plot(comp$optimal, what="gpairs", jitter=FALSE)

plot(GlassDataset$Na , GlassDataset$RI, xlab = 'Sodium Content', ylab = 'Refractive Index', main = 'Scatter plot for sodium content')

library(ggplot2)
ggplot(data=GlassDataset,aes(x=Id, y=Na)) + geom_point() + theme_minimal()+geom_col()

ggplot(data=GlassDataset,aes(x=Id, y=Na)) + geom_point() + theme_minimal()

library(GGally)
ggpairs(GlassDataset)

library(scatterplot3d)
scatterplot3d(GlassDataset[,1:3])

install.packages("ggpubr")

library(ggpubr)
ggscatter(GlassDataset, x = "RI", y = "Na", add = "reg.line", conf.int = TRUE, cor.coef = TRUE, cor.method = "pearson", xlab = "Refractive Index with Sodium Content")

shapiro.test(GlassDataset$RI)

shapiro.test(GlassDataset$Na)

ggqqplot(GlassDataset$RI, ylab = "RI")
ggqqplot(GlassDataset$Na, ylab = "Na")

res <- cor.test(GlassDataset$RI, GlassDataset$Na,
+                 method = "pearson")

plot(res$p.value, res$parameter)
res$p.value

res$estimate

res2 <- cor.test(GlassDataset$RI, GlassDataset$Na,  method="kendall")
res2


library(eNetXplorer)

fn = "data_generated/Clinical_data_v123.txt"
df = fread(fn)

df = df %>%
  dplyr::select(-Subject, -Visit, -starts_with("CD"), -starts_with("NK")) # CBC only, TBNK clinical flow data removed

y = df$weeks
x = df %>%
  dplyr::select(-weeks) %>%
  tibble::column_to_rownames("sample") %>%
  data.matrix()

dn.out = "results/CBC_enet"
dir.create(dn.out, showWarnings = F, recursive = T)
result = eNetXplorer(x=x,y=y,family="gaussian",alpha=seq(0,1,by=0.1),
                     seed=123)#,nlambda.ext=1000,n_run=1000, n_perm_null=250)
save(result,file=file.path(dn.out, "enet_data.Rdata"))
summaryPDF(result,path=dn.out)


require(tseriesChaos)
require(rgl)
walk <- NULL; run <- NULL; stand <- NULL; bike <- NULL; mixed <- NULL; data <- NULL;

d <- 3; m <- 12;

data$run <- read.csv('data/run-2009-03-02.csv',sep='\t')$accel_mag
data$walk <- read.csv('data/walk-2009-02-27-1.csv',sep='\t')$accel_mag
data$stand <- read.csv('data/standing-2009-02-27.csv',sep='\t')$accel_mag
data$bike <- read.csv('data/bike-2009-03-18.csv',sep='\t')$accel_mag
data$mixed <- read.csv('data/run-2009-03-02.csv',sep='\t')$accel_mag
data$trajectory <- read.csv('/tmp/trajectory.csv',sep='\t')

run$data <- data$run[900:2600]
walk$data <- data$walk[500:2200]
bike$data <- data$bike[6341:8110]
stand$data <- data$stand[200:700]
mixed$data <- c(data$mixed[2941:5715], data$bike[8151:10050])

walk$e <- embedd(walk$data, d=d, m=m)
run$e <- embedd(run$data, d=d, m=m)
bike$e <- embedd(bike$data, d=d, m=m)
stand$e <- embedd(stand$data, d=d, m=m)
mixed$e <- embedd(mixed$data, d=d, m=m)

p <- princomp(walk$e,scale=FALSE);

rgl.open()
rgl.clear()
rgl.linestrips(p$scores[,1:3],color=c("white"), alpha=0.2)
rgl.linestrips(data$trajectory[,1:3],col="red")


##################################################################################################################
####  Purpose: Final Project - Classification - SVM
####  Group: Ravi P., Derek P., Aneesh K., Ninad K.
####  Date: 11/28/2018
####  Comment:
####    setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")
####
##################################################################################################################

#### 0. Cleaning of environment ####
setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")
rm(list = ls())

#### 1. Importing of library and data ####
df_train <- read.csv("./data/train_new.csv")
df_test <- read.csv("./data/test_new.csv")

library(e1071)

#### 2. Cleaning of data ####
df_train <- df_train[,-1]
df_test <- df_test[,-1]

levels(df_test$SimpleColor) <- levels(df_train$SimpleColor)

#### 3. SVM ####
svm.model <- svm(OutcomeType~ ., data =df_train[,c(-1)])
svm.pred <- predict(svm.model,  df_test[,c(-1)] )

#### 4. Error Check ####
table(actual=df_test[,2],svm.pred )
SVM_wrong<- (df_test$OutcomeType!=svm.pred)
rate<-sum(SVM_wrong)/length(SVM_wrong)
print(rate)


library(readr)
library(data.table)
mlogloss <- function(actual,pred){
	actual <- as.integer(as.factor(actual))
	probs <- rep(0,length(actual))
	for(i in 1:length(actual)) { probs[i] <- pred[i,actual[i]]}
	probs <- as.numeric(probs)
	probs[which(probs>1-1e-15)] <- 1-1e-15
	probs[which(probs<1e-15)] <- 1e-15
	return(-(1/length(actual))*sum(log(probs)))
}
path <- "../Data/"
xgb <- fread(paste0(path,"xgb_2nd.csv"))
xgb <- as.data.frame(xgb)
NN <- fread(paste0(path,"kerasNN2_2nd.csv"),header=T)
NN <- as.data.frame(NN)
ET <- fread(paste0(path,"extraTree_2nd.csv"),header=T)
ET <- as.data.frame(ET)
id <- xgb$id
xgb$id <- NULL
NN$id <- NULL
ET$id <- NULL
for(i in 1:ncol(xgb)){xgb[,i] <- as.numeric(xgb[,i])}
for(i in 1:ncol(NN)){NN[,i] <- as.numeric(NN[,i])}
for(i in 1:ncol(ET)){ET[,i] <- as.numeric(ET[,i])}
pred <- (NN * 0.4 + xgb * 0.6)
submission <- data.frame(id,pred)
for(i in 1:ncol(submission)){ submission[,i] <- as.character(submission[,i])}
write_csv(submission,paste0(path,"xgbNN_ensemble.csv"))


#' Chi-square test table in pt-br
#'
#' @param df a \code{tibble} object
#' @param variavel_x a character vector (or factor)
#' @param variavel_y a character vector (or factor)
#' @param rotulo a caption of the table
#' @param base directory where to save the results
#'
#' @return a \code{knitr::kable} object with statistic, degree freedom and p-value
#'
#' @usage qui_test(x, y)
#'
#' @example
#' df <- tibble(x = sample(letters[1:5], 100, replace = T),
#'              y = sample(letters[6:10], 100, replace = T))
#' qui_test(df, x, y, "x", "y")
qui_test <- function(df, variavel_x, variavel_y, caption, base = "") {

  if(missing(caption)) caption <- stringr::str_interp("Teste qui-quadrado entre ${variavel_x} e ${variavel_y}.")
  base::suppressWarnings({
    teste <- chisq.test(x = df[, variavel_x][[1]], y = df[, variavel_y][[1]])
  })

  tab <- tibble(`Estatística` = teste$statistic,
         `Graus de liberdade` = teste$parameter,
         `Valor-p` = teste$p.value)

  readr::write_csv2(
    tab,
    stringr::str_interp("${base}teste_qui_quadrado/qui_test_${variavel_x}_${variavel_y}.csv"))
  openxlsx::write.xlsx(
    tab,
    stringr::str_interp("${base}teste_qui_quadrado/qui_test_${variavel_x}_${variavel_y}.xlsx"))

  tab |>
    knitr::kable(format = 'pipe', digits = 2, align = "c",
                 caption = caption,
                 format.args = list(decimal.mark = ","))
}


# Run the code below to set up the data
# Add labels to the plot
# - Title: Unisex Name Popularity
# - x: # of Male Babies per Year
# - y: # of Female Babies per Year
# - legend (color): Name

# Bonus: add additional information in a subtitle or caption

library(tidyverse)
# Load and reshape data
unisex_data <- read_csv("data/unisex.csv")
unisex_data <- unisex_data %>%
  select(-prop) %>%
  spread(sex, n, fill=0)
unisex_data

# make a scatterplot: add labels
ggplot(unisex_data, aes(x=Male, y=Female, color=name)) +
  geom_point() +
  geom_smooth(method="lm", se=FALSE)


library(Hmisc)
data(pbc)

with(pbc,
     rcspline.plot(age, time, model="cox",event=status %in% 1:2, nk=5, show="xbeta",
              showknots=TRUE, plotcl=TRUE, lty=1)
)


library(here)
library(kernlab)
d = readRDS(here("data/sgss_stp.rds"))
d=as.data.frame(d)
# parameters
RESOLUTION="area"
choice_weeks = 46:50
CORRECT=TRUE

un=sort(unique(d[,RESOLUTION])) # unique LTLA names ~300
weeks=sort(unique(d$epiweek))

S_neg = matrix(NA, nrow=length(un),ncol=length(weeks))
S_pos = matrix(NA, nrow=length(un),ncol=length(weeks))

rownames(S_neg)=rownames(S_pos)=un
colnames(S_neg)=colnames(S_pos)=weeks

if(CORRECT){
	d$S_negative = (d$total_cases * d$sgss_s_negative) / (d$sgss_s_negative+ d$sgss_s_positive)
	d$S_positive = (d$total_cases * d$sgss_s_positive) / (d$sgss_s_negative+ d$sgss_s_positive)
}else {
	d$S_negative =  d$sgss_s_negative
	d$S_positive =  d$sgss_s_positive
}

d$S_negative[d$S_negative==0]=1
d$S_positive[d$S_positive==0]=1

# pivot table explicit
for(i in 1:length(un)){
	for(j in 1:length(weeks)){
		S_neg[i,j] = sum(d$S_negative[d$epiweek%in%weeks[j] & d[,RESOLUTION]%in%un[i]])
		S_pos[i,j] = sum(d$S_positive[d$epiweek%in%weeks[j] & d[,RESOLUTION]%in%un[i]])
	}
}
# subset to the number of weeks of interest
S_neg=S_neg[,weeks%in%choice_weeks]
S_pos=S_pos[,weeks%in%choice_weeks]

S_neg_rate = matrix(NA, nrow=nrow(S_neg),ncol=ncol(S_neg)-1)
S_pos_rate = matrix(NA, nrow=nrow(S_neg),ncol=ncol(S_neg)-1)

for(i in 1:nrow(S_neg)){
	for(j in 1:(ncol(S_neg)-1)){
		S_neg_rate[i,j] = (S_neg[i,j+1]/S_neg[i,j])^(6.5/7)
		S_pos_rate[i,j] = (S_pos[i,j+1]/S_pos[i,j])^(6.5/7)
	}
}

growth_rates_p = as.vector(S_pos_rate)
growth_rates_n = as.vector(S_neg_rate)

ks.test(matrix(growth_rates_p),matrix(growth_rates_n))

kmmd(matrix(growth_rates_p),matrix(growth_rates_n))

mat =  matrix(c(sum(growth_rates_p>=1), sum(growth_rates_n>=1), sum(growth_rates_p<1), sum(growth_rates_n<1)), nrow = 2,
	              dimnames =
	       list(c("S_positive", "S_negative"),
		    c("r>=1", "r<1")))
t(mat)
fisher.test(t(mat), alternative = "less")

mat2 =  matrix(c(sum(growth_rates_p>1 & growth_rates_n>1), sum(growth_rates_p>1 & growth_rates_n<=1)	, sum(growth_rates_p<=1 & growth_rates_n>1)	, sum(growth_rates_p<=1 & growth_rates_n<=1)), nrow = 2,
	              dimnames =
	       list(c("Sneg>1", "Sneg<=1"),
		    c("Spos>1", "Spos<=1")))

print(t(mat2))
print(mcnemar.test(mat2))


## Some packages available via github only
## devtools::install_github("tidyverse/googlesheets4")
## devtools::install_github("dill/emoGG")
library(googlesheets4)
library(ggplot2)
library(emoGG)
require(gridExtra)
library(animation)

## 'true' data
set.seed(987)
data <- data.frame(weight = rnorm(10,2,0.5))
data$egg <- 20*data$weight + rnorm(10, 0, 10)

## original plot
p <- ggplot(data, aes(x = egg, y = weight)) +
   # annotation_custom(g, -Inf, Inf, -Inf, Inf)  +
    geom_point() +
    xlab("weight of egg (g)") + ylab("weight of chicken (kg)") +
    ylim(c(0,3)) + xlim(c(0,70)) + geom_emoji(emoji = "1f95a") +
    theme(axis.line=element_blank(),
          axis.line.x = element_line(color="black", size = 2),
          axis.line.y = element_line(color="black", size = 2),
          legend.position="none",
          panel.background=element_blank(),
          panel.border=element_blank(),
          panel.grid.major=element_blank(),
          panel.grid.minor=element_blank(),
          plot.background=element_blank(),
          axis.title.y = element_text(size = rel(1)),
          axis.title.x = element_text(size = rel(1)),
          text = element_text(size=20))
p

## read in coords from google sheet
url <- "https://docs.google.com/spreadsheets/d/1vn7oGtw06KJazYx-F2nReFvoeqONrskNehGkJpeugXw/edit?usp=sharing"
sheets_auth(email = "cmjonestodd@gmail.com") ## my google sheets auth ****SET YOUR OWN*****
dat.all <- as.data.frame(read_sheet(url,col_names = FALSE))
names(dat.all) <- c("x1","y1","x2","y2")
dat.all$slope <- ((500/60)*(dat.all[,2]-dat.all[,4]))/((500/3)*(dat.all[,3] - dat.all[,1]))
## calculating slope from imported pixel start and end positions from mousedown and mouse up
dat.all <- unique(dat.all) ## remove duplicates
dat.all <- na.omit(dat.all) ## remove NA slopes

## grid over plotting area same length as # pixels in canvas y doesn't match up no idea
grd <- data.frame(x = seq(from = 0, to = 70, length.out = 500),
                  y = seq(from = 3, to = 0, length.out = 500))

locs.all <- data.frame(x1 = grd$x[dat.all[,1]],x2 = grd$x[dat.all[,3]],
                       y2 = grd$y[dat.all[,2]],y1 = grd$y[dat.all[,4]])
locs.all$transition <- 1:nrow(locs.all)

## gif

ani.options(ani.width = 1000,ani.height = 500)
saveGIF({
    for(i in 1:nrow(dat.all)){
        locs <- locs.all[1:i,]
        l <- ggplot(data, aes(x = egg, y = weight)) +
            geom_point() +
            xlab("weight of egg (g)") + ylab("weight of chicken (kg)") +
            ylim(c(0,3)) + xlim(c(0,70)) + geom_emoji(emoji = "1f95a") +
            theme(axis.line=element_blank(),
                  axis.line.x = element_line(color="black", size = 2),
                  axis.line.y = element_line(color="black", size = 2),
                  legend.position="none",
                  panel.background=element_blank(),
                  panel.border=element_blank(),
                  panel.grid.major=element_blank(),
                  panel.grid.minor=element_blank(),
                  plot.background=element_blank(),
                  axis.title.y = element_text(size = rel(1)),
                  axis.title.x = element_text(size = rel(1)),
                  text = element_text(size=20)) +
            stat_summary(fun.data= mean_cl_normal) +
            geom_smooth(method='lm', se = FALSE,color = "black") +
            annotate('segment',x = locs$x2, y = locs$y1, xend = locs$x1, yend = locs$y2,color = "grey",size = 1.5,alpha = 0.5)
        ## remember to transpose x2 (as x) and x1 (as xend) due to layout of canvas
        dat <- dat.all[1:i,]
        h <- ggplot(dat,aes(x = slope)) + geom_histogram() +
            xlab("estimated slope from app") + ylab("count") +
            theme(axis.line=element_blank(),
                  axis.line.x = element_line(color="black", size = 2),
                  axis.line.y = element_line(color="black", size = 2),
                  legend.position="none",
                  panel.background=element_blank(),
                  panel.border=element_blank(),
                  panel.grid.major=element_blank(),
                  panel.grid.minor=element_blank(),
                  plot.background=element_blank(),
                  axis.title.y = element_text(size = rel(1)),
                  axis.title.x = element_text(size = rel(1)),
                  text = element_text(size=20))  +
            xlim(range(dat.all$slope,na.rm = TRUE) + c(-1,1)) + ## keep xlim to same limits of est slopes
            ylim(c(0,max(table(cut(dat.all$slope,10))))) +
            annotate('segment',x = 1/20, y = 0, xend = 1/20,
                     yend = 10,color = "grey",size = 1.5,alpha = 0.7) +
            annotate('text',x = 0.5, y = 10, label = "True slope = 0.05",size = 5) +
            annotate('text',x = 0.75, y = 7.5,label = paste("Est. slopes mean = ",round(mean(dat$slope,na.rm = TRUE),2)),size = 5)
        ## plot side by side
        grid.arrange(l,h, ncol=2)
    }
},movie.name = "lm_demo.gif")


install.packages("quantmod")
require(devtools)
devtools::install_github("braverock/blotter")
devtools::install_github("braverock/quantstrat")

library(quantmod)
# initialization
Sys.setenv(TZ="UTC")
symbol = as.character("AMZN")
start <- as.Date("2017-01-01")
end <- as.Date("2020-01-01")
getSymbols(Symbols = symbol, src = "yahoo", from = start, to = end)

AMZN <- na.omit(lag(AMZN))
# calculate indicators
sma20 <- SMA(Cl(AMZN), n = 20)
ema20 <- EMA(Cl(AMZN), n = 20)

library(quantstrat)
# strategy initialization
currency("USD")
stock(symbol, currency = 'USD', multiplier = 1)
tradeSize <- 100000
initEquity <- 100000
account.st <- portfolio.st <- strategy.st <- "my strategy"
rm.strat("my strategy")
out <- initPortf(portfolio.st, symbols = symbol, initDate = start, currency = "USD")
out <- initAcct(account.st, portfolios = portfolio.st, initDate = start, currency = "USD", initEq = initEquity)
initOrders(portfolio.st, initDate = start)
strategy(strategy.st, store = TRUE)

# indicators with QuantStrat
out <- add.indicator(strategy.st, name = "SMA", arguments = list(x = quote(Cl(AMZN)), n = 20, maType = "SMA"), label = "SMA20periods")
out <- add.indicator(strategy.st, name = "SMA", arguments = list(x = quote(Cl(AMZN)), n = 50, maType = "SMA"), label = "SMA50periods")
out <- add.indicator(strategy.st, name = "EMA", arguments = list(x = quote(Cl(AMZN)), n = 20, maType = "EMA"), label = "EMA20periods")
out <- add.indicator(strategy.st, name = "EMA", arguments = list(x = quote(Cl(AMZN)), n = 50, maType = "EMA"), label = "EMA50periods")
out <- add.indicator(strategy.st, name = "RSI", arguments = list(price = quote(Cl(AMZN)), n = 7), label = "RSI720periods")
out <- add.indicator(strategy.st, name = "BBands", arguments = list(HLC = quote(Cl(AMZN)), n = 20, maType = "SMA", sd = 2), label = "Bollinger Bands")

# custom indicator
RSIaverage <- function(price, n1, n2) {
    RSI_1 <- RSI(price = price, n = n1)
    RSI_2 <- RSI(price = price, n = n2)
    calculatedAverage <- (RSI_1 + RSI_2) / 2
    colnames(calculatedAverage) <- "RSI_average"
    return(calculatedAverage)
}
out <- add.indicator(strategy.st, name = "RSIaverage", arguments = list(price = quote(Cl(AMZN)), n1 = 7, n2 = 14), label = "RSIaverage")

# first tests
plot(RSIaverage(Cl(AMZN), n1=7, n2=14)) # for graphing your function results

# load all indicators on my data
test <- applyIndicators(strategy = strategy.st, mktdata = OHLC(AMZN))
subsetTest <- test["2018-01-01/2019-01-01"]
head(subsetTest)

# Moving Average Crossover Strategy - Sample 1
signalPosition <- function(price, ma) {
    # Taking the difference between the prices and the MA timeseries
    price_ma_diff <- price - ma
    price_ma_diff[is.na(price_ma_diff)] <- 0 # replace missing signals with no position
    # Taking the sign of the difference to determine whether the price or the MA is greater
    position <- diff(price_ma_diff)
    position[is.na(position)] <- 0 # replace missing signals with no position
    colnames(position) <- "Signal_position"
    return(position)
}

#out <- add.indicator(strategy.st, name = "signalPosition", arguments = list(price = Cl(AMZN), ma = sma20), label = "signalPosition")
out <- add.indicator(strategy.st, name = "signalPosition", arguments = list(price = Cl(AMZN), ma = ema20), label = "signalPosition1")
out <- add.signal(strategy.st, name = "sigThreshold", arguments = list(column = "Signal_position", threshold = 2, relationship = "gte", cross = TRUE), label = "buy1")
out <- add.signal(strategy.st, name = "sigThreshold", arguments = list(column = "Signal_position", threshold = -2, relationship = "lte", cross = TRUE), label = "sell1")
#add.signal(strategy.st, name = "sigThreshold", arguments = list(data = position, column = "AMZN.Close", threshold = 2, relationship = "gte", cross = TRUE), label = "buy1")
#add.signal(strategy.st, name = "sigThreshold", arguments = list(data = position, column = "AMZN.Close", threshold = -2, relationship = "lte", cross = TRUE), label = "sell1")
# Creating rules
out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "buy1", sigval = TRUE, orderqty = 100, ordertype = 'market', orderside = 'long'), type = 'enter')
out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "sell1", sigval = TRUE, orderqty = 'all', ordertype = 'market', orderside = 'long'), type = 'exit')
#out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "sell1", sigval = TRUE, orderqty = -100, ordertype = 'market', orderside = 'short'), type = 'enter')
#out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "buy1", sigval = TRUE, orderqty = 'all', ordertype = 'market', orderside = 'short'), type = 'exit')

# backtesting
applyStrategy(strategy.st, portfolios=portfolio.st)
out <- updatePortf(portfolio.st)
dateRange <- time(getPortfolio(portfolio.st)$summary)[-1]
out <- updateAcct(portfolio.st, dateRange)
out <- updateEndEq(account.st)
chart.Posn(portfolio.st, Symbol=symbol, TA=c("add_SMA(n=20,col='red')"))

tstats <- tradeStats(portfolio.st, use="trades", inclZeroDays=FALSE)
data.frame(t(tstats))

install.packages("magrittr") # package installations are only needed the first time you use it
install.packages("dplyr")    # alternative installation of the %>%
library(magrittr) # needs to be run every time you start R and want to use %>%
library(dplyr)    # alternatively, this also loads %>%
trades <- tstats %>%
    mutate(Trades = Num.Trades,
        Win.Percent = Percent.Positive,
        Loss.Percent = Percent.Negative,
        WL.Ratio = Percent.Positive/Percent.Negative) %>%
    select(Trades, Win.Percent, Loss.Percent, WL.Ratio)
data.frame(t(trades))

a <- getAccount(account.st)
equity <- a$summary$End.Eq
plot(equity, main = "Equity Curve QQQ")

portfolio <- getPortfolio(portfolio.st)
portfolioSummary <- portfolio$summary
colnames(portfolio$summary)
tail(portfolio$summary)

ret <- Return.calculate(equity, method = "log")
tail(ret)
charts.PerformanceSummary(ret, colorset = bluefocus, main = "Strategy Performance")

rets <- PortfReturns(Account = account.st)
chart.Boxplot(rets, main = "QQQ Returns", colorset= rich10equal)

table.Drawdowns(rets, top=10)

table.CalendarReturns(rets)

table.DownsideRisk(rets)

table.Stats(rets)

chart.RiskReturnScatter(rets)

chart.ME(Portfolio = portfolio.st, Symbol = symbol, type = "MAE", scale = "percent")

chart.ME(Portfolio = portfolio.st, Symbol = symbol, type = "MFE", scale = "percent")

# Moving Average Crossover Strategy - Sample 2
# strategy resetting
rm.strat("my strategy")
out <- initPortf(portfolio.st, symbols = symbol, initDate = start, currency = "USD")
out <- initAcct(account.st, portfolios = portfolio.st, initDate = start, currency = "USD", initEq = initEquity)
initOrders(portfolio.st, initDate = start)
strategy(strategy.st, store = TRUE)
# Indicators
out <- add.indicator(strategy.st, name = "SMA", arguments = list(x = quote(Cl(AMZN)), n = 20, maType = "SMA"), label = "SMA20periods")
out <- add.indicator(strategy.st, name = "SMA", arguments = list(x = quote(Cl(AMZN)), n = 50, maType = "SMA"), label = "SMA50periods")
out <- add.indicator(strategy.st, name = "EMA", arguments = list(x = quote(Cl(AMZN)), n = 20, maType = "EMA"), label = "EMA20periods")
out <- add.indicator(strategy.st, name = "EMA", arguments = list(x = quote(Cl(AMZN)), n = 50, maType = "EMA"), label = "EMA50periods")
# Signals
#out <- add.signal(strategy.st, name = "sigCrossover", arguments = list(columns = c("SMA20periods", "SMA50periods"), relationship = "gte", cross = TRUE), label = "buy")
#out <- add.signal(strategy.st, name = "sigCrossover", arguments = list(columns = c("SMA20periods", "SMA50periods"), relationship = "lte", cross = TRUE), label = "sell")
out <- add.signal(strategy.st, name = "sigCrossover", arguments = list(columns = c("EMA20periods", "EMA50periods"), relationship = "gte", cross = TRUE), label = "buy2")
out <- add.signal(strategy.st, name = "sigCrossover", arguments = list(columns = c("EMA20periods", "EMA50periods"), relationship = "lte", cross = TRUE), label = "sell2")
# Rules
out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "buy2", sigval = TRUE, orderqty = 100, ordertype = 'market', orderside = 'long'), type = 'enter')
out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "sell2", sigval = TRUE, orderqty = 'all', ordertype = 'market', orderside = 'long'), type = 'exit')
#out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "sell2", sigval = TRUE, orderqty = -100, ordertype = 'market', orderside = 'short'), type = 'enter')
#out <- add.rule(strategy.st, name = 'ruleSignal', arguments = list(sigcol = "buy2", sigval = TRUE, orderqty = 'all', ordertype = 'market', orderside = 'short'), type = 'exit')

# backtesting
applyStrategy(strategy.st, portfolios=portfolio.st)
out <- updatePortf(portfolio.st)
dateRange <- time(getPortfolio(portfolio.st)$summary)[-1]
out <- updateAcct(portfolio.st, dateRange)
out <- updateEndEq(account.st)
chart.Posn(portfolio.st, Symbol=symbol) #, TA=c("add_SMA(n=20,col='red')"))

tstats <- tradeStats(portfolio.st, use="trades", inclZeroDays=FALSE)
data.frame(t(tstats))

#install.packages("magrittr") # package installations are only needed the first time you use it
#install.packages("dplyr")    # alternative installation of the %>%
#library(magrittr) # needs to be run every time you start R and want to use %>%
#library(dplyr)    # alternatively, this also loads %>%
trades <- tstats %>%
    mutate(Trades = Num.Trades,
        Win.Percent = Percent.Positive,
        Loss.Percent = Percent.Negative,
        WL.Ratio = Percent.Positive/Percent.Negative) %>%
    select(Trades, Win.Percent, Loss.Percent, WL.Ratio)
data.frame(t(trades))

a <- getAccount(account.st)
equity <- a$summary$End.Eq
plot(equity, main = "Equity Curve QQQ")

ret <- Return.calculate(equity, method = "log")
charts.PerformanceSummary(ret, colorset = bluefocus, main = "Strategy Performance")

rets <- PortfReturns(Account = account.st)
chart.RiskReturnScatter(rets)


ecent_coords <- function(pts){ # pts je vektor sa 4 elementa x, y, e_cent, seed.
  e_cent <- pts[3]/1000
  sigma <- matrix(c(e_cent^2, 0, 0, e_cent^2),2)
  set.seed(pts[4])
  pt_coords <- mvrnorm(1, pts[1:2], sigma)
  return(pt_coords)
}

ni3 <- function(x1, y1, x2, y2){
  ## body
  dEasting <- as.numeric(x2 - x1)
  dNorthing <- as.numeric(y2 - y1)
  atg <- ifelse(dNorthing < 0, atan(dEasting/dNorthing)*180/pi + 180, atan(dEasting/dNorthing)*180/pi)
  ang <- ifelse(atg < 0, atg + 360, atg)
  return(ang)
}

sim_st <- function(survey.net.st, red){
  prj <- st_crs(survey.net.st)
  ro <- 180/pi*3600
  st_data <- survey.net.st %>% st_drop_geometry() %>% .[1, c("x_from", "y_from", "e_cent_from", "seed_from")] %>% as.numeric()
  st_coords_e <- ecent_coords(pts = st_data)
  e_cent_from <- dist(pt1_coords = st_data[1:2], pt2_coords = st_coords_e)*1000

  target_coords_e <- survey.net.st %>% st_drop_geometry() %>% .[, c("x_to", "y_to", "e_cent_to", "seed_to")] %>%  # TODO: seed ne radi.
    apply(., 1, function(x) ecent_coords(pts = as.numeric(x))) %>% t()

  e_cent_to <- data.frame((survey.net.st %>% st_drop_geometry() %>% .[, c("x_to", "y_to")] - target_coords_e)*1000) %>%
    dplyr::rename(e_x = x_to, e_y = y_to) %>%
    dplyr::mutate(e_cent_to = sqrt(e_x^2+e_y^2)) %>%
    .$e_cent_to

  survey.net.st$e_cent_from <- e_cent_from
  survey.net.st$e_cent_to <- e_cent_to

  survey.net.st <- survey.net.st %>%
    dplyr::mutate(x_from = st_coords_e[1],
                  y_from = st_coords_e[2],
                  x_to = target_coords_e[, 1],
                  y_to = target_coords_e[, 2],
                  d = sqrt((x_from-x_to)^2+(y_from-y_to)^2),
                  sd_e_cent_from = sqrt((e_cent_from^2*ro^2)/(2*(d*1000)^2)),
                  sd_e_cent_to = sqrt((e_cent_to^2*ro^2)/(2*(d*1000)^2)),
                  sd_e_cent_dist_from = sqrt(e_cent_from^2/2),
                  sd_e_cent_dist_to = sqrt(e_cent_to^2/2),
                  ni1 = ni3(x_from, y_from, x_to, y_to),
                  z = 360-Hz0,
                  Hz_sim = ifelse(ni1 >= Hz0, z+ni1-360, z+ni1),
                  sd_hz_sq = (e_air^2 + e_focus^2 + sd_Hz^2) + sd_e_cent_from^2 + sd_e_cent_to^2,
                  sd_dist_sq = sd_e_cent_dist_from^2 + sd_e_cent_dist_to^2 + sd_dist^2)

  if(red == TRUE){
    survey.net.st <- survey.net.st %>%
      # dplyr::mutate_at(., .vars = "Hz_sim", ~Hz_sim - Hz_sim[1]) %>%
      dplyr::mutate_at(., .vars = c("sd_hz_sq", "sd_dist_sq"), ~replace(., is.na(.), 0)) %>%
      dplyr::mutate(Hz_sim = ifelse(Hz_sim < 0, Hz_sim + 360, Hz_sim),
                    Hz_sim = Hz_sim - Hz_sim[1],
                    Hz_sim = ifelse(Hz_sim < 0, Hz_sim + 360, Hz_sim), # dplyr::case_when(Hz_sim < 0 ~ Hz_sim + 360, Hz_sim >= 0 ~ Hz_sim),
                    sd_hz_sq = ifelse(is.na(sd_hz_sq), NA, sd_hz_sq + sd_hz_sq[1]),
                    sd_hz_sample = rnorm(dim(survey.net.st)[1], 0, sqrt(sd_hz_sq)),
                    Hz_sim = Hz_sim + sd_hz_sample/3600,
                    Hz = ifelse(round(Hz_sim, 0) == 0, round(Hz_sim, 0), Hz_sim),
                    Hz = pmax(Hz, 0),
                    Hz = ifelse(is.na(sd_Hz), NA, Hz),  #sa ifelse se moze i ostalo resiti da ne stavlja 0 tamo za sd_hz_sq,
                    HzD = floor(Hz), HzM = floor((Hz-HzD)*60), HzS = round(((Hz-HzD)*60-HzM)*60, 1),
                    sd_dist_sample = rnorm(dim(survey.net.st)[1], 0, sqrt(sd_dist_sq)),
                    dist_sim = d + sd_dist_sample/1000,
                    HD = round(dist_sim, 4),
                    HD = ifelse(is.na(sd_dist), NA, HD)) %>%
      as.data.frame() %>%
      dplyr::arrange(ID, Hz) %>%
      st_sf(., crs = prj)
  }else{
    survey.net.st <- survey.net.st %>%
      dplyr::mutate(Hz_sim = ifelse(Hz_sim < 0, Hz_sim + 360, Hz_sim),
                    sd_hz_sample = rnorm(dim(survey.net.st)[1], 0, sqrt(sd_hz_sq)),
                    Hz_sim = Hz_sim + sd_hz_sample/3600,
                    Hz = pmax(Hz, 0),
                    HzD = floor(Hz), HzM = floor((Hz-HzD)*60), HzS = round(((Hz-HzD)*60-HzM)*60, 1),
                    sd_dist_sample = rnorm(dim(survey.net.st)[1], 0, sqrt(sd_dist_sq)),
                    dist_sim = d + sd_dist_sample/1000,
                    HD = round(dist_sim, 4),
                    HD = ifelse(is.na(sd_dist), NA, HD)) %>%
      as.data.frame() %>%
      dplyr::arrange(ID, Hz) %>%
      st_sf(., crs = prj)
  }
  return(survey.net.st)
}

#survey.net = mreza_s; red = TRUE; Hz0 = NA; seed = NULL; type = list("dms", "dec", "rad")

sim_snetobs <- function(survey.net, red = TRUE, Hz0 = NA, seed = NULL, type = list("dms", "dec", "rad")){

  survey.net[[2]] <- survey.net[[2]] %>% dplyr::mutate_at(., .vars = c("e_cent_from", "e_cent_to", "e_focus", "e_air"), ~replace(., is.na(.), 0))

  if(!is.na(Hz0)){
    if(length(Hz0) == 1) Hz0 <- rep(Hz0, length(unique(survey.net[[2]]$from)))
    if(length(Hz0) != length(unique(survey.net[[2]]$from))) stop("Hz0 must be of length either 1 or number of stations")
  }else{
    Hz0 <- sample(1:359, size = length(unique(survey.net[[2]]$from)))
  }

  if(!is.null(seed)){
    if(length(seed) == 1) seed <- rep(seed, length(unique(survey.net[[2]]$from)))
    if(length(seed) != length(unique(survey.net[[2]]$from))) stop("seed must be of length either 1 or the number of stations")
  }else{
    seed <- runif(length(unique(survey.net[[2]]$from)),0,100)#
  }

  nto <- survey.net[[2]] %>% st_drop_geometry() %>% dplyr::mutate(from = as_factor(from)) %>% group_by(from) %>% summarize(n = n())
  survey.net[[2]] <- survey.net[[2]] %>%
    group_by(from) %>%
    mutate(id = row_number()) %>% ungroup() %>%
    dplyr::mutate(Hz0 = rep(Hz0, nto$n),
                  Hz_sim = NA,
                  dist_sim = NA,
                  seed_from = rep(seed, nto$n),
                  seed_to = seed_from + id)

  survey.net[[2]] <- survey.net[[2]] %>% split(., f = factor(.$from)) %>% lapply(., function(x) sim_st(survey.net.st = x, red = red)) %>% do.call(rbind,.) %>% dplyr::arrange(ID)

  # fixed_points <- survey.net[[1]] %>% dplyr::filter(FIX_2D | FIX_1D) %>% .$Name
  #
  # if(length(fixed_points) > 1){
  #   survey.net[[2]][survey.net[[2]]$from %in% fixed_points & survey.net[[2]]$to %in% fixed_points, "HD"] <- NA
  # }

  return(survey.net)
}

#hz = mreza_sim$observations$Hz[2]; sd_Hz = mreza_sim$observations$sd_Hz[2]; e_colim = 15; sd_e_colim = 0.5; ng = 1; faces = "f1f2"

sim_face_hz <- function(hz, sd_Hz, e_colim, sd_e_colim, ng, faces = list("mean", "f1f2"), sd_sd_Hz, seed = NULL, hz_of = TRUE){
  faces = faces[1]
  if(faces == "f1f2"){
    set.seed(seed)
    hz_f1 <- hz - (rnorm(1, e_colim, sd_e_colim))/3600 + rnorm(1, 0, sd_Hz)*sqrt(2)/3600
    if(hz_f1 < 0){hz_f1 + 360}
    if(hz_f1 >= 180){
      set.seed(seed)
      hz_f2 <- (hz_f1 - 180) + (rnorm(1, e_colim, sd_e_colim))/3600 + rnorm(1, 0, sd_Hz)*sqrt(2)/3600
    }else{
      set.seed(seed)
      hz_f2 <- (hz_f1 + 180) + (rnorm(1, e_colim, sd_e_colim))/3600 + rnorm(1, 0, sd_Hz)*sqrt(2)/3600
    }
    hz <- data.frame(hz_f1 = ifelse(hz_f1 < 0, hz_f1 + 360, hz_f1) , hz_f2 = ifelse(hz_f2 < 0, hz_f2 + 360, hz_f2))
  }
  return(hz)
}

#a <- sim_face_hz(hz = mreza_sim$observations$Hz[1], sd_Hz = mreza_sim$observations$sd_Hz[1], e_colim = 15, sd_e_colim = 0.5, ng = 1, faces = "f1f2")
#a
#(a[2]+180-a[1])*3600


 DGERQF Example Program Results

 Minimum-norm solution
    0.2371  -0.4575  -0.0085  -0.5192   0.0239  -0.0543


library(sf)
library(foreign)
library(rgdal)
library(maps)
library(mapview)
library(tmap)
library(osmdata)

df_hous_rent_most_recent <- readRDS("RData/df_hous_rent_most_recent.rds")

# http://www.geoportalpraha.cz/cs/opendata/E9E20135-18B3-4163-B516-45613956B856
# http://www.geoportalpraha.cz/cs/opendata/C4FE893C-81B9-4B4A-BDB4-292479C87E2D
shp_prague_metro_areas <- read_sf("/home/jm/Downloads/mapy_prahy/TMMESTSKECASTI_P_shp/TMMESTSKECASTI_P.shp")
dbf_prague_metro_areas <- read.dbf("/home/jm/Downloads/mapy_prahy/TMMESTSKECASTI_P_shp/TMMESTSKECASTI_P.dbf")
shp_prague_price_map <- read_sf("/home/jm/Downloads/mapy_prahy/SED_CenovaMapa_p_shp/SED_CenovaMapa_p.shp")

# shp_prague_price_map$geometry
# st_geometry(shp_prague_price_map)
# plot(st_geometry(shp_prague_price_map))

# create point data
point <- data.frame(lon=df_hous_rent_most_recent$address_lon, lat=df_hous_rent_most_recent$address_lat)

# alternative way
# as <- data.frame(apply(st_contains(shp_prague_price_map, st_point(data.matrix(point)[1,1:2]), sparse = F), 1, any))

estimatePriceMapCityHall <- function(x, onePoint = T,...) {
  # if a specific lat/lon is given
  if(onePoint){
    datamatrix_point <- st_point(data.matrix(point)[x,1:2])
    containsPointDF <- as.data.frame(st_contains(shp_prague_price_map, datamatrix_point, sparse = F))
    containsPointDF$rn <- rownames(containsPointDF)
    row_num_where_pointResides <- which(containsPointDF$V1 == TRUE)
    return(shp_prague_price_map[row_num_where_pointResides, 1])
  } else {
    datamatrix_point <- st_point(x)
    containsPointDF <- as.data.frame(st_contains(shp_prague_price_map, datamatrix_point, sparse = F))
    containsPointDF$rn <- rownames(containsPointDF)
    row_num_where_pointResides <- which(containsPointDF$V1 == TRUE)
    return(as.numeric(shp_prague_price_map[row_num_where_pointResides, 1])[1])
  }
}

# very SLOW because executes above function each time
# estimatePriceMapCityHall(3, onePoint= T)
# estimatePriceMapCityHall(data.matrix(point), onePoint = F)
vectorOfPrices <- apply(X = data.matrix(point), FUN= estimatePriceMapCityHall, MARGIN = 1, onePoint = F)
# sapply(X = data.matrix(point)[1:2,], FUN= estimatePriceMapCityHall, onePoint = F)
# sasd<-do.call(c, unlist(vectorOfPrices, recursive=FALSE))
df_hous_rent_most_recent$price_sq_meter_offEstimation_cityHall <- vectorOfPrices
#df_hous_rent_most_recent$living_area * df_hous_rent_most_recent$price_sq_meter_offEstimation_cityHall

#https://stackoverflow.com/a/5974908
estimateRightDistrict <- function(x, ...) {
  point <- data.frame(lon=x$address_lon, lat=x$address_lat)
  mydata <- list()
  for(d in 1:nrow(x)) {
    datamatrix_point <- st_point(data.matrix(point)[d,])
    containsPointDF <- as.data.frame(st_contains(shp_prague_metro_areas, datamatrix_point, sparse = F))
    containsPointDF$rn <- rownames(containsPointDF)
    city_district_where_pointResides <- which(containsPointDF$V1 == TRUE)
    districtNamesDF <- dbf_prague_metro_areas[city_district_where_pointResides, c(3, 8)]
    districtNamesDF$NAZEV_MC <- as.character(districtNamesDF$NAZEV_MC)
    districtNamesDF$NAZEV_1 <- as.character(districtNamesDF$NAZEV_1)
    rownames(districtNamesDF) <- NULL
    mydata[[d]] <- districtNamesDF
  }

  districtListNamesDF <- data.frame(t(sapply(mydata,c)))
  districtListNamesDF$NAZEV_MC <- as.character(districtListNamesDF$NAZEV_MC)
  districtListNamesDF$NAZEV_1 <- as.character(districtListNamesDF$NAZEV_1)
  x <- cbind.data.frame(x, districtListNamesDF)

  return(x)
}

df_hous_rent_most_recent <- estimateRightDistrict(df_hous_rent_most_recent)
df_aprt_buy_most_recent <- estimateRightDistrict(df_aprt_buy_most_recent)
df_aprt_rent_most_recent <- estimateRightDistrict(df_aprt_rent_most_recent)
df_hous_buy_most_recent <- estimateRightDistrict(df_hous_buy_most_recent)


data("PlantGrowth")
View(PlantGrowth)

anova_results<-aov(PlantGrowth$weight~PlantGrowth$group, data = PlantGrowth)
summary(anova_results)

R Community/R Stats_Basics Part 1/Assignment7.r


#  James Rekow

connectedSubgraphs = function(g, v, numSubgraphs){

  #  ARGS: g - graph
  #        v - number of vertices in the connected subgraphs to be returned
  #        numSubgraphs - number of connected subgraphs to return
  #
  #  RETURNS: vList - a list of numSubgraphs number of numeric vectors of vertices forming connected
  #                   subgraphs of g, all of which have v vertices, or NULL if no such subgraphs are
  #                   found. May contain repeated subgraphs.

  library(igraph)

  #  get number of vertices in g
  numVertices = vcount(g)

  #  create adjacency matrix for connectivity graph
  adjMat = as.matrix(get.adjacency(g, type = "both"))

  #  make a list to store samples that are not part of any connected subgraphs with
  #  v or more vertices
  unfitVertices = c()

  constructConSubgraph = function(v, numVertices, adjMat, unfitVertices){

    #  ARGS: numVertices - number of vertices in created subgraph
    #        adjMat - adjacency matrix of parent graph
    #        unfitVertices - vector of vertices which are not in any connected subgraph with
    #                        at least numVertices number of vertices (e.g. these might be
    #                        a disconnected subgraph with only a few vertices)
    #
    #  RETURNS: vVec - if a viable connected subgraph was found, this is a numeric vector of
    #                  length numVertices containing the indices of vertices which form a
    #                  connected subgraph of the graph corresponding to the adjacency matrix
    #                  adjMat. If the chosen starting vertex is not part of any connected subgraph
    #                  of sufficient size (at least numVertices number of vertices), then multiply
    #                  the first index of vVec by -1 and return all vertices in the connected subgraph
    #                  of which the starting vertex is a part

    #  samples in the subgraph
    vVec = 0 * (1:v)

    #  potential vertices at which to begin constructing the connected subgraph
    validStartVertices = 1:numVertices

    #  if any unfit vertices have been identified, remove those from the vector of valid
    #  staring samples
    if(length(unfitVertices > 0)){
      validStartVertices = validStartVertices[-which(validStartVertices %in% unfitVertices)]
    }

    #  select the first vertex
    newVertex = sample(validStartVertices, 1)

    #  add the first vertex to the connected subgraph
    vVec[1] = newVertex

    #  remove extraneous edges connecting to newVertex from the adjacency matrix
    adjMat[newVertex, ] = 0

    #  create a vector of vertices which are connected to any of the samples in the existing
    #  connected subgraph
    potentialVertices = which(adjMat[ , vVec[1]] == 1)

    for(ii in 2:v){

      #  if there are no potential samples, but the synthetic cohort is not large enough, mark all
      #  of the synthSamples produced on this iteration as unfit, as they form a connected subgraph
      #  that is disconnected from all of the other samples, but insufficiently large to create a
      #  synthetic cohort with synthM samples
      if(length(potentialVertices) == 0){

        #  return the negative indices of samples if they are not part of any connected synthetic
        #  cohort with at least synthM vertices
        vVec[1] = -vVec[1]
        break

      } #  end if

      ##  select a new sample to add to the synthetic cohort
      if(length(potentialVertices) == 1){
        newVertex = potentialVertices[1]
      } #  end if

      if(length(potentialVertices) > 1){
        newVertex = sample(potentialVertices, 1)
      } #  end if

      #  remove extraneous edges connecting to the newly added vertex from the adjacency matrix
      adjMat[newVertex, ] = 0

      #  remove the newly added vertex from the vector of potential vertices
      potentialVertices = potentialVertices[potentialVertices != newVertex]

      #  identify new potential vertices from non-reduntant edges incident to the newly added vertex
      newPotentialVertices = which(adjMat[ , newVertex] == 1)

      #  add new potential vertices to potential vertices
      potentialVertices = append(potentialVertices, newPotentialVertices)

      #  add the new vertex to vVec
      vVec[ii] = newVertex

    } #  end while loop

    return(vVec)

  } #  end constructConSubgraph function

  #  preallocate list of subgraphs
  vList = vector("list", numSubgraphs)

  #  create variable to store the number of successfully created connected subgraphs
  countSubgraphs = 0

  #  create connected subgraphs until the desired number of connected subgraphs have been obtained,
  #  or it has been determined that there are no connected subgraphs with the desired number of
  #  vertices
  while(length(unfitVertices) < (numVertices - v)){

    #  obtain a connected subgraph, or a vector containing unfit vertices
    vVec = constructConSubgraph(v = v, numVertices = numVertices, adjMat = adjMat,
                                unfitVertices = unfitVertices)

    #  if vVec contains unfit vertices, then add those vertices to unfitVertices
    if(vVec[1] < 0){

      vVec[1] = -vVec[1]
      unfitVertices = append(unfitVertices, vVec)

    } #  end if

    #  if vVec contains the indices of vertices that comprise a connected subgraph, add it to vList
    else{

      vList[[countSubgraphs + 1]] = vVec
      countSubgraphs = countSubgraphs + 1

      #  if the desired number of connected subgraphs have been created, break out of the loop
      if(countSubgraphs == numSubgraphs){
        break
      } #  end if

    } #  end else

  } #  end while loop

  #  return NULL and issue a warning if there are no connected subgraphs with the desired number of
  #  vertices
  if(all(unlist(lapply(vList, is.null)))){
    warning("There are no connected subgraphs with the desired number of vertices.")
    vList = NULL
  } #  end if

  return(vList)

} #  end connectedSubgraphs function


library(plyr)
library(dplyr)
library(ggplot2)

gap_dat <- read.delim("04_gap-merged.tsv")
gap_dat %>% str
# 'data.frame':  3312 obs. of  6 variables:
# $ country  : Factor w/ 187 levels "Afghanistan",..: 1 1 1 1 1 1 1 1 1 1 ...
# $ year     : int  1952 1957 1962 1967 1972 1977 1982 1987 1992 1997 ...
# $ pop      : num  8425333 9240934 10267083 11537966 13079460 ...
# $ gdpPercap: num  779 821 853 836 740 ...
# $ continent: Factor w/ 7 levels "","Africa","Americas",..: 4 4 4 4 4 4 4 4 4 4 ...
# $ lifeExp  : num  28.8 30.3 32 34 36.1 ...

## do we have NAs?
aaply(gap_dat, 2, function(x) sum(is.na(x)))
# continent   country gdpPercap   lifeExp       pop      year
#         0         0         0         0         0         0
## no NAs ... good!

## year
gap_dat$year %>% summary
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max.
##    1950    1967    1982    1980    1996    2007

## confirming we have 1950, 1951, ..., 2007
all.equal(gap_dat$year %>% unique %>% sort, 1950:2007)

## how much data do we have for each year?
ggplot(gap_dat, aes(x = year)) + geom_bar(binwidth = 1)
## most countries have data every five years, e.g. 1952, 1957, 1962,
## and so on

## country
gap_dat$country %>% str  # Factor w/ 187 levels
country_freq <- gap_dat %>%
  group_by(country) %>%
  tally
ggplot(country_freq, aes(x = country, y = n)) +
  geom_bar(stat = "identity")  # ugly but worth seeing
(p <- ggplot(country_freq, aes(x = n)) + geom_bar(binwidth = 1))
p + xlim(c(1, 16))
country_freq$n %>% table
## Most countries have data for 12 years, i.e. the years highlighted
## above.  Some have data for 58 years, which I assume is the maximum.
## Otherwise, there's a little bit of everything between 1 and 58.

## continent
gap_dat$continent %>% levels   # 7 levels for continent, including ""
gap_dat$continent %>% summary
#          Africa Americas     Asia   Europe      FSU  Oceania
#    301      613      343      557     1302      122       74

## 301 rows have no continent data :(

## Is continent data uniform for all rows pertaining to one country?
tmp <- gap_dat %>%
  group_by(country) %>%
  summarize(n_continent = n_distinct(continent))
tmp$n_continent %>% table
## yes, all 187 countries have exactly 1 associated value of continent

## fixing the continent data is a separate task
## to be completed in with a new script

## population
gap_dat$pop %>% summary(digits = 10)
##       Min.    1st Qu.     Median       Mean    3rd Qu.       Max.
##     59412    2678572    7557218   31614891   19585222 1318683096

gap_dat[which.min(gap_dat$pop),]              # we have little countries
## like Aruba w/ 60K people
gap_dat[which.max(gap_dat$pop),]              # ... and big countries
## like China w/ 1.3B people

ggplot(gap_dat,aes(x = pop)) + geom_density() + scale_x_log10()

## life expectancy
gap_dat$lifeExp %>% summary                       # 23 to 83 years
ggplot(gap_dat,aes(x = lifeExp)) + geom_density() # looks plausible
## note bimodality
## modes ~ 42 and 72

gap_dat$gdpPercap %>% summary                # $240 to $114K
#  Min.  1st Qu.   Median     Mean  3rd Qu.     Max.
# 241.2   2515.0   7839.0  11320.0  17360.0 113500.0
## $113K???? really?
gap_dat[which.max(gap_dat$gdpPercap),]        # OIL!  Kuwait, 1957.
ggplot(gap_dat,aes(x = gdpPercap)) + geom_density() # looks plausible
## loooong right tail

## satisfied all is well so far
## next step: populate empty continents


# 4. faza: Analiza podatkov
#NAPOVED VISINE DOBITKA JACKPOTA
v <- tabela3 %>% filter(Dobitek == 'JACKPOT')
v$Datum<-gsub("-([[:digit:]]{1,2})-([[:digit:]]{1,2})","", v$Datum)
povprecje <- v %>% group_by(Datum) %>% summarise(Povprecje = mean(Vrednost))
povprecje$Povprecje <- povprecje$Povprecje/1000000
povprecje$Datum <- as.numeric(povprecje$Datum)
prileganje <- lm(data = povprecje, Povprecje ~ Datum)

g <- data.frame(Datum=seq(2019, 2023, 1))
napoved <- mutate(g, Povprecje=predict(prileganje, g))
options(scipen=999)
graf_regresija <- ggplot(povprecje, aes(x=Datum, y=Povprecje)) +
  geom_point() + geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=napoved, aes(x=Datum, y=Povprecje), color='red', size=2) +
  ggtitle('Napoved povprečne višine dobitka jackpot') +
  ylab('Višina v mio€') + xlab('Leto')

#SHINY
pojavi_v_jackpot <- tabela[c(1,3,4)]
colnames(pojavi_v_jackpot) <- c('Datum','Številke','Število')
pojavi_v_jackpot <- pojavi_v_jackpot %>% filter(Število != '--') %>% filter(Število >0)      #dobila števila ki so bila na dobitnih listkih
pojavi_v_jackpot <- subset(pojavi_v_jackpot, select = -Število)
pojavi_v_jackpot<- pojavi_v_jackpot %>% separate('Številke', c("prve","zadnje"), "-")

pojavi_v_jackpot_prvih<- pojavi_v_jackpot[,-3] %>% separate('prve', c("a", "b","c","d","e"), ",") %>%
  gather(Nepomembno,Stevilka, "a":"e")
pojavi_v_jackpot_prvih <- subset(pojavi_v_jackpot_prvih, select = -Nepomembno)

pojavi_v_jackpot_zadnje<- pojavi_v_jackpot[,-2] %>% separate('zadnje', c("a", "b"), ",") %>%
  gather(Nepomembno,Stevilka, "a":"b")
pojavi_v_jackpot_zadnje <- subset(pojavi_v_jackpot_zadnje, select = -Nepomembno)
pojavi_v_jackpot_zadnje$Stevilka <- as.numeric(pojavi_v_jackpot_zadnje$Stevilka)
pojavi_v_jackpot_prvih$Stevilka <- as.numeric(pojavi_v_jackpot_prvih$Stevilka)

#kolikokrat na dobitnih listkih
pojavi_v_jackpot_prvih <- pojavi_v_jackpot_prvih %>% count(Stevilka)
pojavi_v_jackpot_zadnje <- pojavi_v_jackpot_zadnje %>% count(Stevilka)
colnames(pojavi_v_jackpot_prvih) <- c('Stevilka','Bila na dobitnem Jackpot listku')
colnames(pojavi_v_jackpot_zadnje) <- c('Stevilka','Bila na dobitnem Jackpot listku')

#kolikokrat na listkih
pojavi_prva<- tabela2 %>% filter(Tip == 'prvih_pet') %>% count(Stevilka)
pojavi_zadnja <- tabela2 %>% filter(Tip == 'zadnje_dve') %>% count(Stevilka)
colnames(pojavi_prva) <- c('Stevilka','Bila izžrebana')
colnames(pojavi_zadnja) <- c('Stevilka','Bila izžrebana')
#nazadnje zrebana
nazadnje_prva <-tabela2 %>% filter(Tip == 'prvih_pet') %>% group_by(Stevilka) %>%
  summarise('Bila nazadnje izžrebana' = max(Datum) )

nazadnje_zadnja <- nazadnje_zadnja <-tabela2 %>% filter(Tip == 'zadnje_dve') %>% group_by(Stevilka) %>%
  summarise('Bila nazadnje izžrebana' = max(Datum) )

tabela_prve <- left_join(pojavi_prva,pojavi_v_jackpot_prvih, by = c('Stevilka'='Stevilka') )
tabela_prve <- left_join(tabela_prve, nazadnje_prva, by = c('Stevilka'='Stevilka') )

tabela_zadnje <- left_join(pojavi_zadnja,pojavi_v_jackpot_zadnje, by = c('Stevilka'='Stevilka') )
tabela_zadnje <- left_join(tabela_zadnje, nazadnje_zadnja, by = c('Stevilka'='Stevilka') )

#s katero številko največkrat v paru(za zadnje dve)
par <- tabela2 %>% filter(Tip == 'zadnje_dve') %>% group_by(Datum) %>% summarise (
  'par1' = min(Stevilka), 'par2' =max(Stevilka))
par <-par %>% group_by(par1) %>% count(par2)

table <- function(x){
vparu <- par %>% filter(par1 == x | par2 == x) %>% gather(krneki, Stevilka, par1:par2) %>% filter(Stevilka != x )
vparu$krneki <- NULL
vparu <-vparu[,c(2,1)]
colnames(vparu) <- c('Stevilka','Pojavila v paru z analizirano stevilko')
vparu
}

# podatki <- obcine %>% transmute(obcina, povrsina, gostota,
#                                 gostota.naselij=naselja/povrsina) %>%
#   left_join(povprecja, by="obcina")
# row.names(podatki) <- podatki$obcina
# podatki$obcina <- NULL
#
# # Število skupin
# n <- 5
# skupine <- hclust(dist(scale(podatki))) %>% cutree(n)


# load the wheat data set from uci.edu
wheat <- read.csv("http://archive.ics.uci.edu/ml/machine-learning-databases/00236/seeds_dataset.txt", sep="\t")
# define useful column names
colnames(wheat) <-c("area", "perimeter", "compactness", "length", "width", "asymmetry", "groove", "undefined")
# exclude incomplete cases from the data
wheat <- wheat[complete.cases(wheat),]
# calculate the clusters
fit <- kmeans(wheat, 5)
fit


library(DescTools)
library(tidyverse)
library(gganimate)

#read in data files
co2_df <- read.csv("owid-co2-data.csv",header = TRUE)
data("d.countries")

#calculate GDP per capita
co2_df$gdp_per_cap = co2_df$gdp / co2_df$population

#fil_df <-filter((co2_df), year == 1975)
#fil_df <- filter((fil_df), year != "")
fil_df <- filter((co2_df), year != "")

#left join tables
joined_df <- left_join(x=fil_df, y= d.countries, by=NULL, copy=FALSE)
joined_df <- joined_df[!is.na(joined_df$region),]

#create scatterplot
p <- ggplot(joined_df, aes(x=gdp_per_cap, y=co2_per_capita, size = co2, colour=region)) +
     geom_point(alpha=0.7) +
     ylim(0,80) +
     scale_x_log10(name ="GDP per Capita, USD") +
     ylab("CO2 per capita, metric tonnes")

#animation
anim <- p +
        transition_time(year) +
        labs(title = "Year: {frame_time}")


resanova <- function(data, cl){
    cl = as.factor(as.character(cl))
    m = rowMeans(data, na.rm = T)
    cl.index = split(1:ncol(data), cl)
    nbclasses = length(cl.index)
    MScond = MSerr = 0
    for (i in 1:nbclasses) {
        cli = cl.index[[i]]
        ni = length(cli)
        x = list(means = rowMeans(data[, cli]), vars = matrixStats::rowVars(as.matrix(data[,
        cli])))
        MScond = MScond + ni * ((x$means - m)^2)
        MSerr = MSerr + (ni - 1) * x$vars
    }
    DF1 = (nbclasses - 1)
    MScond = MScond/DF1
    DF2 = ncol(data) - nbclasses
    MSerr = MSerr/DF2
    N = nrow(data)
    f.stat = matrix(MScond/MSerr, nrow = N)
    pval = stats::pf(f.stat, DF1, DF2)
    PVAL = 1 - pval
    names(PVAL) = rownames(data)
    resAnova = data.frame(anova.pvalues = PVAL, anova.adjpvalues = stats::p.adjust(PVAL, method = "fdr"))
    resAnova
}


library(rstan)
library(data.table)
dat <- fread("dat/1In_Welse_May.txt")
standat <- list(nt = nrow(dat), dt = 10, PAR = dat$Light, temp = dat$Temp, do_initial = dat$DO[1], z = 0.47, BP = 0.998815, DO = dat$DO)

fit <- stan(file = 'R/onestation.stan', data = standat, iter = 5000, chains = 3)

samples <- extract(fit, permuted = FALSE)
mcmc_trace(samples, pars = c('P1', 'P2', 'ER24', 'K600', 'sigma', 'gpp24', 'insituER24'))

dims <- grep("do_pr", dimnames(fit)$parameters)
dopr <- apply(samples[,,dims], 3, mean)
dopr_qu <- apply(samples[,,dims], 3, quantile, c(0.025, 0.975))

quartz(w=7, h=7, file="do.png", dpi=72, type='png')
plot(1:145, dat$DO, pch=16, ylim=c(7.2,9.2) , xlab="Time Step", ylab = "DO", cex=0.7)
polygon(x=c(1:145, rev(1:145)), y = c(dopr_qu[1,], rev(dopr_qu[2,])), border=NA, col='#3333ff55')
lines(1:145, dopr, col='#3333ff')
dev.off()


# For drought analysis, determines the number of days in each year
# of the historic record in which flow at a USGS river gauge
# fell below an arbitrary threshold.
# Uses USGS's excellent dataRetrieval package
# tutorial here: https://owi.usgs.gov/R/dataRetrieval.html#1
# Albuquerque gauge to use as example: 08330000

library(dataRetrieval)
library(tidyverse)
library(lubridate)

#get gauge number
siteNo <- readline(prompt="Enter a gauge number: ")

#get threshold
threshold <- as.numeric(readline(prompt="Enter desired threshold: "))

# get station metadata
gauge_meta <- readNWISsite(siteNo)

# reasonable start date
startDate <- "1895-02-01"
endDate <- Sys.Date()

# statistics of interest - this is mean daily discharge
pCode <- "00060"
statCd <- "00003"

# retrieve data
gauge <- as_tibble(gauge <- readNWISdv(siteNo, pCode, startDate, endDate,
                                       statCd))
# use pipes to rename flow variable, select ones we need, and
# add the year
gauge_daily <- gauge %>%
  rename(flow = X_00060_00003) %>%
  select(Date, flow) %>%
  mutate(year=year(Date))

#check to remove spurious negative number that showed up that one time
gauge_daily <- filter(gauge_daily, flow>-1)

tograph <- count(gauge_daily, year, flow<=threshold)
tograph <- filter(tograph, tograph$`flow <= threshold` == TRUE)

# plot
ggplot(data=tograph, aes(x=year, y=n)) +
  xlim(min(gauge_daily$year),max(gauge_daily$year)) +
  geom_bar(stat="identity") +
  labs(title=paste("Days with flow", threshold, "cfs or less"),
       subtitle=gauge_meta$station_nm,
       x="year",
       y="number of days",
       caption="Data: USGS\ngraph: John Fleck, University of New Mexico Water Resources Program")


################################################
## STEP 4. Number of genes vs UMIs filter
#################################################
# This filter focuses on filter cells that are far from the behaviour of the relationship between the number of genes (it measures the number of
# genes in a cell that has at least one count) and the number of UMIs/molecules (the total number of counts in a cell).

############ NEED TO CHECK CONFIG SCHEMA

# OLD SCHEMA

#    "numGenesVsNumUmis": {
#        "filterSettings": {
#            "regressionType": "gam",
#            "smoothing": 13,
#            "upperCutoff": 4.8,
#            "lowerCutoff": 2.1,
#            "stringency": 2.1,
#           "binStep": 0.05
#       },
#       "enabled": true
#   }

# PROPUSAL SCHEMA

#    "numGenesVsNumUmis": {
#        "filterSettings": {
#            "regressionType": "gam",
#             "regressionTypeSettings": {
#                  "gam": {
#                       "p.level": 0.001
#                   }
#               }
#       },
#       "enabled": true
#       "auto": true
#   }

#' @description Filters seurat object based on classifier filter
#' @param config list containing the following information
#'          - enable: true/false. Refering to apply or not the filter.
#'          - auto: true/false. 'True' indicates that the filter setting need to be changed depending on some sensible value (it requires
#'          to call generate_default_values_numGenesVsNumUmis)
#'          - filterSettings: slot with thresholds
#'              - regressionType: String. Regression to be used: {gam}
#'              - regressionTypeSettings: list with the config settings for all the regression type options
#'                          - gam: for the gam option there is only one element:
#'                                - p.level: which refers to  confidence level for deviation from the main trend
#' @export return a list with the filtered seurat object by numGenesVsNumUmis, the config and the plot values
numGenesVsNumUmis <- function(scdata, config){

    # Check wheter the filter is set to true or false
    if (!as.logical(toupper(config$enabled)))
        return(scdata)

    # For now, we can get direcly p.level, but when we add more methods need to be change
    p.level <- config$filterSettings$regressionTypeSettings[[config$filterSettings$regressionType]]$p.level

    # Check if it is required to compute sensible values. Sensible values are based on the funciton "gene.vs.molecule.cell.filter" from the pagoda2 package
    if (as.logical(toupper(config$auto)))
        p.level <-  min(0.001, 1/ncol(scdata))

    # Check wheter the filter is set to true or false
    if (as.logical(toupper(config$enabled))){
        # For now, we are going to suppor only gam as a linear model by robust estimation
        if (config$filterSettings$regressionType=="gam"){

            # We regress the molecules vs the genes. This information are stored in nCount_RNA and nFeature_RNA respectively
            df <- data.frame(molecules = scdata$nCount_RNA, genes = scdata$nFeature_RNA)
            # We take log10 following the plot from the mock-up
            df <- log10(df)
            # Rename the rows to be able to identify the valid cells
            rownames(df) <- colnames(scdata)
            df <- df[order(df$molecules, decreasing = FALSE), ]
            m <- MASS::rlm(genes ~ molecules, data = df)
            # Get the interval based on p.level paramter
            suppressWarnings(pb <- data.frame(predict(m, interval = "prediction",
                level = 1 - p.level, type = "response")))
            # Define the outliers those that are below the lower confidence band and above the upper one.
            outliers <- rownames(df)[df$genes > pb$upr | df$genes < pb$lwr]

            # Keep the ones that are not oulier
            scdata.filtered <- subset(scdata, cells = colnames(scdata)[!colnames(scdata)%in%outliers])
        }
    }else{
        scdata.filtered <- scdata
    }

    # update config
    config$filterSettings$regressionTypeSettings[[config$filterSettings$regressionType]]$p.level <- p.level

    # the result object will have to conform to this format: {data, config, plotData : {plot1, plot2}}
    result <- list(
        data = scdata.filtered,
        config = config,
        plotData = list(
            # Scatter plot which is composed of:
            # x-axis: log_10_UMIs
            # y-axis: log_10_genes
            # bands that are conformed with the upper_cutoff and the lower_cutoff. We can print a band or dotted lines.
            # Q: Should we return the point out the cells that are going to be excluded from the R side or this task can be done in
            # the UI side.
            featuresvsUMIsscatterplot = list(log10_UMIs = df$molecules, log10_genes = df$genes, upper_cutoff = pb$upr,
            lower_cutoff = pb$lwr)
        )
    )

    return(result)
}