library(robustbase) #colmedians
library(stringr) #str_match
library(randomForest)
library(R.matlab) #readMat
library(caret)
library(ggcorrplot)

get_best_coco <- function(folder, best){
  all_best <- c()
  sample_size = 250
  files <- list.files(folder, full.names = FALSE, pattern = toString(sample_size))
  pattern <- ("(\\d+)_(\\d+)_.*")
  for (file in files){
    regex_match <- str_match(file, pattern)
    func <- regex_match[1,2]
    instance <- regex_match[1,3]
    best_index <- ((as.numeric(func) - 1) * 15) + as.numeric(instance)
    file_best <- best[best_index]
    all_best <- c(all_best, file_best)
  }
  return(all_best)
}

transform_best_coco <- function(best){
  #best is a 360 by 10 matrix, we want to convert it to a list of c(), featuring all non-0 members of best per row
  best_list <- list()
  for (row_i in 1:nrow(best)){
    best_row <- best[row_i,]
    best_row <- best_row[best_row > 0] #take away zero elements
    best_list[[row_i]] <- best_row
  }
  return(best_list)
}

linear_matrix_factorization_embeddings<-function(X_temp,problems_names,number_of_singular_values){

  data_temp<-X_temp
  decomposition<-svd(data_temp)

  Sigma<-diag(decomposition$d[1:number_of_singular_values])
  U<-decomposition$u[,1:number_of_singular_values]
  V_t<-t(decomposition$v)[1:number_of_singular_values,]
  inv_Sigma<-diag(1/decomposition$d[1:number_of_singular_values])
  problem_embeddings<-list()

  for(i in 1:nrow(data_temp)){
    problem_embeddings[[i]]<-data_temp[i,]%*%t(V_t)%*%inv_Sigma
  }
  problems_embeded<-matrix(unlist(problem_embeddings)[!is.na(unlist(problem_embeddings))], ncol = length(problem_embeddings[[i]]), byrow = T)

  rownames(problems_embeded)<-problems_names
  return(list(problems_embeded=problems_embeded,U=U,Sigma=Sigma,V_t=V_t))

}

normalize_data <- function(df, means = NA, stds = NA, min = NA, max = NA, type="normalize") {
  classes <- df$class
  df$class <- NULL

  funcs <- df$func
  df$func <- NULL

  df2 <- as.data.frame(df)

  columns <- colnames(df2)
  if(is.na(means)){
    means <- colMeans(df2)
    saveRDS(means, "means")
  }

  if(is.na(stds)){
    stds <- apply(df2, 2, sd)
    saveRDS(stds, "stds")
  }

  if(is.na(min)){
    min <- apply(df2, 2, min)
    saveRDS(min, "max")
  }

  if(is.na(max)){
    max <- apply(df2, 2, max)
    saveRDS(max, "max")
  }

  if(type == "normalize" || type=="both"){
    df2 <- sweep(df2, 2, means, FUN = '-')
    df2 <- sweep(df2, 2, stds, FUN = '/')
  }

  if (type =="minmax" || type == "both"){
    df2 <- sweep(df2, 2, min, FUN = '-')
    df2 <- sweep(df2, 2, (max-min), FUN = '/')
  }

  ret <- c()
  ret$normalized <- df2
  ret$mean <- means
  ret$std <- stds
  df2$class <- classes
  df2$func <- funcs

  #remove constant columns that have been set to NaN during normalization
  df2 <- df2[ , colSums(is.na(as.matrix(df2))) == 0]
  df2 <- df2[ , colSums(is.nan(as.matrix(df2))) == 0]
  return(df2)
}

read_features_performance <- function(folder = "C:\\R_Code\\samples_10D\\features", sample_size = 250){
  files <- list.files(folder, full.names = TRUE, pattern = paste(sample_size, sep=""))
  allData <- NULL
  allBest <- c()
  i<-1
  for (file in files){
    #get class based on file name
    pattern <- "samples_(\\D*)_"
    res <- str_match(file, pattern)
    best_algorithm <- res[1,2]
    allBest <- c(allBest, best_algorithm)

    pattern_function <- ".+_(\\d*)_samples_"
    res <- str_match(file, pattern_function)
    file_function <- as.numeric(res[1,2])
    i <- i + 1

    data <- readRDS(file)
    columns <- readRDS("./landscape_features/processed/ML_cols.RDS")
    if (is.null(allData)){
      allData <- matrix(nrow = 0, ncol = length(columns))
    }
    data$func <- file_function
    columns <- readRDS("landscape_features/processed/ML_cols.RDS")
    data <- unlist(data)
    data <- data[columns]
    allData <- rbind(allData,unlist(data))
  }
  result <- c()
  result$data = allData
  result$best = allBest
  return(result)
}

read_features_performance_coco <- function(folder = "C:\\R_Code\\samples_10D\\features", sample_size = 250){
   files <- list.files(folder, full.names = TRUE, pattern = toString(sample_size))
  allData <- NULL
  allBest <- c()
  for (file in files){
    #get class based on file name
    pattern <- "samples_(\\D*)_"
    res <- str_match(file, pattern)
    best_algorithm <- res[1,2]
    allBest <- c(allBest, best_algorithm)

    pattern_function <- ".+/(\\d*)_.*_250.mat.RDS"
    res <- str_match(file, pattern_function)
    file_function <- as.numeric(res[1,2])

    pattern_instance <- ".+_(\\d*)_.*_250.mat.RDS"
    res <- str_match(file, pattern_instance)
    file_instance <- as.numeric(res[1,2])

    trial_function <- ".+_.+_(\\d*)_250.mat.RDS"
    res <- str_match(file, trial_function)
    trial <- as.numeric(res[1,2])

    if (trial > 10){
      next()
    }

    columns <- readRDS("landscape_features/processed/ML_cols.RDS")
    data <- readRDS(file)
    if (is.null(allData)){
      allData <- matrix(nrow = 0, ncol = length(columns))
    }
    data$func <- as.numeric(file_function) * 100 + as.numeric(file_instance)

    data <- unlist(data)
    data <- data[columns]

    allData <- rbind(allData,unlist(data))
  }
  result <- c()
  result$data = allData
  result$best = allBest
  return(result)
}

#Create k folds, so that all runs of a function are always in the same fold (create folds based on functions)
createFoldsCustom <- function(data, k){
  folds = 10
  funcs <- unique(data$func)
  times <- rep(length(funcs)/folds, folds)
  indices <- sample(rep(1:folds, times = times))
  splits <- split(funcs, indices)

  all_indexes <- c()
  i <- 1
  for (split in splits){
    indexes <- which(data$func %in% split)
    all_indexes[[i]] <- indexes
    i <- i + 1
  }
  return(all_indexes)

}

createFoldsCustomCoco <- function(data, k){
  #print(data)
  funcs <- unique(data$instance)
  funcs <- funcs[order(funcs)] #order is random otherwise

  all_indexes <- c()
  i <- 1
  for (func in funcs){
    indexes <- which(!(data$instance %in% func))
    all_indexes[[i]] <- indexes
    i <- i + 1
  }
  return(all_indexes)

}

train_ml <- function(ml_func, train_data){
  model <- c()
  model$all = ml_func(train_data$all)
  model$Cols = ml_func(train_data$Cols)

  return(model)
}
test_ml <- function(model, test_data, validation_data, model_name, train_data, predictor = function(x,y){predict(x,y, predcontrib = TRUE, approxcontrib = F)}, multilabel=F, classes = NA){
  accuracy <- list()
  precisions <- list()
  recalls <- list()
  f1s <- list()

  model_names <- c("all", "Cols")

  for (m in model_names){
    train <- train_data[[m]]
    validation <- validation_data
    predictions <- predictor(model[[m]], test_data)
    predictions_validate <- predictor(model[[m]], validation)
    t<-table(predictions, test_data$class)

    if(multilabel){
      correct <- 0
      for (pred_i in 1:length(predictions)){
        pred <- predictions[[pred_i]]
        class <- classes[[pred_i]]
        if (pred %in% class){
          correct <- correct + 1
        }
      }
    } else {
      correct <- sum(diag(t)) # the correct predictions are on the diagonals
    }

    accuracy[[m]] <- correct/sum(t)

    total_cols <- colSums(t)
    total_rows <- rowSums(t)

    precisions[[m]] <-  correct / total_rows
    recalls[[m]] <- correct / total_cols
    fp <- total_rows - correct
    fn <- total_cols - correct
    f1s[[m]] <- (2*correct) / (2*correct + fp + fn) #isto kot zgoraj. Isto kot prva enaÄŤba, samo da je 0 namesto NaN ko sta precision in recall oba 0 (drugaÄŤe da f1 veÄŤje kot precision in recall ko damo macro average)

  }

  accuracy <- unlist(accuracy)
  names(accuracy) <-  paste(model_name, names(accuracy), sep = "_")

  #table is: rows = prediction, columns = true

  results <- c()
  results$accuracy <- accuracy
  results$precision <- precisions
  results$recall <- recalls
  results$f1 <- f1s

  return(results)

}

test_ml_old <- function(model, test_data, model_name, predictor = function(x,y){predict(x,y)}){
  accuracy <- c()

  predictions <- predictor(model$all, test_data)
  predictions2 <- predictor(model$"2", test_data)
  predictions5 <- predictor(model$"5", test_data)
  predictions10 <- predictor(model$"10", test_data)
  predictions15 <- predictor(model$"15", test_data)
  predictions20 <- predictor(model$"20", test_data)
  predictionsCols <- predictor(model$Cols, test_data)

  t2<-table(predictions2, test_data$class)
  accuracy$"2" <- sum(diag(t2))/sum(t2)

  t5<-table(predictions5, test_data$class)
  accuracy$"5" <- sum(diag(t5))/sum(t5)

  t10<-table(predictions10, test_data$class)
  accuracy$"10" <- sum(diag(t10))/sum(t10)

  t15<-table(predictions15, test_data$class)
  accuracy$"15" <- sum(diag(t15))/sum(t15)

  t20<-table(predictions20, test_data$class)
  accuracy$"20" <- sum(diag(t20))/sum(t20)

  tall<-table(predictions, test_data$class)
  accuracy$"all" <- sum(diag(tall))/sum(tall)

  tCols<-table(predictionsCols, test_data$class)
  accuracy$"Cols" <- sum(diag(tCols))/sum(tCols)

  accuracy <- unlist(accuracy)
  names(accuracy) <-  paste(model_name, names(accuracy), sep = "_")

  return(accuracy)

}

get_func_coco <- function(folder, best){
  all_best <- c()
  sample_size = 250
  files <- list.files(folder, full.names = FALSE, pattern = toString(sample_size))
  pattern <- ("(\\d+)_(\\d+)_.*")
  for (file in files){
    trial_function <- ".+_.+_(\\d*)_250.mat.RDS"
    res <- str_match(file, trial_function)
    trial <- as.numeric(res[1,2])
    if (trial > 10){
      next()
    }
    regex_match <- str_match(file, pattern)
    func <- regex_match[1,2]
    instance <- regex_match[1,3]
    #func_coco <- as.numeric(func)*100 + as.numeric(instance)
    func_coco <- as.numeric(func)*100
    all_best <- c(all_best, func_coco)
  }
  return(all_best)
}

analyze_results <- function(results){
  accuracy <- matrix(nrow = 0, ncol = length(results[[1]][[1]]$accuracy))
  precision <- matrix(nrow = 0, ncol = length(results[[1]][[1]]$accuracy))
  recall <- matrix(nrow = 0, ncol = length(results[[1]][[1]]$accuracy))
  f1 <- matrix(nrow = 0, ncol = length(results[[1]][[1]]$accuracy))
  for (row in 1:length(results)){
    results_row = results[[row]]
    for (algorithm in length(results_row)){
      algorithm_row <- results_row[[algorithm]]
      #mean for macro scores
      accuracy <- rbind(accuracy, algorithm_row$accuracy)
      precision <- rbind(precision, lapply(algorithm_row$precision, mean))
      recall <- rbind(recall, lapply(algorithm_row$recall, mean))
      f1 <- rbind(f1, lapply(algorithm_row$f1, mean))

    }
  }
  ret <- c()
  ret$accuracy <- accuracy
  ret$precision <- precision
  ret$recall <- recall
  ret$f1 <- f1
  return(ret)
}

make_balanced <- function(data){
  data_ret <- c()
  data_ret$best <- c()
  data_ret$data <- matrix(nrow = 0, ncol = ncol(data$data))
  algorithms <- levels(as.factor(data$best))
  for (algorithm in algorithms){
    print(length(which(data$best == algorithm)))
    indices <- which(data$best == algorithm)[1:50]
    data_ret$best <- c(data_ret$best, data$best[indices])
    data_ret$data <- rbind(data_ret$data, data$data[indices,])

  }

  data_ret$data <- as.data.frame(data_ret$data)
  return(data_ret)
}

make_median <- function(data){
  funcs <- as.data.frame(data$data)
  funcs <- funcs$func
  funcs <- unique(funcs)
  data_ret <- c()
  data_ret$best <- c()
  data_ret$data <- matrix(nrow = 0, ncol = ncol(data$data))
  df <- as.data.frame(data$data)
  for (func in funcs){
    indices <- which(df$func == func)

    if (length(indices) < 10){
      next()
    }

    new_best <- data$best[indices]

    if(length(unique(new_best)) > 1){
      print("different best")
    }

    new_data <- data$data[indices,]
    new_data <- colMedians(new_data)
    data_ret$best <- c(data_ret$best, new_best[[1]])
    data_ret$data <- rbind(data_ret$data, new_data)

  }

  return(data_ret)
}

