library(aod)
library(plyr)
library(rms)
#library(reshape2)

confidence_signiticant <- function(table){
  rights = na.omit(table$confidence_right)
  wrongs = na.omit(table$confidence_wrong)
  wilcox.test(rights, wrongs)
  return(0)
  library(FSA)
  group_by(table, New.Percent.Branch) %>%
    summarise(
      count = n(),
      mean = mean(WDR, na.rm = TRUE),
      sd = sd(WDR, na.rm = TRUE)
    )
  temp <- droplevels(table[table$New.Percent.Branch=='Branch A' |
                  table$New.Percent.Branch=='Branch C' |
                  table$New.Percent.Branch=='Branch G' |
                  table$New.Percent.Branch=='Branch E',])
  res.aov <- aov(WDR ~ New.Percent.Branch,
                 data = temp)
  summary(res.aov)

  dunnTest(WDR ~ New.Percent.Branch,
           data = temp, method="holm")
}

calculate_ratio <- function(total_count, DR_dataframe, condition){
  conditioned_count = length(DR_dataframe$DR[condition])
  conditioned_ratio = conditioned_count/total_count
  return(conditioned_ratio)
}

general_stat <- function(table){
  sizes <- c()
  for (branch in c('A', 'B', 'C', 'D', 'E', 'F', 'G', 'H')){
    branch_size = nrow(table[table$New.Percent.Branch==sprintf("Branch %s", branch),])
    print(sprintf("|Branch %s|=%d", branch, branch_size))
    sizes <- c(sizes, branch_size)
  }
  return(sizes)
}

regression_analysis <- function(table){
  fit <- lm(DR~Age.+Gender+Your.occupation.+Highest.degree.achieved.+Approximate...of.emails.you.receive.in.each.day.,
             data=table)
  summary(fit)
  anova(fit)
  confint(fit)
  wald.test(b=coef(fit), Sigma=vcov(fit), Terms=13:14)
  lrm(DR~Age.+Gender+Your.occupation.+Highest.degree.achieved.+Approximate...of.emails.you.receive.in.each.day.,data=table)
}

anova_time_reasoning <- function(table){
  df = data.frame(Block = c("Q1", "Q2", "Q3", "Q4"),
                  time = c(table$Q1_time, table$Q2_time,
                            table$Q3_time, table$Q4_time),
                  length = c(table$Q1_res_len, table$Q2_res_len,
                              table$Q3_res_len, table$Q4_res_len))
  fit <- aov(time~Block, data = table)
}

draw_bar_plot_reasoning <- function(table){
  df = data.frame(Block = c("Q1", "Q2", "Q3", "Q4"),
                  time = c(mean(table$Q1_time), mean(table$Q2_time),
                             mean(table$Q3_time), mean(table$Q4_time)),
                  length = c(mean(table$Q1_res_len), mean(table$Q2_res_len),
                           mean(table$Q3_res_len), mean(table$Q4_res_len)))
  value_matrix = matrix(, nrow = 2, ncol = 4)
  value_matrix[1,] = df$length
  value_matrix[2,] = df$time
  barplot(value_matrix, names.arg = df$Block, beside = TRUE, space = c(0.1,0.6),
          col = c("blue", "red"), legend.text = c("Time", "Length"),
          ylim=c(0.0, 140), cex.axis=1.5, cex.names=1.3,
          main="Detection Rate of Legit. and Phish by Various Groups",
          cex.main=1.5, ylab = "time(s) and lenght(chars)", cex.lab = 1.3,
          args.legend = list(x = "top", bty = "o", inset=c(0, -0.05),
                             cex=1, horiz=TRUE, y.intersp=0.1))

  fit <- aov(length~Block, data = df)
  fit <- aov(time~Block, data = df)

  temp = data.frame(time=na.omit(table$Q1_ordered_time), group='1')
  for (i in 2:32){
    column = sprintf("Q%d_ordered_time", i)
    question = sprintf("%d", i)
    temp = rbind(temp,
                 data.frame(time=na.omit(table[,column]),
                            group=question))
  }
  ggplot(data = temp,
         aes(x=group,y=time))+
    geom_boxplot(outlier.shape=NA)+
    coord_cartesian(ylim=c(0, 280))+
    labs(title='Distribution of time spent on each question',
         x = "Questions", y = "Time (s)")+
    theme(plot.title = element_text(hjust = 0.5),
          text = element_text(size=17))

  fit<-aov(time~group, data=temp)
  results <- TukeyHSD(fit, 'group')
}

confidence_plots <- function(table){
  library(HH)
  for (branch in c("Branch A", "Branch B", "Branch C", "Branch D",
                   "Branch E", "Branch F", "Branch G", "Branch H")){
    confidences <- table[table$New.Percent.Branch==branch,][,c('Q1_confidence','Q2_confidence','Q3_confidence','Q4_confidence')]
    #library(dplyr)
    #confidences <- select(table, 'New.Percent.Branch', 'Q1_confidence','Q2_confidence','Q3_confidence','Q4_confidence')
    names(confidences) <- c("Q1", "Q2", "Q3", "Q4")
    #confidences <- data.frame(lapply(confidences, factor, ordered=TRUE,
    #                                 levels=1:5,
    #                                 labels=c("Not confident","Slightly confident",
    #                                          "Somewhat confident","Fairly confident","Completely confident")))
    for (i in c("Q1", "Q2", "Q3", "Q4")){
      aggregated <- setNames(aggregate(confidences[i],
                                        by =confidences[i],
                                        FUN=length),
                              c('Response', i))
      if (i != "Q1"){
        total_aggregated = merge(total_aggregated,aggregated)
      } else {
        total_aggregated = aggregated
      }
    }
    total_aggregated = setNames(data.frame(t(total_aggregated[,-1])),
                                total_aggregated[,1])
    total_aggregated$Question <- rownames(total_aggregated)
    if (branch == "Branch B"){
      b = "NLG"
    } else if (branch == "Branch D"){
      b = "Human"
    } else if (branch == "Branch F"){
      b = "Gmail"
    } else if (branch == "Branch H"){
      b = "Linkedin"
    } else if (branch == "Branch G"){
      b = "Sender"
    } else if (branch == "Branch E"){
      b = "Receiver"
    } else if (branch == "Branch A"){
      b = "None"
    } else if (branch == "Branch C"){
      b = "Both"
    }
    Group <-c(b, b, b, b)
    total_aggregated_branch <- cbind(total_aggregated, Group)
    if (branch != "Branch A"){
      total_aggregated_all <- rbind(total_aggregated_all , total_aggregated_branch)
    } else {
      total_aggregated_all = total_aggregated_branch
    }
  }

  likertColor(2)
  likert(Question~.|Group, data=total_aggregated_all, as.percent=TRUE,
         positive.order=FALSE, layout=c(2,4),colorFunction="sequential_hcl",
         strip.left=strip.custom(bg="gray97"),
         strip=FALSE, ylab=NULL,
         main = list("Participants' Confidence Per Group and Question",
                     x=unit(.5, "npc")),
         sub= list("Confidence Level",
                   x=unit(.5, "npc")),
         par.strip.text=list(cex=2, lines=1),
         resize.height.tuning=2,
         left.text.cex =10,left.text.font =2,
         between=list(x=3, y=0),
         right.text.cex =1, right.text.font=2)
}

personality_correlation <- function(table){
  library(corrplot)
  table$ACL=rowMeans(table[c('Q1_confidence','Q2_confidence','Q3_confidence','Q4_confidence')])
  columns = c('agreeableness','extraversion', 'conscientiousness',
              'openness', 'neuroticism', 'CRT', 'Fake.DR', 'Legit.DR', 'DR', 'ACL')
  correlations <- cor(table[,columns])
  res1 <- cor.mtest(table[,columns])
  colnames(correlations) <- c("Agre.", "Extra.", "Cons.", "Open.", "Neur.", "CRT", "FDR", "LDR", "DR", "ACL")
  rownames(correlations) <- c("Agre.", "Extra.", "Cons.", "Open.", "Neur.", "CRT", "FDR", "LDR", "DR", "ACL")
  corrplot(correlations, method="square", type="upper", tl.col = "black", addCoef.col = "black",
           tl.cex=1.8, cl.cex = 1.5, title="Correlation between personality traits and detection rate", mar=c(0,0,1,0),
           diag = FALSE, tl.srt=90, p.mat = res1$p, sig.level = .05, number.cex =1.5, pch.cex = 4)
  for (trait in c('conscientiousness', 'extraversion', 'openness', 'agreeableness', 'neuroticism')){
    for (performance in c('Fake.DR', 'Legit.DR', 'F1', 'DR')){
      test<-cor.test(table[table$New.Percent.Branch=='Branch A',][,trait], table[table$New.Percent.Branch=='Branch A',][,performance])
      if (test$p.value < 0.05){
        print(sprintf("Correlation between %s and %s=%f (%f)", trait, performance, test$p.value, test$estimate))
      }
    }
  }
}

draw_bar_plot <- function(table){
  means=ddply(table, .(table$New.Percent.Branch), summarise,
              Legit.DR=mean(Legit.DR), Fake.DR=mean(Fake.DR))
  barplot(rbind(means$Legit.DR, means$Fake.DR)[, c(8, 6, 4, 2, 7, 5, 3, 1)], beside=T,
          #col=c("#768BE6","#E16A86"),
          col=c("cornflowerblue","pink"),
          names.arg=c('LinkedIn', 'Gmail', 'Human', 'NLG', 'Sender', 'Receiver', 'Send+Rec.', 'None'),
          ylim=c(0.0,1.0), cex.axis=1.5, cex.names=1.3,
          #main="Detection Rate of Legit. and Job Scam by Various Groups",
          cex.main=1.5)
  legend("top", c("Legit DR","Phish DR"), pch=15,
          col=c("cornflowerblue","pink"), cex=1.2,
          bty="o", horiz=TRUE, y.intersp=0.1, text.font=2)
}

group_stat <- function(table, branch){
  ##group-Fake
  group.all.count = length(table$Fake.DR[table$New.Percent.Branch==branch])
  group.fake.DR = data.frame(table$Fake.DR[table$New.Percent.Branch==branch])
  colnames(group.fake.DR) <- c("DR")
  group.Fake.all.legit.ratio = calculate_ratio(group.all.count, group.fake.DR, group.fake.DR$DR==0)
  group.Fake.atleastone.legit.ratio = calculate_ratio(group.all.count, group.fake.DR, group.fake.DR$DR<1)
  group.Fake.none.legit.ratio = calculate_ratio(group.all.count, group.fake.DR, group.fake.DR$DR==1)

  #group-Legit
  group.all.count = length(table$Legit.DR[table$New.Percent.Branch==branch])
  group.legit.DR = data.frame(table$Legit.DR[table$New.Percent.Branch==branch])
  colnames(group.legit.DR) <- c("DR")
  group.legit.all.legit.ratio = calculate_ratio(group.all.count, group.legit.DR, group.legit.DR$DR==1)
  group.legit.atleastone.legit.ratio = calculate_ratio(group.all.count, group.legit.DR, group.legit.DR$DR>0)
  group.legit.none.legit.ratio = calculate_ratio(group.all.count, group.legit.DR, group.legit.DR$DR==0)

  return(list(GFALR=group.Fake.all.legit.ratio,
              GFOLR=group.Fake.atleastone.legit.ratio,
              GFNLR=group.Fake.none.legit.ratio,
              GLALR=group.legit.all.legit.ratio,
              GLOLR=group.legit.atleastone.legit.ratio,
              GLNLR=group.legit.none.legit.ratio))
}

print_stat <- function(stats, name){
  group.Fake.all.legit.ratio=stats$GFALR
  group.Fake.atleastone.legit.ratio=stats$GFOLR
  group.Fake.none.legit.ratio=stats$GFNLR
  group.legit.all.legit.ratio=stats$GLALR
  group.legit.atleastone.legit.ratio=stats$GLOLR
  group.legit.none.legit.ratio=stats$GLNLR
  print(sprintf("%s-Fake: Ratio of participants who labeled both questions as legitimate:  %f",
                name, group.Fake.all.legit.ratio))
  print(sprintf("%s-Fake: Ratio of participants who labeled at least one question as legitimate:  %f",
                name, group.Fake.atleastone.legit.ratio))
  print(sprintf("%s-Fake: Ratio of participants who labeled none of the questions as legitimate:  %f",
                name, group.Fake.none.legit.ratio))
  print(sprintf("%s-Legit: Ratio of participants who labeled both questions as legitimate:  %f",
                name, group.legit.all.legit.ratio))
  print(sprintf("%s-Legit: Ratio of participants who labeled at least one question as legitimate:  %f",
                name, group.legit.atleastone.legit.ratio))
  print(sprintf("%s-Legit: Ratio of participants who labeled none of the questions as legitimate:  %f",
                name, group.legit.none.legit.ratio))
}

group_count_fake_with_condition <- function(table, condition){
  group.all.count = length(table$Fake.DR[condition])
  group.fake.DR = data.frame(table$Fake.DR[condition])
  colnames(group.fake.DR) <- c("DR")
  conditioned_count = length(group.fake.DR$DR[group.fake.DR$DR<1])
  return (list(group.all.count=group.all.count, conditioned_count=conditioned_count))
}

group_count_fake <- function(table, branch){
  group.all.count = length(table$Fake.DR[table$New.Percent.Branch==branch])
  group.fake.DR = data.frame(table$Fake.DR[table$New.Percent.Branch==branch])
  colnames(group.fake.DR) <- c("DR")
  conditioned_count = length(group.fake.DR$DR[group.fake.DR$DR<1])
  return (list(group.all.count=group.all.count, conditioned_count=conditioned_count))
}

group_count_legit_with_condition <- function(table, condition){
  group.all.count = length(table$Legit.DR[condition])
  group.legit.DR = data.frame(table$Legit.DR[condition])
  colnames(group.legit.DR) <- c("DR")
  conditioned_count = length(group.legit.DR$DR[group.legit.DR$DR>0])
  return (list(group.all.count=group.all.count, conditioned_count=conditioned_count))
}

group_count_legit <- function(table, branch){
  group.all.count = length(table$Legit.DR[table$New.Percent.Branch==branch])
  group.legit.DR = data.frame(table$Legit.DR[table$New.Percent.Branch==branch])
  colnames(group.legit.DR) <- c("DR")
  conditioned_count = length(group.legit.DR$DR[group.legit.DR$DR>0])
  return (list(group.all.count=group.all.count, conditioned_count=conditioned_count))
}

significant_test_with_condition <- function(table, first_condition, second_condition){
  group_first= group_count_fake_with_condition(table, first_condition)
  group_second= group_count_fake_with_condition(table, second_condition)

  prop_test_fake = prop.test(c(group_second$conditioned_count, group_first$conditioned_count),
                             c(group_second$group.all.count, group_first$group.all.count),
                             correct = FALSE)

  group_first = group_count_legit_with_condition(table, first_condition)
  group_second = group_count_legit_with_condition(table, second_condition)

  prop_test_legit = prop.test(c(group_second$conditioned_count, group_first$conditioned_count),
                              c(group_second$group.all.count, group_first$group.all.count),
                              correct = FALSE)

  return(list(prop_test_fake=prop_test_fake,
           prop_test_legit=prop_test_legit))
}

significant_test <- function(table, first_branch, second_branch){
  group_first= group_count_fake(table, first_branch)
  group_second= group_count_fake(table, second_branch)

  prop_test_fake = prop.test(c(group_second$conditioned_count, group_first$conditioned_count),
                             c(group_second$group.all.count, group_first$group.all.count),
                             correct = FALSE)

  group_first = group_count_legit(table, first_branch)
  group_second = group_count_legit(table, second_branch)

  prop_test_legit = prop.test(c(group_second$conditioned_count, group_first$conditioned_count),
                             c(group_second$group.all.count, group_first$group.all.count),
                             correct = FALSE)

  return(c(prop_test_fake=prop_test_fake,
           prop_test_legit=prop_test_legit))
}

