#!/usr/bin/Rscript
library(ggplot2)
library(plyr)
library(dplyr)
library(stringr)
library(brms)
library(emmeans)
library(tidybayes)
library(modelr)
library(bayestestR)

filename <- 'data/cat_20190205_flower_E6.csv'

memData <- subset(read.csv(filename, header=T), task=='test')
memData$response <- ifelse(memData$wasCorrect, memData$isOld, 1 - memData$isOld)
memData$RT <- memData$RT / 1000
memData$isPracticed <- as.factor(memData$isPracticed)
memData$isInstructed <- as.factor(memData$isInstructed)
memData$isTarget <- as.factor(memData$isTarget)
memData$isFoil <- as.factor(memData$isFoil)
memData$isOld <- as.factor(memData$isOld)

writeLines(sprintf('Total number of subjects: %d (%d trials)',
                   length(unique(memData$subject)),
                   nrow(memData)))

## exclude subjects with low learning accuracy
learnData <- subset(read.csv(filename, header=T), task=='learn' & isPracticed==1)
endAcc <- aggregate(wasCorrect~subject, learnData,
                    function (trials) mean(tail(trials, 20)))
excluded = endAcc$subject[endAcc$wasCorrect < 0.85]
memData <- memData[!(memData$subject %in% excluded),]
learnData <- learnData[!(learnData$subject %in% excluded),]

## exclude trials with high RT
writeLines(sprintf('Mean RT+3SD: %f', mean(memData$RT) + 3*sd(memData$RT)))
memData <- memData[memData$RT >= mean(memData$RT) - 3*sd(memData$RT) &
                   memData$RT <= mean(memData$RT) + 3*sd(memData$RT),]

writeLines(sprintf('After exclusion: %d subjects (%d trials)',
                   length(unique(memData$subject)),
                   nrow(memData)))

startAcc <- aggregate(wasCorrect~subject+isInstructed, learnData,
                      function (trials) mean(head(trials, 10)))
endAcc <- aggregate(wasCorrect~subject+isInstructed, learnData,
                    function (trials) mean(tail(trials, 10)))
writeLines(sprintf('Instructed: %f -> %f',
                   mean(subset(startAcc, isInstructed==1)$wasCorrect),
                   mean(subset(endAcc, isInstructed==1)$wasCorrect)))
writeLines(sprintf('Not Instructed: %f -> %f',
                   mean(subset(startAcc, isInstructed==0)$wasCorrect),
                   mean(subset(endAcc, isInstructed==0)$wasCorrect)))

memData %>% select(isPracticed, isInstructed, subject) %>%
    group_by(isPracticed, isInstructed) %>%
    summarise(N=length(unique(subject)))

mRT <- brm(bf(RT ~ isPracticed*isInstructed*isTarget*isFoil*isOld +
                  (1+isOld*isTarget*isFoil || subject),
              beta ~ isPracticed*isInstructed*isTarget*isFoil*isOld +
                  (1+isOld*isTarget*isFoil || subject),
              sigma ~ (1 || subject)),
           prior=c(set_prior('normal (0, 2.5)'),
                   set_prior('normal (0, 1)', dpar='beta')),
           family=exgaussian(link="identity"), inits="0", sample_prior=TRUE,
           chains=5, cores=5, iter=4000, warmup=1000, thin=3,
           control=list(adapt_delta=0.9),
           file='brms_RT_exgaussian', data=memData)
posteriorRT <- describe_posterior(mRT, ci=0.95, rope_ci=0.95)
print(posteriorRT)
posteriorRT %>%
    mutate(Parameter=str_replace(str_replace(str_replace(str_replace(str_replace(
               str_remove_all(Parameter, '\\d|b_'),
               'isInstructed', 'I'),
               'isPracticed', 'P'),
               'isTarget', 'L'),
               'isFoil', 'NL'),
               'isOld', 'O'),
           Median=sprintf('%1.2f', Median),
           HDI=sprintf('[%1.2f, %1.2f]', CI_low, CI_high),
           pd=sprintf('%1.2f', pd),
           ROPE=sprintf('[%1.2f, %1.2f]', ROPE_low, ROPE_high),
           ROPE_Percentage=sprintf('%1.2f', ROPE_Percentage)) %>%
    select(Parameter, Median, HDI, pd, ROPE, ROPE_Percentage) %>%
    write.csv('E6_RT_posterior.csv')

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

writeLines('\n\nHits')
hits <- subset(memData, isOld==1)
FAs  <- subset(memData, isOld==0)
FAs$wasCorrect <- 1-FAs$wasCorrect

mHits <- brm(wasCorrect ~ isPracticed*isInstructed*isTarget*isFoil +
                 (1+isTarget*isFoil||subject),
             family="bernoulli", prior=c(set_prior('normal (0, 4)')),
             sample_prior=TRUE,
             chains=5, iter=2500, warmup=1000, cores=5, file='brms_hits', data=hits)
posteriorHits <- describe_posterior(mHits, ci=0.95, rope_ci=0.95,
                                    rope_range=c(-0.15, 0.15))
print(posteriorHits)
posteriorHits %>%
    mutate(Parameter=str_replace(str_replace(str_replace(str_replace(
               str_remove_all(Parameter, '\\d|b|_'),
               'isInstructed', 'I'),
               'isPracticed', 'P'),
               'isTarget', 'L'),
               'isFoil', 'NL'),
           Median=sprintf('%1.2f', Median),
           HDI=sprintf('[%1.2f, %1.2f]', CI_low, CI_high),
           pd=sprintf('%1.2f', pd),
           ROPE=sprintf('[%1.2f, %1.2f]', ROPE_low, ROPE_high),
           ROPE_Percentage=sprintf('%1.2f', ROPE_Percentage)) %>%
    select(Parameter, Median, HDI, pd, ROPE, ROPE_Percentage) %>%
    write.csv('E6_hits_posterior.csv')

eHits <- hits %>%
    data_grid(isPracticed, isInstructed, isTarget, isFoil) %>%
    add_fitted_draws(mHits, re_formula=NA) %>%
    rename(Practice=isPracticed, Instruction=isInstructed,
           Learned=isTarget, NotLearned=isFoil) %>%
    median_hdi()

png('E6_hits_fit.png', height=500, width=1000)
ggplot(eHits, aes(x=interaction(NotLearned, Learned), y=.value,
                      group=interaction(Practice, Instruction),
                      color=interaction(Practice, Instruction))) +
    geom_point(size=5, position=position_dodge(width=.5)) +
    geom_errorbar(aes(ymin=.lower, ymax=.upper), width=.2,
                  position=position_dodge(width=.5)) +
    theme_classic() + ylab('Hit Rate') +
    scale_x_discrete(labels=c('Neither', 'NotLearned', 'Learned', 'Both')) +
    scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
    theme(axis.text=element_text(size=20),
          axis.title.x=element_blank(),
          axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
          legend.title=element_blank(),
          legend.text=element_text(size=20),
          plot.margin=margin(t=1, b=1, unit='cm'))
dev.off()

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

writeLines('\n\nFAs')
mFAs <- brm(wasCorrect ~ isPracticed*isInstructed*isTarget*isFoil +
                (1+isTarget*isFoil||subject),
            family="bernoulli", prior=c(set_prior('normal (0, 4)')),
            sample_prior=TRUE,
            chains=5, iter=2500, warmup=1000, cores=5, file='brms_FAs', data=FAs)
posteriorFAs <- describe_posterior(mFAs, ci=0.95, rope_ci=0.95,
                                   rope_range=c(-0.15, 0.15))
print(posteriorFAs)
posteriorFAs %>%
    mutate(Parameter=str_replace(str_replace(str_replace(str_replace(
               str_remove_all(Parameter, '\\d|b|_'),
               'isInstructed', 'I'),
               'isPracticed', 'P'),
               'isTarget', 'L'),
               'isFoil', 'NL'),
           Median=sprintf('%1.2f', Median),
           HDI=sprintf('[%1.2f, %1.2f]', CI_low, CI_high),
           pd=sprintf('%1.2f', pd),
           ROPE=sprintf('[%1.2f, %1.2f]', ROPE_low, ROPE_high),
           ROPE_Percentage=sprintf('%1.2f', ROPE_Percentage)) %>%
    select(Parameter, Median, HDI, pd, ROPE, ROPE_Percentage) %>%
    write.csv('E6_FAs_posterior.csv')

eFAs <- FAs %>%
    data_grid(isPracticed, isInstructed, isTarget, isFoil) %>%
    add_fitted_draws(mFAs, re_formula=NA) %>%
    rename(Practice=isPracticed, Instruction=isInstructed,
           Learned=isTarget, NotLearned=isFoil) %>%
    median_hdi()

png('E6_FAs_fit.png', height=500, width=1000)
ggplot(eFAs, aes(x=interaction(NotLearned, Learned), y=.value,
                      group=interaction(Practice, Instruction),
                      color=interaction(Practice, Instruction))) +
    geom_point(size=5, position=position_dodge(width=.5)) +
    geom_errorbar(aes(ymin=.lower, ymax=.upper), width=.2,
                  position=position_dodge(width=.5)) +
    theme_classic() + ylab('FA Rate') +
    scale_x_discrete(labels=c('Neither', 'NotLearned', 'Learned', 'Both')) +
    scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
    theme(axis.text=element_text(size=20),
          axis.title.x=element_blank(),
          axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
          legend.title=element_blank(),
          legend.text=element_text(size=20),
          plot.margin=margin(t=1, b=1, unit='cm'))
dev.off()

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

writeLines('\n\nSDT')
mSDT <- brm(response ~ isPracticed*isInstructed*isTarget*isFoil*isOld
            + (1 + isOld*isTarget*isFoil || subject),
            family=bernoulli(link='probit'), file='brms_sdt',
            prior=set_prior('normal (0, 2)'), sample_prior=TRUE,
            chains=5, iter=2500, warmup=1000, cores=5, data=memData)
posteriorSDT <- describe_posterior(mSDT, ci=0.95, rope_ci=0.95,
                                   rope_range=c(-0.075, 0.075))
print(posteriorSDT)
posteriorSDT %>%
    mutate(Parameter=str_replace(str_replace(str_replace(str_replace(str_replace(
               str_remove_all(Parameter, '\\d|b_'),
               'isInstructed', 'I'),
               'isPracticed', 'P'),
               'isTarget', 'L'),
               'isFoil', 'NL'),
               'isOld', 'O'),
           Median=sprintf('%1.2f', Median),
           HDI=sprintf('[%1.2f, %1.2f]', CI_low, CI_high),
           pd=sprintf('%1.2f', pd),
           ROPE=sprintf('[%1.2f, %1.2f]', ROPE_low, ROPE_high),
           ROPE_Percentage=sprintf('%1.2f', ROPE_Percentage)) %>%
    select(Parameter, Median, HDI, pd, ROPE, ROPE_Percentage) %>%
    write.csv('E6_SDT_posterior.csv')

sdt.fit <- memData %>% data_grid(isPracticed, isInstructed,
                                 isTarget, isFoil, isOld) %>%
    add_fitted_draws(mSDT, re_formula=NA, scale='linear') %>%
    rename(Practice=isPracticed, Instruction=isInstructed,
           Learned=isTarget, NotLearned=isFoil)

eC <- sdt.fit %>% subset(isOld==0) %>% mutate(.value=-1*.value) %>% median_hdi()
eDPrime <- sdt.fit %>% compare_levels(.value, by=isOld) %>% median_hdi()

png('E6_sensitivity_fit.png', height=500, width=1000)
ggplot(eDPrime,
       aes(x=interaction(NotLearned, Learned), y=.value,
           group=interaction(Practice, Instruction),
           color=interaction(Practice, Instruction))) +
    geom_point(size=5, position=position_dodge(width=.5)) +
    geom_errorbar(aes(ymin=.lower, ymax=.upper), width=.2,
                  position=position_dodge(width=.5)) +
    theme_classic() + ylab('Sensitivity (d\')') +
    scale_x_discrete(labels=c('Neither', 'NotLearned', 'Learned', 'Both')) +
    scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
    theme(axis.text=element_text(size=20),
          axis.title.x=element_blank(),
          axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
          legend.title=element_blank(),
          legend.text=element_text(size=20),
          plot.margin=margin(t=1, b=1, unit='cm'))
dev.off()

png('E6_bias_fit.png', height=500, width=1000)
ggplot(eC,
       aes(x=interaction(NotLearned, Learned), y=.value,
           group=interaction(Practice, Instruction),
           color=interaction(Practice, Instruction))) +
    geom_point(size=5, position=position_dodge(width=.5)) +
    geom_errorbar(aes(ymin=.lower, ymax=.upper), width=.2,
                  position=position_dodge(width=.5)) +
    theme_classic() + ylab('Bias (C)') +
    scale_x_discrete(labels=c('Neither', 'NotLearned', 'Learned', 'Both')) +
    scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
    theme(axis.text=element_text(size=20),
          axis.title.x=element_blank(),
          axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
          legend.title=element_blank(),
          legend.text=element_text(size=20),
          plot.margin=margin(t=1, b=1, unit='cm'))
dev.off()

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

writeLines('\n\nRT')
mRT <- brm(bf(RT ~ isPracticed*isInstructed*isTarget*isFoil*isOld +
                  (1+isOld*isTarget*isFoil || subject),
              beta ~ isPracticed*isInstructed*isTarget*isFoil*isOld +
                  (1+isOld*isTarget*isFoil || subject),
              sigma ~ (1 || subject)),
           prior=c(set_prior('normal (0, 2.5)'),
                   set_prior('normal (0, 1)', dpar='beta')),
           family=exgaussian(link="identity"), inits="0", sample_prior=TRUE,
           chains=5, cores=5, iter=4000, warmup=1000, thin=3,
           control=list(adapt_delta=0.9),
           file='brms_RT_exgaussian', data=memData)
posteriorRT <- describe_posterior(mRT, ci=0.95, rope_ci=0.95)
print(posteriorRT)
posteriorRT %>%
    mutate(Parameter=str_replace(str_replace(str_replace(str_replace(str_replace(
               str_remove_all(Parameter, '\\d|b_'),
               'isInstructed', 'I'),
               'isPracticed', 'P'),
               'isTarget', 'L'),
               'isFoil', 'NL'),
               'isOld', 'O'),
           Median=sprintf('%1.2f', Median),
           HDI=sprintf('[%1.2f, %1.2f]', CI_low, CI_high),
           pd=sprintf('%1.2f', pd),
           ROPE=sprintf('[%1.2f, %1.2f]', ROPE_low, ROPE_high),
           ROPE_Percentage=sprintf('%1.2f', ROPE_Percentage)) %>%
    select(Parameter, Median, HDI, pd, ROPE, ROPE_Percentage) %>%
    write.csv('E6_RT_posterior.csv')