make_median_coco <- function(data){
  funcs <- as.data.frame(data$data)
  funcs <- funcs$func
  funcs <- unique(funcs)
  data_ret <- c()
  data_ret$best <- c()
  data_ret$data <- matrix(nrow = 0, ncol = ncol(data$data))
  df <- as.data.frame(data$data)
  for (func in funcs){
    #print(func)

    indices <- which(df$func == func)

    if (length(indices) < 10){
      next()
    }

    new_best <- data$best[indices]

    if(length(unique(new_best)) > 1){
      print("different best")
    }

    new_data <- data$data[indices,]
    new_data <- colMedians(new_data)
    #order(train_class)[!duplicated(sort(train_class))]
    data_ret$best <- c(data_ret$best, new_best[[1]])
    data_ret$data <- rbind(data_ret$data, new_data)

  }
  #remove the instance information from the func column, to group folds by function
  df <- as.data.frame(data_ret$data)
  df$func <- floor(df$func/1000)
  data_ret$data <- as.matrix(df)
  return(data_ret)
}

make_median_artificial <- function(data){
  funcs <- as.data.frame(data$data)
  funcs <- funcs$func
  funcs <- unique(funcs)
  data_ret <- c()
  data_ret$best <- c()
  data_ret$data <- matrix(nrow = 0, ncol = ncol(data$data))
  df <- as.data.frame(data$data)
  for (func in funcs){
    #print(func)

    indices <- which(df$func == func)

    if (length(indices) < 10){
      next()
    }

    new_best <- data$best[indices]

    if(length(unique(new_best)) > 1){
      print("different best")
    }

    new_data <- data$data[indices,]
    new_data <- colMedians(new_data)
    #order(train_class)[!duplicated(sort(train_class))]
    data_ret$best <- c(data_ret$best, new_best[[1]])
    data_ret$data <- rbind(data_ret$data, new_data)

  }

  return(data_ret)
}

calculate_accuracy_values<-function(data){
  precisions <- list()
  recalls <- list()
  f1s <- list()

  for (type in c("all", "Cols")){
    precision <- c()
    recall <-c()
    f1 <- c()
    for (fold in c(1:10)){
      p_type <- data[[fold]]$precision[[type]]
      r_type <- data[[fold]]$recall[[type]]
      f1_type <- data[[fold]]$f1[[type]]

      precision <- c(precision, mean(p_type, na.rm=TRUE))
      recall <-c(recall, mean(r_type, na.rm=TRUE))
      f1 <- c(f1, mean(f1_type, na.rm=TRUE))
    }
    precisions[[type]] <- mean(precision, na.rm = TRUE)
    recalls[[type]] <- mean(recall, na.rm = TRUE)
    f1s[[type]] <- mean(f1, na.rm = TRUE)
  }
  ret <- c()
  ret$precision <- precisions
  ret$recall <- recalls
  ret$f1 <- f1s

  return(ret)

}

#The invariant landscape features
columns <- c("cm_angle.angle.mean",
             "ela_distr.skewness",
             "ela_distr.kurtosis",
             "ela_distr.number_of_peaks",
             "ela_meta.lin_simple.adj_r2",
             "ela_meta.lin_simple.intercept",
             "ela_meta.lin_simple.coef.min",
             "ela_meta.quad_w_interact.adj_r2",
             "ela_meta.quad_simple.adj_r2",
             "ela_meta.lin_w_interact.adj_r2",
             "disp.ratio_mean_02",
             "disp.ratio_median_25",
             "nbc.nb_fitness.cor",
             "pca.expl_var_PC1.cov_init",
             "pca.expl_var.cov_init",
             "pca.expl_var.cor_init")


dat <- expand.grid(rep=gl(2,1), NO3=factor(c(0,10)),field=gl(3,1) )
dat
Agropyron <- with(dat, as.numeric(field) + as.numeric(NO3)+2) +rnorm(12)/2
Schizachyrium <- with(dat, as.numeric(field) - as.numeric(NO3)+2) +rnorm(12)/2
total <- Agropyron + Schizachyrium
dotplot(total ~ NO3, dat, jitter.x=TRUE, groups=field,
        type=c('p','a'), xlab="NO3", auto.key=list(columns=3, lines=TRUE) )

Y <- data.frame(Agropyron, Schizachyrium)
mod <- metaMDS(Y)
plot(mod)
### Hulls show treatment
with(dat, ordihull(mod, group=NO3, show="0"))
with(dat, ordihull(mod, group=NO3, show="10", col=3))
### Spider shows fields
with(dat, ordispider(mod, group=field, lty=3, col="red"))

### Correct hypothesis test (with strata)
adonis(Y ~ NO3, data=dat, strata=dat$field, perm=999)

library(dplyr)
data <- read.csv('/Users/glmarschmann/.julia/dev/DEBTrait/files/BatchC/adonis_BGE_select.csv')

X <- data.frame(data$response, as.factor(data$rX), data$concentration)
names(X) <- c('Response', 'rX', 'Concentration')
Y <- data.frame(data$BGE)
names(Y) <- c('BGE')
row_sub = apply(Y, 1, function(row) all(row !=0 ))
Yf <- Y[row_sub,]
Xf <- X[row_sub,]
mod <- metaMDS(Yf)
plot(mod)
with(Xf, ordihull(mod, group=rM, show="1"))
with(Xf, ordihull(mod, group=rM, show="2", col=3))
with(Xf, ordispider(mod, group=Response, lty=3, col="red"))

adonis(Yf ~ rX, data=Xf, perm=999)


vektor.A <- c(2,3,5,7)
vektor.A

vektor.B <- c( TRUE, FALSE, FALSE)
vektor.B

imena <- c( "Pera", "Mika", "Zika")
imena

x<- length(imena)
x

vektor.C = c( 12.5,7.8, 9, 4, -2)
vektor.C

vektor.D <- c( vektor.C, vektor.A)
vektor.D
vektor.E <- c(vektor.D, vektor.D )
vektor.E

vektor.A <- c(2,3,5,7)
vektor.A
vektor.B <- c( TRUE, FALSE, FALSE)
vektor.B
c(vektor.A, vektor.B)

vektor.A <- c(2,3,5,7)
vektor.A
imena <- c( "Pera", "Mika", "Zika")
imena
c(vektor.A, vektor.B, imena)

# operacije
vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
vektor.B <- c(12.1,13,15,17,18, 16)
vektor.B
zbir <- vektor.A + vektor.B
zbir
razlika <- vektor.A - vektor.B
razlika

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
vektor.B <- c(TRUE,TRUE,TRUE,TRUE,FALSE,TRUE)
vektor.B
proizvod <- vektor.A * vektor.B
proizvod

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
vektor.B <- c("TRUE","a","b","c","d", "e")
vektor.B
proizvod <- vektor.A * vektor.B
proizvod

vektor.A <- c(2,3,5,7,9, 16.3)
rezultat <- 2 * vektor.A
rezultat
rezultat <- vektor.A * 2
rezultat

vektor.A <- c(2, 3, 5, 7, 9, 16.3)
vektor.A
vektor.B <- c(12.1, 13)
vektor.B
zbir <- vektor.A + vektor.B
zbir

# indeksiranje vektora
vektor.A <- c(2,3,5,7)
drugi.clan.A <- vektor.A[2]
drugi.clan.A

vektor.A <- c(2,3,5,7)
bez.drugog.clana.A <- vektor.A[-2]
bez.drugog.clana.A

vektor.A <- c(2,3,5,7)
x <- vektor.A[12]
x

vektor.A <- c(2,3,5,7,9)
vektor.A
drugi.i.cetvrti.A <- vektor.A[c(2,4)]
drugi.i.cetvrti.A

vektor.A <- c(2,3,5,7,9)
vektor.A
cetvrti.peti.i.drugi.A <- vektor.A[c(4,5,2)]
cetvrti.peti.i.drugi.A

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
od.drugog.do.petog.A <- vektor.A[c(2,3,4,5)]
od.drugog.do.petog.A

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
od.drugog.do.petog.A <- vektor.A[2:5]
od.drugog.do.petog.A

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
vektor.A[6] <- 22
vektor.A

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
vektor.A[4:6] <- c(3,4,22)
vektor.A

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
vektor.A[4:6] <- c(3,4,22, 23)
vektor.A

vektor.A <- c(2,3,5,7,9, 16.3)
vektor.A
vektor.A[4:6] <- c(3,4)
vektor.A

# filter preko logickih vrednosti
vektor.A <- c(2, 3, 5, 7, 9, 16.3)
vektor.A
filter <- c(TRUE, TRUE, FALSE, FALSE, TRUE, FALSE)
filter
prepisani <- vektor.A[filter]
prepisani

vektor.A <- c(2, 3, 5, 7, 9, 16.3, 22)
vektor.A
filter <- c(TRUE, FALSE)
filter
prepisani <- vektor.A[filter]
prepisani

vektor.A <- c(12, 3, 5, 4, 19, 6, 2)
vektor.A
filter <- vektor.A >= 5
filter
ne.manji.od.5.iz.A <- vektor.A[filter]
ne.manji.od.5.iz.A

vektor.A <- c(12, 3, 5, 4, 19, 6, 2)
vektor.A
filter <- (vektor.A >= 5) & (vektor.A <=10)
filter
rez <- vektor.A[filter]
rez

trojka <- c(23, 45, 78)
trojka
names(trojka) <- c("levi", "srednji", "desni")
trojka

x <- trojka["levi"]
x

trojka["desni"] <- TRUE
trojka

x <- "srednji"
trojka[x] <- 22.4
trojka


# Generate lists of weird species by city and overall. Weird species are species with trait values in the 5th and 9th percentile.
# At this point, only considering one trait: Leaf area per leaf dry mass (specific leaf area, SLA or 1/LMA): petiole excluded

library(dplyr)
library(ggplot2)

# read in species occurance + trait data and filter for traits of interest
species_traits <- read.csv("data/species_and_their_traits.csv", header = TRUE, stringsAsFactors = FALSE)

sla <- species_traits %>%
    select(-count) %>%
    filter(TraitName == "Leaf area per leaf dry mass (specific leaf area, SLA or 1/LMA): petiole excluded") %>%
    mutate(TraitName = "SLA") # Make the trait name easier to work with))

# have a quick peek at the data
sla$City <- factor(sla$City, levels = c("Vancouver", "Edmonton", "Winnipeg", "Toronto", "Montreal", "Halifax")) # reordering city names West to East

canada <- ggplot(sla, aes(x=value)) +
    geom_violin(draw_quantiles = c(0.10, 0.90)) +
    theme_classic(base_size=18)

cities <- ggplot(sla, aes(x=City, y=value, fill=City)) +
    #geom_violin(aes(x="All", y=value), inherit.aes = FALSE, draw_quantiles = c(0.10, 0.90)) +
    geom_violin(draw_quantiles = c(0.10, 0.90)) +
    theme_classic(base_size=18)

#cities + geom_jitter(shape = 1, position = position_jitter(0.2)) ### added jittered points to violin plot

cities$sla$City <- factor(cities$sla$City,
                          levels = c("Vancouver, Edmonton, Winnipeg, Toronto, Montreal, Halifax")) # put cities in order

# fancied up a bit

cities_fancy <- cities +
    theme(legend.position = "none") +
    labs(x = " ",
         y = expression(paste("Specific Leaf Area (mm"^2, " ", mg^-1, sep=")")))

ggsave("figures/sla_violins_ALL.png", plot=cities_fancy, width=16, height=9, units="in")

# quad violins
quads <- ggplot(sla, aes(x=as.factor(quadrat), y=value, fill=City)) +
    geom_violin(draw_quantiles = c(0.10, 0.90)) +
    facet_wrap("City") +
    theme_classic(base_size=18)

#cities + geom_jitter(shape = 1, position = position_jitter(0.2)) ### added jittered points to violin plot

cities$sla$City <- factor(cities$sla$City,
                          levels = c("Vancouver, Edmonton, Winnipeg, Toronto, Montreal, Halifax")) # put cities in order

# fancied up a bit

quads_fancy <- quads +
    theme(legend.position = "none") +
    labs(x = " ",
         y = expression(paste("Specific Leaf Area (mm"^2, " ", mg^-1, sep=")")))

ggsave("figures/sla_violins_quads.png", plot=quads_fancy, width=16, height=9, units="in")
# calculate percentiles

# pick low and high percentiles

lowp <- 0.10
highp <- 0.90

# GLOBALLY WEIRD
global_percentile <- quantile(sla$value, probs=c(lowp, highp))

global_weird <- sla %>%
    select(-City, -quadrat) %>%
    distinct() %>%
    filter(value < global_percentile[1] | value > global_percentile[2]) %>%
    arrange(value)

nrow(global_weird) # 158 globally weird species

# visual check - two humped?

ggplot(global_weird, aes(x=value)) +
    geom_density()

# write out globally weird
write.csv(global_weird, "analysis/canada_weird.csv", row.names = FALSE)

# GLOBAL NORMAL

mediansla <- median(sla$value)
global_normal <- sla %>%
    select(-City, -quadrat) %>%
    distinct() %>%
    mutate(diff = abs(mediansla - value)) %>%
    filter(diff==min(diff))

# most normal species, globally
# species TraitName    value diff
# 1   Senecio viscosus       SLA 22.46667    0
# 2 Sherardia arvensis       SLA 22.46667    0

# LOCALLY WEIRD

# calculate weirdness percentiles for each city
local_percentile <- sla %>%
    select(-quadrat) %>%
    group_by(City) %>%
    summarise(low=quantile(value, probs=lowp), high=quantile(value, probs=highp))

# get list of weird species in each city
local_weird <- sla %>%
    left_join(local_percentile) %>%
    filter(value < low | value > high) %>%
    select(-low, -high)

# counts of weird
local_weird %>%
    group_by(City) %>%
    summarise(weird=n())

# City      weird
# <chr>     <int>
#1 Edmonton     34
# 2 Halifax      72
# 3 Montreal    103
# 4 Toronto     109
# 5 Vancouver   102
# 6 Winnipeg     24

# visual check - two humped?

local_weird <- ggplot(local_weird, aes(x=value, fill=as.factor(City))) +
    geom_density(alpha=0.5) +
    theme_classic()

## fancied it up a bit

local_weird + theme(legend.title = element_blank()) +
    labs(y = "Density",
         x = expression(paste("Specific Leaf Area (mm"^2, " ", mg^-1, sep=")")))

# write out locally weird
write.csv(local_weird, "analysis/city_weird.csv", row.names = FALSE)

# HYPERLOCALLY WEIRD (quadrat)