significant_test_four_branches <- function(table,
                                           first_branch, second_branch,
                                           third_branch, fourth_branch){
  #fourth: both
  #third: None
  #second: Receiver
  #first: Sender
  group_first= group_count_fake(table, first_branch)
  group_second= group_count_fake(table, second_branch)
  group_third= group_count_fake(table, third_branch)
  group_fourth= group_count_fake(table, fourth_branch)

  prop_test_fake = prop.test(c(group_fourth$conditioned_count, group_third$conditioned_count,
                               group_second$conditioned_count, group_first$conditioned_count),
                             c(group_fourth$group.all.count, group_third$group.all.count,
                               group_second$group.all.count, group_first$group.all.count),
                             correct = FALSE)

  pairwise.prop.test(c(group_fourth$conditioned_count, group_second$conditioned_count,
                       group_second$conditioned_count, group_first$conditioned_count),
                     c(group_fourth$group.all.count, group_third$group.all.count,
                       group_second$group.all.count, group_first$group.all.count))

  group_first = group_count_legit(table, first_branch)
  group_second = group_count_legit(table, second_branch)
  group_third = group_count_legit(table, third_branch)
  group_fourth = group_count_legit(table, fourth_branch)

  prop_test_legit = prop.test(c(group_fourth$conditioned_count, group_second$conditioned_count,
                                group_second$conditioned_count, group_first$conditioned_count),
                              c(group_fourth$group.all.count, group_third$group.all.count,
                                group_second$group.all.count, group_first$group.all.count),
                              correct = FALSE)

  pairwise.prop.test(c(group_fourth$conditioned_count, group_second$conditioned_count,
                       group_second$conditioned_count, group_first$conditioned_count),
                     c(group_fourth$group.all.count, group_third$group.all.count,
                       group_second$group.all.count, group_first$group.all.count))

  return(c(prop_test_fake=prop_test_fake,
           prop_test_legit=prop_test_legit))
}

significant_test_per_question <- function(table, first_branch, second_branch){
  group.all.count_first = 2*length(table$Fake.DR[table$New.Percent.Branch==first_branch])
  group.fake.DR = data.frame(table$Fake.DR[table$New.Percent.Branch==first_branch])
  colnames(group.fake.DR) <- c("DR")
  conditioned_count_first = 0
  conditioned_count_first = conditioned_count_first + length(group.fake.DR$DR[group.fake.DR$DR==0.5])
  conditioned_count_first = conditioned_count_first + 2*length(group.fake.DR$DR[group.fake.DR$DR==1])

  group.all.count_second = 2*length(table$Fake.DR[table$New.Percent.Branch==second_branch])
  group.fake.DR = data.frame(table$Fake.DR[table$New.Percent.Branch==second_branch])
  colnames(group.fake.DR) <- c("DR")
  conditioned_count_second = 0
  conditioned_count_second = conditioned_count_second + length(group.fake.DR$DR[group.fake.DR$DR==0.5])
  conditioned_count_second = conditioned_count_second + 2*length(group.fake.DR$DR[group.fake.DR$DR==1])

  prop_test_fake = prop.test(c(conditioned_count_second,conditioned_count_first),
                             c(group.all.count_second,group.all.count_first),
                             correct = FALSE)

  group.all.count_first = 2*length(table$Legit.DR[table$New.Percent.Branch==first_branch])
  group.legit.DR = data.frame(table$Legit.DR[table$New.Percent.Branch==first_branch])
  colnames(group.legit.DR) <- c("DR")
  conditioned_count_first = 0
  conditioned_count_first = conditioned_count_first + length(group.legit.DR$DR[group.legit.DR$DR==0.5])
  conditioned_count_first = conditioned_count_first + 2*length(group.legit.DR$DR[group.legit.DR$DR==1])

  group.all.count_second = 2*length(table$Legit.DR[table$New.Percent.Branch==second_branch])
  group.legit.DR = data.frame(table$Legit.DR[table$New.Percent.Branch==second_branch])
  colnames(group.legit.DR) <- c("DR")
  conditioned_count_second = 0
  conditioned_count_second = conditioned_count_second + length(group.legit.DR$DR[group.legit.DR$DR==0.5])
  conditioned_count_second = conditioned_count_second + 2*length(group.legit.DR$DR[group.legit.DR$DR==1])

  prop_test_legit = prop.test(c(conditioned_count_second,conditioned_count_first),
                              c(group.all.count_second,group.all.count_first),
                              correct = FALSE)

  return(c(prop_test_fake=prop_test_fake,
           prop_test_legit=prop_test_legit))
}

diagram <- function(temp){
  library(ggplot2)
  ggplot(temp, aes(x = Highest.degree.achieved., y = F1)) +
    geom_boxplot(size = .75) +
    #geom_jitter(alpha = .5) +
    facet_grid(Your.occupation. ~ Gender
               , margins = TRUE) +
    theme(axis.text.x = element_text(angle = 45, hjust = 1, vjust = 1))

  op <- par(mar = c(7,4.5,2,1) + 0.1)
  boxplot(F1~reasoning_group, data=table, xaxt = "n", xlab="Number of clues mentioned",
          drop=TRUE, line=3, cex.lab=2, cex.axis=2,cex.main=2)
  #axis(2, at=1:3, labels=c("<=1\n(inattentive)", ">1&<=3\n(moderate attentive)", ">3\n(attentive)"),
  #     side = 1, tick = FALSE, cex.axis=2)
  means <- tapply(table$F1,table$reasoning_group,mean)
  points(means,col="red",pch=8, cex=1)

  plot <- ggplot(data = temp, aes(y = F1, x = reasoning_group)) +
    geom_boxplot(fatten = NULL) +
    stat_summary(fun.y = mean, geom = "errorbar", aes(ymax = ..y.., ymin = ..y..),
                 width = 0.75, size = 1, linetype = "solid")
  print(plot)
}

ordered_logistic_regression  <- function(table){
  table$merged_plafrom[table$platform == "windows"] = "PC"
  table$merged_plafrom[table$platform == "mac"] = "PC"
  table$merged_plafrom[table$platform == "iphone"] = "mobile"
  table$merged_plafrom[table$platform == "android"] = "mobile"

  m1 <- polr(as.factor(DR) ~Age.+merged_plafrom, data = table, Hess=TRUE)
  ctable <- coef(summary(m1))
  p <- pnorm(abs(ctable[, "t value"]), lower.tail = FALSE) * 2
  ctable <- cbind(ctable, "p value" = p)

  m2 <- polr(as.factor(DR) ~Age.+merged_plafrom+How.many.years.have.you.been.using.email.+Approximate...of.emails.you.receive.in.each.day.+How.frequently.do.you.check.social.networks..e.g...Facebook..Twitter..Google..Blogs..LinkedIn.., data = table, Hess=TRUE)
  m3 <- polr(as.factor(DR) ~Age.+
               merged_plafrom+How.many.years.have.you.been.using.email.+
               Approximate...of.emails.you.receive.in.each.day.+
               How.frequently.do.you.check.social.networks..e.g...Facebook..Twitter..Google..Blogs..LinkedIn..+
               Do.you.use.any.spam.filter..stand.alone.or.part.of.Antivirus..to.filter.emails.in.your.personal.account.+
               Have.you.ever.used.browsers..bookmarks.+
               Have.you.ever.installed.computer.software.on.your.computer.+
               Have.you.ever.used.internet.calling.software..e.g...Skype..Hangout.etc...+
               Have.you.ever.used.online.systems.for.banking.or.shopping.+
               Have.you.seen.any.specific.information.in.the.last.year.that.helps.you.detect.email.scams., data = table, Hess=TRUE)
  technology_background= table[c("Do.you.use.any.spam.filter..stand.alone.or.part.of.Antivirus..to.filter.emails.in.your.personal.account.",
                                 "Have.you.ever.used.browsers..bookmarks.",
                                 "Have.you.ever.installed.computer.software.on.your.computer.",
                                 "Have.you.ever.used.internet.calling.software..e.g...Skype..Hangout.etc...",
                                 "Have.you.ever.used.online.systems.for.banking.or.shopping.",
                                 "Have.you.seen.any.specific.information.in.the.last.year.that.helps.you.detect.email.scams.")]
  table$technology_background =rowSums(technology_background=="Yes")

  m2 <- polr(as.factor(DR) ~Age.+merged_plafrom+How.many.years.have.you.been.using.email.+Approximate...of.emails.you.receive.in.each.day.+How.frequently.do.you.check.social.networks..e.g...Facebook..Twitter..Google..Blogs..LinkedIn..+technology_background, data = table, Hess=TRUE)
  anova(m1, m2)

}


library(ggplot2)
library(class)
library(gmodels)
#load data
knn.data <- read.csv("Downloads/MachineLearning-master/Example Data/KNN_Example_1.csv")
#take a look at data
ggplot(knn.data) + geom_point(aes(X, Y, color = Label))
#split data into 2 fold
sub <- sample(2, nrow(knn.data), replace=TRUE, prob=c(0.5, 0.5))
data.train <- knn.data[sub == 1, 1:2]
data.test <- knn.data[sub == 2, 1:2]
data.train.label <- knn.data[sub == 1, 3]
data.test.label <- knn.data[sub == 2, 3]
#train a knn model
knn.pred <- knn(train = data.train, test = data.test, cl = data.train.label, k = 3)
#show accuracy
knn.pred.dataframe <- as.data.frame(knn.pred)
knn.test.label <- as.data.frame(data.test.label)
knn.accuracy <- cbind(knn.pred.dataframe, knn.test.label)
#predict 5.3, 4.3
d1 <- 5.3
d2 <- 4.3
unknown <- cbind(d1, d2)
colnames(unknown) <- c("X", "Y")
knn.pred <- knn(train = data.train, test = unknown, cl = data.train.label, k = 3)
#evaluate classifier
CrossTable(x = knn.accuracy$data.test.label, y = knn.accuracy$knn.pred, prop.chisq = F)


# Potential Questions to Answer:
# 1. Create snacks that the customers can buy and randomize who buys which snack
# 2. Pretend you own multiple theaters and run two simulations to represent each theater and plot the results
# 3. Create conditional statements for movies that may be PG-13 and children are not allowed to watch

# Cost for adults and children
ticket_cost <- ?
ticket_cost_child <- ?
movies <- c('', '', '', '', '')  # List 5 of your favorite movies
screens <-  # How many screens does the theater have? (assume 1 per movie)
seats <-  # How many seats does each theater hold
week_days <- rep(0, 7)  # Store totals for each day

# iterate through the week
for () {

  # Keep track of total revenue for the day

  # iterate through the amount of screens on a particular day
  for () {

    # Calculate  how many adults and children are watching the movie
    visitors_adults <- sample(, 1)
    visitors_children <- sample((),1)

    # Calculate the revenue for adults and children

    # Calculate revenue, and add to running total for the day

  }
  # Save total to the corresponding day

}

# Make a barchart showing total revenue per day

# Make any other chart

# Which day had the highest revenue?


library(mlogit)

data("Heating")
str(Heating)

DataHeating <- mlogit.data(Heating, shape="wide", choice="depvar", varying=c(3:12))
head(DataHeating, 10)

form1 <- mFormula(depvar~ic+oc|0)
MlogitModel <- mlogit(form1, DataHeating)
summary(MlogitModel)


       #par(mfrow=c(2,1), mgp = c(1.5, 0.5, 0),tck=0.02)

       V<- 4.66*10^(-13)

       #V是基础弯月面体积

       vne1<- 0.5*q[1]/fv + 4.66*10^(-13)

       vne2<- (3*10^(-12))*(1-k)/fv

       #vne是体积增量

       fv<-c(1:200)
       q<-c(1.5*10^(-12),8.33*10^(-12),16.67*10^(-12),
            1.5/60*10^(-12),27/60*10^(-12),54/60*10^(-12),3*10^(-12))
       k<-c(0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8)

       #fv,q,k分别为电压频率，流量和占空比

       plot(fv,vne1, mgp = c(1.5, 0.5, 0),tck=0.02,type="b",pch=1,cex=0.6,lwd=1.5,lty=2,xlab = expression(italic(f["v"])(Hz)),
            ylab = expression (italic(V["ne"]+V["m"](m^3))),xlim=c(0,200),ylim=c(4.66*10^(-13), 9*10^(-13)))

       coll<-rainbow(7)
       pcc<-c(1,2,3,4,5,6,7)

       for(i in 2:7){
         lines(fv,(0.5*q[i]/fv + 4.66*10^(-13)),col=coll[i],pch=pcc[i],cex=0.6, type="b",lwd=1.5,
               lty=2)
       }

       abline(h=(V+0.05*V),col="red",lwd=1.5,lty=4)
       abline(h=(V+0.1*V),col="red",lwd=1.5,lty=4)
       abline(h=(V+0.2*V),col="red",lwd=1.5,lty=4)
       abline(h=(V+0.6*V),col="red",lwd=1.5,lty=4)

       legend("topright",c("1.5nl/s","8.33nl/s","16.67nl/s",
                           "1.5nl/min","27nl/min","54nl/min",
                           "180nl/min"),col=c("black",
         coll[2],coll[3],coll[4],coll[5],coll[6],coll[7]),
         inset = .02,pch=c(1,2,3,4,5,6,7),bty = "n",lty=2,lwd=1.5,cex=0.8)


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

library(data.table)
library(ggplot2)
library(dplyr)
library(dtplyr)
library(magrittr)

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

if(! file.exists(dirname(ofile))) dir.create(dirname(ofile))

################
# Functions
checkIfSawtooth = function(Strands, Intercepts, Bps, Rsss, BpsBefore){
  # Added new condition: after/before slope ratio > 1
  sapply(seq_along(Strands), function(i){
    Strand = Strands[i]
    Intercept = Intercepts[i]
    Bp = Bps[i]
    Rss = Rsss[i]
    BpBefore = BpsBefore[i]
    if(is.na(Rss)){
      return(NA)
    }

    if(Strand == "+"){
#     if(Intercept > 0 & Bp < 0 & Rss < 0 & Bp/BpBefore > 1){
      if(Intercept > 0 & Bp < 0 & Rss < 0 & Bp < BpBefore){
        return(TRUE)
      }else{
        return(FALSE)
      }
    }
    if(Strand == "-"){
      # if(Intercept < 0 & Bp > 0 & Rss > 0 & Bp/BpBefore > 1){
      if(Intercept < 0 & Bp > 0 & Rss > 0 & Bp > BpBefore){
        return(TRUE)
      }else{
        return(FALSE)
      }

    }
    return(NA)
  })
}

#################
# Load data and preprocess
dt = rbindlist(
  lapply(ifiles, function(ifile){
    dt = fread(sprintf("gzip -dc %s", ifile), header=TRUE)
    dt[, path := ifile]
    dt
  })
)
dt[, group := basename(dirname(path))]

dtpval = rbindlist(
  lapply(pvalfiles, function(ifile){
    dt = fread(ifile, header=TRUE)
    dt[, path := ifile]
    dt
  })
)
dtpval[, group := basename(dirname(path))]

dtpval[, strand := strand]
dtpval[, sawtooth_raw := checkIfSawtooth(strand, df.rss.lm_Intercept, df.rss.lm_bp, df.rss.lm_RSSTRUE, df.lm_bp)] %>% invisible()
dtpval[, pval.raw_new := pval.raw]
dtpval[sawtooth_raw==FALSE, pval.raw_new := 1]

dtpval[, isRs := pval.raw_new < thPval]

# Select high probability samples
dtProb = fread(probabilityFile, header=TRUE, sep="\t")
dtProb = dtProb[, .(label, rsDetectionProb, label_sum_down, label_sum_up)]
dtpval = dtpval[group %in% dtProb[rsDetectionProb > thProbability & label_sum_up > 0 & label_sum_down > 0, label]]
print(str(dtpval))

save(dt, dtpval, file=path_rdata)

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


 DGBBRD Example Program Results

 Diagonal D:
         3.0561        1.5259        0.9690        1.5685

 Off-diagonal E:
         0.6206        1.2353        1.1240


