##
# computing_uptake
##

computing_uptake <- computing_uptake %>%

    mutate_at(vars(year), as.character) %>%

    left_join(school_rolls_from_1966 %>%
                  select(year, secondary_pupils, index_factor)
              ) %>%
    relocate(index_factor, .after = year) %>%
    relocate(secondary_pupils, .after = year) %>%
    relocate(qualification, .after = year) %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(NoOfStudents_orig = NoOfStudents,
           AllEntries_orig = AllEntries) %>%
    mutate_at(vars(NoOfStudents, AllEntries), ~ as.integer(round(. / index_factor))) %>%

    relocate(NoOfStudents_orig, .before = NoOfStudents) %>%
    relocate(AllEntries_orig, .before = AllEntries)

#head(computing_uptake, 15)

##
# top 5 subjects across qualifications
##

focus_subject <- c("english", "math", "arithmetic")
subject_filter <- "English for Speakers of Other Languages"

top_5_subjects <- sqa_qualifications_data %>%

    filter(!str_detect(Subject, regex(paste0(focus_subject, collapse = "|"), ignore_case = TRUE)) &
           !str_detect(Subject, regex(subject_filter, ignore_case = TRUE))) %>%

    group_by(qualification, year, Subject, gender) %>%
    summarise(NoOfStudents = sum(NoOfStudents, na.rm = TRUE)) %>%
    group_by(qualification, year, gender)%>%
    slice_max(NoOfStudents, n = 5) %>%
    ungroup()

focus_subject <- "computing"

time_range <- top_5_subjects %>%
    select(year) %>%
    n_distinct()

top_5_subjects <- top_5_subjects %>%

    left_join(top_5_subjects %>%
                group_by(qualification) %>%
                summarise(subject_time_range = n_distinct(year))
             ) %>%

    left_join(top_5_subjects %>%
                group_by(Subject) %>%
                summarise(popularity_overall = n())
             )

top_5_subjects <- top_5_subjects %>%

    left_join(top_5_subjects %>%

                group_by(qualification, Subject, gender) %>%
                summarise(popularity = n(),
                          popularityOverTimeAndQualification = popularity / subject_time_range,
                          popularityOverTime = popularity /time_range) %>%
                distinct()
             ) %>%
    arrange(desc(popularity)) %>%

    mutate(Subject.label = eval(formatted_subject_labels_as_expr))

rm(subject_filter, time_range)

# normalisation

top_5_subjects <- top_5_subjects %>%
    mutate_at(vars(year), as.character) %>%

    left_join(school_rolls_from_1966 %>%
                  select(year, secondary_pupils, index_factor)
              ) %>%
    relocate(index_factor, .after = year) %>%
    relocate(secondary_pupils, .after = year) %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(NoOfStudents_orig = NoOfStudents) %>%
    mutate_at(vars(NoOfStudents), ~ as.integer(round(. / index_factor))) %>%

    relocate(NoOfStudents_orig, .before = NoOfStudents)

# deselect and padding
top_5_subjects <- top_5_subjects %>%

    select(-c(secondary_pupils, index_factor, NoOfStudents_orig)) %>%
    mutate_at(vars(Subject, Subject.label), ~ fct_drop(.))

top_5_subjects <- data.frame(year = levels(top_5_subjects$year)) %>%

    full_join(top_5_subjects %>%
                distinct(qualification, subject_time_range), by = character()) %>%

    full_join(top_5_subjects %>%
                distinct(Subject, Subject.label, popularity_overall), by = character()) %>%

    full_join(top_5_subjects %>%
                distinct(gender), by = character()) %>%
    mutate_at(vars(year, qualification, Subject, Subject.label, gender), as.character) %>%

    full_join(top_5_subjects) %>%

    mutate_at(vars(year), as.ordered)  %>%
    mutate_at(vars(qualification, Subject, Subject.label, gender), as.factor) %>%

    mutate_at(vars(Subject, Subject.label), ~ reorder(., popularityOverTime, na.rm = TRUE)) %>%
    mutate_at(vars(qualification), ~ fct_relevel(., sqa_qualifications_ordering$qualification)) %>%
    arrange(qualification) %>%

    mutate_at(vars(NoOfStudents, (starts_with("popularity") & !popularityOverTime)), ~ replace_na(., -Inf))

top_5_subjects <- top_5_subjects %>%

    mutate(tooltip = case_when((NoOfStudents > 0) ~ paste(Subject.label, "at", qualification, "- with", NoOfStudents, gender, "entries in", year,
                                   "\npopularity over time at", qualification, " -", paste0(100 * round(popularityOverTimeAndQualification, 2), "%"),
                                   "\npopularity overall -", paste0(100 * round(popularityOverTime, 2), "%")),
                               (year == "Overall") ~ paste(Subject.label, "popularity over time for", paste0(gender, "s at"), qualification,
                                   "-", paste0(100 * round(popularityOverTimeAndQualification, 2), "%"),
                                   "\n", Subject.label, "popularity overall -", paste0(100 * round(popularityOverTime, 2), "%")),
                               TRUE ~ ""
                              ))
### ###

##
# selected subject groups
##

### ###

focus_subject <- c("english", "math", "arithmetic")
subject_filter <- "English for Speakers of Other Languages"
overwrite_subject_group <- c("arithmetic" = "math")

select_focus_subjects <- createSubjectGroups(sqa_qualifications_data,
                                             focus_subject,
                                             subject_filter,
                                             overwrite_subject_group)

focus_subject <- c("physics", "chemistry", "biology")
subject_filter <- "technology"

select_focus_subjects <- select_focus_subjects %>%
                            bind_rows(createSubjectGroups(sqa_qualifications_data,
                                                          focus_subject,
                                                          subject_filter,
                                                          overwrite_subject_group = NULL))

focus_subject <- c("engineering", "biotechnology", "technological studies")

select_focus_subjects <- select_focus_subjects %>%
                            bind_rows(createSubjectGroups(sqa_qualifications_data,
                                                          focus_subject,
                                                          overwrite_subject_group = NULL)) %>%
                            suppressWarnings() # already catering for empty subject_filter search

focus_subject <- "computing"
# ? Information Systems

select_focus_subjects <- select_focus_subjects %>%
                            bind_rows(createSubjectGroups(sqa_qualifications_data,
                                                          focus_subject,
                                                          overwrite_subject_group = NULL)) %>%
                            suppressWarnings()

select_focus_subjects <- select_focus_subjects %>%
    mutate_at(vars(SubjectGroup), ~ if_else(is.na(.), Subject, .)) %>%
    mutate_at(vars(everything()), as.factor) %>%
    mutate_at(vars(SubjectGroup), ~ fct_relevel(., str_to_title(focus_subject)))

levels(select_focus_subjects$Subject)
levels(select_focus_subjects$SubjectGroup)
select_focus_subjects

rm(subject_filter, overwrite_subject_group)

focus_subjects <- list(c("computing", "english", "math"),
                       c("computing", "physics", "chemistry", "biology"),
                       c("computing", "engineering", "biotechnology", "technological studies")
                      )

##
# uptake over time - selected subjects
##

select_focus_subjects_normalised <- as.data.frame(levels(sqa_qualifications_data$year)) %>%

    full_join(as.data.frame(unique(sqa_qualifications_data$qualification)),
              by = character()) %>%

    full_join(as.data.frame(select_focus_subjects$Subject),
              by = character()) %>%

    full_join(as.data.frame(unique(sqa_qualifications_data$gender)),
              by = character()) %>%

    rename_with(~ c("year", "qualification", "Subject", "gender")) %>%
    mutate(Subject.label = factor(eval(formatted_subject_labels_as_expr)))

select_focus_subjects_normalised <- select_focus_subjects_normalised %>%
    mutate_at(vars(year), as.character) %>%

    full_join(sqa_qualifications_data %>%
                   filter(Subject %in% select_focus_subjects$Subject)
              ) %>%

    left_join(select_focus_subjects) %>%
    relocate(SubjectGroup, .after = Subject) %>%

    select(-c(NumberOfCentres, grade)) %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(pseudo_point = is.na(NoOfStudents),
           tooltip = if_else(pseudo_point, "",
                             paste0(gender, " at ", qualification, " - ", round(PercentageOfStudents, 2) * 100, "% of entries in ", year))
           ) %>%
    mutate_at(vars(NoOfStudents, AllEntries, PercentageOfStudents), ~ replace_na(., -Inf))

select_focus_subjects_normalised <- select_focus_subjects_normalised %>%

    mutate_at(vars(year), as.character) %>%

    left_join(school_rolls_from_1966 %>%
                  select(year, secondary_pupils, index_factor) %>%
                  mutate_at(vars(year), as.character)
              ) %>%
    relocate(index_factor, .after = year) %>%
    relocate(secondary_pupils, .after = year) %>%
    mutate_at(vars(year), as.ordered) %>%

    mutate(NoOfStudents_orig = NoOfStudents,
           AllEntries_orig = AllEntries) %>%
    mutate_at(vars(NoOfStudents, AllEntries), ~ as.integer(round(. / index_factor))) %>%

    relocate(NoOfStudents_orig, .before = NoOfStudents) %>%
    relocate(AllEntries_orig, .before = AllEntries) %>%
    mutate_at(vars(NoOfStudents, AllEntries), ~ replace_na(., -Inf))

# detail - by qualification

filter_focus_subjects <- select_focus_subjects_normalised %>%

    filter(!pseudo_point) %>%
    #mutate_at(vars(NoOfStudents, AllEntries), ~ na_if(., -Inf)) %>%

    filter(SubjectGroup %in% levels(select_focus_subjects$SubjectGroup)) %>%
    group_by(year, qualification, SubjectGroup, gender, pseudo_point) %>%

    summarise(NoOfStudents = sum(NoOfStudents, na.rm = TRUE)) %>%

    pivot_wider(names_from = gender, values_from = NoOfStudents) %>%

    right_join(select_focus_subjects_normalised %>% # need to account for empty entries (by gender and subject)

                #filter(!pseudo_point) %>%
                mutate_at(vars(NoOfStudents, AllEntries), ~ na_if(., -Inf)) %>%

                filter(SubjectGroup %in% levels(select_focus_subjects$SubjectGroup)) %>%
                group_by(year, qualification, SubjectGroup, Subject, gender, pseudo_point) %>%

                summarise(NoOfStudents = sum(NoOfStudents, na.rm = TRUE),
                          AllEntries = sum(AllEntries, na.rm = TRUE)) %>%

                pivot_wider(names_from = gender, values_from = NoOfStudents) %>%

                group_by(year, qualification, SubjectGroup) %>%
                summarise(AllEntries = sum(AllEntries, na.rm = TRUE))
    ) %>% # end join

    mutate_at(vars(all_of(gender_column_labels), AllEntries), ~ if_else(is.na(.) | (. == 0), -Inf, .)) %>%
    #mutate_at(vars(all_of(gender_column_labels), AllEntries), as.integer) %>%
    mutate_at(vars(pseudo_point), ~ is.na(pseudo_point)) %>%

    mutate(uptake_difference = abs(coalesce(female, 0) - coalesce(male, 0)) / AllEntries,
           rounded_uptake_difference = round(abs(coalesce(female, 0) - coalesce(male, 0)) / AllEntries * 100, 1),
           tooltip = case_when((is.na(female) & is.na(male)) | ((female == -Inf) & (male == -Inf)) ~ NA_character_,
                                 is.na(female) | (female == -Inf) ~ paste(SubjectGroup, "at", qualification, "- No female uptake; uptake by males", paste0(rounded_uptake_difference, "% in"), year),
                                 is.na(male) | (male == -Inf) ~ paste(SubjectGroup, "at", qualification, "- No male uptake; uptake by females", paste0(rounded_uptake_difference, "% in"), year),
                                 female > male ~ paste(SubjectGroup, "at", qualification, "- Uptake by females exceeds males by", paste0(rounded_uptake_difference, "% in"), year),
                                 female < male ~ paste(SubjectGroup, "at", qualification, "- Uptake by males exceeds females by", paste0(rounded_uptake_difference, "% in"), year),
                                 female == male ~ paste(SubjectGroup, "at", qualification, "- Gender uptake equal in ", year),
                                 TRUE ~ NA_character_),
           tooltip2 = case_when((is.na(female) & is.na(male)) | ((female == -Inf) & (male == -Inf)) ~ NA_character_,
                                   is.na(female) | (female == -Inf) ~ paste(SubjectGroup, "at", qualification, "- No female uptake; male only class in", year),
                                   is.na(male) | (male == -Inf) ~ paste(SubjectGroup, "at", qualification, "- No male uptake; female only class in", year),
                                   female > male ~ paste(SubjectGroup, "at", qualification, "- Uptake by females exceeds males by", round(female / male, 1), "times", paste0("(", rounded_uptake_difference, "%)"), "in", year),
                                   female < male ~ paste(SubjectGroup, "at", qualification, "- Uptake by males exceeds females by", round(male / female, 1), "times", paste0("(", rounded_uptake_difference, "%)"), "in", year),
                                   female == male ~ paste(SubjectGroup, "at", qualification, "- Gender uptake equal in ", year),
                                   TRUE ~ NA_character_),
           segment_encoding = case_when((is.na(female) & is.na(male)) | ((female == -Inf) & (male == -Inf)) ~ NA_character_,
                                        female > male ~ "female",
                                        female < male ~ "male",
                                        female == male ~ "gray75",
                                        TRUE ~ "")
          ) %>%
    #mutate_at(vars(tooltip), ~ if_else(is.na(.), ., paste(SubjectGroup, "at", qualification, "-", .))) %>% fails :@ - returns NA_character_ not NA
    select(-rounded_uptake_difference) %>%
    relocate(AllEntries, .before = uptake_difference)

