########################################################################
#                                                                      #
#   lib/finite-group.rb                                                #
#                                                                      #
########################################################################
=begin
[((<index|URL:index.html>))]
((<Algebra::OperatorDomain>))
/
((<Algebra::Set>))
/
((<Algebra::Group>))
/
((<Algebra::QuotientGroup>))

= Algebra::OperatorDomain

This is the module for the set oprated by groups.
This is included by ((<Group>)).

== File Name:
* ((|finite-group.rb|))

== Methods:

--- right_act(other)
    Returns the products of ((|self|)) and ((|other|)), i.e.
    ((|Set|)) of (({x * y})) for
    ((|x|)) element of ((|self|)) and ((|y|)) element of ((|other|)).

--- act
    Alias of ((<right_act>)).

--- left_act(other)
    Returns the products of ((|self|)) and ((|other|)), i.e.
    ((|Set|)) of (({y * x})) for
    ((|x|)) element of ((|self|)) and ((|y|)) element of ((|other|)).

--- right_quotient(other)
    Returns the ((|Set|)) of right residue classes
    of ((|self|)) by ((|other|)).

--- quotient
--- right_coset
--- coset
    Alias of ((<right_quotient>)).

--- left_quotient(other)
    Returns the ((|Set|)) of left residue classes
    of ((|self|)) by ((|other|)).

--- left_coset
    Alias of ((<left_quotient>)).

--- right_representatives(other)
    Returns the representatives of the
    right residue classes ((<right_quotient>)).

--- representatives
    Alias of ((<right_representatives>)).

--- left_representatives(other)
    Returns the representatives of the
    left residue classes ((<left_quotient>)).

--- right_orbit!(other)
    Extends ((|self|)) operating the elements of ((|other|)) by right action
    ((|*|)).

--- orbit!
    Alias of ((<right_orbit!>)).

--- left_orbit!(other)
    Extends ((|self|)) operating the elements of ((|other|)) by left action
    ((|*|)).

= Algebra::Set

== File Name:
* ((|finite-group.rb|))

== Included Module:

* ((|OperatorDomain|))

== Methods:

--- * act
    Alias of ((<act>))

--- /
    Alias of ((<quotient>)).

--- %
    Alias of ((<representatives>)).

--- increasing_series([x])
    Returns the increasing series begining with ((|x|)).
    This is equivalent to the following code:

      def increasing_series(x = unit_group)
        a = []
        loop do
          a.push x
          if x >= (y = yield x)
            break
          end
          x = y
        end
        a
      end

--- decreasing_series([x])
    Returns the decreasing series begining with ((|x|)).
    This is equivalent to the following code:

      def decreasing_series(x = self)
        a = []
        loop do
          a.push x
          if x <= (y = yield x)
            break
          end
          x = y
        end
        a
      end

= Algebra::Group

== File Name:
* ((|finite-group.rb|))

== SuperClass:
* ((|Set|))

== Included Module:
(None)

== Class Methods:

--- ::new(u, [g0, g1, ...]])
    Returns the group which consists of ((|u|)), ((|g0|)), ((|g1|)), ...
    and whose unity is ((|u|)).

--- ::generate_strong(u, [g0, [g1, ...]])
    Returns the group strongly generated by ((|g0|)), ((|g1|)), ...
    and whose unity is ((|u|)).

== Methods:

--- quotient_group(u)
    Returns the residue class group of the normal subgroup ((|u|)).

--- separate
    Returns the subgroup whose elements makes the block true.

--- to_a
    Returns the array of elements. The first is the unity.

--- unity
    Returns the unity.

--- unit_group
    Returns the unit group.

--- semi_complete!
    Makes ((|self|)) be the semi-group generated by the elements.

--- semi_complete
    Returns the semi-group generated by the elements.

--- complete!
    Makes ((|self|)) be the semi-group generated by the elements.

--- complete
    Returns the group generated by the elements.

--- closed?
    Returns true when ((|self|)) is closed by product and inverse.

--- subgroups
    Returns the all subgroups.

--- centralizer(s)
    Returns the centralize of ((|s|)) in ((|self|)).

--- center
    Returns the center of((|self|)).

--- center?(x)
    Returns true if ((|x|)) is in the center of ((|self|)).

--- normalizer(s)
    Returns the normalizer of ((|s|)) in ((|self|)).

--- normal?(s)
    Returns true if ((|s|)) is a normal subgroup of ((|self|)).

--- normal_subgroups
    Returns the all normal subgroups.

--- conjugacy_class(x)
    Returns the conjugacy class of the element ((|x|)).

--- conjugacy_classes
    Returns the set of all conjucacy claases of ((|self|)).

--- simple?
    Retuns true if ((|self|)) is a simple group.

--- commutator([h])
    Returns the commutator subgroup of ((|self|)) and ((|h|)).
    If the parameter is omitted, ((|h|)) is assumed to be ((|self|)).

--- D([n])
    Returns the ((|n|))-the commutator subgroup.
    (({D(0) = self})) and (({D(n+1) = [D[n], D[n]]})).
    If the parameter ommitted, ((|n|)) is assumed to be 1.

--- commutator_series
    Returns the array (({[D(0), D(1), D(2),..., D(n)]})) .
    This sequence is terminated for ((|n|)) with (({D(n) == D(n+1)})).

--- solvable?
    Returns true if ((|self|)) is solvable.