plot.area<-function(x,col=NULL,horiz=F,prop=T,stp.ln=T,grp.ln=T,axs.cex=1,axs.lab=T,lab.cex=1,
                    names=c('Group','Step','Value'),...){

  #sort out color fector
  if(!is.null(col)){
    if(sum(col %in% colors()) != length(col)) stop('col vector must be in "colors()"')
    col<-colorRampPalette(col)(ncol(x))
  }
  else col<-colorRampPalette(c('lightblue','green'))(ncol(x))

  #convert data
  if(prop) plt.dat<-x/rowSums(x)
  else plt.dat<-x
  plt.dat<-t(apply(plt.dat,1,cumsum))
  plt.dat<-data.frame(strt=rep(0,nrow(plt.dat)),plt.dat)

  #create plot
  y.range<-c(0,max(plt.dat))
  x.range<-c(0,max(plt.dat))
  y.locs<-seq(y.range[2],y.range[1],length=nrow(plt.dat))
  if(horiz) y.locs<-rev(y.locs)

  plot.new()

  par(...)
  plot(x.range,y.range,type='n',axes=F,xlab='',ylab='')

  #polygons
  sapply(
    1:(nrow(plt.dat)),
    function(y){
      sapply(
        1:(ncol(plt.dat)-1),
        function(x){
          x.loc.poly<-c(plt.dat[y,x],plt.dat[y,x+1],plt.dat[y+1,x+1],plt.dat[y+1,x])
          y.loc.poly<-rep(c(y.locs[y],y.locs[y+1]),each=2)
          if(horiz) polygon(y.loc.poly,x.loc.poly,col=col[x],border=NA)
          else polygon(x.loc.poly,y.loc.poly,col=col[x],border=NA)
        }
      )
    }
  )

  #group labels
  x.labs<-sapply(1:(ncol(plt.dat)-1),function(x) mean(c(plt.dat[1,x],plt.dat[1,x+1])))

  parms<-list(
    1:ncol(plt.dat),
    function(col) lines(plt.dat[,col],y.locs,lwd=1),
    function(y) segments(0,y.locs[y],plt.dat[y,ncol(plt.dat)],y.locs[y]),
    3,1,2,
    x.labs,
    y.locs,
    3,2,1
  )
  if(horiz)
    parms<-list(
      ncol(plt.dat):1,
      function(col) lines(y.locs,plt.dat[,col],lwd=1),
      function(y) segments(y.locs[y],0,y.locs[y],plt.dat[y,ncol(plt.dat)]),
      2,4,1,
      x.labs,
      y.locs,
      2,1,4
    )

  #grp lines
  if(grp.ln) sapply(parms[[1]],parms[[2]])

  #step lines
  if(stp.ln) sapply(nrow(plt.dat):1,parms[[3]])

  #group axis labels
  axis(side=parms[[4]],at=parms[[7]],labels=names(plt.dat)[-1],tick=F,line=-1,las=1,cex.axis=axs.cex)

  #value axis
  axis(side=parms[[5]],las=1,cex.axis=axs.cex)

  #time step axis labels
  axis(side=parms[[6]],at=parms[[8]],labels=row.names(plt.dat),tick=F,line=-1,las=1,cex.axis=axs.cex)

  #axis labels
  if(axs.lab){
    mtext(side=parms[[9]],names[1],line=1,cex=lab.cex)
    mtext(side=parms[[10]],names[2],line=1,cex=lab.cex)
    mtext(side=parms[[11]],names[3],line=2,cex=lab.cex)
  }

}


data = read.delim("sizes.csv")

plotGraph = function(tag, title='', showY=T) {
  n = max(data[data$tag == tag, ]$i)
  i = 1:n
  n2 = n/2

  if (showY) {
    yaxt = 's'
  } else {
    yaxt = 'n'
  }

  plot(actual~q, data[data$tag == tag,], cex=0.2, xaxt='n', xlim=c(0,1), ylim=c(0,1050), xlab='Quantile',
       ylab='Centroid size', yaxt=yaxt)
  title(title)
  box(lwd=3)
  axis(side=1, at=c(0,0.25, 0.5, 0.75, 1), labels=c(0.0,0.25,0.5,0.75, 1.0), lwd=3)

  q = seq(0,1,by=0.01)
  lines(q, 1000*4*q*(1-q), lwd=3, col='gray')
}

png("sizes.png", width=1800, height=700, pointsize=36)
layout(matrix(c(1,2,3), 1, 3, byrow=T), widths=c(1.21,1,1))
plotGraph("uniform", title="Uniform Distribution", T)
old = par(mar=c(5.1,0,4.1,2))
plotGraph("gamma", title="Gamma(0.1, 0.1) Distribution", F)
plotGraph("sequential", title="Sequential Distribution", F)
par(old)
  dev.off()
#plotGraph("mixture", title="Mixture Distribution")


"gen.data"<-function(funind,n=NULL,p=NULL){
if(is.null(n)) n=400
if(is.null(p)) p=1000
y0=NULL
if(funind<=4){
s=3*2^(funind-1)
u=matrix(rnorm(n*(p-50)),n,p-50)
v=matrix(rnorm(n*50),n,50)
w=u[,1:s]
wcoef=(-1)^(1:s+1)/5
x0=w%*%wcoef
x2=as.vector(x0)+sqrt(25-s)/5*v
x=cbind(u,x2)
betatrue=(-1)^(1:s+1)
y0=w%*%betatrue
y=y0+rnorm(n)*sqrt(3)
}  else if(funind==5){
s=3
x=matrix(rnorm(n*p),n,p)
x[,2]=-1/3*x[,1]^3+rnorm(n)
y0= x[,1]+x[,2]+x[,3]
y=y0+rnorm(n)*sqrt(3)
}
#if(funind<=4){
#s=3*2^(funind-1)
#u=matrix(rnorm(n*(p-50)),n,p-50)
#v=matrix(rnorm(n*50),n,50)
#w=u[,1:s]
#wcoef=(-1)^(1:s+1)/5
#x0=w%*%wcoef
#x2=as.vector(x0)+sqrt(25-s)/5*v
#x=cbind(u,x2)
#betatrue=(-1)^(1:s+1)
#y=w%*%betatrue+rnorm(n)
#}  else if(funind==5){
#s=3
#x=matrix(rnorm(n*p),n,p)
#x[,2]=-1/3*x[,1]^3+rnorm(n)
#y=x[,1]+x[,2]+x[,3]+rnorm(n)
#}
#
else if(funind==6){
s=4
x=matrix(runif(n*p),n,p)
y0=5*f1(x[,1])+3*f2(x[,2])+4*f3(x[,3])+6*f4(x[,4])
y=y0+rnorm(n)*sqrt(1.74)
} else if(funind==7){
s=4
w=matrix(runif(n*p),n,p)
u=runif(n)
x=(w+u)/2
y0=5*f1(x[,1])+3*f2(x[,2])+4*f3(x[,3])+6*f4(x[,4])
y=y0+rnorm(n)*sqrt(1.74)
} else if(funind==8){
s=12
x=matrix(runif(n*p),n,p)
y0=(f1(x[,1])+f2(x[,2])+f3(x[,3])+f4(x[,4])+
1.5*f1(x[,5])+1.5*f2(x[,6])+1.5*f3(x[,7])+1.5*f4(x[,8])+
2*f1(x[,9])+2*f2(x[,10])+2*f3(x[,11])+2*f4(x[,12]))
y=y0+rnorm(n)*sqrt(0.5184)
} else if(funind==9){
s=12
w=matrix(runif(n*p),n,p)
u=runif(n)
x=(w+u)/2
y0=(f1(x[,1])+f2(x[,2])+f3(x[,3])+f4(x[,4])+
1.5*f1(x[,5])+1.5*f2(x[,6])+1.5*f3(x[,7])+1.5*f4(x[,8])+
2*f1(x[,9])+2*f2(x[,10])+2*f3(x[,11])+2*f4(x[,12]))
y=y0+rnorm(n)*sqrt(0.5184)
} else if(funind==10){
s=4
x=matrix(rnorm(p*n, mean=0, sd=1), n, p)
betatrue <- c(2,2,2,-3*sqrt(2))
truerho=0.5
corrmat=diag(rep(1-truerho, p))+matrix(truerho, p, p)
corrmat[,4]=sqrt(truerho)
corrmat[4, ]=sqrt(truerho)
corrmat[4,4]=1
cholmat=chol(corrmat)
x=x%*%cholmat
y0 <- x[,1:s]%*%betatrue
y=y0+rnorm(n)
} else if(funind==11){
s=12
x=matrix(runif(n*p),n,p)
y=(f1(x[,1])+f2(x[,2])+f3(x[,3])+f4(x[,4])+
1.5*f1(x[,5])+1.5*f2(x[,6])+1.5*f3(x[,7])+1.5*f4(x[,8])+
2*f1(x[,9])+2*f2(x[,10])+2*f3(x[,11])+2*f4(x[,12]))+0.5*rnorm(n)*sqrt(0.5184)
} else if(funind==12){
s=12
w=matrix(runif(n*p),n,p)
u=runif(n)
x=(w+u)/2
y=(f1(x[,1])+f2(x[,2])+f3(x[,3])+f4(x[,4])+
1.5*f1(x[,5])+1.5*f2(x[,6])+1.5*f3(x[,7])+1.5*f4(x[,8])+
2*f1(x[,9])+2*f2(x[,10])+2*f3(x[,11])+2*f4(x[,12]))+0.5*rnorm(n)*sqrt(0.5184)
}  else if(funind>=18 & funind<=22)
{
s=4
x=matrix(runif(n*p),n,p)
y0=3*f1(x[,1])+3*f2(x[,2])+2*f3(x[,3])+2*f4(x[,4])
y=y0+rnorm(n)*sqrt(3.3843)*sqrt(2^(20-funind))
}   else if(funind>=28 & funind<=32)
{
s=4
w=matrix(runif(n*p),n,p)
u=runif(n)
x=(w+u)/2
y0=3*f1(x[,1])+3*f2(x[,2])+2*f3(x[,3])+2*f4(x[,4])
y=y0+rnorm(n)*sqrt(3.3843)*sqrt(2^(30-funind))
}
return(data=list(x=x,y=y,n=n,p=p,s=s,y0=y0))

}

f1<-function(x){x}
f2<-function(x){(2*x-1)^2}
f3<-function(x){sin(2*pi*x)/(2-sin(2*pi*x))}
f4<-function(x){0.1*sin(2*pi*x)+0.2*cos(2*pi*x)+0.3*sin(2*pi*x)^2+0.4*cos(2*pi*x)^3+0.5*sin(2*pi*x)^3}

simuNIS<-function(funind=NULL, repgroup=NULL, n=NULL, p=NULL, trace.it=NULL, knots=NULL, maxloop=NULL, eps0=NULL, randSeed = 0)
{
  if(is.null(funind)) stop('No given data generating scheme.')
  if(is.null(trace.it)) trace.it=FALSE
  if(is.null(maxloop)) maxloop=10
  if(is.null(eps0)) eps0=1e-6
  if(is.null(n)) n=400
  if(is.null(p)) p=1000
  if(is.null(knots)) knots=ceiling(n^0.2)

  trace.it=as.logical(trace.it)
  set.seed(randSeed)
    cat('Random seed=', randSeed, '...\n')
    data=gen.data(funind,n,p)
    testdata=gen.data(funind,n/2,p)

    greedINIS.fit = greedINIS(data, testdata,  knots=knots, eps0=eps0, DOISIS=TRUE,trace=trace.it)

    aINIS.fit = adaptINIS(data, testdata,  knots=knots, eps0=eps0, DOISIS=TRUE, maxloop=maxloop,trace=trace.it)

  return(list(greedyINIS = greedINIS.fit, INIS = aINIS.fit))
  #filename=paste(newpath,'/','funind=',funind,'_knots=',knots,'_r0=',r0,'_r1=',r1,'.RData',sep='')
  #save(aINIS.fit, greedINIS.fit, penGAM.fit,lmsis.fit,results,file=filename)
}

###########################################################################
#greedINIS: g-INIS algorithm, using knots=n^0.2
###########################################################################
greedINIS <- function(data, testdata=NULL, lambda.pen.list=NULL, folds=NULL, quant=NULL, gnum=1, kfold=NULL, knots=NULL,  eps0=1e-6, DOISIS=TRUE, maxloop=20, trace=FALSE, detailed=FALSE){
  t0=proc.time()[1]
  cat('starting greedINIS, g-INIS-penGAM algorithm, adatively choose number of variables\n')
  x=data$x
  y=data$y
  n <- nrow(x)
  p <- ncol(x)

  #if(is.null(nsis)) nsis=min(floor(n/log(n)),p-1)
  if(is.null(knots)) knots=ceiling(n^0.2)
  if(is.null(folds)) {
    temp= sample(1:n, n, replace = FALSE)
    if(is.null(kfold)) kfold=5
    for(i in 1:kfold){
      folds[[i]]=setdiff(1:n, temp[seq(i, n, kfold)])
    }
  }
  if(is.null(quant)) quant=1
  df0 <- knots+1

  xbs=matrix(0,n,df0*p)

  for(i in 1:p)
    xbs[,(i-1)*(df0)+(1:df0)]=ns(x[,i],df=df0)

  tempresi <- rep(0,p)

  curloop=1
  for(i in 1:p)
  {

    tempfit <-lm.fit (x=cbind(1,xbs[,(i-1)*df0+1:df0]),y=y)
    tempresi[i] <- sum(tempfit$residuals^2)
  }

  used.list<- tempresi

  used.sort <- sort(used.list, method= "sh", index=TRUE, decreasing=FALSE)
  initRANKorder <- used.sort$ix

  mindex <- sample(1:n)
  mresi=NULL
  for(i in 1:p){
    tempfit <-lm.fit (x=cbind(1,xbs[,(i-1)*df0+1:df0]),y=y[mindex])
    mresi[i] <- sum(tempfit$residuals^2)
  }
  resi.thres = quantile(mresi,1-quant)
  nsis <- min(sum(used.list<resi.thres), floor(n/df0/2),gnum)

  SISind <- sort(initRANKorder[1:nsis])
  if(!DOISIS) return (list(initRANKorder=initRANKorder, SISind=SISind, nsis=nsis))

  cat('loop ', curloop, '...SISind ', SISind,'\n')
  pick.ind=initRANKorder[1:nsis]

  xnew=x[,pick.ind]

  fit.tmp <- cv.penGAM(data=list(x=xnew,y=y), folds=folds, lambda.pen.list=NULL, knots=knots, eps0=eps0,cv.trace=trace)
  ISISind <- sort(pick.ind[fit.tmp$penGAMind])
  cat('loop ', curloop, '...ISISind ', ISISind,'\n')
  test= 1
  normal.exit = 1

  detail.pickind=NULL
  detail.ISISind=NULL
  detail.pickind=as.list(detail.pickind)
  detail.ISISind=as.list(detail.ISISind)

  detail.pickind[[curloop]]=pick.ind
  detail.ISISind[[curloop]]=ISISind

  if(length(ISISind)==0) {
    warnings('No variable was selected by this variant of ISIS.')
    normal.exit = 0
    if(detailed){
      return(list(fit=fit.tmp,initRANKorder=initRANKorder, detail.pickind=detail.pickind, detail.ISISind=detail.ISISind,
                  SISind=SISind, ISISind=ISISind,  nsis=nsis, normal.exit=normal.exit))
    } else
    {
      return(list(fit=fit.tmp,SISind=SISind, ISISind=ISISind))
    }
  }

  while(test){
    oldISISind=ISISind
    curloop=curloop+1
    remind <- setdiff(1:p, ISISind)

    tempresi=rep(0,length(remind))

    oldInd = rep(1:df0,length(ISISind))+df0*rep(ISISind-1,each=df0)

    for(i in 1:length(remind))
    {
      tempfit <-lm.fit (x=cbind(1,xbs[,c(oldInd,(remind[i]-1)*df0+1:df0)]),y=y)
      tempresi[i]<-sum(tempfit$residuals^2)
    }

    used.list<- tempresi

    used.sort <- sort(used.list, method= "sh", index=TRUE, decreasing=FALSE)

    mindex <- sample(1:n)
    mresi=NULL
    for(i in 1:length(remind))
    {
      tempfit <-lm.fit (x=cbind(1,xbs[,oldInd],xbs[mindex,(remind[i]-1)*df0+1:df0]),y=y)
      mresi[i] <- sum(tempfit$residuals^2)
    }
    resi.thres = quantile(mresi,1-quant)
    newind <- min(sum(used.list<resi.thres), floor(n/df0/2)-length(ISISind),gnum)

    if(newind==0)
    {
      test=0
      break
    }
    new.pickind <- sort(remind[used.sort$ix[1:newind]])

    pick.ind=c(ISISind, new.pickind)

    cat('loop ', curloop, '...SISind ', sort(pick.ind),'\n')
    xnew=x[,pick.ind]

    fit.tmp <- cv.penGAM(data=list(x=xnew,y=y), folds=folds, lambda.pen.list=NULL, knots=knots, eps0=eps0 ,cv.trace=trace)
    ISISind <- sort(pick.ind[fit.tmp$penGAMind])
    cat('loop ', curloop, '... ISISind ', ISISind,'\n')

    detail.pickind[[curloop]]=pick.ind
    detail.ISISind[[curloop]]=ISISind

    if(setequal(oldISISind, ISISind)) test=0
    if(curloop>=maxloop) {
      test=0
      normal.exit=0
    }

  }
  final.fit<-fit.tmp$fit
  cv.error<-fit.tmp$cv.error
  if(!is.null(testdata)){
    testx=testdata$x
    testy=testdata$y
    pred.error<-mean((predict(final.fit,as.matrix(testx[,pick.ind]))-testy)^2)
  } else pred.error=NULL

  ISISind=sort(ISISind)
  SISind=sort(SISind)
  ptime = proc.time()[1]-t0
  cat('finishing adaptINIS...\n')
  if(detailed){
    return(list(fit=fit.tmp, initRANKorder=initRANKorder, detail.pickind=detail.pickind, detail.ISISind=detail.ISISind,
                SISind=SISind, ISISind=ISISind,  nsis=nsis, cv.error=cv.error, pred.error=pred.error, ptime = ptime, normal.exit=normal.exit))
  } else
  {
    return(list(fit=fit.tmp, ISISind=ISISind, cv.error=cv.error, pred.error=pred.error, ptime = ptime, normal.exit=normal.exit))
  }
}

