#@author: Romeo Kienzler
#This file is copyright protected - do not redistribute

library(dbscan)
library(scatterplot3d)
data(iris)
View(iris)
irisorg = iris
iris <- as.matrix(iris[,1:4])
unique(irisorg$Species)
scatterplot3d(iris[,1],iris[,4],iris[,3], highlight.3d=TRUE, col.axis="blue", col.grid="lightblue", main="scatterplot3d - 1", pch=20)
res = dbscan(iris, eps = .8, minPts = 4)
length(unique(res$cluster))
map = list("setosa"=1, "versicolor"=2, "virginica"=3)
specieskey = unlist(lapply(irisorg$Species,  function(species) map[[species]]))

truthVectorValidate = res$cluster == specieskey
good = length(truthVectorValidate[truthVectorValidate==TRUE])
bad = length(truthVectorValidate[truthVectorValidate==FALSE])
good/(good+bad)


suppressMessages(library(craze))

x = matrix(as.double(1:6), 3)
x_fml = fmlmat(x)

test = as.matrix(svd(x_fml, 0, 0)$d)
truth = svd(x, 0, 0)$d
stopifnot(all.equal(test, truth))

test = as.matrix(svd(x_fml)$u)
truth = svd(x)$u
stopifnot(all.equal(abs(test), abs(truth)))


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(plyr)
library(dplyr)

simulate.mse = function (epsilon, samples, operation, simple, input.size, subset.ratio, overlap.ratio, range.a, range.b, range.mirror) {
  X = matrix(runif(samples*input.size, range.a, range.b), samples, input.size)

  if (range.mirror) {
    X.sign = matrix(rbinom(samples*input.size, 1, 0.5), samples, input.size) * 2 - 1
    X = X * X.sign
  }

  evaluate = function (W) {
    Z = X %*% W
    if (operation == 'add') {
      Y = Z[,1] + Z[,2]
    } else if (operation == 'sub') {
      Y = Z[,1] - Z[,2]
    } else if (operation == 'mul') {
      Y = Z[,1] * Z[,2]
    } else if (operation == 'div') {
      Y = Z[,1] / Z[,2]
    } else if (operation == 'squared') {
      Y = Z[,1] * Z[,1]
    } else if (operation == 'root') {
      Y = sqrt(Z[,1])
    }
    return(Y)
  }

  target.matrix = function (epsilon) {
    if (simple) {
      a.start = 1
      a.end = 2
      b.start = 1
      b.end = 4
    } else {
      subset.size = floor(subset.ratio * input.size)
      overlap.size = floor(overlap.ratio * subset.size)

      a.start = 1
      a.end = a.start + subset.size
      b.start = a.end - overlap.size
      b.end = b.start + subset.size
    }

    W = matrix(0 + epsilon, input.size, 2)
    W[a.start:a.end, 1] = 1 - epsilon
    W[b.start:b.end, 2] = 1 - epsilon
    return(W)
  }

  W.y = target.matrix(epsilon)
  W.t = target.matrix(0)
  errors = (evaluate(W.y) - evaluate(W.t))**2

  return(mean(errors))
}

cases = rbind(
  c(parameter='default', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='default', operation='div', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='default', operation='add', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='default', operation='sub', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='default', operation='root', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='default', operation='squared', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),

  c(parameter='simple', operation='mul', simple=T, input.size=4, subset.ratio=NA, overlap.ratio=NA, range.a=2, range.b=6, range.mirror=F),
  c(parameter='simple', operation='add', simple=T, input.size=4, subset.ratio=NA, overlap.ratio=NA, range.a=2, range.b=6, range.mirror=F),
  c(parameter='simple', operation='sub', simple=T, input.size=4, subset.ratio=NA, overlap.ratio=NA, range.a=2, range.b=6, range.mirror=F)
)

for (input.size in c(4,10,25,50,75,100,125,150,175,200,225,250,275,300)) {
  cases = rbind(cases, c(parameter='input.size', operation='mul', simple=F, input.size=input.size, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F))
}

for (subset.ratio in c(0.05, 0.10, 0.25, 0.50)) {
  cases = rbind(cases, c(parameter='subset.ratio', operation='mul', simple=F, input.size=100, subset.ratio=subset.ratio, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F))
}

for (overlap.ratio in c(0.0, 0.1, 0.25, 0.5, 0.75, 1.0)) {
  cases = rbind(cases, c(parameter='overlap.ratio', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=overlap.ratio, range.a=2, range.b=6, range.mirror=F))
}

cases = rbind(cases,
  c(parameter='extrapolation.range', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=-6, range.b=-2, range.mirror=F),
  c(parameter='extrapolation.range', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=T),
  c(parameter='extrapolation.range', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=1, range.b=5, range.mirror=F),
  c(parameter='extrapolation.range', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=0.2, range.b=2, range.mirror=F),
  c(parameter='extrapolation.range', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=2, range.b=6, range.mirror=F),
  c(parameter='extrapolation.range', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=1.2, range.b=6, range.mirror=F),
  c(parameter='extrapolation.range', operation='mul', simple=F, input.size=100, subset.ratio=0.25, overlap.ratio=0.5, range.a=20, range.b=40, range.mirror=F)
)

eps = data.frame(rbind(
  c(operation='mul', epsilon=0.00001),
  c(operation='add', epsilon=0.00001),
  c(operation='sub', epsilon=0.00001),
  c(operation='div', epsilon=0.00001),
  c(operation='squared', epsilon=0.00001),
  c(operation='root', epsilon=0.00001)
))

mse = data.frame(cases) %>%
  merge(eps) %>%
  mutate(
    simple=as.logical(as.character(simple)),
    input.size=as.integer(as.character(input.size)),
    subset.ratio=as.numeric(as.character(subset.ratio)),
    overlap.ratio=as.numeric(as.character(overlap.ratio)),
    range.a=as.numeric(as.character(range.a)),
    range.b=as.numeric(as.character(range.b)),
    range.mirror=as.logical(as.character(range.mirror)),
    epsilon=as.numeric(as.character(epsilon))
  ) %>%
  rowwise() %>%
  mutate(
    threshold=simulate.mse(epsilon, 1000000, operation, simple, input.size, subset.ratio, overlap.ratio, range.a, range.b, range.mirror),
    extrapolation.range=ifelse(range.mirror, paste0('U[-',range.b,',-',range.a,'] ∪ U[',range.a,',',range.b,']'), paste0('U[',range.a,',',range.b,']')),
    operation=paste0('op-', operation)
  )

write.csv(mse, file="../results/function_task_static_mse_expectation.csv", row.names=F)


#------------------------------------------------------------
# wav2r -- Waveform to Autocorrelation
#
# Calculates m (default = 18) autocorrelation coefficients from an
# input signal.
#------------------------------------------------------------
wav2r <- function(s, m=18) {
  ns = length(s)
  r = array()
  r[1] = sum(s^2)
  for (j in 2:m) {
    r[j] = sum(s[1:(ns-j+1)] * s[j:ns])
  }
  return(r)
}


# Elevation
library(pacman)
p_load(sf,
       raster,
       rgeos,
       rasterVis,
       leaflet,
       dplyr)

# Loading and cleaning shapefile and elevation data
point_shp <- st_read("../data/anlaeg_all_4326.shp")
point_shp <- point_shp[!(!is.na(point_shp$anlaegsbet) & point_shp$anlaegsbet==""), ]
raster_elev <- raster('DTM_10m_20200622.tiff')

# Empty raster to reproject elevation raster with - changes to CRS WGS84
tmax <- raster(nrow=888, ncol=1848, xmn=3.875395, xmx=16.4037 , ymn=54.38102 , ymx=58.24733, crs="+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs")

# Projection and cropping areas of interest
raster_elev_proj <- projectRaster(raster_elev, tmax)
elev <- crop(raster_elev_proj, st_bbox(point_shp))

# Extract elevation for every mound and add to data frame as Elevation column
findings_elev <- raster::extract(elev, point_shp)
point_shp$Elevation <- findings_elev

# Summarised dataframe grouped by both type of finding and municipality
finding_by_elev <- point_shp %>%
  st_drop_geometry() %>%
  group_by(anlaegsbet, kommunenav) %>%
  summarise(mean_elev = mean(Elevation, na.rm = TRUE),
            sd = sd(Elevation, na.rm = TRUE)) %>%
  na.omit()

# Change name for compatibility with other dataframe
finding_by_elev$kommunenav <- ifelse(finding_by_elev$kommunenav=="Århus", "Aarhus", finding_by_elev$kommunenav)
finding_by_elev$kommunenav <- ifelse(finding_by_elev$kommunenav=="Vesthimmerland", "Vesthimmerlands", finding_by_elev$kommunenav)

# Save
write_csv(finding_by_elev, "../data/preprocessed/municipal_elevation.csv")

#### T test ####
# Crop elevation map to the bounding box of all findings in DK
church_test_data <- point_shp %>% filter(anlaegsbet=="Kirke" | anlaegsbet=="Bosættelse, uspec undergruppe")

# Selecting elevation for all other findings
elev_no_church <- church_test_data %>%
  st_drop_geometry() %>%
  filter(anlaegsbet =="Bosættelse, uspec undergruppe") %>%
  dplyr::select(Elevation) %>%
  drop_na()

# Selecting elevation for churches
elev_church <- church_test_data %>%
  st_drop_geometry() %>%
  filter(anlaegsbet =='Kirke') %>%
  dplyr::select(Elevation) %>%
  drop_na()

church_test_data %>%
  group_by(anlaegsbet) %>%
  summarise(mean_ele=mean(Elevation, na.rm = TRUE),
            sd_ele = sd(Elevation, na.rm = TRUE)) %>%
  print()

# Performing t-test
t.test(elev_church, elev_no_church)


library(ggplot2)
library(dplyr)
library(reshape2)
#load data
data <- read.csv("Downloads/MachineLearning-master/Example Data/PCA_Example_1.csv", stringsAsFactors=F)
#change the first column format as Date
data$Date = as.Date(data$Date)
#transform stock data into Date Stock1  Stock2 .... Stock24
data <- reshape(data, idvar = "Date", timevar = "Stock", direction = "wide")
#sort data by date, asc
data <- arrange(data, Date)
#change column id(sort by A, B....Z)
data<-data[,order(colnames(data),decreasing=F)]
#apply PCA
pca.model = prcomp(data[,1:ncol(data)-1])
#Get PCA component PCA component 1:
PC1 <- pca.model$x[,"PC1"]
#add id as duration days:
duration <- 1:length(PC1)
#transform into data frame and combine
PC1 <- as.data.frame(PC1)
duration <- as.data.frame(duration)
PC1 <- cbind(PC1, duration)
colnames(PC1) <- c("feature", "duration")
#draw plot
pc1_plot <- qplot(PC1$duration, PC1$feature)
#verify data path
data.verify <- read.csv("Downloads/MachineLearning-master/Example Data/PCA_Example_2.csv", stringsAsFactors = F)
data.verify$Date <- as.Date(data.verify$Date)
#subset data, only contains 2 columns, date and close
data.verify <- data.verify[,c(1,5)]
#sort by date
data.verify <- arrange(data.verify, Date)
#add duration
duration.verify <- 1:nrow(data.verify)
duration.verify <- as.data.frame(duration.verify)
data.verify <- cbind(duration.verify, data.verify)
#normalize data
max.value <- max(data.verify$Close)
min.value <- min(data.verify$Close)
range.value <- max.value - min.value
data.verify$Close <- data.verify$Close/range.value
#plot data
qplot(data.verify$duration.verify, data.verify$Close)
#normalize to the same scale
#I wrote the normalize part into the readme.md in R folder


### Model Complexity Toy Example
## Use: Generate data for the toy example in the paper
## Author: Mark Verhagen

## Load libraries
library(tidyverse)
library(texreg)
library(lmtest)

## Set n and seed
n <- 40000
set.seed(1704)

n <- 40000
set.seed(1704)

## Simulate data for toy example

age <- rnorm(n, 0, 7.5) + 70
age[age <= 50] <- runif(length(age[age <= 50]), 50, 51)
age[age >= 90] <- runif(length(age[age >= 90]), 89, 90)
medication_use <- ifelse((age - 20) / 100 + runif(n, 0, 0.2) >
    runif(n, 0, 1), 1, 0)
gender <- ifelse((runif(n, 0, 1) + (age / 1000)) > 0.5, 1, 0)
assistance <- ifelse(runif(n, 0, 0.08) + (age / 180) > 0.5, 1, 0)
error <- rnorm(n, 0, 0.3)

fixed_part <- (10 * (ifelse(age >= 50, (age - 50) * 0.025, -0.8) +
    ifelse(age > 65, (age - 65) * 0.05, 0) -
    ifelse(age > 75, (age - 75) * 0.04, 0) -
    ifelse(age > 85, (age - 85) * 0.025, 0) + 0.05 * assistance +
    0.05 * medication_use -
    0.1 * gender + error)) + 10

y <- ifelse(fixed_part < 0, 0, fixed_part)

