library(lmerTest)
library(ggplot2)

rm(list=ls())

tp<-read.csv('..\\..\\..\\empowermentexploration\\data\\regression\\20211011-1434-tinypixels-valuedifferences-human-1.csv')

tpdf<-data.frame(trial=scale(tp$trial),
                  id=paste(tp$id),
                  cbu=scale(tp$delta_cbu),
                  emp=scale(tp$delta_emp),
                  bin=scale(tp$delta_bin),
                  cbv=scale(tp$delta_cbv),
                  decision=tp$decision)

tpdf_fullregression<-glmer(decision~-1+cbu+emp+trial+trial*cbu+trial*emp+(1|id), family='binomial', data=tpdf, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
tpdf_fullregression_summary<-summary(tpdf_fullregression)
tpdf_fullregression_summary
tpdf_fullregression_m<-tpdf_fullregression_summary$coefficients[1:2,1]
tpdf_fullregression_se<-tpdf_fullregression_summary$coefficients[1:2,2]

dataforplot_tpdf_fullregression<-data.frame(mu=tpdf_fullregression_m, ci=1.96*tpdf_fullregression_se,
               model=rep(c('Uncertainty', 'Empowerment')))

#limits with 95% CIs
limits <- aes(ymax = mu + ci, ymin= mu - ci)

#plot
plot_tpdf_fullregression <- ggplot(dataforplot_tpdf_fullregression, aes(x=model, y=mu)) +
  #bars
  geom_bar(position="dodge", stat="identity", width=0.6)+
  #error bars
  geom_errorbar(limits, position="dodge", width=0.25)+
  #points
  geom_point(size=3)+
  #color
  #scale_fill_manual(values = c(cbPalette))+
  #theme
  theme_minimal() +
  #limits
  #scale_y_continuous(limits = c(0,100), expand = c(0, 0)) +
  #labs
  xlab("Model")+
  ylab(expression(beta))+
  #title
  ggtitle("")+
  #adjust text size
  theme(text = element_text(size=21,  family="sans"))+
  #no legend
  theme(legend.position = "none")

plot_tpdf_fullregression

#
#
# ## BOTTOM UP ANALYSIS
# # get model with single models as fixed effect
# me <- glmer(decision ~ -1 + emp + trial + trial*emp + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(me)
#
# mv <- glmer(decision ~ -1 + cbv + trial + trial*cbv + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(mv)
#
# mb <- glmer(decision ~ -1 + bin + trial + trial*bin + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(mb)
#
# mu <- glmer(decision ~ -1 + cbu + trial + trial*cbu + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(mu)
#
# # get model with empowerment and binary as fixed effect
# meb <- glmer(decision ~ -1 + emp + bin + trial + trial*emp + trial*bin + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(meb)
#
# # get model with empowerment and CBU as fixed effect
# meu <- glmer(decision ~ -1 + emp + cbu + trial + trial*emp + trial*cbu + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(meu)
#
# # get model with binary and CBU as fixed effect
# mub <- glmer(decision ~ -1 + bin + cbu + trial + trial*bin + trial*cbu + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(mub)
#
# # get model with empowerment and binary and CBU as fixed effect
# meub <- glmer(decision ~ -1 + emp + bin + cbu + trial + trial*emp + trial*bin + trial*cbu + (1 | id), data=tpdf, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
# summary(meub)
#
# # compare models
# anova(me, meb)
# anova(mb, meb)
# anova(me, meu)
# anova(mu, meu)
# anova(mb, mub)
# anova(mu, mub)
# anova(mub, meub)
# anova(meu, meub)
# anova(meb, meub)
#
# emponbin <- lmer(emp ~ -1 + bin + (1|id), data = tpdf)
# summary(emponbin)

#comparison of empowerment and uncertainty

emp_df <- subset(tpdf, select=c("emp","decision", "id", "trial"))
emp_df$empmodel <- 1
names(emp_df)[names(emp_df) == "emp"] <-"modelestimate"

cbu_df <- subset(tpdf, select=c("cbu","decision", "id", "trial"))
cbu_df$empmodel <- 0
names(cbu_df)[names(cbu_df) == "cbu"] <-"modelestimate"

concatenated_df<-rbind(emp_df,cbu_df)
concatenated_df_fullregression<-glmer(decision~-1+modelestimate+modelestimate*empmodel+trial+trial*modelestimate+(1|id), family='binomial', data=concatenated_df, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(concatenated_df_fullregression)


##Script to read landsat GCP files, calculate accuracy stats, and output a summary table.
## Input: GCP.txt files are read from a common folder
## Output: is a CSV file with each row: scene id, date, Mean RMSE, mean error on X, Y, their SD, and maximum RMSE among the GCP)
## By Jose Gonzalez de Tanago 2012, modified by Eliakim 2013

# set working directory
setwd("")

#Location of the GCP files
pth <- c('')

outfile <- file("geometric_accuracy.csv", "at")
output<-cbind("scene_id","gcp_id","date","juliandate","Mean_RMSE","Mean_Residual_X","Stdev_X","Mean_Residual_Y","Stdev_Y","MaxRMSE")
fl <- list.files(pth, pattern=glob2rx("*_GCP.txt"), recursive=F)

  #pth<-paste(mainpth,fldr[i],sep="")
  #setwd(pth)
for (i in 1:length(fl)){
    sid<-substr(fl[i],1,21)
    v <- fl[i]
    gcp<-v
    table <- as.data.frame(read.table (gcp, header=F,skip=5, sep="" ))
    colnames(table) <- c("Point_ID","Latitude", "Longitude", "Height", "Across", "Along","YResidual",  "XResidual")
    erx <- table$YResidual
    ery <- table$XResidual
    xmean<- mean(erx)
    xsd<-sd(erx)
    ysd<-sd(ery)
    ymean<- mean(ery)
    RMSE <- sqrt((erx^2)+(ery^2))
    maxRMSE<-max(RMSE)
    RMSEmean <-mean(RMSE)
    date<-substr(sid,10,16)
    juliandate<-substr(sid,14,16)
    outputi<- cbind(sid,gcp,date,juliandate,RMSEmean,xmean,xsd,ymean,ysd,maxRMSE)
    output <- rbind(output, outputi)
 }
write.csv(output,outfile )
close(outfile)


#Simulating the effect of observation uncertainty on overall predictability at core, plot and site scales.
#manipulating number of cores per plot.
#clear environment, load packages, source functions.
rm(list=ls())
library(DirichletReg)
source('paths.r')
source('NEFI_functions/ddirch_obs_uncertainty.r')
source('NEFI_functions/tic_toc.r')

#set output path.----
output.path <- ITS_NEON_observation_uncertainty_core.effort.path

#SEt number of cores per plot.5 levels.
cores.per.plot <- c(3,6,9,12,15)

#Generate site values, set parameters.----
set.seed(1234)
n.site <- 13
y1 <- runif(n.site, 0.1, 0.9)    #abundant taxon, varies alot.
y2 <- runif(n.site, 0.001, 0.01) #rare taxon.
y3 <- runif(n.site, 0.1, 0.2)    #abudant taxon, varies comparatively less.
y4 <- 1 - (y1 + y2 + y3)              #'other' so we sum to 1.
site_mu <- as.matrix(data.frame(y1,y2,y3,y4))

#assign variances, higher number means lower variance.
#These are based on Harvard Forest and Dopheide 2018 intra-core uncertainty.
core.var <- 300
plot.var <- 20
site.var <- 4

#run the simulation.----
#This takes a real long time. Function automatically detects number of available processors.
cat('Running simulation...\n');tic()
plot_output <- list()
for(i in 1:length(cores.per.plot)){
  run <- ddirch_obs_uncertainty(site_mu, site.var = site.var, plot.var = plot.var, core.var = core.var,
                                n.sim = 100, n.core = cores.per.plot[i])
  plot_output[[i]] <- run
  cat(i,'of',length(cores.per.plot),'simulations complete. ');toc()
}
names(plot_output) <- cores.per.plot

cat('All simulations complete.\n');toc()

#Save output.----
saveRDS(plot_output, output.path)


library(tidyverse)
library(reshape2)
library(MASS)
library(R2jags)

load('processedDat.RData')

## transform data to fit anxHard.stan

jagsDat <- list()
dat$id <- as.numeric(as.factor(dat$StudyId))

stopifnot(max(dat$id)==n_distinct(dat$StudyId))
jagsDat$N <- max(dat$id)

dat$time <- dat$time+1

jagsDat$nt <- 12

jagsDat$anx <- as.matrix(dat%>%dplyr::select(id,time,anxlevel)%>%dcast(id~time,value.var='anxlevel')%>%dplyr::select(-id))

## fill in missing values by assumption
dat$race <- as.factor(dat$Race_R)
dat$race[is.na(dat$race)] <- 1
levels(dat$race) <- names(attr(datO$Race_R,'labels'))

dat$Hispanic_R[is.na(dat$Hispanic_R)] <- 2
dat$hisp <- ifelse(dat$Hispanic_R==1,1,0)

dat$gender[is.na(dat$gender)] <- 1

X <- model.matrix(~age+gender+race+hisp+Site,
  data=dat%>%group_by(id)%>%summarize_all(function(x) x[1]))

X <- scale(X[,-1])

jagsDat$X <- X

jagsDat$ncov <- ncol(X)

mod <- jags(jagsDat,parameters=c('betaAnx','C','gamAnx'),model='anxHard.bug',n.chains=1,n.iter=100)

#mod <- stan('anxHard2.stan',data=stanDat,chains=1,iter=10,pars=c('anx','sub'),include=FALSE)

anxInit <- function(isObsAnx,anxObs,cAnx){
  nt <- ncol(anxObs)
  N <- nrow(anxObs)
  anx <- matrix(rnorm(nt*N,0,1),N,nt)
  anx[isObsAnx==1&anxObs==1] <- cAnx[1]-.2
  anx[isObsAnx==1&anxObs==2] <- mean(cAnx)
  anx[isObsAnx==1&anxObs==3] <- cAnx[2]+.2
  anx
}

subInit <- function(isObsSub,subObs){
  nt <- ncol(subObs)
  N <- nrow(subObs)
  sub <- matrix(rnorm(nt*N,0,1),N,nt)
  sub[isObsSub==1&subObs==0] <- -.5
  sub[isObsSub==1&subObs==1] <- .5
  sub
}

initFun <- function(){
  attach(stanDat)
  on.exit(detach(stanDat))
  anxMod <- polr(ordered(anxObs[,1])~X,method='probit')
  subMod <- glm(subObs[,1]~X,family=binomial('probit'))
  list(
    b=rnorm(1,0,.5),
    gamAnx=rnorm(1,.25,.5),
    gamSub=rnorm(1,.25,.5),
    betaAnx=coef(anxMod),
    betaSub=coef(subMod)[-1],
    #alphaAnx=rnorm(1),
    alphaSub=coef(subMod)[1],
    cAnx=anxMod$zeta,
    anx=anxInit(isObsAnx,anxObs,anxMod$zeta),
    sub=subInit(isObsSub,subObs))
}

mod <- stan('anxHard2.stan',data=stanDat,chains=4,iter=10000,pars=c('b','cAnx','gamAnx','gamSub','betaAnx','betaSub','alphaSub'),init=initFun,cores=4)
save(mod,file='anxHardMod.RData')


### Multilateral Development Institution Data
foo <- read.csv("https://tinyurl.com/yb4phxx8") # read in the data

# column names
names(foo)

# dimensions of the data set
dim(foo)

# quick look at the data structure
head(foo)

# one thing to be very careful with (in this data set) is the use of dates. 8 columns involve dates.

# take note of the columns representing calendar dates
date.columns <- c(11, 12, 14, 15, 16, 17, 18, 25)

# these columns need some tweaking--I want to address missing values, calling the blank (empty)
# elements "NA" instead of leaving them blank, and I wish to tell R these are "Date" objects.

for(i in date.columns)  # this "for loop" only loops through the "date.columns" -- no other columns.

  {

  # identify which values are missing in the "i"th column of the foo data set
  which_values_are_missing <- which(as.character(foo[, i]) == "")

  # those values that are missing (blank) in the "i"th column are replaced by <NA>
  # because R knows how to handle "NA" -- NA means something special in R--blanks are handled
  # more unpredictably (which is bad).
  foo[which_values_are_missing, i] <- NA

  # last step--replace each of these columns (which is structured as a column of "factor" values)
  # as a column of dates--i.e., convert them to an object of "class" = Date. They are dates, after all.
  # And if you convert them to the Date class, R will know they are dates and you can manipulate
  # dates in a simple, straightforward way. Otherwise, you won't be able to easily manipulate them
  # arithmetically.  E.g., for simple Date operations, see lines 48-58 below...
  # **By the way, if you don't understand what a "factor" is in R, you should Google it.**
  foo[, i] <- as.Date(as.character(foo[, i]))

}

# Now R knows that these columns are comprised of dates
# After replication, I obtain the same results as the github post.

foo[3,12]

foo[4,12]

foo[3,12] - foo[4,12]

# Also, one additional helpful hint... How to eliminate rows with NAs...
# The "is.na" function--for more info, Google it or type ?is.na at the R command prompt in the console.
which.have.NAs <- which(is.na(foo$Rating == TRUE)) # for which rows is the claim "is.na" a TRUE claim?

# Then, if you wanted to, e.g., remove all those rows, retaining only the rows with ratings...
new_foo <- foo[-which.have.NAs, ]
# Notice I called this tweaked data set "new_foo" instead of rewriting over the original data set...
# It's a bit safer to do this, in case I decide I want to quickly revert back to the original data set.

head(new_foo)

names(new_foo)

#I will initialize a vector test_foo for the dataset with non-missing "Circulation.Date" >= 2008-01-01.

test_foo <- new_foo[which(new_foo$CirculationDate >= "2008-01-01"),]

dim(test_foo)

head(test_foo)

# I am adding a new column to the dataset which lists the project duration in units of days
test_foo$ProjectDuration <- test_foo$OriginalCompletionDate-test_foo$ApprovalDate

head(test_foo)

#Upon inspecting the table, I realize that some projects don't have an original completion date.
sum(is.na(test_foo$OriginalCompletionDate))
sum(is.na(test_foo$ApprovalDate))

#Since there are 'NA' values in the ProjectDuration column, I will set the na.rm logical to TRUE so that R can remove the missing values.
#I will also divide the result by 365 to evaluate the average project duration in years.
mean(as.numeric(test_foo$ProjectDuration), na.rm = TRUE)/365
quantile(as.numeric(test_foo$ProjectDuration), na.rm = TRUE)/365

#Now, we will check the distribution of project duration in years to see how long different projects took to complete.
hist(as.numeric(test_foo$ProjectDuration)/365, main="Project Duration Distribution for Projects Circulated After 2008-01-01",xlab="Project Durations (months)",col="gray",label=TRUE,plot = TRUE)
#Note that the hist function automatically removes NA values while plotting the histogram.

range(test_foo$CirculationDate) #First, we will find the range of circulation dates.

#Now, let's divide the range in half and separate the dataset accordingly.

diff <- as.Date(as.character("2018-06-29"), format="%Y-%m-%d")-
              as.Date(as.character("2008-01-07"), format="%Y-%m-%d")
print(diff/2)

cut_off <- as.Date(as.character("2008-01-07"), format="%Y-%m-%d") + diff/2
print(cut_off)

circulated_earlier <- test_foo[which(new_foo$CirculationDate < "2013-04-03"),]
circulated_later <- test_foo[which(new_foo$CirculationDate >= "2013-04-03"),]

# I am adding a new column to each dataset which lists the project duration in units of days
circulated_earlier$ProjectDuration <- circulated_earlier$OriginalCompletionDate-circulated_earlier$ApprovalDate

circulated_later$ProjectDuration <- circulated_later$OriginalCompletionDate-circulated_later$ApprovalDate

#Average project duration and quantiles for projects circulated before 2013-04-03

mean(as.numeric(circulated_earlier$ProjectDuration), na.rm = TRUE)/365
quantile(as.numeric(circulated_earlier$ProjectDuration), na.rm = TRUE)/365

#Average project duration and quantiles for projects circulated after 2013-04-03

mean(as.numeric(circulated_later$ProjectDuration), na.rm = TRUE)/365
quantile(as.numeric(circulated_later$ProjectDuration), na.rm = TRUE)/365

p1 <- hist(as.numeric(circulated_earlier$ProjectDuration)/365, main="Project Duration Distribution for Projects Circulated Before 2013-04-03",xlab="Project Durations (months)",col="gray",label=TRUE,plot = TRUE)
p2 <- hist(as.numeric(circulated_later$ProjectDuration)/365, main="Project Duration Distribution for Projects Circulated After 2013-04-03",xlab="Project Durations (months)",col="gray",label=TRUE,plot = TRUE)

# I am adding a new column to the dataset which lists the actual project duration in units of days
test_foo$ActualProjectDuration <- test_foo$RevisedCompletionDate-test_foo$ApprovalDate

head(test_foo)

#Upon inspecting the table, I realize that all projects have a revised completion date.
sum(is.na(test_foo$RevisedCompletionDate))
sum(is.na(test_foo$ApprovalDate))

#Since there are no 'NA' values in the ActualProjectDuration column, I will set the na.rm logical to FALSE since R doesn't have to remove the missing values.
#I will also divide the result by 365 to evaluate the average actual project duration in years.
mean(as.numeric(test_foo$ActualProjectDuration), na.rm = TRUE)/365
quantile(as.numeric(test_foo$ActualProjectDuration), na.rm = TRUE)/365

hist(as.numeric(test_foo$ActualProjectDuration)/365, main="Actual Project Duration Distribution",xlab="Actual Project Durations (months)",col="gray",label=TRUE,plot = TRUE)

#Now, we will calculate the average difference in means between actual project duration and original planned project duration.
#We will also evaluate difference in quantiles.
mean(as.numeric(test_foo$ActualProjectDuration - test_foo$ProjectDuration), na.rm = TRUE)/365
quantile(as.numeric(test_foo$ActualProjectDuration), na.rm = TRUE)/365 - quantile(as.numeric(test_foo$ProjectDuration), na.rm = TRUE)/365

#First, we will check if any of the projects are missing a rating.
sum(is.na(test_foo$Rating))
range(test_foo$Rating) #Ratings range from 0 to 3.

zero_rating_index <- which(test_foo$Rating == "0")
zero_rating <- length(zero_rating_index) * 100/ dim(test_foo)[1]

one_rating_index <- which(test_foo$Rating == "1")
one_rating <- length(one_rating_index)* 100 / dim(test_foo)[1]

two_rating_index <- which(test_foo$Rating == "2")
two_rating <- length(two_rating_index)* 100 / dim(test_foo)[1]

three_rating_index <- which(test_foo$Rating == "3")
three_rating <- length(three_rating_index)* 100 / dim(test_foo)[1]

percentageA <- round(c(zero_rating, one_rating, two_rating, three_rating), 1)
Rate <- c("0","1","2","3")

df <- data.frame(Rate, Percentage = percentageA)
names(df) <- c('Ratings', "% of Projects")
df

#First, we will use the which function to find the indices of the PPTA projects.
which.are.PPTAs <- which(test_foo$Type == "PPTA")

# Then,  we  will retain only the rows which exclude PPTA projects.
new_test_foo <- test_foo[-which.are.PPTAs, ]

zero_rating_index <- which(new_test_foo$Rating == "0")
zero_rating <- length(zero_rating_index) * 100/ dim(new_test_foo)[1]

one_rating_index <- which(new_test_foo$Rating == "1")
one_rating <- length(one_rating_index)* 100 / dim(test_foo)[1]

two_rating_index <- which(new_test_foo$Rating == "2")
two_rating <- length(two_rating_index)* 100 / dim(test_foo)[1]

three_rating_index <- which(new_test_foo$Rating == "3")
three_rating <- length(three_rating_index)* 100 / dim(test_foo)[1]

percentageB <- round(c(zero_rating, one_rating, two_rating, three_rating), 1)
Rate <- c("0","1","2","3")

df1 <- data.frame(Rate, Percentage = percentageB, Difference = percentageA-percentageB)
names(df1) <- c('Ratings', '% of Projects excluding PPTAs',"Difference (Including PPTAs - Excluding PPTAs)")
df1

top_revised_foo <- test_foo[test_foo$RevisedAmount > quantile(test_foo$RevisedAmount,prob=1-25/100),]
bottom_revised_foo <- test_foo[test_foo$RevisedAmount < quantile(test_foo$RevisedAmount,prob=25/100),]

dim(top_revised_foo)
dim(bottom_revised_foo)

top_zero_index <- which(top_revised_foo$Rating == "0")
zero_rating_top <- length(top_zero_index) * 100/ dim(top_revised_foo)[1]

bottom_zero_index <- which(bottom_revised_foo$Rating == "0")
zero_rating_bottom <- length(zero_rating_index) * 100/ dim(bottom_revised_foo)[1]

top_one_index <- which(top_revised_foo$Rating == "1")
one_rating_top <- length(top_one_index)* 100 / dim(top_revised_foo)[1]

bottom_one_index <- which(bottom_revised_foo$Rating == "1")
one_rating_bottom <- length(bottom_one_index)* 100 / dim(bottom_revised_foo)[1]

top_two_index <- which(top_revised_foo$Rating == "2")
two_rating_top <- length(top_two_index)* 100 / dim(top_revised_foo)[1]

bottom_two_index <- which(bottom_revised_foo$Rating == "2")
two_rating_bottom <- length(bottom_two_index)* 100 / dim(bottom_revised_foo)[1]

top_three_index <- which(top_revised_foo$Rating == "3")
three_rating_top <- length(top_three_index)* 100 / dim(top_revised_foo)[1]

bottom_three_index <- which(bottom_revised_foo$Rating == "3")
three_rating_bottom <- length(bottom_three_index)* 100 / dim(bottom_revised_foo)[1]

top_percentage <- round(c(zero_rating_top, one_rating_top, two_rating_top, three_rating_top), 1)
bottom_percentage <- round(c(zero_rating_bottom, one_rating_bottom, two_rating_bottom, three_rating_bottom), 1)

Rate <- c("0","1","2","3")

df2 <- data.frame(Rate, top_percentage, bottom_percentage, top_percentage - bottom_percentage )
names(df2) <- c('Ratings', 'Top 25%','Bottom 25%', "Difference (Top 25% - Bottom 25%)")
df2

#Counts unique values of county

county_A <- aggregate(data.frame(count = top_revised_foo$Dept), list(value = top_revised_foo$Dept), length)
county_A[2] <- round(county_A[2] * 100/ dim(top_revised_foo)[1],2)
county_A <- county_A[order(-county_A$count),]
names(county_A) <- c("County (top 25%)", "Percentage Count")

county_B <- aggregate(data.frame(count = bottom_revised_foo$Dept), list(value = bottom_revised_foo$Dept), length)
county_B[2] <- round(county_B[2] * 100/ dim(bottom_revised_foo)[1],2)
county_B <- county_B[order(-county_B$count),]
names(county_B) <- c("County (bottom 25%)", "Percentage Count")

county_A
county_B

#Count unique values of division

division_A <- aggregate(data.frame(count = top_revised_foo$Division), list(value = top_revised_foo$Division), length)
division_A[2] <- round(division_A[2] * 100/ dim(top_revised_foo)[1],2)
names(division_A) <- c("Division (top 25%)", "Percentage Count")
division_B <- aggregate(data.frame(count = bottom_revised_foo$Division), list(value = bottom_revised_foo$Division), length)
division_B[2] <- round(division_B[2] * 100/ dim(bottom_revised_foo)[1],2)
names(division_B) <- c("Division (bottom 25%)", "Percentage Count")

dim(division_A)
dim(division_B)

#Since the dataframes are 83 and 118 rows long in total, I will only examine the top 10 divisions with the highest count.
top_division_A <- head(division_A[order(-division_A[2]),], 10)
names(top_division_A) <- c("10 Divisions with highest projects (top 25%)", "Percentage Count")
top_division_A

top_division_B <- head(division_B[order(-division_B[2]),], 10)
names(top_division_B) <- c("10 Divisions with highest projects (bottom 25%)", "Percentage Count")
top_division_B

#Count unique values of Cluster

cluster_A <- aggregate(data.frame(count = top_revised_foo$Cluster), list(value = top_revised_foo$Cluster), length)
cluster_A[2] <- round(cluster_A[2] * 100/ dim(top_revised_foo)[1],2)
names(cluster_A) <- c("Cluster (top 25%)", "Count")
cluster_A <- cluster_A[order(-cluster_A[2]),]

cluster_B <- aggregate(data.frame(count = bottom_revised_foo$Cluster), list(value = bottom_revised_foo$Cluster), length)
cluster_B[2] <- round(cluster_B[2] * 100/ dim(bottom_revised_foo)[1],2)
names(cluster_B) <- c("Cluster (bottom 25%)", "Percentage Count")
cluster_B <- cluster_B[order(-cluster_B[2]),]

cluster_A
cluster_B

#Count unique values of country

country_A <- aggregate(data.frame(count = top_revised_foo$Country), list(value = top_revised_foo$Country), length)
country_A[2] <- round(country_A[2] * 100/ dim(top_revised_foo)[1],2)
names(country_A) <- c("Country (top 25%)", " Percentage Count")
country_A <- country_A[order(-country_A[2]),]

country_B <- aggregate(data.frame(count = bottom_revised_foo$Country), list(value = bottom_revised_foo$Country), length)
country_B[2] <- round(country_B[2] * 100/ dim(bottom_revised_foo)[1],2)
names(country_B) <- c("Country (bottom 25%)", "Percentage Count")
country_B <- country_B[order(-country_B[2]),]

country_A
country_B
dim(country_A)
dim(country_B)

#Count unique values of type

type_A <- aggregate(data.frame(count = top_revised_foo$Type), list(value = top_revised_foo$Type), length)
type_A[2] <- round(type_A[2] * 100/ dim(top_revised_foo)[1],2)
type_A <- type_A[order(-type_A[2]),]
names(type_A) <- c("Type (top 25%)", "Percentage Count")
type_B <- aggregate(data.frame(count = bottom_revised_foo$Type), list(value = bottom_revised_foo$Type), length)
type_B[2] <- round(type_B[2] * 100/ dim(bottom_revised_foo)[1],2)
type_B <- type_B[order(-type_B[2]),]
names(type_B) <- c("Type (bottom 25%)", "Percentage Count")

type_A
type_B


library(epimdr)

data(ccs)

plot(ccs$size, ccs$ext*100, log = "x", xlab =
     "Community size", ylab = "Percent
     of time extinct")

plot(magono$time, magono$number, ylab = "Cases",
     xlab = "Year")
lines(lowess(x = magono$time, y = magono$number, f=.4))

data(cholera)
ses = sesdv = rep(NA, 12)
ses[c(7:12, 1:6)] = sapply(split(cholera$Dacca,
     cholera$Month), mean, na.rm = TRUE)
sesdv[c(7:12, 1:6)] = sapply(split(cholera$Dacca,
     cholera$Month), sd, na.rm = TRUE)/
     sqrt(length(split(cholera$Dacca, cholera$Month)))
require(plotrix)
plotCI(x = 1:12, y = ses, ui = ses+sesdv, li = ses-
     sesdv, xlab = "Month", ylab = "Deaths")
lines(x = 1:12, y = ses)


# cat rf.train.r | R --slave --vanilla --args TYPE NTREE MTRY TR MODEL IMP_PLOT

library(randomForest)

type <- commandArgs(TRUE)[1]
ntree <- as.integer(commandArgs(TRUE)[2])
mtry <- as.integer(commandArgs(TRUE)[3])
model <- commandArgs(TRUE)[5]
imp <- commandArgs(TRUE)[6]
seed = 0; set.seed(seed)

# load data
csv <- read.csv( commandArgs(TRUE)[4], header=FALSE ); tr.x <- csv[,2:ncol(csv)]
if ( 'classify' == type ) {
	tr.y <- factor(csv[,1])
} else {
	tr.y <- csv[,1]
}

rf <- randomForest( tr.y ~ ., data=tr.x, ntree=ntree, mtry=mtry, importance=TRUE, na.action=na.omit )
save( rf, file=model )

png( imp, height = 15*nrow(rf$importance)+150 )
varImpPlot( rf, n.var=nrow(rf$importance) )

if ( 'classify' == type ) {
	importance(rf)[,-2:-1]
} else {
	importance(rf)
}

# vi:nowrap:sw=4:ts=4


# 2. faza: Uvoz podatkov
library(readr)
library(dplyr)
library(rvest)
library(tidyverse)

seznam.map <- list.files(path="podatki/Padavine", full.names = TRUE)

for (mapa in seznam.map) {

  seznam.datotek <- list.files(path=mapa, pattern = "^RR", full.names = TRUE)
  podatki <- read_csv(seznam.datotek, skip = 19) %>% select(DATE, RR)
  podatki$RR[podatki$RR == -9999] <- NA

  stevilo.postaj <- sum(podatki$DATE == 20010501)

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

  racunanje <- podatki %>% filter(DATE > 20151231) %>% group_by(DATE) %>%
    summarise(padavine.dnevno=sum(RR, na.rm=T),
              stevilo.na=sum(is.na(RR)))
  racunanje$povprecno <- racunanje$padavine.dnevno / (stevilo.postaj - racunanje$stevilo.na)

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

  tabela <- tibble(država=basename(mapa),
                   leto=substr(racunanje$DATE, 1, 4) %>% as.integer(),
                   mesec=substr(racunanje$DATE, 5, 6) %>% as.integer(),
                   dan=substr(racunanje$DATE, 7, 8) %>% as.integer(),
                   padavine=racunanje$povprecno) %>% group_by(država, leto, mesec) %>%
    summarise(padavine=round(sum(padavine)/10))

  assign(basename(mapa), tabela)
}

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

EU.clanice <- read_html("podatki/oznake_drzav.html") %>%
  html_nodes(xpath="//table[@class='tdcontent']") %>% .[[1]] %>%
  html_table() %>% select(3, 5) %>% head(27)

colnames(EU.clanice) <- c("Država", "Oznaka.države")

drzave.padavine <- EU.clanice %>% filter(!Država %in% c("Nemčija", "Bolgarija", "Latvija"))
seznam.tabel <- lapply(drzave.padavine$Oznaka.države, get)

padavine <- Reduce(function(x, y) merge(x, y, all=TRUE), seznam.tabel)


# https://towardsdatascience.com/animating-your-data-visualizations-like-a-boss-using-r-f94ae20843e3

hand_data <- read.csv(file="log_1616588440.log",head=TRUE,sep=" ")
hand_data <- transform(hand_data, timestamp = (timestamp - hand_data[1,1]))
hand_data <- transform(hand_data, height = (height * 0.001))
hand_data

library(plotly)

p <- hand_data %>%
  plot_ly(
    x = ~x,
    y = ~y,
    size = 10,
    color = ~height,
    frame = ~timestamp,
    text = ~height,
    hoverinfo = "text",
    type = 'scatter',
    mode = 'markers'
  ) %>%
  layout(
    xaxis = list(
      type = "log"
    )
  )


aggregate_ifr_data_by_age = function(path_to_file_pop_us, path_to_file_ifrbyage = NULL, ifr.by.age = NULL, max_age = 100)
{

  stopifnot(any(!is.null(c(path_to_file_ifrbyage, ifr.by.age))))

  if(!is.null(path_to_file_ifrbyage)){
    ifr.by.age <- as_tibble(read.csv(path_to_file_ifrbyage))
  }

  if(!is.null(ifr.by.age)){
    ifr.by.age <- as_tibble(ifr.by.age)
  }

  stopifnot( c('age','ifr_mean')%in%colnames(ifr.by.age) )
  ifr.by.age <- ifr.by.age %>%
    dplyr::select(age, ifr_mean, ifr_cl, ifr_cu)
  #    aggregate data on contacts by 1-year bands to data by desired age bands
  pop_by_age <- readRDS(path_to_file_pop_us)
  age_bands <- dplyr::select(pop_by_age[which(!is.na(pop_by_age$code)),], -Total) %>%
    reshape2::melt(id.vars = c("Region", "code")) %>%
    dplyr::rename(age = variable, pop = value, state = Region) %>% dplyr::select(age) %>% dplyr::distinct()
  age.cat <- sapply(strsplit(gsub("\\[|\\]|\\(|\\+", "", age_bands$age), "-"), as.numeric)
  if (is.na(age.cat[[length(age.cat)]][2])) age.cat[[length(age.cat)]][2] <- 99
  age.cat <- matrix(unlist(age.cat), ncol = 2, byrow = TRUE)

  ifr.by.age <- ifr.by.age[1:max_age,] %>% # 0 to 95
    dplyr::mutate(age.agg:= cut(age, breaks=c(age.cat[,1],max_age), right=FALSE, labels=seq_len(length(c(age.cat[,1],max_age))-1L))) %>%
    dplyr::group_by(age.agg) %>%
    dplyr::summarise(ifr_mean:= mean(ifr_mean),
                     ifr_cl:= mean(ifr_cl),
                     ifr_cu:= mean(ifr_cu)) %>%
    ungroup() %>%
    dplyr::rename(age= age.agg)

  return(ifr.by.age)
}


subroutine crossutil(i,j,k,x,y,ntot,eps,collin)
implicit double precision(a-h,o-z)
dimension x(-3:ntot), y(-3:ntot)
dimension xt(3), yt(3)
logical collin

xt(1) = x(i)
yt(1) = y(i)
xt(2) = x(j)
yt(2) = y(j)
xt(3) = x(k)
yt(3) = y(k)

# Create indicator telling which of i, j, and k are ideal points.
# The point being added, i, is never ideal.
i1 = 0
if(j<=0) j1 = 1
else j1 = 0
if(k<=0) k1 = 1
else k1 = 0
ijk = i1*4+j1*2+k1

call cross(xt,yt,ijk,cprd)
collin = (abs(cprd) < eps)
return
end


pdf_file<-"pdf/tablecharts_heatmap.pdf"
cairo_pdf(bg="grey98", pdf_file,width=7,height=8)

library(RColorBrewer)
library(pheatmap)
par(mai=c(0.25,0.25,0.25,1.75),omi=c(0.25,0.25,0.75,0.85),family="Lato Light",las=1)

# Import data and prepare chart

myGrades<-read.xls("myData/grades.xlsx", encoding="latin1")
x<-as.matrix(myGrades[,2:13])
rownames(x)<-myGrades$names
x<-x[order(rowSums(x)), ]
x<-x[,order(colSums(x))]

# Create chart

plot.new()
pheatmap(x,col=brewer.pal(6,"Spectral"),cluster_rows=F,cluster_cols=F,cellwidth=25,cellheight=14,border_color="white",fontfamily="Lato Light")

# Titling

mtext("Heat map of school grades within a fictional class",3,line=1,adj=0.2,cex=1.75,family="Lato Black",outer=T)
mtext("Fictional data, names generated with de.fakenamegenerator.com",1,line=-1,adj=1,cex=0.85,font=3,outer=T)
dev.off()


# HW1.R
# Betty Malloy
# 9.11.2020
# Code I used for HW 1 problem 1.

library(mosaic)
library(ggplot2)

lead <- read.csv("lead.csv",header=T)
dim(lead) # number of observations by number of variables
summary(lead$MAXFT) # note the NA's are missing values!
summary(lead$iqf) # no NA's so no missing values

# MAXFT
favstats(MAXFT ~ factor(GROUP), data = lead) # also gives missing values
histogram(~MAXFT | factor(GROUP), data = lead,col="light blue")
qplot(x = factor(lead$GROUP),y = lead$MAXFT, geom = "boxplot",xlab='exposure group',
      ylab='MAXFT')  # the warning you get reiterates there are missing values!

# iqf
favstats(iqf ~ factor(GROUP), data = lead)
histogram(~iqf | factor(GROUP), data = lead,col="light blue")
qplot(x = factor(lead$GROUP),y = lead$iqf, geom = "boxplot",xlab='exposure group',
      ylab='iqf')


#covariate selection on tedersoo ITSprior.
#linear combination of as many predictors as we can think of, no interactions.
#clear environment, load paths and functions.
rm(list=ls())
source('NEFI_functions/covariate_selection_JAGS.r')
source('NEFI_functions/crib_fun.r')
source('paths.r')

#load data.
d <- data.table::data.table(readRDS(ted.ITSprior_data))
d <- d[,.(Ectomycorrhizal,Saprotroph,Pathogen,Arbuscular,cn,pH,moisture,NPP,map,mat,forest,conifer,relEM)]
d <- d[complete.cases(d),] #optional. This works with missing data.
#d <- d[1:35,] #subset to test.

#organize y data
y <- d[,.(Ectomycorrhizal,Saprotroph,Pathogen,Arbuscular)]
#make other column
y <- data.frame(lapply(y,crib_fun))
y$other <- 1 - rowSums(y)
y <- as.data.frame(y)
#reorder columns. other needs to be first.
y <- y[c('other','Ectomycorrhizal','Pathogen','Saprotroph','Arbuscular')]

#Drop in intercept, setup predictor matrix.
d$intercept <- rep(1,nrow(d))
x <- d[,.(intercept,cn,pH,moisture,NPP,mat,map,forest,conifer,relEM)]
x$map <- log(x$map)
y <- as.data.frame(y)
x <- as.data.frame(x)

#run the algorithm.
send_it <- covariate_selection_JAGS(y=y,x_mu=x, n.adapt = 300, n.burnin = 1000, n.sample = 1000, parallel = F)

#save the output.
saveRDS(send_it, ITS.prior_linear_fg_cov.selection_JAGS)


pdf_file<-"pdf/lorenzcurves_10.pdf"
cairo_pdf(bg="grey98", pdf_file,width=6.5,height=7.25)

par(mai=c(0,0,0,0),omi=c(0.75,0.5,0.85,0.2),pin=c(4,4),family="Lato Light",las=1)

# Read data and prepare chart

library(gdata)
myData<-read.xls("myData/income_ten_classes.xlsx",head=T,skip=1,dec=".",encoding="latin1")
attach(myData)
U<-rep(10,10)
U_cum<-c(0,cumsum(U/100))
U2_cum<-c(0,cumsum(U2/100))

# Define chart and other elements

plot(U_cum,U2_cum,type="n",axes=F,xlab="cumulative percentage of population",ylab="cumulative percentage of income",xlim=c(0,1),ylim=c(0,1))
lines(U_cum,U2_cum,lwd=2)
points(U_cum,U2_cum,pch=19)
x<-array(c(0,1,0,1),dim=c(2,2))
lines(x,lwd=2,col="black")
text(0.08,0.585,"Uniform distribution",adj=c(0,0))
text(0.72,0.265,"Inequality",adj=c(0,0))
arrows(0.4,0.28,0.7,0.28,length=0.10,angle=10,code=1,lwd=2,col="black")
arrows(0.49,0.6,0.6,0.60,length=0.10,angle=10,code=2,lwd=2,col="black")
xx<-c(U_cum,rev(U_cum))
yy<-c(U2_cum,rev(U_cum))
polygon(xx,yy,col=rgb(255,97,0,50,maxColorValue=255),border=F)
source("scripts/inc_axes_with_lines_lorenz.r")

# Titling

mtext("Income Distribution in the USA in 2000",side=3,line=1,cex=1.5,family="Lato Black",adj=0,outer=T)
mtext("(10 classes)",side=3,line=-1.5,cex=1.25,font=3,adj=0,outer=T)
mtext("Source: United Nations University, UNU-WIDER World Income Inequality Database",1,line=1,adj=1,cex=0.85,font=3,outer=T)
dev.off()


# Goal: Display two series on one plot, one with a left y axis
#       and another with a right y axis.

y1 <- cumsum(rnorm(100))
y2 <- cumsum(rnorm(100, mean=0.2))

par(mai=c(.8, .8, .2, .8))
plot(1:100, y1, type="l", col="blue", xlab="X axis label", ylab="Left legend")
par(new=TRUE)
plot(1:100, y2, type="l", ann=FALSE, yaxt="n")
axis(4)
legend(x="topleft", bty="n", lty=c(1,1), col=c("blue","black"),
       legend=c("String 1 (left scale)", "String 2 (right scale)"))

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


#========================================================================
#Data set load and prep

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

#load data
dftrain <- read.csv("train.csv", header=TRUE)
dffeatures <- read.csv("features.csv", header=TRUE)
dfstores <- read.csv("stores.csv", header=TRUE)
dftmp2 <- merge(dftrain, dfstores, by = "Store")
dfrm <- merge(dftmp2, dffeatures, by = c("Store","Date", "IsHoliday"))

#replace NAs by mean value
dfrm$MarkDown1[is.na(dfrm$MarkDown1)] <- mean(dfrm$MarkDown1,na.rm=TRUE)
dfrm$MarkDown2[is.na(dfrm$MarkDown2)] <- mean(dfrm$MarkDown2,na.rm=TRUE)
dfrm$MarkDown3[is.na(dfrm$MarkDown3)] <- mean(dfrm$MarkDown3,na.rm=TRUE)
dfrm$MarkDown4[is.na(dfrm$MarkDown4)] <- mean(dfrm$MarkDown4,na.rm=TRUE)
dfrm$MarkDown5[is.na(dfrm$MarkDown5)] <- mean(dfrm$MarkDown5,na.rm=TRUE)
dfrm$CPI[is.na(dfrm$CPI)] <- mean(dfrm$CPI,na.rm=TRUE)
dfrm$Unemployment[is.na(dfrm$Unemployment)] <- mean(dfrm$Unemployment,na.rm=TRUE)

#replace Type A/B/C by 1/2/3
dfrm$Type <- as.numeric(dfrm$Type)

#replace IsHoliday T/F by 1/2
dfrm$IsHoliday <- as.numeric(dfrm$IsHoliday) + 1

#Add Week Column based on Date
dfrm[,"Week"] <- as.numeric(dfrm$Date)

#add Seasonality 1-52
dfrm <- transform(dfrm, Seasonality = (Week %% 52) + 1 )

#scale parameters
dfrm$Size <- scale(dfrm$Size)
dfrm$Temperature <- scale(dfrm$Temperature)
dfrm$Fuel_Price <- scale(dfrm$Fuel_Price)
dfrm$MarkDown1 <- scale(dfrm$MarkDown1)
dfrm$MarkDown2 <- scale(dfrm$MarkDown2)
dfrm$MarkDown3 <- scale(dfrm$MarkDown3)
dfrm$MarkDown4 <- scale(dfrm$MarkDown4)
dfrm$MarkDown5 <- scale(dfrm$MarkDown5)
dfrm$CPI <- scale(dfrm$CPI)
dfrm$Unemployment <- scale(dfrm$Unemployment)

#========================================================================
#basic linear model statistics
res <- lm( Weekly_Sales ~ Store
		+ Dept
		+ Week
		+ IsHoliday
		+ Type
		+ Temperature
		+ Fuel_Price
		+ MarkDown1
		+ MarkDown2
		+ MarkDown3
		+ MarkDown4
		+ MarkDown5
		+ CPI
		+ Unemployment
		+ Seasonality
		, data = dfrm)

summary(res)
anova(res)
#MarkDown4 not relevant
#High correlation of other variables (p-value < 0.05)
#Low quality of model (R-square VERY low)

#========================================================================
#selection of regression variables backward
resb <- lm( Weekly_Sales ~ Store
		+ Dept
		+ Week
		+ IsHoliday
		+ Type
		+ Temperature
		+ Fuel_Price
		+ MarkDown1
		+ MarkDown2
		+ MarkDown3
		+ MarkDown4
		+ MarkDown5
		+ CPI
		+ Unemployment
		+ Seasonality
		, data = dfrm)
reduced <- step(resb, direction = "backward")
summary(reduced)
anova(reduced)
#MarkDown4 not relevant

#========================================================================
#selection of regression variables forward
res1 <- lm( Weekly_Sales ~ 1, data = dfrm)
fwd <- step(res1, direction = "forward", scope = (~ Store
		+ Dept
		+ Week
		+ IsHoliday
		+ Type
		+ Temperature
		+ Fuel_Price
		+ MarkDown1
		+ MarkDown2
		+ MarkDown3
		+ MarkDown4
		+ MarkDown5
		+ CPI
		+ Unemployment
		+ Seasonality))
summary(fwd)
anova(fwd)
#MarkDown4, Week and Fuel_Price are not relevant

#========================================================================
library(MASS)
bc <- boxcox(res)

#========================================================================
#shows differences with the different date algorithms
#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

library("dplyr")

#load data
dftrain <- read.csv("train.csv", header=TRUE)
dftest <- read.csv("test.csv", header=TRUE)

#Add Seasonality Column based on factor of Date
dftrain[,"Seasonality"] <- (as.numeric(dftrain$Date) %% 52) + 1
dftest[,"Seasonality"] <- ((as.numeric(dftest$Date) + 143) %% 52) + 1

# using ISO calendar week
dftrain[,"Seasonality2"] <- format(as.Date(dftrain$Date), "%U")
dftest[,"Seasonality2"]  <- format(as.Date(dftest$Date), "%U")

dftraindiff <- dftrain %>%
	select(Date, IsHoliday, Seasonality, Seasonality2) %>%
	distinct()

dftestdiff <- dftest %>%
	select(Date, IsHoliday, Seasonality, Seasonality2) %>%
	distinct()

dftotal <- rbind(dftraindiff, dftestdiff)
dftotal <- transform(dftotal, Diff = as.numeric(Seasonality2) - Seasonality)

write.csv(file = "datedifferences.csv", dftotal, row.names=FALSE)
#========================================================================
#how many dept we have full data (143 points)

#working directory
setwd("C:/mauricio/Dropbox/vagrant/apps/Kaggle---Walmart-forecast-challenge")

library("dplyr")

#load data
dftrain <- read.csv("train.csv", header=TRUE)

mas <- 0
menos <- 0

# for every store (45)
for (i in 1:45)
{
	#for every department (99)
	for (j in 1:99)
	{
		#do we have enough train data?
		dfsample <- dftrain %>%
			filter(Store == i) %>%
			filter(Dept == j)
		# no data
		if(nrow(dfsample) == 0) next
		if(nrow(dfsample) < 143)
			menos <- menos +1
		else
			mas <- mas +1
	}
}
print(menos)
print(mas)


\name{from_networkDynamic}
\alias{from_networkDynamic}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Convert a networkDynamic object to a PAFit_net object
}
\description{
  This function converts a \code{networkDynamic} object (of package \pkg{networkDynamic}) to a \code{PAFit_net} object.
}
\usage{
  from_networkDynamic(net)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{net}{
    An object of class \code{networkDynamic}.
  }
}

\value{
  The function returns a \code{PAFit_net} object.
}

\author{
  Thong Pham \email{thongphamthe@gmail.com}
}

\examples{
library("PAFit")
# a network from Bianconi-Barabasi model
net          <- generate_BB(N = 50 , m = 10 , s = 10)
nD_graph     <- to_networkDynamic(net)
back         <- from_networkDynamic(nD_graph)
}


# .hlpr_get_matrix ----
.hlpr_get_matrix <- function (data) {
  if ((all(data$Parameter1 %in% data$Parameter2) && all(data$Parameter2 %in% data$Parameter1))) {
    vars <- as.character(unique(c(data$Parameter1, data$Parameter2)))
    dim <- length(vars)
    m <- matrix(nrow = dim, ncol = dim, dimnames = list(vars, vars))
  }
  else {
    m <- matrix(nrow = length(unique(data$Parameter1)), ncol = length(unique(data$Parameter2)), dimnames = list(unique(data$Parameter1), unique(data$Parameter2)))
  }
  m[] <- 1

  return(m)
}


tosummaryMat = function(x){
	#Turns the return from partionSummary into a matrix
	return(data.frame(id =x$levels_out,
		n = x$n_vec))
}
partitionSummary = function(outcome, part1, part2 = NULL){
  ##outcome should be numeric
  #part1, part2, are partitioning factors
  #returns:  levels, labels, n_vec, mean_vec
  #This function doesnt handle names that well,
  # and the (few) ways we partition the data must be mmanually labeled
  #Can optionally add dg pcf and group vecs to obtain Draper-Gittoes scores
  #Optimized by Lucy Greenberg
if (is.null(part1)){return(NULL)}
  #Both vectors need to be partitions
 part1 = as.factor(part1)
 if (!is.null(part2)){
   stopifnot(length(part1) == length(part2))
   part2 = as.factor(part2)
   }

  #If two partition vectors specified, run through data
  # and list all combinations of levels (e.g. inst-subst)
  if (is.null(part2)){
    part_mat = data.frame(levels(part1))
  } else{
    part_mat = data.frame(part1 = NULL, part2 = NULL)
    for (p1 in levels(part1)){
      p2_vec = sort(unique(part2[part1==p1]))
      part_mat = rbind(part_mat,
                       cbind( as.character(p1), as.character(p2_vec)))
    }
    #names(part_mat) = c(names(part1), names(part2))
  }

  #vector partition levels of length q
  if (is.null(part2)){
    levels_out = levels(part1)
  } else{
    levels_out = apply(part_mat, 1, paste, collapse = '-')
  }

  #Vector partitions of length n
  if (is.null(part2)){
    part_vec = part1
  } else {
    part_vec = factor(apply(cbind(as.character(part1),as.character(part2)), 1, paste, collapse = '-'),
		levels = levels_out) #Need to manually set levels or the order changes
  }
  v_mat = cbind(as.character(part1),as.character(part2))

  #Extract variables
  q = length(levels_out)
  n = length(outcome)
  stopifnot( n == length(part_vec)) #Partion vector same length as outcome

  #Partition indicator matrix (n x q)
  #Useful for a lot of linear algebra shortcuts
  #ex: o_mean =  t(ind_mat) %*% ind_mat / n_vec
  ind_mat = Matrix::Matrix(0, nrow = n, ncol = q)

  ind_mat[cbind(1:n, as.numeric(part_vec))] = 1

  #Statistics for each partition
  # n_vec = sapply(levels_out, function(li) sum(part_vec == li))
  # o_mean = sapply(levels_out, function(li) mean(outcome[part_vec == li]))
  temp <- data.frame(table(part_vec))
      n_vec<-temp[,2]
      names(n_vec)<-temp[,1]

      temp2<-aggregate(outcome,by=list(part_vec),mean)
      o_mean<-temp2[,2]
      names(o_mean)<-temp2[,1]

  return(list(levels_out = levels_out,
              n_vec = c(n_vec),
              o_mean = c(o_mean),
              ind_mat = ind_mat,
              part_mat = part_mat
			  ))
}


library(ggplot2)
Cit.HepPh.Unique<-unique(Cit.HepPh)
cit.HepPh.dates.Unique<-unique(cit.HepPh.dates)

paperYear<-data.frame(year=1992:2002,paperCount=0)

for(year in 1992:2002){
  pattern <- paste(year,'-*-*', sep = "")
  group <- grep(pattern, cit.HepPh.dates.Unique[,2],
       ignore.case = FALSE, perl = FALSE, value = FALSE,
       fixed = FALSE, useBytes = FALSE, invert = FALSE)
  paperYear[paperYear$year==year,]$paperCount
                  = nrow(cit.HepPh.dates.Unique[group,])
}
myplot<-ggplot(paperYear,aes(x=as.character(year),y=paperCount,fill=year))
myplot+geom_bar(stat="identity")+geom_point()+
  geom_text(aes(label=paperCount),hjust=0.5, vjust=-0.5 )+
  labs(x='year', y='paperCount')


library(watershed)
library(raster)
library(sf)
library(ggplot2)
library(flume)

dem = raster("data/elevation/thur_dem_3035.tif")
thresh = 1e6
len = 5000
th = delineate(dem, threshold = thresh, reach_len=len, outlet = c(4260565, 2706691))
Tp = pixel_topology(th)

## for plotting
dem_cr = crop(dem, th)
dem_df = as.data.frame(rasterToPoints(dem_cr))
colnames(dem_df)[3] = "elev"
th_v = vectorise_stream(th[["stream"]], Tp=Tp)

discharge = read.csv("data/discharge.txt")
discharge = discharge[discharge$watershed == "Thur",]
discharge = st_as_sf(discharge, coords = c('x', 'y'), crs=3035)

discharge = st_snap(discharge, th_v, tolerance=100)
discharge$ca = catchment(th, type = "points", y = st_coordinates(discharge))
discharge = discharge[discharge$ca > thresh,]

ggplot() + geom_raster(data=dem_df, aes(x = x, y = y, fill = elev)) +
	geom_sf(data = th_v, aes(colour=reach_id)) + scico::scale_fill_scico(palette = "turku") +
	geom_sf(data = discharge, colour='red', size = 0.75)

th_v$catchment = catchment(th, type = 'reach', Tp = Tp)
th_v = cbind(th_v, hydraulic_geometry(discharge$ca, discharge$discharge, th_v$catchment))
Tp_r = reach_topology(th, Tp)
layout = st_coordinates(lwgeom::st_startpoint(th_v))
th_v$len = st_length(th_v)
st_write(th_v, "res/thur.gpkg", append = FALSE)

# combine reaches
simplify_reach = function(tp, i) {
	hw = i[watershed:::.headwater(tp[i,i])]
	if(length(hw) > 1)
		hw = hw[which.max(hw)]
	out = i[watershed:::.outlet(tp[i,i])]
	conn = watershed:::.upstream(tp, hw)

	# find branches
	all_upstream = function(tp, j) {
		val = unlist(sapply(j, function(k) unname(watershed:::.upstream(tp, k))))
		if(length(val) == 0) {
			return(val)
		} else {
			return(c(val, all_upstream(tp, val)))
		}
	}
	br = unname(unlist(sapply(i, function(j) watershed:::.upstream(tp, j))))
	br = br[which(!br %in% c(i, conn))]
	if(length(br) > 0) {
		br = c(br, all_upstream(tp, br))
		tp[br,] = 0
		tp[,br] = 0
	}

	lens = sapply(conn, function(j) {
		k = watershed:::.downstream(tp, j)
		l = tp[j, k]
		while(k != out) {
			ko = k
			k = watershed:::.downstream(tp, ko)
			l = l + tp[ko, k]
		}
		l
	})

	del = c(i[i != out], br)
	if(length(conn) == 0) {
		connect = data.frame()
	} else {
		connect = data.frame(ds = out, us = conn, length = lens)
	}

	list(connect = connect, delete = del)
}

simplify_reaches = function(tp, rs) {
	form = lapply(rs, function(r) simplify_reach(tp, r))
	for(ff in form) {
		if(nrow(ff$connect) > 0) {
			for(i in 1:nrow(ff$connect))
				tp[ff$connect$us[i], ff$connect$ds[i]] = ff$connect$length[i]
		}
	}
	del = unlist(sapply(form, function(ff) ff$delete))
	if(length(del) > 0) {
		tp = tp[-del,]
		tp = tp[,-del]
	}
	list(topology = tp, delete = del)
}

rcomb = list(2:4, 216:217, 184:186, 214:215, 188:190, 191:195, 209:213, 203:205, 206:207,
	196:197, 200:201, 5:8, 178:180, 9:17, 18:19, 20:22, 25:26, 27:30, 34:35, 147:149, 154:156,
	157:159, 160:162, 166:167, 168:170, 44:45, 145:146, 48:49, 50:53, 55:56, 57:58, 60:61, 63:66,
	68:69, 141:143, 70:71, 73:76, 78:79, 80:81, 82:83, 84:86, 87:89, 95:98, 134:135, 104:105,
	131:132, 106:111, 114:115, 119:120, 126:127, 122:124, 117:118)

res = simplify_reaches(Tp_r, rcomb)

th_v$Q = units::drop_units(th_v$Q)
th_v$z = units::drop_units(th_v$z)
th_v$w = units::drop_units(th_v$w)

thur = river_network(res$topology, discharge = th_v$Q[-res$delete],
	area = (th_v$z*th_v$w)[-res$delete], length = len,
	layout = layout[-res$delete,])
thur_old = river_network(Tp_r, discharge = th_v$Q,
	area = (th_v$z*th_v$w), length = len,
	layout = layout)

par(mfrow=c(1,2))
	plot(thur, edge.arrow.size=0, vertex.size=2, vertex.label=NA)
	plot(thur_old, edge.arrow.size=0, vertex.size=2, vertex.label=NA)

saveRDS(thur, "res/thur_network.rds")


 DGECON Example Program Results

 Estimate of condition number =  1.52E+02


#' Perform a HG test for all sigs vs all lists
#'
#' @param background  A character vector of the ground truth
#' @param lists       A list of gene sets
#' @param samples     A vector of my observation or list thereof
hypergeometric_test = function(background, lists, samples) {
    calc = function(back, li, sam) {
        q = sum(sam %in% li) # number of positive balls in the sample
        m = sum(li %in% back) # number of positive balls in the urn
        n = length(background) - m # number of negative balls in the urn
        k = length(sam) # number of balls in the sample
        1 - phyper(q-1, m, n, k) # p-value
    }

    if (!is.list(lists))
        lists = list(lists)
    if (!is.list(samples))
        samples = list(samples)

    A = matrix(NA, nrow=length(lists), ncol=length(samples),
               dimnames=list(names(lists), names(samples)))

    for (li in seq_along(lists))
        for (si in seq_along(samples))
            A[li,si] = calc(background, lists[[li]], samples[[si]])

    drop(A)
}


pdf_file<-"pdf/scatterplots_outliers.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11.69,height=9)

par(mar=c(4,4,0.5,2),omi=c(0.5,0.5,1,0),family="Lato Light",las=1)

# Import data and prepare chart

library(gdata)
myStructuralData<-read.csv(file="myData/struktbtwkr2005.csv",head=F,sep=";",dec=".")
myData<-subset(myStructuralData,V2 > 0 & V34 > 10)
attach(myData)

myXDes<-"Unemployed population(%)"
myYDes<-"Net migration (per 1,000 Inhabitants)"

# Define chart and other elements

plot(type="n",xlab=myXDes,ylab=myYDes,V34,V21,xlim=c(10,26),ylim=c(-20,35),axes=F,cex.lab=1.2)
axis(1,lwd.ticks=0.5,cex.axis=1.15,tck=-0.015)
axis(2,lwd.ticks=0.5,cex.axis=1.15,tck=-0.015)

myC1<-rgb(0,208,226,200,maxColorValue=255)
myC2<-rgb(255,0,210,150,maxColorValue=255)

fit<-lm(V21 ~ V34)
myData$fit<-fitted(fit)
points(V34,myData$fit,col=myC2,type="l",lwd=8)

myData$resid<-residuals(fit)
myData.sort<-myData[order(-abs(myData$resid)) ,]
myData.sort_begin<-myData.sort[1:5,]

myP1<-myData.sort[5+1:length(myData$fit),c("V34","V21")]
myP2<-myData.sort_begin[c("V34","V21")]

myR1<-sqrt(myData.sort$V6)/10
myR2<-sqrt(myData.sort_begin$V6)/10

symbols(myP1,circles=myR1,inches=0.3,bg=myC1,fg="white",add=T)
symbols(myP2,circles=myR2,inches=0.3,bg=myC2,fg="white",add=T)

text(myP2,iconv(as.matrix(myData.sort_begin["V3"]),"LATIN1","UTF-8"),cex=0.65,pos=3,offset=1.1)

abline(v=mean(V34,na.rm=T),col="black",lty=3)
abline(h=mean(V21,na.rm=T),col="black",lty=3)

text(20,20, "The five largest deviations are highlighted. \n\npoint size: constituency area", adj=0)
# Titling
mtext("Unemployed population, migration in Germany 2005",3,adj=0,line=2,cex=2.5,outer=T,family="Lato Black")
mtext("County level, unemployment rate above 10 percent",3,adj=0,line=0,cex=1.5,outer=T,font=3)
mtext("Source: www.bundeswahlleiter.de",1,line=4,adj=1,cex=1.15,font=3)
dev.off()


source("data_cure_rate_real.r")

library(npowerPrioR)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = 4)

#### Sampling from the "prior"
prior <- stan_model("stan/cure_rate_prior.stan")

cr.data <- list(
  n = N_0,
  p = ncol(X_0),
  y = Y_0_cens,
  X = X_0,
  delta = Delta_0,
  mu_0 = mu0,
  sigma_0 = s0,
  delta_0 = d0,
  tau_0 = tau0,
  sigma_beta = 10,
  a_0 = 0.05
)
####################
J <- 20
maxA <- 1
epsilon <- 0.05
#
adaptive.time <- system.time(
  adaptive.ca0.estimates <- build_grid(compiled.model.prior = prior, eps = epsilon,
                                       M = maxA, J = J, v1 = 10, v2 = 10, stan.list = cr.data,
                                       pars = c("alpha", "lambda", "beta"), strict = FALSE)
)
write.csv(adaptive.ca0.estimates$result, row.names = FALSE,
          file = paste0("../../data/constant_data/CureRateRealData_logCA0_adaptive_J=", J, ".csv"))
save(adaptive.ca0.estimates, file = "../../data/sensitivity_data/cure_rate_real.RData")


# 1. Install required packages

#install.packages("mlr")
#install.packages("e1071")
#install.packages("randomForest")
#install.packages("corrplot")
library(mlr)
library(corrplot)

# 2. Make sure you set the right path to the data csv file
path<-"<YOUR PATH>/model_data_no_labels.csv"

# 3. Importing data from csv.file
model_data <- read.csv(path,encoding="UTF-8")
model_data$X=NULL

# 4. Displaying matrix of correlations
arrayOfCorrelations <- cor(model_data)
corrplot(arrayOfCorrelations, order = "hclust")

# 5. Adding target columnt to dataset (You can label the data by yourself)
isOk <- c("OK", "OK", "NOTOK", "OK", "NOTOK", "OK", "OK", "OK", "NOTOK", "OK",
          "OK", "OK", "NOTOK", "NOTOK", "NOTOK", "OK", "NOTOK", "OK", "OK", "OK",
          "OK", "NOTOK","OK", "NOTOK", "NOTOK", "OK")
model_data['isOk'] = isOk

# 6. Defining task
classif_task = makeClassifTask(id = "testowy", data = model_data, target = "isOk")

# 7. Defining repetitive cross validation
rdesc = makeResampleDesc("RepCV", folds=4, reps = 10)

# 8. Learinig and validating model
rf = resample("classif.randomForest", classif_task, rdesc, measures = list(mmce,mcc,f1,acc,kappa))
svm = resample("classif.svm", classif_task, rdesc, measures = list(mmce,mcc,f1,acc,kappa))
knn = resample("classif.knn", classif_task, rdesc, measures = list(mmce,mcc,f1,acc,kappa))

# 9. Displaying results
rf
svm
knn


##################################################################################################################
####  Purpose: Final Project - Classification - RandomForest
####  Group: Ravi P., Derek P., Aneesh K., Ninad K.
####  Date: 11/28/2018
####  Comment:
####    setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")
####
##################################################################################################################
setwd("~/Stevens/Fall2018/CS513_Knowledge_Discovery/Final Project/Classification")
rm(list = ls())

df_train <- read.csv("./data/train_new.csv")
df_test <- read.csv("./data/test_new.csv")

df_train <- df_train[,2:10]
df_test <- df_test[,2:10]

levels(df_test$SimpleColor) <- levels(df_train$SimpleColor)

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

fit <- randomForest( OutcomeType~., data=df_train[,-1], importance=TRUE, ntree=1200)
importance(fit)
varImpPlot(fit)
Prediction <- predict(fit, df_test[,-1])

table(actual=df_test$OutcomeType ,Prediction)
plot(fit, ylim=c(0,1))
legend('topright', colnames(fit$err.rate), col=1:6, fill=1:6)

wrong<- (df_test$OutcomeType!=Prediction )
error_rate<-sum(wrong)/length(wrong)
error_rate


#!/usr/bin/env Rscript

cat("Making plots...\n")

tring <- read.table("trcurve.txt", head=TRUE)
gmoverr <- read.table("gmoverr.txt", head=TRUE)

data <- read.table("maxv.txt",head=FALSE)
vrange <- data[1,1]
dv <- 4
data <- read.table("rsize.txt", head=FALSE)
rsize <- data[1,1]

data <- as.matrix(read.table("observation.txt", head=FALSE))
pdf("pvplot.pdf")
image(log10(data), axes=0, xaxs="i", yaxs="i")
axis(1, at=seq(0,1,length.out=9),labels=1e3*c(seq(-rsize, 0, length.out=5),seq(rsize/4, rsize,length.out=4)))
axis(2, at=seq(0,1,length.out=9),labels=c(seq(-vrange,0,length.out=5),seq(vrange/4,vrange,length.out=4)))
segments(-1,0.5,2,0.5,lty=2)
segments(0.5,-1,0.5,2,lty=2)
dev.off() -> dumpvar

distmedian <- function(vels, distribution) {
	for (i in seq(2,length(distribution))) {
		distribution[i] <- distribution[i] + distribution[i-1]
	}
	midpoint <- distribution[length(distribution)]*0.5
	medpoint <- 0
	for (i in seq(1,length(distribution))) {
		if (distribution[i]<midpoint) {
			medpoint <- i
		}
	}
	return (vels[medpoint])
}

weightedmean <- function(vels, distribution) {
	v <-  sum(vels*distribution)/sum(distribution)
	return(v)
}

velseq <- seq((dv/2)-vrange,vrange-(dv/2),by=dv)
radius <- gmoverr$r[seq(2,1+(length(data[,1])-1)/2)]*1e3
leftcurve <- numeric(0)
rightcurve <- numeric(0)
for (i in seq(1,(length(data[,1])-1)/2 ) ) {
	leftdist <- as.numeric(data[(length(data[,1])+1)/2-i,])
	rightdist <- as.numeric(data[(length(data[,1]+1))/2+i,])
	#leftcurve <- c(leftcurve, distmedian(velseq,leftdist))
	#rightcurve <- c(rightcurve, distmedian(velseq,rightdist))
	leftcurve <- c(leftcurve, weightedmean(velseq,leftdist))
	rightcurve <- c(rightcurve, weightedmean(velseq,rightdist))
}

data <- read.table("finalcurve.txt", head=TRUE)
radius <- data$radius
rightcurve <- data$low
leftcurve <- -data$high

rc <- data.frame(r=radius, vr=rightcurve, vl=leftcurve)

pts <- (rightcurve-leftcurve)/2

pdf("tiltedringcurve.pdf")
plot(rc$r, pts, ylim=c(0,max(tring$v)*1.5), xlim=c(0,max(rc$r)), xlab="R[kpc]", ylab=expression(v[c]~"[kpc]"))
segments(rc$r, rc$vr, rc$r, -rc$vl)
lines(tring$r*1e3, tring$v,lty=2, col="green", lwd=2)
lines(gmoverr$r*1e3, gmoverr$v, lty=2, col="red", lwd=2)
#lines(tring$r*1e3, tring$gas,col="blue",lwd=2)
lines(tring$r*1e3, tring$stars,col="purple",lwd=2)
dev.off() -> dumpvar

errs <- numeric(0)
for (i in seq(1,length(rc$r))) {
	errs[i] = abs((rightcurve[i]+leftcurve[i])/2)
	if (is.nan(errs[i])) {
		errs[i] = 4
	} else {
		if (errs[i] == 0) { errs[i]=4 }
	}
}

sink("curvedata.txt")
cat("# Radius  v_obs  err  v_gas  v_disk  v_bulge\n")
cat("#  kpc    km/s   km/s km/s   km/s    km/s\n")
for (i in seq(1,length(rc$r))) {
	cat(rc$r[i])
	cat("  ")
	cat(pts[i])
	cat("  ")
	cat(errs[i])
	cat("  ")
  cat(tring$gas[i])
	cat("  ")
  cat(tring$stars[i])
	cat("  ")
	cat("0\n")
}
sink()

sink("realcurvedata.txt")
cat("# Radius  v_obs  err  v_gas  v_disk  v_bulge\n")
cat("#  kpc    km/s   km/s km/s   km/s    km/s\n")
for (i in seq(1,length(rc$r))) {
	cat(rc$r[i])
	cat("  ")
	cat(tring$v[i])
	cat("  ")
	cat(errs[i])
	cat("  ")
  cat(tring$gas[i])
	cat("  ")
  cat(tring$stars[i])
	cat("  ")
	cat("0\n")
}
sink()


f_table2= subset(f_table,f_table$distance_traveled_mm_p_min>50 )

PCA_res$other=f_table2$ZD_other
xxx= aov(PCA_res$PC1~PCA_res$group+PCA_res$other)
summary(xxx)
TukeyHSD(xxx)

xxx= aov(PCA_res$PC2~PCA_res$group*PCA_res$other)
summary(xxx)
TukeyHSD(xxx)

fm= lm(PCA_res$PC2~PCA_res$group, data=PCA_res)
shapiro.test(residuals(fm))

 pairwise.wilcox.test(PCA_res$PC1, PCA_res$group, p.adjust.method = "bonf")
 pairwise.wilcox.test(PCA_res$PC3, PCA_res$group, p.adjust.method = "bonf")

xxx= shapiro.test(PCA_res$PC1~PCA_res$group)#*PCA_res$other)
summary(xxx)

Mean_PCA_3d = create.mean.table(PCA1to3,levels(PCA1to3$PCA_res.group),1:3)

pdf("pcaresults.pdf")
layout(matrix(c(1,3,2,4), 2, 2, byrow = TRUE))
#layout.show(4)
dleg=15

M=max(Mean_PCA_3d$means)+max(Mean_PCA_3d$ses)*1.05
ii=1
jj=2
plot(scores[,ii], scores[,jj], xlab=paste("PCA ",ii), ylab=paste("PCA ",jj),
   type="n", main="distance biplot",xlim=c(-M, M),
   ylim=c(-M, M))
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	#points(X$PC3~ X$PC1, col=i)
	#legend(list(x=-6,y=-i/2+5), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,  cex=0.7)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= abc[i], bty="n", inset = c(0,i/dleg))

   x=Mean_PCA_3d$means[i,ii]
y=Mean_PCA_3d$means[i,jj]
x2=Mean_PCA_3d$ses[i,ii]
y2=Mean_PCA_3d$ses[i,jj]
segments (x-x2,y,x+x2,y, col=abc[i])
segments (x,y-y2,x,y+y2, col=abc[i])
	}
	abline (v=0, h=0)

