#####-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#####
#####   Working with map functions and their outputs    #####
#####   University of Guelph R users group (UGRU)       #####
#####   Last updated: 27 February 2020                  #####
#####-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#-#####

# initial set-up ----------------------------------------------------------

## set working directory
getwd()

## load required packages
library(tidyverse)
library(lubridate)
library(ggthemes)

library(skimr)
library(broom)

## set plotting theme
theme_set(theme_few())

# import data -------------------------------------------------------------

## COMMENT:
## we will be using the same dataset as Karl's tutorial, which is
## comes from a camera trap study on the Serengeti
## see metadata at:
## https://datadryad.org/stash/dataset/doi:10.5061/dryad.5pt92

serengeti <- read_csv("../karl_repeating_combos/consensus_data.csv")

serengeti
skimr::skim(serengeti)

## OBSERVATIONS:
## there are 48 species documented in the dataset, recorded at 225 sites
## dataset includes 4 years, spanning 2010-2013

# data manipulations ------------------------------------------------------

## COMMENT:
## the dataset is currently in long format, with each row representing
## a single capture event. let's create a dataset that tells us the
## number of individuals of each species that were observed at a
## given location in a given year
## (this is the similar to Karl's procedure, but we won't spread the data)

## Zorilla = "striped polecat", "African skunk" =/= "gorilla"

serengeti_2 <- serengeti %>%
  mutate(Year = year(DateTime)) %>% ## extract year from DateTime
  select(Year, SiteID, Species, Count) %>%
  mutate(Count = as.numeric(Count)) %>%
  group_by(Year, SiteID, Species) %>%
  summarise(Total = sum(Count)) %>%
  ungroup()

## convert NAs to zeroes
serengeti_2[is.na(serengeti_2)] <- 0

## we can further summarize this by finding the number of individuals
## counted at all sites in a given year (this will likely result in
## double-counting of individuals, but doesn't really matter for our
## purposes)

serengeti_3 <- serengeti_2 %>%
  group_by(Species, Year) %>%
  summarise(Abundance = sum(Total)) %>%
  ungroup()

# data exploration --------------------------------------------------------

## plot the number of individuals of each species through time
ggplot(data = serengeti_3,
       mapping = aes(x = Year, y = Abundance)) +
  geom_point() +
  geom_line() +
  facet_wrap(~ Species, scales = "free_y")

# nest data ---------------------------------------------------------------

## group tibble by department
by_species <- serengeti_3 %>%
  group_by(Species) %>%
  nest()

by_species
by_species$data[[1]]

## COMMENT:
## the nest function produces a new 'data column' that contains the
## subset of data that pertains to each species
## this is a powerful, if unconvential way, of working with larger
## datasets that are comprised of observations on many different groups
##
## list columns can be really useful because they keep related
## things together. anything can go in a list and a list can go in a d.f.
## this nesting has transformed the data from 'observation-per-row' to
## 'species-per-row' format

# model species abundance through time ------------------------------------

## define a function to fit a simple linear model
abund_mod <- function(df) {
  lm(Abundance ~ Year + I(Year^2), data = df)
}

## fit the model for each species separately, adding the output to our
## nested dataframe [this is where the map function comes in handy!!]
by_species <- by_species %>%
  mutate(mod = map(data, abund_mod))

by_species
by_species$mod[[1]]
summary(by_species$mod[[1]])

# convert model objects to tidy data using broom --------------------------

## COMMENT:
## the broom packages provides a number of tools to convert messy model
## output into tidy data
## glance() = model summaries (one row/value per model; e.g., R^2, AIC)
## tidy() = model estimates
## (one row per model parameter; e.g., parameters estimates, SEs)
## augment() = observation-level outputs
## (one row for each row in the original dataset; e.g., residuals, es)

by_species <- by_species %>%
  mutate(int_slope = map(mod, broom::tidy),
         summ_stats = map(mod, broom::glance),
         fits = map(mod, broom::augment),
         rsq = summ_stats %>% map_dbl("adj.r.squared"),
         pval = summ_stats %>% map_dbl("p.value"))

by_species$int_slope[[1]]
by_species$summ_stats[[1]]
by_species$fits[[1]]

## extracting the fitted values can also be done with map2()
head(map2(by_species$mod, by_species$data, predict))[1]

# unnest the data ---------------------------------------------------------

unnest(by_species, data) ## back to where we started

## COMMENT:
## since rsq was extracted from the model for each species, and there
## is only one r-squared per model, it will be repeated for each species

## view model summaries by species
unnest(by_species, summ_stats, .drop = TRUE)

## view model predictions by species
(serengeti_3_fits <- unnest(by_species, fits, .drop = TRUE))

# explore model outputs ---------------------------------------------------

## plot model the fitted lines with the raw data
ggplot(data = serengeti_3_fits) +
  geom_line(mapping = aes(x = Year, y = .fitted)) +
  geom_point(mapping = aes(x = Year, y = Abundance)) +
  facet_wrap(~ Species, scales = "free_y")

# mapping over multiple inputs --------------------------------------------

# ## COMMENT:
# ## A number of the species abundances appear to show a similar pattern,
# ## wherein abundance follows a quadratic relationship, increasing in 2011
# ## and 2012, before dropping again in 2013
# ## this is likely a result of shared environmental conditions (e.g., maybe
# ## 2010 and 2013 were drought years), but could also result from pairwise
# ## species interactions or community-level effects
#
# ## define a model to look how the abundance of one species affects
# ## the abundance of another species through time
# abund_mod2 <- function(df, prey, lions) {
#   lm(Species1 ~ Year + I(Year^2) + Species2, data = df)
# }

## define a list of prey species
prey <- serengeti_3 %>%
  filter(Species %in% c("zebra", "wildebeest", "impala",
              "gazelleGrants", "gazelleThomsons", "dikDik")) %>%
  group_by(Year) %>%
  nest()

## define a list of predator species
predators <- serengeti_3 %>%
  filter(Species %in% c("lionMale", "lionFemale", "jackal",
               "leopard", "hyenaStriped", "cheetah")) %>%
  group_by(Year) %>%
  nest()

## join the predator and prey datasets together
pred_prey <- left_join(predators, prey, by = "Year") %>%
  rename(Predators = data.x,
         Prey = data.y)

## calculate the relative abundances of matched predators and prey
## in each year (this doesn't really do what I want, but you get the point)
t1 <- pred_prey %>%
  mutate(Prey = map2(Predators,
                     Prey,
                     ~mutate(.y,
                             predator = .x$Species,
                             relative_abundance =
                               .x$Abundance/.y$Abundance)))
t1$Prey[[1]]

## calculate the correlation between predator and prey abundances in each
## year of the study
t2 <- pred_prey %>%
  mutate(Prey = map2(Predators,
                     Prey,
                     ~mutate(.y,
                             corr = cor(.x$Abundance, .y$Abundance))))
t2$Prey[[1]]

# test out pmap() ---------------------------------------------------------

pmap(list(by_species$data), nrow) # %>% unlist()

## COMMENT:
## honestly, I don't know how to use pmap(). All of the examples I could
## think of could be done a variety of other (more transparent?) ways,
## which might rely on combining group_by() and summarise()

serengeti_3 %>%
  group_by(Species) %>%
  summarise(min_abundance = min(Abundance),
            min_year = Year[which.min(Abundance)])

## DO YOU HAVE ANY EXAMPLES OF USING pmap() IN YOUR OWN WORK??

# pmap lets you lapply a function that takes the colnmaes as args
# note the ... below lets us throw away the columns we don't need,
# and we can avoid having to use these in the function's argument
# list

new_name = function(Species, Petal.Width, Petal.Length, ...){
  return(paste(Species, Petal.Width, Petal.Length, sep=";"))
}

# here pmap takes all the columns of iris, and use them as the arguments
# to be passed to the new_name func. Note the ... in the new_name args list
# tosses the two sepal length columns and then just uses the relevant columns
# without the ... we get an error saying that
iris$outname = pmap(iris,  new_name)

iris$outname = lapply(1:nrow(iris), function(i){
  new_name(iris$Species[[i]], iris$Petal.Width[[i]], iris$Petal.Length[[i]])
  })

# we can also use various data sources, by making a labelled list, where the labels are
# the function args, the data can be passed to the function through pmap. shorter
# data structures are recycled (use 10 over and over below)

numerators = c(1,2,3,4,5,6,7,8)
denoms = c(2,4,6,8,10,12,14,16)
mul = c(10)

div = function(n, d, m){
  return ((n / d)*m)
}

pmap(list(n = numerators, d = denoms, m = mul), div)

