########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
########################################################
#Some simple visualizations and statistics of the first (of two) admission exams to Mexico's biggest university

library(ggplot2)
library(directlabels)
library(Hmisc)
library(xtable)

#Footnote function taken from:
#http://www.r-bloggers.com/r-good-practice-%E2%80%93-adding-footnotes-to-graphics/
# default footnote is today's date, cex=.7 (size) and color
# is a kind of grey
makeFootnote <- function(footnoteText=
                         format(Sys.time(), "%d %b %Y"),
                         size= .7, color= grey(.5))
{
   require(grid)
   pushViewport(viewport())
   grid.text(label= footnoteText ,
             x = unit(1,"npc") - unit(2, "mm"),
             y= unit(2, "mm"),
             just=c("right", "bottom"),
             gp=gpar(cex= size, col=color))
   popViewport()
}

cleanData <- function(area.df) {
  area <- area.df
  colnames(area) <- c("Num","Score","Accepted","Major","Faculty")
  area$Major <- sub(".[0-9]+. +(.)[\n]*", "\\1", area$Major)
  area$Major <- iconv(area$Major, "windows-1252", "utf-8")
  area$Faculty <- sub(".[0-9]+. +(.)[\n]*", "\\1", area$Faculty)
  area$Loc <- ifelse(substr(area$Faculty,1,8)=="FACULTAD",c("C.U."),
                   c(area$Faculty))

  #area.ac<-subset(area,area$Accepted=="A")
  area
}

median_cl_boot <- function(x, conf.int = 0.95, B = 1000, na.rm = TRUE, reps = FALSE) {
    if (na.rm)
        x <- x[!is.na(x)]
    n <- length(x)
    xm <- median(x)
    if (n < 2)
        return(data.frame(y = xm, ymin = NA, ymax = NA))
    resamples <- lapply(1:B, function(i) sample(x, replace=T))
    r.median <- sapply(resamples, median)
    quant <- quantile(unlist(r.median),
                      c((1 - conf.int)/2, (1 + conf.int)/2))
    names(quant) <- NULL
    Median <- median(x)
    data.frame(y = Median,
               ymin = quant[1],
               ymax = quant[2])
}

graphMajors <- function(area.df, title="", filename) {
  area.ac <- cleanData(area.df)
  area.ac<-subset(area.ac,area.ac$Accepted=="A")

 # major <- data.frame(summarize(area.ac$Score, llist(area.ac$Major,
#                    area.ac$Loc), median ))
 # major$area.ac.Major <- factor(major$area.ac.Major)
 # major$area.ac.Major <- with(major, reorder(area.ac.Major,
  #                                           median))

  colnames(area.ac) <- c("Num", "Score", "Accepted", "Major",
                         "Faculty", "Campus")
  area.ac <- ddply(area.ac, .(Major, Campus), transform,
                        median = median(Score))
  area.ac <- ddply(area.ac, .(Major), transform, median = max(median))
  area.ac$Major <- with(area.ac, reorder(Major, median))
#  area.ac$Major<-factor(area.ac$Major, levels = levels(
 #                                     major$area.ac.Major))
  if (length(levels(factor(area.ac$Campus))) < 7) {
    p <- ggplot(aes(y=Score, x=Major, color=Campus, shape=Campus),
                data=area.ac)
  } else {
    p <- ggplot(aes(y=Score, x=Major, color=Campus, group = Campus), data=area.ac)
  }
  p + opts(strip.text.y = theme_text())  +
      coord_flip() +
      geom_jitter(alpha = I(.2),
                  position=position_jitter(width=.15)) +
      stat_summary(size=.75, fun.data = median_cl_boot, alpha=.8) +#
      stat_summary(fun.data = median_cl_boot, color=I("black"),
                   geom="point",size=3) +
      ylab("Number of correct answers") + xlab("") +
          opts(title=title) + theme_bw()
  ggsave(file = paste("output/", filename, "_maj.png", sep = ""),
         dpi=72, width=3.3, height=2.05, scale=4)
}

graphCampus <- function(area.df, title="", filename) {
  area.ac<-cleanData(area.df)
  area.ac<-subset(area.ac,area.ac$Accepted=="A")
  colnames(area.ac) <- c("Num", "Score", "Accepted", "Major", "Campus",
                         "Loc")
  area.ac$Campus <- with(area.ac, reorder(factor(Campus), Score,
                                          median))
  ggplot(data = area.ac, aes(x = Campus, y = Score)) +
         geom_jitter(alpha = I(.2),
                  position=position_jitter(width = .15)) +
         stat_summary(fun.data = median_cl_boot, color = I("red"),
                      width = .4, geom = "crossbar") +
         ylab("Number of correct answers") +
         xlab("") +
         coord_flip() +
         opts(title = title) + theme_bw()
  ggsave(file = paste("output/", filename, "_fac.png", sep = ""),
         dpi=72, width=2.5, height=1.5, scale=4)
}

makeTable <- function(area.df, filename) {
  area <- cleanData(area.df)
  area.re <- subset(area,area$Accepted == "R")
  area.ac <- subset(area,area$Accepted == "A")
  min_score <- data.frame(summarize(area.ac$Score, llist(area.ac$Major,
                    area.ac$Faculty), min ))
  yieldR <- summarize(area.re,
                      llist(area.re$Accepted,area.re$Major,
                            area.re$Faculty),
                      nrow)
  yieldA <- summarize(area.ac,
                      llist(area.ac$Accepted,area.ac$Major,
                            area.ac$Faculty),
                      nrow)
  colnames(min_score) <- c("Major","Location","Cutoff.Score")
  min_score$Total.Applied <- yieldA$area.ac + yieldR$area.re
  min_score$Accepted <- yieldA$area.ac
  min_score$Acceptance.Rate <- paste(round((yieldA$area.ac /
                                       yieldR$area.re) * 100,
                                digits = 1),"%", sep = "")
  write.csv(min_score[order(-min_score$Cutoff.Score),],
            file = paste("output/", filename, ".csv", sep = ""),
            row.names = FALSE)
#  print(xtable(min_score[order(-min_score$Minimo),]), type="html",
 #       file = paste("output/", filename, ".html", sep = ""),
  #      include.rownames = FALSE)
}

readFile <- function(filename) {
    filename <- paste("data/", filename, ".csv.bz2", sep="")
    read.csv(bzfile(filename), na.strings=c("N","C"), header=FALSE,
                 colClasses = c("factor","numeric","factor","factor",
                              "factor"))
}

newAnalyzeThis <- function(){
    allareas <- data.frame()
    list(
         analyze = function(filename, title.majors, title.campuses) {
            area <- readFile(filename)
            allareas <<- rbind(allareas, area)
            makeTable(area, filename)
            graphMajors(area, title.majors , filename)
            graphCampus(area, title.campuses, filename)
            return(NULL)
         },
         result = function() {
             cleanData(allareas)
         }
    )
}

########################################################
#Finally, the program
########################################################
filenames <- c("AreaI", "AreaII", "AreaIII", "AreaIV")
title.majors <- c("Median score by major (95% CI). Physical Sciences, Mathematics and Engineering",
                  "Median score by major (95% CI). Biological Sciences and Health",
                  "Median score by major (95% CI). Social Sciences",
                  "Median score by major (95% CI). Humanities and Arts")
title.campuses <- c("Median score by Educational Establishment (95% CI). Physical Sciences, Mathematics and Engineering",
                    "Median score by Educational Establishment (95% CI). Biological Sciences and Health",
                    "Median score by Educational Establishment (95% CI). Social Sciences",
                    "Median score by Educational Establishment (95% CI). Humanities and Arts")

analyzeUNAM <- newAnalyzeThis()
mapply(analyzeUNAM$analyze, filenames, title.majors, title.campuses)
allareas <- analyzeUNAM$result()

########################################################
#Some basic statistics
########################################################

#Number Accepted and Rejected (7690 + 98241)
ddply(allareas,.(Accepted),function(df) nrow(df))
#Average score of those Accepted
ddply(allareas,.(Accepted),function(df) mean(df$Score, na.rm=TRUE))
#Wooow, that's a lot of people with high scores who were rejected,
#maybe instead of appling to med school they should have studied
#some social science, hahaha
ddply(allareas[order(-allareas$Score), ][1:7690,], .(Accepted),
      function(df) nrow(df))
3766 / (3924 + 3766)
ddply(allareas[order(-allareas$Score), ][1:7690,], .(Accepted),
      function(df) mean(df$Score, na.rm=TRUE))

ggplot(allareas, aes(Score, group = Accepted, fill = Accepted,
                     color = Accepted)) +
    geom_density(aes(y = ..count..), alpha =.4, binwidth = 1) +
    xlab("Score") + ylab("Number of Students") +
    annotate("text", x = 75, y = 2200, label = "Rejected",
             color = "#F8766D" ) +
    annotate("text", x = 105, y = 270, label = "Accepted",
             color = "#00BFC4") +
    scale_color_manual(values = c("#00BFC4", "#F8766D")) +
    scale_fill_manual(values = c("#00BFC4", "#F8766D")) +
    theme_bw() +
    opts(title = "UNAM - February Admission Exam, 2009") +
    #facet_wrap(~ Loc, scales = "free") +
    opts(legend.position = "none")
ggsave(file = "output/accepted-vs-rejected.png",
         dpi=72, width=1.5, height=1.5, scale=4)

########################################################
#Compare salaries with the entrace exam score
########################################################
#From Reforma:
#Medicina: $13,364 pesos
#Ingeniería en Sistemas: 12,636 pesos
#Derecho: $10,969 pesos
#Ingeniería Mecatrónica: $10,902 pesos
#Arquitectura: $10,870 pesos
#Ingeniería Civil: $10,821 pesos
#Licenciado en Sistemas: $10,736 pesos
#Mercadotecnia: $10,545 pesos
#Ingeniería Industrial: $9,747 pesos
#Psicología: $9,708 pesos
#Relaciones Internacionales: $9,704 pesos
#Administración: $9,567 pesos
#Comunicación: $9,372 pesos
#Contaduría: $8,151 pesos
allareas.a <- subset(allareas,Accepted == "A")
allareas.cu.a <- allareas.a[grep("FACULTAD",allareas.a$Faculty),]
avscore <- function(str, df){
    mean(df[grep(str, df$Major),]$Score)
}
majors <- c("MEDICO", "INGENIERIA EN COMPUTACION",
            "DERECHO","MECATRONICA", "ARQUITECTO","INGENIERIA CIVIL",
            "INGENIERIA INDUSTRIAL","PSICOLOGIA","RELACIONES INT",
            "ADMINISTRACION","COMUNICACION","CONTADURIA" )
scores <- sapply(majors, avscore, allareas.cu.a)
salaries <- c(13364,12636,10969,10902,10870,10821,9747,9708,9704,9567,9372,8151)
ss <- data.frame(scores, log.salaries = log(salaries))
ggplot(ss, aes(scores, log.salaries, label = rownames(ss))) +
    geom_point() +
    ylab("Number of correct answers") +
    geom_smooth(method = lm) +
    geom_text(hjust=-0.05, angle = -40, size = 4) +
    coord_cartesian(xlim = c(75.5, 115)) +
    opts(title = "Starting Salary vs Entrance Exam Score") +
    theme_bw()
ggsave(file = "output/score_vs_salary.png",
         dpi=72, width=1.5, height=1.5, scale=4)

#############################################################
#The med school students at the UNAM have the highest scores
#and since all students who want to become doctors
#have to take the ENARM, we can compare them to other schools
#############################################################

#If 47% percent of the students passed the ENARM what score would
#be the equivalent in the admission exam
enarm <- read.csv("data/enarm-2009.csv")
enarm$University <- iconv(enarm$University, "windows-1252",
                          "utf-8")