ii=1
jj=3
plot(scores[,ii], scores[,jj], xlab=paste("PCA ",ii), ylab=paste("PCA ",jj),
   type="n", main="distance biplot",xlim=c(-M, M),
   ylim=c(-M, M))
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	#points(X$PC3~ X$PC1, col=i)
	#legend(list(x=-6,y=-i/2+5), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,  cex=0.7)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= abc[i], bty="n", inset = c(0,i/dleg))

   x=Mean_PCA_3d$means[i,ii]
y=Mean_PCA_3d$means[i,jj]
x2=Mean_PCA_3d$ses[i,ii]
y2=Mean_PCA_3d$ses[i,jj]
segments (x-x2,y,x+x2,y, col=abc[i])
segments (x,y-y2,x,y+y2, col=abc[i])
	}
	abline (v=0, h=0)

ii=3
jj=2
plot(scores[,ii], scores[,jj], xlab=paste("PCA ",ii), ylab=paste("PCA ",jj),
   type="n", main="distance biplot",xlim=c(-M, M),
   ylim=c(-M, M))
for (i in 1:length(levels(PCA_res$group))){
	X = subset(PCA_res,PCA_res$group == levels(PCA_res$group)[i])
	#points(X$PC3~ X$PC1, col=i)
	#legend(list(x=-6,y=-i/2+5), legend=(levels(PCA_res$group)[i]), fill= i, bty="n")
	 #text(x+1,y-0.1, levels(PCA_res$group)[i], col=i,  cex=0.7)
legend("topleft", legend=(levels(PCA_res$group)[i]), fill= abc[i], bty="n", inset = c(0,i/dleg))

   x=Mean_PCA_3d$means[i,ii]
y=Mean_PCA_3d$means[i,jj]
x2=Mean_PCA_3d$ses[i,ii]
y2=Mean_PCA_3d$ses[i,jj]
segments (x-x2,y,x+x2,y, col=abc[i])
segments (x,y-y2,x,y+y2, col=abc[i])
	}
	abline (v=0, h=0)