df <- data.frame(
    fall = y, age = age, age2 = age^2, med_use = medication_use,
    sex = gender, assist = assistance
) %>%
    mutate(
        age_50p = ifelse(age >= 50, age - 50, 0),
        age_65p = ifelse(age > 65, age - 65, 0),
        age_75p = ifelse(age > 75, age - 75, 0),
        age_85p = ifelse(age > 85, age - 85, 0)
    )

## Save datasets for other scripts
save(df, file = "toy_example/data/edit/toy_data.rda")
write.csv(df, "toy_example/data/edit/toy_df.csv")

## Estimate three functional forms
lm1 <- lm(fall ~ 1 + age + assist + sex + med_use, data = df)

lm2 <- lm(fall ~ 1 + age + age2 + assist + sex + med_use, data = df)

lm3 <- lm(fall ~ 1 + age_50p + age_65p + age_75p + age_85p + assist + sex +
    med_use, data = df)

## Evaluate LR-likelihood test
lrtest(lm1, lm2)
lrtest(lm2, lm3)

## Output regression results
texreg(list(summary(lm1), summary(lm2), summary(lm3)),
    file = "tex/tables/results_toy.tex"
)
screenreg(list(summary(lm1), summary(lm2), summary(lm3)))

## Generate dataset including the implied age effect from the linear models
lm1_df <- summary(lm1)$coefficients %>% as.data.frame()
lm2_df <- summary(lm2)$coefficients %>% as.data.frame()
lm3_df <- summary(lm3)$coefficients %>% as.data.frame()

df <- df %>%
    mutate(
        true_effect = 10 * (age_50p * 0.025 + age_65p * 0.05 -
            age_75p * 0.04 - age_85p * 0.025),
        lm1_implied = lm1_df$Estimate[1] + lm1_df$Estimate[2] * age - 10,
        lm2_implied = lm2_df$Estimate[1] + lm2_df$Estimate[2] * age + lm2_df$Estimate[3] * age2 - 10,
        lm3_implied = lm3_df$Estimate[1] + lm3_df$Estimate[2] * age_50p + lm3_df$Estimate[3] * age_65p +
            lm3_df$Estimate[4] * age_75p + lm3_df$Estimate[5] * age_85p - 10
    )

df_effects <- df %>%
    sample_frac(0.1) %>%
    dplyr::select(age, true_effect, lm1_implied, lm2_implied, lm3_implied) %>%
    reshape2::melt(id.vars = c("age")) %>%
    mutate(` ` = ifelse(grepl("true", variable), "True effect", NA))

saveRDS(df_effects, "toy_example/data/edit/df_effects.rds")


library(quantreg)
q1<-0.025 #lower quantile
q2<-0.975 #higher quantile
first.qr.spcies.no<-1  # first predator species where qr is done  pred(9)=R. radiata

stom<-Read.stomach.data()

cleanup()
dev<-'screen'
dev<-'png'
nox<-2; noy<-2;
newplot(dev,filename='Quantile-regressesion',nox,noy);
i<-0

stom2<-subset(stom,Size.model>0 & Prey.no !=0 &stomcon>1E-4 & stom.used.like==1 & Predator.no>=first.qr.spcies.no)
if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Prey.no,stom2$Predator),function(x) {
 if (min(x$Predator.size) < max(x$Predator.size)) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
    cat(paste(x[1,]$Predator," eating ",x[1,]$Prey,'\n'))
   plot(log(x$Predator.size),log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(predator size)',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio))
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~log(Predator.size) ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3,lwd=2)

   #quantile regression
   for (tau in c(q1,q2)) {
     ru<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=tau)
     abline(ru,col='blue',lty=2)
   }
   # weighted regression
   #aa<-lm(log(Predator.size/Prey.size)~log(Predator.size),weights=stomcon ,data=x)
   #ac<-aa[["coefficients"]]
   #abline(aa, lty=2,col=2)

   title(main=paste(x[1,]$Predator," eating ",x[1,]$Prey,
     " a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),sep=""))
   i<<-i+1
 } else  cat(paste('No regression done for ',x[1,]$Predator," eating ",x[1,]$Prey,'\n'))
})}

if (dev=='png') cleanup()
stom<-Read.stomach.data()
stom<-subset(stom,Size.model>0 & Prey.no !=0 &stomcon>1E-4 & stom.used.like==1 & Predator.no>=first.qr.spcies.no)

qunatileRegression<-function(tau=0.05){

  q<-by(stom,list(stom$Predator.no,stom$Prey.no),function(x) {

   x<-subset(x,Predator.size> Prey.size)

  #cat(x[1,'Predator'],'\n')
   rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=tau)
  })
  dimq<-dimnames(q)
  npred<-max(as.numeric(dimq[[1]]))
  minprey<-min(as.numeric(dimq[[2]]))
  maxprey<-max(as.numeric(dimq[[2]]))

  a<-matrix(-99,ncol=maxprey-minprey+1,nrow=npred)
  dimnames(a)[2]<-list(as.character(seq(minprey,maxprey)))
  dimnames(a)[1]<-list(as.character(seq(1,npred)))
  b<-a

  for (i in dimq[[1]]) for (j in dimq[[2]]) if (!is.null(q[[i,j]])) {
   a[i,j]<-q[[i,j]][["coefficients"]][1]
   b[i,j]<-q[[i,j]][["coefficients"]][2]
  }
  list(a,b)
}

a.lower<-qunatileRegression(tau=q1)
a.higher<-qunatileRegression(tau=q2)

if (T) {
  out<-file.path(data.path,"pred_prey_size_range_param_draft.in")
  cat("# Quantile regression parameters for predator/prey size ratio as a function of predator size\n",file=out)
  cat("# size select.model used for parameter estimate =",SMS.control@size.select.model,'\n',file=out,append=TRUE)
  #cat("# ",SMS.control@species.names,"\n",file=out,append=TRUE)
  cat("# intercept values for",q1*100,"% Quantile \n",file=out,append=TRUE)

  write.table(format(round(a.lower[[1]],4),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)
  cat("# slope values for",q1*100,"% Quantile \n",file=out,append=TRUE)
  write.table(format(round(a.lower[[2]],4),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)

  cat("# intercept values for",q2*100,"% Quantile \n",file=out,append=TRUE)
  write.table(format(round(a.higher[[1]],4),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)
  cat("# slope values for",q2*100,"% Quantile \n",file=out,append=TRUE)
  write.table(format(round(a.higher[[2]],4),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)
  cat("-999  #checksum\n" ,file=out,append=TRUE )
}

##############################################################
# plot pred prey size realtions for all combinations of predators and preys
#  and overlay with "size band" estimated above

Init.function()
sizeModel<-SMS.control@size.select.model

dat<-Read.summary.data()
dat<-subset(dat,Year==SMS.control@last.year.model,select=c(Species, Year, Quarter, Species.n, Age, west, Lsea))

if (sizeModel==1) dat$size<-dat$Lsea
if (sizeModel==2 | sizeModel==3) dat$size<-dat$west
if (sizeModel==4) {
  lw<-Read.length.weight.relation()
  dat<-merge(dat,lw)
  dat$size<-dat$a*dat$Lsea^dat$b
}

dat<-subset(dat,select=c(Species.n,Quarter,Age,size))

pred<-subset(dat,Species.n<=npr)
pred$Pred.no<-pred$Species.n
pred$predSize<-pred$size
pred$predAge<-pred$Age
pred<-subset(pred,select=c(-Species.n,-size, -Age))

prey<-subset(dat,Species.n>=first.VPA)
prey$Prey.no<-prey$Species.n
prey$preySize<-prey$size
prey$preyAge<-prey$Age
prey<-subset(prey,select=c(-Species.n,-size, -Age))

a<-merge(pred,prey)

vul<-subset(Read.vulnerability(),select=c(Pred.no,Prey.no))
a<-merge(a,vul)
#a<-subset(a,Pred.no>=first.VPA)

a$ratio<-SMS.control@prey.pred.size.fac[a$Pred.no]
a$color<-'red'
a[a$preySize<=a$predSize*a$ratio,]$color<-'blue'

cleanup()
i<-0
by(a,list(a$Prey.no,a$Pred.no),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   cat(paste(x[1,]$Pred.no," eating ",x[1,]$Prey.no,'\n'))
   X11()
   plot(log(x$predSize),log(x$predSize/x$preySize),main=NULL,xlab='log(predator size)',col=x$color,
           ylab="log(pred.size/prey.size)",ylim=c(min.ratio,max.ratio))

   abline(a=a.lower[[1]][as.character(x[1,]$Pred.no),as.character(x[1,]$Prey.no)],
          b=a.lower[[2]][as.character(x[1,]$Pred.no),as.character(x[1,]$Prey.no)],lty=3,col='red')
   abline(a=a.higher[[1]][as.character(x[1,]$Pred.no),as.character(x[1,]$Prey.no)],
          b=a.higher[[2]][as.character(x[1,]$Pred.no),as.character(x[1,]$Prey.no)],lty=3,col='red')

   title(paste(sp.names[x[1,]$Pred.no]," eating ",sp.names[x[1,]$Prey.no],'\n'))
   i<<-i+1
})

##############################################################
#observation of predator-prey size ratio against predator size by predator
## prog size 2b

cleanup()
nox<-2; noy<-2;
dev<-'sceen'
newplot(dev,nox,noy);
i<-0

stom2<-subset(stom,Size.model>0 & Prey.no !=0 &stomcon>1E-4)

if (dim(stom2)[1]==0) stop("No data, probably because there is no size selection applied in the model") else {
min.ratio<-log(min(stom2$Predator.size/stom2$Prey.size))
max.ratio<-log(max(stom2$Predator.size/stom2$Prey.size))

by(stom2,list(stom2$Prey.no,stom2$Predator.no),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   par(mar=c(4,4,8,3))   #c(bottom, left, top, right)
   plot(log(x$Predator.size),log(x$Predator.size/x$Prey.size),main=NULL,xlab='log(predator size)',ylab="log(pred.size/prey.size)",
             ylim=c(min.ratio,max.ratio))
   abline(h=0, lty=3)
   aa<-lm(log(Predator.size/Prey.size)~log(Predator.size) ,data=x)
   ac<-aa[["coefficients"]]
   abline(aa, lty=3,lwd=2)

   #quantile regression

   rl<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=q1)
   abline(rl,col='blue',lty=2)
   ru<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=q2)
   abline(ru,col='blue',lty=2)
   rmm<-rq(log(Predator.size/Prey.size)~log(Predator.size) ,data=x, tau=0.5)
   abline(rmm,col='red',lty=2)

   # weighted regression
   #aa<-lm(log(Predator.size/Prey.size)~log(Predator.size),weights=stomcon ,data=x)
   #ac<-aa[["coefficients"]]
   #abline(aa, lty=2,col=2)

   title(main=paste(x[1,]$Predator," eating ",x[1,]$Prey, "\n",
     "mean:  a=",formatC(ac[1],2,format='f')," b=",formatC(ac[2],2,format='f'),"\n",
     "50%:   a=",formatC(rmm[["coefficients"]][1],2,format='f')," b=",formatC(rmm[["coefficients"]][2],2,format='f'),"\n",
     "lower: a=",formatC(rl[["coefficients"]][1],2,format='f')," b=",formatC(rl[["coefficients"]][2],2,format='f'),"\n",
     "upper: a=",formatC(ru[["coefficients"]][1],2,format='f')," b=",formatC(ru[["coefficients"]][2],2,format='f'),

     sep=""))
   i<<-i+1
})}

 ###########################
 # use only intercept values, to allow fixed size ratio in simulation runs
stom2<-subset(stom,Size.model>0 & Prey.no !=0 &stomcon>1E-4)
stom2$ratio<-log(stom2$Predator.size/stom2$Prey.size)

a<-tapply(stom2$ratio,list(stom2$Predator.no,stom2$Prey.no),min)
a[is.na(a)]<- -99
tt<-matrix(rep(-99,6),ncol=1)      # saithe as prey
a<-cbind(a[,1:3],tt,a[,4:6])