enarm$prop <- enarm$Passed / enarm$Students
area.ac<-subset(allareas, allareas$Accepted == "A")

getMinScore <- function(Campus, df) {
    area.ac.F<-subset(df, Major == "MEDICO CIRUJANO" &
                          Faculty == Campus)
    rown <- which(tolower(as.character(enarm$University)) == tolower(Campus))
    print(nrow(area.ac.F) * enarm[rown,]$prop)
    print(enarm[rown,]$prop)
    ordered <- area.ac.F$Score[order(-area.ac.F$Score)]
    min(ordered[1:round(nrow(area.ac.F) * enarm[rown,]$prop,
                        digits=0)])
}
facs <- c("FACULTAD DE MEDICINA",
          "FES IZTACALA",
          "FES ZARAGOZA")
scores <- sapply(facs, getMinScore, area.ac)

area.ac.MC<-subset(area.ac,area.ac$Major=="MEDICO CIRUJANO" &
                   (area.ac$Faculty=="FACULTAD DE MEDICINA" |
                   area.ac$Faculty=="FES IZTACALA"  |
                   area.ac$Faculty=="FES ZARAGOZA"))
colnames(area.ac.MC) <- c("Num", "Correct", "Accepted", "Major",
                          "Campus", "Loc")
ggplot(area.ac.MC, aes(x = Correct, fill = Campus, color = Campus)) +
       geom_density(alpha = 0.4, size=1,
                    aes(y = ..density..))  +
       xlab("number of correct answers") +
       geom_vline(xintercept = scores[1], linetype = 2,
                  color = "red", alpha = .3) +
       geom_vline(xintercept = scores[2], linetype = 2,
                  color = "green", alpha = .3) +
       geom_vline(xintercept = scores[3], linetype = 2,
                  color = "blue", alpha = .3) +
       opts(title = "Distribution of Med Students Admission Scores") +
       theme_bw()
ggsave(file = "output/density_unam.png",
         dpi=72, width=2.5, height=1.5, scale=4)

#Given the differences in the admission exam scores what percentages
#should pass the ENARM
perPass <- function(campus, area.ac){
    nrow(subset(area.ac,area.ac$Major == "MEDICO CIRUJANO" &
                   area.ac$Faculty == campus &
                   area.ac$Score >= scores[1] )) /
    nrow(subset(area.ac,area.ac$Major == "MEDICO CIRUJANO" &
                   area.ac$Faculty == campus ))
}
med <- c("FES IZTACALA", "FES ZARAGOZA", "FACULTAD DE MEDICINA")
sapply(med, perPass, area.ac)
enarm
scores

#enarm$e <- sqrt((enarm$prop * (1 - enarm$prop)) / enarm$Students)
#enarm$University <- reorder(enarm$University, enarm$prop)
#ggplot(enarm, aes(University, prop)) +
#    scale_y_continuous(formatter = "percent") +
#    geom_linerange(aes(ymax = prop + e, ymin = prop -e), color = "red") +
#    geom_point() +
#    coord_flip() +
#    opts(title = "Percentage of students who passed the ENARM in 20089") +
#    ylab("") +
#    theme_bw()
#ggsave(file = "output/uni_ranked.png",
#         dpi=72, width=1.5, height=1.5, scale=4)

########################################################
#ENARM
########################################################

enarm.all <- read.csv("data/enarm-2009-all.csv")
enarm.all$University <- iconv(enarm.all$University,
                              "windows-1252",
                              "utf-8")

enarm.all$per <- ifelse(enarm.all$Passed > 0,
                    enarm.all$Passed / enarm.all$Test.Takers, 0)
means <- sapply(enarm.all[,2:8], function(x) mean(x))
wmeans <- sapply(enarm.all[,5:8],
                 function(x) weighted.mean(x, enarm.all$Test.Takers))
means[["per"]];wmeans[["per"]]
ggplot(enarm.all, aes(Medical.Score, English.Score,
                      label = University)) +
    geom_point(aes(size = Test.Takers)) +
    geom_text(hjust=-0.07, angle = -50, size = 3, alpha = .8) +
    geom_smooth(method = lm, aes(weight = Test.Takers)) +
    theme_bw()
ggsave(file = "output/all-universities.png",
         dpi=72, width=3.3, height=2.3, scale=4)

enarm <- read.csv("data/enarm-2009.csv")
enarm$University <- iconv(enarm$University, "windows-1252",
                          "utf-8")

enarm$per <- enarm$Passed / enarm$Students
enarm$error <- sqrt((enarm$per * (1 - enarm$per)) / enarm$Students)

########################################################
#Fraud
########################################################
ggplot(enarm.all, aes(1 - (Test.Takers / Applicants), Total.Score)) +
#    geom_point() +
    geom_text(aes(label = University), angle = 0, alpha = .8,
              size = 3) +
    ylab("Test Score") + xlab("Percentage who failed to show up") +
    scale_x_continuous(formatter = "percent") +
    stat_smooth(size = 1.2, aes(weight = Test.Takers), method = lm) +
    opts(title = "Total Score in the ENARM vs Percentage of Students who Failed to Show Up for the Test")
ggsave(file = "output/fraud.png",
         dpi=72, width=2, height=1.5, scale=4)
#Fraud in the ENARM?
#http://2.bp.blogspot.com/_7k_XUBT5vbU/SPknrBDqtrI/AAAAAAAAADk/mYcQ5PIlUGg/s800/enarm0708.bmp
#Secretaria de Marina, Escula Médico Naval 71 40 - 2007
#4 1 - 2008
40/71
1/4
#Escuela Médico Militar Univ. Ejer y Fza Aerea 116 115 - 2007
#2 0 - 2008
115/116
0

########################################################
#Multiple Charts
########################################################
grid.newpage()
pushViewport(viewport(layout =  grid.layout(nrow = 2, ncol = 2)))

subplot <- function(x, y) viewport(layout.pos.row = x,
                                   layout.pos.col = y)

enarm$University <- reorder(enarm$University, enarm$per)
print(ggplot(enarm, aes(University, per)) +
    scale_y_continuous(formatter = "percent") +
    geom_linerange(aes(ymax = per + error, ymin = per - error),
                   color = "red") +
    geom_point() + xlab("") +
    coord_flip() +
    geom_hline(yintercept = means[["per"]], linetype = 2,
               color = "gray") +
    scale_y_continuous(formatter = "percent", limits = c(0, .95)) +
    opts(title = "Percentage of students who passed the ENARM in 2009") +
    ylab("") +
    theme_bw(), vp = subplot(1, 1))
enarm.unam <- subset(enarm.all, University %in%
                     c("UNAM FM-CU",
                       "UNAM FES Zaragoza",
                       "UNAM FES Iztacala",
                       "Univ Panameriacana",
                       "Univ La Salle",
                       "Inst Tecnológico Est Sup Monterrey",
                       "Univ. Aut. De Nuevo León"))
print(ggplot(enarm.all, aes(Medical.Score, English.Score,
                        label = University)) +
    geom_text(data = enarm.unam, aes(Medical.Score, English.Score,
                        label = University),
              hjust=-0.09, angle = 0, size = 3, alpha = 1) +
    geom_point(aes(size = Test.Takers)) +
    geom_smooth(method = lm, aes(weight = Test.Takers)) +
    opts(title = "Regression of English and Medical Scores") +
    coord_cartesian(xli = c(51.8, 64), ylim = c(5, 8.4)) +
    theme_bw(),
    vp = subplot(1, 2))

enarm$University <- reorder(enarm$University, enarm$English.Score)
print(ggplot(enarm, aes(University, English.Score)) +
    geom_point() +
    coord_flip() + xlab("") +
    geom_hline(yintercept = means[["English.Score"]], linetype = 2,
               color = "gray") +
    opts(title = "Average English Score in the ENARM 2009") +
    ylab("") +
    theme_bw(), vp = subplot(2, 2))

enarm$University <- reorder(enarm$University, enarm$Medical.Score)
print(ggplot(enarm, aes(University, Medical.Score)) +
    geom_point() +
    coord_flip() + xlab("") +
    geom_hline(yintercept = means[["Medical.Score"]], linetype = 2,
               color = "gray") +
    opts(title = "Average Medical Score in the ENARM 2009") +
    ylab("") +
    theme_bw(), vp = subplot(2, 1))

makeFootnote("As you can see in the regression plot there were many schools that ranked above the FES Acatlan and FES Zaragoza, they were ommited to conserve space")
dev.print(png, "output/uni-enarm2009.png", width=800, height=600)

#filenames <- c("AreaI", "AreaII", "AreaIII", "AreaIV")
#filenamesF <- paste("data/", filenames, "Feb2010.csv", sep="")
#filenamesJ <- paste("data/", filenames, "Junio2010.csv", sep="")

#readFiles <- function(files) {
#  unam <- lapply(files, function(x) {
#                               t <- read.csv(x)
#                               names(t) <- c("Num","Score","Accepted","Major","Faculty")
#                               t
#                           })
#  unam <- rbind.fill(unam)
#  unam
#}

#unamF <- readFiles(filenamesF)
#unamF$date <- "Feb"
#unamJ <- readFiles(filenamesJ)
#unamJ$date <- "Jun"
#unam <- rbind(unamF, unamJ)

#unam$score2 <- as.numeric(as.character(unam$Score))
#ddply(subset(unam, Accepted = "A"), .(Faculty),
#      function(df) mean(df$score2, na.rm = TRUE))
#max(unam$score2, na.rm = TRUE)
#fix(unam)


#' @section Computed variables:
#' \describe{
#'   \item{count}{number of points in bin}
#'   \item{prop}{groupwise proportion}
#' }
#' @seealso [stat_bin()], which bins data in ranges and counts the
#'   cases in each range. It differs from `stat_count()`, which counts the
#'   number of cases at each `x` position (without binning into ranges).
#'   [stat_bin()] requires continuous `x` data, whereas
#'   `stat_count()` can be used for both discrete and continuous `x` data.
#'
#' @export
#' @rdname geom_bar
stat_count <- function(mapping = NULL, data = NULL,
                       geom = "bar", position = "stack",
                       ...,
                       width = NULL,
                       na.rm = FALSE,
                       orientation = NA,
                       show.legend = NA,
                       inherit.aes = TRUE) {

  params <- list2(
    na.rm = na.rm,
    orientation = orientation,
    width = width,
    ...
  )

  layer(
    data = data,
    mapping = mapping,
    stat = StatCount,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = params
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
#' @include stat-.r
StatCount <- ggproto("StatCount", Stat,
  required_aes = "x|y",

  default_aes = aes(x = after_stat(count), y = after_stat(count), weight = 1),

  setup_params = function(self, data, params) {
    params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE)

    has_x <- !(is.null(data$x) && is.null(params$x))
    has_y <- !(is.null(data$y) && is.null(params$y))
    if (!has_x && !has_y) {
      cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.")
    }
    if (has_x && has_y) {
      cli::cli_abort("{.fn {snake_class(self)}} must only have an {.field x} {.emph or} {.field y} aesthetic.")
    }

    if (is.null(params$width)) {
      x <- if (params$flipped_aes) "y" else "x"
      params$width <- resolution(data[[x]]) * 0.9
    }

    params
  },

  extra_params = c("na.rm", "orientation"),

  compute_group = function(self, data, scales, width = NULL, flipped_aes = FALSE) {
    data <- flip_data(data, flipped_aes)
    x <- data$x
    weight <- data$weight %||% rep(1, length(x))

    count <- as.numeric(tapply(weight, x, sum, na.rm = TRUE))
    count[is.na(count)] <- 0

    bars <- new_data_frame(list(
      count = count,
      prop = count / sum(abs(count)),
      x = sort(unique(x)),
      width = width,
      flipped_aes = flipped_aes
    ), n = length(count))
    flip_data(bars, flipped_aes)
  }
)


# 3. faza: Vizualizacija podatkov

# Graf delovno aktivnih moških glede na izobrazbo
graf_izobrazba.moski <- ggplot(filter(tabela_po_izobrazbi, spol == 'Moški'),
                          aes(x=leto, y=stevilo, col=izobrazba)) + geom_point(size=3) +
  ggtitle("Delovno aktivni moški glede na izobrazbo") + ylab("Število v 1000") + theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))