dev.off()

###make stripe dev plot
pdf("stripedev.pdf")
plot= ggplot(f_table2, aes(x=f_table2$ZA_genotype, y=f_table2$AC_stripe_deviation , fill=f_table2$ZD_other))

plot+ geom_boxplot()+
ylab("stripe deviation [°]")+
xlab("genotype")+
scale_fill_manual(values=c("white", "grey"),name="session") +
theme_bw()+
geom_hline(yintercept=44, colour="red")
dev.off()

plot= ggplot(f_table2, aes(x=f_table2$ZA_genotype, y=f_table2$H_speeds , fill=f_table2$ZD_other))

plot=ggplot(cdata, aes(x=xvalue, y=mean, fill=legendvalue)) +
    geom_bar(position=position_dodge(),col="black", stat="identity") +
    geom_errorbar(aes(ymin=mean-se, ymax=mean+se),
                  width=.2,                    # Width of the error bars
                  position=position_dodge(.9)) +
    ylab(title) +
    xlab(xname) +
    scale_fill_manual(values=c("white", "grey"),name=legname) + # column fill and legend title/ -lables
    #scale_y_continuous(breaks=0:16*4, limits = c(0,28)) +  # 4 sind die Schritte auf der y-Achse,
    # limits ist range der y-Achse
    theme_bw()