# summary - across all qualifications

filter_focus_subject_summaries <- filter_focus_subjects %>%

    #filter(!pseudo_point) %>%
    mutate_at(vars(all_of(gender_column_labels), AllEntries), ~ na_if(., -Inf)) %>%

    group_by(year, SubjectGroup) %>%
    summarise_at(vars(all_of(gender_column_labels), AllEntries), ~ sum(., na.rm = TRUE)) %>%
    mutate_at(vars(all_of(gender_column_labels), AllEntries), ~ if_else(is.na(.) | (. == 0), -Inf, .)) %>%

    mutate(uptake_difference = abs(coalesce(female, 0) - coalesce(male, 0)) / AllEntries,
           rounded_uptake_difference = round(abs(coalesce(female, 0) - coalesce(male, 0)) / AllEntries * 100, 1),
           tooltip = case_when((is.na(female) & is.na(male)) | ((female == -Inf) & (male == -Inf)) ~ NA_character_,
                           is.na(female) | (female == -Inf) ~ paste(SubjectGroup, "- No female uptake; uptake by males", paste0(rounded_uptake_difference, "% in"), year),
                           is.na(male) | (male == -Inf) ~ paste(SubjectGroup, "- No male uptake; uptake by females", paste0(rounded_uptake_difference, "% in"), year),
                           female > male ~ paste(SubjectGroup, "- Uptake by females exceeds males by", paste0(rounded_uptake_difference, "% in"), year),
                           female < male ~ paste(SubjectGroup, "- Uptake by males exceeds females by", paste0(rounded_uptake_difference, "% in"), year),
                           female == male ~ paste(SubjectGroup, "- Gender uptake equal in ", year),
                           TRUE ~ NA_character_),
           tooltip2 = case_when((is.na(female) & is.na(male)) | ((female == -Inf) & (male == -Inf)) ~ NA_character_,
                           is.na(female) | (female == -Inf) ~ paste(SubjectGroup, "- No female uptake; male only class in", year),
                           is.na(male) | (male == -Inf) ~ paste(SubjectGroup, "- No male uptake; female only class in", year),
                           female > male ~ paste(SubjectGroup, "- Uptake by females exceeds males by", round(female / male, 1), "times", paste0("(", rounded_uptake_difference, "%)"), "in", year),
                           female < male ~ paste(SubjectGroup, "- Uptake by males exceeds females by", round(male / female, 1), "times", paste0("(", rounded_uptake_difference, "%)"), "in", year),
                           female == male ~ paste(SubjectGroup, "- Gender uptake equal in ", year),
                           TRUE ~ NA_character_),
          segment_encoding = case_when((is.na(female) & is.na(male)) | ((female == -Inf) & (male == -Inf)) ~ NA_character_,
                                        female > male ~ "female",
                                        female < male ~ "male",
                                        female == male ~ "gray75",
                                        TRUE ~ "")
          )

### ###

##
#
##

### ###


library( "rmacrolite" )

# # Setup MACRO directory (if needed)
# rmacroliteSetModelVar( "C:/swash/macro" )

#   Path to an example par-file
par_file_path <- system.file( "par-files",
    "chat_winCer_GW-X_900gHa_d182.par",
    package = "rmacrolite" )

#   Import the example par-file
par_file <- rmacroliteImportParFile(
    file = par_file_path )

#   Fetch the current parametrization
rmacroliteDegradation( x = par_file )
    # $`layer`
      # layer_no      dt50           k dt50_depth_f
    # 1        1  54.99998 0.012602680          1.0
    # 2        2 110.00000 0.006301338          0.5
    # 3        3 110.00000 0.006301338          0.5
    # 4        4 183.33332 0.003780803          0.3
    # 5        5       Inf 0.000000000          0.0
    # 6        6       Inf 0.000000000          0.0

    # $site
     # dt50_ref_temp        dt50_pf  exp_temp_resp exp_moist_resp
             # 21.00           1.00           0.01           0.50

#   Modify the parameter
par_file2 <- par_file
rmacroliteDegradation( x = par_file2 ) <- c( "dt50" = 22,
    "dt50_ref_temp" = 20, "dt50_pf" = 2,
    "exp_temp_resp" = 0.079, "exp_moist_resp" = 0.49 )

#   Check the result
deg <- rmacroliteDegradation( x = par_file2 )
deg
    # $`layer`
      # layer_no     dt50          k dt50_depth_f
    # 1        1 22.00000 0.03150669          1.0
    # 2        2 43.99999 0.01575335          0.5
    # 3        3 43.99999 0.01575335          0.5
    # 4        4 73.33331 0.00945201          0.3
    # 5        5      Inf 0.00000000          0.0
    # 6        6      Inf 0.00000000          0.0

    # $site
     # dt50_ref_temp        dt50_pf  exp_temp_resp exp_moist_resp
            # 20.000          2.000          0.079          0.490

#   Internal controls
if( deg[["layer"]][ 1L, "dt50" ] == 22 ){
    stop( "Test of rmacroliteDegradation() failed (DT50)" ) }

test2 <- identical( deg[["layer"]][, "dt50_depth_f" ],
    c( 1, .5, .5, .3, 0, 0 ) )

if( !test2 ){
    stop( "Test of rmacroliteDegradation() failed (DT50 depth factor)" ) }

test3 <- identical( as.numeric( deg[["site"]] ),
    c( 20, 2, 0.079, 0.49 ) )

if( !test3 ){
    stop( "Test of rmacroliteDegradation() failed (site solute parameters)" ) }

#   Clean-up
rm( par_file_path, par_file, par_file2, deg, test2, test3 )


library(randomForest)
library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# Train and tune random forest classifiers for each of  data sets coming out of the experiment
# "equifinality-3", for binary analysis.
#
# THIS EXPERIMENT AIMS AT DIFFERENTIATING VARIOUS BIASED MODELS FROM ONE ANOTHER

############### Set up Execution Environment #############

# Set up logging
log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "biasedmodels-classification.log")
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-population-data.rda")
  sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-sampled-data.rda")
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-ta-sampled-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-population-data.rda", args = clargs)
  sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-sampled-data.rda", args = clargs)
  ta_sampled_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3", filename = "equifinality-3-ta-sampled-data.rda", args = clargs)
}

load(pop_data_file)
load(sampled_data_file)
load(ta_sampled_data_file)
flog.info("Loaded data file: %s", pop_data_file, name='cl')
flog.info("Loaded data file: %s", sampled_data_file, name='cl')
flog.info("Loaded data file: %s", ta_sampled_data_file, name='cl')

flog.info("Beginning classification analysis of biased models from equifinality-3 data sets", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
num_cores <- get_parallel_cores_given_os(dev=TRUE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

########### Training and Tuning Variables ##############

#
# Common training and tuning parameters for ctmixtures analysis
#

gbm_grid <- expand.grid(.interaction.depth = (1:6)*2,
                        .n.trees = (1:10)*25,
                        .shrinkage = 0.05)

training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)

############ Setup Results Variables ###############

experiment_names <- c("Conf/Anticonf Dominance: Census", "Conf/Anticonf Dominance: Sample 20%")

bias_results <- data.frame()
bias_results_roc <- NULL
bias_results_model <- NULL
bias_results_cm <- NULL

###### Population Data:  conformist dominant versus anticonformist dominant ######

flog.info("Starting analysis of mixconfdom vs. mixanticonfdom with pop census data", name='cl')

# Row index for results data frame -- bump this by one for each analysis block
i <- 1
exp_name <- experiment_names[i]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes

eq3_pop_biased <- dplyr::filter(eq3_pop_df, model_class_label != 'allneutral')
eq3_pop_biasdom_df <- dplyr::filter(eq3_pop_biased, model_class_label != 'mixconfequal')
eq3_pop_biasdom_df$model_class_label = factor(eq3_pop_biasdom_df$model_class_label, levels = c("mixconfdom", "mixantidom"))

# Two labels are left:  mixconfdom and mixantidom

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "innovation_rate")

## Train Model ##

bias_dominance_model <- train_gbm_classifier(eq3_pop_biasdom_df, training_set_fraction, "model_class_label",
                                             gbm_grid, training_control, exclude_columns, verbose=FALSE)
bias_results_model[["bias_dominance_model"]] <- bias_dominance_model$tunedmodel

## Evaluate Model Performance ##

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(bias_dominance_model$tunedmodel, newdata=bias_dominance_model$test_data)
cm <- confusionMatrix(predictions, bias_dominance_model$test_data$model_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments[i] <- exp_name
results$elapsed <- bias_dominance_model$elapsed
bias_results_cm[["bias_dominance_model"]] <- cm

# calculate a ROC curve
bias_dominance_roc <- calculate_roc_binary_classifier(bias_dominance_model$tunedmodel,
                                                      bias_dominance_model$test_data,
                                                      "model_class_label",
                                                      exp_name)
results$auc[i] <- unlist(bias_dominance_roc$auc@y.values)
bias_results_roc[["bias_dominance_model"]] <- bias_dominance_roc

# add to the final data frame
bias_results <- rbind(bias_results, results)

###### Sample Size 20 Data:  conformist dominant versus anticonformist dominant ######

flog.info("Starting analysis of mixconfdom vs. mixanticonfdom with sampled size 20 data", name='cl')

# Row index for results data frame -- bump this by one for each analysis block
i <- 2
exp_name <- experiment_names[i]

# prepare data
# create a label combining the biased models into one
# then, split into training and test sets, with balanced samples for each of the binary classes

eq3_sampled_20 <- dplyr::filter(eq3_sampled_df, sample_size == 20)
eq3_sampled_bias_20 <- dplyr::filter(eq3_sampled_20, model_class_label != 'allneutral')
eq3_sampled_biasdom_20_df <- dplyr::filter(eq3_sampled_bias_20, model_class_label != 'mixconfequal')
eq3_sampled_biasdom_20_df$model_class_label = factor(eq3_sampled_biasdom_20_df$model_class_label, levels = c("mixconfdom", "mixantidom"))

# Two labels are left:  mixconfdom and mixantidom

# remove fields from analysis that aren't predictors, and the detailed label with 4 classes
exclude_columns <- c("simulation_run_id", "innovation_rate", "sample_size")

## Train Model ##

bias_dominance_20_model <- train_gbm_classifier(eq3_sampled_biasdom_20_df, training_set_fraction, "model_class_label",
                                                gbm_grid, training_control, exclude_columns, verbose=FALSE)
bias_results_model[["bias_dominance_20_model"]] <- bias_dominance_20_model$tunedmodel

## Evaluate Model Performance ##

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(bias_dominance_20_model$tunedmodel, newdata=bias_dominance_20_model$test_data)
cm <- confusionMatrix(predictions, bias_dominance_20_model$test_data$model_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- bias_dominance_20_model$elapsed
bias_results_cm[["bias_dominance_20_model"]] <- cm

# calculate a ROC curve
bias_dominance_roc_20 <- calculate_roc_binary_classifier(bias_dominance_20_model$tunedmodel,
                                                      bias_dominance_20_model$test_data,
                                                      "model_class_label",
                                                      exp_name)
results$auc <- unlist(bias_dominance_roc_20$auc@y.values)
bias_results_roc[["bias_dominance_20_model"]] <- bias_dominance_roc_20

# add to the final data frame
bias_results <- rbind(bias_results, results)

############## Complete Processing and Save Results ##########

# we can now use plot_multiple_roc() to plot all the ROC curves on the same plot, etc.
# as well as graph various of the metrics as they vary across sample size and TA duration
#plot_multiple_roc_from_list(bias_results_roc)

# save objects from the environment

# save objects from the environment
if(length(clargs) == 0) {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "bias-model-comparisons-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "bias-model-comparisons-gbm-dfonly.RData")

} else {
  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                              filename = "bias-model-comparisons-gbm.RData", args = clargs)

  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-3",
                                      filename = "bias-model-comparisons-gbm-dfonly.RData", args = clargs)
}