# Graf delovno aktivnih žensk glede na izobrazbo
graf_izobrazba.zenske <- ggplot(filter(tabela_po_izobrazbi, spol == 'Ženske'),
                           aes(x=leto, y=stevilo, col=izobrazba)) + geom_point(size=3) +
  ggtitle("Delovno aktivne ženske glede na izobrazbo") + ylab("Število v 1000") + theme_minimal() +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))

# Graf delovno aktivnih v letu 2019 glede na poklicno skupino in spol
graf_poklicna_skupina.2019 <- ggplot(filter(tabela_po_poklicni_skupini, leto == 2019), aes(x=stevilo, y=poklicna_skupina, fill=spol)) +
  geom_bar(stat='identity', position='dodge') + theme_minimal() +
  labs(title="Delovno aktivni v 2019", x="Število v 1000", y = "Poklicna skupina") +
  scale_fill_manual(values=c('skyblue1', 'plum3'))

# Graf delovno aktivnih tehnikov in drugih strokovnih sodelavcev glede na spol
graf_tehniki <- ggplot(filter(tabela_po_poklicni_skupini, poklicna_skupina == 'Tehniki in drugi strokovni sodelavci'),
       aes(x=leto, y=stevilo, fill=spol)) +
  geom_bar(stat='identity', position='dodge') + theme_minimal() +
  labs(title="Delovno aktivni tehniki in drugi strokovni sodelavci", x="Leto", y = "Število v 1000") +
  coord_cartesian(ylim=c(50,90)) + scale_fill_manual(values=c('skyblue1', 'plum3'))

# Zemljevida

zemljevid <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_SVN_shp.zip",
                             "gadm36_SVN_1", encoding = "UTF-8")

zemljevid$NAME_1[zemljevid$NAME_1 == "GoriĹˇka"] <- "Goriška"
zemljevid$NAME_1[zemljevid$NAME_1 == "KoroĹˇka"] <- "Koroška"
zemljevid$NAME_1[zemljevid$NAME_1 == "Notranjsko-kraĹˇka"] <- "Notranjsko-kraška"
zemljevid$NAME_1[zemljevid$NAME_1 == "Obalno-kraĹˇka"] <- "Obalno-kraška"

glede_na_povrsino <- inner_join(povrsina_regij, filter(tabela_po_statisticni_regiji, leto == 2019),
                     by = NULL, copy = FALSE, suffix = c(".regija", ".regija")) %>% select(-leto) %>%
  mutate(Število = (stevilo / povrsina))

narisi_glede_na_povrsino <- tm_shape(merge(zemljevid, glede_na_povrsino, by.x='NAME_1', by.y='regija')) +
  tm_polygons('Število', palette = "Purples") + tm_layout(main.title = "Zemljevid števila delovno aktivnih \nna kvadratni kilometer regije") +
  tm_text(text='NAME_1', size=0.6)

glede_na_prebivalce <- inner_join(filter(prebivalstvo_regij, leto == 2019), filter(tabela_po_statisticni_regiji, leto == 2019),
                                by = NULL, copy = FALSE, suffix = c(".regija", ".regija")) %>% select(-leto) %>%
  mutate(Delež = ((stevilo * 100) / prebivalstvo))

narisi_glede_na_prebivalce <- tm_shape(merge(zemljevid, glede_na_prebivalce, by.x='NAME_1', by.y='regija')) +
  tm_polygons('Delež', palette = "Purples") + tm_layout(main.title = "Zemljevid deleža delovno aktivnih \nglede na število vseh prebivalcev regije") +
  tm_text(text='NAME_1', size=0.6)


# to do -- use sqlite as storage to work around download/rate limit issues

library(tidyverse)
library(fredr)
library(sqldf)

continue_download = T
clean_existing_data = F

setwd("~/Public_Policy/Projects/COVID-19/data")

fred_sqlite = dbConnect(SQLite(), dbname= "fred_sqlite.sqlite")

fredr_set_key('0437e7baffc7066bacb86efa56cc37c9')

states_category = 27281

desired_title_substrings = c("Per Capita Personal Income","Real Per Capita Personal Income",
                             "All-Transactions House Price Index",
                             "All Employees: Total Nonfarm",
                             "Average Weekly Wages for Employees in Private Establishments",
                             "Total Gross Domestic Product", "Total Per Capita Real Gross Domestic Product")

state_categories = fredr_category_children(states_category)

all_counties_MSAs = lapply(state_categories$id, function(state_id){

  state_children = fredr_category_children(state_id)
  msa_counties = filter(state_children, name %in% c('Counties', 'MSAs', 'Parishes'))
}) %>%
  bind_rows() %>%
  left_join(
    state_categories %>% select(-parent_id) %>% rename(state = name),
    by = c('parent_id' = 'id')
  ) %>%
  rename(
    state_id = parent_id
  )

## all county level data for the US

county_substrings = c(
  'Resident Population',
  'Mean Commuting Time',
  'Unemployment Rate', 'Civilian Labor Force', 'All-Transactions House Price Index',
  'New Private Housing Structures Authorized by Building Permits',
  'Per Capita Personal Income',
  'Net Migration Flow', 'Estimate of Median Household Income', 'Homeownership Rate',
  'Burdened Households'
)

# no counties in puerto rico
counties_categories = filter(all_counties_MSAs, name %in% c('Counties', 'Parishes'), state != 'Puerto Rico')

if (continue_download) {
  loaded_states = dbGetQuery(fred_sqlite, "select distinct state_name from us_county_indicators")
  counties_categories = filter(counties_categories, !state %in% loaded_states$state_name)
}

if (clean_existing_data) {
  dbGetQuery(fred_sqlite, 'drop table us_county_indicators')
}

# dbSendQuery(fred_sqlite, 'drop table us_county_indicators')

all_states_counties_downloaded = map(1:nrow(counties_categories), function(state_it){

  this_state = counties_categories[state_it,]
  state_name = this_state$state
  cat('working on', state_name, '...\n')

  state_id = this_state$state_id
  state_counties_category = this_state$id

  the_counties = fredr_category_children(state_counties_category)

  n_counties = nrow(the_counties)
  progress_bar <- txtProgressBar(min = 0, max = n_counties, style = 3)

  all_counties_downloaded = lapply(1:n_counties, function(county_it){

    this_county = the_counties[county_it,]
    county_id = this_county$id
    county_name = this_county$name

    county_series = fredr_category_series(county_id) %>%
      filter(seasonal_adjustment_short == 'NSA', frequency_short == 'A')

    matched_county_series = map(county_substrings, function(substring){
      county_series$title[str_detect(county_series$title, substring)]
    }) %>%
      unlist() %>%
      unique()

    selected_county_series = filter(county_series, title %in% matched_county_series)

    all_series_downloaded = map(selected_county_series$id, function(x){
      the_download = fredr_series_observations(x, frequency = 'a', aggregation_method = 'eop')
      Sys.sleep(0.75) # the fred api complains about rate limit constraints
      return(the_download)
    }) %>%
      bind_rows() %>%
      left_join(
        dplyr::select(selected_county_series, id, title),
        by = c('series_id' = 'id')
      )

    series_download_clean = mutate(all_series_downloaded,
                                   title_clean = str_replace(title, county_name, '') %>%
                                     str_replace(pattern = '( [a-z]{2,4} )$', ''),
                                   county_name = county_name,
                                   county_id = county_id
    ) %>%
      left_join(
        county_series %>% dplyr::select(id, frequency_short, units, seasonal_adjustment_short),
        by = c('series_id' = 'id')
      )

    setTxtProgressBar(progress_bar, county_it)

    return(series_download_clean)
  }) %>%
    bind_rows() %>%
    mutate(
      state_name = state_name,
      state_id = state_id
    )

  dbWriteTable(fred_sqlite, 'us_county_indicators', all_counties_downloaded, append = T)

  close(progress_bar)

  return(all_counties_downloaded)
})

dbDisconnect(fred_sqlite)


set.seed(2141)
source("~/quasr/suff_stats_quasr.r")
source("~/trw/startup.r")

source("~/quasr/admm.r")

library(parallel)

library(huge)

d=10
n=5000
m1=4
m2=4
#source("~/trw/startup.r")
setwd("~/quasr")
rep=10
#h=huge.generaor(n=n,d=d,graph="random",prob=.9)
h=huge.generator(n=2*rep*n,d=d,graph="hub")
h$data<-scale(h$data,center=T,scale=T)/8+0.5
h$data<- sign(h$data-.5)*(abs(h$data-.5))^.6
h$data<-scale(h$data,center=T,scale=T)/4+0.5

h$data[h$data>=1] = .95
h$data[h$data<=0] = .05

roc=rochuge=list()

hout=h$theta[row(h$theta)>=col(h$theta)+1]
spar=sum(hout)

lammax=max(abs(unlist(Kvec2(h$data,m1,m2))))*1.5
lamseq=exp(seq(from=log(.01*lammax),to=log(lammax),length.out=25))

out=mclapply(1:rep,function(r){
#for(r in 1:rep){

#print(paste("rep number ",r))
ncount=1
#dat=h$data[((r-1)*max(nlist)+1):(r*max(nlist)),]
dat=h$data[((r-1)*n+1):(r*n),]
#test=h$data[(rep*max(nlist)+(r-1)*max(nlist)+1):(rep*max(nlist)+r*max(nlist)),]
ncount=ncount+n

#dat=matrix(runif(d*n),n,d)

g<-graph.full(d,directed=F)
edgelist<- get.edgelist(g)
#g=graph.adjacency(h$theta,mode="undirected")
#edgelist=get.edgelist(g)
# clust<- clusters(g)$membership
# #edge_mean <- edge.means(dat, edgelist, m2, cores)
# #node_mean <- node.means(dat , m1,cores)
# #edge_mean_test <- edge.means(test, edgelist, m2, cores)
# #node_mean_test <- node.means(test , m1,cores)
# #weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])
# edge_coef<- array(0,dim=c(m2,m2,dim(edgelist)[1]))
# node_coef<- matrix(0,d,m2)
# #lam=.1
# alpha_start=1
# sub=g
# tree_obj<-edge.Start(sub,burn.in=10)
# wt<-E(tree_obj)$weight

admm=admmSel(dat,lam=lamseq,m1=m1,m2=m2,rho=1,elist=edgelist)

Q = huge.npn(dat)
hugeout=huge(Q,lambda=lamseq,method="glasso")

roc=lapply(admm,function(x){
	a=1 - sum( (apply(x$ze,3,function(i) 1*any(i!=0)) ==0 )  & (hout!=0) )/spar
	b=1- sum( (apply(x$ze,3,function(i) 1*any(i!=0)) !=0 ) & (hout==0 ) )/(d*(d-1)/2-spar)
	return(list(a,b))
})

rochuge=lapply(hugeout$path,function(x){
	a=1 - sum( (x[row(x)>=col(x)+1] ==0)  & (hout!=0) )/spar
	b=1- sum( (x[row(x)>=col(x)+1] !=0) & (hout==0 ) )/(d*(d-1)/2-spar)
	return(list(a,b))
})

roc=matrix(unlist(roc),nrow=2)
rochuge=matrix(unlist(rochuge),nrow=2)

return(list(roc,rochuge))
},mc.cores=20)