###########################################################################
#adaptINIS: INIS-penGAM algorithm, using knots=n^0.2
###########################################################################
adaptINIS <- function(data, testdata=NULL, lambda.pen.list=NULL, folds=NULL, quant=NULL, kfold=NULL, knots=NULL,  eps0=1e-6, DOISIS=TRUE, maxloop=10, trace=FALSE, detailed=FALSE){
  t0=proc.time()[1]
  cat('starting adaptINIS, INIS-penGAM algorithm, adatively choose number of variables\n')
  x=data$x
  y=data$y
  n <- nrow(x)
  p <- ncol(x)

  #if(is.null(nsis)) nsis=min(floor(n/log(n)),p-1)
  if(is.null(knots)) knots=ceiling(n^0.2)
  if(is.null(folds)) {
    temp= sample(1:n, n, replace = FALSE)
    if(is.null(kfold)) kfold=5
    for(i in 1:kfold){
      folds[[i]]=setdiff(1:n, temp[seq(i, n, kfold)])
    }
  }
  if(is.null(quant)) quant=1
  df0 <- knots+1

  xbs=matrix(0,n,df0*p)

  for(i in 1:p)
    xbs[,(i-1)*(df0)+(1:df0)]=ns(x[,i],df=df0)

  tempresi <- rep(0,p)

  curloop=1
  for(i in 1:p)
  {

    tempfit <-lm.fit (x=cbind(1,xbs[,(i-1)*df0+1:df0]),y=y)
    tempresi[i] <- sum(tempfit$residuals^2)
  }

  used.list<- tempresi

  used.sort <- sort(used.list, method= "sh", index=TRUE, decreasing=FALSE)
  initRANKorder <- used.sort$ix

  mindex <- sample(1:n)
  mresi=NULL
  for(i in 1:p){
    tempfit <-lm.fit (x=cbind(1,xbs[,(i-1)*df0+1:df0]),y=y[mindex])
    mresi[i] <- sum(tempfit$residuals^2)
  }
  resi.thres = quantile(mresi,1-quant)
  nsis <- max(min(sum(used.list<resi.thres), floor(n/df0/3)),2)

  SISind <- sort(initRANKorder[1:nsis])
  if(!DOISIS) return (list(initRANKorder=initRANKorder, SISind=SISind, nsis=nsis))

  cat('loop ', curloop, '...SISind ', SISind,'\n')
  pick.ind=initRANKorder[1:nsis]

  xnew=x[,pick.ind]

  fit.tmp <- cv.penGAM(data=list(x=xnew,y=y), folds=folds, lambda.pen.list=NULL, knots=knots, eps0=eps0,cv.trace=trace)
  ISISind <- sort(pick.ind[fit.tmp$penGAMind])
  cat('loop ', curloop, '...ISISind ', ISISind,'\n')
  test= 1
  normal.exit = 1

  detail.pickind=NULL
  detail.ISISind=NULL
  detail.pickind=as.list(detail.pickind)
  detail.ISISind=as.list(detail.ISISind)

  detail.pickind[[curloop]]=pick.ind
  detail.ISISind[[curloop]]=ISISind

  if(length(ISISind)==0) {
    warnings('No variable was selected by this variant of ISIS.')
    normal.exit = 0
    if(detailed){
      return(list(fit=fit.tmp,initRANKorder=initRANKorder, detail.pickind=detail.pickind, detail.ISISind=detail.ISISind,
                  SISind=SISind, ISISind=ISISind,  nsis=nsis, normal.exit=normal.exit))
    } else
    {
      return(list(fit=fit.tmp,SISind=SISind, ISISind=ISISind))
    }
  }

  while(test){
    oldISISind=ISISind
    curloop=curloop+1
    remind <- setdiff(1:p, ISISind)

    tempresi=rep(0,length(remind))

    oldInd = rep(1:df0,length(ISISind))+df0*rep(ISISind-1,each=df0)

    for(i in 1:length(remind))
    {
      tempfit <-lm.fit (x=cbind(1,xbs[,c(oldInd,(remind[i]-1)*df0+1:df0)]),y=y)
      tempresi[i]<-sum(tempfit$residuals^2)
    }

    used.list<- tempresi

    used.sort <- sort(used.list, method= "sh", index=TRUE, decreasing=FALSE)

    mindex <- sample(1:n)
    mresi=NULL
    for(i in 1:length(remind))
    {
      tempfit <-lm.fit (x=cbind(1,xbs[,oldInd],xbs[mindex,(remind[i]-1)*df0+1:df0]),y=y)
      mresi[i] <- sum(tempfit$residuals^2)
    }
    resi.thres = quantile(mresi,1-quant)
    newind <- min(sum(used.list<resi.thres), floor(n/df0/3)-length(ISISind))

    if(newind==0)
    {
      test=0
      break
    }
    new.pickind <- sort(remind[used.sort$ix[1:newind]])

    pick.ind=c(ISISind, new.pickind)

    cat('loop ', curloop, '...SISind ', sort(pick.ind),'\n')
    xnew=x[,pick.ind]

    fit.tmp <- cv.penGAM(data=list(x=xnew,y=y), folds=folds, lambda.pen.list=NULL, knots=knots, eps0=eps0 ,cv.trace=trace)
    ISISind <- sort(pick.ind[fit.tmp$penGAMind])
    cat('loop ', curloop, '... ISISind ', ISISind,'\n')

    detail.pickind[[curloop]]=pick.ind
    detail.ISISind[[curloop]]=ISISind
    for(testind in (curloop-1):1){
      if(setequal(detail.ISISind[[testind]], ISISind)){
        test=0
        break
      }
    }
    #if(setequal(oldISISind, ISISind)) test=0
    if(curloop>=maxloop) {
      test=0
      normal.exit=0
    }

  }
  final.fit<-fit.tmp$fit
  cv.error<-fit.tmp$cv.error
  if(!is.null(testdata)){
    testx=testdata$x
    testy=testdata$y
    pred.error<-mean((predict(final.fit,testx[,pick.ind])-testy)^2)
  } else pred.error=NULL

  ISISind=sort(ISISind)
  SISind=sort(SISind)
  ptime = proc.time()[1]-t0
  cat('finishing adaptINIS...\n')
  if(detailed){
    return(list(fit=fit.tmp, initRANKorder=initRANKorder, detail.pickind=detail.pickind, detail.ISISind=detail.ISISind,
                SISind=SISind, ISISind=ISISind,  nsis=nsis, cv.error=cv.error, pred.error=pred.error, ptime = ptime, normal.exit=normal.exit))
  } else
  {
    return(list(fit=fit.tmp, ISISind=ISISind, cv.error=cv.error, pred.error=pred.error, ptime = ptime, normal.exit=normal.exit))
  }
}

#########################################################################################################
compModelSize<-function(funind=NULL, n=NULL, p=NULL, repgroup=NULL,  r0=NULL, r1=NULL,  knots=NULL, maxloop=NULL, eps0=NULL, path=NULL)
{
  if(is.null(funind)) stop('No given data generating scheme.')

  if(is.null(eps0)) eps0=1e-6

  if(is.null(n)) n=400
  if(is.null(p)) p=1000
  if(is.null(knots)) knots=ceiling(n^0.2)
  if(is.null(r0)&is.null(r1)){
    if(is.null(repgroup))
    {
      r0=r1=1
    }
    else{
      r0=(repgroup-1)*10+1
      r1=(repgroup)*10
    }
  }

  if(is.null(path)) path='../'

  ########################################
  ####loading packages
  ########################################
  lib.loc=paste(path, 'packages', sep='')
  library(zoo, lib.loc=lib.loc)
  library(fda, lib.loc=lib.loc)
  library(grplasso, lib.loc=lib.loc)
  library(penGAM, lib.loc=lib.loc)
  library(SIS, lib.loc=lib.loc)

  library(mgcv)

  source('gen.datanew.r')

  newpath=paste('result',funind,sep='')
  if(!file.exists(newpath))
    dir.create(newpath)

  s0=gen.data(funind,n,p)$s
  truemodel<-1:s0

  sizelist=matrix(0,r1,3)
  outputfilename=paste('results/result', funind,'/',funind,'modelsize.txt',sep='')
  for(repind in r0:r1){
    set.seed(repind)
    cat('Random seed=', repind, '...\n')
    data=gen.data(funind,n,p)
    sizelist[repind,]=c(getSISSize(data,truemodel=truemodel),getPenGamSize(data,truemodel=truemodel),getLmSISSize(data,truemodel=truemodel))
    cat(repind,sizelist[repind,],'\n',sep=' ',file=outputfilename, append=T)
  }

  filename=paste('result', funind,'/',funind,'_r0=',r0,'_r1=',r1,'modelsize.RData',sep='')

  save(truemodel,sizelist,file=filename)
}
#######################################################################################################
#######################################################################################################
cv.penGAM<- function(data, testdata=NULL, knots=NULL, folds=NULL, kfold=NULL, lambda.pen.list=NULL, model=LinReg(), control = grpl.control(trace=0),
                     eps0=1e-6 ,cv.trace=FALSE, detailed=FALSE){
  t0=proc.time()[1]
  x=data$x
  y=data$y
  x=as.matrix(x)
  n=nrow(x)

  if(is.null(folds)) {
    temp= sample(1:n, n, replace = FALSE)
    if(is.null(kfold)) kfold=5
    for(i in 1:kfold){
      folds[[i]]=setdiff(1:n, temp[seq(i, n, kfold)])
    }
  }
  kfold=length(folds)
  if(is.null(knots)) knots=ceiling(n^0.2)

  if(is.null(lambda.pen.list)){
    lambda.pen.list=seq(1,0.02,-0.02)
  }
  error <- rep(0, length(lambda.pen.list))
  if(cv.trace) cat('Beginning Cross Validation.....\n')

  for(i in 1:kfold){
    if(cv.trace) cat('Cross Validation...', 'fold ', i,'...\n')
    train <- folds[[i]]
    test <- setdiff(1:n, folds[[i]])
    fit <- penGAM(as.matrix(x[train,]), y[train], lambda.pen=lambda.pen.list, lambda.curv=0,
                  knots=knots, model=LinReg(), control = grpl.control(trace=0))
    fit.pred <- predict(fit, as.matrix(x[test,]))
    fit.mat<-t(fit.pred[,1,])
    error <- error+apply((fit.mat-y[test])^2,2,mean)
  }

  if(cv.trace) cat('Ending Cross Validation.....\n')
  best.lambda.pen.ind <- (1:length(lambda.pen.list))[which.min(error)]

  fit <- penGAM(x, y, lambda.pen=lambda.pen.list[best.lambda.pen.ind], lambda.curv=0,
                knots=knots, model=LinReg(), control = grpl.control(trace=0))

  cv.error <- mean((predict(fit,x)-y)^2)

  coef.mat <- matrix(fit$coef[1,1,][-1],nrow=knots+2,ncol=ncol(x))

  coef.norm <- apply(coef.mat^2, 2, sum)

  non.zero.ind <- which(coef.norm>eps0)

  if(!is.null(testdata)){
    testx=as.matrix(testdata$x)
    testy=testdata$y
    pred.error<-mean((predict(fit,testx)-testy)^2)
  } else pred.error=NULL

  ptime = proc.time()[1]-t0
  if(detailed){
    return (list=list(fit=fit, best.lambda.pen.ind=best.lambda.pen.ind, best.lambda=lambda.pen.list[best.lambda.pen.ind],
                      penGAMind=non.zero.ind, cv.error=cv.error, pred.error=pred.error, penGAMfit=fit, ptime = ptime))
  }
  else
  {
    return (list=list(fit=fit, penGAMind=non.zero.ind, cv.error=cv.error, pred.error=pred.error, ptime = ptime))
  }

}
########################################################################################
getSISSize <- function(data, truemodel,  knots=NULL){
  x = data$x
  y = data$y
  n = nrow(x)
  p = ncol(x)

  if(is.null(knots)) knots=ceiling(n^0.2)
  df0 <- knots+1

  xbs=matrix(0,n,df0*p)

  for(i in 1:p)
    xbs[,(i-1)*(df0)+(1:df0)]=ns(x[,i],df=df0)

  tempresi <- rep(0,p)

  curloop=1
  for(i in 1:p)
  {

    tempfit <-lm.fit (x=cbind(1,xbs[,(i-1)*df0+1:df0]),y=y)
    tempresi[i] <- sum(tempfit$residuals^2)
  }

  used.list<- tempresi

  used.sort <- sort(used.list, method= "sh", index=TRUE, decreasing=FALSE)
  amsis.ind <- used.sort$ix

  for(i in 1:p)
  {
    if(length(setdiff(truemodel,amsis.ind[1:i]))==0) {
      amsis.size=i
      break
    }
  }

  return(amsis.size)

}
#######################################################################################
########################################################################################
getPenGamSize <- function(data,  truemodel, lambda.pen.list=NULL, knots=NULL, eps0=1e-6){
  x = data$x
  y = data$y
  n = nrow(x)
  p = ncol(x)
  if(is.null(knots)) knots=ceiling(n^0.2)
  if(is.null(lambda.pen.list)){
    lambda.max=0.99
    lambda.pen.list=lambda.max*(2^seq(0,-10,-0.1))
  }
  lam.len=length(lambda.pen.list)

  fit <- penGAM(x, y, lambda.pen=lambda.pen.list, lambda.curv=0,
                knots=knots, model=LinReg(), control = grpl.control(trace=0))

  coef.mat <- array(fit$coef[,1,-1],c(lam.len,knots+2,p))

  coef.norm <- apply(coef.mat^2, c(1,3), sum)

  nonzeros = coef.norm[,truemodel]>eps0;
  lambdas = apply(nonzeros, 1, all);
  ##str(fit.a);

  pickone = max(which(lambdas==F))+1;

  if (pickone==lam.len+1){
    mlasso <- p;
  }
  if (pickone<lam.len+1){
    mlasso <- sum(coef.norm[pickone,]>eps0);
  }
  return(mlasso)

}