eRT <- memData %>%
    data_grid(isPracticed, isInstructed, isTarget, isFoil, isOld) %>%
    add_fitted_draws(mRT, re_formula=NA, dpar='beta') %>%
    rename(Practice=isPracticed, Instruction=isInstructed,
           Learned=isTarget, NotLearned=isFoil) %>%
    mutate(mu=.value-beta) %>%  ## get the mean of the normal component
    median_hdi()

png('E6_RT_fit.png', height=500, width=1000)
ggplot(eRT, aes(x=interaction(NotLearned, Learned), y=.value,
                      group=interaction(Practice, Instruction),
                      color=interaction(Practice, Instruction))) +
    facet_grid( ~ isOld, labeller=label_both) +
    geom_point(size=5, position=position_dodge(width=.5)) +
    geom_errorbar(aes(ymin=.value.lower, ymax=.value.upper), width=.2,
                  position=position_dodge(width=.5)) +
    theme_classic() + ylab('Reaction Time') +
    scale_x_discrete(labels=c('Neither', 'NotLearned', 'Learned', 'Both')) +
    scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
    theme(axis.text=element_text(size=20),
          axis.title.x=element_blank(),
          axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
          legend.title=element_blank(),
          legend.text=element_text(size=20),
          plot.margin=margin(t=1, b=1, unit='cm'))
dev.off()

png('E6_RT_mu_fit.png', height=500, width=1000)
ggplot(eRT, aes(x=interaction(NotLearned, Learned), y=mu,
                      group=interaction(Practice, Instruction),
                      color=interaction(Practice, Instruction))) +
    facet_grid( ~ isOld, labeller=label_both) +
    geom_point(size=5, position=position_dodge(width=.5)) +
    geom_errorbar(aes(ymin=mu.lower, ymax=mu.upper), width=.2,
                  position=position_dodge(width=.5)) +
    theme_classic() + ylab('Reaction Time') +
    scale_x_discrete(labels=c('Neither', 'NotLearned', 'Learned', 'Both')) +
    scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
    theme(axis.text=element_text(size=20),
          axis.title.x=element_blank(),
          axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
          legend.title=element_blank(),
          legend.text=element_text(size=20),
          plot.margin=margin(t=1, b=1, unit='cm'))
dev.off()

png('E6_RT_beta_fit.png', height=500, width=1000)
ggplot(eRT, aes(x=interaction(NotLearned, Learned), y=beta,
                      group=interaction(Practice, Instruction),
                      color=interaction(Practice, Instruction))) +
    facet_grid( ~ isOld, labeller=label_both) +
    geom_point(size=5, position=position_dodge(width=.5)) +
    geom_errorbar(aes(ymin=beta.lower, ymax=beta.upper), width=.2,
                  position=position_dodge(width=.5)) +
    theme_classic() + ylab('Reaction Time') +
    scale_x_discrete(labels=c('Neither', 'NotLearned', 'Learned', 'Both')) +
    scale_color_discrete(labels=c('Neither', 'Practiced', 'Instructed', 'Both')) +
    theme(axis.text=element_text(size=20),
          axis.title.x=element_blank(),
          axis.title.y=element_text(size=36, margin=margin(r=0.5, unit='cm')),
          legend.title=element_blank(),
          legend.text=element_text(size=20),
          plot.margin=margin(t=1, b=1, unit='cm'))
dev.off()

##  Save posterior summaries
eRT <- eRT %>% mutate(RT=sprintf('%1.2f [%1.2f, %1.2f]',
                                 .value, .value.lower, .value.upper)) %>%
    select(-c(.value.lower, .value.upper)) %>%
    write.csv('posteriors_RT.csv')
eHits <- eHits %>% mutate(Hits=sprintf('%0.2f [%0.2f, %0.2f]',
                                       .value, .lower, .upper)) %>%
    select(-c(.lower, .upper)) %>%
    write.csv('posteriors_hits.csv')
eFAs <- eFAs %>% mutate(FAs=sprintf('%0.2f [%0.2f, %0.2f]',
                                  .value, .lower, .upper)) %>%
    select(-c(.lower, .upper)) %>%
    write.csv('posteriors_FAs.csv')
eDPrime <- eDPrime %>% mutate(DPrime=sprintf('%0.2f [%0.2f, %0.2f]',
                                             .value, .lower, .upper)) %>%
    select(-c(.lower, .upper)) %>%
    write.csv('posteriors_DPrime.csv')
eC <- eC %>% mutate(C=sprintf('%0.2f [%0.2f, %0.2f]',
                              .value, .lower, .upper)) %>%
    select(-c(.lower, .upper)) %>%
    write.csv('posteriors_C.csv')
write.csv(merge(merge(merge(eHits, eFAs), eDPrime), eC), 'posteriors_memory.csv')


  open(OUT,">movie.txt");
  print OUT "iter\tx\ty\tz\n";
  for ($iter=0; $iter<1000; $iter++) {
    for ($k=0; $k<20; $k++) {
      for ($l=0; $l<20; $l++) {

        $r=0.50;
        $c=(($k+$l)%81)/200;
        $color=2.4*$c;
        $pi=3.14159265358979323846264;
        $x=$k+$r*sin($c*$pi*$iter);
        $y=$l+$r*cos($c*$pi*$iter);

        print OUT "$iter\t$x\t$y\t$color\n";
      }
    }
  }
  close(OUT);

  vv<-read.table("c:/vincentg/movie.txt",header=TRUE);
  iter<-vv$iter;
  for (n in 0:999) {
    x<-vv$x[iter == n];
    y<-vv$y[iter == n];
    z<-vv$z[iter == n];
    plot(x,y,xlim=c(3,17),ylim=c(3,17),pch=20,cex=1,col=rgb(0,0,z),xlab="",ylab="",axes=TRUE);
    Sys.sleep(0.01); # sleep 0.05 second between each iteration
  }


library(dplyr)
library(wakefield)
df <-
  r_data_frame(
  n = 254,
  id,
  race,
  age,
  sex,
  hour,
  iq,
  height,
  died,
  Scoring = rpois(50),
  Smoker = valid
  ) %>%
  r_na(prob=0.10)

df <- data.frame(df)

df


# # 4. faza: Analiza podatkov
#
# # Uvozimo funkcijo za uvoz spletne strani.
# source("lib/xml.r")
#
# # Preberemo spletno stran v razpredelnico.
# cat("Uvažam spletno stran...\n")
# tabela <- preuredi(uvozi.obcine(), obcine)
#
# # Narišemo graf v datoteko PDF.
# cat("Rišem graf...\n")
# pdf("slike/naselja.pdf", width=6, height=4)
# plot(tabela[[1]], tabela[[4]],
#      main = "Število naselij glede na površino občine",
#      xlab = "Površina (km^2)",
#      ylab = "Št. naselij")
# dev.off()

#NAPOVED ZA SLOVENIJO
pdf("slike/napoved.pdf", width=6, height=4)
leto<-brezposelnostpoletih$Leto
stbrezposelnih<-brezposelnostpoletih$Stevilo.brezposelnih
plot(leto,stbrezposelnih, xlim=c(2000,2020), ylim=c(60,125),
     xlab="Leto",ylab="Stevilo brezposelnih",
     main="Napoved za Slovenijo",pch=20,col="lightblue",type="p",lwd=3.5)

#premica
linp<-lm(stbrezposelnih~leto)
abline(linp,col="red")
#parabola
kvp<-lm(stbrezposelnih~I(leto^2)+leto)
curve(predict(kvp, data.frame(leto=x)), add = TRUE, col = "lightgreen")
#loess
loep<-loess(stbrezposelnih~leto)
curve(predict(loep, data.frame(leto=x)),add=TRUE,col="blue")

#legenda
legend("bottomright", c("Linerana metoda", "Kvadratna metoda","Loess"),lty=c(1,1,1), col = c("lightblue","lightgreen","purple"))

#Ocenimo prileganje krivulj tako, da izračunamo vsote kvadratov razdalj od napovedanih do dejanskih vrednosti
ostp<-sapply(list(linp, kvp, loep), function(x) sum(x$residuals^2))

#ocenitev ostanka-manjši ostanek je bolj natančen
sapply(list(linp, kvp, loep), function(x) sum(x$residuals^2))
# min(3586.4494, 1227.3295, 392.7765) = 392.7765
#najbolj natančen je loess
dev.off()

#GRAF BDP

pdf("slike/bdp.pdf", width=6, height=4)
z<-bdp[1:14, 2]
# plot(bdp[1:14, 1], z, type="l", xlab="leto", ylab="Stevilo brezposelnih", main="Bdp in stevilo brezposelnih",col="lightblue")

y<-bdp[1:14, 3]
# lines(bdp[1:14, 1], y, type="l" , col="blue")

library(plotrix)
twoord.plot(bdp[1:14, 1], z, bdp[1:14, 1], y, type = "l", xlab="Leto",
            ylab="BDP", rylab="Stevilo brezposelnih",
            main="Bdp in stevilo brezposelnih", lcol="lightblue", rcol="blue")

dev.off()

#GRAF SEZONA

pdf("slike/sezona.pdf", width=6, height=4)
z<-sezona[1:12,2]

plot(1:12, z, type="l", col="blue", xaxt = "n", main="Brezposelnost v letih 2014 in 2013")

axis(1, at = axTicks(1, c(1, 12, 11)), labels = sezona[1:12, 1], las = 2, cex.axis = 0.5)
m<-sezona[1:12,3]
lines(1:12, m, type="l", col="lightblue")

legend("topright", c("Leto 2014", "Leto 2013"),lty=c(1,1), col = c("blue","lightblue"))
dev.off()

# #Napoved za Slovenijo
# pdf("slike/Stevilozivorojenih.pdf", width=6, height=4)
# leto<-Rodnost_smrtnost_SLO$Leto
# stzivorojenih<-Rodnost_smrtnost_SLO$stzivorojenih
# plot(leto,stzivorojenih, xlim=c(2002,2020),ylim=c(17000,25000),
#      xlab="Leto",ylab="Stevilo zivorojenih otrok",
#      main="Napoved za Slovenijo",pch=20,col="lightblue",type="p",lwd=3.5)
# #premica
# linp<-lm(stzivorojenih~leto)
# abline(linp,col="pink")
# #parabola
# kvp<-lm(stzivorojenih~I(leto^2)+leto)
# curve(predict(kvp, data.frame(leto=x)), add = TRUE, col = "purple")
# #loess
# loep<-loess(stzivorojenih~leto)
# curve(predict(loep, data.frame(leto=x)),add=TRUE,col="orange")
# #legenda
# legend("topleft", c("Linerana metoda", "Kvadratna metoda","Loess"),lty=c(1,1,1), col = c("lightblue","purple","orange"))
# #Ocenimo prileganje krivulj tako, da izračunamo vsote kvadratov razdalj od napovedanih do dejanskih vrednosti
# ostp<-sapply(list(linp, kvp, loep), function(x) sum(x$residuals^2))
# #ocenitev ostanka-manjši ostanek je bolj natančen
# sapply(list(linp, kvp, loep), function(x) sum(x$residuals^2))
# #8434860.1 5625253.3 590036.3
# #min(8434860.1, 5625253.3 , 590036.3)=590036.3
# #najbolj natančen je loess
# dev.off()


pdata <- function(x) ggplot_build(x)$data

# Transform the data as the coordinate system does
cdata <- function(plot) {
  pieces <- ggplot_build(plot)

  lapply(pieces$data, function(d) {
    ddply(d, "PANEL", function(panel_data) {
      scales <- panel_scales(pieces$panel, panel_data$PANEL[1])
      details <- coord_train(plot$coord, scales)
      coord_transform(plot$coord, panel_data, details)
    })
  })
}

pranges <- function(plot) {
  panels <- ggplot_build(plot)$panel

  x_ranges <- lapply(panels$x_scales, scale_limits)
  y_ranges <- lapply(panels$y_scales, scale_limits)

  npscales <- plot$scales$non_position_scales()
  npranges <- lapply(npscales$scales$scales, scale_limits)

  c(list(x = x_ranges, y = y_ranges), npranges)
}


# Create Data
# ch new 2 dup 1
# v8 new 1 dup 0
# jsc new 5 dup 0
# sm new 0 dup 2
true_positive_perc=c(24,9)
true_positive_names=c("Bug","Duplicate")

labs <- paste(true_positive_names, " (", true_positive_perc, ")", sep="")

pie(true_positive_perc , labels=labs, radius=.5, cex=1.2)


Red []

my-abs: func [x] [
   either (x >= 0) [x][x * -1]]


library(data.table)

indir = "~/git/US-covid19-data-scraping" # path directory to the repository

set.seed(3312122)
run_index = round(runif(1,0, 10000))
run_tag = paste0("201023o_", run_index)

lastDate = "2020-10-29"
path.to.demographics.data = file.path(indir, "data_visualization", "data", "us_population_withnyc.rds")
path.to.jhu.data = file.path(indir, "data", "official", "jhu_death_data_padded_201207.rds")
path.to.nyc.data = file.path(indir, "data", "official", "NYC_deaths_201207.csv")
path.to.deathByAge.data = file.path(indir, "data", "processed", lastDate, "DeathsByAge_US.csv")
path.to.predict_deaths_ntl_age_strata = file.path(indir, "data_visualization", "results_predict_deaths_common_age_strata", run_tag, "table", "deaths_predict_ntl_age_strata.rds")

outtab.dir = file.path(indir, "data_visualization", "tables_v120")
outfig.dir = file.path(indir, "data_visualization", "figures_v120")

dir.create(outtab.dir, showWarnings = FALSE)
dir.create(outfig.dir, showWarnings = FALSE)

source(file.path(indir, "data_visualization", "functions", "data-visualization-summary_functions.r"))
source(file.path(indir, "data_visualization", "functions", "data-visualization-plot_functions.r"))
source(file.path(indir, "data_visualization", "functions", "data-visualization-table_functions.r"))