## -- ## -- ## -- ## -- ## END OF SCRIPT ## -- ## -- ## -- ## -- ##


create_crv <- function(f){

  type <- readline(prompt="1. Unidim\n2. Bidim\n")

  if(type == 1){

    x_low <- as.integer(readline(prompt="Low: "))
    x_high <- as.integer(readline(prompt="High: "))

    crv <- c(f, x_low, x_high)

    return(crv)

  }

  if(type == 2){

    x_low <- as.integer(readline(prompt="x Low: "))
    x_high <- as.integer(readline(prompt="x High: "))
    y_low <- as.integer(readline(prompt="y Low: "))
    y_high <- as.integer(readline(prompt="y High: "))

    crv <- c(f, x_low, x_high, y_low, y_high)

    return (crv)
  }
}

f <- function(x) {
  if(x >= 0 && x <= 1)
    (exp(1)*(exp(-x)+exp(x)))/(exp(2)-1)
  else 0
}

g <- function(x) {
  if((x >= 0) && (x <= pi)) {sin(x)/2} else {0}
}

h <- function(x) {
  if((x >= 0) && (x <= pi)) {
    sin(x)/2
  } else {0}
}

test <- create_crv(f)


context("imap iterator")

pow <- function(x, y) {
  x^y
}

test_that("imap over two numeric vectors of equal length", {
  it <- imap(pow, c(2, 3, 10), c(5, 2, 3))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})

test_that("imap over two numeric vectors of unequal length", {
  it <- imap(pow, c(2, 3, 10), c(5, 2, 3, 42))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})

test_that("imap over two lists of equal length", {
  it <- imap(pow, list(2, 3, 10), list(5, 2, 3))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})

test_that("imap over two lists of unequal length", {
  it <- imap(pow, list(2, 3, 10), list(5, 2, 3, 42))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})


context("generate_feasible patterns")

test_that("har datasets can be empirically culled under delta constraints", {
    positive_fx_direction_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(1,
        0, 0, 0), bounds_tuple_of_numeric)
    indices_for_muscles <- 1:7
    fmax_info <- lpsolve_force_in_dir("max", positive_fx_direction_constraint, indices_for_muscles)
    context("computing polytope samples for tasks")
    har_per_task_df <- generate_task_trajectory_and_har(H_matrix = H_matrix, vector_out = fmax_info$output_vector_per_task[[1]] *
        (1 - 1e-05), n_task_values = 5, cycles_per_second = 2, cyclical_function = force_cos_ramp,
        output_dimension_names = force_dimnames, muscle_name_per_index = muscle_name_per_index,
        bounds_tuple_of_numeric = bounds_tuple_of_numeric, num_har_samples = 100,
        har_thin = 100)
    context("splitting by task")
    list_of_polytope_dfs <- split_by_time(har_per_task_df)
    # expect_equal(length(list_of_polytope_dfs),10)
    # expect_equal(nrow(list_of_polytope_dfs[[1]]),100)
    # expect_equal(nrow(list_of_polytope_dfs[[9]]),100)
    context("attempting tunneling")
    list_of_culled_polytope_dfs <- rm_solutions_with_infeasible_transitions(list_of_polytope_dfs,
        muscle_name_per_index, threshold = 1, mc.cores = 1)
    expect_equal(length(list_of_culled_polytope_dfs), length(list_of_polytope_dfs))
    threshold_disabled_polytope_dfs <- rm_solutions_with_infeasible_transitions(list_of_polytope_dfs,
        muscle_name_per_index, threshold = 1, mc.cores = 1)
    expect_equal(sapply(threshold_disabled_polytope_dfs, nrow), sapply(list_of_polytope_dfs,
        nrow))
    threshold_infinitely_strict <- rm_solutions_with_infeasible_transitions(list_of_polytope_dfs,
        muscle_name_per_index, threshold = 0, mc.cores = 1)
    expect_equal(sapply(threshold_infinitely_strict, nrow), rep(0, length(list_of_polytope_dfs)))
    medium_threshold <- rm_solutions_with_infeasible_transitions(list_of_polytope_dfs,
        muscle_name_per_index, threshold = 0.5, mc.cores = 1)
    browser()
    # TODO ANIMATION etc/overlay <- dcrb(list_of_culled_polytope_dfs)
})

test_that("feasible task for H yields valid points", {
    # the set of lambdas by which to scale the maximum feasible force for a given
    # task direction. P=
    constr <- constraint_H_with_bounds(H_matrix, c(5, 0, 0, 0), bounds_tuple_of_numeric)
    points <- har_sample(constr, 10000)
    colnames(points) <- muscle_name_per_index
    # Generate points without delta constraints
    expect_true(all(colMins(points) > 0))
    expect_true(all(colMaxes(points) < 1))
})

test_that("feasible task for mini H yields valid points", {
    # the set of lambdas by which to scale the maximum feasible force for a given
    # task direction. P=
    constr <- constraint_H_with_bounds(H_matrix_mini, c(1), bounds_tuple_of_numeric_mini)
    points <- har_sample(constr, 10000)
    # Generate points without delta constraints
    expect_true(all(colMins(points) > 0))
    expect_true(all(colMaxes(points) < 1))
    points_are_valid <- evaluate_solutions(points, constr)
    expect_true(all(points_are_valid))
})

test_that("har performance with fixed dimensionality", {
    constr <- constraint_H_with_bounds(H_matrix, c(5, 0, 0, 0), bounds_tuple_of_numeric) %>%
        eliminate_redundant
    mbm <- microbenchmark(pb1e3 = {
        a <- constr %>% pb_har_sample(1e+07, mc.cores = 8, eliminate = FALSE)
    }, pb1e4 = {
        a <- constr %>% pb_har_sample(1e+07, mc.cores = 8, eliminate = FALSE)
    }, pb1e5 = {
        a <- constr %>% pb_har_sample(1e+07, mc.cores = 8, eliminate = FALSE)
    }, pb1e6 = {
        a <- constr %>% pb_har_sample(1e+07, mc.cores = 8, eliminate = FALSE)
    }, pb1e7 = {
        a <- constr %>% pb_har_sample(1e+07, mc.cores = 8, eliminate = FALSE)
    }, times = 1)
})

test_that("we can generate force trajectory", {
    trajectory_task <- task_time_df(c(100, 0, 0, 0), 20, 1, force_cos_ramp, force_dimnames)
    expect_equal(nrow(trajectory_task), 20)
    expect_equal(trajectory_task$Fx[9], 93.973688, tol = 1e-04)
})

test_that("maps_within_threshold_by_dimension", {
    expect_true(maps_within_threshold_by_dimension(c(1, 2, 3), c(1, 2, 3), threshold = 0.01))
    expect_true(maps_within_threshold_by_dimension(rep(0.5, 7), rep(0.5, 7) * 0.99999,
        threshold = 0.001))
    expect_false(maps_within_threshold_by_dimension(rep(0.5, 7), rep(0.5, 7) * 0.99999,
        threshold = 1e-08))
    expect_false(maps_within_threshold_by_dimension(c(rep(0.5, 7), 0.5), c(rep(0.5,
        7), 0.9) * 0.99999, threshold = 1e-08))
    expect_true(maps_within_threshold_by_dimension(c(1), c(1), threshold = 0.01))
    expect_false(maps_within_threshold_by_dimension(c(0), c(1), threshold = 0.01))
    expect_true(maps_within_threshold_by_dimension(c(1, 2, 3), c(1, 2, 3), threshold = 0.01))
    map0 <- structure(list(FDP = 0.281445228858277, FDS = 0.13815374660091, EIP = 0.481078359065577,
        EDC = 0.94192914712619, LUM = 0.640311108736637, DI = 0.346844080864468,
        PI = 0.225458337356392), row.names = 101L, class = "data.frame")
    map1 <- structure(list(FDP = 0.208347120776137, FDS = 0.0984276508753465, EIP = 0.381784882330989,
        EDC = 0.659188727382571, LUM = 0.654171949911292, DI = 0.119571917524553,
        PI = 0.144473748280277), row.names = 1L, class = "data.frame")
    expect_false(maps_within_threshold_by_dimension(map0, map1, threshold = 0.2))
    expect_true(maps_within_threshold_by_dimension(map0, map1, threshold = 0.3))
    expect_false(maps_within_threshold_by_dimension(map0, map1, threshold = 0.03))
})

context("fmax for a direction")