########################################################################################
getLmSISSize <- function(data, truemodel){
  x = data$x
  y = data$y
  n = nrow(x)
  p = ncol(x)

  lmsis.corr <- NULL
  for(i in 1:p)
  {
    lmsis.corr[i] <- -abs(cor(x[,i],y))
  }
  lmsis.sort <- sort(lmsis.corr, method= "sh", index=TRUE, decreasing=FALSE)
  lmsis.ind <- lmsis.sort$ix

  for(i in 1:p)
  {
    if(length(setdiff(truemodel,lmsis.ind[1:i]))==0) {
      lmsis.size=i
      break
    }
  }
  return(lmsis.size)

}
########################################################################################
getAmSISSize <- function(data, truemodel, rank.method='corr'){
  x = data$x
  y = data$y
  n = nrow(x)
  p = ncol(x)
  q <- ceiling(n^0.2)
  amsis.corr <- NULL
  amsis.resi <- NULL
  amsis.norm <- NULL
  for(i in 1:p)
  {
    #if(i%%(round(p/10))==0) cat('First Step:', round(i*100/p), 'percent complete\n')
    amsis.fit <-gam (y~s(x[,i],k=q,fx=TRUE, bs="cr"))
    amsis.corr[i] <- mean(fitted(amsis.fit)*y)
    amsis.resi[i] <- amsis.fit$deviance
    amsis.norm[i] <- sum(fitted(amsis.fit)^2)
  }
  amsis.list<-switch(rank.method, corr=-amsis.corr, resi=amsis.resi, norm=-amsis.norm)
  amsis.sort <- sort(amsis.list, method= "sh", index=TRUE, decreasing=FALSE)
  amsis.ind <- amsis.sort$ix
  lmsis.corr <- NULL
  for(i in 1:p)
  {
    lmsis.corr[i] <- -abs(cor(x[,i],y))
  }
  lmsis.sort <- sort(lmsis.corr, method= "sh", index=TRUE, decreasing=FALSE)
  lmsis.ind <- lmsis.sort$ix

  for(i in 1:p)
  {
    if(length(setdiff(truemodel,amsis.ind[1:i]))==0) {
      amsis.size=i
      break
    }
  }
  for(i in 1:p)
  {
    if(length(setdiff(truemodel,lmsis.ind[1:i]))==0) {
      lmsis.size=i
      break
    }
  }
  return(size=list(amsis.size=amsis.size,lmsis.size=lmsis.size))

}
####################

####################################################
#######################################################################################
##################################################
"gen"<-function(n,p,funind,t=0){
  if(funind==4){
    w=matrix(runif(n*p),n,p)
    u=runif(n)
    v=runif(n)
  } else {
    w=truncnorm.gen(n,p)
    u=as.vector(truncnorm.gen(n,1))
    v=as.vector(truncnorm.gen(n,1))
  }
  x=matrix(0,n,p)
  x[,1:4]=(w[,1:4]+t*u)/(1+t)
  x[,5:p]=(w[,5:p]+t*v)/(1+t)
  epsi=rnorm(n)
  s=3
  y=switch(funind, -3+3*x[,1]+4*x[,2]-8*x[,3]+5*x[,4]+epsi, -7+8*x[,1]-3*x[,2]+10*x[,3]^3-6*x[,4]*(x[,4]-1)+epsi , -5+8*x[,1]^3+10*x[,2]*(1-x[,2])-10*x[,3]^5-8*x[,4]^2+epsi, -4+4*x[,1]+cos(2*pi*x[,2])-8*x[,3]^3+sqrt(x[,4]*(1-x[,4]))*sin(2*pi*(1+2^((9-4*s)/5))/(x[,4]+2^((9-4*s)/5)))+epsi)
  data=list(x=x,y=y)
}

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

"truncnorm.gen"<-function(n,p){
  norm.trunc<-rnorm(n*p)
  ind= abs(norm.trunc)>2
  test=sum(ind)
  count=0
  while(test>0){
    tmp=rnorm(test)
    test=sum(abs(tmp)>2)
    norm.trunc[ind]= tmp
    ind=abs(norm.trunc)>2
  }
  abs(matrix(norm.trunc,n,p))/2
}


library(rstan)
## Load data
load("inst/extdata/Spence_turtle_data.Rdata")
# Herring

h_qua<-c()
h_age<-c()
h_len<-c()
for (i in 1:nrow(her_on))
{
	h_qua<-c(h_qua,rep(her_on$Quarter[i],her_on$CANoAtLngt[i]))
	h_age<-c(h_age,rep(her_on$Age[i],her_on$CANoAtLngt[i]))
	h_len<-c(h_len,rep(her_on$LngtClass[i],her_on$CANoAtLngt[i]))
}

h_qs<-(h_qua==4)*0.75

temp<-which(h_qua==1)

#### Quarter 1 only

h1_data <- list(t= h_age[temp], l= h_len[temp], N=length(temp))
fit1 <- stan(file = "vb.stan", data = h1_data, iter = 2000, chains = 1)

h1_out<-extract(fit1)

#### Quarter 4 only

h3_data <- list(t= h_age[-temp], l= h_len[-temp], N=length(h_len[-temp]))
fit3 <- stan(file = "vb.stan", data = h3_data, iter = 2000, chains = 1)

h3_out<-extract(fit3)

#### model i

h_complete_dat<-list(t= h_age, l= h_len, N=length(h_age),q= h_qs,mu_a=0.8576*2*pi-pi,sigma_a=0.40493)
fit_c <- stan(file = "vb.stan", data = h_complete_dat, iter = 2000, chains = 1,control=list(adapt_delta=0.85,max_treedepth=10))

h_comp_out<-extract(fit_c)

#### model ii

h_complete_dat1<-list(t= h_age+h_qs, l= h_len, N=length(h_age),q= h_qs,mu_a=0.8576*2*pi-pi,sigma_a=0.40493)
fit_c <- stan(file = "vb1.stan", data = h_complete_dat1, iter = 2000, chains = 1,control=list(adapt_delta=0.85,max_treedepth=10))

h_comp_out1<-extract(fit_c)

#### model iii

h_complete_dat2<-list(t= h_age, l= h_len, N=length(h_age),q= h_qs*(1/0.75),mu_a=0.8576*2*pi-pi,sigma_a=0.40493)

h1_fitsvm <- stan(file = "age_adjusted.stan", data = h_complete_dat2, iter = 2000, chains = 1,control=list(adapt_delta=0.9,max_treedepth=10))

h_fitv<-extract(h1_fitsvm)

#### model iv
temp<-which(h_age==0)
h_a_t<-c(h_age[-temp],h_age[temp])
h_a_l<-c(h_len[-temp],h_len[temp])
h_q_t<-c(h_qs[-temp],h_qs[temp])

h_complete_dat_test<-list(t= h_a_t, l= h_a_l, N1=length(h_a_t)-length(temp),N4=length(temp),q= h_q_t,mu_a=0.8576*2*pi-pi,sigma_a=0.40493)
fitvm <- stan(file = "von_moses1.stan", data = h_complete_dat_test, iter = 2000, chains = 1,control=list(adapt_delta=0.97,max_treedepth=10))

hiv_fitvm<-extract(fitvm)

#### model v

h1_complete_dat_test<-h_complete_dat_test
h1_complete_dat_test$q<-h1_complete_dat_test$q*(1/0.75)

h1_fitsvm <- stan(file = "seasonal_vm1.stan", data = h1_complete_dat_test, iter = 2000, chains = 1,control=list(adapt_delta=0.97,max_treedepth=10))

h1_fitsvm.c<-extract(h1_fitsvm)

######### Cod

## cod
c_qua<-c()
c_age<-c()
c_len<-c()
for (i in 1:nrow(cod_on))
{
	c_qua<-c(c_qua,rep(cod_on$Quarter[i],cod_on$CANoAtLngt[i]))
	c_age<-c(c_age,rep(cod_on$Age[i],cod_on$CANoAtLngt[i]))
	c_len<-c(c_len,rep(cod_on$LngtClass[i],cod_on$CANoAtLngt[i]))
}

c_qs<-(c_qua==4)*0.75

### Quarter 1 only
temp<-which(c_qua==1)

q1_data <- list(t= c_age[temp], l= c_len[temp], N=length(temp))
fit1 <- stan(file = "vb.stan", data = q1_data, iter = 2000, chains = 1,control=list(adapt_delta=0.85,max_treedepth=10))
q1_out<-extract(fit1)

#### Quarter 2 only
q3_data <- list(t= c_age[-temp], l= c_len[-temp], N=length(c_len[-temp]))
fit3 <- stan(file = "vb.stan", data = q3_data, iter = 2000, chains = 1)

q3_out<-extract(fit3)

#### Model i

complete_dat<-list(t= c_age, l= c_len, N=length(c_age),q= c_qs,mu_a=0.3123*2*pi-pi,sigma_a=5.4732)
fit_c <- stan(file = "vb.stan", data = complete_dat, iter = 2000, chains = 1,control=list(adapt_delta=0.9,max_treedepth=10))

comp_out<-extract(fit_c)

#### Model ii

complete_dat1<-list(t= c_age+ c_qs, l= c_len, N=length(c_age),q= c_qs,mu_a=0.3123*2*pi-pi,sigma_a=5.4732)

fit_c <- stan(file = "vb1.stan", data = complete_dat1, iter = 2000, chains = 1,control=list(adapt_delta=0.9,max_treedepth=10))

comp_out1<-extract(fit_c)

#### Model iii
complete_dat2<-list(t= c_age, l= c_len, N=length(c_age),q= c_qs*(1/0.75),mu_a=0.3123*2*pi-pi,sigma_a=5.4732)

c1_fitsvm <- stan(file = "age_adjusted.stan", data = complete_dat2, iter = 2000, chains = 1,control=list(adapt_delta=0.9,max_treedepth=10))

cv_fit<-extract(c1_fitsvm)

#### Model iv
temp<-which(c_age==0)
c_a_t<-c(c_age[-temp],c_age[temp])
c_a_l<-c(c_len[-temp],c_len[temp])
c_q_t<-c(c_qs[-temp],c_qs[temp])

complete_dat_test<-list(t= c_a_t, l= c_a_l, N1=length(c_a_t)-length(temp),N4=length(temp),q= c_q_t,mu_a=0.3123*2*pi-pi,sigma_a=5.4732)

fitvm <- stan(file = "von_moses1.stan", data = complete_dat_test, iter = 2000, chains = 1,control=list(adapt_delta=0.95,max_treedepth=10))

cod_vm1<-extract(fitvm)

#### Model v

complete_dat_test1<-complete_dat_test
complete_dat_test1$q<-complete_dat_test$q*(1/0.75)

c1_fitsvm <- stan(file = "seasonal_vm1.stan", data = complete_dat_test1, iter = 2000, chains = 1,control=list(adapt_delta=0.95,max_treedepth=10))

c1_fitsvm.c<-extract(c1_fitsvm)

#############
#############
#############
## YPR analysis

single_species_model<-function(param,a,b,age.range,sel.at.age,Mort)
{
	require(fishmethods)
	k<-param[1]
	Linf<-param[2]
	t0<-param[3]
	sigmasq<-param[4]
	uage<-c(age.range[-1],max(age.range)+1)
	lts<-Linf*exp(sigmasq/2)*(1-1/k*exp(k*t0)*(exp(-k* age.range)-exp(-k* uage)))
	weighs01 <- a*(lts)^b
	return( ypr(age = age.range, wgt = weighs01, partial = sel.at.age, M = Mort,
              plus = FALSE, maxF = 4,incrF = 0.01,graph=F)$Reference_Points[, 2])
}

age.range <- 0:19

#### Run in parallel

library(parallel)
cl <- makeCluster(getOption("cl.cores", 8))
clusterExport(cl, as.list(ls()))

#### Herring

h.a <- 0.00646
h.b <- 3.05
h.sel.at.age <- c(rep(0, 2), rep(1, 18))
h.Mort<- c(0.767,0.385,0.356,0.339,0.319,0.314,rep(0.307,14)) ## From page 297 of ICES Hawg report 2016

hm_i<-cbind(h_comp_out$k,h_comp_out$l_inf/1000,h_comp_out$t0)
hm_ii<-cbind(h_comp_out1$k,h_comp_out1$l_inf/1000,h_comp_out1$t0)
hm_iii<-cbind(h_fitv$k,h_fitv$l_inf/1000,h_fitv$t0)
hm_iv<-cbind(hiv_fitvm$k,hiv_fitvm$l_inf/1000,hiv_fitvm$t0)
hm_v<-cbind(h1_fitsvm.h$k,h1_fitsvm.h$l_inf/1000,h1_fitsvm.h$t0)

hsm_i<-matrix(parRapply(cl,hm_i, single_species_model,a=h.a,b=h.b,sel.at.age=h.sel.at.age,Mort=h.Mort,age.range=age.range),ncol=2)
hsm_ii<-matrix(parRapply(cl,hm_ii, single_species_model,a=h.a,b=h.b,sel.at.age=h.sel.at.age,Mort=h.Mort,age.range=age.range),ncol=2)
hsm_iii<-matrix(parRapply(cl,hm_iii, single_species_model,a=h.a,b=h.b,sel.at.age=h.sel.at.age,Mort=h.Mort,age.range=age.range),ncol=2)
hsm_iv<-matrix(parRapply(cl,hm_iv, single_species_model,a=h.a,b=h.b,sel.at.age=h.sel.at.age,Mort=h.Mort,age.range=age.range),ncol=2)
hsm_v<-matrix(parRapply(cl,hm_v, single_species_model,a=h.a,b=h.b,sel.at.age=h.sel.at.age,Mort=h.Mort,age.range=age.range),ncol=2)

#### Cod

c.a<-0.00759
c.b<-3.06
c.sel.at.age <- c(rep(0, 2), rep(1, 18))
c.Mort<-c(0.537,0.386,0.306,0.262,0.237,0.223,rep(0.211,14)) #From ICES WGCSE report 2016

m_i<-cbind(comp_out$k,comp_out$l_inf/1000,comp_out$t0)
m_ii<-cbind(comp_out1$k,comp_out1$l_inf/1000,comp_out1$t0)
m_iii<-cbind(cv_fit$k, cv_fit$l_inf/1000,cv_fit$t0)
m_iv<-cbind(cod_vm1$k,cod_vm1$l_inf/1000,cod_vm1$t0)
m_v<-cbind(c1_fitsvm.c$k,c1_fitsvm.c$l_inf/1000,c1_fitsvm.c$t0)

sm_i<-matrix(parRapply(cl,m_i, single_species_model,a=c.a,b=c.b,sel.at.age=c.sel.at.age,Mort=c.Mort,age.range=age.range),ncol=2)
sm_ii<-matrix(parRapply(cl,m_ii, single_species_model,a=c.a,b=c.b,sel.at.age=c.sel.at.age,Mort=c.Mort,age.range=age.range),ncol=2)
sm_iii<-matrix(parRapply(cl,m_iii, single_species_model,a=c.a,b=c.b,sel.at.age=c.sel.at.age,Mort=c.Mort,age.range=age.range),ncol=2)
sm_iv<-matrix(parRapply(cl,m_iv, single_species_model,a=c.a,b=c.b,sel.at.age=c.sel.at.age,Mort=c.Mort,age.range=age.range),ncol=2)
sm_v<-matrix(parRapply(cl,m_v, single_species_model,a=c.a,b=c.b,sel.at.age=c.sel.at.age,Mort=c.Mort,age.range=age.range),ncol=2)


# Modelo de Red neuronal con Variables continuas
library(AMORE)
source("PCAfunction.r")

#Lectura de Datos
data <- read.table("muestra_real_2.txt",header=TRUE)
data
#Se remueven las variables categoricas
drops <- c("cant_mat","opsu","gestion_plantel","tipo_plantel","nivel_socioeco","nivel_estudios_padres","genero","escuela")
y <- data[ , !(names(data) %in% drops)]
y