#
# Read data
# read death by age
deathByAge = as.data.table( read.csv( path.to.deathByAge.data ) )
set(deathByAge, NULL, 'date', deathByAge[,as.Date(date)])

# read demographics by age
pop_count = as.data.table( read_pop_count_by_age_us(path.to.demographics.data) )
setnames(pop_count, "state", "loc_label")

# read predicted death by 4 age groups
death.predict = as.data.table( readRDS( path.to.predict_deaths_ntl_age_strata ) )
set(death.predict, NULL, 'date', death.predict[,as.Date(date)])
death.predict[, code := as.character(code)]
setnames(death.predict, 'age_cat', "age")

# find observation days
death.predict[, month := format(date, "%m")]
dates_data = unique(select(deathByAge, code, date))
dates_data[, month := format(date, "%m")]
death.predict = merge(select(death.predict, -date), dates_data, by = c("code", "month"),  allow.cartesian=TRUE)

# create loc division map
loc_div = data.table(code = c(c("CT", "ME", "MA", "NH", "RI", "VT"), c("NJ", "NY", "PA", "NYC"), c("IL", "IN", "MI", "OH", "WI"), c("IA", "KS", "MN", "MO", "NE", "ND", "SD"),
                              c("DE", "DC", "FL", "GA", "MD", "NC", "SC", "VA", "WV"), c("AL", "KY", "MS", "TN", "AR", "LA", "OK", "TX"),c("AZ", "CO", "ID", "MT", "NV", "NM", "UT", "WY"),
                              c("AK", "CA", "HI", "OR", "WA")),
                     division = c(rep("New England", 6), rep("Middle Atlantic", 4), rep("East North Central", 5), rep("West North Central", 7),
                                  rep("South Atlantic", 9), rep("South Central", 8), rep("Mountain", 8), rep("Pacific", 5)))

#
# Find associated pop count
death_summary = find_pop_count(death.predict, pop_count)

#
# Add the US census division
death_summary = merge(death_summary, loc_div, by = "code")

#
# Find time index since 10th cumulative death
death_summary = find_time_index_since_nth_cum_death(death_summary, path.to.jhu.data, path.to.nyc.data, 10)

#
# Find mortality rate
death_summary[, M_mortality_rate := M_deaths_cum / pop_count]
death_summary[, CL_mortality_rate := CL_deaths_cum / pop_count]
death_summary[, CU_mortality_rate := CU_deaths_cum / pop_count]

#
# Find median death per 100,000
death_summary[, M_deaths_cum_100K := (M_deaths_cum * 100000) / pop_count ]
death_summary[, CL_deaths_cum_100K := (CL_deaths_cum * 100000) / pop_count ]
death_summary[, CU_deaths_cum_100K := (CU_deaths_cum * 100000) / pop_count ]

# Summary for the last month
last_month = as.Date('2020-10-01')
death_summary_last_month = subset(death_summary, date == last_month)

#
# Plot

# crude estimate of the proportion of cases by age
p_proportion_monthly_cases = plot_crude_proportion_monthly_cases_by_age(copy(death_summary), 45)

# proportion of cum deaths by age groups over time
p_proportion_monthly_death = plot_proportion_monthly_death_by_age(copy(death_summary), 0.7, F)

# proportion of cum deaths by age groups in the last month
p_proportion_absolute_cum_death = plot_proportion_absolute_cum_death_by_age(copy(death_summary_last_month))

# mortality rate over time
p_death_per_100K_vs_time_since_10th_cum_death = plot_death_per_100K_vs_time_since_10th_cum_death(copy(select(death_summary, -division)))
p_death_per_100K = plot_death_per_100K(copy(death_summary_last_month))

# USA map proportion of cum deaths and mortality rate on the last month
age_cats = sort(unique(death_summary$age))
plots_prop <- vector('list', length(age_cats))
plots_mortality <- vector('list', length(age_cats))
for(i in 1:length(age_cats)){

  tmp = subset(death_summary_last_month, age == age_cats[i])

  plots_mortality[[i]] = plot_heat_map_usa(tmp = tmp,
                                 variable = "M_deaths_cum_100K",
                                 xlab = "COVID-19 mortality \ncounts per 100,000",
                                 option_viridis = "magma",
                                 range_viridis = c(0.15, 0.9),
                                 limits = NULL,
                                 main = age_cats[i])

  plots_prop[[i]] = plot_heat_map_usa(tmp,
                                 variable = "M_deaths_prop_cum",
                                 xlab = "Proportion of COVID-19 \nmortality counts",
                                 option_viridis = "magma",
                                 range_viridis = c(0.15, 0.9),
                                 scale_percent =1,
                                 limits = range(death_summary_last_month$M_deaths_prop_cum),
                                 main = age_cats[i])

}
p_heat_map_usa_mortality_rate <- gridExtra::grid.arrange(grobs=plots_mortality, ncol=2, nrow = 2)
p_heat_map_usa_proportion <- gridExtra::grid.arrange(grobs=plots_prop, ncol=2, nrow = 2)

#
# Tables
# cumulative death, mortality rate and population count
mortality_counts_rate_summary_024 = find_mortality_counts_rate_summary(copy(death_summary_last_month), Age = "0-24", pop_count)
mortality_counts_rate_summary_2549 = find_mortality_counts_rate_summary(copy(death_summary_last_month), Age = "25-49", pop_count)
mortality_counts_rate_summary_5074 = find_mortality_counts_rate_summary(copy(death_summary_last_month), Age = "50-74", pop_count)
mortality_counts_rate_summary_75 = find_mortality_counts_rate_summary(copy(death_summary_last_month), Age = "75+", pop_count)

#
# Find reporting statistics

# find share of 75+ in covid19 attributable deaths
share_75_deaths = find_share_age_deaths(copy(death_summary_last_month), Age = "75+")

# find share of 50-74 in covid19 attributable deaths
share_5074_deaths = find_share_age_deaths(copy(death_summary_last_month), Age = "50-74")

# find share of 25-49 in covid19 attributable deaths
share_2549_deaths = find_share_age_deaths(copy(death_summary_last_month), Age = "25-49")

# find mortality rate nationally
mortality_rate_report = find_mortality_rate_report(copy(death_summary_last_month), Age = "75+")

#
# Save
ggsave(p_proportion_monthly_death, file = file.path(outfig.dir, paste0("ProportionMonthlyDeathsByAge_ntl_age_strata", ".png")), w = 21/1.5, h=29/1.5)
ggsave(p_proportion_monthly_cases, file = file.path(outfig.dir, paste0("ProportionMonthlyCasesByAge_ntl_age_strata.png")), w = 21/1.5, h=29/1.5)
ggsave(p_proportion_absolute_cum_death, file = file.path(outfig.dir, paste0("Proportion_Cum_DeathsByAge", ".png")), w = 10.1, h = 10.1)

ggsave(p_death_per_100K_vs_time_since_10th_cum_death, file = file.path(outfig.dir, paste0("MortalityRateByAge_vs_time_since_10th_CumDeath.png")), w = 15, h = 10)
ggsave(p_death_per_100K, file = file.path(outfig.dir, paste0("MortalityRateByAge.png")), w = 15, h = 10)

ggsave(p_heat_map_usa_mortality_rate, file = file.path(outfig.dir, paste0("heat_map_usa_", "MortalityRateByAge", ".png")), w = 14, h = 10)
ggsave(p_heat_map_usa_proportion, file = file.path(outfig.dir, paste0("heat_map_usa_", "ProprotionDeathsByAge", ".png")), w = 14, h = 10)

saveRDS(list(format(last_month, "%B %d, %Y"), share_75_deaths, share_5074_deaths, share_2549_deaths, mortality_rate_report),
        file = file.path(outtab.dir, paste0("deaths_ntl_age_strata_summary.rds")), version = 2)
saveRDS(list(format(last_month, "%B %d, %Y"), mortality_counts_rate_summary_024, mortality_counts_rate_summary_2549, mortality_counts_rate_summary_5074, mortality_counts_rate_summary_75),
        file = file.path(outtab.dir, paste0("mortality_counts_rate_summary.rds")), version = 2)


papi.utilization <- function(expr)
{
  papi.check.ncounters(3L)

  ret <- .Call(papi_utilization_on)
  if (ret == -1L)
    stop("PAPI failed to initialize hardware counters.\nYour platform may not support floating point operation event.\n")

  eval(expr)

  ret <- .Call(papi_utilization_off)
  if (is.integer(ret) && ret == -1L)
    stop("There was a problem recovering the counter information.")

  return( ret )
}

#' utilization
#'
#' CPU Utilization.
#'
#' We define processor utilization as:\cr
#'
#' \eqn{utilization = \frac{ins}{clockrate\ *\ real\_time\ *\ ncpus}} \cr
#'
#' where \code{ins} is the number of instructions measured by PAPI,
#' \code{clockrate} is the clock frequency of the processor in Hz,
#' \code{real_time} is the wall clock time, and \code{ncpus} is the number of
#' "cores" (physical+logical) detected by PAPI.
#'
#' @param expr
#' A valid R expression to be profiled.
#' @param gcFirst
#' logical; determines if garbage collection should be called
#' before profiling.
#' @param burnin
#' logical; determines if the function should first be evaluated
#' with an empty expression.
#'
#' @return The return is a list consisting of:
#' \tabular{ll}{
#' \code{real_time} \tab real time spent evaluating expression \cr
#' \code{proc_time} \tab total process time spent evaluating expression \cr
#' \code{ins} \tab Number of instructions. \cr
#' \code{ipc} \tab Instructions per cycle. \cr
#' \code{utilization} \tab CPU utilization (proportion) \cr
#' }
#'
#' @keywords programming
#'
#' @examples
#'
#' \dontrun{
#' library(pbdPAPI)
#'
#' system.flops(1+1)
#' }
#'
#' @export
system.utilization <- function(expr, gcFirst=TRUE, burnin=TRUE)
{
  if (burnin)
    b <- system.utilization(gcFirst=gcFirst, burnin=FALSE)

  if (gcFirst)
    invisible(gc(FALSE))

  if (missing(expr))
    expr <- NULL

  events <- c("PAPI_TOT_INS", "PAPI_TOT_CYC")
  papi.avail.lookup(events=events, shorthand=FALSE)

  ret <- papi.utilization(expr=expr)

  if (burnin)
  {
    for (i in 3:(length(ret)-1))
      ret[[i]] <- max(ret[[i]] - b[[i]], 0)
  }

  return( ret )
}


REBOL [
	Title:   "Red/System unicode conversion library"
	Author:  "Qingtian Xie"
	File: 	 %unicode.r
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2018 Red Foundation. All rights reserved."
	License: "BSD-3 - https://github.com/red/red/blob/master/BSD-3-License.txt"
]