out<-file.path(data.path,"pred_prey_size_range_param_fixed.in")
cat("# Quantile regression parameters for predator/prey size ratio as a function of predator size\n",file=out)
cat("# ",SMS.control@species.names,"\n",file=out,append=TRUE)
cat("# intercept values\n",file=out,append=TRUE)
write.table(format(round(a,4),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)
cat("# slope values\n",file=out,append=TRUE)
a[,]<-0

write.table(format(round(a,0),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)

a<-tapply(stom2$ratio,list(stom2$Predator.no,stom2$Prey.no),max)
a[is.na(a)]<- -99
tt<-matrix(rep(-99,6),ncol=1)      # saithe as prey
a<-cbind(a[,1:3],tt,a[,4:6])

cat("# Quantile regression parameters for predator/prey size ratio as a function of predator size\n",file=out,append=T)
cat("# ",SMS.control@species.names,"\n",file=out,append=TRUE)
cat("# intercept values\n",file=out,append=TRUE)
write.table(format(round(a,4),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)
cat("# slope values\n",file=out,append=TRUE)
a[,]<-0
write.table(format(round(a,0),width=11),file=out,quote=FALSE,row.names=FALSE,col.names=FALSE,append=TRUE)


# R equivalent of judges.sas

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

# need to convert judge # to a factor
#  judges are numbered, so read.table() leaves as numbers
#  even without as.is=T.
#  this is why I prefer to explicitly convert

judges$judge.f <- as.factor(judges$judge)

# fit the ANOVA model using either lm() or aov()

judges.lm <- lm(percent~judge.f, data=judges)
judges.aov <- aov(percent~judge.f, data=judges)

# calculate and print the anova table
anova(judges.lm)     # anova(judges.aov) gives same results

# here's what happens if you mistakenly forget the factor
anova(lm(percent~judge, data=judges))

# judge has 1 d.f.!!!
#  You're fitting a linear regression, not an ANOVA model

# Stuff 'after' the fitting the ANOVA
#  Here's where R is not nearly as flexible as SAS

# tables of means, only for aov object

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

# BUT will only compute se's if equal # obs in each cell !!!!

# and from here on out, you're stuck, at least without
#   hand coding things. There is a se.contrast function, but
#   you can't specify the contrasts.  You need to use
#   sets of predefined contrasts (polynomials, helmert, ...)

# there may be appropriate functions in add on packages,
#   but I haven't found them.

# the one thing that is nice is diagnostics

# e.f. a residual vs predicted value plot:
plot(predict(judges.lm), resid(judges.lm))

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


corr <- function(directory, threshold = 0) {
  full_files <- list.files(directory, full.names = TRUE)
  result1 <- numeric()

  for (i in 1:length(full_files)) {
    newData1 <- read.csv(full_files[i])

    data_sum <- sum((!is.na(newData1$sulfate)) & (!is.na(newData1$nitrate)))

    if (data_sum > threshold) {
      tmpData <- newData1[which(!is.na(newData1$sulfate)), ]

      subnewData1 <- tmpData[which(!is.na(tmpData$nitrate)), ]

      result1 <- c(result1, cor(subnewData1$sulfate, subnewData1$nitrate))
    }
  }

  result1
}


library(raster)
library(gdistance)
## Create a matrix with random data & use image()
xy <- matrix(rnorm(400),20,20)
image(xy)

# Turn the matrix into a raster
rast <- raster(xy)
# Give it lat/lon coords for 36-37°E, 3-2°S
extent(rast) <- c(36,37,-3,-2)
# ... and assign a projection
projection(rast) <- CRS("+proj=longlat +datum=WGS84")
plot(rast)
rast
rast$value2 <- 1
rast
plot(rast)

library(raster)
library(tidyverse)
library(RColorBrewer)

#Fatores de tipo de terreno
kanto_info <- read.csv('dataframe_kanto.csv', sep=';', header=F)
terrain <- data.frame(
            num_factor = c(0,1,2,3,4,5,6,7),
            terrain = c('SE','LD','CT','RM','RC','RG','RF','SH'),
            speed = c(6.5,0.55,5,1.65,15,4.5,3.5,20)
            )
kanto_terrain <- kanto_info %>%
                mutate(V1 = as.character(V1)) %>%
                left_join(., terrain, by=c('V1' = 'terrain')) %>%
                dplyr::select(num_factor) %>%
                rename(terrain = num_factor) %>%
                as.matrix(.)
dim(kanto_terrain) <- c(17, 20)

#fatores de velocidade
kanto_speed <- kanto_info %>%
  mutate(V1 = as.character(V1)) %>%
  left_join(., terrain, by=c('V1' = 'terrain')) %>%
  dplyr::select(speed) %>%
  as.matrix(.)
dim(kanto_speed) <- c(17, 20)

#raster de terreno
kanto <- raster(kanto_speed,
                xmn=139.81,
                xmx=140.18,
                ymn=34.81,
                ymx=35.19,
                crs=CRS("+proj=longlat +datum=WGS84")
                )

#matriz de transição: custo de velocidade de cada tipo de terreno
custoMov <- transition(kanto, function(x) 1/mean(x), 8)
custoMov <- geoCorrection(custoMov)

#localização dos pokécenters
grid_centers <- rbind(
c(3,3),
c(5,4),
c(5,16),
c(8,4),
c(10,6),
c(11,14),
c(13,3),
c(13,6),
c(13,10),
c(17,6))

convCoord <- function(vec){
  #função para por os centros pokémons nas coordenadas corretas
  delta_x <- (140.18-139.81)/21
  delta_y <- (35.19-34.81)/18
  result <- cbind(vec[,1] * delta_x + 139.81, vec[,2] * delta_y+34.81)
  return(result)
}

kanto_centers <- convCoord(grid_centers)
CostMap <- accCost(custoMov, kanto_centers)
CostMap <- CostMap/7000

#plot dos mapas
par(mfrow=c(2, 1))
plot(kanto, main='Custo de movimentação de terreno')
plot(CostMap, col=brewer.pal(n= 9, name='Greens'), main='Isocronos para centros mais próximos')


mmsimstudy1<-function(family="gaussian",n=200,m=10,beta=c(2,0),tau=2,nd=100,balance=TRUE,long=FALSE)
{
  bps <- FALSE  # Indicate perfect separation for binomial data
  print(paste("m = ",m))

  remlx1 <- matrix(NA,nrow=nd,ncol=6)
  mlx1 <- matrix(NA,nrow=nd,ncol=8) # 3: rsq_V (fixed only); 4: rsq_KL (fixed only);7: rsq_V (fixed only for X); 8: rsq_KL (fixed only for X)
  remlx2 <- matrix(NA,nrow=nd,ncol=6)
  mlx2 <- matrix(NA,nrow=nd,ncol=8) # 3: rsq_V (fixed only); 4: rsq_KL (fixed only);7: rsq_V (fixed only for X); 8: rsq_KL (fixed only for X)
  for(d in 1:nd)
  {

    print(paste("  data set = ",d))
    tfamily <- family
    if( family=="probit" )
      tfamily <- "binomial"
    if( long ) # only binomial or gaussian
    {
      simdata <- simldata(family=tfamily,beta=beta,tau=tau,n=n,m=m,balance=balance)
      simdata$yx$seq <- rep(1:(n/m),m)
    }
    else
      simdata <- simglmm(family=tfamily,beta=beta,tau=tau,n=n,m=m,balance=balance)

    if( family=="gaussian")
    {
      # ------------------------------------------
      # Y~X1

      # REML:
      if( long )
        remlfit <- lme(y~x1,random=list(subject=pdDiag(~1)),
                     corr=corAR1(form=~seq|subject),data=simdata$yx)
      else
        remlfit <- lmer(y~x1+(1|subject),data=simdata$yx)

      # rsq
      trsq <- try(rsq(remlfit))
      if(inherits(trsq,"try-error"))
        trsq <- list(model=NA,fixed=NA, random=NA)

      remlx1[d,1] = trsq$model
      remlx1[d,2] = trsq$fixed
      remlx1[d,3] = trsq$random

      # r2_xu
      trsq <- r2_xu(remlfit)
      remlx1[d,4] = trsq

      # r2_nakagawa
      trsq <- r2_nakagawa(remlfit)
      if( check_singularity(remlfit) )
        remlx1[d,5] = 0
      else
        remlx1[d,5] = trsq[[1]]

      remlx1[d,6] = trsq[[2]]

      # ------------------------------------------
      # ML:
      if(long )
        mlfit <- lme(y~x1,random=list(subject=pdDiag(~1)),
                     corr=corAR1(form=~seq|subject),data=simdata$yx,method="ML")
      else
        mlfit <- lmer(y~x1+(1|subject),data=simdata$yx,REML=F)

      # rsq
      trsq <- try(rsq(mlfit))
      if(inherits(trsq,"try-error"))
        trsq <- list(model=NA,fixed=NA, random=NA)

      mlx1[d,1] = trsq$model
      mlx1[d,2] = trsq$fixed
      mlx1[d,3] = trsq$random

      # r2_xu
      trsq <- r2_xu(mlfit)
      mlx1[d,4] = trsq

      # r2_nakagawa
      trsq <- r2_nakagawa(mlfit)
      if( check_singularity(remlfit) )
        remlx1[d,5] = 0
      else
        mlx1[d,5] = trsq[[1]]

      mlx1[d,6] = trsq[[2]]

      # ------------------------------------------
      # Y~X2

      # REML:
      if( long )
        remlfit <- lme(y~x2,random=list(subject=pdDiag(~1)),
                       corr=corAR1(form=~seq|subject),data=simdata$yx)
      else
        remlfit <- lmer(y~x2+(1|subject),data=simdata$yx)

      # rsq
      trsq <- try(rsq(remlfit))
      if(inherits(trsq,"try-error"))
        trsq <- list(model=NA,fixed=NA, random=NA)

      remlx2[d,1] = trsq$model
      remlx2[d,2] = trsq$fixed
      remlx2[d,3] = trsq$random

      # r2_xu
      trsq <- r2_xu(remlfit)
      remlx2[d,4] = trsq

      # r2_nakagawa
      trsq <- r2_nakagawa(remlfit)
      if( check_singularity(remlfit) )
        remlx1[d,5] = 0
      else
        remlx2[d,5] = trsq[[1]]

      remlx2[d,6] = trsq[[2]]

      # ------------------------------------------
      # ML:
      if( long )
        mlfit <- lme(y~x2,random=list(subject=pdDiag(~1)),
                       corr=corAR1(form=~seq|subject),data=simdata$yx,method="ML")
      else
        mlfit <- lmer(y~x2+(1|subject),data=simdata$yx,REML=F)

      # rsq
      trsq <- try(rsq(mlfit))
      if(inherits(trsq,"try-error"))
        trsq <- list(model=NA,fixed=NA, random=NA)

      mlx2[d,1] = trsq$model
      mlx2[d,2] = trsq$fixed
      mlx2[d,3] = trsq$random

      # r2_xu
      trsq <- r2_xu(mlfit)
      mlx2[d,4] = trsq

      # r2_nakagawa
      trsq <- r2_nakagawa(mlfit)
      if( check_singularity(remlfit) )
        remlx1[d,5] = 0
      else
        mlx2[d,5] = trsq[[1]]

      mlx2[d,6] = trsq[[2]]
    } else { #"binomial" or "probit" or others
      sdata <<- simdata$yx
      # ------------------------------------------
      # Y~X1

      # ML only
      if( family=="probit" )
        mlfit <- try(glmer(y~x1+(1|subject),data=sdata,family=binomial(link="probit")),silent=T)
      else
        mlfit <- try(glmer(y~x1+(1|subject),data=sdata,family=family),silent=T)

      if(inherits(mlfit,"try-error"))
      {
        mlx1[d,1] = NA
        mlx1[d,2] = NA
        #mlx1[d,3] = NA

        # r2_nakagawa
        mlx1[d,5] = NA
        mlx1[d,6] = NA
      }
      else
      {
        trsq <- try(rsq(mlfit))
        if(inherits(trsq,"try-error"))
          trsq <- list(model=NA,fixed=NA, random=NA)

        mlx1[d,1] = trsq$model
        mlx1[d,2] = trsq$fixed
        #mlx1[d,3] = trsq$random

        # r2_nakagawa
        trsq <- r2_nakagawa(mlfit)
        if( check_singularity(mlfit) )
          mlx1[d,5] = 0
        else
          mlx1[d,5] = trsq[[1]]

        mlx1[d,6] = trsq[[2]]
      }

      # Fixed effects only for rsq_V & rsq_KL
      if( family=="probit" )
        mlfit <- glm(y~x1+as.factor(subject),data=sdata,family=binomial(link="probit"))
      else
        mlfit <- glm(y~x1+as.factor(subject),data=sdata,family=family)

      mlx1[d,3] = rsq(mlfit)  # rsq_V
      mlx1[d,4] = rsq(mlfit,type="kl")  # rsq_KL

      # Without subject effects:
      if( family=="probit" )
        mlfit <- glm(y~x1,data=sdata,family=binomial(link="probit"))
      else
        mlfit <- glm(y~x1,data=sdata,family=family)

      mlx1[d,7] = rsq(mlfit)  # rsq_V
      mlx1[d,8] = rsq(mlfit,type="kl")  # rsq_KL

      # ------------------------------------------
      # Y~X2

      if( family=="probit" )
        mlfit <- try(glmer(y~x2+(1|subject),data=sdata,family=binomial(link="probit")),silent=T)
      else
        mlfit <- try(glmer(y~x2+(1|subject),data=sdata,family=family),silent=T)

      if(inherits(mlfit,"try-error"))
      {
        mlx2[d,1] = NA
        mlx2[d,2] = NA
        #mlx2[d,3] = NA

        # r2_nakagawa
        mlx2[d,5] = NA
        mlx2[d,6] = NA
      }
      else
      {
        # rsq
        trsq <- try(rsq(mlfit))
        if(inherits(trsq,"try-error"))
          trsq <- list(model=NA,fixed=NA, random=NA)

        mlx2[d,1] = trsq$model
        mlx2[d,2] = trsq$fixed
        #mlx2[d,3] = trsq$random

        # r2_nakagawa
        trsq <- r2_nakagawa(mlfit)
        if( check_singularity(mlfit) )
          mlx2[d,5] = 0
        else
          mlx2[d,5] = trsq[[1]]

        mlx2[d,6] = trsq[[2]]
      }

      # Fixed effects only for rsq_v & rsq_KL
      if( family=="probit" )
        mlfit <- glm(y~x2+as.factor(subject),data=sdata,family=binomial(link="probit"))
      else
        mlfit <- glm(y~x2+as.factor(subject),data=sdata,family=family)

      mlx2[d,3] = rsq(mlfit)  # rsq_V
      mlx2[d,4] = rsq(mlfit,type="kl")  # rsq_KL

      # Without subject effects:
      if( family=="probit" )
        mlfit <- glm(y~x2,data=sdata,family=binomial(link="probit"))
      else
        mlfit <- glm(y~x2,data=sdata,family=family)

      mlx2[d,7] = rsq(mlfit)  # rsq_V
      mlx2[d,8] = rsq(mlfit,type="kl")  # rsq_KL
    }
  }

  if( family=="gaussian")
  {
    remlx1.median <- apply(remlx1,2,median,na.rm=T)
    remlx2.median <- apply(remlx2,2,median,na.rm=T)
  }

  mlx1.median <- apply(mlx1,2,median,na.rm=T)
  mlx2.median <- apply(mlx2,2,median,na.rm=T)

  retList <- list(mlx1.median=mlx1.median,mlx2.median=mlx2.median)
  if( family=="gaussian")
    retList <- list(remlx1.median=remlx1.median,mlx1.median=mlx1.median,
                    remlx2.median=remlx2.median,mlx2.median=mlx2.median)

  retList
}


library(plotly)

dt <- read.table("500-node-from-500-to-1000-app-linear.txt",
                 col.names=c("number", "time"),
                 fill=FALSE,
                 strip.white=TRUE)

l1 = lm(data = dt, time ~ number)
l2 = lm(data = dt, time ~ I(number^2))

p <- plot_ly(data = dt, x = ~number, y = ~time, name = 'raw data', type = 'scatter') %>%
  add_trace(y = predict(l1), mode = 'lines', name = 'linear') %>%
  add_trace(y = predict(l2), mode = 'lines', name = 'X^2')

p


##
## Reproductive success - age at first birth
##
## Supplementary Table 8
##
source("init.r")

library(survival)
library(MuMIn)

####################################################################################
## Prepare data
##
mosuo.afb = as.data.frame( subset(mosuo.people, Age >= 15 & EthnicGroup=="Mosuo") )
mosuo.afb$AFB = ifelse(is.na(mosuo.afb$AFB), 0, mosuo.afb$AFB)

mosuo.afb$Cohort = ifelse(mosuo.afb$BirthYear < 1941, "Before_1941",
                          ifelse(mosuo.afb$BirthYear >= 1941 & mosuo.afb$BirthYear <= 1972, "1941_to_1972", "After_1972"))
mosuo.afb$Cohort = as.factor(mosuo.afb$Cohort)
mosuo.afb$Cohort = relevel(mosuo.afb$Cohort, "Before_1941")

# censor people who never gave birth
mosuo.afb$Status = ifelse(mosuo.afb$AFB > 0, 2, 1)  # status==2 for people who gave birth; ==1 for those who didn't
mosuo.afb$SurvObj = with(mosuo.afb, Surv(AFB, Status==2))

# descriptives about AFB
## mode function from: http://stackoverflow.com/a/8189441
Mode <- function(x) {
  ux <- unique(x)
  ux[which.max(tabulate(match(x, ux)))]
}

library(plyr)
ddply(subset(mosuo.afb, AFB>0),
      .(zhubo1, Sex), plyr::summarise,
      min = min(AFB),
      max = max(AFB),
      mean = mean(AFB),
      median = median(AFB),
      mode = Mode(AFB)
      )

####################################################################################
## Cox regressions
##
# pick one of these two
mosuo.afb_f = na.omit(subset(mosuo.afb, Sex=="f", select=c(SurvObj, Cohort, NumSibs.SameSex, NumSibs.DiffSex, year.of.education, income01_12, livestockno_12, zhubo1)))
mosuo.afb_m = na.omit(subset(mosuo.afb, Sex=="m", select=c(SurvObj, Cohort, NumSibs.SameSex, NumSibs.DiffSex, year.of.education, income01_12, livestockno_12, zhubo1)))

# sample sizes
nrow(mosuo.afb_f)
nrow(mosuo.afb_m)

#' Fit Cox regressions to model females and males ages at first birth
#'
#' @param d Data: either `mosuo.afb_f` or `mosuo.afb_m`
#'
#' @return Named list containing model selection table and summary of average model
#'         Note that the parameter "No. same-sex sibs" should be changed to "No. sisters" for females and "No. brothers" for males
#'         (and similar for 'opposite-sex sibs')
#'
fit_cox = function(d){
  afb_models = list()
  # null
  afb_models[[1]] = coxph(SurvObj ~ 1, data=d)
  # control
  afb_models[[2]] = coxph(SurvObj ~ Cohort + NumSibs.SameSex + NumSibs.DiffSex + year.of.education + income01_12 + livestockno_12, data=d)
  # zhu
  afb_models[[3]] = coxph(SurvObj ~ Cohort + NumSibs.SameSex + NumSibs.DiffSex + year.of.education + income01_12 + livestockno_12 + zhubo1, data=d)

  afb_names = c("Null", "Control", "Control + Zhubo")

  # model selection/averaging
  best.models = model.sel(afb_models)
  avg.model = model.avg(best.models, subset = delta < 2, revised.var=T)

  # get param estimates and CIs
  avg.model.sum = summary(avg.model)$coefficients[2,] %>%
    dplyr::as_data_frame() %>%
    rownames_to_column(var="Parameter") %>%
    bind_cols(confint(avg.model) %>% dplyr::as_data_frame())

  # prettify parameter names
  avg.model.sum$Parameter <- c("Cohort 1941 to 1972", "Cohort After 1972"
                             ,"No. same-sex sibs", "No. opposite-sex sibs"
                             ,"Education", "Tourist income (ref: no)", "No. livestock"
                             ,"Zhu? (ref: no)"
  )

  # calculate hazard ratios + CIs
  avg.model.sum$HR = exp(avg.model.sum$value)
  avg.model.sum$HR_l = exp(avg.model.sum$`2.5 %`)
  avg.model.sum$HR_u = exp(avg.model.sum$`97.5 %`)

  # make model selection table prettier
  best.models$Model = afb_names[ as.integer(rownames(best.models))]  # add model names in correct order
  best.models = best.models %>%
    dplyr::select(Model, K=df, delta, weight, LL=logLik)

  return(list(
    best.models = best.models,
    avg.model.sum = avg.model.sum
  ))
}

# fit models
afb_f = fit_cox(mosuo.afb_f)
afb_m = fit_cox(mosuo.afb_m)

# save everything
write_csv(afb_f$best.models, file.path(results.dir, "AFB - confidence set - females.csv"))
write_csv(afb_m$best.models, file.path(results.dir, "AFB - confidence set - males.csv"))

write_csv(afb_f$avg.model.sum, file.path(results.dir, "AFB - param estimates - females.csv"))
write_csv(afb_m$avg.model.sum, file.path(results.dir, "AFB - param estimates - males.csv"))


#  James Rekow

eulerIntegrate = function(smpl, threshold = 10 ^ (-6), maxSteps = 10 ^ 4, tStep = 10 ^ (-2)){

  #  ARGS: smpl - a sample of the form list(abd, gr, imat)
  #        maxSteps - maximum number of time steps allowed before termination
  #        tStep - length of time covered in each iteration (e.g. delta t)
  #        threshold - cutoff below which a change in the abd vector is considered
  #                    a small step
  #
  #  RETURNS: abd - numeric vector containing the integrated abd vector corresponding to smpl

  #  extract list elements
  abd = smpl[[1]]
  gr = smpl[[2]]
  imat = smpl[[3]]

  #  stores the number of consecutive small steps
  smallSteps = 0

  #  integrate the system of ODEs from the GLV model with parameters from smpl using Euler's method
  for(j in 1:maxSteps){

    #  compute delta x
    abdChange = abd * {gr + c(imat %*% abd)}
    deltaabd = tStep * abdChange
    abd = abd + deltaabd

    #  ensure nonnegativity of abundances
    abd = 0.5 * {abs(abd) + abd}

    #  check if delta x is less than the threshold value (euclidean distance with threshold pre-squared)
    smallStep = sum(abdChange * abdChange) < threshold

    #  if delta x is less than the threshold value five times in a row, we assume x has
    #  reached a steady state and terminate the loop
    if(smallStep){
      smallSteps = smallSteps + 1

      if(smallSteps == 5){
        break
      } #  end if
    } #  end if

    #  reset small step counter if delta x is greater than the threshold value
    else{
      smallSteps = 0
    } #  end else

  } #  end integration loop

  #  round (in part to set very small abundances to zero)
  abd = round(abd, 4)

  return(abd)

} #  end eulerIntegrate function


############################################################################
# Matrix manipulation methods
############################################################################
# Converts an integer into a hexadecimal value
as.character.hexmode <- function(x) {
  hexDigit <- c(0:9, "A", "B", "C", "D", "E", "F")
  isna <- is.na(x)
  y <- x[!isna]
  ans0 <- character(length(y))
  while (any(y > 0)) {
    z <- y%%16
    y <- floor(y/16)
    ans0 <- paste(hexDigit[z + 1], ans0, sep = "")
  }
  ans <- rep("NA", length(x))
  ans[!isna] <- ans0
  ans
}

############################################################################
# Matrix manipulation methods
############################################################################
# Flip matrix (upside-down)
flip.matrix <- function(x) {
  mirror.matrix(rotate180.matrix(x))
}

# Mirror matrix (left-right)
mirror.matrix <- function(x) {
  xx <- as.data.frame(x);
  xx <- rev(xx);
  xx <- as.matrix(xx);
  xx;
}

# Rotate matrix 90 clockworks
rotate90.matrix <- function(x) {
  t(mirror.matrix(x))
}

# Rotate matrix 180 clockworks
rotate180.matrix <- function(x) {
  xx <- rev(x);
  dim(xx) <- dim(x);
  xx;
}

# Rotate matrix 270 clockworks
rotate270.matrix <- function(x) {
  mirror.matrix(t(x))
}

############################################################################
# Color methods
############################################################################
# The inverse function to col2rgb()
rgb2col <- function(rgb) {
  rgb <- as.integer(rgb)
  class(rgb) <- "hexmode"
  rgb <- as.character(rgb)
  rgb <- matrix(rgb, nrow=3)
  paste("#", apply(rgb, MARGIN=2, FUN=paste, collapse=""), sep="")
}

getColorTable <- function(col) {
  # Convert all colors into format "#rrggbb"
  rgb <- col2rgb(col);
  col <- rgb2col(rgb);
  sort(unique(col))
}

############################################################################
# Draw methods
############################################################################
# 'colorTable' instead of 'col' to be more explicit.
image.matrix <- function(x, colorTable=NULL, xlab="", ylab="", ...) {
  image(x=1:ncol(x),y=1:nrow(x),z=rotate270.matrix(x), col=colorTable, xlab=xlab, ylab=ylab, ...)
}

############################################################################
# Example
############################################################################
#opar <- par(ask=TRUE)

#x <- y <- seq(-4 * pi, 4 * pi, len = 27)
#r <- sqrt(outer(x^2, y^2, "+"))
#z <- cos(r^2) * exp(-r/6)
#z[2,] <- min(z) # To show that z[1,1] is in the
#z[,2] <- max(z) # upper left corner.

#colorTable <- gray((0:32)/32)
#image.matrix(z, colorTable=colorTable)
#image.matrix(t(z), colorTable=colorTable)
#image.matrix(mirror.matrix(z), colorTable=colorTable)
#image.matrix(flip.matrix(z), colorTable=colorTable)

#img <- matrix("white", nrow=12, ncol=9)
#img[2:3,c(2:3,7:8)] <- "blue"
#img[5:6,5] <- "green"
#img[9,c(3,7)] <- "red"
#img[10,4:6] <- "red"

#colorTable <- getColorTable(img)
#z <- rgb2col(col2rgb(img)) # Assert format "#rrggbb"
#z <- match(z, colorTable)
#dim(z) <- dim(img)

#image.matrix(z, colorTable=colorTable)
#image.matrix(rotate90.matrix(z), colorTable=colorTable)

#par(opar)

# End of File


library(suncalc)
library(corrplot)
library(MASS)

setwd("R/dwd")

set.seed(1023)
weather_data <- read.csv("dwd.csv", header = TRUE, sep = ";")
colnames(weather_data)
(n <- nrow(weather_data))
weather_data$date <- as.POSIXct(weather_data$date,format='%Y-%m-%d %H:%M:%S', tz='UTC')
c(as.character(weather_data$date[1]), as.character(weather_data$date[n]))

dftt = data.frame(diff1 = numeric(n))
dftt$diff1 <- weather_data$tt - weather_data$dwd_tt
dftt$sun_pos <- getSunlightPosition(weather_data$date-3*30*60, lat = 48.68, lon = 9.22)$altitude * 180/pi
dftt$dwd_n <- weather_data$dwd_n
dftt$diff_td <- weather_data$dwd_tt - weather_data$dwd_td
dftt$dwd_ff <- weather_data$dwd_ff

factor_vars <- names(which(sapply(dftt, class) == "factor"))
numeric_vars <- setdiff(colnames(dftt), factor_vars)
numeric_vars_mat <- as.matrix(dftt)
numeric_vars_cor <- cor(numeric_vars_mat)
corrplot(numeric_vars_cor)

# fit1 <- lm(diff1 ~ dwd_ff + sun_pos + diff_td + dwd_n, data=dftt)

fit1 <- glm(diff1 ~ ., data=dftt)
step <- stepAIC(fit1, direction="both")
step

# Call:  glm(formula = diff1 ~ sun_pos + dwd_n + diff_td + dwd_ff, data = dftt)
#
# Coefficients:
# (Intercept)      sun_pos        dwd_n      diff_td       dwd_ff
#     -1.3731       0.0137       0.0942       0.0183       0.0445
#
# Degrees of Freedom: 26099 Total (i.e. Null);  26095 Residual
# Null Deviance:	    37800
# Residual Deviance: 25000 	AIC: 72900

dttd = data.frame(diff2 = numeric(n))
dttd$diff2 <- weather_data$td - weather_data$dwd_td
dttd$sun_pos <- getSunlightPosition(weather_data$date-3*30*60, lat = 48.68, lon = 9.22)$altitude * 180/pi
dttd$dwd_n <- weather_data$dwd_n
dttd$diff_td <- weather_data$dwd_tt - weather_data$dwd_td
dttd$dwd_ff <- weather_data$dwd_ff

factor_vars <- names(which(sapply(dttd, class) == "factor"))
numeric_vars <- setdiff(colnames(dttd), factor_vars)
numeric_vars_mat <- as.matrix(dttd)
numeric_vars_cor <- cor(numeric_vars_mat)
corrplot(numeric_vars_cor)

# fit_td <- lm(diff2 ~ dwd_ff + sun_pos + diff_td + dwd_n, data=dttd)

fit2 <- glm(diff2 ~ ., data=dttd)
step <- stepAIC(fit2, direction="both")
step

# Call:  glm(formula = diff_td ~ dwd_n + diff_tt + dwd_ff, data = dttd)
#
# Coefficients:
# (Intercept)        dwd_n      diff_tt       dwd_ff
#    -0.50521      0.08313      0.11188      0.01186
#
# Degrees of Freedom: 26099 Total (i.e. Null);  26096 Residual
# Null Deviance:	    23150
# Residual Deviance: 16860 	AIC: 62670


library(MASS)

r <- 0.498
python <- 1-r

python_compila <- 0.825
r_compila <- 0.853

esercizi <- 4
linguaggi <- 3
studenti <- 130

a <- python*python_compila +  r*r_compila
python_a <- python*python_compila/a

f_1 <- function(x) {
    factorial(x)/factorial(x-esercizi) - (studenti*factorial(esercizi)/(esercizi^linguaggi))
}

print(fractions(a))
print(fractions(python_a))
print(ceiling(uniroot(f_1, c(esercizi, 100))$root))


## VEP SNR (N125 peak vs baseline noise 200 ms before stimulus)

raw <- read.table(file = "data/vep_snr_uncorrected.csv",header = FALSE, dec = ".", col.names = "snr", sep=",")
raw$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
raw$subj      <- c(c(1:27), c(1:27))
raw$method    <- c(rep("uncorrected", 27*2))

asr <- read.table(file = "data/vep_snr_asr.csv",header = FALSE, dec = ".", col.names = "snr", sep=",")
asr$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
asr$subj      <- c(c(1:27), c(1:27))
asr$method    <- c(rep("asr", 27*2))

rasr <- read.table(file = "data/vep_snr_rasr.csv",header = FALSE, dec = ".", col.names = "snr", sep=",")
rasr$condition <- c(c(rep("inside",27)), c(rep("outside",27)))
rasr$subj      <- c(c(1:27), c(1:27))
rasr$method    <- c(rep("rasr", 27*2))

### testing time
library(ez)
library(effsize)

# combine all for ANOVA
all <- rbind(raw, asr, rasr)
aov_group <- ezANOVA(data=all, dv = snr, within = .(condition, method), wid=subj)
print(aov_group)

# # outside
# ASR_out <- asr$snr[asr$condition == "outside"];
# rASR_out <- rasr$snr[rasr$condition == "outside"];
# raw_out <- raw$snr[raw$condition == "outside"];
#
# x <- c(ASR_out, rASR_out, raw_out);
# grouping <- c(c(rep("asr out", 27)),c(rep("rasr out", 27)), c(rep("uncorrected out", 27)));
# source("pairwise.t.test.with.t.and.df.R")
# result <- pairwise.t.test.with.t.and.df(x,grouping, p.adjust.method = "holm", paired = TRUE);
# print(result)
#
# # inside
# ASR_in <- asr$snr[asr$condition == "inside"];
# rASR_in <- rasr$snr[rasr$condition == "inside"];
# raw_in <- raw$snr[raw$condition == "inside"];
# x <- c(ASR_in, rASR_in, raw_in);
# grouping <- c(c(rep("asr in", 27)),c(rep("rasr in", 27)), c(rep("uncorrected in", 27)));
# result <- pairwise.t.test.with.t.and.df(x,grouping, p.adjust.method = "holm", paired = TRUE);
# print(result)
#
# #cohen.d(all$snr, all$condition, pooled = FALSE, paired = TRUE)

a <- mean(all$snr[all$condition== "inside" & all$method == "rasr"])
b <- mean(all$snr[all$condition== "inside" & all$method == "asr"])
c <- mean(all$snr[all$condition== "outside" & all$method == "rasr"])
d <- mean(all$snr[all$condition== "outside" & all$method == "asr"])
e <- mean(all$snr[all$condition== "inside" & all$method == "uncorrected"])
f <- mean(all$snr[all$condition== "outside" & all$method == "uncorrected"])
plot(c(a,b,c,d,e,f), xlab = "methods", ylab = "mean vep snr", xaxt = "n")
# Changing x axis
axis(1, at=1:6, labels=c("in rASR","in ASR", "out rASR","out ASR","in uncorr", "out uncorr" ))
legend("topright", legend=c(a,b,c,d,e,f))


lai_col    = '#009900'
k_cols     = c('#002222', '#005555', '#00AAAA', '#00EEEE')
albedo_col = '#AA0000'

par(mfrow = c(2,1), mar = c(1, 3, 0, 3), oma = c(2, 0, 0.5, 0))

x = seq(0, 12, length.out = 361)

lai = (runif(361, 0, 1) * 0.1 + cos(seq(pi, 3*pi, length.out = 361)))*0.5 + 0.3
lai = 1/(1+exp(-10*(lai - 0.5)))
lai = lai  + 0.15 + runif(361, 0, 0.1)

plot(range(x), c(0, 1), axes = FALSE, type = 'n')
points(x, lai * 0.8, col = lai_col)
axis(1, 0.5:11.5, c('J', 'F', 'M', 'A', 'M', 'J', 'J', 'A', 'S', 'O', 'N', 'D'))
axis(2, seq(0, 1, 0.2), 0:5)
mtext('LAI', side = 2, line = 2)
axis(4, seq(0, 1, 0.25), seq(0, 100, 25))
mtext('exposed ground (%)', side = 4, line = 2)

calSoil <- function(k, col = NULL) {
	soil = exp(- k * 	lai)
	if (!is.null(col)) {
		lines(x, soil, col = col)
		text(x=6, y=min(soil) - 0.05, k)
	}
	return(soil)
}

soils = mapply(calSoil, c(0.1, 0.5, 1.0, 2.0), k_cols, SIMPLIFY = FALSE)

soil_albedo = 0.3
veg_albedo = 0.2

soilsX = calSoil(1.3)
soilsX = soilsX + runif(361, -0.3, 0.3)

albedo = soil_albedo * soilsX + veg_albedo * (1-soilsX)
albedoP = albedo - min(albedo)
albedoP = albedoP / max(albedoP)
index = seq(0, 360, 8)
lines(x[index], albedoP[index], col = albedo_col, lwd = 2)

plot(c(0, 1), c(0.0,0.35), axes = FALSE, xaxs = 'i', yaxs = 'i', type = 'n')
axis(1, seq(0, 1, 0.2), seq(0, 100, 20))
axis(2)
mtext('exposed ground (%)', side = 1, line = 2)
mtext('Albedo', side = 2, line = 2)

boundedLinear <- function(x, y0, y1)
	(y1 - y0) * x + y0

plotSoils <- function(soil,  col) {
	x = soil[index]
	y = albedo[index]
	points(x,y, col = col, pch = 19)
	fit = nls(y ~ boundedLinear(x, y0, y1), data = data.frame(x = x, y = y),
		      lower = c(y0 = 0, y1 = 0), upper = c(y0 = 1, y1 = 1), start = c(y0 = 0.1, y1 = 0.9),
			  algorithm = "port")

	print(fit)
	xline = seq(0, 100)
	yline = predict(fit, newdata = data.frame(x = xline))
	lines(xline, yline, col = col)
}

mapply(plotSoils, soils, col = k_cols)
legend('bottomright', c('    LAI', '0.1', '0.5    light decay', '1.0    coefficient', '2.0', '    Albedo'),
		pch = c(1, 19, 19, 19, 19, 0), lwd = c(NaN, 1, 1, 1, 1, 2), col = c(lai_col, k_cols, albedo_col))


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

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

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

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

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

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

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

  specific <- unique(data$reciprocal);

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

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

  }

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

  return(outputlist)
}
###############################################
mydata <- read.csv("pheno_diallel_master_BLUE.csv")

krnca <- getca2(data=mydata, trait="KRN", square=FALSE)
akwca <- getca2(data=mydata, trait="AKW", square=FALSE)
tkwca <- getca2(data=mydata, trait="TKW", square=FALSE)
kcca <- getca2(data=mydata, trait="KC", square=FALSE)

cdca <- getca2(data=mydata, trait="CD", square=FALSE)
cwca <- getca2(data=mydata, trait="CW", square=FALSE)
clca <- getca2(data=mydata, trait="CL", square=FALSE)

##########  GCA #################
gca_master <- merge(krnca[[1]], akwca[[1]], by="Genotype")
gca_master <- merge(gca_master, tkwca[[1]], by="Genotype")
gca_master <- merge(gca_master, kcca[[1]], by="Genotype")
gca_master <- merge(gca_master, cdca[[1]], by="Genotype")
gca_master <- merge(gca_master, cwca[[1]], by="Genotype")
gca_master <- merge(gca_master, clca[[1]], by="Genotype")

write.table(gca_master, "pheno_diallel_master_BLUE_GCA.csv", sep=",", row.names=FALSE, quote=FALSE)

##########  SCA #################
sca_master <- merge(krnca[[2]], akwca[[2]], by="Genotype")
sca_master <- merge(sca_master, tkwca[[2]], by="Genotype")
sca_master <- merge(sca_master, kcca[[2]], by="Genotype")
sca_master <- merge(sca_master, cdca[[2]], by="Genotype")
sca_master <- merge(sca_master, cwca[[2]], by="Genotype")
sca_master <- merge(sca_master, clca[[2]], by="Genotype")

write.table(sca_master, "pheno_diallel_master_BLUE_SCA.csv", sep=",", row.names=FALSE, quote=FALSE)

pairs(d[, c(4,7,9, 11:13)], text.panel = diag, upper.panel=panel.smooth,
lower.panel=panel.cor, gap=0, main="KRN Correlation Plots of three obs")

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

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

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

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

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

#############################
#FUNCTION to GCA and SCA
getca1 <- function(traitnm="TKW"){
  tem <- merge(trait[, c("Genotype2", traitnm, "Dairy", "Johnson", "zumwalt")], dm, by.x="Genotype2", by.y="Geno")
  tem <- tem[!is.na(tem[,2]),]
  yield <- tem[,2]

  idx1 <- numeric(ncol(tem))
  for(i in 3:ncol(tem)){
    idx1[i] <- sum(tem[,i])
  }
  idx <- which(idx1==0)

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

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

  gcaout <- data.frame(Genotype=names(ped.hat1[1:29]), GCA=ped.hat1[1:29]);
  names(gcaout)[2] <- traitnm;

  scaout <- data.frame(Genotype=names(ped.hat1[30:227]), GCA=ped.hat1[30:227]);
  names(gcaout)[2] <- traitnm;

  output <- list(gca=gcaout, sca=scaout)
  return(output)
}

#############
krn1 <- getca1("KRN")

krntem <- merge(krnca[[2]], krn1[[2]], by="Genotype", all.x=TRUE)
krntem[is.na(krntem)] <- 0

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

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

getca(data=sample, trait="Yield")
#########################################################################################################################
x1 <- c("P1", "P1", "P1", "P1", "P2", "P2");
x2 <- c("P2", "P2", "P3", "P3", "P3", "P3")
yield <- c(10, 12, 20, 22, 14, 16)

sample <- data.frame(Parent1=x1, Parent2=x2, Yield=yield)

#####################################################################################################################################################
X <- matrix(c(1, 1, 0, 1, 0, 0,
                   1, 1, 0, 1, 0, 0,
                   1, 0, 1, 0, 1, 0,
                   1, 0, 1, 0, 1, 0,
                   0, 1, 1, 0, 0, 1,
                   0, 1, 1, 0, 0, 1), ncol=6, byrow=TRUE)

y <- sample$Yield
XX=t(X)%*%X
library(MASS)
XXgi=ginv(XX)
Px=X%*%XXgi%*%t(X)
yhat=Px%*%y

fit <- lm(y~X)

y=c(4,1,3,5,3,3,1)
X=matrix(c(
  1,1,0,0,0,1,0,0,
  1,1,0,0,0,0,1,0,
  1,0,1,0,0,0,1,0,
  1,0,1,0,0,0,0,1,
  1,0,0,1,0,0,0,1,
  1,0,0,0,1,1,0,0,
  1,0,0,0,1,0,1,0
  ),byrow=T,nrow=7)
fit <- lm(y ~X)
XX=t(X)%*%X
library(MASS)
XXgi=ginv(XX)
Px=X%*%XXgi%*%t(X)
yhat=Px%*%y

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

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

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

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

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

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

data1 <- subset(data1, )

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

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

fit <- lm(yield ~ dmatrix)


## From Jerome Asselin  https://github.com/harrelfe/rms/issues/32
require(rms)
df <- data.frame(y=rnorm(21), day=weekdays(Sys.Date()-(1:21), abbr=TRUE))
df$day.ordered <-
  with(df, factor(as.character(day),
                  levels=c("Sun","Mon","Tue","Wed","Thu","Fri","Sat"),
                  ordered=TRUE))
options(contrasts=c("contr.treatment", "contr.treatment"))
fit1 <- ols(y ~ day, data=df)
fit2 <- ols(y ~ day.ordered, data=df)
df.char <- df
df.char$day.ordered <- as.character(df.char$day.ordered)
w <- cbind(orig          = predict(fit1),
      orig.newdata       = predict(fit1, newdata=df),
      ordered            = predict(fit2),
      ordered.newdata    = predict(fit2, newdata=df),
      ordered.workaround = predict(fit2, newdata=df.char))
round(w[, -1] - w[, 1], 3)

# From oscar0936330161@gmail.com Oscar Chang
require(rms)
set.seed(8787)
n <- 1000
x1 <- factor(sample(c(0, 1), n, replace = T), ordered=TRUE)
y  <- sample(c(1, 2, 3, 4), n, replace = T)
w <- try(orm(Y ~ x1), silent=TRUE)
w
x1 <- factor(sample(c(0, 1), n, replace = T))
orm(Y ~ x1)


library(ggplot2)
library(dplyr)
library(statsr)
library(gridExtra)
library(corrplot)
library(Hmisc)
load("G:\\rprojects\\clgstuf\\project\\movies.Rdata")
movies1 = data.frame(movies)
# selecting only those attributes that we would need
movies_new <- movies?%>% select(title, title_type, genre,
                                runtime, imdb_rating, imdb_num_votes, critics_rating,
                                critics_score, audience_rating, audience_score,
                                best_pic_win, best?actor_win, best_actress_win, best_dir_win)
# description of the attributes of the dataset
str(movies_new)
#summary
summary(movies_new)
# there is one N/A value in runtime, so we drop the row , for simplicity
movies_new <- na.omit(movies_new)
# boxplot of ?arious genres to runtime
p_genrerun <- ggplot(movies_new, aes(x=factor(genre), y=runtime)) +
  geom_boxplot() + theme(axis.text.x = element_text(angle = 45, hjust = 1))
p_genrerun + ggtitle("Genre to runtime") +
  geom_hline(yintercept =median(movies_new$?untime, na.rm = TRUE), col = "royalblue",lwd = 1)
# We can see all genres are oscilating around median runtime value of 103 minutes.
# There are lot of outliers in data, mostly documentary genre

# boxplot of various genres to IMDB rating
p_genreimdb <- g?plot(movies_new, aes(x=factor(genre), y=imdb_rating)) +
  geom_boxplot() + theme(axis.text.x = element_text(angle = 45, hjust = 1))
p_genreimdb + ggtitle("Genre to IMDB rating") +
  geom_hline(yintercept =median(movies_new$imdb_rating, na.rm = TRUE), col ? "royalblue",lwd = 1)
#OBSERVATIONS:-
#We can see sci-fi has biggest variance between 1Q and 3Q
#median of sci-fi genre is lower then median of all genres.
#Documentary performs best as Musical and performing arts movies.

#we split the data into training?and testing data
set.seed(2017)
split <- sample(seq_len(nrow(movies_new)), size = floor(0.999 * nrow(movies_new)))
train <- movies_new[split, ]
test <- movies_new[-split, ]
dim(train)

# plot between imdb rating and runtime
plot(movies$imdb_rating,movies$r?ntime, main="IMDB rating to runtime",
     xlab = "IMDB rating", ylab="Runtime in minutes")
abline(lm(movies$runtime~movies$imdb_rating),col = "royalblue",lwd = 1)
#From simple linear regression used to IMDB rating and runtime of movie.
#We can see that w? can expect better IMDB rating if runtime is longer.

#plot critique score to audiance score
ggplot(data = movies, aes(x = critics_score, y = audience_score)) +
  geom_jitter() +  geom_smooth(method = "lm", se = FALSE) +
  ggtitle("Critics score to audienc? score - Rotten")
#We see there is correlation between critics score of Rotten Tomato and audience score.

#plot critique score to imdb
ggplot(data = movies, aes(x = imdb_rating, y = audience_score)) +
  geom_jitter() +  geom_smooth(method = "lm", se = FA?SE) +
  ggtitle("Critics score to audience score - IMDB")
#very strong correlation

#plot imdb vs rotten
ggplot(data = movies, aes(x = critics_score, y = imdb_rating)) +
  geom_jitter() +  geom_smooth(method = "lm", se = FALSE) + ggtitle("IMDB vs. Rotten")?#We definitely have correlation between critics and IMDB rating.

#____________________________________________________________________________________
#now we analyze the training data

#HISTOGRAM OF NUMERIC VALUES

#AUDIENCE SCORE
hist(train$audience_sco?e)
summary(train$audience_score)
#audiences are unlikely to give very high or low values

#histogram of runtime , imdb, log(imdb), critics score
p1 <- ggplot(aes(x=runtime), data=train) +
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='blac?', fill='white', binwidth = 5) +
  ylab('percentage') + ggtitle('Run Time')