--- K([n])
    Returns the subgroup definend such that (({K(0) = self})) and
    (({K(n+1) = [self, K[n]})).
    If the parameter is omitted, ((|n|)) is asumed to be 1.

--- descending_central_series
    Returns the descending central series:
    (({[K(0), K(1), K(2),..., K(n)]})).
    This sequence is terminated for ((|n|)) with (({K(n) == K(n+1)})).

--- Z([n])
    Returns the subgroup that defined by: (({Z(0) = unit group})),
    (({Z(n+1) = separate{|x| commutator(Set[x]) <= Z(n-1)}})) .
    If the parameter is omitted, ((|n|)) is assumed to be 1.

--- ascending_central_series
    Returns the array of  ascending central series:
    (({[Z(0), Z(1), Z(2),..., Z(n)]})).
    This sequence is terminated for ((|n|)) such that
    (({Z(n) == Z(n+1)})).

--- nilpotent?
    Returns true if ((|self|)) is nilpotent.

--- nilpotency_class
    Returns the class of nilpotency.
    If ((|self|)) is not nilpotent, returns nil.

= Algebra::QuotientGroup

== File Name:
* ((|finite-group.rb|))

== SuperClass:
* ((|Group|))

== Class Methods:
--- new(u, [g0, [g1,...]])
    Returns the residue class group by ((|u|)) of which the residues are
    ((|u|)), ((|g0|)), ((|g1|)), ... Here ((|u|)) is assumed to be
    the normal subgroup of ((|self|)).

== Methods:

--- inverse
    Returns the inverse element.

--- inv
    Alias of ((<inverse>)).
=end


##' @title
##' Area Under ROC
##'
##' @description
##'
##' \code{mtr_auc_roc}
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @seealso \code{\link{mtr_ar}} \code{\link{mtr_auc_prc}}
##' @author An Chu
##' @include helper-functions.r
##' @examples
##'
##' set.seed(101)
##' pred <- runif(1000)
##' act <- round(pred)
##' pred[sample(1000, 500)] <- runif(500)   # noise
##' mtr_auc_prc(act, pred)
##'
##'
##' @export
mtr_auc_roc <- function(actual, predicted) {

    check_equal_length(actual, predicted)
    check_binary(actual)

    ## This implementation uses Mann–Whitney U test for speed
    ## r <- rank(predicted)            ##
    ## n_pos <- sum(actual == 1)       ##
    ## n_neg <- length(actual) - n_pos ##
    ## sum_r <- sum(r[actual == 1])    ##
    ## auc <- (sum_r - n_pos * (n_pos + 1) / 2) / (n_pos * n_neg) ##

    auc <- auc_(actual, predicted)
    auc
}

##' @title
##' Accuracy Ratio
##'
##' @description
##'
##' \code{mtr_ar}
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @name accuracy_ratio
##' @examples
##'
##' set.seed(101)
##' pred <- runif(1000)
##' act <- round(pred)
##' pred[sample(1000, 500)] <- runif(500)   # noise
##' mtr_accuracy_ratio(act, pred)
##'
##'
##' @export
mtr_ar <- function(actual, predicted) {
    auc <- mtr_auc_roc(actual, predicted)
    ar <- 2 * auc - 1
    ar
}

##' @rdname accuracy_ratio
##' @export
mtr_accuracy_ratio <- mtr_ar

##' @rdname accuracy_ratio
##' @export
mtr_gini_coef <- mtr_ar


getZ = function() {
  return((as.numeric(rawScore) - as.numeric(mean)) / as.numeric(sd))
}

getT = function(z) {
  return(z*10+50)
}

getStanine = function(z) {
  stanine = round(z*2+5)
  stanine = min(max(stanine, 1), 9)
  return(stanine)
}

getSten = function(z) {
  sten = round(z*2+5.5)
  sten = min(max(sten, 1), 10)
  return(sten)
}

getIq = function(z) {
  return(z*15+100)
}

getPercentile = function(z) {
  return(pnorm(z)*100)
}

getPercentileRange = function() {
  ranges = NULL
  score = NULL
  if(scoreType == "percentileRanges") {
    rangesList = fromJSON(percentileRanges)
    if(length(rangesList) > 0) {
      for(i in 1:length(rangesList)) {
        ranges = rbind(ranges, data.frame(rangesList[[i]], stringsAsFactors=F))
      }
    }
  }
  if(scoreType == "percentileRangesTable") {
    rangesTable = fromJSON(percentileRangesTable)
    sql = "SELECT
{{lowerBoundColumn}} AS lowerBound,
{{upperBoundColumn}} AS upperBound,
{{scoreColumn}} AS score
FROM {{table}}"
    ranges = concerto.table.query(sql, params=list(
      lowerBoundColumn=rangesTable$columns$lowerBound,
      upperBoundColumn=rangesTable$columns$upperBound,
      scoreColumn=rangesTable$columns$score,
      table=rangesTable$table
    ))
  }

  if(dim(ranges)[1] > 0) {
    for(i in 1:dim(ranges)[1]) {
      range = ranges[i,]
      range$lowerBound = as.numeric(range$lowerBound)
      range$upperBound = as.numeric(range$upperBound)
      if(!is.na(range$lowerBound) && range$lowerBound > as.numeric(rawScore)) { next }
      if(!is.na(range$upperBound) && range$upperBound <= as.numeric(rawScore)) { next }
      score = as.numeric(range$score)
    }
  }

  return(score)
}

score = switch(scoreType,
               "zScore" = getZ(),
               "tScore" = getT(getZ()),
               "stanine" = getStanine(getZ()),
               "sten" = getSten(getZ()),
               "iq" = getIq(getZ()),
               "percentile" = getPercentile(getZ()),
               "percentileRanges" = getPercentileRange(),
               "percentileRangesTable" = getPercentileRange(),
               "custom" = eval(parse(text=customScoreFormula)),
               "rawScore" = as.numeric(rawScore),
               as.numeric(rawScore)
              )

feedback = NULL
if(feedbackType != "none") {
  ranges = NULL
  if(feedbackType == "ranges") {
    rangesList = fromJSON(feedbackRanges)
    if(length(rangesList) > 0) {
      for(i in 1:length(rangesList)) {
        ranges = rbind(ranges, data.frame(rangesList[[i]], stringsAsFactors=F))
      }
    }
  }
  if(feedbackType == "rangesTable") {
    rangesTable = fromJSON(feedbackRangesTable)
    sql = "SELECT
{{lowerBoundColumn}} AS lowerBound,
{{upperBoundColumn}} AS upperBound,
{{feedbackColumn}} AS feedback
FROM {{table}}"
    ranges = concerto.table.query(sql, params=list(
      lowerBoundColumn=rangesTable$columns$lowerBound,
      upperBoundColumn=rangesTable$columns$upperBound,
      feedbackColumn=rangesTable$columns$feedback,
      table=rangesTable$table
    ))
  }

  if(!is.null(ranges) && dim(ranges)[1] > 0) {
    for(i in 1:dim(ranges)[1]) {
      range = ranges[i,]
      range$lowerBound = as.numeric(range$lowerBound)
      range$upperBound = as.numeric(range$upperBound)
      if(!is.na(range$lowerBound) && range$lowerBound > score) { next }
      if(!is.na(range$upperBound) && range$upperBound <= score) { next }
      feedback = range$feedback
    }
  }
}


##CTE534_Índices=group
##Imagen=raster
##NIR=number 4
##SWIR2=number 10
##NDMI=output raster
##showplots
library(raster)

NDMIsentinel <- function(NIR, SWIR11){
  fNDMI <- function(x,y){(x-y)/(x+y)}
  NDMI <- overlay(NIR, SWIR11, fun=fNDMI)
  return(NDMI)
}


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('multivar')

## ----eval=FALSE---------------------------------------------------------------
## f <- lrm(y ~ sex + race + rcs(age,5) + rcs(weight,5) +
##          rcs(height,5) + rcs(blood.pressure,5))
## plot(anova(f))

## ----echo=FALSE---------------------------------------------------------------
n    <- 20:80
low  <- sqrt((n - 1) / qchisq(.975, n - 1))
hi   <- sqrt((n - 1) / qchisq(.025, n - 1))
m    <- pmax(1/low,hi)
nmin <- min(n[m <= 1.2])

## ----r2adj,echo=FALSE,w=6,h=3.5,ps=9,mfrow=c(1,2),cap='Multiple of $p$ that $n$ must be to achieve a relative drop from $R^{2}$ to $R^{2}_{\\rm adj}$ by the indicated relative factor (left panel, 3 factors) or absolute difference (right panel, 6 decrements)',scap='Comparison of $R^{2}_{\\rm adj}$ to $R^2$'----
require(Hmisc)
# Given R2 solve for multiplier of p that n-1 must be so that adj R2 is
# only a factor of k lower than R2 or is lower by an absolute k
pmultols <- function(R2, k, type=c('relative', 'absolute')) {
  type <- match.arg(type)
  if(type == 'relative')
    ((1/R2) - k) / (1 - k)
    else (1 - R2 + k) /  k
}
r2adj <- function(R2, n, p) 1 - (1 - R2)*(n - 1) / (n - p - 1)
dop <- function(k, type) {
  z <- list()
  R2 <- seq(.01, .99, by=.01)
  for(a in k) z[[as.character(a)]] <-
    list(R2=R2, pfact=if(type=='relative') ((1 / R2) - a) / (1 - a) else
         (1 - R2 + a) /  a)
  labcurve(z, pl=TRUE, ylim=c(0,100), adj=0, offset=3,
           xlab=expression(R^2), ylab=expression(paste('Multiple of ',p)))
}
dop(c(.9, .95, .975), 'relative')
dop(c(.075, .05, .04, .025, .02, .01), 'absolute')

## ----shrink-groupmeans2,child='shrink-groupmeans.Rnw'-------------------------

## ----shrink-groupmeans,ps=7,cap='Sorted means from 20 samples of size 50 from a uniform $[0,1]$ distribution.  The reference line at 0.5 depicts the true population value of all of the means.',scap='Means from 20 $U(0,1)$ samples'----
set.seed(123)
n <- 50
y <- runif(20*n)
group <- rep(1:20,each=n)
ybar <- tapply(y, group, mean)
ybar <- sort(ybar)
plot(1:20, ybar, type='n', axes=FALSE, ylim=c(.3,.7),
     xlab='Group', ylab='Group Mean')
lines(1:20, ybar)
points(1:20, ybar, pch=20, cex=.5)
axis(2)
axis(1, at=1:20, labels=FALSE)
for(j in 1:20) axis(1, at=j, labels=names(ybar)[j])
abline(h=.5, col=gray(.85))

## ----physiol-transcan3,child='physiol-transcan.Rnw'---------------------------

## ----physiol-transcan,h=3,w=6,ps=9,mfrow=c(1,2),cap='Transformations fitted using \\co{transcan}.  Tick marks indicate the two imputed values for blood pressure.',scap='\\protect\\co{transcan} transformations for two physiologic variables'----
require(Hmisc)
getHdata(support)   # Get data frame from web site
heart.rate     <- support$hrt
blood.pressure <- support$meanbp
blood.pressure[400:401]
blood.pressure[400:401] <- NA  # Create two missings
d <- data.frame(heart.rate, blood.pressure)
par(pch=46)   # Figure (*\ref{fig:multivar-physiol-transcan}*)
w <- transcan(~ heart.rate + blood.pressure, transformed=TRUE,
              imputed=TRUE, show.na=TRUE, data=d)
w$imputed$blood.pressure
t <- w$transformed
spe <- round(c(spearman(heart.rate, blood.pressure),
               spearman(t[,'heart.rate'],
                        t[,'blood.pressure'])), 2)

## ----physiol-transcan2,h=3,w=6,ps=9,mfrow=c(1,2),cap=paste('The lower left plot contains raw data (Spearman $\\rho=',spe[1],'$); the lower right is a scatterplot of the corresponding transformed values ($\\rho=',spe[2],'$).  Data courtesy of the SUPPORT study~\\cite{kna95sup}.'),scap='Scatterplot before and after \\co{transcan} transformations'----
plot(heart.rate, blood.pressure)   # Figure (*\ref{fig:multivar-physiol-transcan2}*)
plot(t[,'heart.rate'], t[,'blood.pressure'],
     xlab='Transformed hr', ylab='Transformed bp')

require(Hmisc)
getHdata(support)   # Get data frame from web site
heart.rate     <- support$hrt
blood.pressure <- support$meanbp
blood.pressure[400:401]
blood.pressure[400:401] <- NA  # Create two missings
d <- data.frame(heart.rate, blood.pressure)
par(pch=46)
w <- transcan(~ heart.rate + blood.pressure, transformed=TRUE,
              imputed=TRUE, show.na=TRUE, data=d)
w$imputed$blood.pressure
plot(heart.rate, blood.pressure)
t <- w$transformed
plot(t[,'heart.rate'], t[,'blood.pressure'],
     xlab='Transformed hr', ylab='Transformed bp')
spe <- round(c(spearman(heart.rate, blood.pressure),
               spearman(t[,'heart.rate'],
                        t[,'blood.pressure'])), 2)


setwd("~/R/RCleaningData/UCI HAR Dataset")
## Read in the features table
## Adjust features table to include only those columns that include mean() or std()
f_r<- read.table("features.txt", col.names=c("col_num", "col_name" ), stringsAsFactors=FALSE)
gr1<-grep("mean[^F]|std", f_r$col_name)
features<- f_r[gr1,]
features$col_name<- gsub('\\(\\)', "", features$col_name, perl=TRUE)

## Read in the test table and auxillaries
##
tmp<- read.table("test/X_test.txt")
tmp_data<-tmp[,features$col_num]
colnames(tmp_data)<- features$col_name
tmp_sub<- read.table("test/subject_test.txt", col.names=c("subject"))
tmp_act<- read.table("test/y_test.txt", col.names=c("activity"))
tmp_act[,'activity']<- factor(tmp_act[,'activity'],  labels=c("WALKING", "WALKING_UPSTAIRS", "WALKING_DOWNSTAIRS", "SITTING", "STANDING", "LAYING"))
dataA<- cbind(tmp_sub, tmp_act, tmp_data)

## Read in the training table and auxillaries
##
tmp<- read.table("train/X_train.txt")
tmp_data<-tmp[,features$col_num]
colnames(tmp_data)<- features$col_name
tmp_sub<- read.table("train/subject_train.txt", col.names=c("subject"))
tmp_act<- read.table("train/y_train.txt", col.names=c("activity"))
tmp_act[,'activity']<- factor(tmp_act[,'activity'],  labels=c("WALKING", "WALKING_UPSTAIRS", "WALKING_DOWNSTAIRS", "SITTING", "STANDING", "LAYING"))
dataB<- cbind(tmp_sub, tmp_act, tmp_data)

## Join into 1 dataset
## remove tmp variables
##
activityRecognition<- rbind(dataA, dataB)
rm(list=ls(pattern="tmp"))

## Build new table with means
##
nc<- ncol(activityRecognition)
cnames<-colnames(activityRecognition)[3:nc]
uniqueSubjects<-sort(unique(activityRecognition$subject))
uniqueActivities<- c("WALKING", "WALKING_UPSTAIRS", "WALKING_DOWNSTAIRS", "SITTING", "STANDING", "LAYING")

## make empty dataframe
nodata <- data.frame(Subject=integer(0), Activity=character(0), stringsAsFactors=FALSE)
nodata2<- data.frame(setNames(replicate(66,numeric(0), simplify = F), cnames))
means_df<- cbind(nodata, nodata2)

## loops to calculate means and write data
current_row<- 0
for (i in 1:length(uniqueSubjects)){
    for (j in 1:length(uniqueActivities)){
        current_row<- current_row + 1
        means_df[current_row, 1]<- uniqueSubjects[i]
        means_df[current_row, 2]<- uniqueActivities[j]
        tmp<- filter(activityRecognition, subject==uniqueSubjects[i], activity==uniqueActivities[j])
        for (k in 1:length(cnames)){
            means_df[current_row, 2 + k]<- mean(tmp[,2 + k])
        }
    }
}

filepath<- "summarySamsungActivity.txt"
write.table(means_df, filepath, row.name=FALSE)


malthus <- function(initial_time, initial_population, time_interval, N, growth_rate) {
    time <- initial_time
    population <- initial_population
    times <- c(time)
    populations <- c(population)
    for(i in 1:N) {
        population <- population + growth_rate*time_interval*population
        time <- time + time_interval
        times <- c(times, time)
        populations <- c(populations, population)
    }

    return(data.frame(times, populations))
}

plot(malthus(1900, 76.2, 1, 300, 0.013))


### Reference implementations. Fairly direct translations from the paper

.alldist = function(d, x) sapply(1:nrow(x), function(i) sum((d-x[i, ])^2))

.fastmap = function(x)
{
  d_i = sample(nrow(x), size=1)
  d = x[d_i, ]

  dists = .alldist(d, x)
  a_i = which.max(dists)
  a = x[a_i, ]

  dists = .alldist(a, x)
  b_i = which.max(dists)
  b = x[b_i, ]

  list(a=a, b=b)
}

.cma = function(x, k)
{
  n = ncol(x)

  for (i in 1:k)
  {
    x.i = x[, i:n, drop=FALSE]
    ab = .fastmap(x.i)

    x.i = sweep(x.i, MARGIN=2, STATS=ab$a, FUN="-")

    w = matrix(ab$b - ab$a)
    v = w
    v[1] = w[1] + sign(w[1]) * norm(w, "2")
    v = v / norm(v, "2")
    y = x.i %*% v
    x[, i:n] = x.i - tcrossprod(2*y, v)
  }

  x[, 1:k, drop=FALSE]
}


groupPredict <- function(train,test,groups,K=20,alpha=0.5,t=20,method=1){

###This function is used to predict the subtype of new patients.
#train and test have the same number of view and the same number of columns
# group is the label for the train data
# K, alpha, t are the prameters for SNF.
#K is the number of neighbors
#alpha is the hyperparameter used in constructing similarity network
# t is the number of iterations
#method is a indicator of which method to use to predict the label. method = 0 means to use local and global consistency; method = 1 means to use label propagation.
Wi= vector("list", length=length(train));

for (i in 1:length(train)){
view= standardNormalization(rbind(train[[i]],test[[i]]));
Dist1 = dist2(view, view);
Wi[[i]] = affinityMatrix(Dist1, K, alpha);
}

W = SNF(Wi,K,t);
Y0=matrix(0,nrow(view), max(groups));
for (i in 1:length(groups)) Y0[i,groups[i]]=1;
Y=.csPrediction(W,Y0,method);
newgroups=rep(0,nrow(view));
for (i in 1:nrow(Y)) newgroups[i]=which(Y[i,]==max(Y[i,]));

return (newgroups);
}


# Run the code below to set up the data
# Make a bar plot of the total number of babies with
# the unisex names by sex

# Bonus: Order the bars by the total number of babies, largest to smallest.
# Hint: You need to order the factor levels before sending the data to the plot.
# See the function fct_reorder() in the forcats package

library(tidyverse)
unisex_data <- read_csv("data/unisex.csv")
unisex_counts <- unisex_data %>%
  select(-prop) %>%
  group_by(name, sex) %>%
  summarize(total=sum(n)) %>%
  ungroup()
unisex_counts

# Make a bar plot of the total number of babies with
# the unisex names, colored by sex

ggplot(unisex_counts, aes(x=name, y=total, fill=sex)) +
  geom_bar(stat="identity") +
  labs(x="", y="Total Babies, 1950-2015",
       fill="")

# Bonus: Order the bars by the total number of babies, largest to smallest.
# Hint: You need to order the factor levels before sending the data to the plot.
# See the function fct_reorder() in the forcats package

unisex_counts %>%
  mutate(name=fct_reorder(name, total, .desc=TRUE)) %>%
  ggplot(aes(x=name, y=total, fill=sex)) +
  geom_bar(stat="identity") +
  labs(x="", y="Total Babies, 1950-2015",
       fill="")

# or
ggplot(unisex_counts, aes(x=fct_reorder(name, total, .desc=TRUE), y=total, fill=sex)) +
  geom_bar(stat="identity") +
  labs(x="", y="Total Babies, 1950-2015",
       fill="")


library(ggvis)

# Discrete colours for fill and a manual scale for opacity
mtcars %>% ggvis(x = ~wt, y = ~mpg, fill = ~factor(cyl), fillOpacity = ~hp) %>%
  layer_points() %>%
  scale_numeric("opacity", range = c(0.2, 1))

# Control the domain of a scale - the y scale will go from 0 to whatever the
# maximum of the data is.
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>% layer_points() %>%
  scale_numeric("y", domain = c(0, NA))

# Control the y range with a slider
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>% layer_points() %>%
  scale_numeric("y", domain = input_slider(0, 50, c(10, 40), label = "Y range"))

# Control the lower y range with a slider
# FIXME: clamp=TRUE is necessary to work around a sizing bug
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>% layer_points() %>%
  scale_numeric("y", clamp = TRUE,
    domain = input_slider(0, 50, label = "Lower Y",
                          map = function(x) c(x, NA))
  )

# Multiple x scales
mtcars %>% ggvis(y = ~mpg, size := 25) %>%
  layer_points(prop("x", quote(disp), scale = "xdisp")) %>%
  layer_points(prop("x", quote(wt), scale = "xwt"), fill := "red") %>%
  add_axis("x", "xdisp", orient = "top") %>%
  add_axis("x", "xwt", orient = "bottom",
    properties = axis_props(
      ticks = list(stroke = "red"),
      labels = list(fill = "red")
    )
  )

# Unscaled values in the data
mtc <- mtcars
mtc$color <- c("red", "teal", "#cccccc", "tan")
mtc %>% ggvis(x = ~wt, y = ~mpg, fill := ~color) %>% layer_points()

# Unscaled constant
mtcars %>% ggvis(x = ~wt, y = ~mpg, fill := "red") %>% layer_points()


cutoff <- 40
baseline <- 0.001
enrich <- 0.05
ngenes <- 1e4
top <- sample(c(0,1), size = cutoff, replace = T, prob = c(1-enrich, enrich))
bot <- sample(c(rep(0, (1-baseline) * (ngenes - cutoff) + sum(top)), rep(1, ngenes*baseline - sum(top))),
                size = ngenes-cutoff, replace = F)
alldat <- c(top, bot)
epval <- numeric(ngenes)
escore <- numeric(ngenes)
for (i in 1:ngenes) {
  epval[i] <- phyper(
    q = sum(ranked_list[1:i])-1,
    m = baseline*ngenes,
    n = (1-baseline) * ngenes,
    k = i,
    lower.tail = F,
    log.p = F
  )
  expected = baseline * i
  ## ENRICMENT FUNCTION:
  escore[i] <- sum(alldat[1:i]) - expected
}
plot(x=1:ngenes, y=escore, type='l', xlim=c(0,100))
plot(x=1:ngenes, y=escore, type='l')
abline(h=0)
# plot(x=1:ngenes, y=epval)
# abline(h=log(0.05), col = 'red', lty=2)


# Fit SSD to CCME data using data cloning and compare results to straight likelihood method
# I will ignore for now the repeated measurements on the same species
# This just illustrates the congruence of results between the two methods

# This is a Bayesian analysis using data cloning to get the MLEs (see Lele's paper)

# Copyright 2017 Province of British Columbia
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and limitations under the License.

set.seed(23423423)

library(dclone)
library(fitdistrplus)
library(ggplot2)
library(grid)
library(plyr)
library(rjags)

#load test data
endpoints<-read.csv("Cd_BC_Multi.csv",header=TRUE,as.is=TRUE, strip.white=TRUE)
endpoints$Source <- "BC Cd"
head(endpoints)

sd(log(endpoints$Conc))

###############################################################################
# Fit a Bayesian model for the SSD using a
# log-normal model

model.clone <- dclone::custommodel("
model {
  # Input data for Conc   - concentration
  #                Ndata - number of data values
  #
  # Parameters for lognormal distribution
  #   mu, sigma - intercept and slope (on log scale)

  # likelihood function for observed data for each clone
  for(k in 1:K){
     for(i in 1:Ndata){
       Conc[i,k]  ~ dlnorm(mu, tau)
     }
  }

  # compute the log-likelihood (only need to do for the original set of data in column 1)
  for(i in 1:Ndata){
      loglikc[i] <- log(dlnorm(Conc[i,1], mu, tau))
  }

  loglik <- sum(loglikc[])  #  loglikelihood?

  # priors and derived variables
  tau <- 1/(sigma*sigma)
  sigma  ~ dunif(.01, 5)

  mu ~ dnorm(0, .001)

  # estimate the HC[5]
  hc.log <- qnorm(.05, mu, tau)  # the HC[5] on the log scale
  hc     <- exp(hc.log)

}  # end of model.jags
")

# Next create the data.txt file.

# data for entrainment
Ndata <- nrow(endpoints)

# The datalist will be passed to JAGS with the names of the data values.
data.list.clone <- list(Ndata   = Ndata,
                       Conc    = dcdim(data.matrix(endpoints$Conc)),
                       K=1)
data.list.clone

# Next create the initial values.
# If you are using more than one chain, you need to create a function
# that returns initial values for each chain.

init.list <- list(
  list(mu=mean(logConc), tau=1/var(logConc), tau_obs=1/mean(species.sd$sd.log, na.rm=TRUE)^2)
)  # end of list of lists of initial values

# Next create the list of parameters to monitor.
# The deviance is automatically monitored.
#
monitor.list <- c("mu","sigma","loglik",
                  "hc","hc.log") # parameters to monitor

# Finally, the actual call to JAGS
fit.clone <- dc.fit(data  =data.list.clone,
                    params=monitor.list,
                    model =model.clone,
                    n.clones=c(1,2,4,8,16),
                    unchanged=c("Ndata"),
                    multiply="K")

summary(fit.clone)
coef(fit.clone)
dcsd(fit.clone)
vcov(fit.clone)
confint(fit.clone)

# use fitdistrplus to estimate the parameters
library(fitdistrplus)

fit <- fitdist( endpoints$Conc, "lnorm")
fit
logLik(fit)
quantile(fit, probs=.05)
fit.boot <- bootdist(fit, niter=200)
quantile(fit.boot, probs=.05)


##' Predicts the h-index for a researcher
##'
##' Predicts the h-index for a researcher each year for ten years into
##' the future using Acuna et al's method (see source).  The model was
##' fit to data from neuroscience researchers with an h-index greater
##' than 5 and between 5 to 12 years since publishing their first
##' article.  So naturally if this isn't you, then the results should
##' be taken with a large pinch of salt.  For more caveats, see
##' \url{http://simplystatistics.org/2012/10/10/whats-wrong-with-the-predicting-h-index-paper/}.
##'
##' @note A scientist has an h-index of n if he or she publishes n
##' papers with at least n citations each.  Values returned are
##' fractional so it's up to your own vanity whether you want to round
##' up or down.
##'
##' @source DE Acuna, S Allesina, KP Kording (2012) Future impact:
##' Predicting scientific success.  Nature 489,
##' 201-202. \url{http://dx.doi.org/10.1038/489201a}.  Thanks to DE
##' Acuna for providing the full regression coefficients for each year
##' ahead prediction.
##' @param id a character string giving the Google Scholar ID
##' @param journals optional character vector of top
##' journals. See \code{\link{get_num_top_journals}} for more details.
##' @return a data frame giving predicted h-index values in future
##' @details Since the model is calibrated to neuroscience
##' researchers, it is entirely possible that very strange
##' (e.g. negative) h-indices will be predicted if you are a
##' researcher in another field.  A warning will be displayed if the
##' sequence of predicted h-indices contains a negative value or is
##' non-increasing.
##' @export
##' @examples {
##'    ## Predict h-index of original method author
##'   id <- "GAi23ssAAAAJ"
##'   df <- predict_h_index(id)
##' }
predict_h_index <- function(id, journals) {
  id <- tidy_id(id)
  n <- get_num_articles(id) # number of articles written
  h <- get_profile(id)$h_index
  y <- as.numeric(format(Sys.Date(), "%Y")) - get_oldest_article(id)
  j <- get_num_distinct_journals(id)

  if (missing(journals)) {
    q <- get_num_top_journals(id)
  } else {
    q <- get_num_top_journals(id, journals)
  }

  ## Regression coefficients, courtesy of Daniel Acuna
  coefs <- c(
             1,0.760,0.373,0.967,-0.069,0.018,0.033,
             2,1.413,0.781,0.936,-0.132,0.018,0.064,
             3,2.227,1.105,0.903,-0.193,0.027,0.096,
             4,3.196,1.386,0.871,-0.274,0.039,0.145,
             5,3.997,1.578,0.858,-0.345,0.063,0.198,
             6,4.752,1.671,0.817,-0.377,0.117,0.282,
             7,5.741,1.761,0.761,-0.420,0.170,0.394,
             8,6.531,1.796,0.669,-0.420,0.252,0.508,
             9,7.482,1.653,0.561,-0.415,0.383,0.629,
             10,8.734,1.326,0.478,-0.411,0.522,0.823)
  coefs.m <- matrix(coefs, nrow=10, byrow=TRUE)
  coefs <- coefs.m[,-1]
  vals <- c(1, sqrt(n), h, y, j, q)

  ## Calculate the h-index predictions
  h.pred <- coefs %*% vals
  h.vals <- c(h, h.pred)

  ## Check for sensible values
  standard.warning <- "You're probably not a neuroscientist.  Please read the documentation for information on the limitations of this function."

  if (any(diff(h.vals)<0))
      warning(paste0("Decreasing h-values predicted. ", standard.warning))

  if (any(h.vals<0))
      warning("Negative h-values predicted. ", standard.warning)

  return(data.frame(years_ahead=c(0:10), h_index=h.vals))

}


library(pROC)

# load gene expression data
fn.ge = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_GE_matrix_gene.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()
fn.si = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_sample_info_2_CD38hi.txt")
info = fread(fn.si)

si = info$time==0 # select day 0 samples
dat = dat[,si]
info = info[si,]

niter = 500
set.seed(123)
cc.rob.rand = matrix(NA,nrow=nrow(dat),ncol=niter)
rownames(cc.rob.rand) = rownames(dat)
colnames(cc.rob.rand) = paste0("i",1:niter)

ns = 2
cmb = combn(1:ncol(dat), ns)

for (i in 1:niter) {
  cat(i,"")
  # calculate robust regression removing ns samples --------
  cc.rob = matrix(NA,nrow=nrow(dat),ncol=ncol(cmb))
  for (ic in 1:ncol(cmb)) {
    ridx = cmb[,ic]
    irand = sample(1:(ncol(dat)-2))
    cc.rob[,ic] = cor(t(dat[,-ridx]), info$CD38hi[-ridx][irand], method="spearman", use="pairwise.complete.obs")
  } # ic
  cc.rob.mean = apply(cc.rob,1,mean)
  cc.rob.sd = apply(cc.rob,1,sd)
  cc.rob.1cv = cc.rob.mean / cc.rob.sd

  cc.rob.rand[,i] = cc.rob.1cv
} # i

fn.rand = file.path(PROJECT_DIR, "generated_data", "CHI",
                    sprintf("gene_sig_random_%d_from_all.txt",niter))
fwrite(cc.rob.rand, file=fn.rand, sep="\t")


#
# Test package against LV dynamics
#

require(deSolve)
require(ggplot2)
require(tidyr)
require(tibble)
#
#

parms <- tibble::tribble(
  ~a1,   ~a2,  ~a3,    ~a4,   ~a5,  ~a6,    ~r,
    0,  4e-6, 3e-5,   2e-5,     0,    0,  -0.01,
-1e-5, -1e-4,    0,   1e-4,  6e-5,    0, -0.001,
-1e-4,     0,    0,      0,  6e-5, 5e-5,  -0.01,
-1e-4,  1e-4,    0,  -5e-4, -1e-5,    0,   0.08,
    0, -1e-4,-1e-4,      0, -1e-6,    0,   0.04,
    0,     0,-1e-4,   2e-4,     0,    0,   0.00
)

# Solve for equilibrium populations
#
eq <- lm(r ~ . + 0, parms)
-coef(eq)

# Generalized Lotka-Volterra 6 species  equation
#
GLV_det<-function(Time,State,Pars){
  with(as.list(c(State, Pars)), {
    A <- matrix(Pars,6,7)
    dP1 <- N1*(A[1,7]+A[1,1]*N1+A[1,2]*N2+A[1,3]*N3+A[1,4]*N4+A[1,5]*N5+A[1,6]*N6)
    dP2 <- N2*(A[2,7]+A[2,1]*N1+A[2,2]*N2+A[2,3]*N3+A[2,4]*N4+A[2,5]*N5+A[2,6]*N6)
    dP3 <- N3*(A[3,7]+A[3,1]*N1+A[3,2]*N2+A[3,3]*N3+A[3,4]*N4+A[3,5]*N5+A[3,6]*N6)
    dP4 <- N4*(A[4,7]+A[4,1]*N1+A[4,2]*N2+A[4,3]*N3+A[4,4]*N4+A[4,5]*N5+A[4,6]*N6)
    dP5 <- N5*(A[5,7]+A[5,1]*N1+A[5,2]*N2+A[5,3]*N3+A[5,4]*N4+A[5,5]*N5+A[5,6]*N6)
    dP6 <- N6*(A[6,7]+A[6,1]*N1+A[6,2]*N2+A[6,3]*N3+A[6,4]*N4+A[6,5]*N5+A[6,6]*N6)

    return(list(c(dP1,dP2,dP3,dP4,dP5,dP6)))
  })
}

# Simulate the model by integration
#
pars  <- c(A <- as.matrix(parms[,1:6]),
           r<- as.numeric(parms$r)
)

yini  <- c(N1 = 100,N2=100,N3=100,N4=100,N5=100,N6=100)
out   <- as.data.frame(ode(yini, 1:600, GLV_det, pars))
df <- gather(out,key="Species",value="N", -time)
ggplot(df, aes(time,N,colour=Species)) + geom_line(size=.5)

A <- as.matrix(parms[,1:6])
r<- as.numeric(parms$r)
m <- c(0,0,0,0,0,0)
#NumericMatrix metaW,NumericVector m, NumericVector r, NumericVector ini, int time, double tau=0.01)
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,1000,0.1)
df1 <- as.data.frame(t(A1$STime))
df1$time <- 1:1000
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,1000,0.1)
df2 <- as.data.frame(t(A1$STime))
df2$time <- 1:1000