hyperlocal_percentile <- sla %>%
    group_by(City, quadrat) %>%
    summarise(low=quantile(value, probs=lowp), high=quantile(value, probs=highp))

# get list of weird species in each quadrat
hyperlocal_weird <- sla %>%
    left_join(hyperlocal_percentile) %>%
    filter(value < low | value > high) %>%
    select(-low, -high)

# visual check - two humped?
ggplot(hyperlocal_weird, aes(x=value, fill=as.factor(City))) +
    geom_density(alpha=0.5) +
    facet_wrap("quadrat")

ggplot(hyperlocal_weird, aes(x=City, y=value, fill=City)) +
    geom_violin() +
    facet_wrap("quadrat")

# write out hyperlocally weird
write.csv(hyperlocal_weird, "analysis/quadrat_weird.csv", row.names = FALSE)

#####################################################################################################################
# Test section from Ben
#require(reshape2)

# I think This one is OK!
test <- sla %>%
    select(-TraitName, -quadrat) %>%
    group_by(City)

cityHist <- ggplot(test, aes(x = value, fill =  City)) +
    facet_wrap(~ City) +
    geom_histogram(position = "stack", bins = 50)

cityHist <- cityHist + theme_bw(base_size = 18) +
    theme(legend.position = "None") +
    labs(y = "Count",
         x = expression(paste("Specific Leaf Area (mm"^2, " ", mg^-1, sep=")")))

ggsave("figures/cityHist.png", plot=cityHist, width=16, height=9, units="in")

# Trying to make the 5 quadrat for each city (6x5 plots)
test <- sla %>%
    select(-TraitName) %>%
    group_by(City, quadrat)
#test <-  melt(test, value.name = "value")
tempDf <- data.frame(c("Edmonton","Edmonton","Winnipeg","Winnipeg"), c(3,5,4,5), c(NA,NA), c(NA,NA)) #added manualy empty rows for the missing quadrat so we have one city per columns and they are not mixed up
colnames(tempDf) <- colnames(test)
test <- rbind(test, tempDf)
test$City <- as.factor(test$City)
test$City <- factor(test$City, levels = c("Vancouver","Edmonton","Winnipeg","Toronto","Montreal","Halifax"))

allHist <- ggplot(test, aes(x = value, fill = City)) +
    facet_grid(quadrat ~ City) +
    geom_histogram(bins = 50)

allHist <- allHist + theme_bw(base_size = 18) +
    theme(legend.position = "None") +
    labs(y = "Count",
         x = expression(paste("Specific Leaf Area (mm"^2, " ", mg^-1, sep=")")))
ggsave("figures/quadratHist.png", plot=allHist, width=16, height=9, units="in")

# Sampling effort. Don't know if we can say this is sampling effort, but thought it was worth showing how many obs. we had per city
sampEff <- sla %>%
    group_by(City) %>%
    count()

sampEff_plot <- ggplot(sampEff, aes(x = City, y = n, fill = City)) +
    geom_bar(stat = "identity")

sampEff_plot <- sampEff_plot + theme_classic(base_size = 18) +
    theme(legend.position = "none") +
    labs(x = " ",
         y = "Number of species")
ggsave("figures/sampling_spfig.png", plot=sampEff_plot, width=16, height=9, units="in")


 E04GGJ Example Program Results

 E04GG, Nonlinear least squares method for bound-constrained problems
 Begin of Options
     Print File                    =                   6     * d
     Print Level                   =                   1     * U
     Print Options                 =                 Yes     * d
     Print Solution                =                  No     * d
     Monitoring File               =                  -1     * d
     Monitoring Level              =                   4     * d

     Infinite Bound Size           =         1.00000E+20     * d
     Stats Time                    =                  No     * d
     Time Limit                    =         1.00000E+06     * d

     Bxnl Model                    =        Gauss-newton     * U
     Bxnl Nlls Method              =             Galahad     * d
     Bxnl Glob Method              =                 Reg     * U
     Bxnl Reg Order                =                Auto     * d
     Bxnl Tn Method                =           Min-1-var     * d
     Bxnl Basereg Type             =                None     * d
     Bxnl Basereg Pow              =         2.00000E+00     * d
     Bxnl Basereg Term             =         1.00000E-02     * d
     Bxnl Iteration Limit          =                1000     * d
     Bxnl Monitor Frequency        =                   0     * d
     Bxnl Print Header             =                  30     * d
     Bxnl Save Covariance Matrix   =                  No     * d
     Bxnl Stop Abs Tol Fun         =         1.05367E-08     * d
     Bxnl Stop Abs Tol Grd         =         1.05737E-05     * d
     Bxnl Stop Rel Tol Fun         =         1.05367E-08     * d
     Bxnl Stop Rel Tol Grd         =         1.05367E-08     * d
     Bxnl Stop Step Tol            =         2.22045E-16     * d
     Bxnl Use Second Derivatives   =                 Yes     * U
     Bxnl Use Weights              =                  No     * d
 End of Options

 Status: converged, an optimal solution was found
 Value of the objective             2.17328E-06
 Norm of projected gradient         1.51989E-08
 Norm of scaled projected gradient  7.29019E-06
 Norm of step                       4.98107E-04

Solver stored solution iterate in the handle
X:  4.45E-01  1.87E+00  3.07E+00  4.64E+00  -9.98E-01  4.64E+00


#getting and setting the working directory
#ctrl+L to clear console
setwd("C:\\Users\\lenovo\\Desktop\\Rdatamining")
getwd()

#choose datafile from set directory
datafile <- file.choose()          #"./emp.txt"
empfile <- read.table(datafile,header=TRUE,sep=",")
empfile  #display entire table

edit(empfile)  #open editor to enter new values
#total records in dataframe
nrow(empfile)
#total columns in dataframe

ncol(empfile)
dim(empfile)  ##rows and cols

head(empfile,-5) #all but last 5 rows
tail(empfile)  #last 6 records
#displaying rows with valid values
AV<-na.omit(empfile)
#count valid rows
nrow(AV)

#looking for missing values in rows/columns
rowSums(is.na(empfile)) # Number of missing per row
colSums(is.na(empfile)) # Number of missing per column/variable
#logical vector indicating rows with missing val or not
complete.cases(empfile)

#return valid rows
empfile[complete.cases(empfile),]

#data scaling
install.packages("TH.data")
# bodyfat Data
data("bodyfat", package = "TH.data")
str(bodyfat)
dim(bodyfat)
d1<-bodyfat
head(d1)
km <- kmeans(d1, 3)

centers <- data.frame( size=km$size, km$centers)
round(centers, digits=2)

data1<-scale(d1)  #subtract mean and divide by std dev
head(data1)
head(d1)
km1 <- kmeans(data1, 3)

centers1 <- data.frame( size=km1$size, km1$centers)
round(centers1, digits=2)

data2<-scale(d1,scale=FALSE)  #subtract mean only
head(data2)
str(d1)

#data normalization
#install.packages("clusterSim")
library(clusterSim)

z1 <- data.Normalization(d1,type="n8",normalization="column")
z1
?data.Normalization


StateName<-c("FL","MI","MO","CO")
StateFACName<-sort(unique(subdata08[,2]))
PollerFACName<-sort(unique(subdata08[,5]))
n<-c(0,0,0,0)
SSE<-c(0,0,0,0)
SSE1<-c(0,0,0,0)
# Pred for Q6
Pred<-matrix(0,4,4)
rownames(Pred)<-StateName
colnames(Pred)<-c("LDemWin","LRepWin","sLDemWin","sLRepWin")
# Pred for Q7
Pred1<-matrix(0,4,4)
rownames(Pred1)<-StateName
colnames(Pred1)<-c("LDemWin","LRepWin","sLDemWin","sLRepWin")
# log regression CI for Q8
PredCI<-matrix(0,4,4)
rownames(PredCI)<-StateName
colnames(PredCI)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# sample log regression CI for Q8
PredCI1<-matrix(0,4,4)
rownames(PredCI1)<-StateName
colnames(PredCI1)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# bootstrap CI of log regression for Q8
BSCI<-matrix(0,4,4)
rownames(BSCI)<-StateName
colnames(BSCI)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# bootstrap CI of sample log regression for Q8
BSCI1<-matrix(0,4,4)
rownames(BSCI1)<-StateName
colnames(BSCI1)<-c("DemWinLow","DemWinUp","RepWinLow","RepWinUp")
# Weighted Pred of log regression for Q9
S.Pred<-matrix(0,4,4)
rownames(S.Pred)<-StateName
colnames(S.Pred)<-c("LDemWin","LRepWin","sLDemWin","sLRepWin")
# computation of weight of pollers for Q9
poNum<-length(pollers)
ErrRates<-rep(0,poNum)
for (poID in 1:poNum){
  PoPred08<-NULL
  PoPredRt<-NULL
  Po08Rt<-NULL
  StateID<-NULL
  PoPred08<-po08sub[po08sub[,5]==pollers[poID],]
  PoPredRt<-(PoPred08[,2]>PoPred08[,3])+0
  StateID<-PoPred08[,1]
  Po08Rt<-winers2008[StateID]
  ErrRates[poID]<-sum(1-(PoPredRt==winers2008[StateID]))/length(PoPredRt)
}
PoRank<-rank(ErrRates)
Weight<-1/(PoRank^2)
PollWeight<-data.frame(pollers,Weight)