utf8-to-utf16: func [s [string!] /length /local m cp result cnt][
	result: make string! (1 + length? s) * 2
	cnt: 0
	while [not tail? s][
		cp: first s
		cnt: cnt + 1
		either cp < 128 [
			unless length [repend result [cp #"^@"]]
		][
			m: 8 - length? find	enbase/base	to binary! cp 2 #"0"
			cp: cp xor pick [0 192 224 240 248 252] m
			loop m - 1 [cp: 64 * cp + (63 and first s: next s)]		;--	code point
			either cp < 65536 [
				unless length [append result to-bin16 cp]
			][
				;--	multiple UTF16 characters with surrogates
				either length [cnt: cnt + 1][
					cp: cp - 65536
					append result to-bin16 55296 + shift/logical cp 10
					append result to-bin16 cp and 1023 + 56320
				]
			]
		]
		s: next s
	]
	either length [cnt][result]
]


# Star Wars box office in millions (!)
new_hope <- c(460.998, 314.4)
empire_strikes <- c(290.475, 247.900)
return_jedi <- c(309.306, 165.8)
star_wars_matrix <- rbind(new_hope, empire_strikes, return_jedi)
colnames(star_wars_matrix) <- c("US", "non-US")
rownames(star_wars_matrix) <- c("A New Hope", "The Empire Strikes Back", "Return of the Jedi")

# Estimation of visitors
visitors <- star_wars_matrix / 5

# Print the estimate to the console
print(visitors)


library(dyntoy)

dataset = generate_dataset(
  model = model_multifurcating(),
  num_cells = 5000,
  num_features = 1000
)

saveRDS(dataset, file='/home/lexent/Desktop/dyntoy_disconnected_gen_1.rds')


####################################
# Master solution for assignment 1 #
####################################

# Libraries ---------------------------------------------------------------

library(foreign) # read foreign file objects
library(readstata13) # read stata 13 files
library(dplyr) # manipulate data
library(ggplot2) # plot results
library(psych) # create summary statistics

# Read in data ------------------------------------------------------------

gles <- foreign::read.dta("Assignments/Assignment1/ZA5302_en_v6-0-0.dta") %>%
  dplyr::select(wkrnr, vndkirchg) # drop unnecessary variables
mpData <- readstata13::read.dta13("Assignments/Assignment1/mpData.dta") # in stata 13 format

# Create and describe variables -------------------------------------------

levels(gles$vndkirchg) # inspect variable coding

gles2 <- gles %>%
  dplyr::filter(as.integer(vndkirchg)<8) %>% # filter out missings
  dplyr::group_by(wkrnr) %>% # group by constituency
  dplyr::summarize(churchAttMean = mean(as.integer(vndkirchg), na.rm=T),
                   churchAttDummy = sum(as.integer(vndkirchg) %in% c(4:7)) /
                     n()) %>% # district summaries
    dplyr::ungroup() # remember to ungroup
save(gles2, file = "Assignments/Assignment1/tablesAndFigures/churchAtt.RData")

descript <- psych::describe(gles2[2:3], fast = T) # create summary statistics
save(descript, file ="Assignments/Assignment1/tablesAndFigures/descript.RData")  # save file

mpData2 <- mpData %>%
  dplyr::mutate(vote = replace(vote, vote>1, NA)) # convert to dummy

dfFull <- dplyr::full_join(gles2, mpData2, by = "wkrnr") # merge data sets

# Replicate results -------------------------------------------------------

# Table 3
model1 <- lm(Position ~ churchAttMean + Catholic + Prostestant + NoAffiliation + Female +
               Parent + FemaleParent + Theology + Medicine, data = dfFull)
model2 <- lm(Position ~ churchAttMean + Catholic + Prostestant + NoAffiliation + Female +
               Parent + FemaleParent + Theology + Medicine + Greens + CDU +
               CSU + Left + FDP, data = dfFull) # with controls
# Table 4
indVars <- paste("churchAttMean", "Catholic", "Prostestant", "NoAffiliation",
                  "Female", "Parent", "FemaleParent", "Theology", "Medicine", sep = "+")
controls <- paste("Greens", "CDU", "CSU", "Left", "FDP", sep = "+")

model3 <- glm(as.formula(paste("vote ~", indVars)), family="binomial",
              data = dfFull)
model4 <- glm(as.formula(paste("vote ~", indVars,"+", controls)), family="binomial",
              data = dfFull) # with controls

# save results
save(model1, file ="Assignments/Assignment1/tablesAndFigures/model1.RData")
save(model2, file ="Assignments/Assignment1/tablesAndFigures/model2.RData")
save(model3, file ="Assignments/Assignment1/tablesAndFigures/model3.RData")
save(model4, file ="Assignments/Assignment1/tablesAndFigures/model4.RData")


library(methods)
library(data.table)
{{rimport}}('__init__.r', 'plot.r')

infile1 = {{i.infile1    | quote}}
infile2 = {{i.infile2    | quote}}
outdir  = {{o.outdir     | quote}}
outfile = {{o.outfile    | quote}}
dopval  = {{args.pval    | R}}
dofdr   = {{args.fdr     | R}}
inopts1 = {{args.inopts1 | R}}
inopts2 = {{args.inopts2 | R}}
doplot  = {{args.plot    | R}}
method  = {{args.method  | quote}}
outfmt  = {{args.outfmt  | quote}}
params  = {{args.params  | R}}
ggs     = {{args.ggs     | R}}
devpars = {{args.devpars | R}}

indata1 = read.table.inopts(infile1, inopts1)
indata2 = read.table.inopts(infile2, inopts2)
len1    = ncol(indata1)
len2    = ncol(indata2)
indata = merge(indata1, indata2)

rnames1 = rownames(indata1)
rnames2 = rownames(indata2)
if (is.null(rnames1))
	rnames1 = paste0('R1_', 1:nrow(indata1))
if (is.null(rnames2))
	rnames2 = paste0('R2_', 1:nrow(indata2))
rm(indata1, indata2)
saveResults = function (corr, rnames1, rnames2, outfmt, outfile) {
	if (outfmt == 'pairs') {
		rownames(corr) = apply(merge(rnames1, rnames2), 1, function(row) paste(row, collapse = "\t"))
		write.table(corr, outfile, col.names = F, row.names = T, quote = F, sep = "\t")
	} else {
		corr = cbind(merge(rnames1, rnames2), corr = corr)
		corr = dcast(corr, x ~ y, value.var = 'corr')
		rownames(corr) = corr[, 1]
		corr = corr[, -1, drop = F]
		write.table(corr, outfile, col.names = T, row.names = T, quote = F, sep = "\t")
	}
}

if (!dopval && dofdr == F) {
	corr = apply(indata, 1, function(row) cor(
		row[1:len1],
		row[len1+1:len2],
		method = method
	))
	corr = data.frame(corr = corr)
	saveResults(corr, rnames1, rnames2, outfmt, outfile)
} else {
	corr0 = apply(indata, 1, function(row) cor.test(
		row[1:len1],
		row[len1+1:len2],
		method = method
	))
	corr = data.frame(corr = sapply(corr0, function(x) x$estimate))
	saveResults(corr, rnames1, rnames2, outfmt, outfile)
	pvals = sapply(corr0, function(x) x$p.value)
	corrp = data.frame(pval = sapply(corr0, function(x) x$p.value))
	saveResults(corrp, rnames1, rnames2, outfmt, paste0(tools::file_path_sans_ext(outfile), '_pval.txt'))

	if (dofdr != F) {
		if (dofdr == T) dofdr = 'BH'
		qvals = p.adjust(pvals, method = dofdr)
		corrq = data.frame(qval = qvals)
		saveResults(corrp, rnames1, rnames2, outfmt, paste0(tools::file_path_sans_ext(outfile), '_qval.txt'))
	}
}

if (doplot) {
	outplot = paste0(tools::file_path_sans_ext(outfile), '.png')
	if (is.null(params$dendro))
		params$dendro = F
	corr = cbind(merge(rnames1, rnames2), corr = corr)
	corr = dcast(corr, x ~ y, value.var = 'corr')
	rownames(corr) = corr[, 1]
	corr = corr[, -1, drop = F]
	#corr[lower.tri(corr)] = 0
	ggs = c(list(
		theme = list(
			legend.position      = c(0.03, 0.97),
			legend.justification = c("left", "top"),
			legend.title         = element_text(margin = margin(b = 5)),
			legend.box.just      = "right"
		),
		guides = list(
			fill = guide_legend(title = paste0(toupper(substring(method, 1, 1)), substring(method, 2)), reverse = T)
		)
	), ggs)
	plot.heatmap(corr, outplot, params, ggs, devpars)
}


# Uvoz s spletne strani
#
# library(XML)
#
# # Vrne vektor nizov z odstranjenimi začetnimi in končnimi "prazninami" (whitespace)
# # iz vozlišč, ki ustrezajo podani poti.
# stripByPath <- function(x, path) {
#   unlist(xpathApply(x, path,
#                     function(y) gsub("^\\s*(.*?)\\s*$", "\\1", xmlValue(y))))
# }
#
# uvozi.obcine <- function() {
#   url.obcine <- "http://sl.wikipedia.org/wiki/Seznam_ob%C4%8Din_v_Sloveniji"
#   doc.obcine <- htmlTreeParse(url.obcine, useInternalNodes=TRUE)
#
#   # Poiščemo vse tabele v dokumentu
#   tabele <- getNodeSet(doc.obcine, "//table")
#
#   # Iz druge tabele dobimo seznam vrstic (<tr>) neposredno pod
#   # trenutnim vozliščem
#   vrstice <- getNodeSet(tabele[[2]], "./tr")
#
#   # Seznam vrstic pretvorimo v seznam (znakovnih) vektorjev
#   # s porezanimi vsebinami celic (<td>) neposredno pod trenutnim vozliščem
#   seznam <- lapply(vrstice[2:length(vrstice)], stripByPath, "./td")
#
#   # Iz seznama vrstic naredimo matriko
#   matrika <- matrix(unlist(seznam), nrow=length(seznam), byrow=TRUE)
#
#   # Imena stolpcev matrike dobimo iz celic (<th>) glave (prve vrstice) prve tabele
#   colnames(matrika) <- gsub("\n", " ", stripByPath(tabele[[2]][[1]], ".//th"))
#
#   # Podatke iz matrike spravimo v razpredelnico
#   return(data.frame(apply(gsub("\\*", "",
#                           gsub(",", ".",
#                           gsub("\\.", "", matrika[,2:5]))),
#                     2, as.numeric), row.names=matrika[,1]))
# }
#
#

library(XML)

# Vrne vektor nizov z odstranjenimi začetnimi in končnimi "prazninami" (whitespace)
# iz vozlišč, ki ustrezajo podani poti.
stripByPath <- function(x, path) {
  unlist(xpathApply(x, path,
                    function(y) gsub("^\\s*(.*?)\\s*$", "\\1", xmlValue(y))))
}

uvozi.dejavnosti <- function() {
  url.dejavnosti <- "http://www.stat.si/novica_prikazi.aspx?id=6254"
  doc.dejavnosti <- htmlTreeParse(url.dejavnosti, useInternalNodes=TRUE)

tabele <- getNodeSet(doc.dejavnosti, "//table[@rules]")

vrstice <- getNodeSet(tabele[[1]], "./tr")

seznam <- lapply(vrstice[3:length(vrstice)], stripByPath, "./td")

matrika <- matrix(unlist(seznam), nrow=length(seznam), byrow=TRUE)

colnames(matrika) <- gsub("\n", " ", stripByPath(vrstice[[1]], ".//td"))

dejavnostidata=data.frame(apply(gsub("\\.", "", matrika[,2:3]),
                       2, as.numeric), row.names=matrika[,1])

return(dejavnostidata)
}


nums <- strsplit(readLines(con = file("stdin"))[1], " ")[[1]]
print(strtoi(nums[1])+strtoi(nums[2]))


library(vegan)
library(labdsv)

data(varespec)
data(varechem)

vare.cca <- cca(varespec ~ Baresoil+Humdepth+pH+N+P+K+Ca+Mg+S+Al+Fe, data=varechem)
vare.cca
plot(vare.cca)
summary(vare.cca)

// See also http://ecology.msu.montana.edu/labdsv/R/labs/lab12/lab12.html


args=commandArgs(T)
cutOff<-as.numeric(args[1])

setwd("/home/gaoy1/data/cuizhe/project/2020-06-30-10xPBMC_nextgem_labeled/bin")
library(Matrix)
library(parallel)
Data<-readRDS("../input/10xpbmc5k-snap-full.rds")
labels<-read.table("../input/pbmc_5k_atac_label_nextgem.txt",header = TRUE,sep = "\t",check.names = FALSE)
Data<-as(Data, "dgCMatrix")

labels<-labels[labels$barcode %in% rownames(Data),]

func<-function(label){
    barcode<-labels[labels$label == label,]$barcode
    cell_data<-Data[rownames(Data) %in% barcode,]
    nonZeroColumnList_cell<-diff(cell_data@p)/nrow(cell_data)
    candidateRange<-which(nonZeroColumnList_cell>=cutOff)
    for(i in candidateRange){
        cell_data[,i] = 1
    }
    return(cell_data)
}

cl.cores<-16
cl <- makeCluster(cl.cores,type = "FORK")
results <- parLapply(cl, unique(labels$label),  func)
enhanced_Data<-do.call('rbind',results)
stopCluster(cl)
saveRDS(enhanced_Data,file = paste0('../output/10xpbmc5k-snap-full_enh',cutOff,'.rds'))
print(paste0(cutOff,' is finished'))


#subtype analysis

args=1

subjob_id=as.numeric(args[1]) #subjob id

N_simulation=500  #simulation times

#subjobs
run_i=1
run_array=list()
for (h2_p in c(0.1,0.2,0.3,0.4,0.5)[3]){ #h2 poly
  for (N_causal_SNPs in c(95593)){ #N of causal SNPs
    for (vr in c(0.01,0.02,0.03,0.05,0.10)[1]){ #h2 rare (var rare)
      for (freq_r in c(1e-4,0.001,0.005,0.01,0.05)[4]){ #freq rare
        for (k in c(0.001,0.005,0.01,0.02,0.05)[3]){ #prevalence
          for (genetic_model in c(1,2,3)[1]){ #genetic architecture
            for (pi0 in c(0,0.1,0.3,0.5,0.7,0.9)[1]){  #pi0, proportion of causal variants pi0=0: utility; pi0!=0: power
              run_array[[run_i]]=c(h2_p,N_causal_SNPs,vr,freq_r,k,genetic_model,pi0)
              run_i=run_i+1
            }
          }
        }
      }
    }
  }
}

run_array<-run_array[[subjob_id]]
h2_p=run_array[1]
#N_causal_SNPs=run_array[2]
vr=run_array[3]
freq_r=run_array[4]
k=run_array[5]
N_samples=run_array[6]
genetic_model=switch(run_array[6],'a','b','c')
# a=Infinitesimal architecture
# b=with negative selection
# c=LD-adjusted kinship
pi0=run_array[7]

#load LDsc
ldsc<-read.table('/data/c***/z***/projects/prslev/geno/ldsc/ldsc.simulation_all_snps',header = T,stringsAsFactors = F)

#load common snp table
common_all<-read.table('/data/c***/z***/projects/prslev/common/common_all.bim',header = F,stringsAsFactors = F)
common_all<-data.frame(rsid=common_all$V2,counted_allele=common_all$V5,effect=NA,stringsAsFactors = F)

#load MAF for all the common variants (used for maf-dependent genetic architectures)
maf_all<-read.table('/data/c***/z***/projects/prslev/geno/geno_copies/common_all.frq',header = T,stringsAsFactors = F)

#n of causal common variants
N_causal_SNPs=nrow(common_all)

#load rare snps
rare_dosage<-readRDS('/data/c***/z***/data/biovu/geno/23k/prslev_simulation_rare.rds')
colnames(rare_dosage)[-1]<-sapply(colnames(rare_dosage)[-1], function(x) strsplit(x,"[_]")[[1]][1])
rare_all<-data.frame(rsid=colnames(rare_dosage)[-1],effect=NA,stringsAsFactors = F)

#load rare variant info (freq)
rare_info<-read.table(paste0('/data/c***/z***/data/biovu/geno/chr/rare/rare.list'),header = T,stringsAsFactors = F)
rare_info$SNP=paste0('X',sub(':','.',rare_info$SNP)) #match variants name with dosage data
rare_info<-rare_info[rare_info$maf==freq_r,]

rare=rare_all[which(rare_all$rsid %in% rare_info$SNP),]

#allele frequency for rare variants (the actual number of freq, close to the setting)
freq_snp=sapply(rare$rsid,function(x) rare_info[which(rare_info$SNP==x),'maf'])
#calculate the effect size for rare vatiants
rare$effect=(vr/2/freq_snp/(1-freq_snp))^0.5
#sample N rare variants for simulation (N= number of simulation times)
set.seed(2019)
rare<-rare[sample(nrow(rare),N_simulation,replace = T),]

#simulation
N_samples=10000;i=1 #for testing

print(N_samples)

#output dataframe (liability-threshold model (LTM), probit)
output_p<-data.frame()

#output dataframe (logit)
output_l<-data.frame()

i=1

#for (i in 1:N_simulation){
print(i)

#---generate effect sizes for common variants according to different genetic architectures---
df<-common_all
# a Infinitesimal architecture
#   beta_poly~(0,h2_p/N_caucal_SNPs)
if(genetic_model=='a'){
  set.seed(i)
  df$effect=(1-pi0)*rnorm(N_causal_SNPs,0,(h2_p/N_causal_SNPs)^0.5)

  # b Negative selection
  #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)))
}else if(genetic_model=='b'){
  set.seed(i)
  df$effect=df[,'effect']<-sapply(maf_all$MAF,function(f) rnorm(1,mean=0,sd=((f*(1-f))^0.63)^0.5))
  #find k constant
  k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
  #multiply by k constant
  df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)

  # c LD-adjusted kinship
  #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)*(1/(1+ldsc))))
}else if(genetic_model=='c'){
  set.seed(i)
  df$effect=df[,'effect']<-mapply(function(f,ld) rnorm(1,mean=0,sd=(((f*(1-f))^0.75)*1/(1+ld))^0.5), maf_all$MAF, ldsc$ldscore)
  #find k constant
  k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
  #multiply by k constant
  df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)
}