df1 <- rbind(df1,df2 )

names(df1)[1:6] <- unique(df$Species)
require(tidyr)
df1 <- gather(df1,key="Species",value="N", N1:N6)
require(ggplot2)
ggplot(df, aes(time,N,colour=Species)) + geom_line() + geom_point(data=df1,aes(time,N,colour=Species),size=0.1) + theme_bw() + scale_color_viridis_d()

ggplot(df1, aes(time,N,colour=Species)) + geom_point(size=0.1) +  theme_bw() + scale_color_viridis_d()

#
# LV with migration
#

parms <- tibble::tribble(
  ~a1,   ~a2,  ~a3,    ~a4,   ~a5,  ~a6,    ~r,   ~m,
    0,  4e-6, 3e-5,   2e-5,     0,    0,  -0.01, 0.1,
-1e-5, -1e-4,    0,   1e-4,  6e-5,    0, -0.001, 0.1,
-1e-4,     0,    0,      0,  6e-5, 5e-5,  -0.01, 0.1,
-1e-4,  1e-4,    0,  -5e-4, -1e-5,    0,   0.08, 0.1,
    0, -1e-4,-1e-4,      0, -1e-6,    0,   0.04, 0.1,
    0,     0,-1e-4,   2e-4,     0,    0,   0.00, 0.1
)

# Generalized Lotka-Volterra with migration 6 species  equation
#
GLVM_det<-function(Time,State,Pars){
  with(as.list(c(State, Pars)), {
    A <- matrix(Pars,6,8)
    dP1 <- N1*(A[1,7]+A[1,1]*N1+A[1,2]*N2+A[1,3]*N3+A[1,4]*N4+A[1,5]*N5+A[1,6]*N6)+A[1,8]
    dP2 <- N2*(A[2,7]+A[2,1]*N1+A[2,2]*N2+A[2,3]*N3+A[2,4]*N4+A[2,5]*N5+A[2,6]*N6)+A[2,8]
    dP3 <- N3*(A[3,7]+A[3,1]*N1+A[3,2]*N2+A[3,3]*N3+A[3,4]*N4+A[3,5]*N5+A[3,6]*N6)+A[3,8]
    dP4 <- N4*(A[4,7]+A[4,1]*N1+A[4,2]*N2+A[4,3]*N3+A[4,4]*N4+A[4,5]*N5+A[4,6]*N6)+A[4,8]
    dP5 <- N5*(A[5,7]+A[5,1]*N1+A[5,2]*N2+A[5,3]*N3+A[5,4]*N4+A[5,5]*N5+A[5,6]*N6)+A[5,8]
    dP6 <- N6*(A[6,7]+A[6,1]*N1+A[6,2]*N2+A[6,3]*N3+A[6,4]*N4+A[6,5]*N5+A[6,6]*N6)+A[6,8]

    return(list(c(dP1,dP2,dP3,dP4,dP5,dP6)))
  })
}

pars <- as.matrix(parms)
yini  <- c(N1 = 0,N2=0,N3=0,N4=0,N5=0,N6=0)
out   <- as.data.frame(ode(yini, 1:600, GLVM_det, pars))
df <- gather(out,key="Species",value="N", -time)
ggplot(df, aes(time,N,colour=Species)) + geom_line(size=.5)
calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,600])

A <- as.matrix(parms[,1:6])
r<- as.numeric(parms$r)
m <-as.numeric(parms$m)
#NumericMatrix metaW,NumericVector m, NumericVector r, NumericVector ini, int time, double tau=0.01)
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,600,0.1)
df1 <- as.data.frame(t(A1$STime))
df1$time <- 1:600
A1 <- metaWebNetAssemblyGLV(A,m,r,yini,600,0.1)
df2 <- as.data.frame(t(A1$STime))
df2$time <- 1:600

df1 <- rbind(df1,df2 )

names(df1)[1:6] <- unique(df$Species)
require(tidyr)
df1 <- gather(df1,key="Species",value="N", N1:N6)
require(ggplot2)
ggplot(df, aes(time,N,colour=Species)) + geom_line() + geom_point(data=df1,aes(time,N,colour=Species),size=0.1) + theme_bw() + scale_color_viridis_d()