rocplot1= Reduce("+",lapply(out,function(x)x[[1]]))/rep
rocplot2= Reduce("+",lapply(out,function(x)x[[2]]))/rep

plot(rocplot1[1,],rocplot1[2,],type="l",lty=6,xlim=c(0,1),ylim=c(0,1))
points(rocplot2[1,],rocplot2[2,],type="l",lty=1)
legend("bottomleft",c("quasr","skeptic"),lty=c(6,1))
dev.off()


library(plyr) # install.packages("plyr")

# INPUTS
data <- read.csv("../output.csv", sep=",")

tmp.go_projects = data[data$language == "go",]
tmp.c_projects = data[data$language == "c",]

options(scipen=999) # disable scientific notation
boxplot(tmp.c_projects$support, tmp.go_projects$support, log = "y", at = c(1,2), ylim=c(1,300), names = c("C", "Go"))
quantile(tmp.c_projects$support)
quantile(tmp.go_projects$support)

boxplot(tmp.c_projects$confidence, tmp.go_projects$confidence, at = c(1,2), names = c("C", "Go"))
quantile(tmp.c_projects$confidence)
quantile(tmp.go_projects$confidence)

rm(list = ls(pattern = "tmp.*"))


#!/usr/bin/env Rscript
#
# Given a tsv file with strain frequencies, choose the top
# and bottom strains and output to two files.
#
# The input file should have a column labeled "pool" and one
# additional column for every strain.
#
# choose_top_bottom_strains.r <N> <pool> <infile> <out prefix>
#
# Note that in the case of ties, more than N strains can be
# included.
#

cargs = commandArgs(trailingOnly=TRUE)
n = as.numeric(cargs[1])
pool = cargs[2]
infile = cargs[3]
outpre = cargs[4]

x = read.csv(infile, sep='\t', header=TRUE, as.is=TRUE,
             check.names=FALSE)
y = as.numeric(x[x[, 'pool'] == pool, -1])
names(y) = colnames(x)[-1]

ord = order(y)
low = y[ord[n]]
high = y[ord[length(y)-n+1]]

cat(paste(names(y)[y >= high], collapse='\n'), '\n', sep='',
    file=paste0(outpre, '.top.txt'))
cat(paste(names(y)[y <= low], collapse='\n'), '\n', sep='',
    file=paste0(outpre, '.bottom.txt'))

cat(low, '\n')
cat(high, '\n')


markov.generate.state.series <- function(time.series){

  column.names <- colnames(time.series)

  state.series <- time.series
  for(i in 1:nrow(time.series)){
    for(j in 1:ncol(time.series)){
      if(is.na(time.series[i,j])){
        #TODO
      }
      else{
        state.series[i,j] <- paste(column.names[j], time.series[i,j], sep = '.')
      }
    }
  }

  return(state.series)
}

markov.transition.probability <- function(state.series, from.state, to.state){

  from.timepoint <- unlist(strsplit(from.state, ".", fixed = T))[1]
  to.timepoint <- unlist(strsplit(to.state, ".", fixed = T))[1]

  timepoint.states <- state.series[, from.timepoint]
  timepoint.states <- timepoint.states[!is.na(timepoint.states)]
  from.state.count <- count(timepoint.states == from.state)

  to.state.count <- 0
  from.state.count.reduction <- 0

  for (i in 1:nrow(state.series)){

    state.serie <- state.series[i, ]
    from.serie.state <- state.serie[from.timepoint]
    to.serie.state <- state.serie[to.timepoint]

    to.is.empty <- is.null(to.serie.state) || is.na(to.serie.state)
    from.is.empty <- is.null(from.serie.state) || is.na(from.serie.state)

    is.empty <- to.is.empty || from.is.empty

    if (!is.empty && to.serie.state == to.state && from.serie.state == from.state){
      to.state.count <- to.state.count + 1
    }

    if (to.is.empty && !from.is.empty && from.serie.state == from.state){
      from.state.count.reduction <- from.state.count.reduction + 1
    }
  }

  return(to.state.count / (from.state.count - from.state.count.reduction))
}

markov.transition.matrix.for.timepoint.pair <- function(state.series, from.timepoint.states, to.timepoint.states){

  all.pair.states <- c(from.timepoint.states, to.timepoint.states)
  pair.transition.matrix <- matrix(0L, nrow = length(all.pair.states), ncol = length(all.pair.states))
  rownames(pair.transition.matrix) <- all.pair.states
  colnames(pair.transition.matrix) <- all.pair.states

  for (from.state in from.timepoint.states){
    for (to.state in to.timepoint.states){
      i = which(all.pair.states == from.state)
      j = which(all.pair.states == to.state)
      pair.transition.matrix[i,j] <- markov.transition.probability(state.series, from.state, to.state)
    }
  }

  return(pair.transition.matrix)
}

markov.merge.pair.transition.matrix <- function(transition.matrix, pair.transition.matrix){

  for(i in 1:nrow(pair.transition.matrix)){
    for(j in 1:ncol(pair.transition.matrix)){

      row.name <- rownames(pair.transition.matrix)[i]
      column.name <- colnames(pair.transition.matrix)[j]

      i_new <- which(rownames(transition.matrix) == row.name)
      j_new <- which(colnames(transition.matrix) == column.name)

      transition.matrix[i_new, j_new] <- pair.transition.matrix[i, j]
    }
  }

  return(transition.matrix)
}

markov.transition.matrix <- function(time.series, time.point.list = NULL){

  state.series <- markov.generate.state.series(time.series)
  states.per.timepoint <- lapply(1:ncol(state.series), function(i){unique(state.series[,i])})
  states.per.timepoint <- lapply(states.per.timepoint, function(i){i[!is.na(i)]})

  if (is.na(time.point.list) || is.null(time.point.list)){
    time.point.list <- colnames(time.series)
  }

  states.for.selected.timepoints <- c()
  for(time.point in time.point.list){
    time.point.index = which(colnames(time.series) == time.point)
    states.for.selected.timepoints <- c(states.for.selected.timepoints, states.per.timepoint[time.point.index])
  }

  transition.matrix <- matrix(0L, nrow = length(unlist(states.for.selected.timepoints)), ncol = length(unlist(states.for.selected.timepoints)))
  rownames(transition.matrix) <- unlist(states.for.selected.timepoints)
  colnames(transition.matrix) <- unlist(states.for.selected.timepoints)

  for (i in 1:length(states.for.selected.timepoints)){

    from.timepoint.states <- unlist(states.for.selected.timepoints[i])
    to.timepoint.states <- unlist(states.for.selected.timepoints[i+1])

    if (!is.null(to.timepoint.states)){
      pair.transition.matrix <- markov.transition.matrix.for.timepoint.pair(state.series, from.timepoint.states, to.timepoint.states)
      transition.matrix <- markov.merge.pair.transition.matrix(transition.matrix, pair.transition.matrix)
    }
  }

  return(transition.matrix)
}


# # Save the content of all the environment when the custom visual is used in Power BI.
# # This way you can load the same file in RStudio to debug any issue.
# fileRda = "C:/Users/<your-username>/Power-BI-Custom-Visuals/tempData.Rda"
# if(file.exists(dirname(fileRda)))
# {
#   if(Sys.getenv("RSTUDIO")!="")
#     load(file= fileRda)
#   else
#     save(list = ls(all.names = TRUE), file=fileRda)
# }

source('./r_files/flatten_HTML.r')

############### Library Declarations ###############
libraryRequireInstall("ggplot2");
libraryRequireInstall("plotly")
####################################################

################### Actual code ####################
library(RColorBrewer)
library(cowplot)
library(dplyr)

yeo_johnson_transf <- function(data) {
  require(recipes)

  rec <- recipe(data, as.formula(' ~ .'))

  rec <- rec %>%
    step_center( all_numeric() ) %>%
    step_scale( all_numeric() ) %>%
    step_YeoJohnson( all_numeric() )

  prep_rec <- prep( rec, training = data )

  res_list <- list( df_yeojohnson = bake( prep_rec, data ),
                    lambdas = prep_rec$steps[[3]][["lambdas"]] )
}

# This function allow you to keep the first max_factors-1 factors
# of a vector, combining the others ons into the new factor "others"
collapseFactors <- function(vec, max_factors = 8) {

  levs <- levels(vec)

  if (length(levs) >= max_factors) {

    collapsed_vec <- forcats::fct_collapse(vec, others = levs[max_factors:length(levs)])

  } else {

    collapsed_vec <- vec

  }

  return(collapsed_vec)
}

boxplotsGrouped <- function(data, x, y, grp, y_transf_type, x_max_factors = 6, grp_max_factors = 4) {

    yeo_johnson_list <- data %>%
    yeo_johnson_transf()

    transf_data <- yeo_johnson_list$df_yeojohnson

    # Categorical variable on x axis
    x_vec <- factor(data[[x]])
    x_vec <- collapseFactors(x_vec, max_factors = x_max_factors)

    data[[x]] <- x_vec

    # Numeric variable on y axis
    if (y_transf_type == 'yeo-johnson') {

        y_vec <- transf_data[[y]]
        y_label <- paste0('YeoJohnson(', y, ')')

    } else {

        y_vec <- data[[y]]
        y_label <- y

    }

    data[[y]] <- y_vec

    if (is.null(grp)) {

        title <- paste0(y_label, ' vs ', x)

        praincloud <- ggplot(data, aes_string(x = x, y = y, fill = x, color = x)) +
            geom_boxplot(
                width = .12,
                outlier.color = NA,
                outlier.size = 0,
                outlier.shape = NA,
                alpha = .4
            ) +
            geom_point(
                size = 1,
                alpha = .2,
                position = position_jitter(
                    seed = 1, width = .06
                )
            ) +
            scale_fill_brewer(palette = "Set1") +
            scale_color_brewer(palette = "Set1") +
            theme_minimal() +
            theme(
                axis.text.x = element_text(angle = 90, hjust = 1),
                legend.position="none"
            ) +
            labs(
                x = x,
                y = y_label,
                title = title
            )

    } else {

    title <- paste0(y_label, ' vs ', x, ' by ', grp)

    grp_vec <- factor(data[[grp]])
    grp_vec <- collapseFactors(grp_vec, max_factors = grp_max_factors)

    data[[grp]] <- grp_vec

    praincloud <- ggplot(data, aes_string(x = x, y = y, fill = x)) +
        geom_boxplot(
            width = .12,
            outlier.color = NA,
            outlier.size = 0,
            outlier.shape = NA,
            alpha = .4,
            position = position_dodge(0.5)
        ) +
        geom_point(
            aes_string(color = x_vec),
            size = 1,
            alpha = .2,
            position = position_jitterdodge(
                seed = 1, jitter.width = .06, dodge.width = .5
            )
        ) +
        scale_fill_brewer(palette = "Set1") +
        scale_color_brewer(palette = "Set1") +
        theme_minimal() +
        theme(
            axis.text.x = element_text(angle = 90, hjust = 1),
            strip.background = element_rect(fill="grey85"),
            legend.position="none"
        ) +
        labs(
            x = x,
            y = y_label,
            fill = x,
            colour = x,
            title = title
        ) +
        facet_wrap(as.formula(paste0('~', grp)), scale = 'free', nrow = 1)

    }

    return(praincloud)

}

y_transf_name <- 'standard'

if(exists("settings_variable_params_y_transf_name")){
  y_transf_name <- as.character(settings_variable_params_y_transf_name)
}