library(BiocParallel)
library(tradeSeq)
library(mgcv)
library(clusterExperiment)
library(slingshot)

exprs = read.csv('./data/mic_gene_expression_raw.csv', row.names = 1)
counts = as.matrix(exprs)
meta = read.csv('./data/mic_diff_meta.csv')
rd = read.csv('./mic_diff_pca.csv')

ind_gene = colSums(counts) > (0.5 * nrow(counts) )
counts = counts[,ind_gene]

sds <- slingshot(rd[,1:2], meta$leiden)
pseudotime = slingPseudotime(sds)[,1]

#aicK = evaluateK(t(counts), sds = sds, BPPARAM = BiocParallel::bpparam())

sce <- fitGAM(counts = t(counts), pseudotime = pseudotime,
              cellWeights = rep(1, nrow(counts)), verbose = TRUE,
              parallel=TRUE, BPPARAM = BiocParallel::bpparam())

assoRes <- associationTest(sce)
assoRes$fdr = p.adjust(assoRes$pvalue, 'fdr')
head(assoRes)

saveRDS(assoRes, 'mic_sling_output/pseudotime_association.rds')

sigRes = assoRes[assoRes$fdr < 0.05,]
degs = rownames(sigRes[order(sigRes$pvalue),])
nPointsClus = 20
clusPat = clusterExpressionPatterns(sce, nPoints = nPointsClus,
                                    genes = degs, clusterFunction = "hierarchical01",
                                    ncores = 20,
                                    )