#
# Generate random adjacency matrix
#
require(igraph)

#### ER random graph
build.random.structure <- function(n, connectance){
  S <- matrix(0, nrow = n, ncol = n)
  S[upper.tri(S)] <- rbinom(n * (n - 1)/2,size = 1, p = connectance)
  S[lower.tri(S)] <- rbinom(n * (n - 1)/2,size = 1, p = connectance)
  #S <- S + t(S)
  #diag(S) <- 0
  return(S)
}

#
# Size 106, links 4623
#
require(multiweb)

C <- 4623/(106*106)

#
# Generate random GLV matrix
#

A <- generateRandomGLVadjMat(100,0.01,c(0.3,0.3,0.3,0.05,0.05))
A1 <- generateGLVparmsFromAdj(A,0.01,0.01)
yini <- rep(10,times=nrow(A1$interM))
calcPropInteractionsGLVadjMat(A ,yini)

yini <- rep(0,times=nrow(A1$interM))
A2 <- metaWebNetAssemblyGLV(A1$interM,A1$m,A1$r,yini,600,0.1)
A2$STime[,600]
df1 <- as.data.frame(t(A2$STime))
df1$time <- 1:600
require(tidyr)
require(ggplot2)
require(dplyr)
df1 <- gather(df1,key="Species",value="N", -time)
ggplot(filter(df1,time>500), aes(time,N,colour=Species)) + geom_line() +  theme_bw() + scale_color_viridis_d(guide=FALSE)
ggplot(df1, aes(time,N,colour=Species)) + geom_line() +  theme_bw() + scale_color_viridis_d(guide=FALSE)

df1 <- data_frame(time=1:600,S = A2$S,C = A2$L/(A2$S*A2$S))
ggplot(filter(df1,time>500), aes(time,S)) + geom_line() +  theme_bw() + scale_color_viridis_d()
ggplot(df1, aes(time,S)) + geom_line() +  theme_bw() + scale_color_viridis_d()

ggplot(filter(df1,time>500), aes(time,C)) + geom_line() +  theme_bw() + scale_color_viridis_d()
ggplot(df1, aes(time,C)) + geom_line() +  theme_bw() + scale_color_viridis_d()
ggplot(df1, aes(S,C)) + geom_line() +  theme_bw() + scale_color_viridis_d()

calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,600])

# With no migration
yini <- rep(100,times=nrow(A1$interM))
A1$m <- rep(0.0, 100)
A2 <- metaWebNetAssemblyGLV(A1$interM,A1$m,A1$r,yini,600,0.1)
A2$STime[,600]
df1 <- as.data.frame(t(A2$STime))
df1$time <- 1:600
require(tidyr)
require(ggplot2)
require(dplyr)
df1 <- gather(df1,key="Species",value="N", -time)
ggplot(df1, aes(time,N,colour=Species)) + geom_line() +  theme_bw() + scale_color_viridis_d(guide=FALSE)

calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,600])

#
# To igraph
#
require(multiweb)
require(igraph)
diag(A2$A) <- 0
g <- graph_from_adjacency_matrix(A2$A,mode="directed")
plotTrophLevel(g,modules=TRUE)
calcTopologicalIndices(g)

#
# More testing
#

A <- generateRandomGLVadjMat(100,0.05,c(0.2,0.5,0.1,0.0,0.0))
A
A1 <- generateGLVparmsFromAdj(A,0.1,0.01)

yini <- rep(1,times=nrow(A1$interM))

calcPropInteractionsGLVadjMat(A1$interM,yini)

A2 <- metaWebNetAssemblyGLV(A1$interM,A1$m,A1$r,yini,100,0.1)

df <- as.data.frame(t(A2$STime))
df$Time <- 1:100
require(tidyr)
df <- gather(df,key="Species",value="N", V1:V100)
require(ggplot2)
ggplot(df, aes(Time,N,colour=Species)) + geom_line() +guides(colour=FALSE)

calcPropInteractionsGLVadjMat(A1$interM,A2$STime[,100])

# Delete diagonals
diag(A2$A) <- FALSE
# Delete columns and rows with no species
d <- A2$STime[,100]!=0
A <- A2$A[d,d]
# Size of d == Number of species
sum(d)==A2$S[100]

g <- graph_from_adjacency_matrix(A,mode="directed")
g
plotTrophLevel(g)
calcTopologicalIndices(g) # Trophic level do not work with multiple interactions types

require(NetIndices)
TrophInd(A2$A)


## library(devtools)
## library(roxygen2)
## library(testthat)
##
## Build and Reload Package:  'Ctrl + Shift + B'
## Check Package:             'Ctrl + Shift + E'
## Test Package:              'Ctrl + Shift + T'
## Document:                  'Ctrl + Shift + D'

##
#' @title Scaling of X-Axis (as vector or as scalar) to [-1,1]
#' @param x_axis urspruengliche beliebige X-Achse (Vektor)
#' @param x_val Einzelwert auf X-Achse (Skalar)
#' @return x_cheb_scaled Abhaengig von Eingangsparametern: Skalierte X-Achse (Vektor) oder skalierter Einzelwert anhand vorgegebener X-Achse
#' @description
#' \code{cheb_scale} skaliert beliebige X-Achse auf Achse, die fuer Polynom-fits vertraeglich ist.
#' @export
cheb_scale <- function(x_axis, x_val = NA) {#, scale) {
  ## Funktion zur Skalierung von Stuetzpunkten
  ## von beliebigen Gittern auf [-1, 1]
  ## ##
  if ( is.na(x_val) == TRUE ) { # Fuer Skalierung von vektoriellen Achsen
    x_cheb_scaled <- 2 * (x_axis - min(x_axis)) / (max(x_axis) - min(x_axis)) - 1
  }
  if ( is.na(x_val) == FALSE ) { # Fuer Skalierung von Einzelwert(en) auf Achse
    x_cheb_scaled <- 2 * (x_val - min(x_axis)) / (max(x_axis) - min(x_axis)) - 1
  }
  return(x_cheb_scaled)
}

##
#' @title Rescaling of X-Axis (as vector or as scalar)
#' @param x_cheb skalierte X-Achse (Skalar oder Vektor)
#' @param x_axis beliebige X-Achse (Vektor)
#' @return x_rescaled reskalierte X-Achse (Skalar oder Sektor)
#' @description
#' cheb_rescale reskaliert die fuer den Fit erzeugte Achse auf die Urspruengliche
#' @export
cheb_rescale <- function(x_cheb, x_axis) {
  ## Funktion zur Reskalierung vom [-1, 1]-Gitter
  ## auf das Ursprungsgitter (in diesem Fall - Lat)
  x_rescaled <- (1/2 * (x_cheb + 1) * (max(x_axis) - min(x_axis))) + x_axis[1]
  return(x_rescaled)
}

##
#' @title Generating Chebyshev Polynomials of first kind
#' @param x_axis beliebige X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @return cheb_t Chebyshev-Polynome Erster Art (Vektor)
#' @description
#' cheb_1st erzeugt Chebyshev Polynome erster Art aus beliebiger X-Achse
#' @export
cheb_1st <- function(x_axis, n){
  ## Funktion zur Erzeugung von Chebyshev-Polynomen Erster Art
  ## ## Fehlerabfrage nur mit Schwellwert. Korrigieren! Auch cheb_2nd
  x_cheb <- if (length(x_axis) > 7) cheb_scale(x_axis) else x_axis
  m <- n + 1
  # Rekursionsformel Wiki / Bronstein
  cheb_t_0 <- 1;  cheb_t_1 <- x_cheb;
  cheb_t <- cbind(cheb_t_0, cheb_t_1)
  if (n >= 2) {
    for (i in 3:m) {
      cheb_t_i <- 2 * x_cheb * cheb_t[,(i - 1)] - cheb_t[,(i - 2)]
      cheb_t <- cbind(cheb_t, cheb_t_i)
      rm(cheb_t_i)
    }
  }
  return(cheb_t)
}

##
#' @title Generating Chebyshev Polynomials of second kind
#' @param x_axis beliebigie X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @return cheb_u Chebyshev-Polynome Zweiter Art (Vektor)
#' @description
#' cheb_2nd erzeugt Chebyshev Polynome zweiter Art aus beliebiger X-Achse
#' @export
cheb_2nd <- function(x_axis, n){
  ## Funktion zur Erzeugung von Chebyshev-Polynomen Zweiter Art
  ## ##
  x_cheb <- if (length(x_axis) > 7) cheb_scale(x_axis) else x_axis
  m <- n + 1
  cheb_u_0 <- 1; cheb_u_1 <-  2*x_cheb
  cheb_u <- cbind(cheb_u_0, cheb_u_1)
  if (n >= 2) {
    for (i in 3:m) {
      cheb_u_i <- 2 * x_cheb * cheb_u[,(i - 1)] - cheb_u[,(i - 2)]
      cheb_u <- cbind(cheb_u, cheb_u_i)
      rm(cheb_u_i)
    }
  }
  return(cheb_u)
}

##
#' @title Calculation of Values of the model fit
#' @param x_axis beliebige X-Achse (Skalar oder Vektor)
#' @param cheb_coeff Chebyshev-Koeffizienten aus Least-Squares-Verfahren (Vektor)
#' @return cheb_model gefiltertes Modell (Skalar oder Vektor)
#' @description
#' cheb_model berechnet aus den Chebyshev-Koeffizienten die Y-Werte
#' @export
cheb_model_filter <- function(x_axis, cheb_coeff) {
  ## Funktion zur Berechnung der Y-Werte aus X-Stellen und Cheb-Koeffizienten
  ## ##
  n <- length(cheb_coeff) - 1
  cheb_t <- cheb_1st(x_axis, n)
  cheb_model <- cheb_t %*% cheb_coeff
  return(cheb_model)
}

##
#' @title Calculation of the values of the first derivation
#' @param x_axis beliebige X-Achse (Skalar oder Vektor)
#' @param cheb_coeff Chebyshev-Koeffizienten aus Least-Squares-Verfahren (Vektor)
#' @return cheb_model_deriv_1st Erste Ableitung des gefilterten Modells (Skalar oder Vektor)
#' @description
#' cheb_deriv_1st berechnet aus den Chebyshev-Koeffizienten die Werte der ersten Ableitung
#' @export
cheb_deriv_1st <- function(x_axis, cheb_coeff) {
  ## Funktion zur Berechnung der Y-Werte der Ableitung des Modells
  ## aus X-Stellen und Chebyshev-Koeffizienten
  ## ##
  if (length(x_axis) != 0) { ### ueberpruefen, ob noetig
    n <- length(cheb_coeff) - 1
    m <- n + 1
    cheb_u <- cheb_2nd(x_axis, n)

    # berechnung der ableitung der polynome erster art
    # rekursionsformel 0
    # dT/dx = n * U_(n-1)

    cheb_t_deriv_1st <- if (length(x_axis) == 1) (1:n)*t(cheb_u[,1:n]) else t((1:n) * t(cheb_u[,1:n]))
    cheb_t_deriv_1st <- cbind(0, cheb_t_deriv_1st)
    cheb_model_deriv_1st <- cheb_t_deriv_1st %*% cheb_coeff

    return(cheb_model_deriv_1st)
  }
}

##
#' @title Calculation of the values of the second derivation
#' @param x_axis beliebige X-Achse (Skalar oder Vektor)
#' @param cheb_coeff Chebyshev-Koeffizienten aus Least-Squares-Verfahren (Vektor)
#' @return cheb_model_deriv Zweite Ableitung des gefilterten Modells (Skalar oder Vektor)
#' @description
#' cheb_deriv_2nd berechnet aus den Chebyshev-Koeffizienten die Werte der zweiten Ableitung
#' @export
cheb_deriv_2nd <- function(x_axis, cheb_coeff) {
  n <- length(cheb_coeff) - 1
  #  m <- n + 1
  l <- length(x_axis)
  cheb_t <- cheb_1st(x_axis, n)
  cheb_u <- cheb_2nd(x_axis, n)
  x_cheb <- cheb_scale(x_axis)

  cheb_t_deriv_2nd <- t((0:n) * t(t((0:n + 1) * t(cheb_t )) - cheb_u)) / (x_cheb ** 2 - 1)
  cheb_t_deriv_2nd[1,] <- (-1) ** (0:n) * ((0:n) ** 4 - (0:n) ** 2) / (3)
  cheb_t_deriv_2nd[l,] <- ((0:n) ** 4 - (0:n) ** 2) / (3)

  cheb_model_deriv_2nd <- cheb_t_deriv_2nd %*% cheb_coeff

  return(cheb_model_deriv_2nd)
}

##
#' @title Curve Fitting with Chebyshev Polynomials
#' @param d Zu fittender Datensatz/Zeitreihe (Vektor)
#' @param x_axis Beliebige X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @return cheb_model Werte des gefilterten Modells
#' @description
#' \code{cheb_fit} fittet ein Chebyshev-Polynom beliebiger Ordnung an einen Datensatz/Zeitreihe mittels Least Squares Verfahren
#' @export
cheb_fit <- function(d, x_axis, n){
  ## Herausfiltern von fehlenden Werten (NAs)
  mss_ind  <- which(is.na(d))

  # Fallunterscheidung fuer NAs im Datensatz
  if (length(mss_ind) >= 1) {
    cheb_t <- cheb_1st(x_axis[-mss_ind], n)
  } else {
    cheb_t <- cheb_1st(x_axis, n)
  }

  ## modell berechnungen
  # berechnung der koeffizienten des polyfits
  if (length(mss_ind) >= 1) {
    cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d[-mss_ind]
  } else {
    cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d
  }

  # berechnung des gefilterten modells
  x_cheb <- cheb_scale(x_axis)
  cheb_model <- cheb_model_filter(x_cheb, cheb_coeff)

  # uebergabe der Variablen
  return(cheb_model)
}