indice<-sample(1:nrow(y),85)
#indice<-c(77,67,66,37,27,59,75,120,65,90,83,24,114,116,100,29,5,18,19,96,106,121,11,36,44,80,6,4,105,63,73,51,78,86,48,58,32,98,61,23,41,71,49,3,72,56,54,47,79,22,101,115,85,15,107,40,119,46,93,84,69,112,26,30,118,95,13,117,21,111,82,9487,60,1,7,12,45,25,9,91,81,8,62,16,20,88)
ytrain<-y[indice,1:5]
ytest<-y[-indice,]

#Calculo de Grupos para las salidas
conglomeradoT<-kmeans(y,3)$cluster
conglomerado<-conglomeradoT[indice]
conglomeradoP<-conglomeradoT[-indice]
medias<-c(mean(y[conglomerado==1,6]),mean(y[conglomerado==2,6]),mean(y[conglomerado==3,6]))
names(medias)<-c(1,2,3)
medias
claseC<-as.numeric(names(sort(medias)))
clase<-matrix(NA, ncol=2, nrow=nrow(ytrain))

#creacion del primer grupo bajo
clase[conglomerado==claseC[1],]<-matrix(rep(t(c(0,0)), sum(conglomerado==claseC[1])), byrow=TRUE, ncol=2 )
#Grupo medio
clase[conglomerado==claseC[2],]<-matrix(rep(t(c(0,1)), sum(conglomerado==claseC[2])), byrow=TRUE, ncol=2 )
#Grupo alto
clase[conglomerado==claseC[3],]<-matrix(rep(t(c(1,1)), sum(conglomerado==claseC[3])), byrow=TRUE, ncol=2 )

claseT<-matrix(NA, ncol=2, nrow=nrow(ytest))
claseT[conglomeradoP==claseC[1],]<-matrix(rep(t(c(0,0)), sum(conglomeradoP==claseC[1])), byrow=TRUE, ncol=2 )
claseT[conglomeradoP==claseC[2],]<-matrix(rep(t(c(0,1)), sum(conglomeradoP==claseC[2])), byrow=TRUE, ncol=2 )
claseT[conglomeradoP==claseC[3],]<-matrix(rep(t(c(1,1)), sum(conglomeradoP==claseC[3])), byrow=TRUE, ncol=2 )

######################################
# Creamos el objeto red neuronal feedforward
############################################################
# PRUEBA CON ENTRADAS MAT_1, MAT_2, MAT_3, MAT_4, PROMEDIO #
############################################################
## Creamos dos conjuntos de datos artificiales: ''P'' es el conjunto
#de datos de entrada y ''target'' el de salida. con el 80% de los datos
######################
target-clase
target
##
## inicialmente con Comp1 Comp2 comp3 con el 88% de los datos
########################
P<-matrix(c(ytrain[,1],ytrain[,2],ytrain[,3],ytrain[,4],ytrain[,5]),ncol=5,byrow=TRUE)
P