#write weight file
write.table(df,paste0('/data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.weight'),row.names = F,col.names = F,sep='\t',quote = F)

#use plink to calculate the PB (PRS of common variants)
#if(i %in% c(1,101,201,301,401)){
cmd=paste0('/home/zhoud2/tools/plink2/plink2 --bfile /data/c***/z***/projects/prslev/common/common_all --score /data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.weight variance-standardize  --out /data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.score')
system(cmd,wait = T,ignore.stdout=T,ignore.stderr=T)
#}

#load PB results (A)
PB=read.table(paste0('/data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.score.sscore'),stringsAsFactors = F)
PB$IID=PB$V1;PB$A=PB$V5*2*nrow(common_all)
PB<-PB[,c('IID','A')]

#LEV (R)
rare_id=rare[i,'rsid']
rare_effect=rare[i,'effect']
R=as.numeric(rare_dosage[,rare_id]*rare_effect)
LEV<-data.frame(IID=rare_dosage$FID,R=R)

#combine 10 R

R_sum=R
for(r in 1:9){
  set.seed(r)
  R_sum=R_sum+R[sample(length(R),length(R),replace = F)]
}

LEV$R=R_sum

#merge A and R
combined<-merge(PB,LEV,by='IID')

#---sampling subjects---
set.seed(i)
combined<-combined[sample(seq(1,nrow(combined)),N_samples,replace = F),]

prop_subtype=0.2
effect_subtype=0.5

library(ggplot2)

i_plot=1
list_plot=list()

for(prop_subtype in c(0,0.1,0.2,0.3,0.5)){
  for(effect_subtype in c(0,0.5,1)){

    #subtyped trait
    set.seed(i+100+i_plot)
    combined$sub=rbinom(n = nrow(combined),size = 1,prob = prop_subtype)

    combined$x=ifelse(combined$sub==1,(1+effect_subtype)*combined$A+combined$R,combined$A+combined$R)

    #x=A+R
    #combined$x=combined$A+combined$R

    #h2_e
    h2_e=1-h2_p-vr

    #probability of disease (same with LTM)
    set.seed(i+i_plot)
    combined$L=combined$x+rnorm(nrow(combined),0,h2_e^0.5)
    t=quantile(combined$L,1-k)[[1]]
    combined$prob=pnorm(-(t-combined$x)/h2_e^0.5)

    #------logit model-----
    set.seed(i+i_plot)
    #combined$y_binary<-sapply(combined$prob,function(x) rbinom(1,1,x))
    combined$y_binary<-ifelse(combined$L>t,1,0)
    #combined$R<-ifelse(combined$R!=0,1,0)

    case<-combined[combined$y_binary==1,]

    list_plot[[letters[i_plot]]]<-ggplot(case,aes(x=R,y=A))+
      geom_point(size=0.5)+
      geom_smooth(method = "lm", se = T,data =case, color='red', fill='red')+
      xlab('LEV burden')+
      ylab('cSEV-Polygentic burden')+
      xlim(0,3)+
      ylim(-0.5,2)+
      ggtitle(paste0('proportion of subtype = ',prop_subtype,'\nadditional effect = ',effect_subtype))+
      theme(legend.position = 'none',
            panel.grid =element_blank(),
            panel.background = element_blank(),
            panel.border = element_blank(),
            axis.line = element_line(colour = "black"),
            title = element_text(size=8))+
      labs(tag=letters[i_plot])

    i_plot=i_plot+1

  }
}

library(grid)
lay_out = function(...) {
  x <- list(...)
  n <- max(sapply(x, function(x) max(x[[2]])))
  p <- max(sapply(x, function(x) max(x[[3]])))
  grid::pushViewport(grid::viewport(layout = grid::grid.layout(n, p)))

  for (i in seq_len(length(x))) {
    print(x[[i]][[1]], vp = grid::viewport(layout.pos.row = x[[i]][[2]],
                                           layout.pos.col = x[[i]][[3]]))
  }
}

png(paste0('/data/c***/z***/projects/prslev/plot/subtype/subtype_10_LEV_probit.png'),width = 2400,height = 1300,res = 150)
lay_out(list(list_plot$a,1,1),
        list(list_plot$b,2,1),
        list(list_plot$c,3,1),
        list(list_plot$d,1,2),
        list(list_plot$e,2,2),
        list(list_plot$f,3,2),
        list(list_plot$g,1,3),
        list(list_plot$h,2,3),
        list(list_plot$i,3,3),
        list(list_plot$j,1,4),
        list(list_plot$k,2,4),
        list(list_plot$l,3,4),
        list(list_plot$m,1,5),
        list(list_plot$n,2,5),
        list(list_plot$o,3,5))
dev.off()

args=1

subjob_id=as.numeric(args[1]) #subjob id

N_simulation=500  #simulation times

#subjobs
run_i=1
run_array=list()
for (h2_p in c(0.1,0.2,0.3,0.4,0.5)[3]){ #h2 poly
  for (N_causal_SNPs in c(95593)){ #N of causal SNPs
    for (vr in c(0.01,0.02,0.03,0.05,0.10)[4]){ #h2 rare (var rare)
      for (freq_r in c(1e-4,0.001,0.005,0.01,0.05)[4]){ #freq rare
        for (k in c(0.001,0.005,0.01,0.02,0.05)[3]){ #prevalence
          for (genetic_model in c(1,2,3)[1]){ #genetic architecture
            for (pi0 in c(0,0.1,0.3,0.5,0.7,0.9)[1]){  #pi0, proportion of causal variants pi0=0: utility; pi0!=0: power
              run_array[[run_i]]=c(h2_p,N_causal_SNPs,vr,freq_r,k,genetic_model,pi0)
              run_i=run_i+1
            }
          }
        }
      }
    }
  }
}

run_array<-run_array[[subjob_id]]
h2_p=run_array[1]
#N_causal_SNPs=run_array[2]
vr=run_array[3]
freq_r=run_array[4]
k=run_array[5]
N_samples=run_array[6]
genetic_model=switch(run_array[6],'a','b','c')
# a=Infinitesimal architecture
# b=with negative selection
# c=LD-adjusted kinship
pi0=run_array[7]

#load LDsc
ldsc<-read.table('/data/c***/z***/projects/prslev/geno/ldsc/ldsc.simulation_all_snps',header = T,stringsAsFactors = F)

#load common snp table
common_all<-read.table('/data/c***/z***/projects/prslev/common/common_all.bim',header = F,stringsAsFactors = F)
common_all<-data.frame(rsid=common_all$V2,counted_allele=common_all$V5,effect=NA,stringsAsFactors = F)

#load MAF for all the common variants (used for maf-dependent genetic architectures)
maf_all<-read.table('/data/c***/z***/projects/prslev/geno/geno_copies/common_all.frq',header = T,stringsAsFactors = F)

#n of causal common variants
N_causal_SNPs=nrow(common_all)

#load rare snps
rare_dosage<-readRDS('/data/c***/z***/data/biovu/geno/23k/prslev_simulation_rare.rds')
colnames(rare_dosage)[-1]<-sapply(colnames(rare_dosage)[-1], function(x) strsplit(x,"[_]")[[1]][1])
rare_all<-data.frame(rsid=colnames(rare_dosage)[-1],effect=NA,stringsAsFactors = F)

#load rare variant info (freq)
rare_info<-read.table(paste0('/data/c***/z***/data/biovu/geno/chr/rare/rare.list'),header = T,stringsAsFactors = F)
rare_info$SNP=paste0('X',sub(':','.',rare_info$SNP)) #match variants name with dosage data
rare_info<-rare_info[rare_info$maf==freq_r,]

rare=rare_all[which(rare_all$rsid %in% rare_info$SNP),]

#allele frequency for rare variants (the actual number of freq, close to the setting)
freq_snp=sapply(rare$rsid,function(x) rare_info[which(rare_info$SNP==x),'maf'])
#calculate the effect size for rare vatiants
rare$effect=(vr/2/freq_snp/(1-freq_snp))^0.5
#sample N rare variants for simulation (N= number of simulation times)
set.seed(2019)
rare<-rare[sample(nrow(rare),N_simulation,replace = T),]

#simulation
N_samples=10000;i=1 #for testing

print(N_samples)

#output dataframe (liability-threshold model (LTM), probit)
output_p<-data.frame()

#output dataframe (logit)
output_l<-data.frame()

i=1

#for (i in 1:N_simulation){
print(i)

#---generate effect sizes for common variants according to different genetic architectures---
df<-common_all
# a Infinitesimal architecture
#   beta_poly~(0,h2_p/N_caucal_SNPs)
if(genetic_model=='a'){
  set.seed(i)
  df$effect=(1-pi0)*rnorm(N_causal_SNPs,0,(h2_p/N_causal_SNPs)^0.5)

  # b Negative selection
  #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)))
}else if(genetic_model=='b'){
  set.seed(i)
  df$effect=df[,'effect']<-sapply(maf_all$MAF,function(f) rnorm(1,mean=0,sd=((f*(1-f))^0.63)^0.5))
  #find k constant
  k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
  #multiply by k constant
  df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)

  # c LD-adjusted kinship
  #   beta_poly~N(O,k_constant([f(1-f)]^(1+alpha)*(1/(1+ldsc))))
}else if(genetic_model=='c'){
  set.seed(i)
  df$effect=df[,'effect']<-mapply(function(f,ld) rnorm(1,mean=0,sd=(((f*(1-f))^0.75)*1/(1+ld))^0.5), maf_all$MAF, ldsc$ldscore)
  #find k constant
  k_constant=(h2_p/N_causal_SNPs/var(df[,'effect']))
  #multiply by k constant
  df[,'effect']<-df[,'effect']*k_constant^0.5*(1-pi0)
}

#write weight file
write.table(df,paste0('/data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.weight'),row.names = F,col.names = F,sep='\t',quote = F)

#use plink to calculate the PB (PRS of common variants)
#if(i %in% c(1,101,201,301,401)){
cmd=paste0('/home/zhoud2/tools/plink2/plink2 --bfile /data/c***/z***/projects/prslev/common/common_all --score /data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.weight variance-standardize  --out /data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.score')
system(cmd,wait = T,ignore.stdout=T,ignore.stderr=T)
#}

#load PB results (A)
PB=read.table(paste0('/data/g_gamazon_lab/zhoud2/prslev/tmp/',subjob_id,'.score.sscore'),stringsAsFactors = F)
PB$IID=PB$V1;PB$A=PB$V5*2*nrow(common_all)
PB<-PB[,c('IID','A')]

#LEV (R)
rare_id=rare[i,'rsid']
rare_effect=rare[i,'effect']
R=as.numeric(rare_dosage[,rare_id]*rare_effect)
LEV<-data.frame(IID=rare_dosage$FID,R=R)

#combine 10 R

R_sum=R
# for(r in 1:9){
#   set.seed(r)
#   R_sum=R_sum+R[sample(length(R),length(R),replace = F)]
# }

LEV$R=R_sum

#merge A and R
combined<-merge(PB,LEV,by='IID')

#---sampling subjects---
set.seed(i)
combined<-combined[sample(seq(1,nrow(combined)),N_samples,replace = F),]

prop_subtype=0.2
effect_subtype=0.5

library(ggplot2)

i_plot=1
list_plot=list()

for(prop_subtype in c(0,0.1,0.2,0.3,0.5)){
  for(effect_subtype in c(0,0.5,1)){

    #subtyped trait
    set.seed(i+100+i_plot)
    combined$sub=rbinom(n = nrow(combined),size = 1,prob = prop_subtype)

    combined$x=ifelse(combined$sub==1,(1+effect_subtype)*combined$A+combined$R,combined$A+combined$R)

    #x=A+R
    #combined$x=combined$A+combined$R

    #h2_e
    h2_e=1-h2_p-vr

    #probability of disease (same with LTM)
    set.seed(i+i_plot)
    combined$L=combined$x+rnorm(nrow(combined),0,h2_e^0.5)
    t=quantile(combined$L,1-k)[[1]]
    combined$prob=pnorm(-(t-combined$x)/h2_e^0.5)

    #------logit model-----
    set.seed(i+i_plot)
    #combined$y_binary<-sapply(combined$prob,function(x) rbinom(1,1,x))
    combined$y_binary<-ifelse(combined$L>t,1,0)
    #combined$R<-ifelse(combined$R!=0,1,0)

    case<-combined[combined$y_binary==1,]

    list_plot[[letters[i_plot]]]<-ggplot(case,aes(x=R,y=A))+
      geom_point(size=0.5)+
      geom_smooth(method = "lm", se = T,data =case, color='red', fill='red')+
      xlab('LEV burden')+
      ylab('cSEV-Polygentic burden')+
      xlim(0,3)+
      ylim(-0.5,2)+
      ggtitle(paste0('proportion of subtype = ',prop_subtype,'\nadditional effect = ',effect_subtype))+
      theme(legend.position = 'none',
            panel.grid =element_blank(),
            panel.background = element_blank(),
            panel.border = element_blank(),
            axis.line = element_line(colour = "black"),
            title = element_text(size=8))+
      labs(tag=letters[i_plot])

    i_plot=i_plot+1

  }
}

library(grid)
lay_out = function(...) {
  x <- list(...)
  n <- max(sapply(x, function(x) max(x[[2]])))
  p <- max(sapply(x, function(x) max(x[[3]])))
  grid::pushViewport(grid::viewport(layout = grid::grid.layout(n, p)))

  for (i in seq_len(length(x))) {
    print(x[[i]][[1]], vp = grid::viewport(layout.pos.row = x[[i]][[2]],
                                           layout.pos.col = x[[i]][[3]]))
  }
}

png(paste0('/data/c***/z***/projects/prslev/plot/subtype/subtype_1_LEV_probit.png'),width = 2400,height = 1300,res = 150)
lay_out(list(list_plot$a,1,1),
        list(list_plot$b,2,1),
        list(list_plot$c,3,1),
        list(list_plot$d,1,2),
        list(list_plot$e,2,2),
        list(list_plot$f,3,2),
        list(list_plot$g,1,3),
        list(list_plot$h,2,3),
        list(list_plot$i,3,3),
        list(list_plot$j,1,4),
        list(list_plot$k,2,4),
        list(list_plot$l,3,4),
        list(list_plot$m,1,5),
        list(list_plot$n,2,5),
        list(list_plot$o,3,5))