##
#' @title Curve Fitting with Chebyshev Polynomials and Finding of its Roots
#' @param d Zu fittender Datensatz/Zeitreihe (Vektor)
#' @param x_axis Beliebige X-Achse (Vektor)
#' @param n Ordnung des Polynoms (Skalar)
#' @param roots_bound_lower Unterer Rand des Bereichs der Nullstellensuche
#' @param roots_bound_upper Oberer Rand des Bereichs der Nullstellensuche
#' @return cheb_list Liste berechneter Parameter (Koeffizienten, gefiltertes Modell, erste und zweite Ableitung des gefilterten Modells, Extremstellen und -Werte)
#' @description
#' \code{cheb_fit.extr} fittet ein Chebyshev-Polynom beliebiger Ordnung an einen Datensatz/Zeitreihe mittels Least Squares Verfahren
#' @export
#' @importFrom rootSolve uniroot.all
cheb_find_extr <- function(d, x_axis, n, roots_bound_lower = NA, roots_bound_upper = NA){

  x_cheb <- cheb_scale(x_axis)
  cheb_t <- cheb_1st(x_axis, n)

  ## modell berechnungen
  # berechnung der koeffizienten des polyfits
  cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d

  # Berechnung der Extrema ueber Nullstellen der ersten Ableitung
  extr <- uniroot.all(cheb_deriv_1st, cheb_coeff = cheb_coeff, lower = -1, upper = 1)
  # reskalierung der Extrema auf normale Lat- Achse
  extr_x <- if (length(extr) != 0) cheb_rescale(extr, x_axis = x_axis)

  # ueberpruefen, welche Extrema im gesuchten Bereich liegen
  if (!is.na(roots_bound_lower) | !is.na(roots_bound_upper)) {
    ind <- which(extr_x >= roots_bound_lower & extr_x <= roots_bound_upper)
    extr <- extr[ind]
    extr_x <- extr_x[ind]
  }
  extr.y <- if (length(extr_x) != 0) cheb_model_filter(x_axis = extr, cheb_coeff = cheb_coeff)
  extr_deriv_2nd <- if (length(extr) != 0) cheb_deriv_2nd(x_axis = extr, cheb_coeff = cheb_coeff)

  cheb_list <- list(extr_x = extr_x,
                    extr.y = extr.y,
                    extr_deriv_2nd = extr_deriv_2nd)
  return(cheb_list)
}

##
#' @title Routine to find maximum values of a curve
#' @param d Zu fittender Datensatz
#' @param x_axis beliebiege X-Achse
#' @param n Ordnung des Skalars
#' @param maxima_bound_lower Unterer Rand des Bereichs der Maxima-Suche
#' @param maxima_bound_upper Oberer Rand des Bereichs der Maxima-Suche
#' @return max_list Positionen und Werte der Maxima als Liste
#' @description
#' \code{cheb_find_max} fittet ein Polynom und sucht mittel dessen Ableitung die Maxima des Datensatzes
#' @export
#' @importFrom rootSolve uniroot.all
cheb_find_max <- function(d, x_axis, n, maxima_bound_lower = NA, maxima_bound_upper = NA){
  x_cheb <- cheb_scale(x_axis)
  cheb_t <- cheb_1st(x_axis, n)

  ## modell berechnungen
  # koeffizienten d poly fits
  cheb_coeff <- solve(t(cheb_t) %*% cheb_t) %*% t(cheb_t) %*% d

  # berechnen d maxima
  # nullstellen d ableitung
  extr <- uniroot.all(cheb_deriv_1st, cheb_coeff = cheb_coeff, lower = -1, upper = 1)

  # reskalierung der Extrema auf normale Lat- Achse
  extr_x <- cheb_rescale(extr, x_axis = x_axis)

  # ueberpruefen, welche Extrema im gesuchten Bereich liegen
  if (!is.na(maxima_bound_lower) | !is.na(maxima_bound_upper)) {
    ind <- which(extr_x >= maxima_bound_lower & extr_x <= maxima_bound_upper)
    extr <- extr[ind]
    extr_x <- extr_x[ind]
  }

  # ueberpruefen, welche Extrema Maxima sind
  if (length(extr) != 0) {
    extr_deriv_2nd <- cheb_deriv_2nd(x_axis = extr, cheb_coeff = cheb_coeff)

    # filtern der maxima | wert d zweiten ableitung < 0
    ind_max <- which(extr_deriv_2nd < 0)
    if (length(ind_max) != 0) {
      max_x <- extr_x[ind_max]
      max_y <- cheb_model_filter(x_axis = extr[ind_max], cheb_coeff = cheb_coeff)
    } else {
      max_x <- NA; max_y <- NA
    }
  } else {
    max_x <- NA; max_y <- NA;
  }
  max_list <- list(max_x = max_x,
                   max_y = max_y)
  return(max_list)
}


library(ggplot2)

## load laster data file
load("if2-paraboot.RData")

## this has pretty much everything
parabootdata <- data.frame(if2_paraboot_data)

## get param star data
paramnames <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")
paramstar <- parabootdata[,paramnames]

## get new infection count data, mean, and 95 quantiles
countnames <- paste("counts",1:(dim(parabootdata)[2]-9), sep = "")
countdata <- parabootdata[,countnames]
countmeans <- colMeans(countdata)
countquants <- t(apply(countdata, 2, quantile, probs = c(0.025,0.975)))
colnames(countquants) <- c("025","975")

## get expected observed data, means, and 95 quantiles
obsdata <- matrix(NA, nrow = dim(countdata)[1], ncol = dim(countdata)[2])
for (i in 1:dim(countdata)[1]) {
	obsdataraw <- countdata[i,] + rnorm(dim(countdata)[2], 0, paramstar[i,'sigma'])
	obsdata[i,] <- unlist(ifelse(obsdataraw < 0, 0, obsdataraw))
}
obsquants <- t(apply(obsdata, 2, quantile, probs = c(0.025,0.975)))
colnames(obsquants) <- c("025","975")

qplot(0:T, sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
	geom_point( aes( y = c(infec_counts[1:(Tlim+1)], rep(NA,T-Tlim)) ) ) +
	geom_line(aes(y = c(rep(NA,Tlim), countmeans)), linetype = "dotted") +
	geom_ribbon(aes(ymin = c(rep(NA,Tlim), countquants[,'025']),
        	    	ymax = c(rep(NA,Tlim), countquants[,'975'])),
					alpha=0.15) +
	geom_ribbon(aes(ymin = c(rep(NA,Tlim), obsquants[,'025']),
	            	ymax = c(rep(NA,Tlim), obsquants[,'975'])),
					alpha=0.1) +
	theme_bw()


library(foreach)
#library(doParallel)

cv.lasso <- function(y, X, b.init = NULL, pen.fac = rep(1,p), lambda = NULL,
                     nfold=5, tol=1e-4, cd.maxit=1e+4) {

    #cl <- makeCluster(5)
    #registerDoParallel(cl)

    p <- ncol(X)
    n <- nrow(X)
    if (n < nfold) stop("nfold cannot be larger than n.")

    if(is.null(lambda)) {
        lambda.max <- max(abs(crossprod(X, y - mean(y))))/n
        lambda <- exp(seq(from=log(lambda.max),
                          to=log(ifelse(p < n, 1e-4, .01)*lambda.max),
                          length.out=100))
    }

    # nfold-cross-validation
    obs.fold <- rep(1:nfold,n)[sample.int(n)]
    cv <- foreach(fold = 1:nfold, .combine = "cbind") %do% {
        #source("lasso.r")
        b <- lasso0(y=y[obs.fold!=fold], X=X[obs.fold!=fold,], b.init=b.init, lambda=lambda,
                    pen.fac=pen.fac, tol=tol, cd.maxit=cd.maxit)$b

        apply(b, 2, function(beta) {
            res <- (y[obs.fold==fold] - X[obs.fold==fold,] %*% beta)
            mean((res - mean(res))^2)
        })
    }

    #stopCluster(cl)

    # output CV graph
    cvm <- rowMeans(cv)

    list(lambda.min=lambda[which.min(cvm)], cvm = cvm, lambda=lambda)
}


if (tau < tauAlpha){
    AlphaE = 1

}else{

    AlphaE = Alpha - ((Alpha - 1.0) * (1.0 - tau) / (1.0 - tauAlpha))
}
energyLimitedEvaporation= (evapoTranspirationPriestlyTaylor / Alpha) * AlphaE * tau


# SQRT in R example

# Square Root of Positive values
sqrt(64)
sqrt(25.659)

# Square Root of Negative values
sqrt(-10.0897)
# Absolute function will convert the Negative value to Positive
# Next, sqrt will find the square root of 35.659
sqrt(abs(-35.659))

# Square Root on vectors
num <- c(-25.526, 256.32, -36.5, -81 , -525.796)
sqrt(num)
sqrt(abs(num))


#autor:      Joao Sollari Lopes
#local:      INE, Lisboa
#Rversion:   3.2.3
#criado:     10.07.2017
#modificado: 06.12.2019

set.seed(12345)
n <- 15
x <- runif(n)
k0 <- 1.5
k1 <- 2
y <- k0 + k1*x + rnorm(n,sd=0.1)
mod1 <- lm(y~1)
mod2 <- lm(y~x)
mod3 <- lm(y~poly(x,5))

fnam <- "../images/concept_2.tiff"
tiff(file=fnam,units="in",width=9,height=3,res=300,compression="lzw")
par(mfrow=c(1,3),mgp=c(2,0.75,0),mar=c(3.1,3.1,0.2,0.2))
plot(x,y,xlim=c(0,1))
abline(mod1,lwd=2,col=2)
text(0.1,3.2,"y ~ 1",pos=4,cex=1.5,col=2)
plot(x,y,xlim=c(0,1))
abline(mod2,lwd=2,col=2)
text(0.1,3.2,"y ~ x + 1",pos=4,cex=1.5,col=2)
plot(x,y,xlim=c(0,1))
xpred <- seq(0,1,len=100)
ypred <- predict(mod3,data.frame(x=xpred))
lines(xpred,ypred,lwd=2,col=2)
text(0.1,3.2,"y ~ poly(x,5) + 1",pos=4,cex=1.5,col=2)
dev.off()


##Shape=vector point
##enestacolumnaestaelrinde=field Shape
##Poligono=vector polygon
##Distancia_busqueda=number 40
##showplots
##output=output raster

#output_plots_to_html
##showplots

if("sp" %in% rownames(installed.packages()) == FALSE) {install.packages("sp")} else {print("sp ya esta..")}
if("gstat" %in% rownames(installed.packages()) == FALSE) {install.packages("gstat")} else {print("gstat ya esta..")}
if("spdep" %in% rownames(installed.packages()) == FALSE) {install.packages("spdep")} else {print("spdep ya esta..")}
if("raster" %in% rownames(installed.packages()) == FALSE) {install.packages("raster")} else {print("raster ya esta..")}
if("rgdal" %in% rownames(installed.packages()) == FALSE) {install.packages("rgdal")} else {print("rgdal ya esta..")}

library(sp)
library(spdep)
library(gstat)

crs_imagen<-st_crs(Shape)
datos <- as_Spatial(Shape)
poligono <- as_Spatial(Poligono)

proj4string(datos) <- CRS(proj4string(datos))

>print("ARMO GRILLA DE MUESTREO")
poligono <- buffer(poligono, width=100)
grdpts <- makegrid(poligono, cellsize = 5)
spgrd <- SpatialPoints(grdpts, proj4string = CRS(proj4string(poligono)))
spgrdWithin <- SpatialPixels(spgrd[poligono,])
par(mfrow= c(1,1))
>plot(spgrdWithin,col = "red", pch = 10, cex = 0.2,xlab="X",ylab="Y")
gri<-spgrdWithin
print(str(gri))
print(CRS(proj4string(poligono)))

>print("ARMO VARIOGRAMA")
require(gstat)

semivariograma <- variogram(get(enestacolumnaestaelrinde)~1, datos, cutoff=250)

sill<-max(semivariograma$gamma)
nugget<-semivariograma[1,3]
Limite_distancia<-max(semivariograma$dist)

modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,"Sph",Limite_distancia,nugget))
error1<-attr(modelovgm , 'SSErr')
>print(paste("Error inicial",error1))
modelo_final = "Sph"

seleccion_modelo<-function(){
	modelos<-c("Sph","Exp","Lin","Gau","Ste","Mat")
		for (i in 1:length(modelos)){
                print(i)
		modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,modelos[i],Limite_distancia,nugget))
	 	error<-(attr(modelovgm , 'SSErr'))
			print(modelos[i])
			print(error)
			if(error < error1){
                        modelo_final <<- modelos[i]
		        error1<-error
 			>print(paste("Por ahora el mejor modelo es",modelo_final))

                        }
            }
}

suppressWarnings(seleccion_modelo())
>print(paste("Modelo final",modelo_final))
modelovgm<- fit.variogram(semivariograma, fit.method=1, vgm(sill,modelo_final,Limite_distancia,nugget))
plot(semivariograma,modelovgm ,main="",xlab="Distancia",ylab="Semivarianza")

data2<-remove.duplicates(datos)
>print("Datos originales")
>print(nrow(datos))
>print("Datos filtrados")
>print(nrow(data2))

crs(data2)<-NA
crs(gri)<-NA

>print("---------Distancia de interpolado---------------")
>print(Distancia_busqueda)

Kg_wls <- krige(get(enestacolumnaestaelrinde)~1, data2, gri, model = modelovgm, debug.level=-1,maxdist=Distancia_busqueda)

print("Armamos el Raster para ver en QGIS")
raster<- raster(Kg_wls,layer=1)
crs(raster)<-crs(poligono)
output <- raster


for (line in readLines(tail(commandArgs(), n=1))) {
  cat(sapply(as.integer(line), function(s) {
    t <- c(1)
    if (s > 1) {
      for (i in 1:(s-1)) {
        r <- 1
        t <- append(t, 1)
        for (j in 1:i) {
          r <- (r * (i + 1 - j)) / j
          t <- append(t, r)
        }
      }
    }
    paste(t, collapse=" ")
  }), sep="\n")
}