## Creamos el objeto red neuronal feedforward
############################################
net1 <- newff(n.neurons=c(5,10,2), learning.rate.global=1e-2, momentum.global=0.5,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
#############################
##Se entrena la red
#######################
result1 <- train(net1,P , target, error.criterium="LMS", report=TRUE, show.step=10000, n.shows=5 )
######################
# se grafica la red entrenada con lso datos de entrenamiento
####
s <- sim(result1$net, P)
cbind(round(s),(apply(clase,1,sum)+1))
round(s)
###################
# Validacion con el 20% restante
##############
s <- sim(result1$net, ytest)
round(s)
salT<-cbind(round(s),dist(rbind(c(1,1),s))[1:12],dist(rbind(c(0,1),s))[1:12],dist(rbind(c(0,0),s))[1:12],

cbind((dist(rbind(c(1,1),s))[1:12])/rowSums(cbind(dist(rbind(c(1,1),s))[1:12],dist(rbind(c(0,1),s))[1:12],dist(rbind(c(0,0),s))[1:12]))
,(dist(rbind(c(0,1),s))[1:12])/rowSums(cbind(dist(rbind(c(1,1),s))[1:12],dist(rbind(c(0,1),s))[1:12],dist(rbind(c(0,0),s))[1:12]))
,(dist(rbind(c(0,0),s))[1:12])/rowSums(cbind(dist(rbind(c(1,1),s))[1:12],dist(rbind(c(0,1),s))[1:12],dist(rbind(c(0,0),s))[1:12]))))


rm(list = setdiff(ls(),c('DATADIR','RESDIR','MAIN_DIR')))

NE = 44514
t0 = strptime("2001-01-01 0:0:0", "%Y-%m-%d %H:%M:%S");
tcut.train = as.numeric(strptime("2010-04-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);
tcut.lead =  as.numeric(strptime("2010-09-01 0:0:0", "%Y-%m-%d %H:%M:%S") - t0);

# Load Original Feature File
TD = read.csv(paste(RESDIR,'OrigSet_xinp1p2_yinp3.csv',sep=''),header=T)
LD = read.csv(paste(RESDIR,'OrigSet_xinp1p2p3.csv',sep=''),header=T)
et = scan(paste(RESDIR,'edit_times.csv',sep=''),what="character")
mea = read.csv(paste(RESDIR,'editor_monthly_edits.csv',sep=''),header=T)
meu = read.csv(paste(RESDIR,'editor_monthly_edits_unique_days.csv',sep=''),header=T)
stopifnot(length(et) == dim(LD)[1], all(dim(mea)==c(NE,117)), all(dim(meu)==c(NE,117)))

newfeatures = c('intercept','ln_edit','edits_per_day','pc_edit_ns0','pc_edit_ns1','pc_edit_ns2','pc_edit_ns3','pc_edit_ns4','pc_edit_ns5','ln_reverts','reverts_per_edit','pc_reverts_ns0','pc_reverts_ns1','pc_reverts_ns2','pc_reverts_ns3','pc_reverts_ns4','pc_reverts_ns5','edits_per_article','ln_edit_l5','edits_per_day_l5','edits_per_article_l5','pc_edit_ns0_l5','pc_edit_ns1_l5','pc_edit_ns2_l5','pc_edit_ns3_l5','pc_edit_ns4_l5','pc_edit_ns5_l5','pc_reverts_ns0_l5','pc_reverts_ns1_l5','pc_reverts_ns2_l5','pc_reverts_ns3_l5','pc_reverts_ns4_l5','pc_reverts_ns5_l5','reverts_per_edit_l5','ln_edit_pp','ln_edit_ppp','fsdt_inv','lsdt_inv','regdt_inv','mean_time_between_edits','mean_time_between_edits_l5',"edits_week_last","edits_week_minus1","edits_week_minus2","edits_week_minus3","edit_days_week_last","edit_days_week_minus1","edit_days_week_minus2","edit_days_week_minus3","edit_days_month_last","edit_days_month_minus1","edit_days_month_minus2","edit_days_month_minus3","edit_days_ppp","ln_edit_pppp","ln_edit_ppppp","edit_days_pppp","edit_days_ppppp","ln_edit_1314","ln_edit_1516","ln_edit_1718","ln_edit_1920","ln_edit_2122","ln_edit_2324","edit_days_13","edit_days_14","edit_days_15")

lead = matrix(0,length(et),length(newfeatures))
colnames(lead) = newfeatures

train = lead

itrain = which(LD$user_id %in% TD$user_id)

stopifnot(dim(LD)[1] == NE)
TD$registration_date[is.na(TD$registration_date)] = -36893
LD$registration_date[is.na(LD$registration_date)] = -(36893+150)

edit_p = rowSums(mea[,113:117]); edit_days_p = rowSums(meu[,113:117])
edit_pp = rowSums(mea[,108:112]); edit_days_pp = rowSums(meu[,108:112])
edit_ppp = rowSums(mea[,103:107])
edit_pppp = rowSums(mea[,98:102])

o1 = 0
o2 = o1+41
o3 = o2+12

train[itrain,'intercept'] = 1
train[itrain,'fsdt_inv'] = tcut.train - floor(TD$FSDT)
train[itrain,'lsdt_inv'] = tcut.train - floor(TD$LSDT)
train[itrain,'regdt_inv'] = tcut.train - TD$registration_date
train[itrain,'ln_edit'] = log(TD$sum_edits+1)
train[itrain,'ln_reverts'] = log(TD$sum_reverts+1)
train[itrain,'edits_per_day'] = TD$sum_edits/TD$sum_edit_days
train[itrain,'reverts_per_edit'] = TD$sum_reverts/TD$sum_edits
train[itrain,'edits_per_article'] = TD$sum_edits/TD$sum_articles
train[itrain,'mean_time_between_edits'] = (train[itrain,'regdt_inv']/TD$sum_edits)
train[itrain,'mean_time_between_edits_l5'] = 150/(edit_pp[itrain]+1)
train[itrain,'ln_edit_l5'] = log(edit_pp[itrain]+1)
train[itrain,'edits_per_day_l5'] = (edit_pp[itrain]+1)/(edit_days_pp[itrain]+1)
train[itrain,'edits_per_article_l5'] = (edit_pp[itrain]+1)/(TD$sum_new_articles_l5+1)
train[itrain,'reverts_per_edit_l5'] = (TD$sum_reverts_l5+1)/(edit_pp[itrain]+1)

# Namesapce based features
train[itrain,'pc_edit_ns0'] = TD$sum_edit_ns0/TD$sum_edits
train[itrain,'pc_reverts_ns0'] = (TD$sum_reverts_ns0+1)/(TD$sum_reverts+1)
train[itrain,'pc_edit_ns0_l5'] = (TD$sum_edit_ns0_l5+1)/(edit_pp[itrain]+1)
train[itrain,'pc_reverts_ns0_l5'] = (TD$sum_reverts_ns0_l5+1)/(TD$sum_reverts_l5+1)

train[itrain,'pc_edit_ns1'] = TD$sum_edit_ns1/TD$sum_edits
train[itrain,'pc_reverts_ns1'] = (TD$sum_reverts_ns1+1)/(TD$sum_reverts+1)
train[itrain,'pc_edit_ns1_l5'] = (TD$sum_edit_ns1_l5+1)/(edit_pp[itrain]+1)
train[itrain,'pc_reverts_ns1_l5'] = (TD$sum_reverts_ns1_l5+1)/(TD$sum_reverts_l5+1)

train[itrain,'pc_edit_ns2'] = TD$sum_edit_ns2/TD$sum_edits
train[itrain,'pc_reverts_ns2'] = (TD$sum_reverts_ns2+1)/(TD$sum_reverts+1)
train[itrain,'pc_edit_ns2_l5'] = (TD$sum_edit_ns2_l5+1)/(edit_pp[itrain]+1)
train[itrain,'pc_reverts_ns2_l5'] = (TD$sum_reverts_ns2_l5+1)/(TD$sum_reverts_l5+1)

train[itrain,'pc_edit_ns3'] = TD$sum_edit_ns3/TD$sum_edits
train[itrain,'pc_reverts_ns3'] = (TD$sum_reverts_ns3+1)/(TD$sum_reverts+1)
train[itrain,'pc_edit_ns3_l5'] = (TD$sum_edit_ns3_l5+1)/(edit_pp[itrain]+1)
train[itrain,'pc_reverts_ns3_l5'] = (TD$sum_reverts_ns3_l5+1)/(TD$sum_reverts_l5+1)

train[itrain,'pc_edit_ns4'] = TD$sum_edit_ns4/TD$sum_edits
train[itrain,'pc_reverts_ns4'] = (TD$sum_reverts_ns4+1)/(TD$sum_reverts+1)
train[itrain,'pc_edit_ns4_l5'] = (TD$sum_edit_ns4_l5+1)/(edit_pp[itrain]+1)
train[itrain,'pc_reverts_ns4_l5'] = (TD$sum_reverts_ns4_l5+1)/(TD$sum_reverts_l5+1)

train[itrain,'pc_edit_ns5'] = TD$sum_edit_ns5/TD$sum_edits
train[itrain,'pc_reverts_ns5'] = (TD$sum_reverts_ns5+1)/(TD$sum_reverts+1)
train[itrain,'pc_edit_ns5_l5'] = (TD$sum_edit_ns5_l5+1)/(edit_pp[itrain]+1)
train[itrain,'pc_reverts_ns5_l5'] = (TD$sum_reverts_ns5_l5+1)/(TD$sum_reverts_l5+1)

# --------------- Leaderboard --------------------------
lead[,'intercept'] = 1
lead[,'fsdt_inv'] = tcut.lead - floor(LD$FSDT)
lead[,'lsdt_inv'] = tcut.lead - floor(LD$LSDT)
lead[,'regdt_inv'] = tcut.lead - LD$registration_date
lead[,'ln_edit'] = log(LD$sum_edits+1)
lead[,'ln_reverts'] = log(LD$sum_reverts+1)
lead[,'edits_per_day'] = LD$sum_edits/LD$sum_edit_days
lead[,'reverts_per_edit'] = LD$sum_reverts/LD$sum_edits
lead[,'edits_per_article'] = LD$sum_edits/LD$sum_articles
lead[,'mean_time_between_edits'] = (lead[,'regdt_inv']/LD$sum_edits)
lead[,'mean_time_between_edits_l5'] = 150/(edit_p+1)
lead[,'ln_edit_l5'] = log(edit_p+1)
lead[,'edits_per_day_l5'] = (edit_p+1)/(edit_days_p+1)
lead[,'edits_per_article_l5'] = (edit_p+1)/(LD$sum_new_articles_l5+1)
lead[,'reverts_per_edit_l5'] = (LD$sum_reverts_l5+1)/(edit_p+1)

# Namesapce based features
lead[,'pc_edit_ns0'] = LD$sum_edit_ns0/LD$sum_edits
lead[,'pc_reverts_ns0'] = (LD$sum_reverts_ns0+1)/(LD$sum_reverts+1)
lead[,'pc_edit_ns0_l5'] = (LD$sum_edit_ns0_l5+1)/(edit_p+1)
lead[,'pc_reverts_ns0_l5'] = (LD$sum_reverts_ns0_l5+1)/(LD$sum_reverts_l5+1)

lead[,'pc_edit_ns1'] = LD$sum_edit_ns1/LD$sum_edits
lead[,'pc_reverts_ns1'] = (LD$sum_reverts_ns1+1)/(LD$sum_reverts+1)
lead[,'pc_edit_ns1_l5'] = (LD$sum_edit_ns1_l5+1)/(edit_p+1)
lead[,'pc_reverts_ns1_l5'] = (LD$sum_reverts_ns1_l5+1)/(LD$sum_reverts_l5+1)

lead[,'pc_edit_ns2'] = LD$sum_edit_ns2/LD$sum_edits
lead[,'pc_reverts_ns2'] = (LD$sum_reverts_ns2+1)/(LD$sum_reverts+1)
lead[,'pc_edit_ns2_l5'] = (LD$sum_edit_ns2_l5+1)/(edit_p+1)
lead[,'pc_reverts_ns2_l5'] = (LD$sum_reverts_ns2_l5+1)/(LD$sum_reverts_l5+1)

lead[,'pc_edit_ns3'] = LD$sum_edit_ns3/LD$sum_edits
lead[,'pc_reverts_ns3'] = (LD$sum_reverts_ns3+1)/(LD$sum_reverts+1)
lead[,'pc_edit_ns3_l5'] = (LD$sum_edit_ns3_l5+1)/(edit_p+1)
lead[,'pc_reverts_ns3_l5'] = (LD$sum_reverts_ns3_l5+1)/(LD$sum_reverts_l5+1)

lead[,'pc_edit_ns4'] = LD$sum_edit_ns4/LD$sum_edits
lead[,'pc_reverts_ns4'] = (LD$sum_reverts_ns4+1)/(LD$sum_reverts+1)
lead[,'pc_edit_ns4_l5'] = (LD$sum_edit_ns4_l5+1)/(edit_p+1)
lead[,'pc_reverts_ns4_l5'] = (LD$sum_reverts_ns4_l5+1)/(LD$sum_reverts_l5+1)

lead[,'pc_edit_ns5'] = LD$sum_edit_ns5/LD$sum_edits
lead[,'pc_reverts_ns5'] = (LD$sum_reverts_ns5+1)/(LD$sum_reverts+1)
lead[,'pc_edit_ns5_l5'] = (LD$sum_edit_ns5_l5+1)/(edit_p+1)
lead[,'pc_reverts_ns5_l5'] = (LD$sum_reverts_ns5_l5+1)/(LD$sum_reverts_l5+1)

train[,'ln_edit_pp'] = log(edit_ppp+1)
train[,'ln_edit_ppp'] = log(edit_pppp+1)

lead[,'ln_edit_pp'] = log(edit_pp+1)
lead[,'ln_edit_ppp'] = log(edit_ppp+1)

m5len = 152
for (i in 1:length(et)){
	edates = as.numeric(strsplit(et[i],',')[[1]])

	# train[i,'ln_edit_pp'] = log(length(edates[edates > (tcut.train - 2*m5len)  & edates <= (tcut.train - 1*m5len)])+1)
	# train[i,'ln_edit_ppp'] = log(length(edates[edates > (tcut.train - 3*m5len)  & edates <= (tcut.train - 2*m5len)])+1)

	# lead[i,'ln_edit_pp'] = log(length(edates[edates > (tcut.lead - 2*m5len)  & edates <= (tcut.lead - 1*m5len)])+1)
	# lead[i,'ln_edit_ppp'] = log(length(edates[edates > (tcut.lead - 3*m5len)  & edates <= (tcut.lead - 2*m5len)])+1)
	# -------------- Adding 12 features more -----------------
	for (w in 1:4){
		ew.train = edates[edates > (tcut.train - w*7)  & edates <= (tcut.train - (w-1)*7)]
		train[i,o2+w] = length(ew.train)
		train[i,o2+w+4] = length(unique(ew.train))

		ew.lead = edates[edates > (tcut.lead - w*7)  & edates <= (tcut.lead - (w-1)*7)]
		lead[i,o2+w] = length(ew.lead)
		lead[i,o2+w+4] = length(unique(ew.lead))
	}
	for (m in 1:4){
		em.train = edates[edates > (tcut.train - m*30.4)  & edates <= (tcut.train - (m-1)*30.4)]
		train[i,o2+m+8] = length(unique(em.train))

		em.lead = edates[edates > (tcut.lead - m*30.4)  & edates <= (tcut.lead - (m-1)*30.4)]
		lead[i,o2+m+8] = length(unique(em.lead))
	}

	#----------------- Adding another 14 features

	train[i,o3+2]= length(unique(edates[edates > (tcut.train - 3*m5len)  & edates <= (tcut.train - 2*m5len)]))
	lead[i,o3+1]= length(unique(edates[edates > (tcut.lead - 3*m5len)  & edates <= (tcut.lead - 2*m5len)]))
	for (m5 in 4:5){
		em.train = edates[edates > (tcut.train - m5*m5len)  & edates <= (tcut.train - (m5-1)*m5len)]
		train[i,o3+m5-2] = log(length(em.train)+1)
		train[i,o3+m5] = (length(unique(em.train)))

		em.lead = edates[edates > (tcut.lead - m5*m5len)  & edates <= (tcut.lead - (m5-1)*m5len)]
		lead[i,o3+m5-2] = log(length(em.lead)+1)
		lead[i,o3+m5] = (length(unique(em.lead)))
	}
	m2len = 61
	for (m2 in 1:6){
		em.train = edates[edates > (tcut.train - (6 + m2)*m2len)  & edates <= (tcut.train - (6 + m2-1)*m2len)]
		train[i,o3+5+m2] = log(length(em.train)+1)

		em.lead = edates[edates > (tcut.lead - (6 + m2)*m2len)  & edates <= (tcut.lead - (6 + m2-1)*m2len)]
		lead[i,o3+5+m2] = log(length(em.lead)+1)
	}
	mlen = 30.5
	for (m1 in 1:3){
		em.train = edates[edates > (tcut.train - (12+m1)*mlen)  & edates <= (tcut.train - (12+m1-1)*mlen)]
		train[i,o3+11+m1] = length(unique(em.train))

		em.lead = edates[edates > (tcut.lead - (12+m1)*mlen)  & edates <= (tcut.lead - (12+m1-1)*mlen)]
		lead[i,o3+11+m1] = length(unique(em.lead))
	}
}

newcolnames.t =  c(colnames(TD)[1],colnames(train)[1],colnames(TD)[-1],colnames(train)[-1]);
newcolnames.l =  c(colnames(LD)[1],colnames(lead)[1],colnames(LD)[-1],colnames(lead)[-1]);

TDnew =  cbind(TD[,1],train[itrain,1],TD[,-1],train[itrain,-1]);
LDnew =  cbind(LD[,1],lead[,1],LD[,-1],lead[,-1]);

colnames(TDnew) <- newcolnames.t
colnames(LDnew) <- newcolnames.l

write.csv(TDnew,file=paste(RESDIR,"Features113_XinP1P2_YinP3.csv",sep=''), row.names = F)
write.csv(LDnew,file=paste(RESDIR,"Features113_XinP1P2P3.csv",sep=''), row.names=F)


# Check that we can properly recover the true parameters
# author: Alberto Lumbreras
#########################################################
library(parallel)
library(data.table)
library(neldermead)
library(dfoptim)
library(dplyr)
library(ggplot2)
source('R/thread_generators.r')
source('R/likelihood.r')

df.errors <- data.frame(alpha=rep(NA,100*4),
                        beta=rep(NA,100*4),
                        tau=rep(NA,100*4),
                        alpha_hat=rep(NA,100*4),
                        beta_hat=rep(NA,100*4),
                        tau_hat=rep(NA,100*4),
                        N = rep(NA,100*4),
                        like = rep(NA,100*4))

# Repeat the experiment with different parameters to see error mean and variance
ncores <- detectCores() - 2
cl<-makeCluster(ncores, outfile="", port=11439)
clusterEvalQ(cl, {library(igraph); library(dplyr)})

N.list <- c(50,500,5000,50000)

# Length of simulated threads will be based on real thread lengths
load('dfposts_gameofthrones.Rda')
thread.lengths <- as.numeric(table(df.posts$thread))

# Too many short threads make it very difficult to estimate the parameters
# We therefore impose a minimum length
thread.lengths <- thread.lengths[thread.lengths>10]

row <- 1
for (j in 1:length(N.list)){
  N <- N.list[j]

  for(i in 1:100){
    cat("\n****************************************** ", i)
    cat("\n******************************************\n")

    ###############
    # generate N trees with fixed parameters
    ###############
    alpha <- runif(1)*5
    beta <- runif(1)*10
    tau <- runif(1)
    thread.size <- thread.lengths[sample(1:length(thread.lengths), 1)]

    # TODO: parallelize this as well
    trees <- replicate(N, gen.thread.Gomez2013(n=thread.size, alpha=alpha, beta=beta, tau=tau), simplify = FALSE)

    # Create one dataframe from each tree
    data.parlapply <- parLapply(cl, trees, tree.to.data)

    # join dataframes adding thread id
    for (i in 1:length(data.parlapply)){
      data.parlapply[[i]]$thread <- i
    }
    data.parlapply <- rbindlist(data.parlapply)
    df.trees <- data.frame(thread = data.parlapply$thread,
                           user = data.parlapply$user,
                           post = data.parlapply$post,
                           t = data.parlapply$t,
                           parent = data.parlapply$parent,
                           popularity = data.parlapply$popularity,
                           lag = data.parlapply$lag)

    ########################################
    # Estimation
    ########################################
    Qopt <- function(params, df.trees){
      sum(apply(df.trees, 1, function(x) likelihood.post(x, params[1], params[2], params[3])))
    }

    sol <- nmkb(c(0.5, 0.5, 0.5), Qopt,
                lower = c(0,0,0), upper = c(Inf, Inf, 1),
                control = list(maximize=TRUE),
                df.trees = df.trees)
    cat('\n', alpha, " ", beta, " ", tau)
    cat('\n', sol$par)

    # Store results
    #################
    df.errors[row,] <- c(alpha, beta, tau, sol$par[1], sol$par[2], sol$par[3], N, sol$value)
    row <- row + 1
  }
}

stopCluster(cl)
df.errors <- df.errors[complete.cases(df.errors),]
save("df.errors", "df.errors.Rda")

#########################
# Analize errors
#########################
if(FALSE){
  df.errors <- mutate(df.errors, alpha.error = alpha_hat - alpha,
                                 beta.error = beta_hat - beta,
                                 tau.error = tau_hat - tau)

  df.errors <- mutate(df.errors, alpha.error.perc = (alpha_hat - alpha)/alpha,
                      beta.error.perc = (beta_hat - beta)/beta,
                      tau.error.perc = (tau_hat - tau)/tau)

  df.errors.g <- melt(df.errors, measure.vars=c("alpha.error", "beta.error", "tau.error",
                                                "alpha.error.perc", "beta.error.perc", "tau.error.perc"))

  ggplot(filter(df.errors.g, N==50), aes(x=variable, y=value)) +
    geom_boxplot(outlier.colour="red", outlier.shape=8,outlier.size=4) +
    ylim(c(-1,1)) +
    theme_bw()
}


#' @export
#'
#' @title compVagueSd - Compute sD's of vague priors
#'
#' @description  Compute the standard deviation of a normal
#' distribution that is big enough to be considered a 'vague'
#' prior.  This is not straight forward when there are covariates, as here.
#'
#' @param Y Vector of number of carcasses found, one element per year. If
#' multiple sites are involved, elements of Y are the total (summed) number
#' of targets found per season.
#'
#' @param alpha.vec vector of the alpha parameters of the Beta distributions
#'
#' @param beta.vec vector of the beta parameters of the Beta distributions
#'
#' @param X a design matrix upon which an approximation of inflated
#' numbers of targets is regressed.  Usually, this is meant to be the
#' design matrix from the \code{eoar} function.
#'
#' @param range.multiplier a multipiler for the range of coefficient
#' estimates to make the output standard deviations sufficiently vague.
#' Increasing this number increases vagueness.
#'
#' @return List containing two components.  \code{$vagueSd} is a
#' vector, one per parameter, of standard deviations that should
#' be large enough to call vague when used in a normal prior.
#' \code{$startA} is a vector of potential starting values for
#' the coefficients in the model.
#'
#'
compVagueSd<- function(Y,alpha.vec,beta.vec,X, range.multiplier=100){

  g <- alpha.vec / (alpha.vec+beta.vec)

  if( min(Y) == 0 ){
    m.c <- 0.5
  } else {
    m.c <- 0
  }
  M <- log(Y+m.c) - log(g + min(g)*m.c)

  lm.fit <- lm( M ~ -1+X )
  if( any(is.na(lm.fit$coefficients)) ){
    warning(paste("Multicolinearity in the vague SD model. Using",
                  2*range.multiplier, "for all vague priors.",
                  "You better check sensitivity of results to priors."))
    coefSD <- rep(1, ncol(X))
    beta <- rep(1, ncol(X))
  } else {
    lm.fit <- suppressWarnings(summary(lm.fit)$coefficients)
    coefSD <- lm.fit[, "Std. Error"]
    beta <- lm.fit[, "Estimate"]
  }

  if( any(is.na(coefSD)) ){
    # in absence of coef var estimate, seems reasonable to
    # assume a CV of 100%
    ind <- is.na(coefSD)
    coefSD[ind] <- abs(beta[ind])
  }

  # Impose a minimum vague sd.
  # This fixes the case when Y is constant and g is constant, or,
  # when any dimension has zero variance.
  # This also means that 2*range.multiplier is the minimum
  # vague prior.
  CVs <- coefSD / beta
  coefSD <- ifelse(CVs < 1.0, abs(beta), coefSD)

  coef.range <- 2*coefSD * range.multiplier

  # names of coef.range must match coefficient names because
  # we use them to subset outside this routine.
  names(coef.range) <- dimnames(X)[[2]]

  list(vagueSd=coef.range, startA=lm.fit)
}


# setwd(dirname(rstudioapi::getActiveDocumentContext()$path))

#########################################################################
# Dependencies

# library(purrr)
# library(glmnet)

#########################################################################
# Tuning parameter

.Lambdahat <- function(X, t = .05, m = 500){
  n <- nrow(X)
  g <- rnorm(n * m, 0, 1)
  map(1:m, ~ (X * rnorm(n, 0, 1)) %>%
        apply(2, sum) %>%
        max) %>%
    as.numeric %>%
    quantile(1 - t)
}

.lambda <- function(X, sigma0hat, t = 0.05, c = 1.1) {  2 * c * sigma0hat * .Lambdahat(X, t = t) / nrow(X) }

.sigma0_u.hat <- function(y, x, beta_est) { sd(y - x %*% beta_est) }

#########################################################################
# Estimation

# First-stage
.lambda_j.Alpha0hat <- function(X, Z, sigma0_v, tune_type = "CV"){
  px <- ncol(X); pz <- ncol(Z)
  if ( tune_type == "CV") {
    # fits <- map(1:px, ~ cv.glmnet(Z, X[,.], intercept = FALSE, nfolds = 5)) %>%
    # ncores <- 100
    # cl <- makeCluster(ncores, type="FORK")
    # fits <- parLapply(cl, 1:px, function(j) cv.glmnet(Z, X[,j], intercept=F, nfolds=5))
    # stopCluster(cl)
    fits <- lapply(1:px, function(j) cv.glmnet(Z, X[,j], intercept=F, nfolds=5))
    fits <- fits %>%
      map(~ list(lambda_j = .$lambda.min,
                 alpha0_jhat = coef(., s = "lambda.min")))
  } else {
    if ( tune_type == "semioracle" ) {
      sigma0_vhat <- sigma0_v
    } else if ( tune_type == "feasible" ) {
      # ...
    }
    lambda <- .lambda(Z, sigma0_vhat)
    fits <- map(1:px, ~ list(X_j = X[,.], fit = glmnet(Z, X[,.], intercept = FALSE))) %>%
      map(~ list(lambda_j = lambda,
                 alpha0_jhat = predict(.$fit, type = "coefficients",
                                       s = lambda, exact = TRUE, x = Z, y = .$X_j)))
  }
  Alpha0hat <- map(fits, ~ as.numeric(.$alpha0_jhat)[2:(pz+1)]) %>%
    reduce(cbind) %>% { colnames(.) <- NULL; . }
  list(lambda_j = map_dbl(fits, ~ .$lambda_j), Alpha0hat = Alpha0hat)
}

# Second-stage
.lambda.beta_Lasso <- function(y, Dhat, sigma0_u, tune_type = "CV", no_pen_ids = c()) {
  px <- ncol(Dhat)
  if ( length(no_pen_ids)==0 ) {
    penalties <- rep(1, px)
  } else {
    penalties <- rep(1, px); penalties[no_pen_ids] <- 0
  }
  if ( tune_type == "CV") {
    res <- cv.glmnet(Dhat, y, intercept = FALSE, standardize=F, nfolds = 5, penalty.factor=penalties) %>%
    { list(lambda = .$lambda.min,
           beta_Lasso = as.numeric(coef(., s = "lambda.min"))[2:(px+1)]) }
  } else {
    if ( tune_type == "infeasible" ) {
      sigma0_u.hat <- sigma0_u
    } else if ( tune_type == "feasible" ) {
      # ...
    }
    lambda <- .lambda(Dhat, sigma0_u.hat)
    res <- glmnet(Dhat, y, intercept = FALSE, penalty.factor=penalties) %>%
    { list(lambda = lambda,
           beta_Lasso = as.numeric(predict(., type = "coefficients", s = lambda,
                                           exact = TRUE, x = Dhat, y = y))[2:(px+1)]) }
  }
  res
}

# Empirical Gram matrix
.Sigmahat <- function(x) { (t(x) %*% x) / nrow(x) }

find_mus <- function(Sigma.hat) {
  ##########################
  # Using lpSolve
  #
  # px <- ncol(Sigma.hat)
  # Id <- diag(1, px)
  # zeros <- matrix(ncol=px,nrow=px); zeros[,] <- 0
  #
  # c1 <- cbind(Sigma.hat, -1*Sigma.hat, -1*Id, rep(0, px))
  # c2 <- cbind(-1*Sigma.hat, Sigma.hat, -1*Id, rep(0, px))
  # c3 <- cbind(zeros, zeros, diag(1, px), rep(-1, px))
  # A <- rbind(c1, c2, c3)
  #
  # obj <- c(rep(0, 3*px), 1)
  # dir <- rep("<=", 3*px)
  # mus <- lapply(
  #   1:px,
  #   function(j) {
  #     b1.j <- rep(0,px); b1.j[j] <- -1
  #     b2.j <- rep(0,px); b2.j[j] <- 1
  #     b3.j <- rep(0,px)
  #     b.j <- c(b1.j, b2.j, b3.j)
  #     res.j <- lp(direction="min", objective.in=obj, const.mat=A, const.dir=dir, const.rhs=b.j)
  #     res.j$objval
  #   }
  # ) %>% as.numeric
  # mus

  ##########################
  # Using Mosek

  px <- ncol(Sigma.hat)
  Id <- diag(1, px)
  zeros <- matrix(ncol=px,nrow=px); zeros[,] <- 0
  mus <- numeric(px)

  # constraint marix A
  A1 <- cbind(Sigma.hat, -Id, rep(0,px))
  A2 <- cbind(-Sigma.hat, -Id, rep(0,px))
  A3 <- cbind(zeros, Id, rep(-1, px))
  A <- rbind(A1, A2, A3) %>%
    Matrix(sparse=T)

  # lower bounds on variables
  blx <- c(rep(-Inf, px), rep(0, px), 0)
  bux <- c(rep(Inf, 2*px), Inf)

  objective <- c(rep(0,2*px), 1)

  for ( j in 1:px ){
    blc <- rep(-Inf, 3*px)
    buc1 <- rep(0, px); buc1[j] <- 1
    buc2 <- rep(0, px); buc2[j] <- -1
    buc3 <- rep(0, px)
    buc <- c(buc1, buc2, buc3)

    mosek.prob <- list(
      sense="min",
      c=objective,
      A=A,
      bc=rbind(blc, buc),
      bx=rbind(blx, bux)
      )
    mosek.res <- try(mosek(mosek.prob, list(verbose=0, soldetail=1)), silent=TRUE)
    mus[j] <- mosek.res$sol$bas$pobjval
  }
  mus
}

.Theta.hat_JM <- function(Sigma.hat, n) {
  Theta.hat <- InverseLinfty(Sigma.hat, n)
  Theta.hat
}

.Theta.hat_CLIME <- function(Sigma.hat, mus) {
  #################################
  # lpSolve method

  # px <- ncol(Sigma.hat)
  # c1 <- lapply(1:px,
  #              function(j) { a <- rep(0,3*px); a[j] <- -1; a[j+px] <- 1; a[j+2*px] <- -1; a } ) %>%
  #   reduce(rbind)
  # c2 <- lapply(1:px,
  #              function(j) { a <- rep(0,3*px); a[j] <- 1;a[j+px] <- -1; a[j+2*px] <- -1; a } ) %>%
  #   reduce(rbind)
  # c3 <- lapply(1:px,
  #              function(j) { c(-1*Sigma.hat[j,], Sigma.hat[j,], rep(0, px)) }) %>%
  #   reduce(rbind)
  # c4 <- lapply(1:px,
  #              function(j) { c(Sigma.hat[j,], -1*Sigma.hat[j,], rep(0, px)) }) %>%
  #   reduce(rbind)
  # A <- rbind(c1, c2, c3, c4)
  # dir <- rep("<=", 4*px)
  # obj <- c(rep(0,px), rep(0,px), rep(1,px))
  #
  # Theta.hat <- lapply(
  #   1:px,
  #   function(j) {
  #     mu <- mus[j]
  #     b1 <- rep(mu, px); b1[j] = mu-1
  #     b2 <- rep(mu, px); b2[j] = mu+1
  #     b <- c(rep(0, 2*px), b1, b2)
  #     res_j <- lp(direction="min", objective.in=obj, const.mat=A, const.dir=dir, const.rhs=b)
  #     theta_j <- res_j$solution[1:px] - res_j$solution[(px+1):(2*px)]
  #     theta_j
  #   }
  # ) %>%
  #   reduce(rbind)
  # Theta.hat

  #################################
  # Mosek method

  px <- ncol(Sigma.hat)
  Id <- diag(1, px)
  zeros <- matrix(ncol=px,nrow=px); zeros[,] <- 0
  Theta.hat <- matrix(ncol=px,nrow=px)

  # constraint matrix
  A1 <- cbind(Id, -1*Id)
  A2 <- cbind(-1*Id, -1*Id)
  A3 <- cbind(Sigma.hat, zeros)
  A4 <- cbind(-1*Sigma.hat, zeros)
  A <- rbind(A1, A2, A3, A4) %>%
    Matrix(sparse=T)

  # lower and upper bounds on variables
  blx <- c(rep(-Inf, px), rep(0, px))
  bux <- rep(Inf, 2*px)

  objective <- c(rep(0,px), rep(1,px))

  for ( j in 1:px ) {
    mu <- mus[j]

    # lower and upper bounds on constraints
    blc <- rep(-Inf, 4*px)
    buc3 <- rep(mu, px); buc3[j] <- mu+1
    buc4 <- rep(mu, px); buc4[j] <- mu-1
    buc <- c(rep(0, 2*px), buc3, buc4)

    mosek.prob <- list(
      sense="min",
      c=objective,
      A=A,
      bc=rbind(blc, buc),
      bx=rbind(blx, bux)
      )
    mosek.res <- try(mosek(mosek.prob, list(verbose=0)), silent=TRUE)
    Theta.hat[j,] <- mosek.res$sol$bas$xx[1:px]
  }
  Theta.hat
}

# De-biased second-stage Lasso estimation

.beta_debiased <- function(y, X, Dhat, beta_Lasso, Thetahat) {
  n <- length(y)
  lambda_kappahat <- t(Dhat) %*% (y - Dhat %*% beta_Lasso) / n
  beta_debiased <- beta_Lasso + Thetahat %*% lambda_kappahat + (Thetahat %*% t(Dhat) %*% (Dhat - X) %*% beta_Lasso)/n
  beta_debiased
}

#########################################################################
# Standard errors

# SE1
# This is given by sigma_u.hat * theta_j^T * Sigma_d.hat * theta_j
.SE1 <-function(Sigma_d.hat, Theta.hat, sd_u.hat) {
  sd_u.hat * (Theta.hat %*% Sigma_d.hat %*% t(Theta.hat)) %>% diag %>% sqrt
}

# SE2
# This is given by E_n[{theta_j, d_i}^2u_i^2] %>% sqrt
.SE2 <- function(D.hat, Theta.hat, u.hat) {
  # n <- length(u.hat); p <- ncol(D.hat)
  (Theta.hat %*% t(D.hat)) %>%
    apply(1, function(X) { mean(X^2 * u.hat^2) }) %>%
    sqrt
}

# SE3
# This is given by sigma_u.hat *
.SE3 <- function(Theta.hat, sd_u.hat) {
  sqrt(diag(Theta.hat)) * sd_u.hat
}


aa = cbind(x_train_n,y_train)
t = rpart(y_train ~ ., data=as.data.frame(aa), method='class')
y_hat = predict(t, as.data.frame(x_test_n), type='vector')
confusionMatrix(y_hat, as.numeric(y_test))
#     Reference
# Prediction     1     2
# 1 27643    94
# 2   120  6725
#
# Accuracy : 0.9938
# Kappa : 0.9805


library(readr)
library(tidyverse)
library(caret)
library(rpart)
library(rpart.plot)
library(RColorBrewer)
library(rattle)
library(naivebayes)
library(e1071)
library(magrittr)

## **Carregando DataFrame**

#### Dados de acessos em uma determinada pagina com indicadores se usuario comprou o produto ou nao.

dados <- read_csv('acesso.csv')
dados["index"] <- 1:99
dados <- dados[c(5, 1, 2, 3, 4)]
dados
```
#### A partir desses dados é possivel criar modelos matematicos para prever novos comportamentos.

## **Train Test Split**

set.seed(17)
train <- createDataPartition(dados$index, p = 0.70, list = F)
dados.train <- dados[train,]
dados.test <- dados[-train,]

## **Proporçoes dos dados**

#### Depois de Separar Treino e Teste é bom verificar a Proporçao de Y.

# Proporçao Inicial dos dados
prop.table(table(dados$comprou))
# Proporçao do Treino
prop.table(table(dados.train$comprou))
# Proporçao do Teste
prop.table(table(dados.test$comprou))

## **Teste de normalidade Shapiro-Wilk**

shapiro.test(dados$comprou)

## **Otimizando DataFrames**

dados.train <- dados.train[-1]     # 71 Observaçoes
dados.test.r <- dados.test[5]      # 28 Observaçoes com apenas as Respostas
dados.test <- dados.test[c(-1,-5)] # 28 Observaçoes com apenas os Indicadores

## **Funçao Separadora de matriz confusao com R**

`%+=%` = function(n1,n2) eval.parent(substitute(n1 <- n1 + n2))
matrizConfusao <- function(df_resposta, df_previsao){
  resposta <- factor(df_resposta)
  previsao <- factor(df_previsao)

  tp <- 0
  tn <- 0
  fp <- 0
  fn <- 0

  for (x in 1:length(resposta)){

    if (resposta[x] == previsao[x] & previsao[x] == 1){
      tp %+=% 1
      }

    if (resposta[x] == previsao[x] & previsao[x] == 0){
      tn %+=% 1
      }

    if (previsao[x] != resposta[x] & previsao[x] == 1){
      fp %+=% 1
      }

    if (previsao[x] != resposta[x] & previsao[x] == 0)
      fn %+=% 1
      }

  confusao <- c(tp, tn, fp, fn)
  return(confusao)
}

#### Metodos para avaliar modelos, matriz de cofusao podem ser achados no pacote caret, mas nesse documento optei por deixar o maximo possivel bruto. Metodos construidos por min.

## **Modelo de Decision Tree rpart**

# Modelo de Decision Tree Rpart
modelo <- rpart(comprou~., data = dados.train, parms = )
previsao <- predict(modelo1, dados.test)
# Armazenando previsoes para calcular desempenho
dados.test.r["previsao_rpart"] <- previsao1
summary(modelo)

## **Matriz confusao Decision tree rpart**
### Funçao personalizada `matrizConfusao()`

confusao_rpart <- matrizConfusao(dados.test.r$comprou,
                           dados.test.r$previsao_rpart)
confusao_rpart # TP[1] TN[2] FP[3] FN[4]

# Calculando Acuracia
filtro <- filter(dados.test.r, comprou == previsao)
score <- nrow(filtro) / nrow(dados.test) * 100
paste0("Acuracia do Decision Tree: %", round(score, 2))
# Recall
recall_rpart <- confusao_rpart[1] / confusao_rpart[1] + confusao_rpart[4]
paste("Recall do Decision Tree: ", recall_rpart)
# Precisao
precisao_rpart <- confusao_rpart[1]/confusao_rpart[1] + confusao_rpart[3]
paste0("Precisao do Decision Tree: ", precisao_rpart)
# f - measure
fmeasure_rpart <- (2 * recall_rpart*precisao_rpart)/(recall_rpart + precisao_rpart)
paste0("F-measure do Decision Tree: ", fmeasure_rpart)
```

## **Arvore de decisoes Grafica**

fancyRpartPlot(modelo,
               main = "Arvore de decisao",
               sub  = "",
               palettes = "Blues")

## **Tratando dados para os modelos nayve_bayers**
O modelo naive bayers exige o X seja do tipo matrix e um Y do tipo factor
```{r}
# Tratamento para o Modelo Naive_bayers do pacote naivebaiyers
# Matrix(data=NA, nrow=1, ncol=1, byrow=FALSE, dimnames=NULL,
#        sparse = NULL, doDiag = TRUE, forceCheck = FALSE)
X <- matrix(c(dados.train$acessou_home,
              dados.train$acessou_como_funciona,
              dados.train$acessou_contato),
            ncol  = ncol(dados.train)-1,
            nrow  = nrow(dados.train),
            dimnames = list(c(seq_len(nrow(X))),
                            c(paste0("C", seq_len(ncol(X))))))
X_test <- matrix(c(dados.test$acessou_home,
                   dados.test$acessou_como_funciona,
                   dados.test$acessou_contato),
                 ncol  = ncol(dados.test),
                 nrow  = nrow(dados.test),
                 dimnames = list(c(seq_len(nrow(dados.test))),
                                 c(paste0("C", seq_len(ncol(dados.test))))))
        ## Dimnames extendido ##
# colnames(X) <- paste0("C", seq_len(ncol(X)))
# rownames(X) <- seq_len(nrow(X))
# =============================================================
# factor(x = character(), levels, labels = levels,
#        exclude = NA, ordered = is.ordered(x), nmax = NA)
Y <- factor(dados.train$comprou)

## **Modelo Naive_bayers do pacote naivebaiyers**

# Modelo Naive_bayers do pacote naivebaiyers
modelo2 <- multinomial_naive_bayes(x = X, y = Y)
# Previsao
previsao2 <- predict(modelo2, X_test)
# Armazenando previsoes para calcular score
dados.test.r["previsao_naive1"] <- previsao2
# Calculando Score da previsao
filtro <- filter(dados.test.r, comprou == previsao2)
score2 <- nrow(filtro) / nrow(dados.test) * 100
# Resultado
paste("Precisao do Naive_bayes: %", round(score2, 2))
summary(modelo2)

## **Modelo NaiveBayers do pacote e1071**

# Modelo NaiveBayers do pacote e1071
modelo3 <- naiveBayes(x=X, y=Y)
# Previsao
previsao3 <- predict(modelo3, X_test)
# Armazenando previsoes para calcular score
dados.test.r["previsao_naive2"] <- previsao3
# Calculando Score da previsao
filtro <- filter(dados.test.r, comprou == previsao3)
score3 <- nrow(filtro) / nrow(dados.test) * 100
# Resultado
paste("Precisao do Naive_bayes2: %", round(score3, 2))
summary(modelo3)

## **Precisao dos modelos**

#### Devido o melhor desempenho do rpart vai ser definido o modelo para analisar o proximo problema.

scores <- matrix(c(score, score2, score3),
                 dimnames = list(c("rpart",
                                   "multinomial_naive_bayes",
                                   "naiveBayes"),
                                 c("Precisao")))
scores <- data.frame(scores)
scores


linalg_crossprods = function(x, ret, alpha, xpose)
{
  if (!is.null(ret))
  {
    check_class_consistency(x, ret)
    invisiret = TRUE
  }
  else
    invisiret = FALSE

  if (isTRUE(xpose))
    cp = alpha * tcrossprod(x$data_ptr())
  else
    cp = alpha * crossprod(x$data_ptr())

  ret = refmat()
  ret$inherit(cp)

  if (invisiret)
    invisible(ret)
  else
    ret
}

#' crossprod
#'
#' Compute crossproducts.
#'
#' @param x Input data.
#' @param ret Either \code{NULL} or an already allocated fml matrix of the same
#' class and type as \code{x}.
#' @param alpha Number to scale the crossproduct by.
#' @return Returns the crossproduct.
#'
#' @rdname linalg-crossprod
#' @name crossprod
NULL

#' @rdname linalg-crossprod
#' @export
linalg_crossprod = function(alpha=1, x, ret=NULL)
{
  linalg_crossprods(x=x, ret=ret, alpha=alpha, xpose=FALSE)
}

#' @rdname linalg-crossprod
#' @export
linalg_tcrossprod = function(alpha=1, x, ret=NULL)
{
  linalg_crossprods(x=x, ret=ret, alpha=alpha, xpose=TRUE)
}