write.csv(clusPat$yhatScaled,'mic_sling_output/yhat_scaled.csv')

dn_curves = (which(colSums(diff(t(clusPat$yhatScaled), ) <= 0, ) == (nPointsClus - 1) ))
up_curves = (which(colSums(diff(t(clusPat$yhatScaled), ) >= 0, ) == (nPointsClus - 1) ))

not_monotone = setdiff(1:length(degs), dn_curves)
not_monotone = setdiff(not_monotone, up_curves)

not_monotone_genes = rownames(clusPat$yhatScaled)[not_monotone]
clusPat_nm = clusterExpressionPatterns(sce, nPoints = nPointsClus,
                                    genes = not_monotone_genes,
                                    clusterFunction = "hierarchical01",
                                    ncores = 20,
                                    )

clusterLabels_nm <- primaryCluster(clusPat_nm$rsec)
clusterLabels_nm = clusterLabels_nm

out = data.frame(cluster = clusterLabels_nm - 1 )
rownames(out) = rownames(clusPat_nm$yhatScaled)
write.csv(out, './mic_sling_output/clusterLabel_nm.csv')
write.csv(clusPat_nm$yhatScaled, './mic_sling_output/yhat_scaled_nm.csv')

#merged_label = seq(length(degs))
merged_label = rep(-1, length(degs))
merged_label[not_monotone] = clusterLabels_nm - 1
merged_label[dn_curves] = max(clusterLabels_nm)
merged_label[up_curves] = max(clusterLabels_nm) + 1