is_valid_plot <- FALSE

if (exists('x') & exists('y')) {

    categ_var_name <- names(x)
    value_var_name <- names(y)

    dataset <- data.frame(
        x = x,
        y = y
    )

    if (exists('grp')) {

        grp_var_name   <- names(grp)

        dataset <- cbind(dataset, grp = grp)

    } else {
        grp_var_name   <- NULL
    }

    is_valid_plot <- TRUE
}

if (is_valid_plot) {
    rc <- boxplotsGrouped(dataset, categ_var_name, value_var_name, grp_var_name, y_transf_name)
} else {
    rc <- ggplot() + theme_minimal() # Empty plot
}

p <- plotly::ggplotly(rc, tooltip = c('x', 'y'))

# Removing some Plotly modebar icons
disabledButtonsList <- list('toImage', 'sendDataToCloud', 'zoom2d', 'pan', 'pan2d', 'select2d', 'lasso2d', 'hoverClosestCartesian', 'hoverCompareCartesian')
p$x$config$modeBarButtonsToRemove = disabledButtonsList
p <- config(p, staticPlot = FALSE, editable = FALSE, sendData = FALSE, showLink = FALSE,
            displaylogo = FALSE,  collaborate = FALSE, cloud=FALSE)

# Workaround to hide outliers in Plotly
hideOutliers <- function(x) {
  if (x$hoverinfo == 'y') {
    x$marker = list(opacity = 0)
    x$hoverinfo = NA
  }
  return(x)
}

p[["x"]][["data"]] <- purrr::map(p[["x"]][["data"]], ~ hideOutliers(.))

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

############# Create and save widget ###############
internalSaveWidget(p, 'out.html');
####################################################

################ Reduce paddings ###################
ReadFullFileReplaceString('out.html', 'out.html', ',"padding":[0-9]*,', ',"padding":0,')
####################################################


IndexFit<-function(dat,f=1,main="Model 1",ylab="", yf=1970,yl=2014 ,Doleg=F,ylim=c(0,1))
{
  attach(dat)
  require(plotrix)
  x<-paste("Obs_Survey_",f,sep="")
  Data<-get(x)
  d1<-subset(Data,Data[,2]>0)
#  windows(8,8)
  plotCI( d1[,1], d1[,2], 2*d1[,4],
  new=F,
  main=main,
          #Index_names[f],
  cex.main=1.3,
  cex.lab=1.2,
  ylim=ylim, #c(0,(max(d1[,2])*1.9)),
  xlim=c(yf,yl),pch=19,cex=1,
  ylab=ylab,
  xlab="Year",col="blue",scol="black",lab=c(10,10,7)
)

  points(Data[,3]~Data[,1],type="l",col="red",lwd=2)
  points(Data[Data[,2]>0,1],Data[Data[,2]>0,2],type="p",pch=19,col="blue",cex=1)

  if (Doleg){
    text(min(Data[,1])+2,(max(d1[,2])*0.5),"Observed estimate",pos=4,cex=0.8)
    text(min(Data[,1])+2,(max(d1[,2])*0.4),"Model Fit",pos=4,cex=0.8)
    points(min(Data[,1])+2,(max(d1[,2])*0.5),pch=19,col="blue",cex=0.8)
    text(min(Data[,1])+2,(max(d1[,2])*0.4),"--",cex=1.5,col="red")
  }
  detach(dat)
}

Indices<-function(dat=mod1c,Title="Model 1c"){
  # Index fits
  # windows(,11, 6.5)
  par(mfrow=c(2,4), oma=c(0,1,3,1) )
  for(i in 1:length(dat$Index_names))
  {
    if (i==1)
      Doleg=T
    else
      Doleg=F

   IndexFit(dat,f=i,Doleg=Doleg)
  }
  # text(2000,  20, Title , cex=3, col="black",family="sans serif",font=1)
  mtext(Title,3,-0,outer=T, cex=2, col="blue",family="sans",font=2)
}

CatchFit<-function(dat=am1,Title="Model 1"){
 par(mfrow=c(2,2), oma=c(0,1,3,1) )
 for (i in 1:4){
   p.catch.fit(dat,f=i)
 }
 mtext(Title,3,-0,outer=T, cex=2, col="blue",family="sans",font=2)
 }


#################################################
#################################################
# Populations datasets
#################################################
#################################################

#########################################################################################
# Population projections
# Researchers from NCAR’s IAM group and the City University of New York Institute
# for Demographic Research have developed a set of global, spatially explicit population
# scenarios that are consistent with the new Shared Socioeconomic Pathways (SSPs).
# The SSPs describe alternative future pathways of societal change that were developed to
# facilitate global change research, with SSP5 corresponding most closely to the RCP8.5 scenario
# modelled by the UKCP18 projections. A copy of the SSP5 population projections on the OSGB grid
# is available on the data science platform at ~/UKCP18/population/. The original data was
# produced on a slightly different grid, so we’d recommend using the prepared version.
#########################################################################################

pop.nc <- nc_open("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/population/population-projections-ssp5-total.nc")
print(pop.nc)
names(pop.nc$var) #"crs" "ssp"

pop <- brick("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/population/population-projections-ssp5-total.nc")
pop
# Useful information:
#     class      : RasterBrick
#     dimensions : 112, 82, 9184, 11  (nrow, ncol, ncell, nlayers)
#     resolution : 12000, 12000  (x, y)
#     extent     : -216000, 768000, -108000, 1236000  (xmin, xmax, ymin, ymax)
#     crs        : NA
#     source     : population-projections-ssp5-total.nc
#     names      : X20000101, X20100101, X20200101, X20300101, X20400101, X20500101, X20600101, X20700101, X20800101, X20900101, X21000101
#     z-value    : 20000101, 20100101, 20200101, 20300101, 20400101, 20500101, 20600101, 20700101, 20800101, 20900101, 21000101
#     varname    : ssp

plot(popM[[1]])

#################################################
# Manipulation
#################################################

# Masking and cropping according to uk_borders
popM <- mask(pop, uk_borders) %>% crop(uk_borders)

# See population over time
pop_TS <- c(cellStats(popM, sum, na.rm=T))
pop_TS <- ts(pop_TS)
plot(pop_TS) # Population (absolute number) is +/- linear

# Now check the distribution of population over time
# First, I need to get the total pop (pop_TS)
# Then I need to: Dist = pop in each grid / pop_TS
popD2000_2100 <- brick(nrows=109, ncols=55, xmn=0, xmx=660000, ymn=-84000, ymx=1224000 , nl=11)

for (i in 1:nlayers(popM)){
  popD2000_2100[[i]] <- (popM[[i]]  / pop_TS[i] )
}

plot(popD2000_2100[[1]]) # proportion of people per grid cell

# We need to produce other layers for intermediate years
# First layer we have and will use = 2020 (nl = 3)
# Last layer we'll use = 2080 (nl = 9)

2020
2030
2040
2050
2060
2070
2080


extract.range = function(v) {
  r <- c(1, which(diff(v) != 1) + 1, length(v) + 1)
  paste0(collapse=",",
         v[head(r, -1)],
         ifelse(diff(r) == 1,
                "",
                paste0(ifelse(diff(r) == 2, ",", "-"),
                       v[r[-1] - 1])))
}

print(extract.range(c(
    -6, -3, -2, -1, 0, 1, 3, 4, 5, 7, 8, 9, 10, 11, 14, 15, 17, 18, 19, 20)))
print(extract.range(c(
    0, 1, 2, 4, 6, 7, 8, 11, 12, 14, 15, 16, 17, 18, 19, 20, 21, 22,
    23, 24, 25, 27, 28, 29, 30, 31, 32, 33, 35, 36, 37, 38, 39)))


print(paste0(Sys.time(), " --- Paragraph on taxonomic effort"))

####################
# Summary

# Count number of statuses
status <- table(df_all$status)
sum(status)
round(prop.table(status)*100, 1)

####################
# Data processing

# Subset data for describers which made at least 1 description as 1st/2nd auth
df_tax <- df_describers[spp_N_1st_auth_s > 0]; dim(df_tax)

# Calculate difference between "all species"* max and "valid species" max
# *includes subspecies
df_tax$diff <- df_tax$max - df_tax$ns_max

# Author names for those that described non valid species
tax_only_not_valid <- df_tax[ns_spp_N == 0]$full.name.of.describer

# Author names of those describing valid species AND at least 1 synonym
tax_valid_w_one_syn <-
    df_tax[ns_spp_N > 0 & syn_spp_N > 0]$full.name.of.describer

####################
# Tabulation

# Total number of author-years
total_author_years <- dim(df_describers_year)[1]
tax_notvalid_onesyn <- c(tax_only_not_valid, tax_valid_w_one_syn)

# First aspect: -
# Author-years: Only non-valid species
length(tax_only_not_valid) # number of authors

total_1 <- author_years_not_valid <-
    length(df_describers_year[full.name.of.describer %in% tax_only_not_valid]$N)
author_years_not_valid / total_author_years * 100 # proportion for non-valid

# Did not shift the median
summary(df_describers_year$N) # their inclusion
summary(df_describers_year[!full.name.of.describer %in% tax_only_not_valid]$N) # did not shift

# Second aspect: -
# Author-years: At least valid species and at least 1 non-valid species
length(tax_valid_w_one_syn)

# Those without difference
no_diff <- df_tax[full.name.of.describer %in% tax_valid_w_one_syn]$diff==0
round(prop.table(table(no_diff))*100, 1)

# Those with difference
length(df_tax[full.name.of.describer %in% tax_valid_w_one_syn & diff > 0]$diff)

# Median and quantiles
summary(df_tax[full.name.of.describer %in% tax_valid_w_one_syn & diff > 0]$diff)

# Cumulative
total_2 <-
    sum(df_tax[full.name.of.describer %in% tax_valid_w_one_syn & diff > 0]$diff)
total_2

# Total for aspect 1 and 2
(total_1 + total_2) / total_author_years * 100
(total_1 + total_2)

####################
# Plot

# Plot number of authors-years in a density plot
p1 <- ggplot(df_describers_year) +
    geom_density(aes(x = N), alpha = 0.2) +
    xlim(c(0, 20)) + theme

p2 <- ggplot(df_describers_year[!full.name.of.describer %in% tax_only_not_valid]) +
    geom_density(aes(x = N), alpha = 0.2) + xlim(c(0,20)) + theme

grid.arrange(p1, p2) # they look similar


head(beav1, 100)
data(beav1)
beav1$day <- as.factor(beav1$day)
beav1[beav1$day==346,]$time <- 1:sum(beav1$day==346)
beav1[beav1$day==347,]$time <- 1:sum(beav1$day==347)
beav1 <- filter(beav1, time<23)
ggplot(beav1, aes(x=time, y=temp, group=day, fill=day, color=day)) + stat_summary(fun.y = mean, na.rm=TRUE, geom='line')

ggplot(beav1, aes(x=time, y=temp, group=day, fill=day, color=day)) +
  geom_line()

data(beav1)
beav1$day <- as.factor(beav1$day)
beav1[beav1$day==346,]$time <- 1:sum(beav1$day==346)
beav1[beav1$day==347,]$time <- 1:sum(beav1$day==347)
beav1 <- filter(beav1, time<23)
ggplot(beav1, aes(x=time, y=temp, group=day, fill=day, color=day)) +
  stat_summary(fun.y = mean, na.rm=TRUE, geom='line')


library(here)
library(data.table)
library(magrittr)
source(here::here("src", "stroop-rsa-pc.R"))

## build label vectors

target <- gsub("[A-Z]", "", ttypes$all)
distractor <- gsub("[a-z]", "", ttypes$all)
incongruency <- as.character(target != tolower(distractor))