#' Creates a graph plot using the similarity values calculated with ClusterFoldSimilarity().
#'
#' `plot_clusters_graph()` Creates a graph plot using the similarity values calculated with ClusterFoldSimilarity().
#'
#' This function will calculate a similarity coeficient using the fold changes of shared genes among clusters of different samples/batches. The similarity coeficient
#' is calculated using the dotproduct of every pairwise combination of Fold Changes between a source cluster i of sample n and all the target clusters in sample j.
#'
#' @param similarity.table Dataframe. A table obtained from ClusterFoldSimilarity that contains the similarity values as a column "similarity_value" that represents
#' the similarity of a source cluster to a target cluster.
#'
#' @return This function plots a graph in which the nodes are clusters from a specific dataset, the edges represent the similarity and the direction
#' of that similarity between clusters.
#'
#' @export
plot_clusters_graph <- function(similarity.table = NULL){

  # We will use the similarity matrix to create a graph
  if(is.null(similarity.table) | !is.data.frame(similarity.table)){
    stop("A similarity table from clusterFoldSimilarity was not found.")
  }
  df <- similarity.table
  from <- paste(paste0("D", df$dataset_l), paste0("C", df$cluster_l), sep = ".")
  to <- paste(paste0("D", df$dataset_r), paste0("C", df$cluster_r), sep = ".")
  # igraph
  require(igraph,quietly = T)
  relations <- data.frame(from = from, to = to, sim = df$similarity_value)
  g <- igraph::graph_from_data_frame(relations, directed = T)
  cl <- as.numeric(apply(table(df$dataset_l, df$cluster_l) != 0, 1, sum))
  cluster_colors <- c("#7BCCC4","#FEB24C","#74C476","#FDDBC7","#D0D1E6","#FDBF6F","#D1E5F0","#67A9CF","#E08214","#800026","#006837","#0570B0",
                      "#FC8D62", "#045A8D", "#02818A", "#8C96C6", "#CCEBC5", "#E31A1C", "#78C679", "#A8DDB5", "#FDD49E", "#DE77AE", "#B3B3B3", "#EF6548",
                      "#D73027")
  cl_codes <- sample(cluster_colors,size = length(unique(df$dataset_l)))
  par(mar=c(1,5,3,1));base::plot(g, vertex.label = V(g)$name, edge.arrow.size = .3,
       vertex.color = rep(cl_codes, cl),edge.color = "black",
       vertex.size = 12, vertex.frame.color = NA, vertex.label.color = "black",
       vertex.label.cex = 0.6, vertex.label.dist = 0, edge.curved = 0.2);legend('topleft', legend = paste0('Dataset ', 1:length(unique(df$dataset_l))),
                                                                                fill = cl_codes,xpd=TRUE, inset=c(-0.2,0),)
}


#data_url <- "https://files.datapress.com/london/dataset/2011-boundary-files/2011_london_boundaries.zip"
#zip_fn <- "london.zip"
#download.file(data_url, zip_fn)
#unzip(zip_fn)

library(maptools)
library(rgdal)
library(data.table)
library(ggplot2)
library(plyr)
library(gganimate)

set.seed(33333334)

crswgs84=CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")

lon <- maptools::readShapePoly("LSOA_2011_BFE_City_of_London.shp")
cam <- readShapePoly("LSOA_2011_BFE_Camden.shp")
lon <- rbind(lon, cam)
plot(lon)

lon_coords <- sp::coordinates(lon)  # Coordinates of polygon centers
lon_nbs <- spdep::poly2nb(lon)  # Neighbour relationships based on a triangulation

rownames(lon_coords) <- lon$LSOA11NM
plot(lon)
points(lon_coords)
points(lon_coords[2,1], lon_coords[2,2], col="red")

lon_w_mat <- spdep::nb2mat(lon_nbs)  # Weight matrix between the nodes.
colnames(lon_w_mat) <- rownames(lon_w_mat)
hist(Filter(f = function(x) x > 0, x = as.vector(lon_w_mat)))

num_nbs <- length(lon_nbs)
threshold <- 0.16
plot(lon)
points(lon_coords)

adj_matrix <- lon_w_mat>threshold
dimnames(adj_matrix) <- NULL

edges <- which(adj_matrix, arr.ind = TRUE)
apply(edges, 1, function(r){
  lines(lon_coords[r,1], lon_coords[r,2], col="blue")
})

#transmission rate
beta <- 3

#recovery rate
gamma <- 1

n.nodes <- ncol(adj_matrix)
status.vector <- rep("S", n.nodes)

status.vector[sample(length(status.vector), 1)] <- "I"
names(status.vector) <- 1:n.nodes
colnames(adj_matrix) <- rownames(adj_matrix) <- 1:n.nodes

#matrix and vector to store results at each time step
time.steps <- rep(NA, 2*n.nodes)
status.matrix <- matrix(NA, nrow = 2*n.nodes, ncol = n.nodes)

time.steps[[1]] <- 0
status.matrix[1,] <- status.vector

#run until
stopping.time <- 10

#initialise time
current.time <- 0
time.step <- 1

while(current.time < stopping.time){
  # message for debugging
  # message(paste(c("time step:", time.step, "current time:", current.time), collapse = " "))

  #calculate vector recovery rates for each infected person
  recovery.rates <- rep(gamma, sum(status.vector=="I"))
  names(recovery.rates) <- c(1:n.nodes)[status.vector=="I"]

  #infection rates for each suceptiable person
  infection.rates <- rowSums(adj_matrix[,status.vector=="I",drop=FALSE])[status.vector=="S"]
  infection.rates <- infection.rates*beta
  names(infection.rates) <- c(1:n.nodes)[status.vector=="S"]

  #sample event
  event.rate <- sum(recovery.rates, infection.rates)
  if(event.rate<=0){
    #we've reached the end of the simulation
    break
  }

  p <- c(recovery.rates, infection.rates)/event.rate
  event.num <- sample(names(p), 1, prob = p)

  #update status
  if(status.vector[event.num]=="S"){
    status.vector[event.num] <- "I"
  } else if (status.vector[event.num]=="I") {
    status.vector[event.num] <- "R"
  } else {
    stop("bad index!")
  }

  #sample time to event
  current.time <- current.time + rexp(1, rate = event.rate)
  time.step <- time.step + 1

  #update results
  time.steps[[time.step]] <- current.time
  status.matrix[time.step, ] <- status.vector
}

time.steps <- time.steps[1:time.step]
status.matrix <- status.matrix[1:time.step,]

results.df <- data.frame(t(apply(status.matrix, 1, function(r){
  table(factor(r, levels = list("S", "I", "R")))
  })), stringsAsFactors = FALSE)

results.df$time <- time.steps
results.df <- melt(results.df, id.vars="time")

# Plot
ggplot(results.df, aes(x=time, y=value, col=variable)) + geom_line()

results.df <- melt(status.matrix)
colnames(results.df) <- c("time step", "node", "status")
results.df <- cbind(results.df, lon_coords[results.df$node,], rownames(lon_coords))
results.df$node <- rownames(lon_coords)[results.df$node]
colnames(results.df) <- c("time step", "node", "status", "lat", "long", "area")

lon@data$id = rownames(lon@data)
london.points = fortify(lon, region="id")
london.df = join(london.points, lon@data, by="id")

plot.df <- do.call(rbind, lapply(unique(results.df$`time step`), function(t){
  temp.df <- results.df[results.df$`time step`==t,]
  london.df$status <- temp.df$status[match(as.character(london.df$LSOA11NM), temp.df$node)]
  london.df$time <- t
  return(london.df)
}))

gg <- ggplot(plot.df) +
  aes(long,lat, group=group, fill=status) +
  geom_polygon() +
  geom_path(color="white") +
  coord_equal() +
  # Here comes the gganimate code
  transition_manual(time)

anim_save("london.gif",animate(gg))

contents <- base64enc::base64encode("london.gif")
tag <- '<img src="data:image/gif;base64,%s">'
IRdisplay::display_html(sprintf(tag, contents))


#' fastmap
#'
#' Implementation of the fastmap algorithm.
#'
#' @details
#' The method is threaded via OpenMP. This requires \code{nthreads*n} doubles of
#' additional storage.  If \code{n} is very large relative to \code{m}, this
#' could be very costly; in this case, try using a smaller number of threads by
#' setting the environment variable \code{OMP_NUM_THREADS}.
#'
#' @param x
#' Input data, preferably as a matrix, or optionally as anything coercible to
#' a matrix.
#'
#' @return
#' A list of points \code{a} and \code{b}, the latter being the most distant
#' from the former.
#'
#' @examples
#' \dontrun{
#' library(fastmap)
#'
#' x = matrix(1:30, 10)
#' fastmap(x)
#' }
#'
#' @references
#' Ostrouchov, G., 2009. A Matrix Computation View of FastMap and RobustMap
#' Dimension Reduction Algorithms. SIAM Journal on Matrix Analysis and
#' Applications, 31(3), pp.1351-1360.
#'
#' Faloutsos, C. and Lin, K.I., 1995. FastMap: A fast algorithm for indexing,
#' data-mining and visualization of traditional and multimedia datasets (Vol.
#' 24, No. 2, pp. 163-174). ACM.
#'
#' @export
fastmap = function(x)
{
  if (!is.matrix(x))
    x = as.matrix(x)

  if (!is.double(x))
    storage.mode(x) = "double"

  .Call(R_fastmap, x)
}


#' Curbe ball algorithm to generate random networks with given an igraph network
#'
#' This extract the adjacency matrix from an igraph object and generates a randomized version
#' of the network with the same row and column totals, the results have the same in and out degree sequence
#' than the original network. The diagonals are not avoided so it can generate self-links or cannibalism in
#' the context of food-webs. In the case that the network has multiple components (or disconnected networks)
#' the algorithm simulates around the same number of components, if the original network has 1 component
#' the algorithm enforces that the results have all 1 component. If the edge attribute weight is present
#' and istrength=TRUE then the weigth is additionally randomized keeping the column sum equal to the original matrix.
#'
#' Based on:
#'
#' @references Strona, G. et al. 2014. A fast and unbiased procedure to randomize ecological binary matrices with
#' fixed row and column totals. -Nat. Comm. 5: 4114. doi: 10.1038/ncomms5114
#'
#' @aliases curveBall
#' @param g igraph object to extract adjacency matrix
#' @param nsim number of generated random networks
#' @param istrength if TRUE the edge attribute weight is taken as interaction strength and randomized keeping the column sum equal to the original matrix.
#'
#' @return a list of randomized igraph objects
#' @export
#'
#' @examples
#'
#' curve_ball(netData[[1]])
#'
curve_ball<-function(g,nsim=1000,istrength=FALSE){
  stopifnot(class(g)=="igraph")

  m <- get.adjacency(g,sparse=FALSE)

  if(components(g)$no>1) {

    nets<- lapply(1:nsim, function (x) {
      # repeat {
      RC <- dim(m)
      R  <- RC[1]
      C  <- RC[2]
      hp <- list()
      for (row in 1:dim(m)[1]) {hp[[row]] <- (which(m[row,]==1))}
      l_hp <- length(hp)
      for (rep in 1:5*l_hp){
        AB <- sample(1:l_hp,2)
        a  <- hp[[AB[1]]]
        b  <- hp[[AB[2]]]
        ab <- intersect(a,b)
        l_ab <- length(ab)
        l_a <- length(a)
        l_b <- length(b)
        if ((l_ab %in% c(l_a,l_b))==FALSE){
          tot <- setdiff(c(a,b),ab)
          l_tot <- length(tot)
          tot <- sample(tot, l_tot, replace = FALSE, prob = NULL)
          L <- l_a-l_ab
          hp[[AB[1]]]  <-  c(ab,tot[1:L])
          hp[[AB[2]]]  <-  c(ab,tot[(L+1):l_tot])}

      }
      rm <- matrix(0,R,C)
      for (row in 1:R){rm[row,hp[[row]]] <- 1}

      g <- graph_from_adjacency_matrix(rm,mode="directed")
      return(g)
    })
  } else {   #if the the networks has only one component enforce that in the simulations

    nets<- lapply(1:nsim, function (x) {
      repeat {
      RC <- dim(m)
      R  <- RC[1]
      C  <- RC[2]
      hp <- list()
      for (row in 1:dim(m)[1]) {hp[[row]] <- (which(m[row,]==1))}
      l_hp <- length(hp)
      for (rep in 1:5*l_hp){
        AB <- sample(1:l_hp,2)
        a  <- hp[[AB[1]]]
        b  <- hp[[AB[2]]]
        ab <- intersect(a,b)
        l_ab <- length(ab)
        l_a <- length(a)
        l_b <- length(b)
        if ((l_ab %in% c(l_a,l_b))==FALSE){
          tot <- setdiff(c(a,b),ab)
          l_tot <- length(tot)
          tot <- sample(tot, l_tot, replace = FALSE, prob = NULL)
          L <- l_a-l_ab
          hp[[AB[1]]]  <-  c(ab,tot[1:L])
          hp[[AB[2]]]  <-  c(ab,tot[(L+1):l_tot])}

      }
      rm <- matrix(0,R,C)
      for (row in 1:R){rm[row,hp[[row]]] <- 1}

      g <- graph_from_adjacency_matrix(rm,mode="directed")
      if(components(g)$no==1)
         break
      }
      return(g)
    })
  }

  if(istrength) {
    m <- get.adjacency(g,sparse=FALSE,attr="weight")
    r <- dim(m)[1]
    c <- dim(m)[2]

    wnets<- lapply(nets, function (x) {
      m1 <- get.adjacency(x,sparse=FALSE)
      for(i in seq_len(c) ){
        ss <- sample(m[,i])
        ss <- ss[ss>0]
        k <- 1
        for( j in seq_len(r)){
          if(m1[j,i]>0 ) {
            m1[j,i] <- ss[k]
            k <- k+1
          }
        }
      }
      graph_from_adjacency_matrix(m1,mode="directed",weighted = "weight")
    })
  } else {
    return(nets)
  }
}

#' @export
curveBall<-function(g,nsim=1000,istrength=FALSE){curve_ball(g,nsim,istrength)}

#' Generate directed Erdos-Renyi random networks with at least 1 basal node and only one component
#'
#' This uses the igraph's function sample_gnm to generate nsim random networks with the same number of nodes
#' and links than the parameter ig and two restrictions:
#' 1) at least one basal species/node, that is a species that has no prey, 2) 1 connected component so there is no
#' disconnected species or sub-community.
#'
#' @param ig igraph object with parameters to use in the random network simulations: number of species/nodes
#'           and number of links/edges
#' @param nsim number of simulations
#'
#' @aliases generateERbasal
#'
#' @return a list with igraph objects
#' @export
#'
#' @examples
#'
#' generateERbasal(netData[[1]])
generate_er_basal <- function(ig,nsim=1000){
  if(!is_igraph(ig))
    stop("Parameter ig must be an igraph object")

  size <- vcount(ig)

  links <- ecount(ig)

  er <- lapply(1:nsim, function (x) {
    e <- sample_gnm(size, links, directed = TRUE)
    basal <- length(V(e)[degree(e,mode="in")==0])
    while(components(e)$no>1 | basal==0){
      e <- sample_gnm(size, links,directed = TRUE)
      basal <- length(V(e)[degree(e,mode="in")==0])
    }
    return(e) })
}

#' @export
generateERbasal <- function(ig,nsim=1000){generate_er_basal(ig,nsim)}


# Loading the caret library to build the Naïve Bayes model
library("caret")

# Loading the data
df <- read.table('breast-cancer-wisconsin.data', header = TRUE, sep = ",", na.strings = 'null')

head(df)

"""**Preprocessing the data**"""

# Dropping the id number as it is not required in the analysis
df <- (df[,-1])