flog.info("Saving combined_results of analysis to R environment snapshot: %s", image_file, name='cl')
save(bias_results, bias_results_model, bias_results_roc, bias_results_cm, file=image_file)

flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(bias_results, file=image_file_results)

# End
flog.info("Analysis bias comparison complete", name='cl')


# script can be executed with

library(readr)
library(ggplot2)
library(dplyr)
library(lubridate)
library(gganimate)

temps = read_csv("saxony-monthly-temperature.csv")

temp_median_year = temps %>%
  mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))), mo= month(ymd(MESS_DATUM_BEGINN))) %>%
  filter(mo == 2)%>%
  group_by(yr,STATIONS_ID)

nyears = length(unique(temp_median_year$yr))
message("animating ",nyears," years")

# https://github.com/thomasp85/gganimate
anplot = ggplot(temp_median_year,aes(x=geo_lon,y=geo_lat,color=MO_TT)) +
  geom_point(size=6) +
  theme_minimal() +
  xlab("longitude") +
  ylab("latitude") +
  labs(title = 'Year: {frame_time}', x = 'longitude', y = 'latitude') +
  transition_time(yr) +
  ease_aes('linear')

anim = animate(anplot,
               nframes=nyears,
               fps=15,
               renderer = gifski_renderer(),
               width=500,
               height=350)
#magick::image_write(anim, path="monthly-temperatures.gif")
anim_save("monthly-temperatures-map.gif",anim)


title_case <- function(x) gsub(x, pattern="(^|[[:space:]])([[:alpha:]])", replacement="\\1\\U\\2", perl=TRUE)

#' Prints PAPI objects
#'
#' @param x
#' A papi_output object to print.
#' @param ...
#' Extra arguments (ignored).
#' @param digits
#' Number of digits to print.
#'
#' @rdname print
#' @export
print.papi_output <- function(x, ..., digits=5)
{
  maxlen <- max(sapply(names(x), nchar))
  names <- gsub(names(x), pattern="_", replacement=" ")
  names <- title_case(x=names)
  spacenames <- simplify2array(lapply(names, function(str) paste0(str, ":", paste0(rep(" ", maxlen-nchar(str)), collapse=""))))

  cat(paste(spacenames, sapply(x, round, digits=digits), sep=" ", collapse="\n"), "\n")
  invisible()
}

#' Subsets PAPI outputs.
#'
#' @param x
#' PAPI object.
#' @param i
#' Index.
#'
#' rdname subset
#' @export
"[.papi_output" <- function(x, i)
{
  class(x) <- NULL
  ret <- x[i]
  if (length(ret) > 0)
    class(ret) <- "papi_output"
  else
    return(numeric(0))

  return(ret)
}


setwd(file.path(mainDataDir, subDir))
tnmc=length(keep.samples)

#if(plot.phi==TRUE)phi=array(NA,c(n.chains,n.hpars,tnmc))
if(plot.lower==TRUE)theta=array(NA,c(n.chains,n.pars,S,tnmc))
#if(plot.weights==TRUE)weights=array(NA,c(n.chains,S,tnmc))
# if(plot.sigma==TRUE){
#   Sigma1=array(NA,c(n.chains,n.Sigma1,tnmc))
#   Sigma2=array(NA,c(n.chains,n.Sigma2,tnmc))
# }
# if(plot.mu==TRUE){
#   mu1=array(NA,c(n.chains,n.mu1,tnmc))
#   mu2=array(NA,c(n.chains,n.mu2,tnmc))
# }

for(q in 1:n.chains){
  if(plot.lower==TRUE){
    for(j in 1:S){
      temp=t(as.matrix(read.table(paste("chain",q,"_sub",j,"_lower.txt",sep=""),header=F)))
      theta[q,,j,]=temp[,-1]
    }}
  if(plot.sigma==TRUE){
    temp=t(as.matrix(read.table(paste("chain",q,"_Sigma1.txt",sep=""),header=F)));Sigma1[q,,]=temp[,-1];
    temp=t(as.matrix(read.table(paste("chain",q,"_Sigma2.txt",sep=""),header=F)));Sigma2[q,,]=temp[,-1];
  }
  if(plot.mu==TRUE){
    temp=t(as.matrix(read.table(paste("chain",q,"_mu1.txt",sep=""),header=F)));mu1[q,,]=temp[,-1];
    temp=t(as.matrix(read.table(paste("chain",q,"_mu2.txt",sep=""),header=F)));mu2[q,,]=temp[,-1];
  }
  if(plot.phi==TRUE){temp=t(as.matrix(read.table(paste("chain",q,"_hyper.txt",sep=""),header=F)));phi[q,,]=temp[,-1]}
  if(plot.weights==TRUE){temp=t(as.matrix(read.table(paste("chain",q,"_weights.txt",sep=""),header=F)));weights[q,,]=temp[,-1]}
  #if(plot.weights.delta==TRUE){temp=t(as.matrix(read.table(paste("chain",q,"_weights_delta.txt",sep=""),header=F)));weight.delta[q,,]=temp[,-1]}
  print(round(q/n.chains*100))
}

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

breaks=50

if(plot.lower==TRUE){
  par(mfrow=c(2,2),ask=F)
  for(j in 1:10){
    for(k in 1:n.pars){
      matplot(t(theta[,k,j,starti:tnmc]),type="l",lty=1,main=paste0(par.names[k],"; Subject ",j),ylab=par.names[k])
      #if(any(k==c(1,2,3,6)))abline(h=log(true$vec[k]),lwd=3)
      #if(any(k==c(4,5)))abline(h=logit(true$vec[k]),lwd=3)
      hist(theta[,k,j,starti:tnmc],prob=T,breaks=breaks,main=paste0(par.names[k],"; Subject ",j),xlab=par.names[k])
      #if(any(k==c(1,2,3,6)))abline(v=log(true$vec[k]),lwd=3,col="red")
      #if(any(k==c(4,5)))abline(v=logit(true$vec[k]),lwd=3,col="red")
    }
  }

  par(mfrow=c(2,3),ask=F)
  for(j in 11:S){
    for(k in 1:n.pars){
      if (k==2) {
        next
      }
      #matplot(t(theta[,k,j,starti:tnmc]),type="l",lty=1,main=paste0(par.names[k],"; Subject ",j),ylab=par.names[k])
      #if(any(k==c(1,2,3,6)))abline(h=log(true$vec[k]),lwd=3)
      #if(any(k==c(4,5)))abline(h=logit(true$vec[k]),lwd=3)
      hist(theta[,k,j,starti:tnmc],prob=T,breaks=breaks,main=paste0(par.names[k],"; Subject ",j),xlab=par.names[k])
      #if(any(k==c(1,2,3,6)))abline(v=log(true$vec[k]),lwd=3,col="red")
      #if(any(k==c(4,5)))abline(v=logit(true$vec[k]),lwd=3,col="red")
    }
  }
}

count=1
if(plot.phi==TRUE){
par(mfrow=c(2,2),ask=T)
for(k in 1:n.hpars){
if(plot.priors==TRUE){
if(k==(n.pars+1))count=1
xs=seq(min(phi[,k,starti:tnmc]),max(phi[,k,starti:tnmc]),length=200)
if(k<=n.pars)ys=dnorm(xs,prior[[count]]$mu,prior[[count]]$sigma)
if(k>n.pars)ys=dinvgamma(xs,prior[[count]]$alpha,prior[[count]]$beta)
}
matplot(t(phi[,k,starti:tnmc]),type="l",lty=1,main="",ylab=hpar.names[k])
hist(phi[,k,starti:tnmc],prob=T,breaks=breaks,main="",xlab=hpar.names[k])
if(plot.priors==TRUE){
lines(xs,ys,lty=2)
count=count+1
}}}

if(plot.sigma==TRUE){
  par(mfrow=c(2,2),ask=T)
  for(k in 1:n.Sigma1){
    matplot(t(Sigma1[,k,starti:tnmc]),type="l",lty=1,main=paste("Sigma1",k))
    hist(Sigma1[,k,starti:tnmc],prob=T,breaks=breaks)
  }
  for(k in 1:n.Sigma2){
    matplot(t(Sigma2[,k,starti:tnmc]),type="l",lty=1,main=paste("Sigma2",k))
    hist(Sigma2[,k,starti:tnmc],prob=T,breaks=breaks)
  }
}

if(plot.mu==TRUE){
  par(mfrow=c(2,2),ask=T)
  for(k in 1:n.mu1){
    matplot(t(mu1[,k,starti:tnmc]),type="l",lty=1,main=paste("mu1",k))
    hist(mu1[,k,starti:tnmc],prob=T,breaks=breaks)
  }
  for(k in 1:n.mu2){
    matplot(t(mu2[,k,starti:tnmc]),type="l",lty=1,main=paste("mu2",k))
    hist(mu2[,k,starti:tnmc],prob=T,breaks=breaks)
  }
}

if(plot.rho==TRUE){
  par(mfrow=c(2,2),ask=T)
  shift=n.mu1
  for(k in 2:shift){
    temp=Sigma1[,k,starti:tnmc]/(sqrt(Sigma1[,shift*(k-1)+k,starti:tnmc])*sqrt(Sigma1[,1,starti:tnmc]))
    matplot(t(temp),type="l",lty=1,main=paste("Sigma1",k))
    hist(temp,prob=T,breaks=breaks)

    temp=Sigma2[,k,starti:tnmc]/(sqrt(Sigma2[,shift*(k-1)+k,starti:tnmc])*sqrt(Sigma2[,1,starti:tnmc]))
    matplot(t(temp),type="l",lty=1,main=paste("Sigma2",k))
    hist(temp,prob=T,breaks=breaks)
  }
}

if(plot.weights==TRUE){
par(mfrow=c(2,2),ask=T)
for(j in 1:S){
matplot(t(weights[,j,starti.weights:tnmc]),type="l",lty=1,main=paste("Subject ",j),ylab="log likelihood")
}}

setwd(file.path(mainDir))


library(R.utils) # Utility functions useful when programming and developing R packages.
library(logging) # Pure R implementation of the ubiquitous log4j package. It offers hierarchic loggers, multiple handlers per log
#library(xlsx)
#library(WriteXLS)
library("XML")
library("methods")
logReset();
basicConfig('DEBUG');
addHandler(writeToConsole);
addHandler(writeToFile, file=paste("output-",System$getHostname(),'-',Sys.Date(),".log",sep=''), level='DEBUG');

path = '/Users/proton/Google\ Диск/Science/OpensimModeling/Storage/model/'

athlete <- "998_denshikov"
experiment <- "jump_jo 2"
save_to_file = TRUE

model_xml_file = paste(path,'/data/',athlete,'/gait_with_arms_scaled.osim',sep='')

#------------------------------------------------------------------#
logdebug('loading antropometry...');
antropometry = scan(file = paste(path,'/data/',athlete,'/antrop.txt',sep=''), what = character())
sex <- antropometry[2]
weight <- as.numeric(antropometry[4])
height <- as.numeric(antropometry[6])

#------------------------------------------------------------------#
logdebug('loading source data files (pos, vel, acc, body_forces, inverse_dynamics, mot)...');
pos_source <- read.table(paste(path,'/data/',athlete,'/gait_reduced_nonscaled-scaled_BodyKinematics_pos_global.sto',sep=''), skip=18, header = TRUE)
vel_source <- read.table(paste(path,'/data/',athlete,'/gait_reduced_nonscaled-scaled_BodyKinematics_vel_global.sto',sep=''), skip=18, header = TRUE)
acc_source <- read.table(paste(path,'/data/',athlete,'/gait_reduced_nonscaled-scaled_BodyKinematics_acc_global.sto',sep=''), skip=18, header = TRUE)
body_forces_source <- read.table(paste(path,'/data/',athlete,'/', experiment, '_body_forces_at_joints.sto',sep=''), skip=6, header = TRUE)
inverse_dynamics_source <- read.table(paste(path,'/data/',athlete,'/', experiment, '_inverse_dynamics.sto',sep=''), skip=6, header = TRUE)
mot_source <- read.table(paste(path,'/data/',athlete,'/', experiment, '.mot',sep=''), skip=10, header = TRUE)
ext_forces_source <- read.table(paste(path,'/data/',athlete,'/', experiment, '_ext_forces.mot',sep=''), skip=10, header = TRUE)
frames <- length(mot_source$time)
logdebug(paste('loaded', frames, 'frames'))