dev.off()


library(cmdstanr)
library(tidyverse)

options(mc.cores = parallel::detectCores())

# YOUR DATA HERE!
d = read.csv('../data/h3.csv')

d = d %>%
    filter(
        FLAG == 0 &
        SNR > 3 &
        Vrot < 5 &
        Teff < 7000 &
        V_tan < 1000 &
        abs(V_gsr) < 400 &
        R_gal > 50 &
        !is.na(GAIAEDR3_RA) &
        !is.na(GAIAEDR3_PMRA) &
        !is.na(GAIAEDR3_PARALLAX) &
        !is.na(Vrad) &
        !is.na(X_gal)
    )

nrow(d)

# are variables observed?
posobs = !is.na(d$GAIAEDR3_RA) %>% as.integer
pmobs = !is.na(d$GAIAEDR3_PMRA) %>% as.integer
distobs = !is.na(d$dist_adpt) %>% as.integer
vlosobs = !is.na(d$Vrad) %>% as.integer
d[is.na(d)] = 0

# Format the data to be passed in to Stan.
# MULTIPLY kpc by 1000 to get pc
# DIVIDE mas by 1000 to get arcsec

mas_to_deg = 2.777777777777778e-07

standata = list(
    N = nrow(d),
    pos_obs = posobs,
    dist_obs = distobs,
    pm_obs = pmobs,
    vlos_obs = vlosobs,

    ra_measured = d$GAIAEDR3_RA,
    dec_measured = d$GAIAEDR3_DEC,
    dist_measured = d$dist_adpt, # kpc

    ra_err = d$GAIAEDR3_RA_ERROR * mas_to_deg,
    dec_err = d$GAIAEDR3_DEC_ERROR * mas_to_deg,
    dist_err = d$dist_adpt_err, # kpc

    Xgc = d$X_gal,
    Ygc = d$Y_gal,
    Zgc = d$Z_gal,

    pmra_measured = d$GAIAEDR3_PMRA, # mas/yr
    pmdec_measured = d$GAIAEDR3_PMDEC, # mas/yr
    vlos_measured = d$Vrad,

    pmra_err = d$GAIAEDR3_PMRA_ERROR, # mas/yr
    pmdec_err = d$GAIAEDR3_PMDEC_ERROR, # mas/yr
    vlos_err = d$Vrad_err,

    pos_corr = d$GAIAEDR3_RA_DEC_CORR,
    pm_corr = d$GAIAEDR3_PMRA_PMDEC_CORR,
    ra_pmra_corr = d$GAIAEDR3_RA_PMRA_CORR,
    dec_pmdec_corr = d$GAIAEDR3_DEC_PMDEC_CORR,
    ra_pmdec_corr = d$GAIAEDR3_RA_PMDEC_CORR,
    dec_pmra_corr = d$GAIAEDR3_DEC_PMRA_CORR,

    # try different priors!
    alpha_mean = 4.,
    alpha_sigma = 0.1,
    beta_mean = 0.3,
    beta_sigma = 0.05
)

# Define a function which generates a dictionary with the initial values. Initial values must be specified for either all parameters xor none of the parameters. The type for each parameter must match what is defined in the Stan model.

initfun = function() {
    list(

        p_gamma = 0.4,
        p_phi0 = 65,
        p_beta = 0.5,
        p_alpha = 4.,

        pmra = standata$pmra_measured / 5,
        pmdec = standata$pmdec_measured / 5,
        dist = standata$dist_measured,
        vlos = standata$vlos_measured / 5
    )
}

mod = cmdstan_model("../models/h3p.stan")

fit = mod$sample(
    data = standata,
    chains = 2,
    init = initfun,
    iter_warmup = 1000,
    iter_sampling = 1000,
    # output_dir = '../saved/'
    # max_treedepth = 13,
    # adapt_delta = 0.95,
)

fit = stan(file = "../models/gc.stan", # or use another model (.stan file) in the same directory
           data=stan_data,
           # warmup=4e3,
           # iter=4e3 + 2e3,
           chains = 2, # use this for diagnostics
           # chains = parallel::detectCores(),  # use all cores
           init = initfun,
           control=list(
               # max_treedepth=13,
               # adapt_delta=0.95
           ),
           verbose = TRUE
)

# Run diagnostics.
fit$cmdstan_diagnose()

# Refer to `gme.r` for examples of what to do next.


library(here)
data = readRDS(here("src/epidemia_fixed_seed.rds"))
library(rstan)

options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(here("stan-models/epidemia_base.stan"))

fit = sampling(m, data=data, iter=400, seed=8, control = list(max_treedepth=15, adapt_delta=0.9))


library(xgboost)
library(methods)
library(car)

train <- read.csv("train.csv",header=TRUE,stringsAsFactors = F)
test <- read.csv("test.csv",header=TRUE,stringsAsFactors = F)
train <- train[,-1]
test <- test[,-1]

# normalization
train[,-ncol(train)] <- log(1+train[,-ncol(train)])
test <- log(1+test)

y <- train[,ncol(train)]
y <- gsub('Class_','',y)
y <- as.integer(y)-1

x <- rbind(train[,-ncol(train)],test)
x <- as.matrix(x)
x <- matrix(as.numeric(x),nrow(x),ncol(x))

trind <- 1:length(y)
teind <- (nrow(train)+1):nrow(x)

param <- list("objective" = "multi:softprob",
              "eval_metric" = "mlogloss",
              "num_class" = 9,
              "max_depth" = 12,
              "eta" = 0.002,
              "min_child_weight" = 8,
              "max_delta_step" = 0,
              "subsample" = 0.9,
              "colsample_bytree" = 0.8
              )
set.seed(131)
nround <- 14275
bst <- xgboost(param=param, data = x[trind,], label = y, nrounds=nround)

pred <- predict(bst,x[teind,])
pred <- matrix(pred,9,length(pred)/9)
pred <- t(pred)

pred <- format(pred, digits=2,scientific=F) # shrink file size
pred <- data.frame(1:nrow(pred),pred)
names(pred) <- c('id', paste0('Class_',1:9))
write.csv(pred,file="submission.csv", quote=FALSE,row.names=FALSE)


#` Perform fast PCA (use irlba package) on LSI sparse matrix, retaining observation names (no further scaling or centering done)
#` @param mat  (sparse matrix)  A saparse matrix of TF-IDF matrix (LSI) used for PCA
#` @param dims (integer)        number of PCs to calculate (default:10)
#` @return     (sparse matrix)  A sparse matrix of PCA
do_pca <- function(mat, dims=10) {
  pca.results <- irlba(t(mat), nv=dims, fastpath=FALSE)
  PCA_result <- pca.results$u %*% diag(pca.results$d)
  rownames(PCA_result) <- colnames(mat)
  colnames(PCA_result) <- paste0('PC_', 1:dims)
  return(PCA_result)
}


#' Data from growth charts
#'
#' @details
#' A data frame containing information for growth charts from the National Center from Health and Statistics. Visit \url{https://www.cdc.gov/growthcharts/percentile_data_files.htm} for more details.
#'
#' @format Data frame with 14 variables and 436 observations:
#' \describe{
#'    \item{Gender}{A character string. Refers to Male or Female.}
#'    \item{Agemos}{Age in months}
#'    \item{Power}{Power in the Box-Cox transformation}
#'    \item{Median}{Median}
#'    \item{CV}{Generalized Coeficient of Variation}
#'    \item{P3}{Data under percentile 3}
#'    \item{P5}{Data under percentile 5}
#'    \item{P10}{Data under percentile 10}
#'    \item{P25}{Data under percentile 25}
#'    \item{P50}{Data under percentile 50}
#'    \item{P75}{Data under percentile 75}
#'    \item{P90}{Data under percentile 90}
#'    \item{P95}{Data under percentile 95}
#'    \item{P97}{Data under percentile 97 }
#'
#' }
#' @usage curves
#'

"curves"


test_that("first works", {
  expect_equal(first((1:5) > 3), 4)
  expect_equal(first((1:5) > 5), integer(0))
})

test_that("sort_by works", {
  # mpg_expec = mtcars %>% arrange(disp) %>% head %>% pull(mpg)
  mpg_expec = c(33.9, 30.4, 32.4, 27.3, 30.4, 22.8)
  expect_equal(head(sort_by(mtcars, disp))$mpg, mpg_expec)
  # wt_expec = mtcars %>% arrange(desc(disp)) %>% head %>% pull(wt)
  wt_expec = c(5.250, 5.424, 5.345, 3.845, 3.440, 3.570)
  expect_equal(head(sort_by(mtcars, disp, .desc = TRUE))$wt, wt_expec)

  # with some expressions
  # drat_expec = mtcars %>% arrange(cyl*100 + hp) %>% head %>% pull(drat)
  drat_expec = c(4.93, 3.69, 4.22, 4.08, 4.08, 4.43)
  expect_equal(head(sort_by(mtcars, cyl * 100 + hp))$drat, drat_expec)
})
test_that("filter_rows works",{
  # filter(mtcars, cyl==6, disp < 200)
  expect_equal(nrow(filter_rows(mtcars, cyl == 4)), 11)
  expect_equal(unique(filter_rows(mtcars, cyl == 4)$cyl), 4)
  expect_equal(nrow(filter_rows(mtcars,
                    cyl == 6 & disp < 200)), 5)
  expect_equal(filter_rows(mtcars, cyl == 9), mtcars[integer(0),])
})


# Get input filename
inputFilename <- commandArgs(trailingOnly = TRUE)[1]
# Get output filename
outputFilename <- commandArgs(trailingOnly = TRUE)[2]

# read file into r
data <- read.csv(file=inputFilename, header=FALSE, sep=",")
# filename for result
png(file = outputFilename, width=1080,height=1080)

plot(x = data$V1,y = data$V2,
	xlab = "number",
	ylab = "lenght",

	col=rgb(255, 0, 0, maxColorValue=255),
)

# Save the file.
dev.off()


suppressPackageStartupMessages({
    library(data.table)
    library(ggplot2)
    library(colorspace)
    library(RColorBrewer)
    library(sf)
})
source('../../../functions.r')
## source('../../data/parameters.r')

spplist  <- fread('../../acap-species-list.csv')[base_species==T]
setkey(spplist, code.sra)
nspp <- nrow(spplist)

load('../../generated/model/mcmc-results.rdata')
mcsumm <- readRDS('../../generated/model/mcmc-results-summary.rds')

load('../../../input-data/grid/grids.rdata')

## * APF by species

mcsel <- mcmc[variable %in% mc_attributes[role == 'quarter0_spatial1' & vartype == 'apf_t', variable]]
mcsel <- merge(mcsel, mc_attributes, by = 'variable', all.x=T, all.y=F)
apf_sp <- mcsel[, .(value = sum(value)), .(species_code, grid_id, sample)][
  , .(mean     = mean(value),
      median   = median(value),
      sd       = sd(value),
      lcl      = quantile(value, 0.025, names=F),
      ucl      = quantile(value, 0.975, names=F),
      nsamples = .N), .(code = species_code, grid_id)]

apf_sp <- apf_sp[spplist[base_species == T], on = c('code' = 'code.sra')][
  , .(common_name = upper1st(cname), code, grid_id, mean , sd, lcl, ucl)]

## * Maps

pal <- sequential_hcl(10, 'Reds 3', rev=T)

spp <- spplist[base_species == T]
sp='DIM'
for (sp in spp$code.sra) {
    cat(sp, '\n')
    a <- apf_sp[code == sp, .(grid_id, mean)]
    if (nrow(a) > 1) {
        g <- map_grid_values(grid_values=a, legend.title = 'APF', pal=pal)
        ggsave(sprintf('../assets/apf-map-%s.png', sp), width = 7, height = 7, dpi=100)
    }
}


#######Calculation of module preservation
load("../ChineseHumanBrain/Chinese-Signed-networkConstruction-auto.RData")
load("../BrainGVEx/Caucasian-Unsigned-networkConstruction-auto.RData")
load("../overlapgenes.rdata")
load("AA-Unsigned-networkConstruction-auto.RData")
color <- moduleColors
#colorGVX <- GVXinformatio$module
setLabels = c("AA","CNS");
multiExpr = list(AA = list(data = t(AA_datExpr[genes,])),CNS = list(data = t(CNS_datExpr[genes,])));
multiColor = list(AA = color)

#ref=AA
system.time( {
mp = modulePreservation(multiExpr, multiColor,
referenceNetworks = 1,
nPermutations = 200,
randomSeed = 1,
quickCor = 0,
verbose = 3)
} );
# Save the results
save(mp, file = "AA-UnSigned-ref-CNS-test-modulePreservationin.RData");

load("CAUC-Unsigned-ref-AA-test-modulePreservationin.RData")
ref = 1
test = 2
statsObs = cbind(mp$quality$observed[[ref]][[test]][, -1], mp$preservation$observed[[ref]][[test]][, -1])
statsZ = cbind(mp$quality$Z[[ref]][[test]][, -1], mp$preservation$Z[[ref]][[test]][, -1]);

# Compare preservation to quality:
print( cbind(statsObs[, c("medianRank.pres", "medianRank.qual")],
signif(statsZ[, c("Zsummary.pres", "Zsummary.qual")], 2)) )

# Module labels and module sizes are also contained in the results
modColors = rownames(mp$preservation$observed[[ref]][[test]])
moduleSizes = mp$preservation$Z[[ref]][[test]][, 1];