#the loop
for (k in 1:4){
  # number of locations
  NOpolls<-sum(subdata12[,2]==StateName[k])
  locations<-which(subdata12[,2]==StateName[k])
  n[k]<-length(locations)

  # clearance of variables in the loop
  probDemwin<-NULL
  probGopwin<-NULL
  subWeight<-NULL

  # for log model to get the X
  XStateFac<-(StateFACName==StateName[k])+0
  XPollerFAC<-(PollerFACName==pollersFAC2012[i])+0
  X<-matrix(0,n[k],nrow(vcov(logitreg)))
  Xs<-matrix(0,n[k],nrow(vcov(logitreg1)))

  # container of predictions
  LogPR<-cbind(as.double(subdata12[locations,1]),
               rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
  sLogPR<-cbind(as.double(subdata12[locations,1]),
                rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
  DeLogPR<-cbind(as.double(subdata12[locations,1]),
                 rep(0,n[k]),rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
  DesLogPR<-cbind(as.double(subdata12[locations,1]),
                  rep(0,n[k]),rep(0,n[k]),rep(0,n[k]))
  counts<-0
  sumGL<-rep(0,nrow(vcov(logitreg)))
  sumGsL<-rep(0,nrow(vcov(logitreg1)))
  for (i in locations){
    counts<-counts+1
    LogDPs<-data.frame(statesFAC=StateName[k],
                       margins=margins2012[i],lagtime=lagtime2012[i],
                       pollersFAC=pollersFAC2012[i])
    sLogDPs<-data.frame(margins=margins2012[i],
                        lagtime=lagtime2012[i],pollersFAC=pollersFAC2012[i])
#     X[counts,2:3]<-as.matrix(LogDPs[2:3])
#     Xs[counts,1:2]<-as.matrix(sLogDPs[1:2])
    # col1 :winner; col2:p(fit); col3:se.fit; col4:residual scale
    LogPR[counts,2]<-unlist(predict(logitreg,LogDPs,
                                      type="response",se.fit=TRUE))
    sLogPR[counts,2]<-unlist(predict(logitreg1,sLogDPs,
                                       type="response",se.fit=TRUE))
    #derivative
#     DeLogPR[counts,2:5]<-(1-LogPR[counts,2])*LogPR[counts,2]*unlist(LogDPs)
#     DesLogPR[counts,2:4]<-(1-sLogPR[counts,2])*sLogPR[counts,2]*unlist(sLogDPs)
#
#

    X[counts,]<-c(1,XStateFac[2:length(XStateFac)],margins2012[i],lagtime2012[i],XPollerFAC[2:length(XPollerFAC)])
    Xs[counts,]<-c(1,margins2012[i],lagtime2012[i],XPollerFAC[2:length(XPollerFAC)])
    sumGL<-sumGL+LogPR[counts,2]*(1-LogPR[counts,2])*X[counts,]
    sumGsL<-sumGsL+LogPR[counts,2]*(1-LogPR[counts,2])*X[counts,]
    }
  SSE<-sum(LogPR[,3]^2)
  SSE1<-sum(sLogPR[,3]^2)
  P1<-LogPR[,1]*LogPR[,2]+(1-LogPR[,1])*(1-LogPR[,2])
  P2<-sLogPR[,1]*sLogPR[,2]+(1-sLogPR[,1])*(1-sLogPR[,2])

  # Predictions for Q6
  Pred[k,1]<-mean(P1)
  Pred[k,2]<-mean(1-P1)
  Pred[k,3]<-mean(P2)
  Pred[k,4]<-mean(1-P2)
  # Predictions for Q7
  Pred1[k,1]<-mean(P1>0.5+0)
  Pred1[k,2]<-mean(P1<0.5+0)
  Pred1[k,3]<-mean(P2>0.5+0)
  Pred1[k,4]<-mean(P2<0.5+0)
  # Q8.1
  # clearance of containers

  # define the function of var of two models
  for (a in 1:n[k]){
    v<-v+(P1[i]*(1-P1[i]))^2*X[i,]%*%vcov(logitreg)%*%t(X[i,])
    v1<-v+(P2[i]*(1-P2[i]))^2*Xs[i,]%*%vcov(logitreg1)%*%t(Xs[i,])
  }

  PredCI[k,1]<-mean(P1)-qnorm(0.975)*sqrt(mean(varbeta)/n[k])
  PredCI[k,2]<-mean(P1)+qnorm(0.975)*sqrt(mean(varbeta)/n[k])
  PredCI[k,3]<-1-PredCI[k,2]
  PredCI[k,4]<-1-PredCI[k,1]
  PredCI1[k,1]<-mean(P2)-qnorm(0.975)*sqrt(mean(varbeta1)/n[k])
  PredCI1[k,2]<-mean(P2)+qnorm(0.975)*sqrt(mean(varbeta1)/n[k])
  PredCI1[k,3]<-1-PredCI1[k,2]
  PredCI1[k,4]<-1-PredCI1[k,1]
  # Q8.2 Bootstrap prediction CI
  xStar<-NULL
  xStar1<-NULL
  for (boot in 1:500){
    BS.sample<-sample(P1,n[k],replace=TRUE)
    xStar[boot]<-mean(BS.sample)
    BS.sample1<-sample(P2,n[k],replace=TRUE)
    xStar1[boot]<-mean(BS.sample)
  }
  BSCI[k,1]<-mean(xStar)-qnorm(0.975)*sd(xStar)
  BSCI[k,2]<-mean(xStar)+qnorm(0.975)*sd(xStar)
  BSCI[k,3]<-mean(1-xStar)-qnorm(0.975)*sd(1-xStar)
  BSCI[k,4]<-mean(1-xStar)+qnorm(0.975)*sd(1-xStar)
  BSCI1[k,1]<-mean(xStar1)-qnorm(0.975)*sd(xStar1)
  BSCI1[k,2]<-mean(xStar1)+qnorm(0.975)*sd(xStar1)
  BSCI1[k,3]<-mean(1-xStar1)-qnorm(0.975)*sd(1-xStar1)
  BSCI1[k,4]<-mean(1-xStar1)+qnorm(0.975)*sd(1-xStar1)
  #Q9
  subPoName<-subdata12[subdata12[,2]==StateName[k],5]
  subWeight<-rep(0,NOpolls)
  for (f in 1:NOpolls){
    subWeight[f]<-PollWeight[PollWeight[,1]==subPoName[f],2]
  }
  W.P1<-P1*subWeight/sum(subWeight)
  W.P2<-P2*subWeight/sum(subWeight)
  W.P1.C<-(1-P1)*subWeight/sum(subWeight)
  W.P2.C<-(1-P2)*subWeight/sum(subWeight)
  S.Pred[k,1]<-sum(W.P1)
  S.Pred[k,2]<-sum(W.P1.C)
  S.Pred[k,3]<-sum(W.P2)
  S.Pred[k,4]<-sum(W.P2.C)
}
#Q6
Pred
#Q7
Pred1
results2012[results2012[,1]%in%StateName,]
#Q8
PredCI
PredCI1
BSCI
BSCI1
#Q9
S.Pred


power.test = function(params, pi.0.true, myseed=567, dist = "binorm",
                      simreps = 100, r.vec = c(.01, .1, .5), metric = "k",
                      m = 100, plus = T, pool, method = "AH",
                      rho, s.vec.ls = list(c(1, 1), c(1, 1))) {

  eff_seeds <- sample(1:2^15, simreps)
  results <- foreach(z = 1:simreps, .export=c("normalCopula", "mvdc", "rMvdc", "PerfCurveTest", "mvrnorm", "EstLambda")) %dopar% {
    set.seed(eff_seeds[z])
    X = rbinom(n=m, size=1, prob=pi.0.true)
    if (sum(X)==0) X = rbinom(n=m, size=1, prob=pi.0.true)
    if(dist == "binorm") {
      # Target parameters for univariate normal distributions
      # Parameters for bivariate normal distribution
      s1 <- s.vec.ls[[1]][1] ; s2 <- s.vec.ls[[2]][1];
      sigma1 <- matrix(c(s1^2, s1*s2*rho, s1*s2*rho, s2^2), 2)
      s1 <- s.vec.ls[[1]][2]; s2 <- s.vec.ls[[2]][2];
      sigma2 <- matrix(c(s1^2, s1*s2*rho, s1*s2*rho, s2^2), 2)# Covariance matrix
      bvn1 <- mvrnorm(m, mu = c(params[[1]][1], params[[2]][1]), Sigma = sigma1)*X + mvrnorm(m, mu = c(params[[1]][2], params[[2]][2]), Sigma = sigma2)*(1-X)
      S1 <- bvn1[, 1]
      S2 <- bvn1[, 2]
    } else if(dist == "bibeta") {
      myCopPlus <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdPlus <- mvdc(copula=myCopPlus, margins=c("beta", "beta"),
                        paramMargins=list(list(shape1=params[[1]][[1]][1], shape2=params[[1]][[1]][2]),
                                          list(shape1=params[[2]][[1]][1], shape2=params[[2]][[1]][2])))
      myCopNeg <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdNeg <- mvdc(copula=myCopNeg, margins=c("beta", "beta"),
                       paramMargins=list(list(shape1=params[[1]][[2]][1], shape2=params[[1]][[2]][2]),
                                         list(shape1=params[[2]][[2]][1], shape2=params[[2]][[2]][2])))

      bvn1 <- rMvdc(m, myMvdPlus)*X + rMvdc(m, myMvdNeg)*(1-X)
      S1 <- bvn1[, 1]
      S2 <- bvn1[, 2]
    } else if(dist == "unif") {
      myCopPlus <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdPlus <- mvdc(copula=myCopPlus, margins=c("unif", "unif"),
                        paramMargins=list(list(min=params[[1]][[1]][1], max=params[[1]][[1]][2]),
                                          list(min=params[[2]][[1]][1], max=params[[2]][[1]][2])))
      myCopNeg <- normalCopula(param=c(rho), dim = 2, dispstr = "un")
      myMvdNeg <- mvdc(copula=myCopNeg, margins=c("unif", "unif"),
                       paramMargins=list(list(min=params[[1]][[2]][1], max=params[[1]][[2]][2]),
                                         list(min=params[[2]][[2]][1], max=params[[2]][[2]][2])))

      bvn1 <- rMvdc(m, myMvdPlus)*X + rMvdc(m, myMvdNeg)*(1-X)
      S1 <- bvn1[, 1]
      S2 <- bvn1[, 2]
    }

    PerfCurveTest(S1, S2, X, r = r.vec, metric = "rec", method = method, plus = plus, pool = pool, alpha = .05, seed = eff_seeds[z])
  }

  sr <- length(results)
  covout <- matrix(NA, nrow=length(r.vec), ncol=sr)
  widthout <- matrix(NA, nrow=length(r.vec), ncol=sr)
  interval.ls <- list()

  for (i in 1:sr) {
    covout[, i] <- results[[i]]$p_value < .05
    widthout[, i] <- results[[i]]$ci_interval[, 2] - results[[i]]$ci_interval[, 1]
    interval.ls[[i]] <- results[[i]]$ci_interval
  }

  return(list(r = r.vec, covout = covout, widthout = widthout, interval.ls = interval.ls, params = params, eff_seeds))

}


# 4. faza: Analiza podatkov
library(ggplot2)
library(GGally)
library(mgcv)
library(ggpubr)

#NAPOVED BREZPOSELNOSTI VISJESOLSKA
tabela.preciscena1 <- brezposelnost_izobrazba %>% filter(izobrazba =="Visjesolska, visokosolska")
tabela.preciscena1$izobrazba <- NULL
star <- lm(data=tabela.preciscena1, stevilo ~ leta)

model1 <- ggplot(tabela.preciscena1) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  geom_point() +
  ggtitle("višješolska ali visokošolska \nizobrazba") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki1 <- data.frame(leta = seq(2018, 2022))
napoved1 <- novi.podatki1 %>% mutate(stevilo=predict(star, .))
model1 <- model1 + geom_point(data=napoved1, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks = seq(2008,2022, 3))

#BREZ IZOBRAZBE
tabela.preciscena2 <- brezposelnost_izobrazba %>% filter(izobrazba =="Brez izobrazbe")
tabela.preciscena2$izobrazba <- NULL
star2 <- lm(data=tabela.preciscena2, stevilo ~ leta)

model2 <- ggplot(tabela.preciscena2) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  geom_point() +
  ggtitle("brez izobrazbe") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki2 <- data.frame(leta = seq(2018, 2022, 1))
napoved2 <- novi.podatki2 %>% mutate(stevilo=predict(star2, .))
model2 <- model2 + geom_point(data=napoved2, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3)) + scale_y_continuous(breaks = 0:2)

#OSNOVNOSOLSKA
tabela.preciscena3 <- brezposelnost_izobrazba %>% filter(izobrazba =="Osnovnosolska")
tabela.preciscena3$izobrazba <- NULL
star3 <- lm(data=tabela.preciscena3, stevilo ~ leta)

model3 <- ggplot(tabela.preciscena3) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_point() +
  ggtitle("osnovnošolska \nizobrazba") +
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki3 <- data.frame(leta = seq(2018, 2022, 1))
napoved3 <- novi.podatki3 %>% mutate(stevilo=predict(star3, .))
model3 <- model3 + geom_point(data=napoved3, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3))

#NIZJA ALI SREDNJA POKLICNA
tabela.preciscena4 <- brezposelnost_izobrazba %>% filter(izobrazba =="Nizja ali srednja poklicna")
tabela.preciscena4$izobrazba <- NULL
star4 <- lm(data=tabela.preciscena4, stevilo ~ leta)

model4 <- ggplot(tabela.preciscena4) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  geom_point() +
  ggtitle("nižja ali srednja \npoklicna izobrazba") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki4 <- data.frame(leta = seq(2018, 2022, 1))
napoved4 <- novi.podatki4 %>% mutate(stevilo=predict(star4, .))
model4 <- model4 + geom_point(data=napoved4, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3))

#SREDNJA STROKOVNA, SPOLOSNA
tabela.preciscena5 <- brezposelnost_izobrazba %>% filter(izobrazba =="Srednja strokovna, splosna")
tabela.preciscena5$izobrazba <- NULL
star5 <- lm(data=tabela.preciscena5, stevilo ~ leta)

model5 <- ggplot(tabela.preciscena5) +
  aes(x=leta, y=stevilo) +
  ylab("število brezposelnih") +
  theme(plot.title = element_text(size = 10, face = "bold", hjust=0.5))+
  geom_point() +
  ggtitle("srednja strokovna ali \nsplošna izobrazba") +
  geom_smooth(method="lm", formula = y ~ x, fullrange = TRUE, se = FALSE)
novi.podatki5 <- data.frame(leta = seq(2018, 2022, 1))
napoved5 <- novi.podatki5 %>% mutate(stevilo=predict(star5, .))
model5 <- model5 + geom_point(data=napoved5, aes(x=leta, y=stevilo), color="red") +
  scale_x_continuous(breaks =  seq(2008,2022, 3))

skupaj <- ggarrange(model2, model3, model4, model5, model1)


data = read.csv(file.choose(), header = T, sep = ',')

attach(data)
summary(data)
head(data)
#------------------------------A ZADATAK------------------------------
# a)	Opišite varijable statističkog skupa i grafički ih prikažite.
# Izračunajte korelacije između kvantitativnih varijabli i grafički ih prikažite.

#Clear packages
p_unload(all)
detach("package:datasets", unload = TRUE) #for base

install.packages("ggpubr")
install.packages("pacman")
require(pacman)
pacman::p_load(pacmam, dplyr, GGally, ggplot2, ggthemes, ggvis, httr, lubridate,
               plotly, rio, rmarkdown, shiny, stringr, tidyr)
library(datasets)

head(data)
install.packages("psych")
#install.packages("mnormt")
p_load(psych)

#Graficki prikazi - kvalitativne

distinct(.data = data, Country, .keep_all = FALSE) #popis država
count<-distinct(.data = data, Status, .keep_all = FALSE)

plot(data$Year, data$Life.expectancy, xlab = "Godina", ylab = "Očekivani životni vijek")
plot(data$BMI, data$Life.expectancy, xlab = "BMI", ylab = "Očekivani životni vijek")
plot(data$Status, data$Life.expectancy, xlab = "Status", ylab = "Očekivani životni vijek")
plot(data$percentage.expenditure, data$infant.deaths, xlab = "Postotni izdaci za zdravstvo", ylab = "Broj umrlih novorođenčadi")
plot(data$Year, data$infant.deaths, xlab = "Postotni izdaci za zdravstvo", ylab = "Broj umrlih novorođenčadi")
plot(data$Alcohol, data$Adult.Mortality, xlab = "alk", ylab = "ODrasli")
plot(data$Schooling, data$Alcohol, xlab = "alk", ylab = "ODrasli")
hist(data$BMI)
hist(data$Hepatitis.B)
hist(data$Schooling, main = "Histogram godina obrazovanja", xlab = "Godine obrazovanja", ylab = "Frekvencija")
hist(data$thinness.5.9.years, main = "Histogram mršavosti djece od 5-9 godina", xlab = "Postotak mršavosti", ylab = "Frekvencija")
hist(data$thinness..1.19.years, main = "Histogram mršavosti djece od 1-19 godina", xlab = "Postotak mršavosti", ylab = "Frekvencija")
hist(data$Polio, main = "Histogram imunizacije dječje paralize  kod jednogodišnjaka", xlab = "Postotak imunizacije dječje paralize", ylab = "Frekvencija")
hist(data$Measles, main = "Histogram prijavljenih slučajeva ospica", xlab = "Broj prijavljenih slučajeva na 1000 stanovnika", ylab = "Frekvencija")
hist(data$Adult.Mortality, main = "Histogram smrtnosti odraslih osoba", xlab = "Broj smrtnih slučajeva na 1000 stanovnika", ylab = "Frekvencija")
hist(data$BMI, main = "Histogram indeksa tjelesne mase", xlab = "Prosječni BMI cjelokupne populacije", ylab = "Frekvencija")
hist(data$under.five.deaths, main = "Histogram broja umrlih ispod pet godina", xlab = "broj umrlih ispod pet godina na 1000 stanovnika", ylab = "Frekvencija")
hist(data$Total.expenditure, main = "Histogram općih državnih izdataka za zdravstvo ", xlab = "Opći državni izdaci za zdravstvo u postotku od ukupnih državnih izdataka (%)", ylab = "Frekvencija")
hist(data$Diphtheria, main = "Histogram pokrivenosti imunizacijom difterijskog tetanusa (DTP3) kod jednogodišnjaka", xlab = "Postotak imunizacije", ylab = "Frekvencija")
hist(data$HIV.AIDS, main = "HIV/AIDS", xlab = "Broj smrti od HIV / AIDS na 1000 osoba (0-4 godine)", ylab = "Frekvencija")
hist(data$GDP, main = "Histogram BDP-a", xlab = "Bruto domaći proizvod po glavi stanovnika, izražen u USD", ylab = "Frekvencija")
hist(data$Income.composition.of.resources, main = "Histogram sastava dohotka", xlab = "Indeks ljudskog razvoja s obzirom na sastav dohotka resursa (indeks se kreće od 0 do 1)", ylab = "Frekvencija")
hist(data$Hepatitis.B, main = "Histogram imunizacije hepatitisa B", xlab = "Pokrivenost imunizacijom protiv hepatitisa B (HepB) kod jednogodišnjaka (%)", ylab = "Frekvencija")
hist(data$percentage.expenditure, main = "Histogram postotnih izdataka za zdravstvo", xlab = "Izdaci za zdravstvo u postotku bruto domaćeg proizvoda po glavi stanovnika (%)", ylab = "Frekvencija")
hist(data$Life.expectancy, main = "Histogram očekivanog životnog vijeka", xlab = "Godina", ylab = "Frekvencija")
hist(data$infant.deaths, main = "Histogram broja umrle novorođenčadi", xlab = "Broj umrle novorođenčadi na 1000 djece", ylab = "Frekvencija")
hist(data$Alcohol, main = "Histogram alkohola", xlab = "Zabilježen po glavi stanovnika (15+), izražen u litrama čistog alkohola", ylab = "Frekvencija")
hist(data$Year, main = "Histogram alkohola", xlab = "Zabilježen po glavi stanovnika (15+), izražen u litrama čistog alkohola", ylab = "Frekvencija")