#------------------------------------------------------------------#
logdebug('determining the phases of the jump...')

center_of_mass_Y_delta = c(pos_source$center_of_mass_Y, pos_source$center_of_mass_Y[frames]) - c(pos_source$center_of_mass_Y[1], pos_source$center_of_mass_Y)
center_of_mass_Y_delta = center_of_mass_Y_delta[2:(frames-1)]
center_of_mass_X_delta = c(pos_source$center_of_mass_X, pos_source$center_of_mass_X[frames]) - c(pos_source$center_of_mass_X[1], pos_source$center_of_mass_X)
center_of_mass_X_delta = center_of_mass_X_delta[2:(frames-1)]
center_of_mass_Z_delta = c(pos_source$center_of_mass_Z, pos_source$center_of_mass_Z[frames]) - c(pos_source$center_of_mass_Z[1], pos_source$center_of_mass_Z)
center_of_mass_Z_delta = center_of_mass_Z_delta[2:(frames-1)]

if (save_to_file)
{
	png_file = paste(path,'/data/',athlete,'/', experiment, '_plot_1_center_of_mass_delta_raw.png', sep = "")
	png(png_file, width=1600, height=1000, units="px", res=106)
}
plot(center_of_mass_Y_delta, ann=FALSE, type="l", col="red", lwd=2)
lines(x=seq(1,frames-2),center_of_mass_X_delta, col='darkgreen', lwd=1)
lines(x=seq(1,frames-2),center_of_mass_Z_delta, col='blue', lwd=1)
lines(x=c(-10000,10000), y=c(0,0), col='black')
title(main=paste("Center of Mass movement (delta) over time", sep=''))
title(ylab="Delta (m)")
title(xlab=paste("Frames", sep=""))
legend("topleft", c("pos_source$center_of_mass Y delta", "pos_source$center_of_mass X delta","pos_source$center_of_mass Z delta"),
   col=c('red', "darkgreen","blue"), lty=c(1,1,1), lwd=c(2,1,1));
if(save_to_file) dev.off();

#if (save_to_file)
#{
#	png_file = paste(path,'/data/',athlete,'/', experiment, '_plot_1_center_of_mass_raw.png', sep = "")
#	png(png_file, width=1600, height=1000, units="px", res=106)
#}
#plot(pos_source$center_of_mass_Y, ann=FALSE, type="l", col="red", lwd=2)
#title(main=paste("Center of Mass movement over time", sep=''))
#title(ylab="Hieght (m)")
#title(xlab=paste("Frames", sep=""))
#if(save_to_file) dev.off();

logdebug('detecting ground release point...')
combined_vertical_force = ext_forces_source$X1_Force_Y + ext_forces_source$X2_Force_Y
zero_force = combined_vertical_force[length(combined_vertical_force)]
force_tolerance = 0.1
force_max_time = min(ext_forces_source$time[combined_vertical_force>=max(combined_vertical_force)])
force_max_frame = frames-sum(mot_source$time>=force_max_time)-2
fitting_times = ext_forces_source$time[(combined_vertical_force<=zero_force*(1+ force_tolerance))]
eject_time = min(fitting_times[fitting_times >= force_max_time])
eject_frame = frames-sum(mot_source$time>=eject_time)-2
logdebug(paste("calculated platform eject time (sec): ", eject_time))
logdebug(paste("calculated platform eject frame: ", eject_frame))

#smoothing
center_of_mass_Y_delta_smoothed = smooth.spline(center_of_mass_Y_delta, spar=0.4)$y
center_of_mass_X_delta_smoothed = smooth.spline(center_of_mass_X_delta, spar=0.4)$y
center_of_mass_Z_delta_smoothed = smooth.spline(center_of_mass_Z_delta, spar=0.4)$y
center_of_mass_Y_smoothed = smooth.spline(pos_source$center_of_mass_Y, spar=0.4)$y

logdebug('detecting movement point (COM goes down)...')
movement_tolerance = 7e-5
frames_array = seq(1, frames)
movement_frame = min(frames_array[abs(center_of_mass_Y_delta_smoothed)> movement_tolerance]) - 2
movement_time = mot_source$time[movement_frame+1]
logdebug(paste("calculated movement start time (sec): ", movement_time))
logdebug(paste("calculated movement start frame: ", movement_frame))

logdebug('detecting lowest COM point...')
lowest_time = min(pos_source$time[center_of_mass_Y_smoothed <= min(center_of_mass_Y_smoothed)])
lowest_frame = min(frames_array[center_of_mass_Y_smoothed <= min(center_of_mass_Y_smoothed)])
logdebug(paste("calculated lowest COM time (sec): ", lowest_time))
logdebug(paste("calculated lowest COM frame: ", lowest_frame))

logdebug('detecting highest COM point...')
highest_frame = min(frames_array[pos_source$center_of_mass_Y==max(pos_source$center_of_mass_Y)])
highest_time = mot_source$time[highest_frame]
logdebug(paste("calculated highest COM time (sec): ", highest_time))
logdebug(paste("calculated highest COM frame: ", highest_frame))

logdebug('normalizing files (pos, vel, acc, body_forces, inverse_dynamics, mot)...')

normalize_file <- function(data, out_name)
{
	logdebug(paste('normalizing: ', out_name, sep=''))

	columns = attributes(data)[1]$names
	n_columns = length(columns)

	source_array = slot(data, '.Data')
	target_array = matrix(nrow=400, ncol=n_columns)

	start_frame = movement_frame
	end_frame = eject_frame

	new_frames = seq(start_frame, end_frame, length.out = 400)

	for (i in seq(1, n_columns))
	{
		column = columns[i]

		#logdebug(paste('processing column ',i,' - ', column, sep=''))

		array = source_array[i][[1]]

		array_spl = smooth.spline(array)
		target_array[,i] = predict(array_spl, new_frames)$y
	}

	write.table(target_array, file = out_name, append = FALSE, col.names = columns, row.names=FALSE, dec=',', sep=';')
	#WriteXLS(as.data.frame(target_array), ExcelFileName = out_name, col.names = columns, row.names=FALSE, AdjWidth=TRUE, BoldHeaderRow=TRUE, FreezeRow=1)
}

normalize_force_file <- function(data, out_name)
{
	logdebug(paste('normalizing force: ', out_name, sep=''))

	columns = attributes(data)[1]$names
	n_columns = length(columns)

	source_array = slot(data, '.Data')
	target_array = matrix(nrow=400, ncol=n_columns)

	frames_force = seq(1, length(data$time))
	start_frame = min(frames_force[data$time >= movement_time])
	end_frame = min(frames_force[data$time >= eject_time])

	new_frames = seq(start_frame, end_frame, length.out = 400)

	for (i in seq(1, n_columns))
	{
		column = columns[i]

		#logdebug(paste('processing column ',i,' - ', column, sep=''))

		array = source_array[i][[1]]

		array_spl = smooth.spline(array)
		target_array[,i] = predict(array_spl, new_frames)$y
	}

	write.table(target_array, file = out_name, append = FALSE, col.names = columns, row.names=FALSE, dec=',', sep=';')
	#WriteXLS(as.data.frame(target_array), ExcelFileName = out_name, col.names = columns, row.names=FALSE, AdjWidth=TRUE, BoldHeaderRow=TRUE, FreezeRow=1)
}

normalize_file(pos_source, paste(path,'/data/',athlete,'/',experiment,'_normalized_1_pos.csv',sep=''))
normalize_file(vel_source, paste(path,'/data/',athlete,'/',experiment,'_normalized_2_vel.csv',sep=''))
normalize_file(acc_source, paste(path,'/data/',athlete,'/',experiment,'_normalized_3_acc.csv',sep=''))
normalize_file(body_forces_source, paste(path,'/data/',athlete,'/',experiment,'_normalized_4_body_forces.csv',sep=''))
normalize_file(inverse_dynamics_source, paste(path,'/data/',athlete,'/',experiment,'_normalized_5_inverse_dynamics.csv',sep=''))
normalize_file(mot_source, paste(path,'/data/',athlete,'/',experiment,'_normalized_6_mot.csv',sep=''))
normalize_force_file(ext_forces_source, paste(path,'/data/',athlete,'/',experiment,'_normalized_7_ext_forces.csv',sep=''))

#TODO - ext forces normalize as well, but needs to be filtered differently as it has different timescale
logdebug('normalization done.')

logdebug('loading XML model to get segment weights')
model_xml = xmlParse(file = model_xml_file)

get_segment_mass <- function(segment)
{
	#OpenSimDocument -> Model -> BodySet -> objects -> Body name = "tibia_r"
   seg = getNodeSet(model_xml, paste("//Body[@name='",segment,"']/mass",sep=''))
	value = xmlValue(seg[[1]])
	as.numeric(value)
}

logdebug('loading normalized files')
pos_smoothed <- read.table(paste(path,'/data/',athlete,'/',experiment,'_normalized_1_pos.csv',sep=''), header = TRUE, sep=";", dec=',')
vel_smoothed <- read.table(paste(path,'/data/',athlete,'/',experiment,'_normalized_2_vel.csv',sep=''), header = TRUE, sep=";", dec=',')
acc_smoothed <- read.table(paste(path,'/data/',athlete,'/',experiment,'_normalized_3_acc.csv',sep=''), header = TRUE, sep=";", dec=',')
body_forces_smoothed <- read.table(paste(path,'/data/',athlete,'/',experiment,'_normalized_4_body_forces.csv',sep=''), header = TRUE, sep=";", dec=',')
inverse_dynamics_smoothed <- read.table(paste(path,'/data/',athlete,'/',experiment,'_normalized_5_inverse_dynamics.csv',sep=''), header = TRUE, sep=";", dec=',')
mot_smoothed <- read.table(paste(path,'/data/',athlete,'/',experiment,'_normalized_6_mot.csv',sep=''), header = TRUE, sep=";", dec=',')
ext_forces_smoothed <- read.table(paste(path,'/data/',athlete,'/',experiment,'_normalized_7_ext_forces.csv',sep=''), header = TRUE, sep=";", dec=',')

# 1 frame - beginning of ammortization phase, 400 - end of push-off
phase_split = round((lowest_frame - movement_frame) / (eject_frame - movement_frame) * 400, digits=0)

# Жесткость

amort_com_max = max(pos_smoothed$center_of_mass_Y[seq(1, phase_split)])
amort_com_min = min(pos_smoothed$center_of_mass_Y[seq(1, phase_split)])

max_sum_of_left_and_right_force_Y = max(ext_forces_smoothed$X1_Force_Y + ext_forces_smoothed$X2_Force_Y)
max_avg_of_left_and_right_force_Y = max((ext_forces_smoothed$X1_Force_Y + ext_forces_smoothed$X2_Force_Y)/2)

amort_stiffness_K_sum = max_sum_of_left_and_right_force_Y / (amort_com_max - amort_com_min)
amort_stiffness_K_avg = max_avg_of_left_and_right_force_Y / (amort_com_max - amort_com_min)

# Энергии

Ekin1 = weight * (((vel_smoothed$center_of_mass_X*vel_smoothed$center_of_mass_X + vel_smoothed$center_of_mass_Y*vel_smoothed$center_of_mass_Y + vel_smoothed$center_of_mass_Z*vel_smoothed$center_of_mass_Z)*pi/180)^2) * 0.5

I_foot = ((get_segment_mass("toes_r") + get_segment_mass("calcn_r") + get_segment_mass("talus_r"))/660.49)+((get_segment_mass("toes_r") + get_segment_mass("calcn_r") + get_segment_mass("talus_r"))/4716100)
I_shank = ((get_segment_mass("tibia_r"))/789.61)+((get_segment_mass("tibia_r"))/278784)
I_thigh = ((get_segment_mass("femur_r"))/712.89)+((get_segment_mass("femur_r"))/291600)

Ekin_foot_right = I_foot * (((vel_smoothed$calcn_r_Oz)*pi/180)^2)*0.5
Ekin_shank_right = I_shank * (((vel_smoothed$tibia_r_Oz)*pi/180)^2)*0.5
Ekin_thigh_right = I_thigh * (((vel_smoothed$femur_r_Oz)*pi/180)^2)*0.5

Ekin2 = Ekin_foot_right + Ekin_shank_right + Ekin_thigh_right
Ekin = Ekin1 + (2 * Ekin2)

Epot = weight * 9.81 * (pos_smoothed$center_of_mass_Y + 0.398)

Emech = Ekin + Epot

# Моменты

Moment_knee_right = inverse_dynamics_smoothed$knee_angle_r_moment
Moment_ankle_right = inverse_dynamics_smoothed$ankle_angle_r_moment
Moment_hip_right = inverse_dynamics_smoothed$hip_flexion_r_moment
Moment_right_sum = Moment_knee_right + Moment_ankle_right + Moment_hip_right