skip_if_not(run_full_long_tests, message = deparse(substitute(condition)))
test_that("(har vs lpSolve) estimations of fmax in a given dir are expected to be different.",
    {

        negative_fx_direction_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(-1,
            0, 0, 0), bounds_tuple_of_numeric)
        positive_fx_direction_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(1,
            0, 0, 0), bounds_tuple_of_numeric)
        res_neg <- pb_har_sample(negative_fx_direction_constraint, n_samples = 10000)
        res_pos <- pb_har_sample(positive_fx_direction_constraint, n_samples = 10000)

        expect_equal(colMaxes(res_pos[, 1:7]), colMaxes(res_neg[1:7]), tol = 0.01)
        expect_equal(colMins(res_pos[, 1:7]), colMins(res_neg[, 1:7]), tol = 0.01)
        indices_for_muscles <- 1:7
        max_lp_negative <- lpsolve_force_in_dir("max", negative_fx_direction_constraint,
            indices_for_muscles)
        max_lp_positive <- lpsolve_force_in_dir("max", positive_fx_direction_constraint,
            indices_for_muscles)

        # Hit and run does not get all the way to the vertex/edge unless you give it
        # infinite time.
        expect_false(abs(max(res_pos[, 8]) - max_lp_positive$vector_magnitude_per_task[[1]]) <
            0.001)
        most_negative_mvc_fx <- H_matrix %*% max_lp_negative$muscle_activation_pattern_per_task[[1]]
        most_positive_mvc_fx <- H_matrix %*% max_lp_positive$muscle_activation_pattern_per_task[[1]]
        expect_equal(as.numeric(most_negative_mvc_fx), c(-17.5927374630042, -4.44089209850063e-16,
            3.5527136788005e-15, -6.93889390390723e-18))
        expect_equal(as.numeric(most_positive_mvc_fx), c(28.8115546379602, -9.99200722162641e-16,
            0, -2.42861286636753e-17))
        expect_false(abs(max(res_neg[, 8]) - max_lp_negative$vector_magnitude_per_task[[1]]) <
            0.001)
    })

skip_if_not(run_full_long_tests, message = deparse(substitute(condition)))
test_that("output_folder paths work", {
    expect_equal(output_filepath("hexbin/hexbin.html"), "../../output/hexbin/hexbin.html")
    expect_equal(output_subfolder_path("hexbin", "hexbin.html"), "../../output/hexbin/hexbin.html")
})

skip_if_not(run_full_long_tests, message = deparse(substitute(condition)))

test_that("we can generate and har upon each task polytope independently", {
    positive_fx_direction_constraint <- a_matrix_lhs_direction(H_matrix, direction = c(1,
        0, 0, 0), bounds_tuple_of_numeric)
    indices_for_muscles <- 1:7
    fmax_info <- lpsolve_force_in_dir("max", positive_fx_direction_constraint, indices_for_muscles)
    har_per_task_df <- generate_task_trajectory_and_har(H_matrix = H_matrix, vector_out = fmax_info$output_vector_per_task[[1]] *
        (1 - 1e-05), n_task_values = 60, cycles_per_second = 2, cyclical_function = force_cos_ramp,
        output_dimension_names = force_dimnames, muscle_name_per_index = muscle_name_per_index,
        bounds_tuple_of_numeric = bounds_tuple_of_numeric, num_har_samples = 1000,
        har_thin = 100)
    expect_true(all(!where_muscles_have_unreasonable_values(har_per_task_df, muscle_name_per_index)))
    p <- ggplot(har_per_task_df, aes(DI, PI, frame = time)) + geom_hex(aes(group = time),
        binwidth = c(0.05, 0.05)) + coord_fixed() + unit_cube_zoom() + theme_classic()
    gganimate::gganimate(p, output_subfolder_path("hexbin", "hexbin.html"))
    p2 <- ggplot(har_per_task_df, aes(DI, PI, frame = time)) + geom_point(aes(group = time),
        size = 0.01, alpha = 0.1) + stat_chull(aes(group = time), alpha = 0.1, geom = "polygon") +
        coord_fixed() + unit_cube_zoom() + theme_classic()
    gganimate::gganimate(p2, output_subfolder_path("points", "points.html"))
})

context('full_for_task_st')
test_that('full_ st histograms', {
    har_n <- 1e3
    st_constr_str <- force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, c(28,0,0,0), 0.5, 0.5, n_task_values = 10, cycles_per_second=10, eliminate = FALSE)
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant
    points_st <- res %>% pb_har_sample(har_n, mc.cores=8, eliminate=FALSE)
    p_st <- ggplot(har_per_task_df, aes(DI, PI, frame = time)) + geom_hex(aes(group = time),
        binwidth = c(0.05, 0.05)) + coord_fixed() + unit_cube_zoom() + theme_classic()
    points_st$st <- factor(1, levels=c(0,1))
    st_constr_str <- force_cos_ramp_constraint(H_matrix, bounds_tuple_of_numeric, c(28,0,0,0), 1.0, 1.0, n_task_values = 10, cycles_per_second=10, eliminate = FALSE)
    res <- st_constr_str$nonredundant_constr %>% eliminate_redundant
    points_no_st <- res %>% pb_har_sample(har_n, mc.cores=8, eliminate=FALSE)
    points_no_st$st <- factor(0, levels(c(0,1)))

    gganimate::gganimate(p_st, output_subfolder_path("st_vs_degenerate", "st.html"))

})


#Plot the memory model, first argument is the upperbound, the the dataset containing the plotting data

args<-commandArgs(TRUE)
dataset <-read.csv(args[1])
filename = gsub(".csv", "", args[1])
fileNameEt <- paste(filename, "_FREQUENCE", sep="")
breaks   <- c(11,117,223,329,435,541,647,753,859,965,1071)
breaksSS <- c(16.4,111.13,205.86,300.59,395.32,490.05,584.78,679.51,774.24,868.97,963.7)

xmean <- rowMeans(cbind(dataset$MEMA0,dataset$MEMA1 ,dataset$MEMA2 ,dataset$MEMA3 ,dataset$MEMA4,dataset$MEMA5,dataset$MEMA6,dataset$MEMA7,dataset$MEMA8,dataset$MEMA9))

png(paste(fileNameEt,"_FULL_DENSITY_B.png") , 1827, 1458)
d<- density(xmean)
plot(d, main = "Density", col="brown", type="h", ylim=c(0,0.05), xlim=range(breaks))

png(paste(fileNameEt,"_FULL_HIST_B.png") , 1827, 1458)
hist(xmean, main="Histogram",  col="brown", xlim=range(breaks), ylim=c(0,20000), labels=TRUE, breaks=breaks)

dev.off()


#' @title calcCp
#'
#'@description Calculates the prismatic coefficient (\code{Cp}) (dimensionless).
#'
#'@param Cm Midship section coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCm}})
#'@param Cbw Waterline block coefficient (vector of numericals, dimensionless)
#'(see \code{\link{calcCbw}})
#'@param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#' Must align with \code{roroPaxContainerShipTypes},
#'\code{gCargoShipTypes}, and \code{tankerBulkCarrierShipTypes} groupings
#'@param bounds Indicates which upper and lower bounds on \code{Cp} should be
#'applied:\itemize{
#'\item Pass "holtrop mennen" to use the bounds specified by Holtrop & Mennen
#'\item Pass "none" (default) to calculate \code{Cp} without upper or lower
#' bounds}
#' This argument is not vectorized. Either supply a single string or rely on the
#' default
#'@param roroPaxContainerShipTypes Ship types specified in input \code{shipTypes}
#'to be modeled as RORO, passenger and container ships (vector of strings)
#'@param gCargoShipTypes Ship types specified in input \code{shipTypes} to be
#'modeled as general cargo (vector of strings)
#'@param tankerBulkCarrierShipTypes Ship types specified in input
#'\code{shipTypes} to be modeled as tankers and bulk carriers (vector of strings)
#'
#' @details
#' \deqn{Cp = \frac{Cbw}{Cm}}{Cp=Cbw/Cm}
#'
#' This function can calculate \code{Cp} with or without upper and lower bounds.
#' If the Holtrop & Mennen bounds are applied, this requires ship types to be
#' grouped. Use the \code{roroPaxContainerShipTypes}, \code{gCargoShipTypes},
#' and  \code{tankerBulkCarrierShipTypes} parameters to provide these ship
#' type groupings. Any ship types not included in these groupings will be
#' considered as miscellaneous vessels.
#'
#' @return \code{Cp} (vector of numericals, dimensionless)
#'
#'@references
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#' @seealso
#' \itemize{
#'   \item \code{\link{calcCm}}
#'   \item \code{\link{calcCbw}}
#'   \item \code{\link{calcShipType}}
#' }
#'
#' @examples
#' calcCp(c(0.99,0.98), c(.8,.75),c("bulk.carrier","container.ship"),"none")
#'
#' @export