# leave grey and gold modules out
plotMods = !(modColors %in% c("grey", "gold"));
# Text labels for points
text = modColors[plotMods];
# Auxiliary convenience variable
plotData = cbind(mp$preservation$observed[[ref]][[test]][, 2], mp$preservation$Z[[ref]][[test]][, 2])
# Main titles for the plot
mains = c("Preservation Median rank", "Preservation Zsummary");
# Start the plot
pdf(file="CAUCOnly-Unsigned-AA-test-modulePreservation-Zsummary-medianRank.pdf", wi=10, h=5)
par(mfrow = c(1,2))
par(mar = c(4.5,4.5,2.5,1))
for (p in 1:2)
{
min = min(plotData[, p], na.rm = TRUE);
max = max(plotData[, p], na.rm = TRUE);
# Adjust ploting ranges appropriately
if (p==2)
{
if (min > -max/10) min = -max/10
ylim = c(min - 0.1 * (max-min), max + 0.1 * (max-min))
} else
ylim = c(min - 0.1 * (max-min), max + 0.1 * (max-min))
plot(moduleSizes[plotMods], plotData[plotMods, p], col = 1, bg = modColors[plotMods], pch = 21,
main = mains[p],
cex = 2.4,
ylab = mains[p], xlab = "Module size", log = "x",
ylim = ylim,
xlim = c(10, 2000), cex.lab = 1.2, cex.axis = 1.2, cex.main =1.4)
labelPoints(moduleSizes[plotMods], plotData[plotMods, p], text, cex = 1, offs = 0.08);
# For Zsummary, add threshold lines
if (p==2)
{
abline(h=0)
abline(h=2, col = "blue", lty = 2)
abline(h=10, col = "darkgreen", lty = 2)
}
}
# If plotting into a file, close it
dev.off();

# Re-initialize module color labels and sizes
modColors = rownames(statsZ)
moduleSizes = mp$quality$Z[[ref]][[test]][, 1];
# Exclude improper modules
plotMods = !(modColors %in% c("grey", "gold"));
# Create numeric labels for each module
labs = match(modColors[plotMods], standardColors(50));
# Start the plot: open a suitably sized graphical window and set sectioning and margins.
pdf(file="CAUCOnly-Unsigned-AA-test-modulePreservation.pdf", wi=10, h=5)
par(mfrow = c(3,5))
par(mar = c(3,3,2,1))
par(mgp = c(1.6, 0.4, 0));
# Plot each Z statistic in a separate plot.
for (s in 1:ncol(statsZ))
{
min = min(statsZ[plotMods, s], na.rm = TRUE);
max = max(statsZ[plotMods, s], na.rm = TRUE);
if (min > -max/5) min = -max/5
plot(moduleSizes[plotMods], statsZ[plotMods, s], col = 1, bg = modColors[plotMods], pch = 21,
main = colnames(statsZ)[s],
cex = 1.7,
ylab = colnames(statsZ)[s], xlab = "Module size", log = "x",
ylim = c(min - 0.1 * (max-min), max + 0.1 * (max-min)),
xlim = c(20, 1000))
labelPoints(moduleSizes[plotMods], statsZ[plotMods, s], labs, cex = 0.7, offs = 0.04);
abline(h=0)
abline(h=2, col = "blue", lty = 2)
abline(h=10, col = "darkgreen", lty = 2)
}
dev.off()


# Ensemble gene noise for the H1N1

library(parallel)

setwd("/media/yuri/Data/home1/GNI_data/infection/DataSciRep/")
# Read CORUM and KEGG gene ensembles annotations
load("org.Hs.core_paths.Rdat")
names(kegg_path) <- paste0("kegg:", names(kegg_path))
# redundant to Respiratory chain complex I (subcomplex I alpha), mitochondrial complex
corum_core$`mitochondrial respiratory chain complex I assembly` <- NULL
names(corum_core) <- paste0("complex:", names(corum_core))
core_paths <- c(corum_core, kegg_path)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/")
# Read H1N1 Illumina data
load("eset_H1N1.Rdat")

# match genes between ensembles annotations and affymetrix data
core_paths_H1N1 <- lapply(seq_along(core_paths), function(i) core_paths[[i]][ core_paths[[i]] %in% rownames(eset_H1N1) ] )
names(core_paths_H1N1) <- names(core_paths)
# select ensembles represented by more than 10 genes
core_paths_H1N1 <- core_paths_H1N1[ sapply(core_paths_H1N1, length) >= 10 ]

# Calculate ensemble gene noise
H1N1_noise_paths <- lapply(seq_along(core_paths_H1N1), function(i) {
  cat(i, "\r")
  idx <- rownames(eset_H1N1) %in% core_paths_H1N1[[i]]
  dat <- eset_H1N1[idx,]
  res <- apply(dat, 2, var)
  res
})
names(H1N1_noise_paths) <- names(core_paths_H1N1)
H1N1_noise_paths <- do.call(cbind, H1N1_noise_paths)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("H1N1_Ensemble_noise.RDat")

################################################################################
# Estimate significance of association of ensemble gene noise with H1N1

library(SuppDists)
setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("H1N1_Ensemble_noise.RDat")

H1N1_stage <- samples_H1N1$'disease phase:ch1'
pR_H1N1_stage <- apply(H1N1_noise_paths, 2, function(x) {

  q = cor(x, as.numeric(factor(H1N1_stage)), method="kendall")
  r = length(H1N1_stage)
  res <- c(tau = q, p = pKendall(q,r, lower=F))

})
pR_H1N1_stage <- data.frame(t(pR_H1N1_stage))
padjR_H1N1_stage <- pR_H1N1_stage
padjR_H1N1_stage$p <- p.adjust(pR_H1N1_stage$p, "BH")
# padjR_H1N1_stage[grep("mitoch", rownames(padjR_H1N1_stage)),]

padjR_H1N1_stage_sig <- padjR_H1N1_stage[padjR_H1N1_stage$p <= 0.05,]
padjR_H1N1_stage_sig_UP <- padjR_H1N1_stage_sig[padjR_H1N1_stage_sig$tau > 0,]
# There are no significantly down-regulated pathways
# padjR_H1N1_stage_sig_DOWN <- padjR_H1N1_stage_sig[padjR_H1N1_stage_sig$tau < 0,]

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
save.image("H1N1_Ensemble_noise_sig.RDat")


#!/usr/bin/env Rscript

# Example classifier on Numerai data using logistic regression classifier.

# Set seed for reproducibility
set.seed(0)

print("Loading data...")
# Load the data from the CSV files
train <- read.csv("numerai_training_data.csv", head=T)
test <- read.csv("numerai_tournament_data.csv", head=T)

print("Removing all columns from train other than features and target...")
train <- train[,grep("feature|target",names(train))]
print("Removing all columns from test other than features and id...")
test  <- test[,grep("id|feature",names(test))]

print("Training...")
# This is your model that will learn to predict. Your model is trained on the numerai_training_data
model <- glm(as.factor(target) ~ ., data=train, family=binomial(link='logit'))

print("Predicting...")
# Your trained model is now used to make predictions on the numerai_tournament_data
predictions <- predict(model, test[,-1], type="response")
test$probability <- predictions
pred <- test[,c("id", "probability")]

print("Writing predictions to predictions.csv")
# Save the predictions out to a CSV file
write.csv(pred, file="predictions.csv", quote=F, row.names=F)
# Now you can upload your predictions on numer.ai


# sqs version 3.2 by John Alroy
# performs shareholder quorum subsampling on an array of specimen counts
# can be used to perform classical rarefaction instead of SQS
# written 29 July 2010; version 2.0 completed 14 February 2011; versions 3.0,
#  3.1, 3.2, and 3.3 written 3 June, 12 July, 19-23 August, and 2 December 2011
# change in version 3.3: fixed bug in computation of maximum estimated coverage
# changes in version 3.2: specimens drawn and subsampled U are based on
#  geometric means of counts; ignore.singletons option added
# change in version 3.1: an even better frequency adjustment involving
#  singletons and doubletons
# changes in version 3.0: an even better subsampling algorithm involving a new
#  adjustment to u combined with a new throwback criterion
# changes in version 2.0: improved subsampling algorithm; including the dominant
#  taxon is now the default; improved reporting of errors and basic statistics
# warning: do not use this program with taxonomic occurrence data drawn from
#  multiple published references because it is not designed to count
#  single-reference taxa or adjust for long taxonomic lists
# warning: version 1.0 yields estimates that are downwards-biased when q < 0.6
#  and abundance distributions are highly uneven

# Read in data
data<-read.csv("file.csv",header=TRUE)

#Convert occurrence list to occurrence table

data.occs<-table(data[,"genus"])

sqs<-function(ab,q,trials,method,ignore.singletons,dominant)  {

  params <- array(data=NA,dim=0)
  if (missing(trials))  {
    trials <- 100
  }
  if (missing(method))  {
    method <- ""
  } else if (method != "" && method != "rarefaction" && method != "CR")  {
    return(print('If the method is rarefaction enter method="rarefaction" or "CR"',quote=F))
  }
  if ((q <= 0 || q >= 1) && method != "rarefaction" && method != "CR")  {

    return(print("If the method is SQS the quota must be greater than zero and less than one",quote=F))
  } else if (q < 1 && (method == "rarefaction" || method == "CR"))  {

    return(print("If the method is rarefaction the quota must be an integer",quote=F))
  }
  ignore <- 0
  if (! missing(ignore.singletons) && (ignore.singletons == T || ignore.singletons == "yes" || ignore.singletons == "y"))  {
    ignore <- 1
  }
  if (missing(dominant))  {
    dominant <- 0
  } else if (dominant != "" && dominant != "exclude" && dominant != "no")  {
    return(print('To exclude the dominant taxon, enter dominant="exclude" or "no"',quote=F))
  }

  # compute basic statistics
  specimens <- sum(ab)
  singletons <- 0
  doubletons <- 0
  highest <- 0
  for (i in 1:length(ab))  {
    if (ab[i] == 1)  {
      singletons <- singletons + 1
    } else if (ab[i] == 2)	{
      doubletons <- doubletons + 1
    }
    if (ab[i] > highest)	{
      highest <- ab[i]
      mostfrequent <- i
    }
  }
  u <- 1 - singletons / specimens
  # optionally, exclude the dominant taxon
  if (dominant == "exclude" || dominant == "no")	{
    u <- 1 - singletons / (specimens - highest)
  }

  if (u == 0)	{
    return(print("Coverage is zero because all taxa are singletons",quote=F))
  }

  # compute raw taxon frequencies (temporarily)
  freq <- ab / specimens

  # standard recursive equation for Fisher's alpha
  alpha <- 10
  oldalpha <- 0
  while (abs(alpha - oldalpha) > 0.0000001)	{
    oldalpha <- alpha
    alpha <- length(ab) / log(1 + specimens/alpha)
  }

  params["raw richness"] <- length(ab)
  params["subsampled richness"] <- u
  params["subsampled richness"] <- NA
  params["subsampled u"] <- NA
  params["Chao 1"] <- length(ab) + singletons**2/(2* doubletons)
  params["subsampled Chao 1"] <- NA
  # governing parameter of the geometric series distribution
  params["k"] <- abs(lm(log(sort(freq)) ~ c(1:length(freq)))$coefficients[2])
  params["Fisher's alpha"] <- alpha
  params["Shannon's H"] <- -1 * sum(freq * log(freq))
  params["Hurlbert's PIE"] <- (1 - sum(freq**2)) * length(ab) / (length(ab) - 1)
  params["dominance"] <- highest / specimens
  params["specimens"] <- specimens
  params["singletons"] <- singletons
  params["doubletons"] <- doubletons
  params["specimens drawn"] <- 0

  if (dominant != "exclude" && dominant != "no")	{
    highest <- 0
    mostfrequent <- 0
  }

  # return if the rarefaction quota is equal to or higher than the
  #  specimen count
  if (method == "rarefaction" && q >= specimens - highest)	{
    return(params)
  }

  # compute taxon frequencies (tweak added in version 3.1)
  freq <- ab - (singletons + doubletons / 2) / length(ab)
  freq <- freq / (specimens - highest)

  # return if the quorum target is higher than estimated coverage
  if ((q > sum(freq) && method != "rarefaction" && method != "CR") || (q >= sum(ab)))	{
    return(params)
  }

  # create an array in which each cell corresponds to one specimen
  ids <- array()
  n <- 0
  for (i in 1:length(ab))	{
    for (j in 1:ab[i])	{
      n <- n + 1
      ids[n] <- i
    }
  }

  # subsampling trial loop
  # s will be the subsampled taxon count
  s <- array(rep(0,trials))
  drawn <- array(rep(0,trials))
  mostfrequentdrawn <- array(rep(0,trials))
  subsingle <- array(rep(0,trials))
  subdouble <- array(rep(0,trials))
  subchao <- array(rep(0,trials))

  for (trial in 1:trials)	{
    pool <- ids
    left <- length(pool)
    seen <- array(data=rep(0,length(ab)))
    subfreq <- array(rep(0,length(ab)))
    if (method != "rarefaction" && method != "CR")	{
      udrawn <- 0
      # equation new to version 3.0
      # the exponent corrects for downwards bias
      while (udrawn < q)	{
        # draw a specimen
        x <- floor(runif(1,min=1,max=left+1))
        # add to frequency and taxon sums if species has
        #  not been drawn previously
        subfreq[pool[x]] <- subfreq[pool[x]] + 1
        if (seen[pool[x]] == 0)	{
          if (pool[x] != mostfrequent && (ignore == 0 || ab[pool[x]] > 1))	{
            udrawn <- udrawn + freq[pool[x]]
          }
          seen[pool[x]] <- 1
          # randomly throw back some draws that put the sum over q
          #  (an even better algorithm added in version 3.0)
          if (runif(1) <= freq[pool[x]] || udrawn < q)	{
            s[trial] <- s[trial] + 1
          } else	{
            subfreq[pool[x]] <- subfreq[pool[x]] - 1
          }
        }
        # decrease pool of specimens not yet drawn
        pool[x] <- pool[left]
        left <- left - 1
      }
    } else	{
      i <- 0
      draws <- 0
      while (i < q)	{
        draws <- draws + 1
        x <- floor(runif(1,min=1,max=length(ids)-draws+2))
        subfreq[pool[x]] <- subfreq[pool[x]] + 1
        if (pool[x] != mostfrequent)	{
          i <- i + 1
        }
        if (seen[pool[x]] == 0)	{
          seen[pool[x]] <- 1
          s[trial] <- s[trial] + 1
        }
        pool[x] <- pool[length(ids)-draws+1]
      }
    }
    for (i in 1:length(ab))	{
      if (subfreq[i] == 1 && i != mostfrequent)	{
        subsingle[trial] <- subsingle[trial] + 1
      } else if (subfreq[i] == 2 && i != mostfrequent)	{
        subdouble[trial] <- subdouble[trial] + 1
      }
    }
    if (subsingle[trial] > 0 && subdouble[trial] > 0)	{
      subchao[trial] <- s[trial] + subsingle[trial]**2/(2*subdouble[trial])
    } else	{
      subchao[trial] <- s[trial]
    }
    drawn[trial] <- sum(subfreq)
    if (mostfrequent != 0)	{
      mostfrequentdrawn[trial] <- subfreq[mostfrequent]
    }
  }

  # compute vectors of non-zero counts
  options(warn=-1)
  s2 <- sort(sqrt(s-1))^2+1
  d2 <- sort(sqrt(drawn-1))^2+1
  m2 <- sort(sqrt(mostfrequentdrawn-1))^2+1
  ss2 <- sort(sqrt(subsingle-1))^2+1
  options(warn=0)

  # compute geometric means
  params["subsampled richness"] <- exp(mean(log(s2))) * length(s2)/length(s)
  params["specimens drawn"] <- exp(mean(log(d2))) * length(d2)/length(drawn)
  meanmost <- 0
  if (sum(mostfrequentdrawn) > 0)	{
    meanmost <- exp(mean(log(m2))) * length(m2)/length(mostfrequentdrawn)
  }
  meansubsingle <- exp(mean(log(ss2))) * length(ss2)/length(subsingle)

  params["subsampled u"] <- 1 - meansubsingle / (params["specimens drawn"] - meanmost)
  params["subsampled Chao 1"] <- exp(mean(log(subchao)))
  return(params)

}