# Мощности

Knee_angular_velocity_right = (c(mot_smoothed$knee_angle_r) - c(mot_smoothed$knee_angle_r[1],mot_smoothed$knee_angle_r[seq(1,399)])) * pi / 180 / ((eject_time-movement_time)/400)
Power_knee_right = Moment_knee_right * Knee_angular_velocity_right

Ankle_angular_velocity_right = (c(mot_smoothed$ankle_angle_r) - c(mot_smoothed$ankle_angle_r[1],mot_smoothed$ankle_angle_r[seq(1,399)])) * pi / 180 / ((eject_time-movement_time)/400)
Power_ankle_right = Moment_ankle_right * Ankle_angular_velocity_right

Hip_angular_velocity_right = (c(mot_smoothed$hip_flexion_r) - c(mot_smoothed$hip_flexion_r[1],mot_smoothed$hip_flexion_r[seq(1,399)])) * pi / 180 / ((eject_time-movement_time)/400)
Power_hip_right = Moment_hip_right * Hip_angular_velocity_right

Power_sum = abs(Power_knee_right) + abs(Power_ankle_right) + abs(Power_hip_right)

#фаза амортизации

Emech_max = max(Emech[seq(1, phase_split)])
Emech_min = min(Emech[seq(1, phase_split)])
delta_E_amort = Emech_max - Emech_min

Moment_max = max(Moment_right_sum[seq(1, phase_split)])
Moment_min = min(Moment_right_sum[seq(1, phase_split)])
delta_moment_amort = Moment_max - Moment_min

Power_sum_max = max(Power_sum[seq(1, phase_split)])
Power_sum_min = min(Power_sum[seq(1, phase_split)])
delta_power_amort = Power_sum_max - Power_sum_min

#фаза отталкивания

Emech_max = max(Emech[seq(phase_split+1, 400)])
Emech_min = min(Emech[seq(phase_split+1, 400)])
delta_E_ott = Emech_max - Emech_min

Moment_max = max(Moment_right_sum[seq(phase_split+1, 400)])
Moment_min = min(Moment_right_sum[seq(phase_split+1, 400)])
delta_moment_ott = Moment_max - Moment_min

Power_sum_max = max(Power_sum[seq(phase_split+1, 400)])
Power_sum_min = min(Power_sum[seq(phase_split+1, 400)])
delta_power_ott = Power_sum_max - Power_sum_min

# TODO save to file

power_and_moments_file = paste(path,'/data/',athlete,'/',experiment,'_normalized_8_RCALC_power_and_moments.csv',sep='')
columns = c(
'Ekin1',
'Ekin_foot_right',
'Ekin_shank_right',
'Ekin_thigh_right',
'Ekin2',
'Emech',
'Moment_knee_right',
'Moment_ankle_right',
'Moment_hip_right',
'Moment_right_sum',
'Knee_angular_velocity_right',
'Power_knee_right',
'Ankle_angular_velocity_right',
'Power_ankle_right',
'Hip_angular_velocity_right',
'Power_hip_right',
'Power_sum'
)
target_array = matrix(nrow=400,ncol=length(columns))
target_array[,1] = Ekin1
target_array[,2] = Ekin_foot_right
target_array[,3] = Ekin_shank_right
target_array[,4] = Ekin_thigh_right
target_array[,5] = Ekin2
target_array[,6] = Emech
target_array[,7] = Moment_knee_right
target_array[,8] = Moment_ankle_right
target_array[,9] = Moment_hip_right
target_array[,10] = Moment_right_sum
target_array[,11] = Knee_angular_velocity_right
target_array[,12] = Power_knee_right
target_array[,13] = Ankle_angular_velocity_right
target_array[,14] = Power_ankle_right
target_array[,15] = Hip_angular_velocity_right
target_array[,16] = Power_hip_right
target_array[,17] = Power_sum
write.table(target_array, file = power_and_moments_file, append = FALSE, col.names = columns, row.names=FALSE, dec=',', sep=';')

summary_file = paste(path,'/data/',athlete,'/',experiment,'_normalized_9_RCALC_summary.csv',sep='')
target_array = matrix(nrow=2,ncol=8)
target_array[1,1] = 'Энергия_фаза амортизации'
target_array[1,2] = 'Момент_фаза амортизации'
target_array[1,3] = 'Мощность_фаза амортизации'
target_array[1,4] = 'Показатель жесткости'
target_array[1,5] = 'Показатель жесткости_для одной ноги'
target_array[1,6] = 'Энергия_фаза отталкивания'
target_array[1,7] = 'Момент_фаза отталкивания'
target_array[1,8] = 'Мощность_фаза отталкивания'
target_array[2,1] = delta_E_amort
target_array[2,2] = delta_moment_amort
target_array[2,3] = delta_power_amort
target_array[2,4] = amort_stiffness_K_sum
target_array[2,5] = amort_stiffness_K_avg
target_array[2,6] = delta_E_ott
target_array[2,7] = delta_moment_ott
target_array[2,8] = delta_power_ott
write.table(target_array, file = summary_file, append = FALSE, col.names = FALSE, row.names=FALSE, dec=',', sep=';')

if (save_to_file)
{
	png_file = paste(path,'/data/',athlete,'/', experiment, '_plot_2_jump_phases.png', sep = "")
	png(png_file, width=1600, height=1000, units="px", res=106)
}
plot(center_of_mass_Y_delta_smoothed, ann=FALSE, type="l", col="red", lwd=2)
lines(x=seq(1,frames-2),center_of_mass_X_delta_smoothed, col='darkgreen', lwd=1)
lines(x=seq(1,frames-2),center_of_mass_Z_delta_smoothed, col='blue', lwd=1)
lines(x=c(-10000,10000), y=c(0,0), col='black')
title(main=paste("Jump Phases Breakdown (Using smoothed Center of Mass + Force Reactions)", sep=''))
title(ylab="Delta (m)")
title(xlab=paste("Frames", sep=""))
legend("topleft", c("center_of_mass VERTICAL delta smoothed", "center_of_mass TRANSVERSAL delta smoothed","center_of_mass LONGITUDINAL delta smoothed",
paste("Frame ", movement_frame, " (" , movement_time, " sec): start of movement (Phase 1 begins)", sep=""), paste("Frame ", lowest_frame, " (" , lowest_time, " sec): center of mass it at lowest point (Phase 1 ends, 2 begins)",sep=''), paste("Frame ", eject_frame, " (" , eject_time, " sec): ejecting from the platform (Phase 2 ends, Phase 3 begins)", sep=''), paste("Frame ", highest_frame, " (" , highest_time, " sec): center of mass is at highest point (Phase 3 ends)", sep='')),
   col=c('red', "darkgreen","blue", "orange", "brown", "purple", "darkgreen"), lty=c(1,1,1,2,2,2,2), lwd=c(2,1,1,2,2,2,2));

top = max(center_of_mass_Y_delta_smoothed)
bottom = min(center_of_mass_Y_delta_smoothed)
lines(x=c(eject_frame, eject_frame), y=c(bottom, top), lty=2, lwd=2, col="purple")
lines(x=c(movement_frame, movement_frame), y=c(bottom, top*0.6), lty=2, lwd=2, col="orange")
lines(x=c(lowest_frame, lowest_frame), y=c(bottom, top), lty=2, lwd=2, col="brown")
lines(x=c(highest_frame, highest_frame), y=c(bottom, top), lty=2, lwd=2, col="darkgreen")
if(save_to_file) dev.off();

#------------------------------------------------------------------#
logdebug('plotting knee joint moment/velocity angle...')
knee_angle_r_moment = inverse_dynamics_source$knee_angle_r_moment
angular_velocity_knee_Oz = vel_source$femur_r_Oz - vel_source$tibia_r_Oz
knee_angle_r_moment_smoothed = smooth.spline(knee_angle_r_moment)$y
angular_velocity_knee_Oz_smoothed = smooth.spline(angular_velocity_knee_Oz)$y

if (save_to_file)
{
	png_file = paste(path,'/data/',athlete,'/', experiment, '_plot_3_knee_moment_vs_angular_velocity.png', sep = "")
	png(png_file, width=1600, height=1000, units="px", res=106)
}
plot(x=knee_angle_r_moment_smoothed, y=angular_velocity_knee_Oz_smoothed, ann=FALSE, type="l", col="black", lwd=2)
points(x= knee_angle_r_moment_smoothed[1], y = angular_velocity_knee_Oz_smoothed[1], pch=17, col="grey", cex=3)
points(x= knee_angle_r_moment_smoothed[movement_frame], y = angular_velocity_knee_Oz_smoothed[movement_frame], pch=18, col="orange", cex=3)
points(x= knee_angle_r_moment_smoothed[lowest_frame], y = angular_velocity_knee_Oz_smoothed[lowest_frame], pch=18, col="brown", cex=3)
points(x= knee_angle_r_moment_smoothed[eject_frame], y = angular_velocity_knee_Oz_smoothed[eject_frame], pch=18, col="purple", cex=3)
points(x= knee_angle_r_moment_smoothed[frames], y = angular_velocity_knee_Oz_smoothed[frames], pch=19, col="red", cex=3)
points(x= knee_angle_r_moment_smoothed[highest_frame], y = angular_velocity_knee_Oz_smoothed[highest_frame], pch=17, col="darkgreen", cex=3)

title(main=paste("Knee Angle Moment vs Angular Velocity", sep=''))
title(ylab="Angular Velocity")
title(xlab=paste("Angle Moment", sep=""))
legend("bottomleft", c("start of experiment",
paste("Frame ", movement_frame, " (" , movement_time, " sec): start of movement (Phase 1 begins)", sep=""), paste("Frame ", lowest_frame, " (" , lowest_time, " sec): center of mass has lowest Y (Phase 1 ends, 2 begins)",sep=''), paste("Frame ", eject_frame, " (" , eject_time, " sec): ejecting from the platform (Phase 2 ends)",sep=''), paste("Frame ", highest_frame, " (" , highest_time, " sec): center of mass is at highest point (Phase 3 ends)", sep=''), "end of experiment"),
   col=c("grey", "orange", "brown", "purple", "darkgreen", "red"), lty=c(1,1,1,1,1,1), pch=c(17,18,18,18,17,19));
if(save_to_file) dev.off();


#-------------------------------------------------------------------------------
# Licence:
# Copyright (c) 2012-2017 Luzzi Valerio for Gecosistema S.r.l.
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.
#
# Name:
# Purpose:     Kriging
#
# Author:      Luzzi Valerio
#
# Created:     05/09/2017
#-------------------------------------------------------------------------------

#SRS =  "+proj=tmerc +lat_0=0 +lon_0=9 +k=0.9996 +x_0=500092 +y_0=-3999800 +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs"
#
#Default SRS= epsg:3857 if not defined in shape
SRS = "+proj=merc +a=6378137 +b=6378137 +lat_ts=0.0 +lon_0=0.0 +x_0=0.0 +y_0=0 +k=1.0 +units=m +nadgrids=@null +wktext  +no_defs"
#------------------------------------------------------------------------------
#	string functions
#------------------------------------------------------------------------------
len<-function(arr)length(arr)
contains<-function(text,search){return(length(grep(search,text))>0)}
alltrim <- function (text) gsub("^\\s+|\\s+$", "",text)
upper<-function(text)toupper(text)
lower<-function(text)tolower(text)
left<-function(text,n)substr(text,1,n)
juststem<-function(text) sub("^([^.]*).*", "\\1", basename(text))
justpath<-function(text)dirname(text)
justext<-function(text) substr(text,nchar(text)-2,nchar(text))
forceext<-function(text,ext) sub("^([^.]*).*", paste("\\1",ext,sep="."), text)
mkdirs<-function(text)dir.create(text,recursive=TRUE,showWarnings = FALSE)
isDate<-function(text){res = tryCatch(length(as.Date(text))>0,error=function(e){return(FALSE)});return(res)}
logger<-function(text){f=file("log.txt",open="at");writeLines(text,f);print(text);close(f);}
progression<-function(text,perc){f=file("interp.progress",open="at");writeLines(text,f);print(text);close(f);}

#------------------------------------------------------------------------------
#	CreateMask
#------------------------------------------------------------------------------
CreateMask<-function(piezo,buffer=200,pixelsize=10){

	bbox = bbox(piezo)
	minx = bbox[1]-buffer
	miny = bbox[2]-buffer
	maxx = bbox[3]+buffer
	maxy = bbox[4]+buffer
	x= seq(minx,maxx,pixelsize)
	y= seq(miny,maxy,pixelsize)

	grid = expand.grid(X=x,Y=y)
	grid$Z = 0.0
	gridded(grid)=~X+Y
	proj4string(grid)=proj4string(piezo)
	#writeGDAL(grid["Z"],"buffer.tif")
	return(grid)
}