#-----------------------------KORELACIJE-----------------------------
head(data)
library("ggpubr")
ggscatter(data, x = "BMI", y = "Life.expectancy",
          add = "reg.line", conf.int = TRUE,
          cor.coef = TRUE, cor.method = "pearson",
          xlab = "Indeks tjelesne mase", ylab = "Očekivani životni vijek u godinama")

# Shapiro-Wilk normality test
shapiro.test(data$BMI) #p-value < 2.2e-16
# Shapiro-Wilk normality test
shapiro.test(data$Life.expectancy) #p-value < 2.2e-16
#podaci nisu normalno distribuirani

plot(data$BMI, data$Life.expectancy)

library("ggpubr")
ggqqplot(data$BMI, xlab = "Teoretska", ylab = "Indeks tjelesne mase")
ggqqplot(data$Life.expectancy, xlab = "Teoretska",ylab = "Očekivani životni vijek")
qqnorm(data$BMI, xlab = "Teoretska", ylab = "Indeks tjelesne mase")
qqline(data$BMI)
qqnorm(data$Life.expectancy)
qqline(data$Life.expectancy)

res <- cor.test(data$BMI, data$Life.expectancy,
                method = "pearson")
res

res2 <-cor.test(data$BMI, data$Life.expectancy,  method = "spearman")
res2

# select variables
myvars <- c("Year", "Life.expectancy", "Adult.Mortality", "infant.deaths", "Alcohol", "percentage.expenditure",
            "Hepatitis.B", "Measles", "BMI", "under.five.deaths", "Polio", "Total.expenditure", "Diphtheria",
            "HIV.AIDS", "GDP", "Population", "thinness..1.19.years", "thinness.5.9.years",
            "Income.composition.of.resources", "Schooling")
dataKorelacija <- data[myvars]
res3 <- cor(dataKorelacija, use = "complete.obs")
round(res3, 2)

install.packages("Hmisc")
library("Hmisc")
#res2 <- rcorr(as.matrix(dataKorelacija), type = c("pearson","spearman"))
res2 <- rcorr(as.matrix(dataKorelacija), type = c("pearson"))
res2$P
res2$r
res2

install.packages("corrplot")
library(corrplot)
corrplot(res3, type = "upper", order = "hclust",
         tl.col = "black", tl.srt = 65)

cor(dataKorelacija, method = "pearson", use = "complete.obs")

par(mfrow=c(2,1))
hist(data$BMI [data$Year == "2015"],
     breaks = 9,
     xlim = c(0, 3),
     main = "histogram",
     xlab = "",
     col = "red")

count<-table(data$Country)
count
postotci<-round(100*count/dim(Podaci)[1],2)
barplot(count)
pie(count)
barplot(postotci)
barplot(postotci, main="Struktura po državama", xlab = "Country", ylab = "%", las=1)
pie(count, main = "Struktura po državama")
box()
plot(data$Country)
plot(data$Status) #
data %>% distinct(Country)

#Graficki prikazi - kvantitativne varijable

psych::describe(Podaci$Life.expectancy)
psych::describe(Podaci$BMI)

#Korelacije
cor.test(data$Life.expectancy, data$Alcohol)

#------------------------------B ZADATAK------------------------------
# b)	Temeljem kvantitativnih varijabli Number of years schooling i Average Body mass index of entire population (BMI) definirajte nove varijable na sljedeći način

NumberOfYearsSchooling <- cut(data$Schooling, breaks=c(0, 8, 12, 22),
                              labels=c(0, 1, 2), as.factor.result=TRUE)

#Schooling[1:20]
#NumberOfYearsSchooling[1:20]

data1 = cbind(data, NumberOfYearsSchooling)
detach(data)
attach(data1)

BMIqualitative <- cut(data1$BMI, breaks=c(0,15,16,18.5,25,30,40,100),
                      labels = c("vrlo jaka pothranjenost", "jaka pothranjenost",
                                 "umjerena pothranjenost", "normalna težina",
                                 "umjerena pretilost", "jaka pretilost",
                                 "vrlo jaka pretilost"))

#BMI[0:10]
#BMIqualitative[0:10]

data2 = cbind(data1, BMIqualitative)
detach(data1)
attach(data2)

dataFinal <- data2[complete.cases(data2),]
detach(data2)
attach(dataFinal)

plot(NumberOfYearsSchooling, main = "Kvalitativna varijabla Number Of Years Schooling", xlab = "")
plot(BMIqualitative, main = "Kvalitativna varijabla BMI")

#------------------------------C ZADATAK------------------------------
# c)	Opišite novodobivene varijable statističkog skupa i grafički ih prikažite.

plot(NumberOfYearsSchooling, main = "Kvalitativna varijabla Number Of Years Schooling", xlab ="")
pie(NumberOfYearsSchooling, main = "Kvalitativna varijabla Number Of Years Schooling", xlab = "")
plot(BMIqualitative, main = "Kvalitativna varijabla BMI")
pie(BMIqualitative, main = "Kvalitativna varijabla BMI")

#------------------------------D ZADATAK------------------------------
# d)	Korištenjem hi-kvadrat testa ispitajte postoji li povezanost kvalitativnih statističkih varijabli
#       Number of years schooling kvalitativna i BMI kvalitativna.
head(dataFinal)
NumberOfYearsSchooling = as.factor(NumberOfYearsSchooling)
BMIqualitative = as.factor(BMIqualitative)

tab <- table(NumberOfYearsSchooling, BMIqualitative)
tab
barplot(tab, beside = T, legend = T)

CTest <- chisq.test(tab, correct = TRUE)
CTest

detach(dataFinal)

#------------------------------E ZADATAK------------------------------
# e)	Korištenjem hi-kvadrat testa ispitajte postoji li povezanost kvalitativnih statističkih varijabli
#       Status (Developed/Developing) i BMI kvalitativna.
remove(CTest)
remove(tab)
dataFinal$Status=as.factor(Status)

tab <- table(Status, dataFinal$BMIqualitative)
tab

length(dataFinal$Status)
length(dataFinal$BMIqualitative)

barplot(tab, beside = T, legend = T)

CTest <- chisq.test(tab, correct = TRUE)
CTest

#------------------------------F ZADATAK------------------------------

#f)	Korištenjem odgovarajućeg parametarskog i neparametarskog testa
#ispitajte postoje li razlike varijable Life expectancy in years  po
#razinama (modalitetima)  varijable Number of years schooling kvalitativna.
#Za provedbu parametarskog testa ispitajte pretpostavke za provedbu.
#Ukoliko se korištenjem parametarskog testa utvrdi da postoje
#signifikantne razlike provedite i post hoc test.

#Parametarski test - ANOVA jednofaktorska

#Provjera pretpostavki za provedbu ANOVE

NumberOfYearsSchooling0 <- subset(dataFinal, subset = NumberOfYearsSchooling==0)
NumberOfYearsSchooling1 <- subset(dataFinal, subset = NumberOfYearsSchooling==1)
NumberOfYearsSchooling2 <- subset(dataFinal, subset = NumberOfYearsSchooling==2)

shapiro.test(NumberOfYearsSchooling0$Life.expectancy)
shapiro.test(NumberOfYearsSchooling1$Life.expectancy)
shapiro.test(NumberOfYearsSchooling2$Life.expectancy)

tapply(dataFinal$Life.expectancy, dataFinal$NumberOfYearsSchooling, var)
bartlett.test(Life.expectancy ~ NumberOfYearsSchooling, data=dataFinal)
library(car)
leveneTest(dataFinal$Life.expectancy, dataFinal$NumberOfYearsSchooling, center = mean)

#ANOVA
boxplot(Life.expectancy ~ NumberOfYearsSchooling, data=dataFinal,
        xlab = "Number of years schooling", ylab="Life expectancy", las=1)
tapply(dataFinal$Life.expectancy, dataFinal$NumberOfYearsSchooling, mean)
tapply(dataFinal$Life.expectancy, dataFinal$NumberOfYearsSchooling, sd)

AnovaModel1 <- aov(Life.expectancy ~ NumberOfYearsSchooling, data=dataFinal)
summary(AnovaModel1)

#Među kojim grupama postoji signifikantna razlika?

TukeyHSD(AnovaModel1)
library(multcomp)
.Pairs <- glht(AnovaModel1, linfct = mcp(NumberOfYearsSchooling = "Tukey"))
summary(.Pairs)
confint(.Pairs)
cld(.Pairs)
plot(confint(.Pairs))

#Neparametarski test: Kruskal-Wallisov test
kruskal.test(Life.expectancy ~ NumberOfYearsSchooling, data=dataFinal)

#ZAKLJUČAK: POSTOJE SIGNIFIKANTNE RAZLIKE IZMEĐU GRUPA - provedeni su
#post hoc testovi (Tukey)

#------------------------------G ZADATAK------------------------------

#g)	Korištenjem odgovarajućeg parametarskog i neparametarskog testa
#ispitajte postoje li razlike varijable Life expectancy in years  po
#razinama (modalitetima)  varijable BMI kvalitativna. Za provedbu
#parametarskog testa ispitajte pretpostavke za provedbu. Ukoliko se
#korištenjem parametarskog testa utvrdi da postoje signifikantne razlike
#provedite i post hoc test.

#Provjera pretpostavki za provedbu ANOVE

BMI0 <- subset(dataFinal, subset = BMIqualitative=="vrlo jaka pothranjenost")
BMI1 <- subset(dataFinal, subset = BMIqualitative=="jaka pothranjenost")
BMI2 <- subset(dataFinal, subset = BMIqualitative=="umjerena pothranjenost")
BMI3 <- subset(dataFinal, subset = BMIqualitative=="normalna težina")
BMI4 <- subset(dataFinal, subset = BMIqualitative=="umjerena pretilost")
BMI5 <- subset(dataFinal, subset = BMIqualitative=="jaka pretilost")
BMI6 <- subset(dataFinal, subset = BMIqualitative=="vrlo jaka pretilost")

shapiro.test(BMI0$Life.expectancy)
shapiro.test(BMI1$Life.expectancy)
shapiro.test(BMI2$Life.expectancy)
shapiro.test(BMI3$Life.expectancy)
shapiro.test(BMI4$Life.expectancy)
shapiro.test(BMI5$Life.expectancy)
shapiro.test(BMI6$Life.expectancy)

tapply(dataFinal$Life.expectancy, dataFinal$BMIqualitative, var)
bartlett.test(Life.expectancy ~ BMIqualitative, data=dataFinal)
library(car)
leveneTest(dataFinal$Life.expectancy, dataFinal$BMIqualitative, center = mean)

#ANOVA
boxplot(Life.expectancy ~ BMIqualitative, data=dataFinal,
        xlab = "BMI value", ylab="Life expectancy", las=1)
tapply(dataFinal$Life.expectancy, dataFinal$BMIqualitative, mean)
tapply(dataFinal$Life.expectancy, dataFinal$BMIqualitative, sd)

AnovaModel2 <- aov(Life.expectancy ~ BMIqualitative, data=dataFinal)
summary(AnovaModel2)

#Među kojim grupama postoji signifikantna razlika?

TukeyHSD(AnovaModel2)
library(multcomp)
.Pairs <- glht(AnovaModel2, linfct = mcp(BMIqualitative = "Tukey"))
summary(.Pairs)
confint(.Pairs)
cld(.Pairs)
plot(confint(.Pairs))

#Neparametarski test: Kruskal-Wallisov test
kruskal.test(Life.expectancy ~ BMIqualitative, data=dataFinal)

#ZAKLJUČAK: POSTOJE SIGNIFIKANTNE RAZLIKE IZMEĐU GRUPA - provedeni su
#post hoc testovi (Tukey)

#------------------------------G ZADATAK------------------------------

#g)	Korištenjem odgovarajućeg parametarskog i neparametarskog testa
#ispitajte postoje li razlike varijable Life expectancy in years  po
#razinama (modalitetima)  varijable BMI kvalitativna. Za provedbu
#parametarskog testa ispitajte pretpostavke za provedbu. Ukoliko se
#korištenjem parametarskog testa utvrdi da postoje signifikantne razlike
#provedite i post hoc test.

#Provjera pretpostavki za provedbu ANOVE

BMI0 <- subset(dataFinal, subset = BMIqualitative=="vrlo jaka pothranjenost")
BMI1 <- subset(dataFinal, subset = BMIqualitative=="jaka pothranjenost")
BMI2 <- subset(dataFinal, subset = BMIqualitative=="umjerena pothranjenost")
BMI3 <- subset(dataFinal, subset = BMIqualitative=="normalna težina")
BMI4 <- subset(dataFinal, subset = BMIqualitative=="umjerena pretilost")
BMI5 <- subset(dataFinal, subset = BMIqualitative=="jaka pretilost")
BMI6 <- subset(dataFinal, subset = BMIqualitative=="vrlo jaka pretilost")