## build feature vectors (indicators)

ftrs_target <- indicator_matrix(target)
ftrs_distractor <- indicator_matrix(distractor)
ftrs_incongruency <- cbind(indicator_matrix(incongruency)[, "TRUE"])
ftrs_conjunction <- indicator_matrix(ttypes$all)
rownames(ftrs_target) <- ttypes$all
rownames(ftrs_distractor) <- ttypes$all
rownames(ftrs_incongruency) <- ttypes$all
rownames(ftrs_conjunction) <- ttypes$all

## make models for crcor: cross-run correlation matrices (with downsampling)

models_cor <- c("target", "distractor", "incongruency", "conjunction")
subsets <- c("all", "bias", "pc50")

l <- list(
    target = ftrs_target,
    distractor = ftrs_distractor,
    incongruency = ftrs_incongruency,
    conjunction = ftrs_conjunction
    )

for (ses in sessions) {
    for (mod in models_cor) {
        for (sub in subsets) {

            conditions_run1 <- ttypes_by_run[[ses]]$run1
            conditions_run2 <- ttypes_by_run[[ses]]$run2

            if (sub == "bias") {
                conditions_run1 <- intersect(ttypes_by_run[[ses]]$run1, ttypes$bias)
                conditions_run2 <- intersect(ttypes_by_run[[ses]]$run2, ttypes$bias)
            } else if (sub == "pc50") {
                conditions_run1 <- intersect(ttypes_by_run[[ses]]$run1, ttypes$pc50)
                conditions_run2 <- intersect(ttypes_by_run[[ses]]$run2, ttypes$pc50)
            }

            x <- l[[mod]]
            X <- tcrossprod(x)[conditions_run1, conditions_run2]
            image(X)
            X <- as.data.table(X, keep.rownames = "run1")
            fwrite(X, here("out", "rsa_models", paste0("model_similarity_", mod, "_", ses, "_", sub, ".csv")))

        }
    }
}

## make models for cveuc: cross-validated euclidean (no downsampling)
models_dis <- c("target", "distractor", "incongruency")

for (ses in sessions) {
    for (mod in models_dis) {
        for (sub in subsets) {

            conditions_run1 <- ttypes_by_run[[ses]]$run1
            conditions_run2 <- ttypes_by_run[[ses]]$run2

            if (sub == "bias") {
                conditions_run1 <- intersect(conditions_run1, ttypes$bias)
                conditions_run2 <- intersect(conditions_run2, ttypes$bias)
            } else if (sub == "pc50") {
                conditions_run1 <- intersect(conditions_run1, ttypes$pc50)
                conditions_run2 <- intersect(conditions_run2, ttypes$pc50)
            }

            x <- l[[mod]]
            x1 <- x[conditions_run1, , drop = FALSE]
            x2 <- x[conditions_run2, , drop = FALSE]
            X <- cvdist(t(x1), t(x2))
            X <- X / abs(max(X)) ## scale so max val is 1
            image(X)
            dimnames(X) <- list(conditions_run1, conditions_run2)
            X <- as.data.table(X, keep.rownames = "run1")
            fwrite(X, here("out", "rsa_models", paste0("model_cvdistance_", mod, "_", ses, "_", sub, ".csv")))

        }
    }
}


#Convert matrix to 1D array

m=matrix(1:12,3,4)
print("Original matrix:")
print(m)
a = as.vector(m)
print("1 dimensional array:")
print(a)


#library(showtext)
library(ggplot2)
#library(sysfonts)

Sys.setlocale("LC_ALL", "C")

monthly_stat_graph <- function(d){

    #Sys.getlocale()
    #Sys.setlocale("LC_ALL","Chinese")
    #l10n_info()
    #sessionInfo()
    #par(family='wqy')
    #getOption("encoding")

    #Encoding("中文")

    print(d)

    plt <- ggplot(data = d, mapping=aes(x=a,y=b)) +
        geom_point(color="#FF851B",shape=0) +
        geom_line(colour="red") +
        #geom_bar(stat="identity") +
         xlab("月份") +
        #intToUtf8(c(20013, 25990))
        scale_x_continuous(breaks=c(1:12), labels=d$e) +
        #c('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec')) +
        #scale_x_continuous("月份\n2014") +
        ylab("利用率 (%)") +
        # ylab(intToUtf8(c(20013, 25991))) +
        ylim(c(80,100)) +
        ggtitle(iconv("2014年设备利用情况","UTF-8","UTF-8")); #iconv

    ggsave(file="plot04.png", width=6, height=3)

}

monthly_data <- data.frame(a=c(1:12),  b =100 - abs(15* sin(c(1:12))),  c1=c(rep(c("Odd","Even"),times=6)),  e=c('一月\nJan', 'Feb', 'Mar', 'Apr', 'May', '六月\nJun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'))

monthly_stat_graph(monthly_data)


movies<-read.csv("C://Users//Harsh Darji//Desktop//movies.csv")

head(movies)

ratings<-read.csv("C://Users//Harsh Darji//Desktop//ratingss.csv")

head(ratings)

#Libraries

library(ggplot2)

install.packages('recommenderlab')

library(recommenderlab)

library(data.table)

# Data Pre-processing

genres<-as.data.frame(movies$genres)

head(genres)

genres2<-as.data.frame(tstrsplit(genres[,1], '[|]', type.convert=TRUE))

head(genres2)

colnames(genres2)<-c(1:10)

## we have 18 genres in total
genre_list<-c("Action","Adventure","Animation","Children","Comedy","Crime","Documentary","Drama","Fantasy","Film-Noir","Horror",
             "Musical","Mystery","Romance","Sci-Fi","Thriller","War","Western")

#empty matrix, 10330=no of movies+1, 18=no of genres
genre_matrix<-matrix(0,10330,18)

#set first row to genre list
genre_matrix[1,]<-genre_list

#set column names to genre list
colnames(genre_matrix)<-genre_list

#iterate through matrix

for (i in 1:nrow(genres2)) {
  for (c in 1:ncol(genres2)) {
    genmat_col = which(genre_matrix[1,] == genres2[i,c])
    genre_matrix[i+1,genmat_col] <- 1
  }
}

#convert into dataframe

 #remove first row, which was the genre list
genre_matrix2 <- as.data.frame(genre_matrix[-1,], stringsAsFactors=FALSE)

 #convert from characters to integers

for (c in 1:ncol(genre_matrix2)) {
  genre_matrix2[,c] <- as.integer(genre_matrix2[,c])
}

head(genre_matrix2)

#Create a matrix to search for a movie by genre:

years <- as.data.frame(movies$title, stringsAsFactors=FALSE)

library(data.table)

head(years)

str(years)

years$`movies$title`<-as.character(years$`movies$title`)

substrRight <- function(x, n){
  substr(x, nchar(x)-n+1, nchar(x))
}

years <- as.data.frame(substr(substrRight(substrRight(years$`movies$title`, 6),5),1,4))

search_matrix <- cbind(movies[,1], substr(movies[,2],1,nchar(movies[,2])-6), years, genre_matrix2)

colnames(search_matrix) <- c("movieId", "title", "year", genre_list)

write.csv(search_matrix, "search.csv")

search_matrix <- read.csv("search.csv", stringsAsFactors=FALSE)

head(search_matrix)

# Example of search an Action movie produced in 1995:
subset(search_matrix, Action == 1 & year == 1995)$title

## Create a user profile

binaryratings <- ratings

# ratings of 4 and 5 are mapped to 1,
# representing likes, and ratings of 3
# and below are mapped to -1,(duslikes)

for (i in 1:nrow(binaryratings)){
  if (binaryratings[i,3] > 3){
    binaryratings[i,3] <- 1
  }
  else{
    binaryratings[i,3] <- -1
  }
}

# convert binaryratings matrix to the correct format:

binaryratings2 <- dcast(binaryratings, movieId~userId, value.var = "rating", na.rm=FALSE)

for (i in 1:ncol(binaryratings2)){
  binaryratings2[which(is.na(binaryratings2[,i]) == TRUE),i] <- 0
}

#remove movieIds col. Rows are movieIds, cols are userIds
binaryratings2 = binaryratings2[,-1]

#Remove rows that are not rated from movies dataset

movieIds <- length(unique(movies$movieId))

ratingmovieIds <- length(unique(ratings$movieId))

movies2 <- movies[-which((movies$movieId %in% ratings$movieId) == FALSE),]

rownames(movies2) <- NULL

#Remove rows that are not rated from genre_matrix2

genre_matrix3 <- genre_matrix2[-which((movies$movieId %in% ratings$movieId) == FALSE),]

rownames(genre_matrix3) <- NULL

# calculate the dot product of the genre matrix and
# the ratings matrix and obtain the user profiles

#Calculate dot product for User Profiles

# here, 668=no of users/raters, 18=no of genres
result = matrix(0,18,668)

for (c in 1:ncol(binaryratings2)){
  for (i in 1:ncol(genre_matrix3)){
    result[i,c] <- sum((genre_matrix3[,i]) * (binaryratings2[,c])) #ratings per genre
  }
}

#Convert to Binary scale

for (c in 1:ncol(result)){
  for (i in 1:nrow(result)){
    if (result[i,c] < 0){
      result[i,c] <- 0
    }
    else {
      result[i,c] <- 1
    }
  }
}

## Assume that users like similar items, and retrieve movies
# that are closest in similarity to a user's profile, which
# represents a user's preference for an item's feature.
# use Jaccard Distance to measure the similarity between user profiles

library(reshape2)

ratingmat <- dcast(ratings, userId~movieId, value.var = "rating", na.rm=FALSE)

#remove userIds
ratingmat <- as.matrix(ratingmat[,-1])

# Method: UBCF
# Similarity Calculation Method: Cosine Similarity
# Nearest Neighbors: 30

#Convert rating matrix into a recommenderlab sparse matrix
ratingmat <- as(ratingmat, "realRatingMatrix")

# Determine how similar the first four users are with each other
# create similarity matrix
similarity_users <- similarity(ratingmat[1:4, ],
                               method = "cosine",
                               which = "users")

as.matrix(similarity_users)

image(as.matrix(similarity_users), main = "User similarity")

 #compute similarity between
# the first four movies
similarity_items <- similarity(ratingmat[, 1:4], method =
                                 "cosine", which = "items")

as.matrix(similarity_items)

image(as.matrix(similarity_items), main = "Item similarity")

# Exploring values of ratings:

vector_ratings <- as.vector(ratingmat@data)

# what are unique values of ratings
unique(vector_ratings)

# what is the count of each rating value
table_ratings <- table(vector_ratings)

table_ratings

# Visualize the rating:

# rating == 0 are NA values

vector_ratings <- vector_ratings[vector_ratings != 0]

vector_ratings <- factor(vector_ratings)

qplot(vector_ratings) +
  ggtitle("Distribution of the ratings")

# Exploring viewings of movies:

# count views for each movie
views_per_movie <- colCounts(ratingmat)

# create dataframe of views
table_views <- data.frame(movie = names(views_per_movie),
                          views = views_per_movie)

# sort by number of views
table_views <- table_views[order(table_views$views,
                                 decreasing = TRUE), ]

ggplot(table_views[1:6, ], aes(x = movie, y = views)) +
  geom_bar(stat="identity") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
  scale_x_discrete(labels=subset(movies2, movies2$movieId == table_views$movie)$title) +
  ggtitle("Number of views of the top movies")

#Visualizing the matrix:

image(ratingmat, main = "Heatmap of the rating matrix")

image(ratingmat[1:10, 1:15], main = "Heatmap of the first rows and columns")