calcCp <-function(Cm, Cbw, shipType, bounds="none",
                  roroPaxContainerShipTypes=c("ro.ro","passenger","ferry.pax","ferry.ro.pax","cruise","cruise.ed","yacht","container.ship"),
                  gCargoShipTypes=c("general.cargo"),
                  tankerBulkCarrierShipTypes=c("tanker","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier")
){

  Cp <-if(bounds=="holtrop mennen"){
    ifelse(
      shipType%in%roroPaxContainerShipTypes,
      pmax(0.55,pmin(0.67,(Cbw/Cm))),
      ifelse(shipType%in%gCargoShipTypes,
             pmax(0.56,pmin(0.75,(Cbw/Cm))),
             ifelse(shipType%in%tankerBulkCarrierShipTypes,
                    pmax(0.85,pmin(0.73,(Cbw/Cm))),#case 3: bulk carrier & tanker,
                    Cbw/Cm
                    )
      )
    )
    }else{(Cbw/Cm)}

  return(Cp)
}


##############################
#
# Required Packages
#
require("ggplot2")
require("RSNNS")
require("scales")

##############################
#
# Loading data
#
load("data/intel.mlr.rda")
load("data/amd.mlr.rda")
load("data/both.mlr.rda")

load("data/intel.mlp.rda")
load("data/amd.mlp.rda")
load("data/both.mlp.rda")

load("data/intel.rt.rda")
load("data/amd.rt.rda")
load("data/both.rt.rda")

intel <- read.table("data/intel.csv", sep = ",", dec = ".", header = TRUE)
amd   <- read.table("data/amd.csv",   sep = ",", dec = ".", header = TRUE)
both  <- read.table("data/both.csv",  sep = ",", dec = ".", header = TRUE)

###################################
#
# Comparing Observed vs. Predicted
#
###################################

legend <- c("Actual", "Estimate")