# Naming the columns
colnames(df) = c("Clump.Thickness", "Uniformity.of.Cell.Size", "Uniformity.of.Cell.Shape", "Marginal.Adhesion", "Single.Epithelial.Cell.Size", "Bare.Nuclei", "Bland.Chromatin", "Normal.Nucleoli", "Mitoses", "Class")

# When importing the data to a data.frame,
# it gets converted to a factor if the entire column is not numeric and
# "Bare.Nuclei" has some missing values which is represented as "?" So with that in mind,
# it will have to be converted to character and then to numeric.
str(df)

# Counting the number of rows
nrow(df)

# Converting "Bare.Nuclei" into character and then into numeric
df$Bare.Nuclei = as.numeric(as.character(df$Bare.Nuclei))

# The above line turned "?" in the "Bare.Nuclei" column into the NAs
# Hence missing values needs to be checked
sum(is.na(df))

# Omiting the rows which has missing values
df <- na.omit(df)

# Checking if there no missing values
sum(is.na(df))

# Converting "Bare.Nuclei" into integer just like other attributes
df$Bare.Nuclei<- as.integer(df$Bare.Nuclei)
str(df)

# Factorizing the class attribute and replacing it with the new factorized class attribute
factorizedClass <- as.factor(df$Class)
df <- data.frame(df, factorizedClass)
df <- df[,-10]
head(df)

"""**Building Naïve Bayes Model**"""

# Trainign the Naïve Bayes model using 10 fold cross validation
nbModel <- train(df[,-10], df$factorizedClass, "nb", trControl = trainControl(method = "cv", number = 10))

# Checking the model
nbModel

# Predicting the model
nbPrediction <- predict(nbModel, df[,-10])

# Generating the confusion matrix
confusionMatrix <- confusionMatrix(nbPrediction, df$factorizedClass)
confusionMatrix

"""A confusion matrix is a special contingency table used to evaluate the predictive accuracy of a classifier. Predicted classes are listed in rows & actual classes in columns, w/ counts of respective cases in each cell.

There are two predicted class: Benign and Malignant.
The "2" in confusion matrix represents as benign and "4" as malignant

We can infer from the above calculation that the specificity for the model is 94% refers that there are proportion of people without the disease who will have a negative result.

Sensitivity value is 97% which means the predicted values were positive when compared to actual positive class.

The accuracy for this model is 96% which means that 96% of the time, the model classified the class benign or malignant correctly.

"""

# Calculation the misclassification rate
misclassificationErr <- mean(nbPrediction != df$factorizedClass)
misclassificationErr

"""The above model classified the patients with either benign or malignant 3% incorrectly.

**Discretising the data**
"""

# Loading the required library
library(infotheo)

# Discritising the data
ef.data <-discretize(df, disc="equalfreq", nbins=3 )

# Factorising the class and replacing old with new factorised attribute
classFactor <- as.factor(ef.data$factorizedClass)
ef.data <- data.frame(ef.data, classFactor)
ef.data <- ef.data[,-10]
head(ef.data)

# Building the new model with discretized data
discretizedModel <- train(ef.data[,-10], ef.data$classFactor, "nb", trControl = trainControl(method = "cv", number = 10))

discretizedModel

discretizedPrediction <- predict(discretizedModel, ef.data[,-10])

discretizedConfusionMatrix <- confusionMatrix(discretizedPrediction, ef.data$classFactor)
discretizedConfusionMatrix

"""The accuracy increased to 97% after discretising the data which is improved from the previous model."""


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

# set up a device driver to plot
postscript(file='~/Copy/Programming/R/rprograms/plotting/legends/legend1.eps')

## Run the example in '?matplot' or the following:
leg.txt <- c("Setosa     Petals", "Setosa     Sepals",
             "Versicolor Petals", "Versicolor Sepals")
y.leg <- c(4.5, 3, 2.1, 1.4, .7)
cexv  <- c(1.2, 1, 4/5, 2/3, 1/2)
matplot(c(1, 8), c(0, 4.5), type = "n", xlab = "Length", ylab = "Width",
        main = "Petal and Sepal Dimensions in Iris Blossoms")
for (i in seq(cexv)) {
  text  (1, y.leg[i] - 0.1, paste("cex=", formatC(cexv[i])), cex = 0.8, adj = 0)
  legend(3, y.leg[i], leg.txt, pch = "sSvV", col = c(1, 3), cex = cexv[i])
}

## 'merge = TRUE' for merging lines & points:
x <- seq(-pi, pi, len = 65)
plot(x, sin(x), type = "l", ylim = c(-1.2, 1.8), col = 3, lty = 2)
points(x, cos(x), pch = 3, col = 4)
lines(x, tan(x), type = "b", lty = 1, pch = 4, col = 6)
title("legend(..., lty = c(2, -1, 1), pch = c(NA, 3, 4), merge = TRUE)",
      cex.main = 1.1)
legend(-1, 1.9, c("sin", "cos", "tan"), col = c(3, 4, 6),
       text.col = "green4", lty = c(2, -1, 1), pch = c(NA, 3, 4),
       merge = TRUE, bg = "gray90")

## right-justifying a set of labels: thanks to Uwe Ligges
x <- 1:5; y1 <- 1/x; y2 <- 2/x
plot(rep(x, 2), c(y1, y2), type = "n", xlab = "x", ylab = "y")
lines(x, y1); lines(x, y2, lty = 2)
temp <- legend("topright", legend = c(" ", " "),
               text.width = strwidth("1,000,000"),
               lty = 1:2, xjust = 1, yjust = 1,
               title = "Line Types")
text(temp$rect$left + temp$rect$w, temp$text$y,
     c("1,000", "1,000,000"), pos = 2)

##--- log scaled Examples ------------------------------
leg.txt <- c("a one", "a two")

par(mfrow = c(2, 2))
for(ll in c("","x","y","xy")) {
  plot(2:10, log = ll, main = paste0("log = '", ll, "'"))
  abline(1, 1)
  lines(2:3, 3:4, col = 2)
  points(2, 2, col = 3)
  rect(2, 3, 3, 2, col = 4)
  text(c(3,3), 2:3, c("rect(2,3,3,2, col=4)",
                      "text(c(3,3),2:3,\"c(rect(...)\")"), adj = c(0, 0.3))
  legend(list(x = 2,y = 8), legend = leg.txt, col = 2:3, pch = 1:2,
         lty = 1, merge = TRUE)   #, trace = TRUE)
}
par(mfrow = c(1,1))

##-- Math expressions:  ------------------------------
x <- seq(-pi, pi, len = 65)
plot(x, sin(x), type = "l", col = 2, xlab = expression(phi),
     ylab = expression(f(phi)))
abline(h = -1:1, v = pi/2*(-6:6), col = "gray90")
lines(x, cos(x), col = 3, lty = 2)
ex.cs1 <- expression(plain(sin) * phi,  paste("cos", phi))  # 2 ways
utils::str(legend(-3, .9, ex.cs1, lty = 1:2, plot = FALSE,
                  adj = c(0, 0.6)))  # adj y !
legend(-3, 0.9, ex.cs1, lty = 1:2, col = 2:3,  adj = c(0, 0.6))

require(stats)
x <- rexp(100, rate = .5)
hist(x, main = "Mean and Median of a Skewed Distribution")
abline(v = mean(x),   col = 2, lty = 2, lwd = 2)
abline(v = median(x), col = 3, lty = 3, lwd = 2)
ex12 <- expression(bar(x) == sum(over(x[i], n), i == 1, n),
                   hat(x) == median(x[i], i == 1, n))
utils::str(legend(4.1, 30, ex12, col = 2:3, lty = 2:3, lwd = 2))

## 'Filled' boxes -- for more, see example(plot.factor)
op <- par(bg = "white") # to get an opaque box for the legend
plot(cut(weight, 3) ~ group, data = PlantGrowth, col = NULL,
     density = 16*(1:3))
par(op)

## Using 'ncol' :
x <- 0:64/64
matplot(x, outer(x, 1:7, function(x, k) sin(k * pi * x)),
        type = "o", col = 1:7, ylim = c(-1, 1.5), pch = "*")
op <- par(bg = "antiquewhite1")
legend(0, 1.5, paste("sin(", 1:7, "pi * x)"), col = 1:7, lty = 1:7,
       pch = "*", ncol = 4, cex = 0.8)
legend(.8,1.2, paste("sin(", 1:7, "pi * x)"), col = 1:7, lty = 1:7,
       pch = "*", cex = 0.8)
legend(0, -.1, paste("sin(", 1:4, "pi * x)"), col = 1:4, lty = 1:4,
       ncol = 2, cex = 0.8)
legend(0, -.4, paste("sin(", 5:7, "pi * x)"), col = 4:6,  pch = 24,
       ncol = 2, cex = 1.5, lwd = 2, pt.bg = "pink", pt.cex = 1:3)
par(op)

## point covering line :
y <- sin(3*pi*x)
plot(x, y, type = "l", col = "blue",
     main = "points with bg & legend(*, pt.bg)")
points(x, y, pch = 21, bg = "white")
legend(.4,1, "sin(c x)", pch = 21, pt.bg = "white", lty = 1, col = "blue")

## legends with titles at different locations
plot(x, y, type = "n")
legend("bottomright", "(x,y)", pch = 1, title = "bottomright")
legend("bottom", "(x,y)", pch = 1, title = "bottom")
legend("bottomleft", "(x,y)", pch = 1, title = "bottomleft")
legend("left", "(x,y)", pch = 1, title = "left")
legend("topleft", "(x,y)", pch = 1, title = "topleft, inset = .05",
       inset = .05)
legend("top", "(x,y)", pch = 1, title = "top")
legend("topright", "(x,y)", pch = 1, title = "topright, inset = .02",
       inset = .02)
legend("right", "(x,y)", pch = 1, title = "right")
legend("center", "(x,y)", pch = 1, title = "center")

# using text.font (and text.col):
op <- par(mfrow = c(2, 2), mar = rep(2.1, 4))
c6 <- terrain.colors(10)[1:6]
for(i in 1:4) {
  plot(1, type = "n", axes = FALSE, ann = FALSE); title(paste("text.font =",i))
  legend("top", legend = LETTERS[1:6], col = c6,
         ncol = 2, cex =~/Copy/Programming/R/rprograms/plotting/legends/legend1.r 2, lwd = 3, text.font = i, text.col = c6)
}
par(op)

# turn off device driver
dev.off()


##' Vortex transform.
##'
##' Fringe analysis by Vortex aka Spiral Quadrature transform.
##'
##' @param imagedata matrix containing the interferogram data
##' @param cp list with circle parameters describing interferogram location. Defaults to NULL
##' @param filter size of filter to remove background
##' @param fw.o size of gaussian blur to smooth orientation estimate
##' @param options A list with general fitting and display options. See [psfit_options()].
##'
##' @return a list with wavefront estimates, wrapped phase, modulation, etc.
##'
##' @seealso This is one of two routines provided for analysis of single interferograms,
##'   along with [fftfit()]. This \emph{may} be suitable for interferograms with
##'   closed fringes.
##'
##' @details Implements the Vortex or spiral phase quadrature transform method
##'  of Larkin et al. (2001) [https://doi.org/10.1364/JOSAA.18.001862] including the
##'  fringe orientation estimation approach in Larkin (2005) [https://doi.org/10.1364/OPEX.13.008097].
##'  Thanks to Steve Koehler for ideas on implementation details.
##'
##' @section Warning:
##'   This routine is offered as is with no license, as it may be in violation of one or more
##'   US and international patents.
##'
##' @examples
##' require(zernike)
##' fpath <- file.path(find.package(package="zernike"), "psidata")
##' fname <- "Image197.jpg"
##' img <- load.images(file.path(fpath, fname))
##'
##' # parameters for this run
##'
##' source(file.path(fpath, "parameters.txt"))
##'
##' # target SA coefficients for numerical null.
##'
##' sa.t <- sconic(diam,roc,lambda=wavelength)
##' zopt <- psfit_options()
##' zopt$satarget <- sa.t
##'
##' # display an interferogram
##'
##' if (tolower(.Platform$OS.type) == "windows") windows() else x11()
##' image(1:nrow(img), 1:ncol(img), img, col=grey256, asp=1,
##'  xlab="X", ylab="Y", useRaster=TRUE)
##' mtext("Sample Interferogram")
##'
##' if (tolower(.Platform$OS.type) == "windows") windows() else x11()
##' vfit <- vortexfit(img, filter=15, fw.o=10, options=zopt)
vortexfit <- function(imagedata, cp=NULL, filter=NULL, fw.o=10, options=psfit_options()) {

  nr <- nrow(imagedata)
  nc <- ncol(imagedata)
  npad <- nextn(max(nr,nc))
  xs <- (-npad/2):(npad/2-1)
  im <- padmatrix(imagedata, npad=npad, fill=mean(imagedata))
  im.fft <- fftshift(fft(im))
  if (is.null(filter)) {
    sldata <- pick.sidelobe(imagedata, logm=TRUE)
    filter <- sldata$filter
  }
  if (filter > 0) {
    xss <- 2*xs/filter
    rho2 <- outer(xss, xss, function(x,y) x^2+y^2)
    im.fft <- im.fft*(1-exp(-rho2/2))
  }
  theta <- function(x,y) atan2(y,x)
  phi <- outer(xs, xs, theta)
  im.nb <- Re(fft(fftshift(im.fft), inv=TRUE))/(npad^2)
  D <- fft(fftshift(exp(1i*phi)*im.fft), inv=TRUE)/(npad^2)
  D2 <- fft(fftshift(exp(2*1i*phi)*im.fft), inv=TRUE)/(npad^2)
  sx <- (D^2-im.nb*D2)[1:nr, 1:nc]
  if (fw.o > 0) {
    rsx <- gblur(Re(sx), fw=fw.o)
    isx <- gblur(Im(sx), fw=fw.o)
    sx <- rsx + 1i*isx
  }
  orient <- Arg(sx)
  mod.o <- Mod(sx)
  if (options$plots) {
    image(1:nr, 1:nc, orient, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE)
    mtext("Orientation")
  }
  dir <- wrap(pi * qpuw(orient, mod.o))
  if (options$plots) {
    image(1:nr, 1:nc, dir, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE)
    mtext("Direction")
  }
  Q <- Re(D[1:nr, 1:nc] * exp(-1i*dir))
  phase <- atan2(Q, im.nb[1:nr, 1:nc])
  mod <- sqrt(Q^2+(im.nb[1:nr, 1:nc])^2)
  mod <- (mod-min(mod))/(max(mod)-min(mod))
  if (is.null(cp)) {
    cp <- circle.pars(mod, plot=options$plots)
  }
  cp.orig <- cp
  if (options$crop) {
    mod <- crop(mod, cp)$im
    phase <- crop(phase, cp)
    cp <- phase$cp
    phase <- phase$im
  }
  nr <- nrow(phase)
  nc <- ncol(phase)
  prt <- pupil.rhotheta(nr, nc, cp)
  phase[is.na(prt$rho)] <- NA
  class(phase) <- "pupil"
  wf.raw <- switch(options$puw_alg,
                   qual = qpuw(phase, mod),
                   brcut = brcutpuw(phase),
                   qpuw(phase, mod)
  )
  wf.raw <- options$fringescale*wf.raw
  class(wf.raw) <- "pupil"
  wf.nets <- wf_net(wf.raw, cp, options)
  outs <- list(im.bgclean=im.nb[1:nr, 1:nc], orient=orient, dir=dir, phi=phase, mod=mod,
       cp=cp, cp.orig=cp.orig,
       wf.net=wf.nets$wf.net, wf.smooth=wf.nets$wf.smooth,
       wf.residual=wf.nets$wf.residual, fit=wf.nets$fit, zcoef.net=wf.nets$zcoef.net)
  class(outs) <- append(class(outs), "wf_fitted")
  outs
}