image(ratingmat[rowCounts(ratingmat) > quantile(rowCounts(ratingmat), 0.99),
                 colCounts(ratingmat) > quantile(colCounts(ratingmat), 0.99)],
      main = "Heatmap of the top users and movies")

#Normalize the data

ratingmat_norm <- normalize(ratingmat)

ratingmat_norm <- normalize(ratingmat)
image(ratingmat_norm[rowCounts(ratingmat_norm) > quantile(rowCounts(ratingmat_norm), 0.99),
                colCounts(ratingmat_norm) > quantile(colCounts(ratingmat_norm), 0.99)],
      main = "Heatmap of the top users and movies")

#Create UBFC Recommender Model. UBCF stands for User-Based Collaborative Filtering

recommender_model <- Recommender(ratingmat_norm,
                                 method = "UBCF",
                                 param=list(method="Cosine",nn=30))

model_details <- getModel(recommender_model)

model_details$data

#Obtain top 10 recommendations for 1st user in dataset
recom <- predict(recommender_model,
                 ratingmat[1],
                 n=10)

recom

#convert recommenderlab object to readable list
recom_list <- as(recom,
                 "list")
recom_list

#Obtain recommendations
recom_result <- matrix(0,10)
for (i in 1:10){
  recom_result[i] <- as.character(subset(movies,
                                         movies$movieId == as.integer(recom_list[[1]][i]))$title)
}

recom_result

# Evaluation:

evaluation_scheme <- evaluationScheme(ratingmat,
                                      method="cross-validation",
                                      k=5, given=3,
                                      goodRating=5) #k=5 meaning a 5-fold cross validation. given=3 meaning a Given-3 protocol
evaluation_results <- evaluate(evaluation_scheme,
                               method="UBCF",
                               n=c(1,3,5,10,15,20))
eval_results <- getConfusionMatrix(evaluation_results)[[1]]

#Explore

ratings_movies <- ratingmat[rowCounts(ratingmat) > 50,
                             colCounts(ratingmat) > 50]

ratings_movies

min_movies <- quantile(rowCounts(ratings_movies), 0.98)

min_users <- quantile(colCounts(ratings_movies), 0.98)

image(ratings_movies[rowCounts(ratings_movies) > min_movies,
                     colCounts(ratings_movies) > min_users],
main = "Heatmap of the top users and movies")

average_ratings_per_user <- rowMeans(ratings_movies)

qplot(average_ratings_per_user) + stat_bin(binwidth = 0.1) +
  ggtitle("Distribution of the average rating per user")

### Normalizing data

ratings_movies_norm <- normalize(ratings_movies)

sum(rowMeans(ratings_movies_norm) > 0.00001)

image(ratings_movies_norm[rowCounts(ratings_movies_norm) > min_movies,
                          colCounts(ratings_movies_norm) > min_users],
main = "Heatmap of the top users and movies")

### Binarizing data

#### 1st option: define a matrix equal to 1 if the movie has been watched

ratings_movies_watched <- binarize(ratings_movies, minRating = 1)
min_movies_binary <- quantile(rowCounts(ratings_movies), 0.95)
min_users_binary <- quantile(colCounts(ratings_movies), 0.95)

image(ratings_movies_watched[rowCounts(ratings_movies) > min_movies_binary,
                             colCounts(ratings_movies) > min_users_binary],
main = "Heatmap of the top users and movies")

#### 2nd option: define a matrix equal to 1 if the cell has a rating above the threshold

ratings_movies_good <- binarize(ratings_movies, minRating = 3)

image(ratings_movies_good[rowCounts(ratings_movies) > min_movies_binary,
colCounts(ratings_movies) > min_users_binary],
main = "Heatmap of the top users and movies")

## ITEM-based Collaborative Filtering Model

## Defining training/test sets

which_train <- sample(x = c(TRUE, FALSE),
                      size = nrow(ratings_movies),
                      replace = TRUE,
                      prob = c(0.8, 0.2))

recc_data_train <- ratings_movies[which_train, ]
recc_data_test <- ratings_movies[!which_train, ]

## Building the recommendation model

recommender_models <- recommenderRegistry$get_entries(dataType ="realRatingMatrix")

recommender_models$IBCF_realRatingMatrix$parameters

recc_model <- Recommender(data = recc_data_train,
                          method = "IBCF",
                          parameter = list(k = 30))

recc_model

class(recc_model)

model_details <- getModel(recc_model)

class(model_details$sim)

dim(model_details$sim)

n_items_top <- 20

image(model_details$sim[1:n_items_top, 1:n_items_top],
      main = "Heatmap of the first rows and columns")

row_sums <- rowSums(model_details$sim > 0)

table(row_sums)

col_sums <- colSums(model_details$sim > 0)

qplot(col_sums) + stat_bin(binwidth = 1) + ggtitle("Distribution of the column count")

## Applying recommender system on the dataset:

n_recommended <- 10

recc_predicted <- predict(object = recc_model,
                          newdata = recc_data_test,
                          n = n_recommended)

recc_predicted

recc_user_1 <- recc_predicted@items[[1]] # recommendation for the first user

movies_user_1 <- recc_predicted@itemLabels[recc_user_1]

movies_user_2 <- movies_user_1

for (i in 1:10){
  movies_user_2[i] <- as.character(subset(movies,
                                         movies$movieId == movies_user_1[i])$title)
}

movies_user_2

recc_matrix <- sapply(recc_predicted@items,
                      function(x){ as.integer(colnames(ratings_movies)[x]) }) # matrix with the recommendations for each user
#dim(recc_matrix)
recc_matrix[,1:4]

number_of_items <- factor(table(recc_matrix))

chart_title <- "Distribution of the number of items for IBCF"
qplot(number_of_items) + ggtitle(chart_title)

number_of_items_sorted <- sort(number_of_items, decreasing = TRUE)
number_of_items_top <- head(number_of_items_sorted, n = 4)

table_top <- data.frame(as.integer(names(number_of_items_top)),
                       number_of_items_top)

for (i in 1:4){
  table_top[i,1] <- as.character(subset(movies,
                                         movies$movieId == table_top[i,1])$title)
}

colnames(table_top) <- c("Movie title", "No of items")
head(table_top)

## USER-based Collaborative Filtering Model

recommender_models <- recommenderRegistry$get_entries(dataType ="realRatingMatrix")

recommender_models$UBCF_realRatingMatrix$parameters

recc_model <- Recommender(data = recc_data_train, method = "UBCF")

recc_model
model_details <- getModel(recc_model)

model_details$data

## Applying the recommender model on the test set

n_recommended <- 10

recc_predicted <- predict(object = recc_model,
                          newdata = recc_data_test,
                          n = n_recommended)

recc_predicted

## Explore results

recc_matrix <- sapply(recc_predicted@items,
                      function(x){ as.integer(colnames(ratings_movies)[x]) })

recc_matrix[, 1:4]

number_of_items <- factor(table(recc_matrix))

chart_title <- "Distribution of the number of items for UBCF"
qplot(number_of_items) + ggtitle(chart_title)

number_of_items_sorted <- sort(number_of_items, decreasing = TRUE)
number_of_items_top <- head(number_of_items_sorted, n = 4)

table_top <- data.frame(as.integer(names(number_of_items_top)), number_of_items_top)

for (i in 1:4){
  table_top[i,1] <- as.character(subset(movies,
                                         movies$movieId == table_top[i,1])$title)
}

colnames(table_top) <- c("Movie title", "No of items")
head(table_top)

## Evaluating the Recommender Systems

### Splitting the data

percentage_training <- 0.8

min(rowCounts(ratings_movies))
items_to_keep <- 5 #number of items to generate recommendations
rating_threshold <- 3 # threshold with the minimum rating that is considered good
n_eval <- 1 #number of times to run evaluation

eval_sets <- evaluationScheme(data = ratings_movies,
                              method = "split",
                              train = percentage_training,
                              given = items_to_keep,
                              goodRating = rating_threshold,
                              k = n_eval)

eval_sets

getData(eval_sets, "train") # training set
getData(eval_sets, "known") # set with the items used to build the recommendations
getData(eval_sets, "unknown") # set with the items used to test the recommendation

qplot(rowCounts(getData(eval_sets, "unknown"))) +
  geom_histogram(binwidth = 10) +
  ggtitle("unknown items by the users")

### Bootstrapping the data

eval_sets <- evaluationScheme(data = ratings_movies,
                              method = "bootstrap",
                              train = percentage_training,
                              given = items_to_keep,
                              goodRating = rating_threshold,
                              k = n_eval)

table_train <- table(eval_sets@runsTrain[[1]])
n_repetitions <- factor(as.vector(table_train))

qplot(n_repetitions) +
  ggtitle("Number of repetitions in the training set")

### Using cross-validation to validate models

n_fold <- 4
eval_sets <- evaluationScheme(data = ratings_movies,
                              method = "cross-validation",
                              k = n_fold,
                              given = items_to_keep,
                              goodRating = rating_threshold)

size_sets <- sapply(eval_sets@runsTrain, length)
size_sets

## Evavluating the ratings

eval_sets <- evaluationScheme(data = ratings_movies,
                              method = "cross-validation",
                              k = n_fold,
                              given = items_to_keep,
                              goodRating = rating_threshold)

model_to_evaluate <- "IBCF"
model_parameters <- NULL

eval_recommender <- Recommender(data = getData(eval_sets, "train"),
                                method = model_to_evaluate,
                                parameter = model_parameters)

items_to_recommend <- 10

eval_prediction <- predict(object = eval_recommender,
                           newdata = getData(eval_sets, "known"),
                           n = items_to_recommend,
                           type = "ratings")

qplot(rowCounts(eval_prediction)) +
  geom_histogram(binwidth = 10) +
  ggtitle("Distribution of movies per user")

eval_accuracy <- calcPredictionAccuracy(x = eval_prediction,
                                        data = getData(eval_sets, "unknown"),
                                        byUser = TRUE)

head(eval_accuracy)

qplot(eval_accuracy[, "RMSE"]) +
  geom_histogram(binwidth = 0.1) +
  ggtitle("Distribution of the RMSE by user")

eval_accuracy <- calcPredictionAccuracy(x = eval_prediction,
                                        data = getData(eval_sets, "unknown"),
                                        byUser = FALSE)

eval_accuracy

## Evaluating the recommendations

results <- evaluate(x = eval_sets,
                    method = model_to_evaluate,
                    n = seq(10, 100, 10))

head(getConfusionMatrix(results)[[1]])

columns_to_sum <- c("TP", "FP", "FN", "TN")
indices_summed <- Reduce("+", getConfusionMatrix(results))[, columns_to_sum]
head(indices_summed)

plot(results, annotate = TRUE, main = "ROC curve")

plot(results, "prec/rec", annotate = TRUE, main = "Precision-recall")

## Comparing models

models_to_evaluate <- list(
IBCF_cos = list(name = "IBCF",
                param = list(method = "cosine")),
IBCF_cor = list(name = "IBCF",
                param = list(method = "pearson")),
UBCF_cos = list(name = "UBCF",
                param = list(method = "cosine")),
UBCF_cor = list(name = "UBCF",
                param = list(method = "pearson")),
random = list(name = "RANDOM", param=NULL)
)

n_recommendations <- c(1, 5, seq(10, 100, 10))

list_results <- evaluate(x = eval_sets,
                         method = models_to_evaluate,
                         n = n_recommendations)

sapply(list_results, class) == "evaluationResults"

avg_matrices <- lapply(list_results, avg)
head(avg_matrices$IBCF_cos[, 5:8])

## Identifying the most suitable model

plot(list_results, annotate = 1, legend = "topleft")
title("ROC curve")

## Optimizing a numeric parameter