out = data.frame(cluster = merged_label )
rownames(out) = rownames(clusPat$yhatScaled)
write.csv(out, './mic_sling_output/clusterLabel.csv')
write.csv(clusPat$yhatScaled, './mic_sling_output/yhat_scaled.csv')

pdf('fig/decreasing_genes_smooth_traj.pdf')

genes = c('MT.CO1', 'MT.ND4', 'CSMD1')
for (g in genes){
#print(plotSmoothers(sce, t(counts), gene = g))
 print(plotSmoothers(sce, t(counts), gene = g))
}
dev.off()


context("lagr")

test_that("str_length is number of characters", {
    data(poverty)
    df = poverty[poverty$year=="1970",]

    #Define which variables we'll use as predictors of poverty:
    f = logitindpov ~ pag + pex + pman + pserve + pfire + potprof
    fl = rbind(c(-89.4437, 38.8863), c(-89.5350, 41.4068))
    colnames(fl) = c('x', 'y')

    #LAGR model
    tune = lagr.tune(formula=f, data=df, coords=c(x,y), longlat=TRUE, varselect.method='AIC', kernel=epanechnikov, tol.bw=0.01, bw.type='knn', bwselect.method='AIC', verbose=TRUE)
    model = lagr(formula=f, data=df, coords=c('x','y'), fit.loc=fl, longlat=TRUE, varselect.method='AIC', bw=0.2, kernel=epanechnikov, bw.type='knn', verbose=TRUE)

    y2 = ifelse(df$logitindpov > mean(df$logitindpov), 1, 0)
    df2 = df
    df2$logitindpov = y2
    model = lagr(formula=f, data=df2, family=binomial(), coords=c('x','y'), fit.loc=fl, longlat=TRUE, varselect.method='AIC', bw=0.5, kernel=epanechnikov, bw.type='knn', verbose=TRUE)
    model = lagr(formula=f, data=df2, family=gaussian, coords=c('x','y'), fit.loc=fl, longlat=TRUE, varselect.method='AIC', bw=0.5, kernel=epanechnikov, bw.type='knn', verbose=TRUE)

    sglm = SGL(list(x=as.matrix(df2[,c(3:7,15)]), y=df2$logitindpov), type='logit', alpha=0, index=1:6)
})


# bin data
# figure out logical breaks
ra <- range(strat$m_age)
timerange <- abs(diff(ra))
#timerange <- abs(diff(ord))
rr <- timerange / constant
brks1 <- seq(from = hirnantian, to = ra[2] + 1, by = rr) #
brks2 <- seq(from = hirnantian, to = ra[1] - 1, by = -rr) #
brks <- c(rev(brks2[-1]), brks1)
brks <- cbind(brks[-1], brks[-length(brks)])
brks <- brks[rev(seq(nrow(brks))), ]
write_rds(brks, path = '../data/breaks.rds')

# one pesky observation that doesn't play nice with bins
strat <- strat[strat$m_age > min(brks), ]

# get the count information from the data
out <- purrr::map(shelly, ~ get_values(taxon, strat, .x))
names(out) <- shelly

# make a mollusc category after the fact
tt <- full_join(out$Bivalvia, out$Gastropoda)
tt <- tt %>%
  group_by(unit_id, bin) %>%
  dplyr::mutate(diversity = sum(diversity),
                collections = sum(collections)) %>%
  ungroup() %>%
  distinct(unit_id, .keep_all = TRUE)
out$Mollusca <- tt
shelly <- names(out)

out <- purrr::map(out, function(x) {
                    m <- x$unit_id != 19112
                    x <- x[m, ]
                    x})

# do all the exporting
# partials make this easier, imo
esd <- partial(export_standata, type = 'diversity')
purrr::walk2(out, shelly, esd)
eso <- partial(export_standata, type = 'occurrence')
purrr::walk2(out, shelly, eso)


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

df <- read.table("../data/workshops.csv", h = T, sep = ";")

#### t-test and CI -------------------------------------------------------------
x  <- table(df$ID) # participants per workshop
t.test(x, mu = 12)


 ZGESVX Example Program Results

 Solution(s)
                    1                 2
 1  ( 1.0000, 1.0000) (-1.0000,-2.0000)
 2  ( 2.0000,-3.0000) ( 5.0000, 1.0000)
 3  (-4.0000,-5.0000) (-3.0000, 4.0000)
 4  ( 0.0000, 6.0000) ( 2.0000,-3.0000)

 Backward errors (machine-dependent)
       5.3E-17    8.4E-17

 Estimated forward error bounds (machine-dependent)
       5.7E-14    7.7E-14

 A has been row scaled as diag(R)*A

 Reciprocal condition number estimate of scaled matrix
       1.0E-02

 Estimate of reciprocal pivot growth factor
       8.3E-01


# Team Rython, Dainius Masiliunas and Tim Weerman
# Date: 11 January, 2016
# Apache License 2.0

library(rgeos) # g functions

# Plots the towns in a given distance from a given railway type
PlotTownsNextToRailways = function(RailwayLines, TownPoints, RailwayType, Distance = 1000)
{
    # Select requested railways
    OurRails = subset(RailwayLines, type == RailwayType)

    # Buffer of a kilometre
    RailSurroundings = gBuffer(OurRails, byid = TRUE, width = Distance)

    # Find intersecting places
    RailNeighbours = gIntersection(RailSurroundings, TownPoints, byid = TRUE)

    # Plot
    plot(RailSurroundings, axes=TRUE)
    plot(OurRails, add=TRUE, col="red")
    # In case there are none, do not plot
    if (class(RailNeighbours) == "NULL")
    {
        warning("No cities are in buffer range, consider increasing the distance!")
        return()
    }
    else
        plot(RailNeighbours, add=TRUE, pch=15)

    # A tricky way to extract and match IDs of the points we just intersected
    CityIDs = as.numeric(unlist(strsplit(dimnames(RailNeighbours@coords)[[1]], " "))[c(FALSE,TRUE)])

    # Extract population and name from our IDs
    CityInfo = TownPoints@data[CityIDs,]

    # Add the city names onto the plot
    text(RailNeighbours$x, RailNeighbours$y, labels = CityInfo[[2]])

    # Prints the city ID, city name, and population
    print(CityInfo[c("name", "population")])
}


pdf("slike/Auditrgianaliza.pdf")

pripraviVrstico <- function(podatki) {
  vrstica <- as.numeric(as.vector(podatki))
  vrstica[is.na(vrstica)] = 0
  vrstica <- vrstica / 1000
  return(vrstica)
}

pripraviTabelo <- function(podatki, izbrani) {
  m <- rbind(pripraviVrstico(podatki[izbrani[1],]))
  for (k in 2:length(izbrani) ) {
    i <- izbrani[k]
    m <- rbind(m, pripraviVrstico(podatki[i,]))
  }
  return(m)
}

izracunajRange <- function(tabela, barve) {
  g_range <- range(0)
  for (i in 1:nrow(tabela) ) {
    g_range <- range(g_range, tabela[i, ])
  }
  return(g_range)
}

imenaStolpcev <- function(podatki) {
  imena <- names(podatki)
  for (i in 1:length(imena) ) {
    imena[i] <- substr(imena[i], 2, 5)
  }
  return(imena)
}

narisiGraf <- function(tabela, barve, naslov, tekst_x, text_y, col_names, row_names) {
  stLetNapovedi <- 5

  xdata <- as.numeric(col_names)
  first_x <- xdata[1]
  last_x <- tail(xdata, n=1)
  # izracunaj zalogo vrednosti
  g_range <- izracunajRange(tabela)
  g_range[2] <- g_range[2] * 1.5
  # ustvari graf in narisi prvo krivuljo
  x_lim = c(first_x, last_x + stLetNapovedi)
  plot(xdata, tabela[1, ], type="o",
       xlab=tekst_x, ylab=text_y, col=barve[1], ylim=g_range,
       axes=TRUE, xlim=x_lim)
  # narisi se ostale krivulje
  for (i in 2:nrow(tabela) ) {
    lines(xdata, tabela[i, ], type="o", col=barve[i])
  }
  # napovedne krivulje
  for (i in 1:nrow(tabela) ) {
    ydata <- tabela[i, ]
    fit <- lm(ydata ~ xdata + I(xdata^2))
    new_xdata <- seq(first_x, last_x + stLetNapovedi, 1)
    coef <- as.numeric(unlist(fit["coefficients"]))
    new_ydata <- coef[1] + new_xdata*coef[2] + new_xdata^2*coef[3]
    lines(new_xdata,new_ydata, pch=22, lty=2,col=barve[i])

    inx <- length(xdata) + 3
    coef<-round(coef, 2)
    text_fun = paste0("x^2*(",toString(coef[3]),") + x*(", toString(coef[2]),") + (" ,toString(coef[1]), ")")
    text_y <- new_ydata[inx] + g_range[2]*0.04
    if (text_y < 0){
      text_y <- 0
    }
    text(new_xdata[inx], y = text_y, labels = text_fun,
         cex = 0.5, col=barve[i], lty=1:1)
  }
  # napisi naslov
  title(main=naslov, col.main="black", font.main=4)
  # legenda
  legend(first_x, g_range[2], row_names, cex=0.8, col=barve, lty=1:1);
}

####################### PRODAJA
izbrani <- c(1, 4, 5, 6, 12, 13)
# barve <- c("blue", "red", "pink", "green", "brown", "black")
barve <- rainbow(length(izbrani))
barve[2] <- "orange"
tabela_prodaja <- pripraviTabelo(AudiByMarkets, izbrani)

narisiGraf(tabela_prodaja,
           barve,
           "Prodaja avtomobilov",
           "Leta",
           "Stevilo prodanih Audijev v tisocih",
           imenaStolpcev(AudiByMarkets),
           row.names(AudiByMarkets)[izbrani])

####################### PROIZVODNJA
izbrani <- c(4, 11, 18, 22, 25, 31)
# barve <- c("blue", "red", 116, "brown", "black", "purple")
barve <- rainbow(length(izbrani))
barve[2] <- "orange"
tabela_proizvodnja <- pripraviTabelo(AudiProduction, izbrani)

narisiGraf(tabela_proizvodnja,
           barve,
           "Audi po modelih",
           "Leta",
           "Stevilo proizvedenih avtomobilov v tisocih",
           imenaStolpcev(AudiProduction),
           row.names(AudiProduction)[izbrani])

dev.off()