all <- rbind(
  cbind(
    data.frame(
      arch   = "A1",
      method = "MLR"),
    rbind(
      data.frame(
        index = 1:length(intel$POWER_CONSUMPTION),
        value = intel$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(intel$POWER_CONSUMPTION),
        value = as.numeric(predict(intel.mlr)),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "A2",
      method = "MLR"),
    rbind(
      data.frame(
        index = 1:length(amd$POWER_CONSUMPTION),
        value = amd$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(amd$POWER_CONSUMPTION),
        value = as.numeric(predict(amd.mlr)),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "Mix",
      method = "MLR"),
    rbind(
      data.frame(
        index = 1:length(both$POWER_CONSUMPTION),
        value = both$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(both$POWER_CONSUMPTION),
        value = as.numeric(predict(both.mlr)),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "A1",
      method = "RET"),
    rbind(
      data.frame(
        index = 1:length(intel$POWER_CONSUMPTION),
        value = intel$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(intel$POWER_CONSUMPTION),
        value = as.numeric(predict(intel.rt)),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "A2",
      method = "RET"),
    rbind(
      data.frame(
        index = 1:length(amd$POWER_CONSUMPTION),
        value = amd$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(amd$POWER_CONSUMPTION),
        value = as.numeric(predict(amd.rt)),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "Mix",
      method = "RET"),
    rbind(
      data.frame(
        index = 1:length(both$POWER_CONSUMPTION),
        value = both$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(both$POWER_CONSUMPTION),
        value = as.numeric(predict(both.rt)),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "A1",
      method = "MLP"),
    rbind(
      data.frame(
        index = 1:length(intel$POWER_CONSUMPTION),
        value = intel$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(intel$POWER_CONSUMPTION),
        value =
          denormalizeData(as.numeric(predict(intel.mlp)),
                          getNormParameters(normalizeData(intel$POWER_CONSUMPTION, type = "0_1"))),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "A2",
      method = "MLP"),
    rbind(
      data.frame(
        index = 1:length(amd$POWER_CONSUMPTION),
        value = amd$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(amd$POWER_CONSUMPTION),
        value =
          denormalizeData(as.numeric(predict(amd.mlp)),
                          getNormParameters(normalizeData(amd$POWER_CONSUMPTION, type = "0_1"))),
        type  = legend[2]))),
  cbind(
    data.frame(
      arch   = "Mix",
      method = "MLP"),
    rbind(
      data.frame(
        index = 1:length(both$POWER_CONSUMPTION),
        value = both$POWER_CONSUMPTION,
        type  = legend[1]),
      data.frame(
        index = 1:length(both$POWER_CONSUMPTION),
        value =
          denormalizeData(as.numeric(predict(both.mlp)),
                          getNormParameters(normalizeData(both$POWER_CONSUMPTION, type = "0_1"))),
        type  = legend[2])))
)

rm(amd, both, intel,
   amd.mlp, amd.mlr, amd.rt,
   intel.mlp, intel.mlr, intel.rt,
   both.mlp, both.mlr, both.rt)

graph <-
ggplot(all, aes(x = index, y = value, colour = type)) +
  geom_line(alpha = .6) +
  xlab("Sample") +
  ylab("Energy Consumption (W)") +
  scale_color_hue("Legend") +
  facet_grid(arch ~ method, scales = "free_y") +
  theme(
    legend.position   = c(.92, .5),
    legend.background = element_rect(fill=alpha('white', 0.6)),
    text              = element_text(size=10),
    axis.title        = element_text(size=10),
    axis.text         = element_blank(),
    axis.ticks        = element_blank()
  )

rm(legend, all)

ggsave("../images/MODELS_ACCURACY.png", graph, units = "cm", width = 16, height = 10, limitsize = T)

rm(graph)


#' eigen
#'
#' Solve a system of equations or invert a float matrix.
#'
#' @param x
#' A float vector/matrix.
#' @param symmetric
#' Is the matrix symmetric? If not, it will be tested for symmetry with
#' \code{isSymmetric()}. Note that only symmetric matrices are supported at this
#' time.
#' @param only.values
#' Should only the values (and not the vectors) be returned?
#' @param EISPACK
#' Ignored.
#'
#' @return
#' A list containing the values and optionally vectors, each stored as floats.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' cp = crossprod(s)
#'
#' eigen(cp)
#'
#' @useDynLib float R_symeig_spm
#' @name eigen
#' @rdname eigen
NULL

eigen_float32 = function(x, symmetric, only.values=FALSE, EISPACK=FALSE)
{
  if (missing(symmetric))
    symmetric = isSymmetric(x)

  if (!isTRUE(symmetric))
    stop("only symmetric=TRUE is supported at this time")

  only.values = as.integer(only.values)
  ret = .Call(R_symeig_spm, DATA(x), only.values, TRUE)

  ret$values = float32(ret$values)
  if (!only.values)
    ret$vectors = float32(ret$vectors)

  class(ret) = "eigen"
  ret
}

#' @rdname eigen
#' @export
setMethod("eigen", signature(x="float32"), eigen_float32)


source('epimap/epiclean.r')

m = c(rep(.5,21*2)^2,1.3^seq(1,to=21),1.3^21*0.9^seq(1,to=21),rep(1.3^21*.9^21,21))
Count = rpois(21*5,m)
print(Count)

Tcond = 21
Nstep = 21*4
Tstep = 1
Nproj = 21

infprofile = read.csv('data/serial_interval.csv')$fit
Tip = 30
infprofile <- infprofile[1:Tip]
infprofile <- infprofile/sum(infprofile)

Tdp <- 21
presymptomdays <- 2
Tdpnz <- Tdp - presymptomdays
Adp <- 5.8
Bdp <- 0.948
testdelayprofile <- pgamma(1:Tdpnz,shape=Adp,rate=Bdp)
testdelayprofile <- testdelayprofile/testdelayprofile[Tdpnz]
testdelayprofile <- testdelayprofile - c(0.0,testdelayprofile[1:(Tdpnz-1)])
testdelayprofile <- c(rep(0, presymptomdays), testdelayprofile)

gp_time_scale = 14
gp_time_decay_scale = .5
num_iterations = 3000
fit = epiclean(
  Count = Count,
  Tcond = Tcond,
  Nstep = Nstep,
  Nproj = Nproj,
  Tstep = Tstep,
  infprofile = infprofile,
  testdelayprofile = testdelayprofile,
  gp_time_scale = gp_time_scale,
  gp_time_decay_scale = gp_time_decay_scale,
  num_iterations = num_iterations
)
print(summary(fit$stanfit,
  pars=c(
    "mu",
    "sigma",
    "alpha",
    "gp_time_length_scale",
    "phi_latent",
    "phi_observed",
    "xi",
    "Noutliers",
    "meandelay"),
  probs=c(.025,.5,.975)
)$summary)

print(fit$Rt[,c("2.5%","50%","97.5%")])


g <- prod(x)^(1/length(x))


d <- read.csv(file='…/ch.5/input/data-attendance-3.txt')
aggregate(Y ~ A, data=d, FUN=table)

#   A Y.0 Y.1
# 1 0 288 994
# 2 1 386 728


#' @title nodePosition
#' @description Computes the position of vertices along axes
#' @details Computes the position of vertices along axes based on some centrality algorithm such as \code{\link[igraph]{closeness}}
#' @aliases nodePosition
#' @export nodePosition
#' @author Jared P. Lander
#' @importFrom igraph closeness "V<-" V
#' @param graph An igraph object
#' @param func A function that returns a cluster membership for each node
#' @param \dots Further arguments for \code{func}
#' @return A graph with a new Vertex slot 'axis' that stores the cluster membership
#' @examples
#' data(flights)
#' library(igraph)
#' g <- graph.data.frame(flights, directed=TRUE)
#' g2 <- nodePosition(g)
#' V(g2)$nodePosition
#'
nodePosition <- function(graph, func=closeness, ...)
{
    V(graph)$nodePosition <- rank(func(graph, ...))

    return(graph)
}


context("Missing x values")

get.data.class <- function(n=800) {
  p = 4
  x = matrix(runif(n*p), n, p)
  f = function(x) (x[,1]>0.5) + (x[,2]>0.6) + (x[,3]>0.4)
  y = factor(f(x), levels=0:3)
  x[1, 1] = NA
  x[2, 2] = NA
  x[3, 3] = NA
  x[4, 4] = NA
  return(list(x=x, y=y))
}

train <- get.data.class(100)
test  <- get.data.class(101)

test_that("na.action='stop' gives error", {
  expect_error( extraTrees(train$x, train$y, ntree=50, na.action='stop'), regex="NA" )
})

test_that("na.action='zero' does not give error", {
  et   <- extraTrees(train$x, train$y, ntree=50, na.action='zero')
  yhat <- predict(et, test$x)
  expect_equal(et$xHasNA, FALSE)
})

test_that("na.action='fuse' enables fusing", {
  et   <- extraTrees(train$x, train$y, ntree=50, na.action='fuse')
  yhat <- predict(et, test$x)
  expect_equal(et$xHasNA, TRUE)
})


# Calculate score from genes x samples matrix as average z-score
get_score <- function(x) {
  x = t(scale(t(x)))
  return (colMeans(x, na.rm=T))
}


suppressPackageStartupMessages(library(okcpuid, quietly=TRUE))

suppressPackageStartupMessages(library(pbdMPI, quietly=TRUE))
if (interactive())
  comm.stop("This benchmark may not be run interactively.")

suppressPackageStartupMessages(library(pbdDMAT, quietly=TRUE))
init.grid()

N <- 4500
bldim <- 64

#  comm.set.seed(diff=TRUE)

if (length(bldim) == 1)
  bldim <- rep(bldim, 2)

A <- ddmatrix("rnorm", N, N)
B <- ddmatrix("rnorm", N, 1)

peak <- linpack(A=A, B=B)
comm.print(peak)

finalize()


#' pegasos
#'
#' Pegasos SVM solver.
#'
#' @description
#' If \code{intercept=TRUE}, the data is not literally modified to include a
#' column of ones.  However, this is conceptually what we do.
#'
#' @param x
#' The features matrix.
#' @param y
#' The 2-class response vector. Note that the groups must be +/- 1.
#' See \code{recode()}
#' @param intercept
#' Should the model include an intercept term?
#' @param k
#' TODO, currently ignored
#' @param lambda
#' Regularization parameter.
#' @param niter
#' The number of iterations.
#'
#' @return
#' An object of class pegasosSVM.
#'
#' @references
#' Shalev-Shwartz, Shai, et al. "Pegasos: Primal estimated sub-gradient solver
#' for svm." Mathematical programming 127.1 (2011): 3-30.
#'
#' @examples
#' \dontrun{
#' library(ssvm)
#'
#' y <- recode(iris$Species == "setosa")
#' x <- as.matrix(iris[, -5])
#'
#' pegasos(x, y)
#' }
#'
#' @author
#' Drew Schmidt
#'
#' @export
pegasos <- function(x, y, intercept=TRUE, k=5, lambda=.1, niter=1e5)
{
  check.is.flag(intercept)
  check.is.posint(k)
  check.is.scalar(lambda)
  check.is.posint(niter)

  if (!is.double(x))
    storage.mode(x) <- "double"
  if (!is.integer(y))
    storage.mode(y) <- "integer"

  w <- .Call(R_svm_pegasos_fit, intercept, as.integer(k), as.double(lambda), as.integer(niter), x, y)
  nm <- colnames(x)
  if (!is.null(nm))
  {
    if (intercept)
      nm <- c("Intercept", nm)

    names(w) <- nm
  }

  svm <- list(w=w, niter=niter, intercept=intercept)
  class(svm) <- "pegasosSVM"

  svm
}

#' @export
print.pegasosSVM <- function(x, ...)
{
  cat(paste0("SVM model (Method=Pegasos, Iterations=", x$niter, ")\n"))
  print(x$w)
}

#' @export
predict.pegasosSVM <- function(object, newdata, ...)
{
  .Call(R_svm_pegasos_pred, newdata, object$w, object$intercept)
}


R --vanilla

if (!requireNamespace("data.table")) install.packages("data.table")
if (!requireNamespace("mobr")) install.packages("mobr")

library(data.table)
library(mobr)

## home function
# iNEXT coverage
Chat.Ind <- function(x, m){
  x <- x[x>0]
  n <- sum(x)
  f1 <- sum(x == 1)
  f2 <- sum(x == 2)
  f0.hat <- ifelse(f2 == 0, (n - 1) / n * f1 * (f1 - 1) / 2, (n - 1) / n * f1 ^ 2/ 2 / f2)  #estimation of unseen species via Chao1
  A <- ifelse(f1>0, n*f0.hat/(n*f0.hat+f1), 1)
  Sub <- function(m){
    #if(m < n) out <- 1-sum(x / n * exp(lchoose(n - x, m)-lchoose(n - 1, m)))
    if(m < n) {
      xx <- x[(n-x)>=m]
      out <- 1-sum(xx / n * exp(lgamma(n-xx+1)-lgamma(n-xx-m+1)-lgamma(n)+lgamma(n-m)))
    }
    if(m == n) out <- 1-f1/n*A
    if(m > n) out <- 1-f1/n*A^(m-n+1)
    out
  }
  sapply(m, Sub)
}

smpl_space_y <- function(j, a, max_effort, samp_method){
                  x <- data.table(reshape2::dcast(a[year == j, .N, by = .(parcel_id, crop_name)], parcel_id ~ crop_name, fun.agg = function(x) sum(x), value.var = "N"))
                  y_rar <- as.numeric(rarefaction(as.matrix(x[, safety := 0][, -c("parcel_id")]), method = samp_method, effort = c(1:max_effort), extrapolate = TRUE, quiet_mode = TRUE))
              }

smpl_time_y <- function(j, a, max_effort, samp_method){
                  x <- data.table(reshape2::dcast(a[parcel_id == j, .N, by = .(year, crop_name)], year ~ crop_name, fun.agg = function(x) sum(x), value.var = "N"))
                  f_rar <- as.numeric(rarefaction(as.matrix(x[, safety := 0][, -c("year")]), method = samp_method, effort = c(1:max_effort), extrapolate = TRUE, quiet_mode = TRUE))
              }

cov_time_y <- function(j, a, max_effort){
                    x <- data.table(reshape2::dcast(a[parcel_id == j, .N, by = .(year, crop_name)], year ~ crop_name, fun.agg = function(x) sum(x), value.var = "N"))
                    f_rar <- as.numeric(Chat.Ind(colSums(as.matrix(x[, safety := 0][, -c("year")])), c(1:max_effort)))
              }

trans.matrix <- function(X, prob=T){
              tt <- table( c(X[,-ncol(X)]), c(X[,-1]) )
              if(prob) tt <- tt / rowSums(tt)
              tt
            }

## Scenarios (6)
## =============
## MONOCULTURE -space and time
## MONOCULTURE -time but diverse in space
## Synchronized rotation - Temporal synchrony
## Asynchrony in rotation
## Diverse rotations but synchronized
## Diverse rotation and asynchony

mono <- data.table(parcel_id = c(rep(c(1,2,3,4), each = 4)),
            year = c(rep(c(1,2,3,4),c(4))),
            crop_name = c(rep("a", 16)))

mono_div <- data.table(parcel_id = c(rep(c(1,2,3,4), each = 4)),
            year = c(rep(c(1,2,3,4),c(4))),
            crop_name = c(rep(c("a", "a", "b", "c"), each = 4)))

rot_sync <- data.table(parcel_id = c(rep(c(1,2,3,4), each = 4)),
            year = c(rep(c(1,2,3,4),c(4))),
            crop_name = c("a", "a", "b", "c",
                          "a", "a", "b", "c",
                          "a", "a", "b", "c",
                          "a", "a", "b", "c"))

rot_desync <- data.table(parcel_id = c(rep(c(1,2,3,4), each = 4)),
            year = c(rep(c(1,2,3,4),c(4))),
            crop_name = c("a", "a", "b", "c",
                          "c", "a", "a", "b",
                          "b", "c", "a", "a",
                          "a", "b", "c", "a"))

div_rot_sync <- data.table(parcel_id = c(rep(c(1,2,3,4), each = 4)),
            year = c(rep(c(1,2,3,4),c(4))),
            crop_name = c("a", "a", "b", "c",
                          "e", "e", "f", "g",
                          "a", "a", "b", "c",
                          "e", "e", "f", "g"))

div_rot_desync <- data.table(parcel_id = c(rep(c(1,2,3,4), each = 4)),
            year = c(rep(c(1,2,3,4),c(4))),
            crop_name = c("a", "a", "b", "c",
                          "g", "e", "e", "f",
                          "b", "c", "a", "a",
                          "f", "g", "e", "e"))

pdf_name <- c("mono.pdf",               ## MONOCULTURE -space and time
              "mono_div.pdf",           ## MONOCULTURE -time but diverse in space
              "rot_sync.pdf",           ## Synchronized rotation - Temporal synchrony
              "rot_desync.pdf",         ## Asynchrony in rotation
              "div_rot_sync.pdf",       ## Diverse rotations but synchronized
              "div_rot_desync.pdf")     ## Diverse rotation and asynchony

scenario_data <- list(mono, mono_div, rot_sync, rot_desync, div_rot_sync, div_rot_desync)

max_effort <- 16

for(i in seq_along(pdf_name)){

  a_t <- scenario_data[[i]]

  x <- data.table(reshape2::dcast(a_t[, .N, by = .(parcel_id, crop_name)], parcel_id ~ crop_name, fun.agg = function(x) sum(x), value.var = "N"))

  land_div <- as.numeric(rarefaction(as.matrix(x[, safety := 0][, -c("parcel_id")]),
                                      method = 'IBR',
                                      effort = c(1 : max_effort, seq(from = 2*max_effort, to = max_effort^2, by = max_effort)),
                                      extrapolate = TRUE,
                                      quiet_mode = TRUE))

  spce_div <- rowMeans(sapply(1:4, FUN = smpl_space_y, a = a_t, samp_method = 'IBR', max_effort = max_effort))
  time_div <- rowMeans(sapply(1:4, FUN = smpl_time_y, a = a_t, samp_method = 'IBR', max_effort = max_effort))

pdf(paste0("output/scenarios/",pdf_name[i]))
  plot(land_div[1:20], type = 'l', ylim = c(0, 10))
  points(spce_div[1:8], pch= 19)
  points(spce_div[1:20], type = 'l', lty = 2)
  points(time_div[1:8], pch = 22)
  points(time_div[1:20], type = 'l', lty = 3)
dev.off()

}


#!/usr/bin/env Rscript

data <- read.table("gasdisk.txt", head=TRUE)
trmodel <- read.table("trcurve.txt", head=TRUE)

rc <- splinefun(trmodel$r, trmodel$v)
theta <- seq(0,2*pi, length.out=10000)

cross <- function(a, b) {
	return (c( a[2]*b[3]-a[3]*b[2] , a[3]*b[1]-a[1]*b[3] , a[1]*b[2]-a[2]*b[1] ))
}

dotprod <- function(a,b) {
  return ( a[1]*b[1] + a[2]*b[2] + a[3]*b[3] )
}

lhat <- c(-0.137364,0.332812,0.932935)
slit0 <- c(-0.000159857,0.00147301,0.000698394)
slit90 <- c(0.00197305,-0.000506444,-0.00141966)
i <- cross(lhat, c(1,0,0))
j <- cross(lhat, i)
slitpos0 <- c(dotprod(slit0, i), dotprod(slit0, j))
slitpos90 <- c(dotprod(slit90, i), dotprod(slit90, j))

slitpos0 <- 10 * slitpos0/sqrt(sum(slitpos0^2))
slitpos90 <- 10 * slitpos90/sqrt(sum(slitpos90^2))

pdf("velmap.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
vtot <- sqrt(data$vx^2 + data$vy^2)
vscale <- 1e-3 * max(vtot)/50
radius <- sqrt(data$x^2 + data$y^2)*1e-3
n <- which(vtot>rc(radius))
m <- which(vtot<rc(radius))
segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col="red")
segments(data$x[m], data$y[m], data$x[m]+data$vx[m]*vscale, data$y[m]+data$vy[m]*vscale, col="blue")
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
segments(-slitpos0[1], -slitpos0[2], slitpos0[1], slitpos0[2], lty=2)
segments(-slitpos90[1], -slitpos90[2], slitpos90[1], slitpos90[2], lty=2)
dev.off()

pdf("radmotion.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
vr <- abs(data$x*data$vx + data$y*data$vy)/sqrt(data$x^2 + data$y^2)
for (ratio in seq(0,0.9,by=0.1)) {
	n <- intersect(which(vr/vtot > ratio), which(vr/vtot < ratio+0.1))
	segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col=rgb(ratio,0,1-ratio^0.5))
}
n <- which(vr/vtot > 1)
segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col="red")
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

pdf("lzmap.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
Lz <- data$x*data$vy - data$y*data$vx
for (i in seq(10,1000, by=10)) {
	n <- intersect(which(Lz<i), which(Lz>i-100))
	segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col=rgb(i/1e3,0,1-i/1e3))
}
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

pdf("philz.pdf")
phi <- atan2(data$x, data$y)
m <- intersect(which(radius<2.6e-3),which(radius>2.5e-3))
m <- m[order(phi[m])]
plot(phi[m], Lz[m], cex=0.1, ylim=c(0,4e-3), type="l")
dL <- 500
for (L in seq(dL,2000,by=dL)) {
	m <- intersect(which(Lz<L+dL),which(Lz>L))
	m <- m[order(phi[m])]
	if (length(m)>0) { lines(phi[m], radius[m]) }
}

n <- which(radius<4e-3)
coldmass <- sum(data$m[n])
data <- read.table("hotdisk.txt", head=TRUE)
radius <- sqrt(data$x^2 + data$y^2)*1e-3
n <- which(radius<4e-3)
hotmass <- sum(data$m[n])
dev.off()

pdf("fullvelmap.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
vtot <- sqrt(data$vx^2 + data$vy^2)
n <- which(vtot>rc(radius))
m <- which(vtot<rc(radius))
segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col="red")
segments(data$x[m], data$y[m], data$x[m]+data$vx[m]*vscale, data$y[m]+data$vy[m]*vscale, col="blue")
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

pdf("fullradmotion.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
vr <- abs(data$x*data$vx + data$y*data$vy)/sqrt(data$x^2 + data$y^2)
for (ratio in seq(0,0.9,by=0.1)) {
	n <- intersect(which(vr/vtot > ratio), which(vr/vtot < ratio+0.1))
	segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col=rgb(ratio,0,1-ratio^0.5))
}
n <- which(vr/vtot > 1)
segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col="red")
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

pdf("fulllzmap.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
Lz <- data$x*data$vy - data$y*data$vx
for (i in seq(10,1000, by=10)) {
	n <- intersect(which(Lz<i), which(Lz>i-100))
	segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col=rgb(i/1e3,0,1-i/1e3))
}
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

data <- read.table("stellardisk.txt", head=TRUE)
radius <- sqrt(data$x^2 + data$y^2)*1e-3
n <- which(radius<4e-3)
starmass <- sum(data$m[n])
n <- sample(seq(length(data$x)), min(c(50000,length(data$m))))
data <- data[n,]

pdf("starvelmap.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
vtot <- sqrt(data$vx^2 + data$vy^2)
radius <- sqrt(data$x^2 + data$y^2)*1e-3
n <- which(vtot>rc(radius))
m <- which(vtot<rc(radius))
segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col="red")
segments(data$x[m], data$y[m], data$x[m]+data$vx[m]*vscale, data$y[m]+data$vy[m]*vscale, col="blue")
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

pdf("starradmotion.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
vr <- abs(data$x*data$vx + data$y*data$vy)/sqrt(data$x^2 + data$y^2)
for (ratio in seq(0,0.9,by=0.1)) {
	n <- intersect(which(vr/vtot > ratio), which(vr/vtot < ratio+0.1))
	segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col=rgb(ratio,0,1-ratio^0.5))
}
n <- which(vr/vtot > 1)
segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col="red")
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

pdf("starlzmap.pdf")
plot(data$x, data$y, cex=0.1, xlim=c(-5,5), ylim=c(-5,5), xlab="x[kpc]", ylab="y[kpc]")
Lz <- data$x*data$vy - data$y*data$vx
for (i in seq(10,1000, by=10)) {
	n <- intersect(which(Lz<i), which(Lz>i-100))
	#segments(data$x[n], data$y[n], data$x[n]+data$vx[n]*vscale, data$y[n]+data$vy[n]*vscale, col=rgb(i/1e3,0,1-i/1e3))
	points(data$x[n], data$y[n], col=rgb(i/1e3,0,1-i/1e3), cex=0.2, pch=19)
}
lines(3*cos(theta), 3*sin(theta), lty=3, col="green", lwd=3)
points(0,0, pch=16)
dev.off()

hotmass <- hotmass-coldmass
totmass <- coldmass+hotmass+starmass
print(coldmass/totmass)
print(hotmass/totmass)
print(starmass/totmass)


library(hdfmat)
set.seed(1234)

f = tempfile()
n = "mydata"
type = "double"

nr = 3
nc = 10
x = matrix(1:(nr*nc), nr, nc)
storage.mode(x) = type

h = crossprod_ooc(x, f, name=n)
test = h$eigen(k=3)

truth = c(9450.2858568857428, 4.714143114255676, 5.0978833483225391e-13)

tol = 1e-6
stopifnot(all.equal(test, truth, tol))

h$close()
unlink(f)


# Load necessary packages
library(tidyverse)
library(readr)

# Load the data
responses <- read_csv("datasets/kagglesurvey.csv")

# Print the first 10 rows
head(responses, 10)
str(responses)

# Print the first respondent's tools and languages
responses[1,2]

# Add a new column, and unnest the new column
tools <- responses  %>%
    mutate(work_tools = str_split(WorkToolsSelect, ","))  %>%
    unnest(work_tools)

# View the first 6 rows of tools
head(tools)

# Group the data by work_tools, summarise the counts, and arrange in descending order
tool_count <- tools  %>%
    group_by(work_tools)  %>%
    summarise(tool_count = n()) %>%
    arrange(desc(tool_count))

# Print the first 6 results
head(tool_count)

# Create a bar chart of the work_tools column, most counts on the far right
# stat = "identity" means that the height of bar is the value of variable values instead of count of variables
ggplot(tool_count, aes(x = reorder(work_tools, tool_count), y = tool_count)) +
    geom_bar(stat = "identity") +
    theme(axis.text.x = element_text(angle = 90, vjust = .5, hjust = 1))

# Create a new column called language preference
debate_tools <- responses  %>%
   mutate(language_preference = case_when(
       str_detect(WorkToolsSelect, "R") & !str_detect(WorkToolsSelect, "Python") ~ "R",
       str_detect(WorkToolsSelect, "Python") & !str_detect(WorkToolsSelect, "R") ~ "Python",
       str_detect(WorkToolsSelect, "R") & str_detect(WorkToolsSelect, "Python") ~ "both",
       TRUE ~ "neither"
   ))

# Print the first 6 rows
head(debate_tools, 6)

debate_tools %>%
  group_by(language_preference) %>%
  summarize(count = n())

debate_tools_counts <- debate_tools %>%
    count(language_preference)

# Group by language preference, calculate number of responses, and remove "neither"
debate_plot <- debate_tools  %>%
   group_by(language_preference)  %>%
   summarize(n = n())  %>%
   filter(language_preference != "neither")

# Create a bar chart
ggplot(debate_plot, aes(x = fct_reorder(language_preference, n), y = n)) +
  geom_bar(stat = "identity") +
  theme(axis.text.x = element_text(angle = 90))

# Group by, summarise, arrange, mutate, and filter
recommendations <- debate_tools  %>%
    group_by(language_preference, LanguageRecommendationSelect)  %>%
    summarise(count = n())  %>%
    arrange(language_preference, desc(count))  %>%
    mutate(row = row_number()) %>%
    filter(row <= 4)

# Create a faceted bar plot
str(recommendations)
ggplot(recommendations, aes(x = LanguageRecommendationSelect, y = count)) +
    geom_bar(stat = "identity") +
    facet_wrap(~language_preference)

# Would R users find this statement TRUE or FALSE?
R_is_number_one = TRUE

02. Exploring the Kaggle Data Science Survey.r


 ZGECON Example Program Results

 Estimate of condition number =  1.50E+02


# import data

wd = "D:/Ruo_data/2019_Paper_Publish/Publish"
setwd(wd)

sp_TL.result <- read.csv("./SizeAggregTend_data/output/1_size_TL/all_TL_result_16_compiled.csv",stringsAsFactors = F,sep=",",header = T)
sp_TL.result$spwn <- as.factor(sp_TL.result$spwn)
sp_TL.result$quarter <- as.factor(sp_TL.result$quarter)
sp_TL.result$sp_ID <- as.factor(sp_TL.result$sp_ID)
sp_TL.result$mat_stage <- as.factor(sp_TL.result$mat_stage)

########################################################################
### Relationship fitted with considering spawning effect ###############
########################################################################

library("mgcv")
library("itsadug")

## GAMM result with Spawn by REML
fit.SPWN.tempCV.smooth.inter.Rslt <- gam(b~spwn+
                                    ti(std_T_cv,by=spwn,bs="ts")+
                                    ti(std_L,by=spwn,bs="ts")+
                                    ti(std_L,std_T_cv,by=spwn,bs="ts")+
                                    s(std_L,sp_ID,bs="re",by=dum)+s(sp_ID,bs="re",by=dum),
                                  data = sp_TL.result,
                                  method = "REML",
                                  family = Gamma(link = log)
                                  #select = F
)

summary(fit.SPWN.tempCV.smooth.inter.Rslt)

##################################################
# Bootstrapping

TL_BSdata <- read.csv("./SizeAggregTend_data/output/1_size_TL/resample_TL_bs_data.csv")
TL_BSdata <- TL_BSdata[,-1]

# bootstrap 999 times for model fitting and prediction
bs_fit_para_summary <- NULL
bs_fit_smth_summary <- data.frame(temp_cv_N=NA,temp_cv_Y=NA,
                                  size_N=NA,size_Y=NA,
                                  inter_N=NA,inter_Y=NA,
                                  re_slope=NA,re_intercept=NA)

bs_spawn_diff <- NULL
bs_pred_result_Y <- NULL
bs_pred_result_Y_temp <- NULL
bs_pred_result_N <- NULL
bs_pred_result_N_temp <- NULL

newdat <- expand.grid(std_L = seq(-0.69,0.75,length=200),
                        std_T_cv = 0,
                        spwn = c("Y","N"),
                        sp_ID = factor(c(1:9)),
                        dum=0)
newdat_Y <- expand.grid(std_L = seq(-0.69,0.75,length=200),
                        std_T_cv = 0,
                         spwn = c("Y"),
                         sp_ID = factor(c(1:9)),
                         dum=0)
newdat_N <- expand.grid(std_L = seq(-0.69,0.75,length=200),
                        std_T_cv = 0,
                         spwn = c("N"),
                         sp_ID = factor(c(1:9)),
                         dum=0)
newdat_Y_temp <- expand.grid(std_T_cv = seq(-0.80,0.92,length=200),
                                std_L = 0,
                                spwn = c("Y"),
                                sp_ID = factor(c(1:9)),
                                dum=0)
newdat_N_temp <- expand.grid(std_T_cv = seq(-0.80,0.92,length=200),
                             std_L = 0,
                             spwn = c("N"),
                             sp_ID = factor(c(1:9)),
                             dum=0)

for (bs in 1:999){
  bs_TL_result <- cbind(TL_BSdata[,bs],sp_TL.result[,9:20])
  colnames(bs_TL_result)[1] <- "b"
  bs_fit <- gam(b~spwn+
                  ti(std_T_cv,by=spwn,bs="ts")+
                  ti(std_L,by=spwn,bs="ts")+
                  ti(std_L,std_T_cv,by=spwn,bs="ts")+
                  s(std_L,sp_ID,bs="re",by=dum)+s(sp_ID,bs="re",by=dum),
                data = bs_TL_result,
                method = "REML",
                family = Gamma(link = log)
  )
  bs_fit_summary <- summary(bs_fit)
  bs_fit_para_summary = rbind(bs_fit_para_summary,bs_fit_summary$p.table[2,])
  bs_fit_smth_summary = rbind(bs_fit_smth_summary,bs_fit_summary$s.table[,4])

  # spawn different
  bs_pred_b <- predict(bs_fit, newdata = newdat, type="lpmatrix")
  c1 <- grepl('Y', colnames(bs_pred_b))
  c3 <- grepl('N', colnames(bs_pred_b))
  r1 <- with(newdat, spwn == 'Y')
  r3 <- with(newdat, spwn == 'N')
  X <- bs_pred_b[r1, ] - bs_pred_b[r3, ]
  X[, ! (c1 | c3)] <- 0
  X[, !grepl('^ti\\(', colnames(bs_pred_b))] <- 0
  spawn_diff <- X %*% coef(bs_fit)
  spawn_diff <- tapply(spawn_diff,newdat_Y$std_L,mean)
  bs_spawn_diff <- cbind(bs_spawn_diff,spawn_diff)

  # Spawn season prediction
  bs_size_pred_b_Y <- tapply(predict(bs_fit, newdata = newdat_Y, type="response"),newdat_Y$std_L,mean)
  bs_pred_result_Y <- cbind(bs_pred_result_Y,bs_size_pred_b_Y)

  bs_temp_pred_b_Y <- tapply(predict(bs_fit, newdata = newdat_Y_temp, type="response"),newdat_Y_temp$std_T,mean)
  bs_pred_result_Y_temp <- cbind(bs_pred_result_Y_temp,bs_temp_pred_b_Y)

  # Rest season prediction
  bs_size_pred_b_N <- tapply(predict(bs_fit, newdata = newdat_N, type="response"),newdat_N$std_L,mean)
  bs_pred_result_N <- cbind(bs_pred_result_N,bs_size_pred_b_N)

  bs_temp_pred_b_N <- tapply(predict(bs_fit, newdata = newdat_N_temp, type="response"),newdat_N_temp$std_T,mean)
  bs_pred_result_N_temp <- cbind(bs_pred_result_N_temp,bs_temp_pred_b_N)

  if(bs%%50==0){print(bs)}
}

bs_fit_smth_summary <- bs_fit_smth_summary[-1,]
write.csv(bs_fit_para_summary,"./SizeAggregTend_data/output/2_spwan_effect/SPWN_bs_fit_para_summary.csv")
write.csv(bs_fit_smth_summary,"./SizeAggregTend_data/output/2_spwan_effect/SPWN_bs_fit_smooth_summary.csv")

write.csv(bs_spawn_diff,"./SizeAggregTend_data/output/2_spwan_effect/bs_fit_spawn_diff.csv")
write.csv(bs_pred_result_Y,"./SizeAggregTend_data/output/2_spwan_effect/bs_fit_predicted_data_Y.csv")
write.csv(bs_pred_result_N,"./SizeAggregTend_data/output/2_spwan_effect/bs_fit_predicted_data_N.csv")
write.csv(bs_pred_result_Y_temp,"./SizeAggregTend_data/output/2_spwan_effect/bs_fit_predicted_data_Y_temp.csv")
write.csv(bs_pred_result_N_temp,"./SizeAggregTend_data/output/2_spwan_effect/bs_fit_predicted_data_N_temp.csv")

# original model prediction
# spawn different
pred_b <- predict(fit.SPWN.tempCV.smooth.inter.Rslt, newdata = newdat, type="lpmatrix")
c1 <- grepl('Y', colnames(pred_b))
c3 <- grepl('N', colnames(pred_b))
r1 <- with(newdat, spwn == 'Y')
r3 <- with(newdat, spwn == 'N')
X <- pred_b[r1, ] - pred_b[r3, ]
X[, ! (c1 | c3)] <- 0
X[, !grepl('^ti\\(', colnames(pred_b))] <- 0
spawn_diff <- X %*% coef(fit.SPWN.tempCV.smooth.inter.Rslt)
spawn_diff <- tapply(spawn_diff,newdat_Y$std_L,mean)

pred_b_Y <- tapply(predict(fit.SPWN.tempCV.smooth.inter.Rslt, newdata = newdat_Y, type="response"),
                   newdat_Y$std_L,mean)
pred_b_N <- tapply(predict(fit.SPWN.tempCV.smooth.inter.Rslt, newdata = newdat_N, type="response"),
                   newdat_N$std_L,mean)
pred_b_Y_temp <- tapply(predict(fit.SPWN.tempCV.smooth.inter.Rslt, newdata = newdat_Y_temp, type="response"),
                        newdat_Y_temp$std_T,mean)
pred_b_N_temp <- tapply(predict(fit.SPWN.tempCV.smooth.inter.Rslt, newdata = newdat_N_temp, type="response"),
                        newdat_N_temp$std_T,mean)

bs_spawn_diff <- cbind(bs_spawn_diff[,-1],spawn_diff)
bs_pred_result_Y <- cbind(bs_pred_result_Y[,-1],pred_b_Y)
bs_pred_result_N <- cbind(bs_pred_result_N[,-1],pred_b_N)
bs_pred_result_Y_temp <- cbind(bs_pred_result_Y_temp[,-1],pred_b_Y_temp)
bs_pred_result_N_temp <- cbind(bs_pred_result_N_temp[,-1],pred_b_N_temp)

library("coxed")
bca_SPWNdiff_95CI <- apply(bs_spawn_diff,1,bca)
size_Y_95CI = apply(bs_pred_result_Y,1,bca)
size_N_95CI = apply(bs_pred_result_N,1,bca)
temp_Y_95CI = apply(bs_pred_result_Y_temp,1,bca)
temp_N_95CI = apply(bs_pred_result_N_temp,1,bca)

# peak location
Max_b_Y <- apply(bs_pred_result_Y,2,max)
peak_locat_order_Y <- apply(bs_pred_result_Y,2,function(x)which(x==max(x)))
peak_locat_Y <- seq(-0.69,0.75,length=200)[peak_locat_order_Y]
bca(peak_locat_Y)
peak_locat_Y[length(peak_locat_Y)]

Max_b_N <- apply(bs_pred_result_N,2,max)
peak_locat_order_N <- apply(bs_pred_result_N,2,function(x)which(x==max(x)))
peak_locat_N <- seq(-0.69,0.75,length=200)[peak_locat_order_N]
bca(peak_locat_N)
peak_locat_N[length(peak_locat_N)]

#######################################################
### Plot difference between spawning and resting season
jpeg(".SizeAggregTend_data/output/fig/Appendix/Fig_spwan_size_diff.jpeg", width=6, height=5, units = "in",res=600)

plot(unique(newdat$std_L),bs_spawn_diff[,1000],
     type="l",xlim = c(-0.7,0.8),ylim=c(-0.15,0.2),
     xlab="Standardized length",ylab="Difference between spawning and resting season",family=c("newrom"),bty="l")
polygon(c(rev(unique(newdat$std_L)), unique(newdat$std_L)),
        c(rev(bca_SPWNdiff_95CI[2,]), bca_SPWNdiff_95CI[1,]),
        col = rgb(50, 50, 50, 40, maxColorValue=255), border = NA)
abline(h=0)
abline(v=range(as.numeric(colnames(bca_SPWNdiff_95CI)[which(bca_SPWNdiff_95CI[1,]>0)])),lty=2)
abline(v=range(as.numeric(colnames(bca_SPWNdiff_95CI)[which(bca_SPWNdiff_95CI[2,]<0)])),lty=2)

dev.off()


#' @title findCurvature
#' @description generally preferable to using first differences of raw data,  because differencing raw data amplifies noise, while appropriate smooths eliminate much of the noise, leaving you with what you most want. Ramsay and Silverman (2005) Functional Data Analysis, 2nd ed. (Springer) suggest that if you want a second derivative, it is often wise to use quintic splines, because then the second derivative are cubic splines. (The first derivative of a spline of order k is a spline of order k-1.)
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
findCurvature = function (x, y, eps = 0.02) {
#

       print('aka second derivative via splines--not done')

        sp <- loess( y~x ,degree=5)
        xl = data.frame(x = seq(min(x),max(x),by=eps))
        yl = predict(sp,newdata.xl)

        yp = diff(yl)/diff(xl)
        dd1 <- loess(xp, yp,degree =4 )

    D1 <- predict(sp, x, deriv = 1)$y

        sp <- smooth.spline(x, D1)
        sp <- smooth.spline(x, D1, spar = offset + sp$spar)
        x <- sort(x)
    list(x = x, y = predict(sp, x, deriv = 1)$y)
}