#------------------------------------------------------------------------------
#	DetectFormulaUK -  Formula for universal Kriging
#------------------------------------------------------------------------------
DetectFormulaUK <- function( prec ){

	#Creo la formula per l'Universal Kriging
	#Cerco il nome della variabile dipendente
	VALUE = "VALUE"
	cn  = names( prec )  #Nomi dei campi
	candidates = c("VALUE","value")
	for(varname in candidates){
		if ( isTRUE(grep(varname,cn)) ){
			VALUE = varname
			break
		}
	}

	#Creo la formula per l'Universal Kriging
	cn = cn[cn!=VALUE] #Rimuovo "VALUE" non deve comparire a dx nella formula
	f = paste(cn,collapse="+")
	f = paste(VALUE,"~",f)
	f = as.formula(f)
	return(f)
}

#------------------------------------------------------------------------------
#	Kriging | IDW
#------------------------------------------------------------------------------
Kriging <- function( fileshp, filetif="", sformula="VALUE~1", type ="AUTO", pixelsize=100, psill=1, range=900, nugget=1, buffer=0, RemoveNegativeValues=FALSE)
{
    prec = readOGR(fileshp,juststem(fileshp))
    if (is.na(proj4string(prec)))
        proj4string(prec) = CRS(SRS)

	print(paste("Number of points to krige",length(prec)))

	dem <- CreateMask(prec, buffer, pixelsize)
	xy  <- as.data.frame(coordinates(dem))
	dem@data$x<-xy$X
	dem@data$y<-xy$Y

	#Rinomino la banda1 in z
	colnames(dem@data)[1]="z"

	#fieldname (in genere VALUE)
	formula   = as.formula(sformula)
	fieldname = alltrim(strsplit(sformula,"~")[[1]][1])

	#Remove na from prec$VALUE
	prec<-prec[!is.na(prec[[fieldname]]),]

	#Overlay prendo il valori nei punti delle stazioni
	ov<-over(prec,dem)
	prec$x <- ov$x
	prec$y <- ov$y
	prec$z <- ov$z

	#print(prec)

	#UniversalKriging
	if (type =="UK"){
	  # trend model
	  #sformula ="VALUE~X+Y+Z"
	  #formula = as.formula(sformula)    #else fm = DetectFormulaUK(prec@data)
	  lm.prec <- lm(fm, prec)
	  formula_optimal <-step(lm.prec)
	  residui = residuals(fm)

	  null.vgm <- vgm(var(residui), "Sph", sqrt(areaSpatialGrid(dem))/4, nugget=0) # initial parameters
	  vgm_r    <- fit.variogram(variogram(residui~1, prec) ,model=null.vgm)
	  prec_ok  <- krige(as.formula(formula_optimal), locations=prec, newdata=dem, model=vgm_r)
	  prediction = prec_ok[1]
	}

	#Automap
	if (type == "AUTO"){
	  library(automap)
		prec_ok <-autoKrige(formula,prec,dem)
		prec_ok = prec_ok$krige_output
		prediction = prec_ok[1]
	}
	#Ordinary Kriging
	if ( type =="OK"){
	  #psill,range,nugget are auto calculated by fitting the variogram

	  #this are initial parameters to suggest an initial variogram model to fit.variogram algorithm
    psill = var(prec[[fieldname]]) #variance of prec$VALUE
    range = sqrt(areaSpatialGrid(dem))/4
    nugget = 0

		null.vgm = vgm(psill, "Sph", range, nugget)
		vgm_optimal = fit.variogram(variogram(formula, prec), model=null.vgm )
		#vgm_optimal is the best variogram model that fit the empirical variogram data

		#print(vgm_optimal)
		#print("-----------------------")

		prec_ok <- krige(formula, locations=prec, newdata=dem, model=vgm_optimal)
		prediction = prec_ok[1]
	}
	#Ordinary Kriging
	if ( type =="OK-ADVANCED"){
	  #psill,range,nugget are chosen from user passed by arg
	  vgm_optimal<- vgm(psill, "Sph", range, nugget)

	  print(vgm_optimal)
	  print("-----------------------")

		prec_ok <- krige(formula, locations=prec, newdata=dem, model=vgm_optimal)
		prediction = prec_ok[1]
	}
	#Inverse Distance
	if( type =="IDW2"){
    prec_ok <- idw(formula, prec, dem,idp=2.0,maxdist=Inf)
    prediction = prec_ok[1]
	}
	mkdirs(justpath(filetif))

	#Remove negative values!!!!
	if (RemoveNegativeValues){
		prediction@data[prediction@data<0]=0}

	writeGDAL(prediction,filetif)
	return(filetif)
}

#------------------------------------------------------------------------------
#	Main
#------------------------------------------------------------------------------
Main <- function(){
  #Suppress Warning
  options(warn=-1)

	#Getting command arguments
	args <- commandArgs(trailingOnly = TRUE)
	res = FALSE

	#load required libraries
	suppressPackageStartupMessages(library(rgdal))
	library(sp)
	library(rgdal)
	library(gstat)
	#library(tools)

	#Test
	filetif = ""
	if (length(args)==0){

		setwd("c:\\Users\\vlr20\\Dektop\\FeFlow\\results")
		fileshp		= "okrige-759066-2015-08-01.shp"
		filetif   = forceext(fileshp,"tif")

		method = "OK"
		sformula ="value~1"
		psill = 1
		range = 900
		nugget = 1
		pixelsize=10
		buffer = 5000
		filetif = Kriging(fileshp, filetif, sformula, method, pixelsize, psill, range, nugget, buffer, RemoveNegativeValues=FALSE)
	}
	if (length(args)==10){

		Sys.getenv()

		fileshp		  = Sys.getenv("FILESHP")
		filetif		  = Sys.getenv("FILETIF")
		sformula      = Sys.getenv("SFORMULA")
		method		  = Sys.getenv("METHOD")  #AUTO|UK|UK-AutoKrige|OK|OK-ADVANCED|IDW2
		pixelsize     = as.numeric(Sys.getenv("PIXELSIZE"))

		psill         = as.numeric(Sys.getenv("PSILL"))
		range         = as.numeric(Sys.getenv("RANGE"))
		nugget        = as.numeric(Sys.getenv("NUGGET"))
		buffer        = as.numeric(Sys.getenv("BUFFER"))
		RemoveNegativeValues = as.logical(Sys.getenv("REMOVENEGATIVEVALUES")) #remove non-sense negative values caused by interpolation

		#print(fileshp)
		#print(method)
		#print(pixelsize)
		#print(sformula)
		#print(RemoveNegativeValues)
		#comment next 2 lines
		# ...
		#pixelsize	=50
		#Pay attention here!!
		filetif = Kriging(fileshp, filetif, sformula, method, pixelsize, psill, range, nugget, buffer, RemoveNegativeValues)
	}

	#res = paste('{"success":TRUE,"filename":"',filetif,'"}',sep="")
	return(filetif)
}

#------------------------------------------------------------------------------
#	Main-loop launch
#------------------------------------------------------------------------------
##libray = "D:\\Program Files (x86)\\SICURA\\apps\\common\\bin\\R\\R-3.3.2\\library"
##install.packages("sp",     lib=libray)
##install.packages("rgdal",  lib=libray)
##install.packages("gstat",  lib=libray)
##install.packages("automap",  lib=libray)
##install.packages("tools",  lib=libray)
print(Main())


# 3. faza: Vizualizacija podatkov

# Funkcija za prikaz napredka discipline

Graf_napredka <- function(razdalja, bazen){
  ggplot(podatki %>% filter(Distance == razdalja, Pool == bazen) %>%
           mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
           group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)),
         aes(x=zaokrozeni_datumi, y=Time)) +
    geom_line() + ylab("Čas plavanja") + xlab("Datum")
}

# Funkcija za prikaz napredka plavalca pri neki disciplini

Graf_plavalca <- function(razdalja, bazen, ime){
  ggplot(podatki %>% filter(Distance == razdalja, Pool == bazen, Name == ime) %>%
           mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
           group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)),
         aes(x=zaokrozeni_datumi, y=Time), colour = "steelblue", size = 1) +
    geom_line() + ylab("Swim Time") + xlab("Date")
}

# Primerjava kratkih in dolgih bazenov

Graf_LCM_vs_SCM <- function(razdalja){
  SCM_podatki <- podatki %>% filter(Distance == razdalja, Pool == "SCM") %>%
    mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
    group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)) %>%
    mutate(Pool="SCM")

  LCM_podatki <- podatki %>% filter(Distance == razdalja, Pool == "LCM") %>%
    mutate(zaokrozeni_datumi=Swim_date-day(Swim_date)+1) %>%
    group_by(zaokrozeni_datumi) %>% summarise(Time=min(Time)) %>%
    mutate(Pool="LCM")

  ime_grafa <- paste("Primerjava dolgih in kratkih bazenov pri", as.character(razdalja), "metrov delfin")

  LCM_vs_SCM <- rbind(SCM_podatki, LCM_podatki)

  ggplot(LCM_vs_SCM) +
    geom_line() +
    aes(x = zaokrozeni_datumi, y = Time, col = Pool) +
    ylab("Čas plavanja [sekunde]") + xlab("Datum") + labs(title = ime_grafa)
}

# Osebni rekordi plavalca

Osebni_rekordi_plavalca <- function(ime){
  vsi_casi <- podatki %>% filter(Name == ime)
  osebni_rekordi <- vsi_casi %>% group_by(Distance, Pool) %>% summarise(Time=min(Time))
  osebni_rekordi
}

# Najboljse tekme (stevilo novih casov na tekmi) po disciplini

Najboljse_tekme <- function(dolzina, bazen){
  ggplot(as.data.frame(table((podatki %>%
                                filter(Distance == dolzina, Pool == bazen)) %>%
                               group_by(Meet_name)%>%
                               summarise(Meet_name))),
         aes(x=reorder(Var1, Freq), y=Freq)) +
    geom_bar(stat = "identity", fill="steelblue") +
    coord_flip() +
    labs(x = "Meet name", y = "Number of top 200 results")
}

# Koliko tekem je bilo kje

tekme_na_drzavo <- as.data.frame(table(dogodki %>% group_by(Meet_country) %>% summarise(Meet_country)))

graf_tekme_na_drzavo <- ggplot(tekme_na_drzavo,
                          aes(x=reorder(Var1, -Freq), y=Freq)) +
  geom_bar(stat = "identity", fill="steelblue") +
  labs(x = "Country", y = "Number of competitions")

# Uvozim zemljevid za število tekem

zemljevid <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/110m_cultural.zip",
                             "ne_110m_admin_0_countries", encoding="UTF-8") %>%
  fortify()

colnames(zemljevid)[12] <- "Var1"

zemljevid$Var1 <- gsub("US1", "USA", zemljevid$Var1)
zemljevid$Var1 <- gsub("AU1", "AUS", zemljevid$Var1)
zemljevid$Var1 <- gsub("COG", "CGO", zemljevid$Var1)
zemljevid$Var1 <- gsub("CH1", "CHN", zemljevid$Var1)
zemljevid$Var1 <- gsub("HRV", "CRO", zemljevid$Var1)
zemljevid$Var1 <- gsub("DN1", "DEN", zemljevid$Var1)
zemljevid$Var1 <- gsub("FI1", "FIN", zemljevid$Var1)
zemljevid$Var1 <- gsub("FR1", "FRA", zemljevid$Var1)
zemljevid$Var1 <- gsub("GB1", "GBR", zemljevid$Var1)
zemljevid$Var1 <- gsub("DEU", "GER", zemljevid$Var1)
zemljevid$Var1 <- gsub("GRC", "GRE", zemljevid$Var1)
zemljevid$Var1 <- gsub("IDN", "INA", zemljevid$Var1)
zemljevid$Var1 <- gsub("IS1", "ISN", zemljevid$Var1)
zemljevid$Var1 <- gsub("MYS", "MAS", zemljevid$Var1)
zemljevid$Var1 <- gsub("NL1", "NED", zemljevid$Var1)
zemljevid$Var1 <- gsub("NZ1", "NZL", zemljevid$Var1)
zemljevid$Var1 <- gsub("ZAF", "RSA", zemljevid$Var1)
zemljevid$Var1 <- gsub("CHE", "SUI", zemljevid$Var1)
zemljevid$Var1 <- gsub("ARE", "UAE", zemljevid$Var1)