# -*- coding: utf-8 -*-
# @author:    mahnooshsadeghi
# github:     https://github.com/mahnooshs
# This code imputes missing heart rate data with Kalman Filtering method

library(data.table)
library(imputeTS)

###Due to some reasons it cannot impute around 10 files. Those files are implemented separately
i<- 1
p<- list.files("<path/to/file>", pattern="*.csv", full.names=TRUE)

setwd("<path/to/wd>")
for (i in 1:98) {
  #reading in data
  df<- fread(filename <- p[[i]])
  df$hr[df$hr==0]<-NA
  df$hr=na_kalman(df$hr, model = "StructTS", smooth = TRUE, nit = -1, maxgap = 5)
  N=sprintf('Participant.%d.csv', i)
  write.csv(df, file=N)
}


#################################################################
#################################################################
#################################################################
#' @title Make Trinary maps from previous workflow runs
#'
#' @description Read in workflow info, make trinary maps and plot vs thresholds
#'
#' @details
#' See Examples.
#'
# #' @param mod.out
# #' @param stats
# #' @param proj.env
# #' @param name
# @keywords
#'
# @examples
#'
#'
#' @return a data.frame
#' @author Cory Merow <cory.merow@@gmail.com>
# @note
# @seealso
# @references
# @aliases - a list of additional topic names that will be mapped to
# this documentation when the user looks them up from the command
# line.
# @family - a family name. All functions that have the same family tag will be linked in the documentation.

#' @export
logmod=function(x){sign(x)*log(abs(x))}

# @export
# .curv1=function(y.,y..,y...){
# 	abs(y.*y..)/abs(y...)
# }

#' @export
.curv2=function(y.,y..){
	abs(y..)/( (1+(y.^2))^1.5 )
}

#' @export
.deriv <- function(x, y) diff(y) / diff(x)
#' @export
.middle_pts <- function(x) x[-1] - diff(x) / 2


numf <- function(s) {
  strsplit(gsub("[^-. 0123456789]", "", s), " ")[[1]]
}
cat(sapply(lapply(readLines(tail(commandArgs(), n=1)), numf), function(s) {
  t <- as.double(s)
  t <- t[!is.na(t)]
  x <- t[4]-t[1]
  y <- t[5]-t[2]
  if (x*x + y*y <= t[3]*t[3]) {
    "true"
  } else {
    "false"
  }
}), sep="\n")


# Returns Lambda, or P(+|S=t)
EstLambda = function(S, X, t, idx, h = NULL){

  tryCatch({
    Sorder <- order(S, decreasing=TRUE)
    m <- length(S)
    idx.range <- c(max(1, idx - 1000), min(length(S), idx + 1000))

    S.ordered <- S[Sorder][idx.range[1]:idx.range[2]]
    X.ordered <- X[Sorder][idx.range[1]:idx.range[2]]

    ## --1 Kernsmooth bandwidth estimator
    ## more accurate, but prone to errors
    # if(is.null(h)) h <- KernSmooth::dpill(x = S.ordered, y = X.ordered, gridsize = 100)

    ## --2 Rule of thumb estimator
    ## Should not throw an error
    if(is.null(h)) h <- (m^{-1/5}) * sd(S)

    lp0 <- KernSmooth::locpoly(x = S.ordered, y = X.ordered, bandwidth = h, degree = 0,
                               range.x = range(S.ordered), gridsize = 1000)

    lp0.idx <- which.min(abs(lp0$x - t))
    lam <- lp0$y[lp0.idx]
  }, error = function(e) {
    stop("Lambda estimate failed.  Try setting h manually.")
  }
  )

  return(lam)
}

#' Perform a hypothesis test for the difference between two performance curves.
#'
#' \code{PerfCurveTest} takes score vectors for two scoring algorithms and an activity vector.
#' A performance curve is created for the two scoring algorithms and hypothesis tests are performed
#' at the selected testing fractions.
#'
#' @param S1 a vector of scores for scoring algorithm 1.
#' @param S2 a vector of scores for scoring algorithm 2.
#' @param X a vector of activities.
#' @param r a vector of testing fractions.
#' @param metric the performance curve to use. Options are recall ("rec") and precision ("prec").
#' @param method the method to use. Recall options are
#' c("EmProc", "binomial", "JZ ind", "mcnemar", "binomial ind"). Precision options are
#' c("EmProc", "binomial", "JZ ind", "stouffer", "binomial ind").
#' @param plus should plus correction be used or not?
#' @param pool use pooling for hypothesis tests or not? (only relevant to "EmProc")
#' @param alpha the significance level.
#'
#' @export
PerfCurveTest <- function(S1, S2, X, r, metric = "rec", method = "EmProc",
                          plus = T, pool = F, alpha = .05, h = NULL, seed = 111){

  # TODO need some more error checking here
  if(pool & method != "EmProc") warning("Pooling only relevant to EmProc and will not be applied")

  set.seed(seed)
  m <- length(S1) #total sample size
  r.all <- (1:m)/m
  idx <- which(r.all %in% r)

  # Z Quantile for CIs
  quant <- qnorm(1-alpha/2)

  # Convert fractions in r to thresholds, for both sets of scores
  # Also accumulate the number of actives, for each score and jointly
  F1cdf <- ecdf(S1); yyobs <- sort(unique(S1))
  F1inv <- stepfun(x = F1cdf(yyobs), y = c(yyobs, max(yyobs)), right=TRUE, f=1)
  F2cdf <- ecdf(S2); yyobs <- sort(unique(S2))
  F2inv <- stepfun(x = F2cdf(yyobs), y = c(yyobs, max(yyobs)), right=TRUE, f=1)
  hits1 <- hits2 <- hits12 <- ntest12 <- vector(length = length(r))
  for(i in 1:length(r)) {
    t1 <- F1inv(1-r[i])
    t2 <- F2inv(1-r[i])
    hits1[i] <- sum(X*(S1 > t1))
    hits2[i] <- sum(X*(S2 > t2))
    hits12[i] <- sum(X*(S1 > t1 & S2 > t2))
    ntest12[i] <- sum(S1 > t1 & S2 > t2)
  }
  nact <- sum(X) #total number of actives
  ntest <- (m*r) #number of compounds tested

  # Uncorrected parameters
  r <- ntest/m
  pi.0 <- nact/m
  k1 <- (hits1)/nact
  k2 <- (hits2)/nact
  k12 <- (hits12)/nact
  pi1 <- pi.0/r*k1
  pi2 <- pi.0/r*k2
  r12 <- ntest12/m
  pi12 <- hits12/ntest12
  pi12 <- ifelse(is.na(pi12), 0, pi12)
  # pooled estimates
  pi <- (pi1 + pi2)/2
  k <- (k1 + k2)/2

  if(plus) {
    hits1.c <- hits1 + 1
    hits2.c <- hits2 + 1
    nact.c <- nact + 2
    ntest.c <- ntest + 1
    m.c <- m + 2
  } else {
    hits1.c <- hits1
    hits2.c <- hits2
    nact.c <- nact
    ntest.c <- ntest
    m.c <- m
  }

  # Corrected parameters
  r.c <- ntest.c/m.c
  pi.0.c <- nact.c/m.c
  k1.c <- (hits1.c)/nact.c
  k2.c <- (hits2.c)/nact.c
  k12.c <- (hits12)/nact.c
  pi1.c <- (hits1.c)/(ntest.c)
  pi2.c <- (hits2.c)/(ntest.c)
  r12.c <- ntest12/m.c
  pi12.c <- hits12/ntest12
  pi12.c <- ifelse(is.na(pi12.c), 0, pi12.c)

  Lam1.vec <- vector(length = length(k1))
  Lam2.vec <- vector(length = length(k1))
  for(j in seq_along(k1)){
    Lam1.vec[j] <- EstLambda(S1, X, t = F1inv(1-r[j]), idx = idx[j], h)
    Lam2.vec[j] <- EstLambda(S2, X, t = F2inv(1-r[j]), idx = idx[j], h)
  }

  CI.int <- matrix(ncol = 2, nrow = length(k1))
  se.p <- se.np <- p.val <- vector(length = length(k1))
  if(metric == "rec") {
    if(method %in% c("JZ ind", "EmProc")){
      for(j in seq_along(k1)) {

        Lam1 <- Lam1.vec[j]
        Lam2 <- Lam2.vec[j]

        # unpooled variances
        var1.k.np <- ((k1.c[j]*(1-k1.c[j]))/(m.c*pi.0.c))*(1-2*Lam1) +
          (Lam1^2*(1-r.c[j])*r.c[j])/(m.c*pi.0.c^2)
        # Check to see if var.k.np is negative due to m.cachine precision problem.c
        var1.k.np <- ifelse(var1.k.np < 0, 0, var1.k.np)
        var2.k.np <- ((k2.c[j]*(1-k2.c[j]))/(m.c*pi.0.c))*(1-2*Lam2) +
          (Lam2^2*(1-r.c[j])*r.c[j])/(m.c*pi.0.c^2)
        var2.k.np <- ifelse(var2.k.np < 0, 0, var2.k.np)
        cov.k.np <- (m.c^-1*pi.0.c^-2)*(pi.0.c*(k12.c[j]-k1.c[j]*k2.c[j])*(1-Lam1-Lam2) +
                                          (r12.c[j]-r.c[j]^2)*Lam1*Lam2)

        # pooled variances
        var1.k.p <- ((k[j]*(1-k[j]))/(m*pi.0))*(1-2*Lam1) +
          (Lam1^2*(1-r[j])*r[j])/(m*pi.0^2)
        var1.k.p <- ifelse(var1.k.p < 0, 0, var1.k.p)
        var2.k.p <- ((k[j]*(1-k[j]))/(m*pi.0))*(1-2*Lam2) +
          (Lam2^2*(1-r[j])*r[j])/(m*pi.0^2)
        var2.k.p <- ifelse(var2.k.p < 0, 0, var2.k.p)
        cov.k.p <- (m^-1*pi.0^-2)*(pi.0*(k12[j]-k[j]*k[j])*(1-Lam1-Lam2) +
                                     (r12[j]-r[j]^2)*Lam1*Lam2)

        if(method == "JZ ind"){
          # assuming independence of k
          var.k.p <- var1.k.p + var2.k.p
          var.k.np <- var1.k.np + var2.k.np
        } else if(method == "EmProc") {
          var.k.p <- var1.k.p + var2.k.p - 2*cov.k.p
          var.k.np <- var1.k.np + var2.k.np - 2*cov.k.np
        }
        var.k.p <- ifelse(var.k.p < 0, 0, var.k.p)
        var.k.np <- ifelse(var.k.np < 0, 0, var.k.np)
        se.p[j] <- sqrt(var.k.p)
        se.np[j] <- sqrt(var.k.np)

        # Use pooled variance for tests, and unpooled for CIs
        CI.int[j, ] <- c( (k1[j]-k2[j]) - quant*se.np[j],
                          (k1[j]-k2[j]) + quant*se.np[j])
        zscore <- ( (k1[j]-k2[j]) )/ifelse(pool, se.p[j], se.np[j])
        p.val[j] <- 2*pnorm(-abs(zscore))
        p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
      }
    } else if(method %in% c("binomial ind", "binomial")) {
      for(j in seq_along(k1.c)) {

        # unpooled variances
        var1.k.np <- (m.c*pi.0.c)^-1*(k1.c[j])*(1-k1.c[j])
        var2.k.np <- (m.c*pi.0.c)^-1*(k2.c[j])*(1-k2.c[j])
        cov.k.np <- (m.c*pi.0.c)^-1*(k12.c[j] - k1.c[j]*k2.c[j])

        # pooled variances
        var1.k.p <- (m*pi.0)^-1*(k[j])*(1-k[j])
        var2.k.p <- (m*pi.0)^-1*(k[j])*(1-k[j])
        cov.k.p <- (m*pi.0)^-1*(k12[j] - k[j]*k[j])

        if(method == "binomial") {
          var.k.p <- var1.k.p + var2.k.p - 2*cov.k.p
          var.k.np <- var1.k.np + var2.k.np - 2*cov.k.np
        } else if(method == "binomial ind") {
          var.k.p <- var1.k.p + var2.k.p
          var.k.np <- var1.k.np + var2.k.np
        }
        var.k.p <- ifelse(var.k.p < 0, 0, var.k.p)
        var.k.np <- ifelse(var.k.np < 0, 0, var.k.np)
        se.p[j] <- sqrt(var.k.p)
        se.np[j] <- sqrt(var.k.np)
        CI.int[j, ] <- c( (k1[j]-k2[j]) - quant*se.np[j],
                          (k1[j]-k2[j]) + quant*se.np[j])

        # For CorrBinom, unpooled is always used
        zscore <- ( (k1[j]-k2[j]) )/se.np[j]
        p.val[j] <- 2*pnorm(-abs(zscore))
        p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
      }
    } else if(method == "mcnemar") {
      for(j in seq_along(k1.c)) {
        BminusC <- hits1[j] - hits2[j]
        BplusC <- hits1[j] + hits2[j] - 2*hits12[j]
        BminusC.c <- hits1.c[j] - hits2.c[j]
        BplusC.c <- hits1.c[j] + hits2.c[j] - 2*hits12[j]
        zscore <- ifelse(BplusC>0, BminusC/sqrt(BplusC), 0)
        p.val[j] <- 2*pnorm(-abs(zscore))
        se.np[j] <- sqrt(BplusC.c - BminusC.c^2/nact.c) / nact.c
        # Using corrected difference for center point since this is the true BP corrected McNemar
        CI.int[j,] <- c( BminusC.c/nact.c - quant*se.np[j], BminusC.c/nact.c + quant*se.np[j])
      }
    }
    # difference estimates
    est <- (k1 - k2)
  } else if(metric == "prec") {

    # TODO still need to implement pooled and unpooled variances here
    if(method %in% c("JZ ind", "EmProc")) {
      for(j in seq_along(pi1.c)) {
        Lam1 <- Lam1.vec[j]
        var1.pi <- (pi1.c[j]*(1-pi1.c[j]))/(m*r[j]) + (1-r[j])*(pi1.c[j]-Lam1)^2/(m*r[j])
        var1.pi <- ifelse(var1.pi < 0, 0, var1.pi)
        Lam2 <- Lam2.vec[j]
        var2.pi <- (pi2.c[j]*(1-pi2.c[j]))/(m*r[j]) + (1-r[j])*(pi2.c[j]-Lam2)^2/(m*r[j])
        var2.pi <- ifelse(var2.pi < 0, 0, var2.pi)
        cov.pi <- ((m^-1*r[j]^-2))*(r12[j]*pi12.c[j]*(1 - pi12.c[j]) +
                                      (pi12.c[j]-Lam1)*(pi12.c[j]-Lam2)*(r12[j] - r[j]^2))

        if(method == "JZ ind") {
          var.pi <- var1.pi + var2.pi
        } else if(method == "EmProc") {
          var.pi <- var1.pi + var2.pi - 2*cov.pi
        }

        # Check to see if var.k is negative due to machine precision problem
        var.pi <- ifelse(var.pi < 0, 0, var.pi)
        se <- sqrt(var.pi)
        CI.int[j, ] <- cbind((pi1[j] - pi2[j]) - quant*se, (pi1[j] - pi2[j]) + quant*se)
        zscore <- (pi1[j] - pi2[j])/se
        p.val[j] <- 2*pnorm(-abs(zscore))
        p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
      }
    } else if(method %in% c("binomial ind", "binomial")) {
      for(j in seq_along(k1.c)) {
        var1.pi <- (pi.c[j]*(1-pi.c[j]))/(m*r[j])
        var2.pi <- (pi.c[j]*(1-pi.c[j]))/(m*r[j])
        cov.pi <- (r12[j]/(m*r[j]^2))*(pi12.c[j]*(1 - pi12.c[j]))

        if(method == "binomial") {
          var.pi <- var1.pi + var1.pi - 2*cov.pi
        } else if(method == "binomial ind") {
          var.pi <- var1.pi + var1.pi
        }

        # Check to see if var.k is negative due to machine precision problem
        var.pi <- ifelse(var.pi < 0, 0, var.pi)
        se <- sqrt(var.pi)
        CI.int[j, ] <- cbind((pi1.c[j] - pi2.c[j]) - quant*se, (pi1.c[j] - pi2.c[j]) + quant*se)
        zscore <- (pi1.c[j] - pi2.c[j])/se
        p.val[j] <- 2*pnorm(-abs(zscore))
        p.val[j] <- ifelse(is.na(p.val[j]), 1, p.val[j])
      }
    } else if(method == "stouffer") {
      # TODO check that stouffer implemented correctly after changes
      for(j in seq_along(pi1.c)) {
        Sorder1 <-  order(S1,decreasing=TRUE)
        Sorder2 <-  order(S2,decreasing=TRUE)
        overlap.idx <- Sorder1[which(Sorder1[1:idx[j]] %in% Sorder2[1:idx[j]])]
        S1.unique.idx <- Sorder1[which(!Sorder1[1:idx[j]] %in% Sorder2[1:idx[j]])]
        S2.unique.idx <- Sorder2[which(!Sorder2[1:idx[j]] %in% Sorder1[1:idx[j]])]
        n12 <- length(overlap.idx)
        a <- sum(X[overlap.idx])
        d <- n12 - a
        n1 <- m*r[j] - n12
        e <- sum(X[S1.unique.idx])
        g <- sum(X[S2.unique.idx])
        p.1 <- e/n1
        p.2 <- g/n1
        p.bar <- (e + g)/(2*n1)
        if(correction == "plus") {
          n1 <- n1 + 4
          e <- e + 2
          g <- g + 2
        }
        z1 <- (p.1 - p.2)/sqrt((2*p.bar*(1-p.bar))/n1)
        z1 <- ifelse(is.na(z1), 0, z1)
        z3 <- 0
        w <- (n1 + n1)/(2*n12 + n1 + n1)
        z5 <- (w*z1 + (1-w)*z3)/(sqrt(w^2 + (1-w)^2))
        p.val[j] <- 2*(1 - pnorm(abs(z5)))
      }
    }
    # difference estimates
    est <- pi1 - pi2
  }
  list(diff_estimate = est, std_err = se.np, ci_interval = CI.int, p_value = p.val)
}