shapiro.test(BMI0$Life.expectancy)
shapiro.test(BMI1$Life.expectancy)
shapiro.test(BMI2$Life.expectancy)
shapiro.test(BMI3$Life.expectancy)
shapiro.test(BMI4$Life.expectancy)
shapiro.test(BMI5$Life.expectancy)
shapiro.test(BMI6$Life.expectancy)

tapply(dataFinal$Life.expectancy, dataFinal$BMIqualitative, var)
bartlett.test(Life.expectancy ~ BMIqualitative, data=dataFinal)
library(car)
leveneTest(dataFinal$Life.expectancy, dataFinal$BMIqualitative, center = mean)

#ANOVA
boxplot(Life.expectancy ~ BMIqualitative, data=dataFinal,
        xlab = "BMI value", ylab="Life expectancy", las=1)
tapply(dataFinal$Life.expectancy, dataFinal$BMIqualitative, mean)
tapply(dataFinal$Life.expectancy, dataFinal$BMIqualitative, sd)

AnovaModel2 <- aov(Life.expectancy ~ BMIqualitative, data=dataFinal)
summary(AnovaModel2)

#Među kojim grupama postoji signifikantna razlika?

TukeyHSD(AnovaModel2)
library(multcomp)
.Pairs <- glht(AnovaModel2, linfct = mcp(BMIqualitative = "Tukey"))
summary(.Pairs)
confint(.Pairs)
cld(.Pairs)
plot(confint(.Pairs))

#Neparametarski test: Kruskal-Wallisov test
kruskal.test(Life.expectancy ~ BMIqualitative, data=dataFinal)

#ZAKLJUČAK: POSTOJE SIGNIFIKANTNE RAZLIKE IZMEĐU GRUPA - provedeni su
#post hoc testovi (Tukey)

#------------------------------H ZADATAK------------------------------

#Korištenjem dvofaktorske analize varijace ispitajte postoje li
#signifikantne razlike  varijable Life expectancy in years
#po tretmanima varijabli Status i Number of years schooling kvalitativna.

library(multcomp)

dataFinal$Status = as.factor(dataFinal$Status)

## Provedba dvofaktorske ANOVE

AnovaModel <- (lm(Life.expectancy ~ Status * dataFinal$NumberOfYearsSchooling))
Anova(AnovaModel)

library(RcmdrMisc)

plotMeans(Life.expectancy, dataFinal$NumberOfYearsSchooling, error.bars = 'conf.int')

#------------------------------I ZADATAK------------------------------

#Korištenjem odgovarajućeg parametarskog i neparametarskog testa
#ispitajte postoje li razlike varijable Life expectancy in years
#po razinama (modalitetima)  varijable Status.
#Za provedbu parametarskog testa ispitajte pretpostavke za provedbu.

## Neparametarski test

tapply(Life.expectancy, Status, median)
wilcox.test(Life.expectancy ~ Status, alternative = 'greater')

## Ispitivanje normalnosti po grupama

status_developed = dataFinal[Status == 'Developed',]
status_developing = dataFinal[Status == 'Developing',]

shapiro.test(status_developed$Life.expectancy)
ks.test(status_developed$Life.expectancy, 'pnorm')

shapiro.test(status_developing$Life.expectancy)
ks.test(status_developing$Life.expectancy, 'pnorm')

## Ispitivanje jednakosti varijanci

tapply(Life.expectancy, Status, var)

var.test(Life.expectancy ~ Status, alternative = 'two.sided', conf.level = .95)
bartlett.test(Life.expectancy ~ Status)

library(car)
leveneTest(Life.expectancy, Status, center = mean)

#------------------------------J ZADATAK------------------------------

#Provedite regresijsku analizu kod koje će zavisna varijabla biti Life expectancy in years,
#a nezavisne sve ostale kvantitativne varijable.
#Komentirajte parametre regresije: koeficijent determinacije i korigirani koeficijent determinacije.
#Interpretirajte skupni i pojedinačne testove signifikantnosti regresije za svaku
#od promatranih nezavisnih varijabli. Komentirajte rezultate regresije.
#Provedite izbor varijabli koristeći neku od metoda
#za izbor varijabli  (Forward Selection Procedure, Backward Selection Procedure, Backward/Forward).
#Nacrtajte normalni prikaz rezidualnih vrijednosti.

## Računanje regresijskog modela: sve grane

RegModelLifeExpectancy <- lm(Life.expectancy ~ Adult.Mortality + infant.deaths + Alcohol + percentage.expenditure + Hepatitis.B + Measles + BMI + under.five.deaths + Polio + Total.expenditure + Diphtheria + HIV.AIDS + GDP + Population + thinness..1.19.years + thinness.5.9.years + Income.composition.of.resources + Schooling, data = dataFinal)
summary(RegModelLifeExpectancy)

## fitted vs residuals
#plot(RegModelLifeExpectancy, which = 1, pch = 20, lwd = 2, font = 2, font.lab = 2, font.sub = 2, las = 1)

## qqplot
plot(RegModelLifeExpectancy, which = 2, pch = 20, lwd = 2, font = 2, font.lab = 2, font.sub = 2, las = 1)
shapiro.test(residuals(RegModelLifeExpectancy))

## Izbor varijabli: sve varijable

library(MASS)
step <- stepAIC(RegModelLifeExpectancy, direction = 'both')


LDx.core = function ( obj, cf=c(1,2), p=0.5, method="default", covars=NULL ) {

   # print( "Expecting: y ~ aX + bT + cU + dXT + eXU ..." )
   # print( "Order of terms is important: main effects first, then first order effects")
   # print( "Where X is the variable of interest ... dose, size, date, etc)" )
   # print( "When there are interaction terms, the first interaction term must be the second main effect" )

    # modified from MASS::dose.p
    # cf = indices of vars of interest (intercept, xvar):
    #   default :: no interaction terms

    eta <- family(obj)$linkfun(p)  #logit at associated Prob
    a <- coef(obj)
    out = NULL

    if (method == "default" ) {
      # identicle to MASS::dose.p
      x.p <- (eta - a[1])/a[2]
      pd <- -cbind(1, x.p)/a[cf[2]]
      SD <- sqrt(((pd %*% vcov(obj)[cf, cf]) * pd) %*% c(1, 1))
    }

    if (method == "2main.0interaction" ) {
      # Solve[ 0  == eta - (a1 + a2*X + a3*T ), X] ;  x = main factor of interest
      T = covars
      x.p = (eta -  a[1] - a[3]* T)/  a[2]
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2]
      dy1 = - 1/Q     # partial derivative wrt a[1] -- the intercept... etc
      dy2 = - ( eta - a[1] - a[3]*T )/Q^2
      dy3 = - T / Q
      diag(dy) = c( dy1^2, dy2^2, dy3^2 ) # partial derivatives associated with variances
      dy[1,2:3] = dy1 * c(dy2, dy3 )
      dy[2,3  ] = dy2 * c(dy3 )
      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T ) )

    }

    if (method == "2main.1interaction" ) {
      # Solve[ 0  == eta - (a1 + a2*X + a3*T + a4*X*T), X] ;  x = main factor of interest
      T = covars
      x.p = (eta - a[1] - a[3]* T)/ ( a[2] + a[4]*T)
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[4] * T
      dy1 = - 1/Q     # partial derivative wrt a[1] -- the intercept... etc
      dy2 = - (-a[1] + eta -a[3]*T) / Q^2
      dy3 = - T / Q
      dy4 = - T * (-a[1] + eta -a[3]*T) / Q^2
      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2 ) # partial derivatives associated with variances
      dy[1,2:4] = dy1 * c(dy2, dy3, dy4 )
      dy[2,3:4] = dy2 * c(dy3, dy4 )
      dy[3,4]   = dy3 * c(dy4 )
      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T ) )

    }

    if (method=="3main.0interaction") {
      # Solve[eta == a1 + a2*X + a3*T + a4*U , X] ; x = main factor of interest

      T = covars[1]
      U = covars[2]
      x.p = ( eta -a[1]- a[3]*T - a[4]*U )/ a[2]
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2]
      dy1 = -1/Q
      dy2 = (-a[1] + eta - a[3]*T - a[4] *U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2 ) # partial derivatives associated with variances
      dy[1,2:4] = dy1 * c(dy2, dy3, dy4 )
      dy[2,3:4] = dy2 * c(     dy3, dy4 )
      dy[3,4  ] = dy3 * c(          dy4 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.1interaction") {
      # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T, X] ; x = main factor of interest

      T = covars[1]
      U = covars[2]
      x.p = ( eta -a[1]- a[3]*T - a[4]*U )/ (a[2] + a[5]*T)
      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T
      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U)/Q^2

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2 ) # partial derivatives associated with variances
      dy[1,2:5] = dy1 * c(dy2, dy3, dy4, dy5 )
      dy[2,3:5] = dy2 * c(     dy3, dy4, dy5 )
      dy[3,4:5] = dy3 * c(          dy4, dy5 )
      dy[4,  5] = dy4 * c(               dy5 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.2interaction.12.13") {
       # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T + a6*X*U, X] ; x = main factor of interest

  	  T = covars[1]
      U = covars[2]
      x.p = (eta - a[1] - a[3]*T - a[4]*U) / (a[2] + a[5]*T + a[6]*U)

      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T + a[6]* U

      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U)/Q^2
      dy6 = -U * (-a[1] + eta - a[3]*T - a[4]* U)/Q^2

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2, dy6^2 ) # partial derivatives associated with variances
      dy[1,2:6] = dy1 * c(dy2, dy3, dy4, dy5, dy6 )
      dy[2,3:6] = dy2 * c(     dy3, dy4, dy5, dy6 )
      dy[3,4:6] = dy3 * c(          dy4, dy5, dy6 )
      dy[4,5:6] = dy4 * c(               dy5, dy6 )
      dy[5,  6] = dy5 * c(                    dy6 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.2interaction.12.23") {
       # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T + a6*T*U, X] ; x = main factor of interest

  	  T = covars[1]
      U = covars[2]
      x.p = (eta - a[1] - a[3]*T - a[4]*U - a[6]*T * U) / (a[2] + a[5]*T )

      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T

      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U -a[6]*T*U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U-a[6]*T*U)/Q^2
      dy6 = -U * (-a[1] + eta - a[3]*T - a[4]* U-a[6]*T*U)/Q^2

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2, dy6^2 ) # partial derivatives associated with variances
      dy[1,2:6] = dy1 * c(dy2, dy3, dy4, dy5, dy6 )
      dy[2,3:6] = dy2 * c(     dy3, dy4, dy5, dy6 )
      dy[3,4:6] = dy3 * c(          dy4, dy5, dy6 )
      dy[4,5:6] = dy4 * c(               dy5, dy6 )
      dy[5,  6] = dy5 * c(                    dy6 )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }

    if (method=="3main.3interaction"  ) {
       # Solve[eta == a1 + a2*X + a3*T + a4*U + a5*X*T + a6*X*U + a7*T*U, X] ; x = main factor of interest

  	  T = covars[1]
      U = covars[2]
      x.p = (eta - a[1] - a[3]*T - a[4]*U -  a[7]*T*U) / (a[2] + a[5]*T + a[6]*U)

      vcv =  vcov(obj)
      vcv[lower.tri(vcv)] = 0
      dy = vcv * 0
      Q = a[2] + a[5]*T + a[6]* U

      dy1 = -1/Q
      dy2 = -(-a[1] + eta - a[3]*T - a[4] *U - a[7]*T*U)/Q^2
      dy3 = -T/Q
      dy4 = -U/Q
      dy5 = -T * (-a[1] + eta - a[3]*T - a[4]* U - a[7]*T*U)/Q^2
      dy6 = -U * (-a[1] + eta - a[3]*T - a[4]* U - a[7]*T*U)/Q^2
      dy7 = - T * U  / Q

      diag(dy) = c( dy1^2, dy2^2, dy3^2, dy4^2, dy5^2, dy6^2, dy7^2 ) # partial derivatives associated with variances
      dy[1,2:7] = dy1 * c(dy2, dy3, dy4, dy5, dy6, dy7 )
      dy[2,3:7] = dy2 * c(     dy3, dy4, dy5, dy6, dy7  )
      dy[3,4:7] = dy3 * c(          dy4, dy5, dy6, dy7  )
      dy[4,5:7] = dy4 * c(               dy5, dy6, dy7  )
      dy[5,6:7] = dy5 * c(                    dy6, dy7  )
      dy[6,  7] = dy6 * c(                         dy7  )

      SD <- sqrt( sum(dy * vcv) )
      out <- data.frame(cbind( p=p, dose=x.p, SD=SD, Cov1=T, Cov2=U ) )

    }
    rownames(out) = NULL
    return(out)
}


library(MASS)
ip <- read.csv('scientificNames-eudex-ip.csv', header = TRUE, sep = ',', quote = '', dec = '.', check.names = FALSE)
ipDist <- dist(ip[,2:9], method = 'manhattan')
mds <- isoMDS(ipDist, cmdscale(ipDist, k = 8), k = 8, maxit = 50)
mds
np <- read.csv('scientificNames-eudex-np.csv', header = TRUE, sep = ',', quote = '', dec = '.', check.names = FALSE)
npDist <- dist(unique(np[,2:9]), method = 'manhattan')
mds <- isoMDS(npDist, cmdscale(npDist, k = 8), k = 8, maxit = 50)
mds


##
## A mechanistic combined toxicokinetic–toxicodynamic (TK/TD) and growth
## model for the aquatic macrophytes Lemna spp. as published by
## Schmitt et al. (2013), DOI: 10.1016/j.ecolmodel.2013.01.017
##
## Parts of the implementation were commented out for reasons of brevity.
##