# Check real value with a quorum of 0.4
sqs(data.occs,0.4)['subsampled richness']

# Bootstrap
s<-rep(NA,1000)
for(i in 1:length(s)){
  bootstrapped<-data.occs[sample(1:length(data.occs),replace=TRUE)]
  s[i]<-sqs(bootstrapped,0.4)['subsampled richness']
}

# To remove any NAs (bootstrapping can produce a lot of pseudo-singletons)
s<-na.omit(s)
s<-as.numeric(s)

# Returns the median and 95% confidence intervals
quantile(s,probs=c(0.5,0.025,0.975))
hist(s)


### old from version 1.05

"decomposeSurv" <-
function(
 formula,
 data,
 sort=FALSE
)
### decomposes complex survival formula
### with time-factor interactions
### 2006-10
{
	orig.formula <- formula

	## expand formula if needed:
	repeat {
		terms <- terms(formula, data=data)
		fac <- attr(terms, "factors")
		needed <- rownames(fac)[!rownames(fac) %in% colnames(fac)][-1]

		if(length(needed) == 0) break

		formula <- as.formula(paste(as.character(formula)[2], "~",
							as.character(formula)[3], "+",
							paste(needed, sep="+")))
	}

	## construct 3-col response:
	resp <- model.extract(model.frame(formula, data = data), "response")
	if(ncol(resp) == 2)
		resp <- cbind(start=rep(0, nrow(resp)), resp)

	## sortieren nach STOPzeit und -Cens
	if(sort) {
	      sort <- order(resp[, 2],  -resp[, 3])
      	data <- data[sort, , drop=FALSE]
		resp <- resp[sort, ]
	}

	mm <- model.matrix(formula, data = data) ## Model-Matrix
	mm1 <- mm[, -1, drop=FALSE]	# w/o intercept

	terms <- terms(formula, data=data)
	fac <- attr(terms, "factors")
	labels <- attr(terms, "term.labels")

	## splittes by special chars
#	f <- function(str)
#		for(chars in c("(", ")", ":", " ", ",", "*", "^"))
#			str <- unlist(strsplit(str, split=chars, fixed=TRUE))
  f<-function(str) {
          for(chars in c("(", ")", ":", " ", ",", "*", "^"))
            str <- unlist(strsplit(str, split=chars, fixed=TRUE))
          str
          }

	rowSplit <- sapply(rownames(fac), f)	# splitted effects
	stopName <- tail(rowSplit[[1]], 2)[1]	# name of stoptime
	rowInter <- unlist(lapply(rowSplit[-1], function(z) any(z == stopName)))

	fac <- fac[-1, , drop=FALSE]	# omit Surv

	colSplit <- sapply(colnames(fac), f)
	colInter <- unlist(lapply(colSplit, function(z) any(z == stopName)))

	nTimes <- colSums(fac[rowInter, , drop=FALSE])
	nFac   <- colSums(fac[!rowInter, , drop=FALSE])

	inters <- (nFac>0) & (nTimes>0)
	NTDE <- sum(inters)

	timedata <- matrix(0, nrow(data), 0)
	timeind <- c()

	## loop for (time x effect)
	for(i in which(inters)) {
		## search pure time:
		ind <- (colSums(fac[rowInter, i] != fac[rowInter, , drop=FALSE]) == 0) & (nFac==0)
		timedata <- cbind(timedata, mm1[, ind, drop=FALSE])

		## search pure effect:
		ind <- (colSums(fac[!rowInter, i] != fac[!rowInter, , drop=FALSE]) == 0) & (nTimes == 0)
		timeind <- c(timeind, which(ind[!colInter]))
	}
	mm1 <- mm1[, !colInter, drop=FALSE]

	covnames <- c(colnames(mm1),
		paste(colnames(timedata), colnames(mm1)[timeind], sep=":")
	)

	## indicator to identify the original formula:
	ind <- covnames %in% colnames(attr(terms(orig.formula, data=data), "factors"))

	list(NTDE=NTDE, 			# number time dep. effects
		fac=fac, 			# factor matrix ..
		resp=resp, 			# N x 3 - response matrix
		mm1=mm1, 			# model matrix without time effects
		timedata=timedata, 	# matrix with time functions as columns
		timeind=timeind, 		# indicator of time-dependend effect
		covnames=covnames,	# names of covariates
		ind=ind			# indicator if some terms of not in formula
	)
}


#' ms2kmh
#'
#' Conversion speed meter per second  in kilometers per hour.
#'
#' @param ms Speed numeric   in meters per second [m/s].
#' @return kilometers per hour
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  ms2kmh
#'
#' @export
#'
#'
#'
#'

ms2kmh=function(ms) {
                         ct$assign("ms", as.array(ms))
                         ct$eval("var res=[]; for(var i=0, len=ms.length; i < len; i++){ res[i]=ms2kmh(ms[i])};")
                          res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


if(require(XML)) {
  w <- xmlTreeParse('demo.xml')

  z <- w$doc$children$Transfer$children$Catalog$children$CatalogSchemas$children$Schema$children$SchemaTables$children

  u <- z[[length(z)]]$children

  v <- matrix(unlist(u), nrow=length(u), byrow=T)

  v[,seq(3,ncol(v),by=4)][1,]

##  [1] "#_4" "#_5" "#_6" "#_7" "#_8" "#_9"

  v[,seq(5,ncol(v),by=4)]

##      [,1]  [,2]  [,3]   [,4] [,5] [,6]
## [1,] "111" "ABC" "27"   "1"  "2"  "1976-04-22"
## [2,] "222" "XYX" "35.2" "2"  "1"  "1968-02-10"
## [3,] "333" "WHO" "19"   "1"  "1"  "1984-04-20"
## [4,] "444" "WHY" "45.7" "1"  "3"  "1957-08-14"
## [5,] "555" "HUH" "82"   "2"  "3"  "1921-05-06"

## Process variables one column of v at a time, converting appropriate
## ones to numeric.
}


title <- "Fac (memory)"

masterdata <- read.table("master-times-Fac", header=T)
recdata <- read.table("recursive-times-Fac", header=T)
cpsdata <- read.table("cps-times-Fac", header=T)
origdata <- read.table("orig-times-Fac", header=T)

allmem <-  c(masterdata$mem, recdata$mem, cpsdata$mem, origdata$mem)
ylim <- c(min(allmem)/1024, max(allmem/1024))

start <- function(fr,col) {  # Just to make it easier to plot biggest thing first by Trial and error
    plot  (fr$n,fr$mem/1024, col=col, pch=20, main=title, xlab = "n", ylab ="Memory (MB)", xlim = c(0,max(masterdata$n)), ylim=ylim)
    lines (fr$n,fr$mem/1024, col=col, pch=20)
}

draw <- function(fr,col) {
    points (fr$n,fr$mem/1024, col=col, pch=20)
    lines  (fr$n,fr$mem/1024, col=col, pch=20)
}

mastercol="gold"
reccol="darkolivegreen3"
cpscol="blue"
origcol="darkmagenta"

start (origdata, origcol)
draw  (masterdata,mastercol)
draw  (recdata,reccol)
draw  (cpsdata, cpscol)

legend(x="topleft", inset=.05, legend=c("master","recursive", "CPS", "Original CEK machine"), col=c(mastercol, reccol, cpscol, origcol), lty=1, lw=2)


insertionsort <- function(x)
{
   for(i in 2:(length(x)))
   {
      value <- x[i]
      j <- i - 1
      while(j >= 1 && x[j] > value)
      {
         x[j+1] <- x[j]
         j <- j-1
      }
      x[j+1] <- value
   }
  x
}

executeTask <- function(i) {

insertionsort(c(16+i,93,-99,95,-96,-24,-53,-71,96,-66,-21,72,-12,-32,-96,62,-42,-50,49,53,-65,52,-25,-69,88,-43,60,66,-94,-69,53,-71,-17,-58,-30,32,-16,-94,-42,-86,59,-53,94,97,-12,15,65,-35,-12,-82,-82,48,-48,66,-42,-63,33,-49,41,-85,94,66,-60,60,-65,-73,-50,-9,-48,-3,15,-77,81,95,-93,83,-21,34,-78,-61,-22,-58,65,78,41,-7,-59,20,88,-38,-15,-69,42,97,-35,61,8,2,-22,-85)) # -31   0   1   2   4  65  83  99 782
	return(i)
}

r=0
for(i in 0:1000000000) {
	r = executeTask(i)
}


## Boundary end detection experiments:
## These look only turns known to contain reported speech

source("../scripts/collate-word-feats.r")

## Load word info
load("xprospn.dt")
xe.params.all <- train.test.re.all(xprospn)
save(xe.params.all, file="xe.params.all")

re.feats <- names(xe.params.all[["x0.data"]])
re.feats <- re.feats[!(re.feats %in% c("p.thought","p.parc","p.said","p.rs20"))]

re.pred.all <- pred.tune(xe.params.all, feats=re.feats, outfile="pred.re.all")
fs.re.all <- get.fs.pred(xe.params.all, feats=re.feats, outfile="fs.re.all")

## only F0 and Intensity features
pcontext <- re.feats[grep("(F0|I0)",re.feats)]
re.pred.pcontext <- pred.tune(xe.params.all, feats=pcontext, outfile="pred.re.pcontext")
fs.re.pcontext <- get.fs.pred(xe.params.all, feats=pcontext, outfile="fs.re.pcontext")

## F0 and Int, no context
pros <- pcontext[grep("^d", pcontext, invert=T)]
re.pred.pros <- pred.tune(xe.params.all, feats=pros, outfile="pred.re.pros")
fs.re.pros <- get.fs.pred(xe.params.all, feats=pros, outfile="fs.re.pros")

lex <- grep("^n\\.", re.feats, value=T)
re.pred.lex <- pred.tune(xe.params.all, feats=lex, outfile="pred.re.lex")
fs.re.lex <- get.fs.pred(xe.params.all, feats=lex, outfile="fs.re.lex")

nonlex <- grep("^n\\.", re.feats, value=T, invert=T)
re.pred.nonlex <- pred.tune(xe.params.all, feats=nonlex, outfile="pred.re.nonlex")
fs.re.nonlex <- get.fs.pred(xe.params.all, feats=nonlex, outfile="fs.re.nonlex")

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

        m.end <- glmer(is.rsend ~ (1 | spk)
                        + to.zscore(mean.normF0) + to.zscore(mean.normI0)
                        + to.zscore(range.normF0) + to.zscore(range.normI0)
                        + to.zscore(mean.normF0 - p.mean.normF0)
                        + to.zscore(range.normF0 - p.range.normF0)
                        + to.zscore(mean.normI0 - p.mean.normI0)
                        + to.zscore(range.normI0 - p.range.normI0)
                        + to.zscore(mean.normF0 - n.mean.normF0)
                        + to.zscore(range.normF0 - n.range.normF0)
                        + to.zscore(mean.normI0 - n.mean.normI0)
                        + to.zscore(range.normI0 - n.range.normI0)
                        , data=xprospn,  family = binomial(link = "logit"))

        m.end <- glmer(is.rsend ~ (1 | spk)
                        + to.zscore(mean.normF0) + to.zscore(mean.normI0)
                        + to.zscore(range.normF0) + to.zscore(range.normI0)
                        + to.zscore(mean.normF0 - p.mean.normF0)
                        + to.zscore(range.normF0 - p.range.normF0)
                        + to.zscore(mean.normI0 - p.mean.normI0)
                        + to.zscore(range.normI0 - p.range.normI0)
                        + to.zscore(mean.normF0 - n.mean.normF0)
                        + to.zscore(range.normF0 - n.range.normF0)
                        + to.zscore(mean.normI0 - n.mean.normI0)
                        + to.zscore(range.normI0 - n.range.normI0)
                        , data=xprospn[is.rsturn==T],  family = binomial(link = "logit"))

u <- get.fixef(m.end)
u[ymin > 0]
u[ymax < 0]

###########################################################################
## only Intensity features
pi0 <- re.feats[grep("I0",re.feats)]
re.pred.pi0 <- pred.tune(xe.params.all, feats=pi0, outfile="pred.re.pi0")

## only F0
pf0 <- re.feats[grep("F0",re.feats)]
re.pred.pf0 <- pred.tune(xe.params.all, feats=pf0, outfile="pred.re.pf0")
fs.re.pf0 <- get.fs.pred(xe.params.all, feats=pf0, outfile="fs.re.pf0")

## only Intensity features
ti0 <- pros[grep("I0",pros)]
re.pred.ti0 <- pred.tune(xe.params.all, feats=ti0, outfile="pred.re.ti0")

## only F0
tf0 <- pros[grep("F0",pros)]
re.pred.tf0 <- pred.tune(xe.params.all, feats=tf0, outfile="pred.re.tf0")
fs.re.tf0 <- get.fs.pred(xe.params.all, feats=tf0, outfile="fs.re.tf0")

sigpros <- c("range.normF0","range.normI0","dp.range.I0", "dn.mean.I0","dn.range.I0")
re.pred.sigpros <- pred.tune(xe.params.all, feats=sigpros, outfile="pred.re.sigpros")