p2 <- ggplot(aes(x=imdb_rating), data=train) +
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='black', fill='white', binwidth = 0.2) +
  ylab('percentage') + ggtit?e('IMDB rating')
p3 <- ggplot(aes(x=log10(imdb_num_votes)), data=train) +
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='black', fill='white') +
  ylab('percentage') + ggtitle('log(IMDB number of votes)')
#plot(p3)
p4 <- ggplot(aes(x=criti?s_score), data=train) +
  geom_histogram(aes(y=100*(..count..)/sum(..count..)), color='black', fill='white', binwidth = 2) +
  ylab('percentage') + ggtitle('Critics Score')
grid.arrange(p1, p2, p3, p4, ncol=2)

# bar plot of catagorical data
p1 <- ggplot(?es(x=title_type), data=train) + geom_bar(aes(y=100*(..count..)/sum(..count..))) +
  ylab('percentage') +
  ggtitle('Title Type') + coord_flip()
p2 <- ggplot(aes(x=genre), data=train) + geom_bar(aes(y=100*(..count..)/sum(..count..))) +
  ylab('percentage'? +
  ggtitle('Genre') + coord_flip()
p3 <- ggplot(aes(x=critics_rating), data=train) + geom_bar(aes(y=100*(..count..)/sum(..count..))) +
  ylab('percentage') +
  ggtitle('Critics Rating') + coord_flip()
p4 <- ggplot(aes(x=audience_rating), data=train) + g?om_bar(aes(y=100*(..count..)/sum(..count..))) +
  ylab('percentage') + ggtitle('Audience Rating') + coord_flip()
grid.arrange(p1, p2, p3, p4, ncol=2)

#correlation of numericle values
vars <- names(train) %in% c('runtime', 'imdb_rating', 'imdb_num_votes',?'critics_score')
selected_train <- train[vars]
mydata.cor = cor(selected_train, method = c("spearman"))
corrplot(mydata.cor, method = "color", outline = T, addgrid.col = "darkgray",
         order = "hclust", addrect = 4, rect.col = "black", rect.lwd = 5, ?l.pos = "b",
         t1.col = "indianred4", t1.cex = 1.5, cl.cex = 1.5, addCoef.col = "white",
         number.digits = 2, number.cex = 0.75,
         col = colorRampPalette(c("darkred","white","midnightblue"))(100))

#correlation between catagorical val?es
boxplot(audience_score~critics_rating, data=train, main='Audience score vs. Critics rating',
        xlab='Critics Rating', ylab='Audience Score')
by(train$audience_score, train$critics_rating, summary)
boxplot(audience_score~audience_rating, data=trai?, main='Audience Score vs. Audience Rating',
        xlab='Audience rating', ylab='Audience Score')
by(train$audience_score, train$audience_rating, summary)
boxplot(audience_score~title_type, data=train, main='Audience score vs. Title type',
        xlab?'Title_type', ylab='Audience Score')
by(train$audience_score, train$title_type, summary)
boxplot(audience_score~genre, data=train, main='Audience score vs. Genre',
        xlab='Genre', ylab='Audience score')
by(train$audience_score, train$genre, summary)?#_________________________________________________________________________________
#MODEL MAKING
#We will be using stepwise model forward selection method
#We will start with an empty model
#then add variables one at a time until a parsimonious model is re?ched.
#parsimonius model is the simplest model required to generate required outcome
#____________________
#choosing predictors
full_model <- lm(audience_score~imdb_rating+title_type+genre+runtime+imdb_num_votes+critics_rating+audience_rating+best_pic_win+?est_actor_win+best_actress_win+best_dir_win, data=train)
summary(full_model)
#imdb rating has the lowest p value and is the most correlated variable to our response variable.
#So we choose imdb rating as the first predictor.
fit1 <- lm(audience_score ~ im?b_rating, data=train)
summary(fit1)
#The 0.75 R-squared and almost zero p value indicate that imdb rating is a statistically significant
#predictor of audience score.
#now we find the next predictor attribute
fit_model <- lm(audience_score~title_type+genre?runtime+imdb_num_votes+critics_rating+audience_rating+best_pic_win+best_actor_win+best_actress_win+best_dir_win, data=train)
summary(fit_model)
#in fit_model , audiance rating has the lowest p-value , so it will be our next predictor
fit2 <- lm(audience_sc?re ~ imdb_rating + audience_rating, data=train)
summary(fit2)
# again the p value is almost 0 so our predictors are significant
#next we tried the critics_rating , imdb_num_votes and genre as predictors
#we only got significant results for genre as our pre?ictor
fit3 <- lm(audience_score ~ imdb_rating + audience_rating + genre, data=train)
anova(fit3)
#so fit3 is our final model
summary(fit3)

#model diagnostics
ggplot(data = fit3, aes(x = .fitted, y = .resid)) +
  geom_point() +
  geom_hline(yintercept = 0,?linetype = "dashed") +
  xlab("Fitted values") +
  ylab("Residuals")
#There is clear a linear relationship between imdb rating and audience score.
#The linearity condition is met by our model.
ggplot(data = fit3, aes(x = .resid)) +
  geom_histogram(binwid?h = 1, fill='white', color='black') +
  xlab("Residuals")
#Constant variance of residuals condition met, No fan shape in residuals plot.
ggplot(data = fit3, aes(sample = .resid)) +
  stat_qq()
#______________________________________________________________?__________________
#PREDICTION
newmovie <- test %>% select(genre, imdb_rating, audience_rating)
predict(fit3, newmovie)
predict(fit3, newmovie, interval = "prediction", level = 0.95)
test$audience_score
#the actual value is 81, our prediction contains this?value
#Our model demonstrates that it is possible to predict a movie's popularity, as measured by audience score with only three predictors - imdb score, audience rating and genre. Movie industries can use the similar methods when producing movies that are?more likely to be liked by the target audience.
#However, the potential shortcoming is that our model's predictive power is limited because the sample data is not representative. Therefore, a larger number of observations to capture more variability in the?population data in our testing data set is required to have a better measure of the model's accuracy.


r1 = dnorm(1:120, 1*66, 0.2*66)
r2 = dnorm(1:120, 1*62, 0.3*62)

pdf('predicted_Rdist.pdf',
    width = 6, height = 2.5)
par(mgp = c(2,1,0),
    mar = c(2,0,0,0))
plot(r1, xlab = '', ylab = '',
     axes = F, type = 'l',
     lwd = 4)
arrows(x0 = 66, x1 = 66, length = 0.15,
       y0 = 0, y1 = max(r1),
       lwd = 4)
lines(r2, xlab = '', ylab = '',
      type = 'l', lwd = 4, col = 'grey50')

arrows(x0 = 62, x1 = 62,
       y0 = 0, y1 = max(r2),
       lwd = 4, length = 0.15,
       col = 'grey50')
axis(1, at = c(0, 60, 120),
     lwd = 4, cex.axis = 2,
     tck = -0.02, labels = c('', 60, ''))

dev.off()


##
## Supplementary table 3
##
source("init.r")

hh.all = hh.dyads %>%
  left_join(hh %>% dplyr::select(Ego.HH=HH,   Ego.zhubo1=zhubo1),   by="Ego.HH") %>%
  left_join(hh %>% dplyr::select(Alter.HH=HH, Alter.zhubo1=zhubo1), by="Alter.HH")

####################################################################################
## Witch stats
##
#hh = unique(subset(hh.all, select=c(Ego.HH, Ego.zhubo1, Ego.VillageID)))
table(hh$zhubo1)  # no. witch houses with Mosuo heads
num.witch.hh = nrow(subset(hh, zhubo1==1))
num.non_witch.hh = nrow(subset(hh, zhubo1==0))

##
## farm help
##
# how many witch houses (and non-witch) helped other witch houses (and non-witch)?
(witch.help = ftable(xtabs(~ Ego.zhubo1 + Alter.zhubo1,
                           data = subset(hh.all, Ego.HH != Alter.HH & HelpObserved > 0))))
# chi square on farm help
help.chi = chisq.test(witch.help)
help.chi$observed
help.chi$expected

##
## gifts
##
(witch.gifts = ftable(xtabs(~ Ego.zhubo1 + Alter.zhubo1,
                            data = subset(hh.all, Ego.HH != Alter.HH & TotalGifts.ind > 0))))
# chi square on gifts
gifts.chi = chisq.test(witch.gifts)
gifts.chi$observed
gifts.chi$expected

##
## partners
##
(witch.partners = ftable(xtabs(~ Ego.zhubo1 + Alter.zhubo1,
                               data = subset(hh.all, Ego.HH != Alter.HH & AnySpousesInAlter > 0))))
# chi square on partners
partners.chi = chisq.test(witch.partners)
partners.chi$observed
partners.chi$expected

##
## children
##
(witch.kids = ftable(xtabs(~ Ego.zhubo1 + Alter.zhubo1,
                           data = subset(hh.all, Ego.HH != Alter.HH & TotalChildrenInAlter > 0))))
# chi square on kids
kids.chi = chisq.test(witch.kids)
kids.chi$observed
round(kids.chi$expected, 1)


# Shiny server function

shiny::shinyServer(function(input, output) {

  output$rtstable4 <- shiny::renderTable( {

    g <- input$g
    k1 <- input$k1
    r1 <- input$r1
    sg1 <- input$sg1
    k2 <- input$k2
    r2 <- input$r2
    sg2 <- input$sg2
    sigmaG2 <- input$sigmaG2
    sigmaGL2 <- input$sigmaGL2
    sigmaGY2 <- input$sigmaGY2
    sigmaGLY2 <- input$sigmaGLY2
    sigmaE2 <- input$sigmaE2

    # first step

    alpha1 <- sg1 / g
    x1 <- qnorm(1 - alpha1) # truncation point on the N(0,1) for the selected fraction
    z1 <- dnorm(x1)
    i1 <- z1 / alpha1
    rho1 <- sqrt(sigmaG2 / (sigmaG2 + sigmaGL2 / k1 + sigmaGY2 + sigmaGLY2 / k1 + sigmaE2 / k1 / r1))
    R1 <- i1 * rho1

    # second step

    alpha2 <- sg2 / sg1
    rho2 <- sqrt(sigmaG2 / (sigmaG2 + sigmaGL2 / k2 + sigmaGY2 + sigmaGLY2 / k2 + sigmaE2 / k2 / r2))

    # both togheter

    alpha <- alpha1 * alpha2
    rho <- rho1 * rho2
    int <- function(x) {
      1 / sqrt(2 * pi) * exp(-x^2 / 2) * pnorm((x1 - rho * x) / (sqrt(1 - rho^2)), lower.tail = FALSE)
    }
    f <- function(t) {
      integrate(int, t, Inf)$value - alpha
    }
    x2 <- uniroot(f, c(0, 20))$root # truncation point on the N(0,1) for the selected fraction
    z2 <- dnorm(x2)
    a <- (x1 - rho * x2) / sqrt(1 - rho^2)
    b <- (x2 - rho * x1) / sqrt(1 - rho^2)
    I1 <- 1 - pnorm(a)
    I2 <- 1 - pnorm(b)
    R2 <- (rho1 * z1 * I2 + rho2 * z2 * I1) / alpha
    salida <- data.frame(row.names = c("1st step =", "2nd step ="))
    salida$x <- c(x1, x2)
    salida$Ru <- c(R1, R2)
    salida

  })

})


# Thanks: 袁超磊 <yuanclfeng@gmail.com> from ROBERT I. KABACOFF, 2011, R in Action,
#function could not give two minor tick marks
#between each major tick mark on the y-axis.
## This seemed to fail but it really succeeded.
## minor.tick uses par('xaxp' or 'yaxp') and worked with respect
## to the plot( ) as can be seen if yaxt='n' is omitted
require(Hmisc)
x <- c(1:10)
y <- x
z <- 10/x

plot(x, y, type="b",
     pch=21, col="red",
     yaxt="n", lty=3, ann=FALSE)
lines(x, z, type="b", pch=22, col="blue", lty=2)
axis(2, at=x, labels=x, col.axis="red", las=2)
axis(4, at=z, labels=round(z, digits=2),
     col.axis="blue", las=2, cex.axis=0.7, tck=-.01)
mtext("y=1/x", side=4, line=3, cex.lab=1, las=2, col="blue")
title("An Example of Creative Axes",
      xlab="X values",
      ylab="Y=X")
minor.tick(nx=2, ny=3, tick.ratio=0.5)


## Curvas de Kaplan-Meier

survObject <- Surv(dataframe$TiempoDeSupervivencia, dataframe$EstadoDelPaciente)
fit <- survfit(survObject ~ 1, data = dataframe)
ggsurvplot(fit, data=dataframe, surv.median.line = "hv",   conf.int = TRUE, xlab = "Tiempo / meses")

summary(fit)


#https://medium.com/@albertoarrigoni/paper-review-code-deep-ensembles-nips-2017-c5859070b8ce
#https://blogs.rstudio.com/tensorflow/posts/2018-11-12-uncertainty_estimates_dropout/
#https://github.com/yaringal/ConcreteDropout/blob/master/concrete-dropout-keras.ipynb
#https://keras.rstudio.com/articles/guide_keras.html
library(keras)
use_implementation("tensorflow")
library(tensorflow)
library(ggplot2)

####DATA PREPRATION####
# sample size (training data)
n_train <- 1000
# sample size (validation data)
n_val <- 1000
# prior length-scale
l <- 1e-4
# initial value for weight regularizer
wd <- l^2/n_train
# initial value for dropout regularizer
dd <- 2/n_train

gen_data_1d <- function(n) {
  sigma1 <- 1
  sigma2 <- 4
  X <- matrix(rnorm(n))
  w <- 2
  b <- 8
  Y <- matrix(ifelse(X>0,X %*% w + b + sigma1 * rnorm(n), X %*% w + b + sigma2 * rnorm(n)))
  list(X, Y)
}

c(X, Y) %<-% gen_data_1d(n_train + n_val)

c(X_train, Y_train) %<-% list(X[1:n_train], Y[1:n_train])
c(X_val, Y_val) %<-% list(X[(n_train + 1):(n_train + n_val)],
                          Y[(n_train + 1):(n_train + n_val)])
############################################

custom_loss <- function(sigma){
  gaussian_loss <- function(y_true,y_pred){
    tf$reduce_mean(0.5*tf$log(sigma) + 0.5*tf$div(tf$square(y_true - y_pred), sigma)) + 1e-6
  }
  return(gaussian_loss)
}

GaussianLayer <- R6::R6Class("GaussianLayer",
                             inherit = KerasLayer,

                             public = list(
                               output_dim = NULL,
                               kernel_1 = NULL,
                               kernel_2 = NULL,
                               bias_1 = NULL,
                               bias_2 = NULL,

                               initialize = function(output_dim){
                                 self$output_dim <- output_dim
                               },
                               build = function(input_shape){
                                 super$build(input_shape)

                                 self$kernel_1 = self$add_weight(name = 'kernel_1',
                                                                 shape = list(as.integer(input_shape[[2]]), self$output_dim), #list(30, self$output_dim),#shape = keras::shape(30, self$output_dim),
                                                                 initializer = keras::initializer_glorot_normal(),
                                                                 trainable = TRUE)
                                 self$kernel_2 = self$add_weight(name = 'kernel_2',
                                                                 shape = list(as.integer(input_shape[[2]]), self$output_dim),#list(30, self$output_dim),  #shape = keras::shape(30, self$output_dim),
                                                                 initializer = keras::initializer_glorot_normal(),
                                                                 trainable = TRUE)
                                 self$bias_1 = self$add_weight(name = 'bias_1',
                                                               shape = list(self$output_dim),  #shape = keras::shape(self$output_dim),
                                                               initializer = keras::initializer_glorot_normal(),
                                                               trainable = TRUE)
                                 self$bias_2 = self$add_weight(name = 'bias_2',
                                                               shape = list(self$output_dim), #shape = keras::shape(self$output_dim),
                                                               initializer = keras::initializer_glorot_normal(),
                                                               trainable = TRUE)
                               },

                               call = function(x, mask = NULL){
                                 output_mu = keras::k_dot(x, self$kernel_1) + self$bias_1
                                 output_sig = keras::k_dot(x, self$kernel_2) + self$bias_2
                                 output_sig_pos = keras::k_log(1 + k_exp(output_sig)) + 1e-06
                                 return (list(output_mu, output_sig_pos))
                               },

                               compute_output_shape = function(input_shape){
                                 return (list (
                                   list(input_shape[[1]], self$output_dim),
                                   list(input_shape[[1]], self$output_dim) )
                                 )
                               }
                             )
)

# define layer wrapper function
layer_custom <- function(object, output_dim, name = NULL, trainable = TRUE) {
  create_layer(GaussianLayer, object, list(
    output_dim = as.integer(output_dim),
    name = name,
    trainable = trainable
  ))
}
input_dim = 1L
input <- keras::layer_input(shape = input_dim)

predictions <- input %>%
  layer_dense(units = 10L, activation = 'relu') %>%
  layer_dense(units = 6L, activation = 'relu') %>%
  layer_dense(units = 30L, activation = 'relu')

c(mu,sigma) %<-% layer_custom(predictions,1,name = 'main_output')

##############################
######Train NN Ensemble#######
##############################
create_trained_network <- function(train_x, train_y){
  input <- keras::layer_input(shape = input_dim)

  predictions <- input %>%
    layer_dense(units = 10L, activation = 'relu') %>%
    layer_dense(units = 6L, activation = 'relu') %>%
    layer_dense(units = 30L, activation = 'relu')

  c(mu,sigma) %<-% layer_custom(predictions,1,name = 'main_output')
  model <- keras_model(inputs = input, outputs = mu)

  model %>% keras::compile(
    optimizer = optimizer_adam(),
    loss = custom_loss(sigma)
  )

  history <- model %>% fit(
    X_train,
    Y_train,
    epochs = 200,
    batch_size = 50
  )

  layer_name = 'main_output'
  get_intermediate = k_function(inputs=list(model$input),
                                outputs=model$get_layer(layer_name)$output)

  return(get_intermediate)

}
pred_fns <- list()
for (i in seq(10)){
  #print(i)
  pred_fn<-create_trained_network(X_train,Y_train)
  pred_fns<-append(pred_fns,pred_fn)
}

muMatrix <- data.frame()
sigmaMatrix <-data.frame()
for ( i in seq(10)){
  #print(i)
  c(mus,sigmas) %<-% pred_fns[[i]](inputs=list(as.matrix(X_val)))
  muMatrix<-rbind(muMatrix,t(as.data.frame(mus)))
  sigmaMatrix<-rbind(sigmaMatrix,t(as.data.frame(sigmas)))
}

preds<-c()
sigmas<-c()

for (i in seq(length(muMatrix))){
  out_mu <- mean(muMatrix[,i])
  out_sigma <-sqrt(mean(sigmaMatrix[,i]+sqrt(muMatrix[,i])) - sqrt(out_mu) )
  preds<-append(preds,out_mu)
  sigmas<-append(sigmas,out_sigma)
}

##visualize the outcome
df <- data.frame(
  x = X_val,
  y_pred = preds,
  upper = preds + sqrt(sigmas),
  lower = preds - sqrt(sigmas)
)

ggplot(df, aes(x, y_pred)) +
  geom_point() +
  geom_ribbon(aes(ymin = lower, ymax = upper), alpha = 0.3)


# Goal: Some of the standard tests

# A classical setting --
x <- runif(100, 0, 10)                  # 100 draws from U(0,10)
y <- 2 + 3*x + rnorm(100)               # beta = [2, 3] and sigma is 1
d <- lm(y ~ x)
# CLS results --
summary(d)

library(sandwich)
library(lmtest)
# Durbin-Watson test --
dwtest(d, alternative="two.sided")
# Breusch-Pagan test --
bptest(d)
# Heteroscedasticity and autocorrelation consistent (HAC) tests
coeftest(d, vcov=kernHAC)

# Tranplant the HAC values back in --
library(xtable)
sum.d <- summary(d)
xtable(sum.d)
sum.d$coefficients[1:2,1:4] <- coeftest(d, vcov=kernHAC)[1:2,1:4]
xtable(sum.d)

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


########################################################################
#                                                                      #
#   lib/permutation-group.rb                                           #
#                                                                      #
########################################################################
=begin
[((<index|URL:index.html>))]
((<Algebra::PermutationGroup>))
/
((<Algebra::Permutation>))

= Algebra::PermutationGroup
This is the class of permutations.
The elements are assumed to be the instances of ((<Permutation>)).

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

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

== Class Methods:

--- ::new(u, [g0, [g1, ...]])
    Returns the group with unit ((|u|)), whcih
    consists of ((|g0|)), ((|g1|)), ....

--- ::unit_group(d)
    Return the unit group of degree ((|d|)).

--- ::unity(n)
    Retunrs the unity of degree ((|n|)).

--- ::perm(a)
    Returns the permuation represented by the array ((|a|)).

--- ::symmetric(n)
    Returns the simmetric group of degree ((|n|))

--- ::alternate(n)
    Returns the alternative group of dgree ((|n|)).

= Algebra::Permutation

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

== SuperClass:
* ((|Object|))

== Included Module:

* ((|Enumerable|))
* ((|Powers|))

== Class Methods:

--- ::new(x)
    Returns the permutaiont represented by the array ((|x|)).

--- ::[]([n0, [n1, [n2, ..., ]]])
    Returns the permutation (({[n0, n1, n2, ..., ]})).

    Example:
      a = Permutation[1, 2, 0]
      p a**2 #=> [2, 0, 1]
      p a**3 #=> [0, 1, 2]

--- ::unity(d)
    Returns the unity of degree ((|d|)).

--- ::cyclic2perm(c, n)
    Returns the ((<Permutation>)) represented by
    ((|c|)) : the array of arrays of cyclic permutations,
    where ((|n|)) is the degree. This method is the inverse of
    ((<decompose_cyclic>)).

    Example:
      Permutation.cyclic2perm([[1,6,5,4], [2,3]], 7) #=> [0, 6, 3, 2, 1, 4, 5]
      Permutation[0, 6, 3, 2, 1, 4, 5].decompose_cyclic #=> [[1,6,5,4], [2,3]]

== Methods:

--- unity
    Returns the unity.

--- perm
    Returns the array which represents ((|self|))

--- degree
    Returns the degree

--- size
    Alias of ((<degree>)).

--- each
    Iterates for each entry.

--- eql?(other)
    Returns true if ((|self|)) is equal to ((|other|)).

--- ==
    Alias of ((|eql?|)).

--- hash
    Returns the hash number.

--- [](i)
    Returns the number to which ((|i|)) is transferrd.

--- call
    Alias of ((<[]>)).

--- index(i)
    Returns the number from which ((|i|)) is transferred.

--- right_act(other)
    Returns the value multiplying ((|other|)) from right.
    It follows (({(g.right_act(h))[x] == h[g[x]]})).

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

--- left_act(other)
    Returns the value multiplying ((|other|)) from left.
    It follows (({(g.left_act(h))[x] == g[h[x]]})).

--- inverse
    Returns the inverse element.

--- inv
    Alias of ((|inverse|)).

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

--- conjugate(g)
    Returns the conjugate by ((|g|)): (({g * self * g.inv})).

--- decompose_cyclic
    Returns the array of arrays of cyclic permutations.
    This is the inverse of ((<::cyclic2perm(c, n)>)).

--- to_map
    Returns the ((<Map|URL:finite-map.html>)) object of ((|self|)).

--- decompose_transposition
    Decompose into the array of the transpositions.

=end


library(chorddiag)
library(RColorBrewer)
tashu <- na.omit(read.csv('tashu.csv', header = TRUE))

top_path <- data.frame(table(tashu $ RENT_STATION, tashu $ RETURN_STATION))
top_path <- top_path[order(top_path $ Freq, decreasing = T),]
top_path <- head(top_path, n = 20)
top_path

matrix_path <- matrix(0, nrow = 144, ncol = 144)
dimnames(matrix_path) <- list(have = 1:144, prefer = 1:144)
matrix_path

for (i in 1 : nrow(top_path))
    matrix_path[top_path[i, 1], top_path[i, 2]] <- top_path[i, 3]

matrix_path

qual_col_pals = brewer.pal.info[brewer.pal.info $ category == 'qual',]
color_vector = unlist(mapply(brewer.pal, qual_col_pals $ maxcolors, rownames(qual_col_pals)))

chorddiag(matrix_path, groupColors = color_vector, groupnamePadding = 50)


permutationsort <- function(x)
{
   if(!require(e1071) stop("the package e1071 is required")
   is.sorted <- function(x) all(diff(x) >= 0)

   perms <- permutations(length(x))
   i <- 1
   while(!is.sorted(x))
   {
      x <- x[perms[i,]]
      i <- i + 1
   }
   x
}
permutationsort(c(1, 10, 9, 7, 3, 0))


#
# --- EJERCICIOS DE REPASO DEL TEMA 2 Y 3 ----------------------------------------
#
rm(list = ls())
# Ejercicio 1

set.seed(1)
x <- runif(100)

mx <- mean(x)
minIndex <- which.min(abs(x - mx))
x[minIndex]
sum(x < mx)

x[!(x < mx)]
A <- cbind(x, abs(x - mx))
A

# --------------------------------------------------------------------------------
# Ejercicio 2
rm(list = ls())
hatco <- read.table("./inputfiles/hatco.txt", header = T)
# # Eliminar la primera columna, que es meramente un índice asociado
# hatco <- hatco[2:ncol(hatco)]
hatco$x8 <- factor(hatco$x8, labels = c("Pequeña", "Grande"))
# 3
hatco$cliente <- as.character(hatco$cliente)

str(hatco)

sum(hatco$x8 == "Pequeña") # Pequeña
sum(hatco$x8 == "Grande") # Grande
hatco$x8

hatco.pequeña <- subset(hatco, x8 == "Pequeña")
hatco.grandes <- subset(hatco, x8 == "Grande")
hatco.pequeña[sample(seq_len(nrow(hatco.pequeña)), 1), ]
hatco.grandes[sample(seq_len(nrow(hatco.grandes)), 1), ]

# Alternativa más elegante y corta:
aggregate(x = hatco, by = list(hatco$x8), FUN = sample, 1)
# Nota: observa que se ha añadido la columna Group.1 al df. Si la quitamos:
aggregate(x = hatco, by = list(hatco$x8), FUN = sample, 1)[-1]

# --------------------------------------------------------------------------------
# 5

fidelidad.media <- mean(hatco$y)
fidelidad.media.pequeña <- mean(hatco.pequeña$y)
fidelidad.media.grandes <- mean(hatco.grandes$y)

# --------------------------------------------------------------------------------
# 6

sum(hatco.pequeña$y > fidelidad.media.pequeña)
sum(hatco.grandes$y > fidelidad.media.grandes)
# --------------------------------------------------------------------------------
# 7
str(hatco)
hatco2 <- hatco
numeric.cols <- colnames(Filter(is.numeric, hatco))
numeric.cols
hatco2[numeric.cols] <- sapply(hatco2[numeric.cols], scale)
head(hatco2)

#
# --- EJERCICIO 3 ----------------------------------------------------------------
#

progresion_aritmetica <- function(n, a1, d) {
    a <- a1 + d * (seq_len(n) - 1)
    suma <- sum(a)
    producto <- prod(a)

    return(list(v = a, suma = suma, producto = producto))
}

progresion_aritmetica2 <- function(n, a1, d, explicit = FALSE) {
    a <- a1 + d * (seq_len(n) - 1)
    if (!explicit) {
        suma <- sum(a)
        producto <- prod(a)

        return(list(v = a, suma = suma, producto = producto))
    } else {
        return(
            list(
                v = a,
                suma = n * (a[[1]] + a[[n]]) / 2,
                producto = d^n * gamma(a[[1]] / d + n) / gamma(a[[1]] / d)
            )
        )
    }
}


 DSYEVX Example Program Results

 Number of eigenvalues found =    2

 Eigenvalues
    -0.5146 -0.2943
 Selected eigenvectors
          1       2
 1  -0.5144  0.2767
 2   0.4851 -0.6634
 3   0.5420  0.6504
 4  -0.4543 -0.2457


#====================================================================
invlogit = function(x)
{
  1/(1+exp(-x))
}
#====================================================================
lrbarplot = function(x, y, coefs = NULL, autofit = FALSE,
                     bcol="darkgrey", blwd = 6, llwd = 4, spacer = 1,
                     lcol="black", axis2.lab = "Number of observations", decimal.mark=".",...)
{
  #blwd = 6; llwd = 4; bcol="black";lcol="red";ylab2 = "Number of observations";

  #tabulating the numbers of observations
  tab = as.matrix(table(y, x))
  upper = (2+spacer)*max(tab)
  xtab = sort(unique(x))

  #original plot (lower bars)
  plot(x=xtab, y=tab[1,], type='h', lend=2, col=bcol,
       xlim=range(x), ylim=c(0,upper), lwd=blwd, yaxt="n", ...)

  #plot(x=xtab, y=tab[1,], type='h', lend=2, col=bcol,
  #     xlim=range(x), ylim=c(0,upper), lwd=blwd, yaxt="n")

  #adding the upper bars
  segments(x0 = xtab, x1 = xtab, y0 = upper, y1=upper-tab[2,],
         col=bcol, lwd=6, lend=2)

  #1st y axis, probability of event
  axis(side=2, at = pretty(0:1)*upper,
       labels=format(pretty(0:1), digits = 1, decimal.mark = decimal.mark))

  #2nd y axis, number of observations
  ats = pretty(tab, n = 3)
  axis(side=4, at = c(ats, upper-ats), labels = c(ats,ats),
lwd=par()$lwd)

  #2nd y label
  opar = par()
  originalLas = opar$las
  par(las = 3)
  mtext(side=4, text = axis2.lab, line = opar$mgp[1], cex=opar$cex.lab)
  par(las = originalLas)

  #adding the predicted line, or not.
  if(!is.null(coefs[1]))
  {
    par(new=TRUE)
    curve(invlogit(coefs[1]+coefs[2]*x), col=lcol, lwd=llwd,
          xlim=range(x), ylim=c(0,1), xlab="", ylab="", xaxt="n", yaxt="n")
  }
  else if (autofit)
  {
    lr = glm(y~x, family=binomial)
    coefs = coef(lr)
    par(new=TRUE)
    curve(invlogit(coefs[1]+coefs[2]*x), col=lcol, lwd=llwd,
          xlim=range(x), ylim=c(0,1), xlab="", ylab="", xaxt="n",
          yaxt="n")
  }
  invisible(cbind(x = xtab, b0 = tab[1,], b1 = tab[2,]))
}
#====================================================================
#example
#x = round(rnorm(2000),1)
#y = rbinom(2000, 1, invlogit(1+3*x))
#library(extrafont)
#png("lrbarplot.png", width = 5*4, height = 5*3, units = "cm", res=450)
#par(las=1, bty="l", mar=c(6,6,2,6), family="Arial", cex.lab=2)

#lrbarplot(x=x, y=y, autofit = TRUE, bcol = "grey30", lcol="red",
#          xlab="Standardized centrality", ylab="Jump probability",
#          axis2.lab = "Number of observations", spacer = 1)
#dev.off()

#====================================================================


n_experiments <- 100
result <- 0
exper <- 0

while (exper <= n_experiments)
{
	n_samples <- 100
	samples <- runif(n_samples)
	counter <- 1
	for (sample in samples)
	{
		if (sample <= 1/6)
		{
			result = result + counter
			break
		}
		else
		{
			counter = counter + 1
		}
	}
	exper = exper + 1
}

result = result / n_experiments
print(result)