zemljevid_tekem <- ggplot() +
  geom_polygon(data=right_join(tekme_na_drzavo, zemljevid, by="Var1"),
               aes(x=long, y=lat, group=group, fill=Freq)) +
  xlab("") +
  ylab("") +
  ggtitle("Zemljevid tekem po državah") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#FCDADA', high='#970303', limits=c(1,35)) +
  labs(fill="Število tekem")

# plot(zemljevid_tekem)

# Najštevilčnejše reprezentance delfinistov

stevilo_plavalcev_iz_posamicnih_drzav <- as.data.frame(table(plavalci %>% group_by(Country) %>% summarise(Country)))

graf_stevila_plavalcev_iz_posamicnih_drzav <- ggplot(stevilo_plavalcev_iz_posamicnih_drzav,
                                                     aes(x=reorder(Var1, Freq), y=Freq)) +
  geom_bar(stat = "identity", fill="steelblue") +
  geom_text(aes(label=Freq)) +
  labs(x = "Country", y = "Number of top 200 swimmers") +
  coord_flip()

# Uvozim zemljevid za število najboljših delfinistov

zemljevid2 <- uvozi.zemljevid("https://www.naturalearthdata.com/http//www.naturalearthdata.com/download/110m/cultural/110m_cultural.zip",
                             "ne_110m_admin_0_countries", encoding="UTF-8") %>%
  fortify()

colnames(zemljevid2)[11] <- "Var1"

zemljevid2$Var1 <- gsub("United Kingdom", "Great Britain", zemljevid2$Var1)
zemljevid2$Var1 <- gsub("Russia", "Russian Federation", zemljevid2$Var1)
zemljevid2$Var1 <- gsub("Republic of Serbia", "Serbia", zemljevid2$Var1)

zemljevid_stevilo_delfinistov <- ggplot() +
  geom_polygon(data=right_join(stevilo_plavalcev_iz_posamicnih_drzav, zemljevid2, by="Var1"),
               aes(x=long, y=lat, group=group, fill=Freq)) +
  xlab("") +
  ylab("") +
  ggtitle("Zemljevid števila delfinistov iz držav") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#FCDADA', high='#970303', limits=c(1,20)) +
  labs(fill="Število delfinistov")

# Starost rekorderjev

t <- ((right_join(podatki, plavalci, by="Name")) %>%
        filter(Points>=1000)) %>%
  select(Name, Swim_date, Birth_date)

graf_starosti_rekorderjev <- ggplot(as.data.frame(table(floor((t$Swim_date - t$Birth_date)/365.25))),
                                    aes(x=Var1, y=Freq)) +
  geom_bar(stat = "identity", fill = "steelblue") +
  labs(x = "Starost", y = "Število plavalcev") +
  labs(title = "Graf starosti plavalcev ko so odplavali svetovni rekord")


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(ggplot2)
library(xtable)
library(plyr)
library(dplyr)
library(tidyr)
library(readr)
library(kableExtra)
source('./_sequential_mnist_expand_name.r')
source('./_compute_summary.r')
source('./_plot_parameter.r')

best.range = 1000
alpha = 0.01

plot.label = paste0("Extrapolation length")
plot.x.breaks = c(1,10,200,400,600,800,1000)

best.model.step.fn = function (errors) {
  best.step = max(length(errors) - best.range, 0) + which.min(tail(errors, best.range))
  if (length(best.step) == 0) {
    return(length(errors))
  } else {
    return(best.step)
  }
}

first.solved.step = function (steps, errors, threshold) {
  index = first(which(errors < threshold))
  if (is.na(index)) {
    return(NA)
  } else {
    return(steps[index])
  }
}

safe.interval = function (alpha, vec) {
  if (length(vec) <= 1) {
    return(NA)
  }

  return(abs(qt((1 - alpha) / 2, length(vec) - 1)) * (sd(vec) / sqrt(length(vec))))
}

eps = expand.name(read_csv('../results/sequential_mnist_sum_reference.csv')) %>%
  gather(
    key="parameter", value="test.extrapolation.mse",
    metric.test.extrapolation.1.mse, metric.test.extrapolation.10.mse,
    metric.test.extrapolation.100.mse, metric.test.extrapolation.200.mse,
    metric.test.extrapolation.300.mse, metric.test.extrapolation.400.mse,
    metric.test.extrapolation.500.mse, metric.test.extrapolation.600.mse,
    metric.test.extrapolation.700.mse, metric.test.extrapolation.800.mse,
    metric.test.extrapolation.900.mse, metric.test.extrapolation.1000.mse
  ) %>%
  rowwise() %>%
  mutate(
    parameter = extrapolation.loss.name.to.integer(parameter)
  ) %>%
  group_by(seed, parameter) %>%
  summarise(
    best.model.step = best.model.step.fn(metric.valid.mse),
    threshold = test.extrapolation.mse[best.model.step],
  ) %>%
  filter(seed %in% c(0,1,2,3,4,5,6,7,8,9)) %>%
  group_by(parameter) %>%
  summarise(
    threshold = mean(threshold) + qt(1 - alpha, 8) * (sd(threshold) / sqrt(n()))
  )

dat = expand.name(read_csv('../results/sequential_mnist_sum_long.csv')) %>%
  gather(
    key="parameter", value="test.extrapolation.mse",
    metric.test.extrapolation.1.mse, metric.test.extrapolation.10.mse,
    metric.test.extrapolation.100.mse, metric.test.extrapolation.200.mse,
    metric.test.extrapolation.300.mse, metric.test.extrapolation.400.mse,
    metric.test.extrapolation.500.mse, metric.test.extrapolation.600.mse,
    metric.test.extrapolation.700.mse, metric.test.extrapolation.800.mse,
    metric.test.extrapolation.900.mse, metric.test.extrapolation.1000.mse
  ) %>%
  mutate(
    valid.interpolation.mse=metric.valid.mse,
    train.interpolation.mse=metric.train.mse
  ) %>%
  select(-metric.valid.mse, -metric.train.mse) %>%
  rowwise() %>%
  mutate(
    parameter = extrapolation.loss.name.to.integer(parameter)
  ) %>%
  merge(eps)

dat$model = with(dat, as.factor(ifelse(
  as.character(model) == '$\\mathrm{NAC}_{+}$' & regualizer.z > 0,
  '$\\mathrm{NAC}_{+,R_z}$',
  as.character(model)
)))

dat.last = dat %>%
  group_by(name, parameter) %>%
  summarise(
    threshold = last(threshold),
    best.model.step = best.model.step.fn(valid.interpolation.mse),
    interpolation.last = valid.interpolation.mse[best.model.step],
    extrapolation.last = test.extrapolation.mse[best.model.step],
    interpolation.step.solved = first.solved.step(step, valid.interpolation.mse, threshold),
    extrapolation.step.solved = first.solved.step(step, test.extrapolation.mse, threshold),
    sparse.error.max = sparse.error.max[best.model.step],
    solved = replace_na(test.extrapolation.mse[best.model.step] < threshold, FALSE),

    model = last(model),
    operation = last(operation),
    regualizer.z = last(regualizer.z),
    seed = last(seed),
    size = n()
  )

dat.last.rate = dat.last %>%
  group_by(model, operation, parameter, regualizer.z) %>%
  group_modify(compute.summary) %>%
  ungroup()

plot.by.regualizer.z = function (regualizer.z.show) {
  dat.gather = dat.last.rate %>% filter(
    (model == 'NAU' & regualizer.z == regualizer.z.show) | model != 'NAU'
  ) %>% mutate(
    parameter = as.factor(parameter)
  ) %>% plot.parameter.make.data()

  p = ggplot(dat.gather, aes(x = parameter, colour=model, group=model)) +
    geom_errorbar(aes(ymin = lower.value, ymax = upper.value), alpha=0.4) +
    geom_point(aes(y = mean.value, shape=our.model)) +
    geom_line(aes(y = mean.value)) +
    geom_blank(data = data.frame(
      key = c("success.rate"),
      model = NA,
      y.limit.max = c(1),
      parameter = mean(dat.gather$parameter)
    ), aes(x = parameter, y = y.limit.max)) +
    scale_color_discrete(labels = model.to.exp(levels(dat.gather$model))) +
    scale_y_continuous(name = element_blank(), limits=c(0,NA)) +
    scale_x_discrete(name = plot.label, breaks=plot.x.breaks) +
    scale_shape(guide = FALSE) +
    facet_wrap(~ key, scales='free_y', labeller = labeller(
      key = c(
        success.rate = "Success rate",
        converged.at = "Solved at iteration step",
        sparse.error = "Sparsity error"
      )
    )) +
    guides(colour = guide_legend(nrow = 1)) +
    theme(legend.position="bottom") +
    theme(plot.margin=unit(c(5.5, 10.5, 5.5, 5.5), "points"))

  return(p)
}

p.with.R.z = plot.by.regualizer.z(1)
print(p.with.R.z)
ggsave('../paper/results/sequential_mnist_sum_long.pdf', p.with.R.z, device="pdf", width = 13.968, height = 5.7, scale=1.4, units = "cm")

p.without.R.z = plot.by.regualizer.z(0)
print(p.without.R.z)
ggsave('../paper/results/sequential_mnist_sum_long_ablation.pdf', p.without.R.z, device="pdf", width = 13.968, height = 5.7, scale=1.4, units = "cm")


#' Select a geographic region around the distribution of a species
#'
#' This function takes as arguments a SpatialPolygonsDataFrame with a column representing whether or not a species was detected in each polygon. It then selects a subset of the shape focused around the area of detections.
#' @param x SpatialPolygonsDataFrame
#' @param detect Character, name of column in \code{x} that contains detection data.  Zero values are assumed to represent no detections.
#' @param expand Positive numeric, determines size of the focal region. For example, 0.5 corresponds to a region that comprises the occupied polygons plus a buffer with a width about 50% as large as the distance from the centroid of occupied polygons to the farthest occupied polygon.
#' @param upper Character, name of column in \code{x} that contains names of "upper" level polygons that contain "lower" level polygons which are at the scale at which detection/non-detection is scored. This argument is used to remove all lower-level polygons that fall in the same upper-level polygon but have no detections among them. For example, if upper-level polygons are states/provinces and lower-level polygons are counties with detections, then this could be used to remove all states/provinces with no counties with detections. Note that \code{minLowerPolysPerUpper} must be specified. A value of \code{NULL} (default) will not remove any polygons regardless of the values of \code{minLowerPolysPerUpper}.
#' @param cullIslands Logical, if \code{TRUE} (default) then remove islands (i.e., counties with no neighbors). Islands are only removed if all islands in an "upper" polygon (i.e., state, province) have no detections.
#' @param minLowerPolysPerUpper Character, only used if \code{upper} is not \code{NULL}. Minimum number of lower-level polygons necessary to be present in an upper-level polygon if none of them have any detections.
#' @return SpatialPolygonsDataFrame.
#' @examples
#' \donttest{
#'
#' library(sp)
#'
#' # polygons of Mexican counties
#' x <- raster::getData('GADM', country='MEX', level=2)
#'
#' # generate detections
#' set.seed(123)
#' x@data$detect <- 0
#' n <- sum(x@data$NAME_1 == 'Aguascalientes')
#' x@data$detect[x@data$NAME_1 == 'Aguascalientes'] <- rpois(n, 7)
#'
#' n <- sum(x@data$NAME_1 == 'Jalisco')
#' x@data$detect[x@data$NAME_1 == 'Jalisco'] <- rpois(n, 4)
#'
#' n <- sum(x@data$NAME_1 == 'Aguascalientes')
#' x@data$detect[x@data$NAME_1 == 'Aguascalientes'] <- rpois(n, 1)
#'
#' cols <- x@data$detect / max(x@data$detect)
#' cols <- scales::alpha('darkred', cols)
#' plot(x, col=cols, border='gray90')
#'
#' # generate focal region around detections
#' focus1 <- getGeogFocus(x, detect='detect', expand=0.1)
#' focus2 <- getGeogFocus(x, detect='detect', expand=0.5)
#' focus3 <- getGeogFocus(x, detect='detect', expand=0.1, upper='NAME_1')
#' focus4 <- getGeogFocus(x, detect='detect', expand=0.5, upper='NAME_1')
#'
#' # plot
#' par(mfrow=c(2, 2))
#'
#' cols <- focus1@data$detect / max(focus1@data$detect)
#' cols <- scales::alpha('darkred', cols)
#' plot(focus1, col=cols, border='gray90', main='expand=0.1')
#'
#' cols <- focus2@data$detect / max(focus2@data$detect)
#' cols <- scales::alpha('darkred', cols)
#' plot(focus2, col=cols, border='gray90', main='expand=0.5')
#'
#' cols <- focus3@data$detect / max(focus3@data$detect)
#' cols <- scales::alpha('darkred', cols)
#' plot(focus3, col=cols, border='gray90', main='expand=0.1 | sans sparse')
#'
#' cols <- focus4@data$detect / max(focus4@data$detect)
#' cols <- scales::alpha('darkred', cols)
#' plot(focus4, col=cols, border='gray90', main='expand=0.5 | sans sparse')
#'
#'
#' }
#' @export