######################################## FUNCOES UTILITARIAS #######################################

#' Gera Grade \code{dhl} x \code{dpot} No Dominio Da Curva Colina
#'
#' Funcao auxiliar para gerar grades de pontos nos quais interpolar a curva colina
#'
#' Os argumentos \code{dhl} e \code{dpot} especificam a grade de maneira mais simples: se forem
#' inteiros, as coordenadas de queda e potencia da grade sao geradas segmentando a faixa de quedas
#' e potencias contidas na colina em \code{dhl} e \code{dpot} respectivamente. Caso sejam vetores,
#' a grade sera construida com as posicoes contidas nestes vetores. Veja os Exemplos.
#'
#' \code{byhl} e \code{bypot} permitem uma especificacao mais detalhada. Estes argumentos sao
#' interpretados como o intervalo de separacao entre cada divisao de queda e potencia na grade. Para
#' manter a consistencia, a faixa de quedas e potencias usada nessa construcao nao sao exatamente
#' aquelas contidas na colina, como quando gerando grades a partir de \code{dhl} e \code{dpot} (pois
#' muito provavelmente uma sequencia comecando em min(hl) andando de byhl em byhl nao terminaria em
#' max(hl)). Os minimos e maximos das faixas serao obtidos segundo as regras:
#'
#' \itemize{
#' \item{minimo: o maior multiplo de \code{byX} menor que min(X)}
#' \item{maximo: o menor multiplo de \code{byX} maior que max(X)}
#' }
#'
#' Se estes dois argumentos forem passados, \code{dhl} e \code{dpot} sao automaticamente ignorados.
#'
#' \code{expande} permite montar grades que vao alem dos minimos e maximos de queda e potencia
#' observados na curva colina. Deve ser informado como um vetor de duas posicoes indicando
#' percentuais em formato decimal (5% = 0.05), sendo a primeira posicao para queda e a segunda para
#' potencia. Para um dado valor em \code{expande}, a faixa de quedas ou potencias sera expandida
#' segundo
#'
#' \eqn{faixa_hl = range(hl) + c(-range(hl) * expande[1], -range(hl) * expande[1])}
#'
#' O calculo para potencia e analogo. Esta expansao de faixa se aplica tanto no caso em que
#' \code{dhl} e \code{dpot} sao passados quanto \code{byhl} e \code{bypot}. Adicionalmente, se
#' \code{dhl} e \code{dpot} forem fornecidos como vetores, \code{expande} sera ignorado.
#'
#' @param colina objeto da classe \code{curvacolina} (retornado pelas funcoes de leitura)
#' @param dhl,dpot numero de divisoes no eixo de queda liquida e potencia, respectivamente. Tambem
#'     podem ser fornecidos vetores indicando as posicoes das divisoes de queda e potencia
#' @param byhl,bypot intervalo entre divisoes de queda e potencia, respectivamente; se forncecido
#'     \code{dhl} e \code{dpot} serao ignorados. Ver Detalhes
#' @param expande vetor de duas posicoes indicando percentual de expansao do dominio. Ver Detalhes
#'
#' @examples
#'
#' # grade contemplando toda a faixa de quedas e potencias da colina, cada uma divida em 20 partes
#' grade1 <- coordgrade(colinadummy, 20, 20)
#'
#' # grade com coordenadas especificadas diretamente
#' grade2 <- coordgrade(colinadummy, 40:60, seq(150, 400, by = 10))
#'
#' # grade com intervalos de 1 cm em queda e 10 MW em potencia
#' # grade3 <- coordgrade(colinadummy, byhl = .1, bypot = 10)
#'
#' \dontrun{
#' plot(colinadummy, "2d") + ggplot2::geom_point(data = grade, aes(hl, pot), col = 2)
#' }
#'
#' @return data.frame contendo coordenadas dos pontos na grade
#'
#' @family curvacolina
#'
#' @import data.table
#'
#' @export

coordgrade <- function(colina, dhl, dpot, byhl, bypot, expande) UseMethod("coordgrade", colina)

#' @export

coordgrade.data.table <- function(colina, dhl, dpot, byhl, bypot, expande = c(0, 0)) {

    hl <- pot <- NULL

    xhl <- expande[1] * diff(range(colina$hl))
    xhl <- range(colina$hl) + c(-1, 1) * xhl

    xpot <- expande[2] * diff(range(colina$pot))
    xpot <- range(colina$pot) + c(-1, 1) * xpot

    if(!missing(byhl)) {
        if(!missing(dhl)) warning("Tanto 'dhl' quanto 'byhl' foram fornecidos -- ignorando 'dhl'")

        minhl <- floor(xhl[1] / byhl) * byhl
        maxhl <- ceiling(xhl[2] / byhl) * byhl
        dhl <- seq(minhl, maxhl, by = byhl)
    }

    if(!missing(bypot)) {
        if(!missing(dpot)) warning("Tanto 'dpot' quanto 'bypot' foram fornecidos -- ignorando 'dpot'")

        minpot <- floor(xpot[1] / bypot) * bypot
        maxpot <- ceiling(xpot[2] / bypot) * bypot
        dpot <- seq(minpot, maxpot, by = bypot)
    }

    dhlvetor <- length(dhl) > 1L
    dpotvetor <- length(dpot) > 1L

    if(dhlvetor) hl <- dhl else hl <- seq(xhl[1], xhl[2], length.out = dhl)
    if(dpotvetor) pot <- dpot else pot <- seq(xpot[1], xpot[2], length.out = dpot)

    grade <- expand.grid(hl = hl, pot = pot)

    grade <- as.data.table(grade)

    return(grade)
}

#' @export

coordgrade.data.frame <- function(colina, dhl, dpot, byhl, bypot, expande = c(0, 0)) {

    grade <- coordgrade.data.table(as.data.table(colina), dhl, dpot, byhl, bypot, expande)

    return(grade)
}

#' @export

coordgrade.curvacolina <- function(colina, dhl, dpot, byhl, bypot, expande = c(0, 0)) {

    grade <- coordgrade(colina$CC, dhl, dpot, byhl, bypot, expande)

    return(grade)
}

# --------------------------------------------------------------------------------------------------

#' Generica Para Extrair Colina Original do Ajuste
#'
#' Extrai o dado ajustado corretamente dependendo do tipo de modelo. Funcao interna
#'
#' @param object objeto do qual extrair \code{data.table} da curva colina. Pode ser um modelo
#'     interpolador ou objeto da classe \code{curvacolina}
#'
#' @return \code{data.table} contendo a curva colina em formato padronizado

getcolina <- function(object) UseMethod("getcolina")

# --------------------------------------------------------------------------------------------------

#' Ordem Dos Vertices De Poligono
#'
#' Centraliza \code{dat} por referencia e retorna vetor de indices dos vertices em ordem adjacente
#'
#' A determinacao de ordem dos vertices e feita com base no angulo entre cada um e o centro do
#' poligono. Este centro pode ser infromado por meio dos argumentos \code{centro_hl} e
#' \code{centro_pot} ou, caso estes fiquem vazios, sera calculado como a media amostral.
#'
#' @param dat \code{data.table} contendo vertices de um poligono cuja ordem sera determinada
#' @param centro_hl opcional, valor para centralizar \code{dat$hl}. Caso vazio usa a media
#' @param centro_pot opcional, valor para centralizar \code{dat$pot}. Caso vazio usa a media
#'
#' @return vetor de inteiros indicando os indices dos vertices na ordenacao por angulo

orderpoly <- function(dat, centro_hl, centro_pot) {

    ang <- pot <- hl <- NULL

    if(missing(centro_hl))  centro_hl  <- mean(dat$hl)
    if(missing(centro_pot)) centro_pot <- mean(dat$pot)

    dat$hl  <- dat$hl - centro_hl
    dat$pot <- dat$pot - centro_pot
    dat[, ang := atan2(pot, hl)]

    angord <- order(dat$ang)

    return(angord)
}


#stolpični diagram1
cairo_pdf("slike/stolpicni1.pdf", family="Arial")
tabela<-table(filmi$KRAJ)
imena<-names(tabela)
vektor<-c(tabela)
barplot(vektor, names.arg = imena, xlab="DRŽAVE", ylab="ŠTEVILO FILMOV PO DRŽAVAH", main="ŠTEVILO FILMOV POSNETIH V POSAMEZNI DRŽAVI", las=2, cex.names=0.5, col="blue")
dev.off()

#stolpični diagram2
zanr.imena <- colnames(filmi)[7:26] #v oglatih oklepajih je inerval stolpcev - za eno manj na obeh straneh
zanr.vrednosti <- apply(filmi[zanr.imena], 2, sum) #2 pomeni da so na x osi obrnjeni navpično, na y osi vodoravno

zanr.vrednosti <- sort(zanr.vrednosti)
zanr.imena <- names(sort(zanr.vrednosti))

cairo_pdf("slike/stolpicni2.pdf", family="Arial")
barplot(zanr.vrednosti, names.arg = zanr.imena, xlab="ŽANRI", ylab="ŠTEVILO FILMOV", main="DISTRIBUCIJA ŽANROV", las=2, cex.names=0.5, col="blue")
dev.off()

#stolpični diagram3
cairo_pdf("slike/stolpicni3.pdf",family="Arial")
hist(filmi$OCENA, breaks=5, xlab="OCENE FILMOV", ylab="ŠTEVILO FILMOV", main="DISTRIBUCIJA FILMOV GLEDE NA OCENE", col="blue")
dev.off()

#stolpični diagram4
cairo_pdf("slike/stolpicni4.pdf",family="Arial")
hist(filmi$"LETNICA.NASTANKA", breaks=8, axes=F, xlab="LETNICE NASTANKOV", ylab="ŠTEVILO FILMOV", main="DISTRIBUCIJA FILMOV GLEDE LETNICE NASTANKA", col="blue")
axis(2)
axis(1, at=seq(1930, 2010, 10))
dev.off()

# tortni diagram1
cairo_pdf("slike/tortni1.pdf",family="Arial")
pie(table(filmi$"STEVILO.NAGRAD" > 0), labels=NA, main="ALI JE FILM PREJEL VSAJ ENO NAGRADO?", col=topo.colors(2), radius = 1)
text(-0.5,0, paste("DA"), col="black")
text(0.6, 0.2, paste("NE"), col="black")
legend("bottomleft", title="ŠTEVILO FILMOV:", bg="white", legend=table(filmi$"STEVILO.NAGRAD" > 0), fill=topo.colors(2),  text.font=2, cex=0.75)
dev.off()

# tortni diagram2
drzave <- sort(table(filmi$KRAJ))
imena.drzav <- names(drzave)
cairo_pdf("slike/tortni2.pdf",family="Arial")
pie(drzave, labels=NA, col= topo.colors(length(imena.drzav)), main="ŠTEVILO FILMOV POSNETIH V POSAMEZNI DRŽAVI", radius = 1)
legend("bottomleft", title="LEGENDA DRŽAV:", bg="white", text.font=1, cex=0.8, legend=imena.drzav, fill=topo.colors(length(imena.drzav)))
dev.off()