vector_k <- c(5, 10, 20, 30, 40)
models_to_evaluate <- lapply(vector_k, function(k){
  list(name = "IBCF",
       param = list(method = "cosine", k = k))
})

names(models_to_evaluate) <- paste0("IBCF_k_", vector_k)

n_recommendations <- c(1, 5, seq(10, 100, 10))
list_results <- evaluate(x = eval_sets,
                         method = models_to_evaluate,
                         n = n_recommendations)

plot(list_results, annotate = 1, legend = "topleft")
title("ROC curve")

plot(list_results, "prec/rec", annotate = 1, legend = "bottomright")
title("Precision-recall")

Project - Movie Recommendation System/Final Project code.r


library(scales)
library(ggplot2)
library(gridExtra)
library(data.table)
library(RColorBrewer)

args <- commandArgs(trailingOnly = TRUE)

file1 <- args[1]
file2 <- args[2]
call <- args[3]
date1 <- args[4]
date2 <- args[5]

# file1 <- 'wsprspots-2016-04-SWLJO20.csv'
# file2 <- 'wsprspots-2016-04-per-hour-SWLJO20.png'
# call <- 'SWLJO20'
# date1 <- '2016-04-01'
# date2 <- '2016-12-31'

colNames <- c('id', 'epoch', 'rcall',
  'rgrid', 'snr', 'freq', 'call',
  'grid', 'power', 'drift', 'distance',
  'azimuth', 'band', 'version', 'code')
colClasses = c('numeric', 'numeric', 'character',
  'character', 'numeric', 'numeric', 'character',
  'character', 'numeric', 'numeric', 'numeric',
  'numeric', 'numeric', 'character', 'numeric')

spots <- as.data.table(read.table(file1, header = F, sep = ',', col.names = colNames, colClasses = colClasses))

spots[, time := as.POSIXct(epoch, origin = '1970-01-01')]

bands <- c(0, 1, 3, 5, 7, 10, 14, 18, 21, 24, 28, 50)
names <- c('MF', '160m', '80m', '60m', '40m', '30m', '20m', '17m', '15m', '12m', '10m', '6m')

for(i in 1:length(bands))
{
  spots[band == bands[i], name := names[i]]
}

subset <- spots[time >= as.POSIXct(paste0(date1, ' 00:00:00')) & time <= as.POSIXct(paste0(date2, ' 23:59:59'))]

palette <- rev(brewer.pal(length(names), 'Set3'))
names(palette) <- names

png(file2, width = 760, height = 570, res = 120)

ggplot(data = subset, aes(time, fill = factor(name, levels = names))) +
  geom_histogram(binwidth = 3600) +
  scale_fill_manual(values = palette) +
  scale_x_datetime(breaks = date_breaks('1 day'), minor_breaks = date_breaks('1 hour')) +
  guides(fill = guide_legend(title = NULL, reverse = TRUE)) +
  theme(axis.text.x = element_text(angle = 45)) +
  labs(title = paste0('Number of WSPR spots per hour (', call, ')')) +
  labs(x = '', y = '')

dev.off()

# ggplot(data = subset(subset, band == '40m'), aes(azimuth, distance)) + geom_point() + coord_polar() + scale_x_continuous(breaks = seq(0, 360, 30), limits = c(0, 360))


# Pool LMER Estimated Marginal Means (EMM) of imputed data from the Fear Generalization Task (FGT) in the SAM study
# written by Rosalie Gorter, adapted by Milou Sep (function created)
# Last version 16.1.19

library(emmeans) # to calculate EMMs
library(ggplot2) # to visualize EMMs

# EMM Trialtype -----------------------------------------------------------

pool.means.trialtype <- function(model, m, phase){
  # model is the largest model, m is number of imputations, phase is "ACQ" or "TEST"

  results<-list()
  for(i in 1:m){#place emmeans() results for every imputation in list
    results[i]<-list(emmeans(model[[4]][[i]],
                             pairwise ~ trialtype, #set contrasts
                             adjust="tukey",#p-value adjustment for multiple comparisons family wise (note: Benjamini-Hochberg correction is not appropriate here because p-values are not independent http://www-stat.wharton.upenn.edu/~steele/Courses/956/Resource/MultipleComparision/Writght92.pdf)
                             lmer.df = "kenward-roger"))
  }

  # # To check:
  # model[[4]][[1]]
  # results[[1]]
  # results[[1]]$emmeans
  # data.frame(results[[1]][1]$emmeans)$emmean
  # data.frame(results[[i]][1]$emmeans)$SE

  # pool parameters according to rubins rules
  # Rubin DB. Inference and missing data. Biometrika. 1976;63:581-92.
  # Marshall A, Altman DG, Holder RL, Royston P. Combining estimates of interest in prognostic modelling studies after multiple imputation: current practice and guidelines. BMC Med Res Methodol. 2009;9:57. doi:10.1186/1471-2288-9-57.
  # steps: calculate pooled parameter; calculate pooled standard error (pse); used pse to calculate 95% CI

  # Combine all imputed values into pooled mean and variance and 95% CI

  if (phase == "ACQ"){
  Qhat<-matrix(NA,ncol=m,nrow=2) #estimated means for every imputed dataset
  rownames(Qhat)<-c("mean.Threat","mean.Safe")
  colnames(Qhat)<-c(paste("imp.",1:m,sep=""))

  U_i<-matrix(NA,ncol=m,nrow=2) #estimated variance per imputed dataset associated with mean
  rownames(U_i)<-c("SE.Threat","SE.Safe")
  colnames(U_i)<-c(paste("imp.",1:m,sep=""))

  } else if (phase == "TEST"){
    Qhat<-matrix(NA,ncol=m,nrow=3) #estimated means for every imputed dataset
    rownames(Qhat)<-c("mean.Threat","mean.Safe", "mean.New")
    colnames(Qhat)<-c(paste("imp.",1:m,sep=""))

    U_i<-matrix(NA,ncol=m,nrow=3) #estimated variance per imputed dataset associated with mean
    rownames(U_i)<-c("SE.Threat","SE.Safe", "SE.New")
    colnames(U_i)<-c(paste("imp.",1:m,sep=""))
  }

  for(i in 1:m){ #place estimates per imputation in matrix
    Qhat[,i]<-data.frame(results[[i]][1]$emmeans)$emmean
    U_i[,i]<-data.frame(results[[i]][1]$emmeans)$SE
  }

  #pool means and se's
  Ubar<-rowMeans(U_i) #within imputation variance
  B<-(1/(m-1)) * rowSums((Qhat-rowMeans(Qhat))^2)#between imputation variance
  Total.var <-Ubar+B #Total variance
  Qbar<-rowMeans(Qhat) #pooled means (overall point estimate)
  r_m<-(1+m^-1)*B/Ubar #relative increase in variance
  nu<-(m-1)*(1+r_m)^2 #degrees of freedom t reference distribution
  results[[1]]
  t.bound<-abs(qt(0.05/2, nu))#calculate t values for boundaries 95% CI based on adjusted df (nu)

  lower.95<-Qbar-t.bound*Total.var^(1/2) #rubin1987 p77
  upper.95<-Qbar+t.bound*Total.var^(1/2)

  pooled.results.means<-data.frame(cbind(Qbar,Total.var,lower.95,upper.95))
  return(pooled.results.means) #pooled estimates per Condition
}

# EMM Condition -----------------------------------------------------------

pool.means.condition <- function(model, m){
  # model is the largest model, m is number of imputations
  results<-list()
  for(i in 1:m){#place emmeans() results for every imputation in list
    results[i]<-list(emmeans(model[[4]][[i]],
                             pairwise ~ Condition, #set contrasts
                             adjust="tukey",#p-value adjustment for multiple comparisons family wise (note: Benjamini-Hochberg correction is not appropriate here because p-values are not independent http://www-stat.wharton.upenn.edu/~steele/Courses/956/Resource/MultipleComparision/Writght92.pdf)
                             lmer.df = "kenward-roger"))
  }

  # pool parameters according to rubins rules
  # Rubin DB. Inference and missing data. Biometrika. 1976;63:581-92.
  # Marshall A, Altman DG, Holder RL, Royston P. Combining estimates of interest in prognostic modelling studies after multiple imputation: current practice and guidelines. BMC Med Res Methodol. 2009;9:57. doi:10.1186/1471-2288-9-57.
  # steps: calculate pooled parameter; calculate pooled standard error; used pse to calculate 95% CI

  # Combine all imputed values into pooled mean and variance and 95% CI

  Qhat<-matrix(NA,ncol=m,nrow=3) #estimated means for every imputed dataset
  rownames(Qhat)<-c("mean.Delayed.Stress","mean.Direct.Stress", "mean.No.Stress")
  colnames(Qhat)<-c(paste("imp.",1:m,sep=""))

  U_i<-matrix(NA,ncol=m,nrow=3) #estimated variance per imputed dataset associated with mean
  rownames(U_i)<-c("SE.Delayed.Stress","SE.Direct.Stress", "SE.No.Stress")
  colnames(U_i)<-c(paste("imp.",1:m,sep=""))

  for(i in 1:m){ #place estimates per imputation in matrix
    Qhat[,i]<-data.frame(results[[i]][1]$emmeans)$emmean
    U_i[,i]<-data.frame(results[[i]][1]$emmeans)$SE
  }

  #pool means and se's
  Ubar<-rowMeans(U_i) #within imputation variance
  B<-(1/(m-1)) * rowSums((Qhat-rowMeans(Qhat))^2)#between imputation variance
  Total.var <-Ubar+B #Total variance
  Qbar<-rowMeans(Qhat) #pooled means (overall point estimate)
  r_m<-(1+m^-1)*B/Ubar #relative increase in variance
  nu<-(m-1)*(1+r_m)^2 #degrees of freedom t reference distribution
  results[[1]]
  t.bound<-abs(qt(0.05/2, nu))#calculate t values for bounderies 95% CI based on adjusted df (nu)

  lower.95<-Qbar-t.bound*Total.var^(1/2) #rubin1987 p77
  upper.95<-Qbar+t.bound*Total.var^(1/2)

  pooled.results.means<-data.frame(cbind(Qbar,Total.var,lower.95,upper.95))
  return(pooled.results.means) #pooled estimates per Condition
}

# Function to plot mean epochs follow-up analyses -------------------------
Trialtype.PlotD2 <- function(dataset_to_plot, x, y){
  plot2<-
    ggplot(data=dataset_to_plot, aes(x, y)) +
    theme_classic() +
    ylab('FPS \n (mean+/-95%CI)') + xlab("") +   # axis labels & title
    scale_x_discrete(limits=c("mean.Threat","mean.Safe","mean.New"), # Change order x-axis
                     labels=c("Threat ", "Safe", "New ")) +
    scale_fill_manual( # Colours: http://sape.inf.usi.ch/quick-reference/ggplot2/colour
      values= c( Safe = "navyblue", Threat = "red3", New = "black")) +
    # labels =c(Delayed = "delayed-stress",
    #           Direct = "direct-stress",
    #           Control = "no-stress")) +
    # adjust fontsize legend
    theme(legend.title=element_text(size=12), legend.text=element_text(size=9))+
    # Add mean & CI's
    geom_bar(stat="identity", position = position_dodge(.9), alpha=.8) +
    geom_errorbar(aes(ymin=lower.95, ymax=upper.95), width=.2, position=position_dodge(.9))

  return(plot2)
}


library(rbenchmark)
reps <- 100
cols <- c("test", "replications", "elapsed", "relative")

m <- 2000
n <- 200
x <- matrix(rnorm(m*n), m, n)

benchmark(coop::cosine(x), lsa::cosine(x), columns=cols, replications=reps)