getGeogFocus <- function(
	x,
	detect,
	expand = 0.3,
	upper = NULL,
	cullIslands = TRUE,
	minLowerPolysPerUpper = 10
) {

	mollweide <- '+proj=moll +lon_0=0 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs'

	origProj <- raster::projection(x)
	xSpEa <- sp::spTransform(x, sp::CRS(mollweide))

	# get MCP of polygon representing counties with detections
	speciesIndex <- which(xSpEa@data[ , detect] > 0)
	occs2SpEa <- xSpEa[speciesIndex, ]
	mcpSpEa <- enmSdm::mcpFromPolygons(occs2SpEa)

	# study region includes MCP and all counties with records
	occsDissolveSpEa <- rgeos::gUnaryUnion(occs2SpEa)
	occsPlusMcpSpEa <- rgeos::gUnion(occsDissolveSpEa, mcpSpEa)

	centSpEa <- rgeos::gCentroid(occsPlusMcpSpEa)
	distFromCent_m <- rgeos::gDistance(occsPlusMcpSpEa, centSpEa, hausdorff=TRUE)

	# study region includes buffer region around this area
	focalAreaSpEa <- rgeos::gBuffer(occsPlusMcpSpEa, width=expand * distFromCent_m)

	# get counties in this area
	xSpEa$id <- 1:nrow(xSpEa)

	focalAreaSp <- sp::spTransform(focalAreaSpEa, enmSdm::getCRS('wgs84'))
	focalIndices <- sp::over(focalAreaSpEa, xSpEa, returnList=TRUE)

	focalIndices <- sp::over(focalAreaSpEa, xSpEa, returnList=TRUE)
	focusSpEa <- x[focalIndices[[1]]$id, ]

	# remove islands with no detections
	if (cullIslands) {

		neighs <- spdep::poly2nb(focusSpEa, queen=TRUE)
		islandIndex <- which(sapply(neighs, function(focusSpEa) { length(focusSpEa == 1) && (focusSpEa == 0) }))

		bads <- integer()
		if (length(islandIndex) > 0) {

			islandUppers <- unique(x@data[islandIndex, upper])
			for (islandUpper in islandUppers) {

				lowersInUppers <- which(x@data[ , upper] == islandUpper)
				lowersAreIslands <- intersect(lowersInUppers, islandIndex)

				if (all(focusSpEa@data[lowersAreIslands, detect] == 0)) bads <- c(bads, lowersAreIslands)

			}

		}

		if (length(bads) > 0) focusSpEa <- focusSpEa[-bads, ]

	}

	# removing states with with no detections that have too-few counties
	if (!is.null(upper)) {
		uppers <- unique(focusSpEa@data[ , upper])
		for (thisUpper in uppers) {
			focusUpper <- focusSpEa[focusSpEa@data[ , upper] == thisUpper, ]
			if (all(focusUpper@data[ , detect] == 0) & nrow(focusUpper) < minLowerPolysPerUpper) {
				focusSpEa <- focusSpEa[-which(focusSpEa@data[ , upper] == thisUpper), ]
			}
		}
	}

	focusSp <- sp::spTransform(focusSpEa, sp::CRS(origProj))
	focusSp

}


#!/usr/bin/env Rscript

# Command line argument processing
args = commandArgs(trailingOnly=TRUE)
if (length(args) < 5) {
  stop("Usage: dupRadar.r <input.bam> <annotation.gtf> <strandDirection:0=unstranded/1=forward/2=reverse> <paired/single> <nbThreads> <R-package-location (optional)>", call.=FALSE)
}
input_bam <- args[1]
annotation_gtf <- args[2]
stranded <- as.numeric(args[3])
paired_end <- if(args[4]=='paired') TRUE else FALSE
threads <- as.numeric(args[5])

bamRegex <- "(.+)\\.bam$"

if(!(grepl(bamRegex, input_bam) && file.exists(input_bam) &&  (!file.info(input_bam)$isdir))) stop("First argument '<input.bam>' must be an existing file (not a directory) with '.bam' extension...")
if(!(file.exists(annotation_gtf) &&  (!file.info(annotation_gtf)$isdir))) stop("Second argument '<annotation.gtf>' must be an existing file (and not a directory)...")
if(is.na(stranded) || (!(stranded %in% (0:2)))) stop("Third argument <strandDirection> must be a numeric value in 0(unstranded)/1(forward)/2(reverse)...")
if(is.na(threads) || (threads<=0)) stop("Fifth argument <nbThreads> must be a strictly positive numeric value...")

# Remove bam file extension to generate basename
input_bam_basename <- gsub(bamRegex, "\\1", input_bam)

# Debug messages (stderr)
message("Input bam      (Arg 1): ", input_bam)
message("Input gtf      (Arg 2): ", annotation_gtf)
message("Strandness     (Arg 3): ", c("unstranded", "forward", "reverse")[stranded+1])
message("paired/single  (Arg 4): ", ifelse(paired_end, 'paired', 'single'))
message("Nb threads     (Arg 5): ", threads)
message("R package loc. (Arg 6): ", ifelse(length(args) > 4, args[5], "Not specified"))
message("Output basename       : ", input_bam_basename)

#-----------------------------
#-----------------------------
# Load / install packages
#-----------------------------
#-----------------------------------------------------------
#- not needed anymore because I added dupradar to bioconda
#-----------------------------------------------------------
#-  .libPaths( c( "/shared/ucl/depts/cancer/apps/nextflow_pipelines/rnaseq/Rlibs/3.4", .libPaths() ) )

if (length(args) > 5) { .libPaths( c( args[6], .libPaths() ) ) }
if (!require("dupRadar")){
  source("http://bioconductor.org/biocLite.R")
  biocLite("dupRadar", suppressUpdates=TRUE)
  library("dupRadar")
}
if (!require("parallel")) {
  install.packages("parallel", dependencies=TRUE, repos='http://cloud.r-project.org/')
  library("parallel")
}

# Duplicate stats
dm <- analyzeDuprates(input_bam, annotation_gtf, stranded, paired_end, threads)
write.table(dm, file=paste(input_bam_basename, "_dupMatrix.txt", sep=""), quote=F, row.name=F, sep="\t")

# 2D density scatter plot
pdf(paste0(input_bam_basename, "_duprateExpDens.pdf"))
duprateExpDensPlot(DupMat=dm)
title("Density scatter plot")
mtext(input_bam_basename, side=3)
dev.off()
fit <- duprateExpFit(DupMat=dm)
cat(
  paste("- dupRadar Int (duprate at low read counts):", fit$intercept),
  paste("- dupRadar Sl (progression of the duplication rate):", fit$slope),
  fill=TRUE, labels=input_bam_basename,
  file=paste0(input_bam_basename, "_intercept_slope.txt"), append=FALSE
)

# Create a multiqc file dupInt
sample_name <- gsub("Aligned.sortedByCoord.out.markDups", "", input_bam_basename)
line="#id: DupInt
#plot_type: 'generalstats'
#pconfig:
#    dupRadar_intercept:
#        title: 'dupInt'
#        namespace: 'DupRadar'
#        description: 'Intercept value from DupRadar'
#        max: 100
#        min: 0
#        scale: 'RdYlGn-rev'
#        format: '{:.2f}%'
Sample dupRadar_intercept"

write(line,file=paste0(input_bam_basename, "_dup_intercept_mqc.txt"),append=TRUE)
write(paste(sample_name, fit$intercept),file=paste0(input_bam_basename, "_dup_intercept_mqc.txt"),append=TRUE)

# Get numbers from dupRadar GLM
curve_x <- sort(log10(dm$RPK))
curve_y = 100*predict(fit$glm, data.frame(x=curve_x), type="response")
# Remove all of the infinite values
infs = which(curve_x %in% c(-Inf,Inf))
curve_x = curve_x[-infs]
curve_y = curve_y[-infs]
# Reduce number of data points
curve_x <- curve_x[seq(1, length(curve_x), 10)]
curve_y <- curve_y[seq(1, length(curve_y), 10)]
# Convert x values back to real counts
curve_x = 10^curve_x
# Write to file
line="#id: DupRadar
#section_name: 'DupRadar'
#section_href: 'bioconductor.org/packages/release/bioc/html/dupRadar.html'
#description: \"provides duplication rate quality control for RNA-Seq datasets. Highly expressed genes can be expected to have a lot of duplicate reads, but high numbers of duplicates at low read counts can indicate low library complexity with technical duplication.
#    This plot shows the general linear models - a summary of the gene duplication distributions. \"
#pconfig:
#    title: 'DupRadar General Linear Model'
#    xLog: True
#    xlab: 'expression (reads/kbp)'
#    ylab: '% duplicate reads'
#    ymax: 100
#    ymin: 0
#    tt_label: '<b>{point.x:.1f} reads/kbp</b>: {point.y:,.2f}% duplicates'
#    xPlotLines:
#        - color: 'green'
#          dashStyle: 'LongDash'
#          label:
#                style: {color: 'green'}
#                text: '0.5 RPKM'
#                verticalAlign: 'bottom'
#                y: -65
#          value: 0.5
#          width: 1
#        - color: 'red'
#          dashStyle: 'LongDash'
#          label:
#                style: {color: 'red'}
#                text: '1 read/bp'
#                verticalAlign: 'bottom'
#                y: -65
#          value: 1000
#          width: 1"

write(line,file=paste0(input_bam_basename, "_duprateExpDensCurve_mqc.txt"),append=TRUE)
write.table(
  cbind(curve_x, curve_y),
  file=paste0(input_bam_basename, "_duprateExpDensCurve_mqc.txt"),
  quote=FALSE, row.names=FALSE, col.names=FALSE, append=TRUE,
)

# Distribution of expression box plot
pdf(paste0(input_bam_basename, "_duprateExpBoxplot.pdf"))
duprateExpBoxplot(DupMat=dm)
title("Percent Duplication by Expression")
mtext(input_bam_basename, side=3)
dev.off()

# Distribution of RPK values per gene
pdf(paste0(input_bam_basename, "_expressionHist.pdf"))
expressionHist(DupMat=dm)
title("Distribution of RPK values per gene")
mtext(input_bam_basename, side=3)
dev.off()

# Print sessioninfo to standard out
print(input_bam_basename)
citation("dupRadar")
sessionInfo()


test_that("Integer check fails when character or factor is added", {
  expect_error(phyloseq2ML:::is.wholenumber(c("blabla")))
})

test_that("Integer check returns TRUE for decimals without rest", {
  expect_true(phyloseq2ML:::is.wholenumber(c(7.0)))
})

test_that("Integer check works for vectors", {
  expect_true(phyloseq2ML:::is.wholenumber(c(7, 7.0, 9, 500, 0, -1)))
})

test_that("Integer check returns FALSE if one value is not wholenumber", {
  expect_false(phyloseq2ML:::is.wholenumber(c(7, 7.0, 3.1)))
})

test_that("Integer check returns TRUE for decimals without rest", {
  expect_true(phyloseq2ML:::is.wholenumber(c(7, 7.0)))
})

test_that("Integer check returns TRUE for number", {
  expect_false(phyloseq2ML:::is.wholenumber(c(7.1)))
})

## is.dummy
test_that("Dummy check works for vectors", {
  expect_true(phyloseq2ML:::is.dummy(c(1, 0, 0, 1)))
  expect_true(phyloseq2ML:::is.dummy(c(0, 0)))
  expect_true(phyloseq2ML:::is.dummy(c(1, 1)))
})

test_that("Dummy check returns FALSE for numerical vectors unlike 0 or 1", {
  expect_false(phyloseq2ML:::is.dummy(c(7, 7.0, 9, 500, 0, -1)))
})

test_that("Dummy check returns FALSE for decimal with rest", {
  expect_false(phyloseq2ML:::is.dummy(c(1, 0, 1.1)))
  expect_true(phyloseq2ML:::is.dummy(c(1, 0, 1.0)))
})

test_that("Dummy check returns FALSE for negative value", {
  expect_false(phyloseq2ML:::is.dummy(c(-1)))
})

test_that("Dummy check returns FALSE for text or factor", {
  expect_false(phyloseq2ML:::is.dummy(c("word", "word2")))
  expect_false(phyloseq2ML:::is.dummy(as.factor(c("word", "word2"))))
})