schiz <- read.table('schiz.txt',as.is=T,header=T)

# two ways to do a paired t-test:
t.test(schiz$unaff - schiz$aff)
t.test(schiz$unaff,schiz$aff,paired=T)

# and two ways to do Wilcoxon signed rank test:
wilcox.test(schiz$unaff - schiz$aff)
wilcox.test(schiz$unaff,schiz$aff,paired=T)

# can also do a sign test, but need to code from scratch by
#  counting # + and # - signs, then computing binomial tail
#  probability, probably by using pbinom()
#

# need to reshape the data (one obs per row) to use blocks
#  N.B. the reshape package has much more powerful methods
#    to reshape data sets

# here's a brute force approach, to create columns with
#  appropriate information

schiz2 <- data.frame(pair=rep(schiz$pair,2),
       trt = rep(c('unaffected','affected'),c(15,15)),
       y=c(schiz$unaff,schiz$aff) )

schiz2.aov <- aov(y~as.factor(pair) + as.factor(trt),data=schiz2)
anova(schiz2.aov)

# as before, R's facilities for 'after the ANOVA' are limited
# here's how to get means for each block and for each trt

model.tables(schiz2.aov,type='means')

# you can get Tukey HSD intervals for all pairwise differences:
TukeyHSD(schiz2.aov)

# this includes both trt (what you prob. want) and
#    pair (that you prob. don't want)

# you can restrict, but the which = has to match the model term
#   exactly:

TukeyHSD(schiz2.aov, which = 'as.factor(trt)')   # works
TukeyHSD(schiz2.aov, which = 'trt')              # doesn't

# unless you've already converted trt to a factor, so the model
#  only has trt

# There are at least 3 ways to fit a model with blocks as a random
#   effect, including lme() in the nlme package and
#   lmer() in the nlme package.
# Again, it is exceedingly difficult to move beyond tests, so the
#  use of these functions will have to wait until 511

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


#PROBLEM NUMBER 03

# GNU Multiple Precision Arithmetic
library('gmp')
factorize(600851475143)


# The Basics of R =========================================
# topics to cover:
  # make a variable
  # math operations
  # logic operations
  # typical builtins
  # make a function
  # if-else statements
  # forloops, whileloops
  # file manipulation

# make a variable ======================
# two primitive types of variables: numeric (double) & strings (character)

# numeric / double
a = 1 # note: although "<-" is standard, "=" can be more convenient
b = 2
print(a+b)
print(paste('sum: ',a+b))

# character / strings
c = "some string"
print(c)

# lists
d = c(1,2,3,4)
print(d)

# math operations ======================
# sum, sub, mult, div, pow, modulus
print(1+1-2*3/3+5**2 - 7%%2) # note: sqrt is also a builtin

# logic operations =====================
print(TRUE == TRUE)
print(TRUE != F) # note, F & T can replace TRUE & FALSE
print(2 > 1)
print(2<=2)

# typical builtins =====================
print('print what you have') # note: in R, ' is also valid
c(1,2,3) # combine multiple values to create a list, single type
length(3) # length of an object's "first" dimension
typeof(3) # type of an object
print(paste(1,2)) # join two strings, converting things that aren't strings

# make a function ======================
pyt = function(a,b=4){
  return ((a*a+b*b)**0.5)
}
print(pyt(3,4))

# if-else statements ===================
a = 5
if(a<2) {
  print('less than 2')
} else if(a>10) {
   print('greater than 10')
} else{
   print('between 2 and 10, inclusive')
 }

# for-loops ============================
for(i in 1:5){
  print(paste('loop:',i))
}

# while loops ==========================
b = 10
while(b>0){
  print(paste("curr value:",b))
  b = b-2
}

# filesystem manipulation ====================
# is path a folder, does it exist, rename a file, get list of folders
getwd() # get working directory
file.path('a','b','c') # concatenate filepaths
dir.exists('.') # check that a directory exists
dir.create('delme') # create a folder
list.files() # list files / directories in a folder
# ??? how to delete a file / folder

# working with dataframes ====================

# create a dataframe

SAFE = c('a','b','c','d')

testArchives = c()
testR10s = c()
testTCIs = c()

for(iarchive in SAFE){
  testArchives = append(testArchives,existsArchive(...))
  testR10s = append(testR10s,existsR10(...))
  testTCIs = append(testTCIs,existsTCI(...))
}

write.csv(cbind(SAFE,testArchives,testR10s,testTCIs),
          "SAFE_check.csv")


require(reshape2)
require(scatterplot3d)

source('fmm_multivariate_generative.r')

dimension = 3

config_3d = list(
    k = 4
  , l = rep(0, dimension)
  , r = diag(0.05, dimension)
  , b = dimension
  , w = diag(1, dimension)
  , n = 10000
  )

set.seed(42)

d_3d = model(
    config_3d$k, config_3d$l, config_3d$r
  , config_3d$b, config_3d$w, config_3d$n
  )

framed_3d = lapply(d_3d,
  function(mat) { data.frame(x = mat[,1], y = mat[,2], z = mat[,3]) })
melted_3d = do.call(rbind, framed_3d)

scatterplot3d(melted_3d, highlight.3d = T, pch = 19)


###### Knowledge Discovery and Data Mining (CS 513) ######
#         (Assignment 3 - Explore and Clean)

# Course      : CS 513 - A
# First Name  : PARAS
# Last Name   : GARG
# Id          : 10414982
# Purpose     : Assignment 3 - Explore and Clean

###### ******************************************** ######

# clearing object environment
rm(list=ls());

# 3.1. Load the following CSV file to your R environment : http://www.math.smith.edu/sasr/datasets/help.csv
loadCSVFile <- read.csv("http://www.math.smith.edu/sasr/datasets/help.csv");  # reading file
View(loadCSVFile);                                                            # viewing file

# 3.2. Using the above file perform the following,
# 3.2.1. Create a dataframe of: id, pcs1, mcs1, substance, and race group
newDataFrame = data.frame( id        = loadCSVFile$id,
                           pcs1      = loadCSVFile$pcs1,
                           mcs1      = loadCSVFile$mcs1,
                           substance = loadCSVFile$substance,
                           racegroup = loadCSVFile$racegrp );
View(newDataFrame);

# 3.2.2. Calculate: Mean, Max, STD, Max, Min of mcs1
  # mean
  mean(newDataFrame$mcs1, na.rm = TRUE);
  #median
  median(newDataFrame$mcs1, na.rm = TRUE)
  # standard deviation
  sd(newDataFrame$mcs1, na.rm = TRUE);
  # maximum
  max(newDataFrame$mcs1, na.rm = TRUE);
  # minimum
  min(newDataFrame$mcs1, na.rm = TRUE);

  # summary excute all the functions
  summary(newDataFrame$mcs1);

# 3.2.3. Create a frequency table of substance vs. racegroup
table(substance = newDataFrame$substance, racegroup = newDataFrame$racegroup)

# 3.2.4. Substitute the missing values of mcs1 by the overall average
for(i in seq(from=1, to=length(newDataFrame$mcs1), by=1)){
  if(is.na(newDataFrame$mcs1[i]))
    newDataFrame$mcs1[i] <- mean(newDataFrame$mcs1, na.rm = TRUE);
}
# the other way to repace all the values of mcs1 by the overall average is
  newDataFrame$mcs1[is.na(newDataFrame$mcs1)] <- mean(newDataFrame$mcs1, na.rm = TRUE);

View(newDataFrame);

CS 513 - Knowledge Discovery & Data Mining/Assignments/Assignment #3 - Explore & Clean/Assignment #3 Solution.r


library(rpart)
{{rimport}}('__init__.r', 'plot.r')

infile       = {{i.infile | quote}}
outmodel     = {{o.outmodel | quote}}
outdir       = {{o.outdir | quote}}
args.plot    = {{args.plot | R}}
args.formula = {{args.formula | R}}
inopts       = {{args.inopts | R}}
devpars      = {{args.devpars | R}}
na           = {{args.na | R}}
prefix       = {{i.infile | stem | quote}}

indata = read.table.inopts(infile, inopts)
indata[is.na(indata)] = na

cnames = colnames(indata)
if (is.null(cnames)) {
	colnames(indata) = c(paste('X', 1:(ncol(indata)-1)), 'Y')
	cnames = colnames(indata)
}

if (is.null(args.formula)) {
	backtick = function(x) sprintf('`%s`', x)
	ycol = cnames[ncol(indata)]
	args.formula = as.formula(paste(cnames[ncol(indata)], '~', paste(backtick(cnames[1:(ncol(indata)-1)]), collapse = '+')))
} else {
	ycol = unlist(strsplit(args.formula, '\\s*~\\s*'))[1]
	args.formula = as.formula(args.formula)
}

model.dt = rpart(args.formula, data = indata)
saveRDS(model.dt, outmodel)

# save importance
write.table(
	round(model.dt$variable.importance, 3),
	file.path(outdir, paste0(prefix, '.importance.txt')),
	col.names = F, row.names = T, quote = F, sep = "\t")

# plot importance
{% if args.plot %}
vi    = as.matrix(model.dt$variable.importance)
nfeat = min(30, nrow(vi))
vi    = vi[1:nfeat, , drop = F]
feats = rownames(vi)
plot.col(
	data.frame(Feature = feats, Importance = vi[, 1]),
	file.path(outdir, paste0(prefix, '.importance.png')),
	params  = list(aes(x = factor(feats, levels = rev(feats)))),
	ggs = list(coord_flip = list()),
	devpars = devpars)
{% endif %}


x <- 1:20
constant <- rep(1, 20)
linear <- 1:20
logarithmic <- log2(x)
quadratic <- x ^ 2
exponential <- 2 ^ x

svg("comparison.svg")

plot(x, constant, col = "black", type = "b", xlab = "Input Size", ylab = "Runtime / Complexity", pch = 20, xlim=c(1, 20), ylim=c(1, 200))
lines(x, linear, col = "blue", type = "b", pch = 20)
lines(x, logarithmic, col = "green", type = "b", pch = 20)
lines(x, quadratic, col = "red", type = "b", pch = 20)
lines(x, exponential, col = "darkviolet", type = "b", pch = 20)

legend("topleft", legend=c("Constant", "Linear", "Logarithmic", "Quadratic", "Exponential"), col=c("black", "blue", "green", "red", "darkviolet"), lty = 1:2, cex=0.8)


## Ch06.확률분포 : 도수분포(frequency table)의 %

abs <- c(0:4)
stu.n <- c(40,35,15,7,3)

pro.stu <- data.frame(abs,stu.n)

prop.stu1 <- prop.table(stu.n)

barplot(prop.stu1 ~ abs,
        main ="확률분포",
        xlab = "결석일수",
        ylab = "학생수")

# 이산확률변수와 연속확률변수의 차이 이해 (특정수치(사건 수, 방문자 수 등) vs. 연속변수(몸무게, 체온, 통근시간 등)

# 확률밀도함수: d~ 개별 건수에 대한 확률 확인
# 누적분포함수(점수): p~ 점수(숫자)를 가지고 몇 %에 해당하는지를 파악
# 누적분포함수(확률): q~ 확률을 가지고 몇 점에 해당하는지를 파악

## 01.이항분포
# 이항분포 확률밀도 : 확률이 두 가지로 구분되어 있을 경우 활용하는 방법
# dbinom(성공회수, size(시행횟수(n)), prob(성공확률)

# fortune 쿠키 성공사례 : 식당에서 쿠키를 나누어줌
# 시행횟수: 3명
# 성공확률: 90% (쿠키가 들어있을 확률)
# P(X = a) 확률 계산
dbinom(0, size=3, prob=0.9)
dbinom(1, size=3, prob=0.9)
dbinom(2, size=3, prob=0.9)
dbinom(3, size=3, prob=0.9)

# 이항분포 확률밀도 graph
y <- dbinom(0:3, size=3, prob=0.9)
plot(0:3, y,    # x를 0부터 3까지 4개로 쪼개라
     type='h',  #   유형이 달라지면, 그래프의 모양도 달라짐. 옵션은 찾아봐야 함
     lwd=10,
     col="red",
     ylab="확률",
     xlab="성공확률 X",
     main = "이항분포")

# 이항분포 누적확률계산
# 이하 : P(X <= a) lower.tail = TRUE * 여기가 옵션 넣을 때 매우 중요한 부분임. R의 기본 옵션은 이하와 초과로 구분
# 초과: P(X > a) lower.tail = FALSE
# P(X <= 1)이하로 받을 확률 => 3번 중에 1번 이하로 성공할 확률(누적확률이므로 pbinom사용 )
pbinom(1, size=3, prob=0.9, lower.tail = TRUE)

# 1명이상 받을 확률: P(X >= 1) 확률 계산, 초과이므로 최소 0을 넣어야 함. lowe.tail 옵션은 FALSE
pbinom(0, size=3, prob=0.9, lower.tail = FALSE)

# 누적이항분포  graph

plot(pbinom(0:3, size=3, prob=0.9),
     type='h',
     lwd=10,
     col="red",
     main = "누적이항분포")

## 퀴즈
# 성공확률 0.7, 10명중 7명 이상: P(X >= 7) 확률 계산

pbinom(6, size=10, prob=0.7, lower.tail = FALSE)

# 확률밀도 graph
y <- dbinom(0:10, size=10, prob=0.7)
plot(0:10, y,
     type='h',
     lwd=10,
     col="red",
     ylab="확률",
     xlab="성공확률 X",
     main = "이항분포")

# 누적이항분포  graph
plot(pbinom(0:10, size=10, prob=0.7),
     type='h',
     lwd=10,
     col="red",
     main = "누적이항분포")