#
# options(warn=-1)
#
# #********** Control of calculation *********************************************
# # Simulation name  (will be used for naming output files !!!)
# Simname = 'Test'
#
# # Working directory
# workdir = 'C:/Users/zfwsm/Documents/4_R Projects/Lemna Model/Growth model_official'
#
# # F i l e s to be loaded
# # Name ='' for unused files
# Conc_file = 'Peak_2d@t=0.txt'
# Temperature_file = ''
# Irradiation_file = ''
# ##Data_file = 'Data.txt',
#
# # Save results after execution?
# fileout = F       # T=true/F=false
#
# #---- Settings of simulation ---------------------------------------------------
# # Define method to be used
# callfun = 'CS'   # CS = single simulation, DR = Dose response, MC = MC Simulation
# # Set  timepoints for output
# outtimes = seq(0,100,1)
# # DOSE RESPONSE: Define exposure steps/factors (only used for "Dose Response")
# expfact = 10^seq(0,1.5,0.25)
# # MC SIMULATION: Define list of parameters to vary and No of replicates
# MCrep = 100
# parlist = list(
#     parnames=c(
#       'k_G_max',
#       'k_mort',
# #      'Emax',
#       'EC50'),
# #      'b',
# #      'BM50',
# #      'P_up'),
#     pardis=list(
#     c(0.47,0.2,1),
#     c(0.05,0.1,1),
# #    c(1,0,1),
#     c(.48,.1,2))
# #    c(6.4,.1,1),
# #    c(176,.1,1),
# #    c(.3,.2,2))
# )

# Set initial values
vars <- c(
BM       = 50,     # [g_dw/m?]   Dry Biomass dryweight per m2
E        = 1,      # (0-1)      (Toxic) Effect = Factor on growth rate  (Range: 0 - 1, 1=no effect)
M_int    = 0       # [?g]       Amount of toxicant in biomass
)

#---- Parameter Setting --------------------------------------------------------
param <- list(
#
#      - Effect -
Conc     = 1,   #  [any]      Concentration of toxicant (may also be a table)
Emax     = .784,    #   maximum Effect
EC50     = 0.3,     #  [same as conc. data]      Midpoint of effect curve
b        = 4.16,    #  [-]         Slope of effect curve
#
#       - Toxicokinetics -
P_up     = .0054,   # [cm/d]      Permeability for uptake
AperBM   = 1000,   # [cm?/g_dw]   A_leaf / d_leaf = 1/d_leaf (for circular disc, d=0.05 cm) [Ref. HARLAN-022]
Kbm      = .75,   # []          Biomass(fw):water partition coefficient
P_Temp = F,       # Switch for temperature dependence of cuticle permeability
MolWeight = 381,  # Molmass of molecule (determines Q10_permeability)

#       - Fate of biomass -
k_phot_fix  = F,   #  T/F          If True k_G_max is not changed by environmental factors
k_phot_max  = 0.47, #  [1/d]       Maximum growth rate of biomass + kmort     [Ref. F 0191, Harlan-011]
k_resp   = 0.05, #  [1/d]       Rate of mortality                 [Ref. Harlan-011, rough estimate]
k_loss   = 0.0, #  [1/d]       Some rate of loss (e.g. Flow rate)
#
#      - Temperatur dependence -
# k_phot
Temp     = 12,   #  [?C]        Current temperature (may also be a table)
Tmin     = 8.0  , #  [?C]        Minimum growth temperature      [Ref. F 0191, data re-evaluated  incl. kmort(T)]
Tmax     = 40.5 , #  [?C]        Maximum growth temperature      [Ref. F 0191, data re-evaluated  incl. kmort(T)]
Topt     = 26.7 , #  [?C]        Optimum growth temperature      [Ref. F 0191, data re-evaluated  incl. kmort(T)]
# k_resp
t_ref       = 25,   # temperature at which t_mort is effective
Q10         = 2,
#
#      - Light dependence (linear dependence on global radiation (see Hodgeson 1969)
Rad 	    = 15000 , #  [kJ/m?/d]  Radiation  (may also be given as table)
k_0     	= 3 ,     #  [1/d]      Intercept of linear part
a_k     	= 5E-5 ,  #  [(1/d)/(kJ/m?/d)]        Slope of linear part

#      - Phosphorus dependence (Hill like dependence) -
C_P      = 0.3,          #   [mg/L]       Phosporus concentration in water
CP50     = 0.0043,        #   [mg/L]       P-conc. where growth rate is halfened   [Data from L??nd, 1983 evaluated with monod model]
a_P      = 1,        #   []            Hill coefficient
KiP      = 101,         #   [mg/L]       P-inhibition constant for very high P-conc.   [Ref. F 0191]

#      - Nitrogen dependence (Hill like dependence) -
C_N      = 0.6,         #   [mg/L]       Nitrogen concentration in water
CN50     = 0.034,          #   [mg/L]       N-conc. where growth rate is halfened   [Data from L??nd, 1983 evaluated with monod model]
a_N      = 1,        #   []            Hill coefficient
KiN      = 604,         #   [mg/L]       n-inhibition constant for very high P-conc.   [Ref. F 0191]

#      - Density dependence -
BM50     = 176,    #  [g_dw/m?]             Cut off BM   [Ref. F 0191]

#      - Others -
mass_per_frond     = 0.0001,   #  [g_dw/frond]  Dryweight per frond [Ref. HARLAN-022]
BMw2BMd     = 16.7   #  [g_fresh/g_dry]  Fresh- / dryweight [Ref. F 0191]

)

# **************** Call of scripts ********************************************
# +++++++  Do not change the following !!!! +++++++++++++++++++++++++++++++++++

# if (Conc_file!=''){Conc_file = paste(workdir,'/',Conc_file,sep="")}
# if (Temperature_file!=''){Temperature_file = paste(workdir,'/',Temperature_file,sep="")}
# if (Irradiation_file!=''){Irradiation_file = paste(workdir,'/',Irradiation_file,sep="")}
# #Data_file = 'Data.txt',
# filenames = c(
# Conc_file=Conc_file,
# Temperature_file=Temperature_file,
# Irradiation_file=Irradiation_file
# )
#
# # Function to read source files (needs to be defined before first call)
# sourceDir <- function(path, trace = TRUE, ...) {
#    for (nm in list.files(path, pattern = "\\.[RrSsQq]$")) {
#       if(trace) cat(nm,":")
#       source(file.path(path, nm), ...)
#       if(trace) cat("\n")
#     }
#  }
#
# # Read source files
# sourceDir(paste(workdir,'/SourceFun',sep=""))
#
# if (callfun == 'CS'){
# # Call: calcgrowth(timepoints, vars, param, filenames,graph=T)
#   res <- calcgrowth(outtimes, vars, param, filenames,graph=T)
#   if(fileout){write.table(res,paste(Simname,'_out.dat',sep=''))}
# }
#
# if (callfun=='DR'){
# # Call:  dos_resp('growthmodel',doses,eff_frac,t_recov,timepoints,vars,param,filenames,graph=T)
#    dosres <- dos_resp('growthmodel',expfact,0.01,5,outtimes,vars,param,filenames,graph=F)
#    res <- dosres$Popcurves
#
#    if(fileout){
#       write.table(dosres$Popcurves,paste(outname,'_data.dat',sep=""))
#       write.table(dosres$Concentrations,paste(outname,'_conc.dat',sep=""))
#       write.table(dosres$Effects,paste(outname,'_eval.dat',sep=""))
#       }
# }
#
# if(callfun=='MC'){
# # Call:    MCsim(model,parlist,MCrep,simperiod,vars,param,filenames,graph,eff_frac,t_recov)
#     MCres <- MCsim('growthmodel',parlist,MCrep,outtimes,vars,param,filenames,graph=F,0.01,28)
# }


## TODO: for package, move these to DESCRIPTION import section and use double colon in code!

# for bounding box plot
library(spatstat)
# better plot colours
library(colorRamps)
# prettier plots
library(ggplot2)
#for biplots (pca)
library(ggfortify)
#probabilistic index models
library(pim)
# moments, skewness, kurtosis
library(moments)
# best standardization to normal distribution
library(bestNormalize)
# multiple group comparisons
library(multcomp)
# statistics and better qq plot
library(car)
# utility operations for data analysis
library(Hmisc)
# used for simple histogram and boxplox combo plots
library(UsingR)
# For plotting matrix using ggplot
library(reshape2)

######### placeholder for unnecessary packages/packages we are not using but need to be installed ###
library(MASS)
library(rlang)
library(vctrs)
library(backports)
library(fdapace)
library(fda.usc)
library(VGAM)
library(gamlss)
library(coin)


#' Compute principal components of a methylation matrix.
#'
#' @param beta Output from \code{\link{meffil.normalize.samples}()},
#' either a matrix or a GDS filename.
#' @param probe.range Default = 50000. How many probes to be used in calculating PCs.
#' @param sites Subset of CpG sites to consider (row names of beta) (Default: NULL).
#' @param samples Subset of samples to consider (column names of beta) (Default: NULL).
#' @param  autosomal If true, remove probes on sex chromosomes (Default: TRUE).
#' @param winsorize.pct Apply to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: NA).
#' @param outlier.iqr.factor Apply to methylation after setting,
#' for each CpG site, values less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @param  full.obj Default = FALSE.  If true, then return the full `prcomp` object rather than just the PCs.
#' @param  verbose=T Print progress messages?
#' @return the principal components of \code{normalized.beta}.
#'
#' @export
meffil.methylation.pcs <- function (beta, probe.range = 50000, sites=NULL, samples=NULL, autosomal=T, winsorize.pct=NA, outlier.iqr.factor=NA, full.obj=F, verbose = F) {
    meffil:::msg("Calculating CpG variance", verbose = verbose)

    var.sites <- meffil.most.variable.cpgs(beta, probe.range, sites, samples, autosomal, winsorize.pct, outlier.iqr.factor)

    if (is.matrix(beta)) {
        beta <- beta[var.sites,,drop=F]
        if (!is.null(samples))
            beta <- beta[,samples,drop=F]
    } else {
        beta <- meffil:::retrieve.gds.methylation(beta, var.sites, samples)
    }
    beta <- meffil.handle.outliers(beta, winsorize.pct, outlier.iqr.factor)
    beta <- meffil:::impute.matrix(beta, margin=1)

    meffil:::msg("Calculating beta PCs", verbose = verbose)
    ret <- prcomp(t(beta))$x
    if (!full.obj)
        ret <- ret$x
    ret
}


context("Test telfer")

# Create data
set.seed(seed = 128)
SS <- 1000 # number of observations
taxa <- sample(letters, SS, replace = TRUE)
site <- sample(paste('A', 1:20, sep = ''), SS, replace = TRUE)
time_period <- sample(1:3, SS, replace = TRUE)

df <- unique(data.frame(taxa, site, time_period))

# This is what the results should look like
results <- structure(list(taxa = structure(1:26, .Label = c("a", "b", "c",
                                                            "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p",
                                                            "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"), class = "factor"),
                          Nsite_1.x = c(7, 5, 11, 6, 8, 12, 13, 10, 11, 7, 9, 10, 10,
                                        8, 6, 10, 10, 9, 7, 9, 7, 12, 7, 6, 11, 6),
                          Nsite_2.x = c(8, 8, 10, 11, 14, 12, 8, 8,  8, 10, 10, 10,
                                        9, 11, 7, 13, 9, 10, 12, 9, 14, 11, 5, 11, 13, 8),
                          Telfer_1_2 = c(-0.73732519, -0.77133792, -0.09783170,  0.70566506,  1.84449356,
                                         0.79320432, -1.39542120, -0.88966350, -0.98871825,  0.14526451,  0.02084756, -0.03627006,
                                         -0.45903684,  0.49957587, -1.23170170,  1.26438351, -0.45903684,  0.02084756,  1.02785421,
                                         -0.39539529,  1.98143673,  0.30605205, -2.22583487,  0.70566506, 1.25996498,
                                         -0.72891844), Nsite_1.y = c(7, 5, 11, 6, 8, 12, 13, 10, 11, 7, 9, 10, 10, 8,
                                                                     6, 10, 10, 9, 7, 9, 7, 12, 7, 6, 11, 6),
                          Nsite_3.x = c(10, 8, 11, 11, 7, 11, 12, 9, 7, 11, 10, 9, 9, 7, 11, 5, 10, 12, 9, 8, 7, 10, 10, 11, 12, 8),
                          Telfer_1_3 = c(0.4282569, -0.9490873, 0.6579022,  1.2282920, -1.2888609,  0.6135323,
                                         1.0747447, -0.2624847, -1.2994921,  1.0052868,  0.2779805, -0.2624847,
                                         -0.2624847, -1.2888609,  1.2282920, -2.4181066,
                                         0.2248821,  1.2932700, -0.1487729, -0.7373091, -1.3469912,  0.1331646,
                                         0.4282569,  1.2282920,  1.1469913, -0.7816810),
                          Nsite_2.y = c(8, 8, 10, 11, 14, 12, 8, 8, 8, 10, 10, 10, 9, 11, 7, 13, 9, 10, 12, 9, 14, 11, 5, 11, 13, 8),
                          Nsite_3.y = c(10, 8, 11, 11, 7, 11, 12, 9, 7, 11, 10, 9, 9, 7, 11, 5, 10, 12, 9, 8, 7, 10, 10, 11, 12, 8),
                          Telfer_2_3 = c(0.241879867, -1.128220065,  0.905222087,  0.882140381, -0.835189914,  0.855157996,
                                         1.611979800, -0.436860690, -1.846284033, 0.905222087, 0.325816517,
                                         -0.253589053, -0.340138161, -1.278488893,  0.896127341, -2.002866510,
                                         0.290092553,  1.495399688, -0.112055477, -0.982085822, -0.835189914,  0.352123266,
                                         0.006522637,  0.882140381,  1.275183707, -1.128220065)),
                     .Names = c("taxa",
                                                                                "Nsite_1.x", "Nsite_2.x", "Telfer_1_2", "Nsite_1.y", "Nsite_3.x",
                                                                                "Telfer_1_3", "Nsite_2.y", "Nsite_3.y", "Telfer_2_3"), row.names = c(NA,
                                                                                -26L), class = "data.frame")

######################
test_that("Test errors and warnings", {

  expect_error(temp <- telfer(taxa = 'tom', site = df$site, time_period = df$time_period),
               'The following arguements are not of equal length: taxa, site, time_period')
  expect_error(temp <- telfer(taxa = df$taxa, site = head(df$site,-1), time_period = df$time_period),
               'The following arguements are not of equal length: taxa, site, time_period')
  expect_error(temp <- telfer(taxa = df$taxa, site = df$site, time_period = tail(df$time_period, -1)),
               'The following arguements are not of equal length: taxa, site, time_period')
  expect_error(temp <- telfer(taxa = df$taxa, site = df$site, time_period = df$time_period, minSite = 100),
               'No taxa satisfy the minSite criteria when comparing time period 1 and 2')
  expect_error(temp <- telfer(taxa = df$taxa, site = df$site, time_period = df$time_period, minSite = TRUE),
               'minSite must be numeric or integer')
  expect_warning(temp <- telfer(taxa, site, time_period),
                 '269 out of 1000 observations will be removed as duplicates')

})
test_that("The function works", {

  TelferResult <- telfer(df$taxa, df$site, df$time_period)
  expect_true(all.equal(TelferResult, results, tolerance = .0000001))
  expect_is(TelferResult, class = 'data.frame')
  TelferResult <- telfer(df$taxa, df$site, df$time_period, useIterations = FALSE)
  expect_is(TelferResult, class = 'data.frame')

})


coralDelayModel <- function( y, parameters) {
    M <- y[1]
    C <- y[2]
    a <- parameters[1]
    g <- parameters[2]
    gamma <- parameters[3]
    r <- parameters[4]
    d <- parameters[5]
    dy[1] <- a*M*C - (g*M)/(1-C) + gamma*M - gamma*M*M - gamma*M*C
    dy[2] <- r*C - r*M*C - r*C*C - d*C - a*M*C
    list(dy)
}


########################
## Histogram of residuals from OP run

SSBparm<-"out"   # read ssb-R parameters from SSB_R.in (="in") or SSB_R.out (="out")
dev<-"screen"
dev<-"png"
Portrait <- T

#scenario.dir<-"C:/users/movi/sms/NS_63-10-Nov-2013/opti_s2b_HCR_2_0_Rec3_penBlim_atAgeW___lim_2"
output.dir<-scenario.dir
op.dir<-scenario.dir

##########################################################################
## init section used by other sections
#

cleanup()
if (nsp==1) { nox<-1; noy<-1; } else { nox<-1; noy<-1; }

noxy<-nox*noy
par(ask=TRUE)

#read SSB/R parameters
if (SSBparm=="in") p<-Read.SSB.Rec.data.in() else p<-Read.SSB.Rec.data()

model.name<-c('Ricker','Bev. & Holt','Geom. mean','Hockey stick')

SSB_R<-function(x) {
    delta<-0.5
    y<-x  # copy structure
    #print(c(alfa,beta,exp(alfa+beta)))
    if (model==1) y<-alfa*x*exp(-beta*x)
    else if (model==51 | model==52) y<-alfa*x*exp(-beta*x+info1*info2)
    else if (model==2) y<-alfa*x/(1+x*beta)
    else if (model==3) y<-rep(exp(alfa),length(x))
    else if (model==4) {for (ii in (1:length(x))) y[i]<-exp(alfa)*min(x[i],exp(beta))}
    else if (model==5) {for (ii in (1:length(x))) {
        if (x[ii]<=(exp(beta)*(1-delta))) y[ii]<-exp(alfa)*x[ii]
        else if (x[ii]< exp(beta)*(1+delta)) y[ii]=exp(alfa)*(x[ii]-(((x[ii]-exp(beta)*(1+delta))^2)/(4*delta*exp(beta))))
        else if (x[ii]>=exp(beta)*(1+delta)) y[ii]<=exp(alfa+beta)
        else x[i]<-NA
        }}
    else if (model==100) {for (ii in (1:length(x))) y[ii]<-exp(alfa)*min(x[ii],beta)}
    return(y)
}

##########################  SSB - Recruit plot Obsevations  #############

 dat<-Read.OP.condensed(dir=op.dir)
 ssb<-tapply(dat$SSB,list(dat$Species.n,dat$Year),sum)/1000
 rec<-tapply(dat$recruit,list(dat$Species.n,dat$Year),sum)/1000

 s.index<-0

if (dev=="print") cleanup()

nox<-3; noy<-4;
noxy<-nox*noy
newplot(dev,filename='SSB_R_OP1',nox,noy,Portrait,dir=op.dir);
i<-0

ss<-as.character(seq(first.VPA,nsp))

for (sp in ss) {
  s.index<-s.index+1
  model<-p[s.index,'model']
  alfa<-p[s.index,'alfa']
  beta<-p[s.index,'beta']
  info1<-p[s.index,'info1']
  info2<-p[s.index,'info2']
  CV<- sqrt(exp(p[s.index,'std']^2) - 1)
  modelName<-model.name[min(model,4)]
  if (model==51 | model==52) modelName<-paste("Ricker, Temp=",info2,sep='')

  if (i==noxy) {newplot(dev,filename=paste('SSB_R_OP1',s.index,sep=''),nox,noy,Portrait,dir=op.dir); i<-0 }
  x<-ssb[sp,]*1000
  y<- 1000*rec[sp,] /SSB_R(x)   # residuals: observed / predicted

  x<-seq(-3,3,by=0.01)
  hist(log(y),freq=F,main=paste(sp.names[as.numeric(sp)],': ',modelName," ",sep=''),xlab='Residual (log(obs/est))')

  SD<-p[s.index,'std']
  curve(dnorm(x,mean=0,sd=SD), col = 2, lty = 2, lwd = 3, add = TRUE)
  i<-i+1
}

## range in noise function
s.index<-0

if (dev=="print") cleanup()

newplot(dev,filename='SSB_R_OP2',nox,noy,Portrait,dir=op.dir);
i<-0

for (sp in ss) {
  s.index<-s.index+1
  model<-p[s.index,'model']
  alfa<-p[s.index,'alfa']
  beta<-p[s.index,'beta']
  info1<-p[s.index,'info1']
  info2<-p[s.index,'info2']
  CV<-p[s.index,'std']
  modelName<-model.name[min(model,4)]
  if (model==51 | model==52) modelName<-paste("Ricker, Temp=",info2,sep='')
  if (i==noxy) {newplot(dev,filename=paste('SSB_R_OP2',s.index,sep=''),nox,noy,Portrait,dir=op.dir);; i<-0 }
  x<-ssb[sp,]*1000
  y<- 1000*rec[sp,] /SSB_R(x)   # residuals: observed / predicted

  x<-seq(-3,3,by=0.01)
  hist(log(y)/CV,freq=F,main=paste(sp.names[as.numeric(sp)],': ',modelName," ",sep=''),xlab='Noise')

  CV<-p[s.index,'std']
  curve(dnorm(x,mean=0,sd=1), col = 2, lty = 2, lwd = 3, add = TRUE)
  i<-i+1
}
if (dev=='png') cleanup()


# Simulate some kind of explosion.
# This program will generate two plots.

# Load the only necessary library to complete this simulation:
library(ggplot2)

# Number of particles to simulate
n=200

# Simulates a vector explosion
bigbang<-data.frame("x"=rnorm(n),"y"=rnorm(n))
bigbang$dx<-bigbang$x*.1+.05*rnorm(n)
bigbang$dy<-bigbang$y*.1+.05*rnorm(n)
bigbang$speed=sqrt(bigbang$dx^2+bigbang$dy^2)
bigbang$dist=sqrt(bigbang$x^2+bigbang$y^2)

ggplot(bigbang)+
  geom_point(aes(x=x,y=y),size=1)+
  geom_segment(color="steelblue",aes(x=x,y=y,xend=x+dx,yend=y+dy),arrow=arrow(length=unit(.1,"cm")))+
  geom_point(aes(x=0,y=0),color="red",shape=3)+
  ggtitle("Particle Speeds after an Explosion")

ggplot(bigbang,aes(dist,speed))+
  geom_point(size=1)+
  geom_smooth(method=lm,se=F,formula=y~x+0,linetype=4,size=1)+
  ylab("Speed of Particle")+
  xlab("Distance of Particle from Center")+
  ggtitle("Particle Speeds after an Explosion")


# helper functions used by catch curves and age consistency plots

#-------------------------------------------------------------------------------
# function to compute catch at age (matrix)
# from proportions at age (matrix), weight at age (matrix) and total weight (vector)
wtprop2caa <- function(totwt,waa,props){
  caa <- props
  for (i in 1:length(totwt)){
    if (sum(props[i,]) == 0) caa[i,] = 0
    if (sum(props[i,]) > 0) caa[i,] <- props[i,] * (totwt[i] / sum(props[i,] * waa[i,]))
  }
  return(caa)
}

#-------------------------------------------------------------------------------
# function replace zeros and take log
rep0log <- function(mat){
  mat1 <- mat
  for (i in 1:length(mat1[,1])){
    mat1[i,mat1[i,]==0] <- NA
    mat1[i,] <- log(mat1[i,])
  }
  return(mat1)
}

#-------------------------------------------------------------------------------
# function make cohorts
makecohorts <- function(mat){
  NAmat <- matrix(NA, nrow=length(mat[1,]), ncol=length(mat[1,]))
  matcoh1 <- rbind(NAmat,mat,NAmat)
  nr <- length(matcoh1[,1])
  nc <- length(mat[1,])
  matcoh <- matrix(NA, nrow=nr, ncol=nc)
  for (i in 1:nc){
    matcoh[1:(nr-i),i] <- matcoh1[i:(nr-1),i]
  }
  colnames(matcoh) <- colnames(mat)
  return(matcoh)
}

#-------------------------------------------------------------------------------
find_peak_age <- function(cohmat){
  # determines peak age within each cohort and replaces younger ages with NA
  ages <- seq(1,length(cohmat[1,]))
  #  temp.sum <- apply(cohmat,1,function(x) sum(x, na.rm=T)) # this is the offending line, replaced with the one below
  temp.sum <- apply(cohmat,1,function(x) sum(exp(x), na.rm=T))  # note have to use exp because took logs in earlier function rep0log
  for (i in 1:length(cohmat[,1])){
    if (temp.sum[i] > 0){  # necessary to avoid cohorts that are all NA
      age.peak <- max(ages[cohmat[i,]==max(cohmat[i,],na.rm=T)], na.rm=T)  # find the peak age
      if (age.peak > 1) cohmat[i,1:(age.peak-1)] <- NA  # replace ages < peak.age with NA
    }
  }
  return(cohmat)
}

#-------------------------------------------------------------------------------
calc_Z_cohort <- function(cohmat){
  # calculate Z along cohort using linear regression and return point estimate and 80% confidence interval
  ages <- seq(1,length(cohmat[1,]))
  z <- matrix(NA, nrow=length(cohmat[,1]), ncol=3)
  for (i in 1:length(cohmat[,1])){
    if (length(cohmat[i,!is.na(cohmat[i,])]) >= 2){  # make sure there are at least 2 data points for point estimate
      z.fit <- lm(cohmat[i,]~ages)  # linear regression of cohort abundance vs age
      z[i,1] <- -1 * z.fit$coefficients[2]  # note change in sign for Z
      if (length(cohmat[i,!is.na(cohmat[i,])]) >= 3){  # need at least 3 data points for CI
        z[i,2:3] <- -1 * rev(confint(z.fit, "ages", level=0.80))  # note change in sign and order for Z CI
      }
    }
  }
  return(z)
}


#clear environment
rm(list = ls())

# set working directory
wd <- 'C:/Users/guillaume/Desktop/r.training/2.data'
setwd(wd)

# load salmon .data
salmon <- read.table('salmon.data.raw.txt', sep = ',', dec = '.', h = TRUE)

# multiple plot on panel
#par(mfcol = c(3, 2))

# regular plot =============================================

salmon$weight[!is.na(salmon$weight) & salmon$weight > 50] <- salmon$weight[!is.na(salmon$weight) & salmon$weight > 50] / 1000

salmon$length[!is.na(salmon$length) & salmon$length < 44] <- salmon$length[!is.na(salmon$length) & salmon$length < 44] * 2.54

#plot length vs weight
plot(x = salmon$length, y = salmon$weight,
     pch = '.', col = 'blue',
     xlab = 'Length (cm)', ylab = 'Weight (g)',
     main ='Lenght weight relationship')

# weight histogram
hist(x = salmon$weight)

# boxplot weight per river
boxplot(salmon$weight ~ salmon$river,
        outline = FALSE,
        ylab = 'Weight (Kg)',
        main = 'Salmon weight per River')

# pairs function
pairs(salmon[ , c(2, 6, 7)])

# barplot contengency table
barplot(table(salmon$sea.age, salmon$river),
        main = 'Number fish per sea age',
        ylab = 'Abundance')

# compute weight by river per year for 1 sw fish
weight.river.year.1sw <- by(data = salmon$weight[salmon$sea.age == 1],
                        INDICES = list(salmon$river[salmon$sea.age == 1], salmon$year[salmon$sea.age == 1]),
                        FUN = mean, na.rm = TRUE)
# reorganize as matrix
weight.river.year.1sw <- matrix(unlist(weight.river.year.1sw),
                            ncol = length(unique(salmon$river)),
                            nrow = length(unique(salmon$year)),
                            byrow = TRUE)

# plot multiple time series
matplot(x = weight.river.year.1sw, type = 'l',
        xlab = 'Year index', ylab = 'Mean weight (Kg)')

# save a graph =================================================================

pdf(file = 'matplot.pdf',
    useDingbats = FALSE)

matplot(x = weight.river.year.1sw, type = 'l',
        xlab = 'Year index', ylab = 'Mean weight (Kg)')

dev.off()


 D01BDJ Example Program Results

 A      - lower limit of integration =     0.0000
 B      - upper limit of integration =     1.0000
 EPSABS - absolute accuracy requested =  0.00E+00
 EPSREL - relative accuracy requested =  1.00E-04

 RESULT - approximation to the integral =  -0.03183
 ABSERR - estimate to the absolute error =  1.34E-11